0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 0a 28 uses server))..(
02b0: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
02c0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
02d0: 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f nclude "key_reco
02e0: 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 rds.scm").(inclu
02f0: 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 de "db_records.s
0300: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 cm").(include "r
0310: 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 un_records.scm")
0320: 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f .(include "test_
0330: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b records.scm")..;
0340: 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d ; runs:get-runs-
0350: 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 72 by-patt.;; get r
0360: 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 63 uns by list of c
0370: 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 73 riteria.;; regis
0380: 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 ter a test run w
0390: 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b 3b ith the db.;;.;;
03a0: 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 61 Use: (db-get-va
03b0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 64 lue-by-header (d
03c0: 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 6e b:get-header run
03d0: 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f 77 info)(db:get-row
03e0: 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 20 74 runinfo)).;; t
03f0: 6f 20 65 78 74 72 61 63 74 20 69 6e 66 6f 20 66 o extract info f
0400: 72 6f 6d 20 74 68 65 20 73 74 72 75 63 74 75 72 rom the structur
0410: 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a 28 64 e returned.;;.(d
0420: 65 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d efine (runs:get-
0430: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
0440: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
0450: 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 29 0a ) ;; test-name).
0460: 20 20 28 6c 65 74 2a 20 28 28 74 6d 70 20 20 20 (let* ((tmp
0470: 20 20 20 28 72 75 6e 73 3a 67 65 74 2d 73 74 64 (runs:get-std
0480: 2d 72 75 6e 2d 66 69 65 6c 64 73 20 6b 65 79 73 -run-fields keys
0490: 20 27 28 22 69 64 22 20 22 72 75 6e 6e 61 6d 65 '("id" "runname
04a0: 22 20 22 73 74 61 74 65 22 20 22 73 74 61 74 75 " "state" "statu
04b0: 73 22 20 22 6f 77 6e 65 72 22 20 22 65 76 65 6e s" "owner" "even
04c0: 74 5f 74 69 6d 65 22 29 29 29 0a 09 20 28 6b 65 t_time"))).. (ke
04d0: 79 73 74 72 20 20 20 28 63 61 72 20 74 6d 70 29 ystr (car tmp)
04e0: 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 28 63 ).. (header (c
04f0: 61 64 72 20 74 6d 70 29 29 0a 09 20 28 72 65 73 adr tmp)).. (res
0500: 20 20 20 20 20 27 28 29 29 0a 09 20 28 6b 65 79 '()).. (key
0510: 2d 70 61 74 74 20 22 22 29 0a 09 20 28 72 75 6e -patt "").. (run
0520: 77 69 6c 64 74 79 70 65 20 28 69 66 20 28 73 75 wildtype (if (su
0530: 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 25 bstring-index "%
0540: 22 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 20 22 " runnamepatt) "
0550: 6c 69 6b 65 22 20 22 67 6c 6f 62 22 29 29 0a 09 like" "glob"))..
0560: 20 28 71 72 79 2d 73 74 72 20 20 23 66 29 29 0a (qry-str #f)).
0570: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
0580: 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 ambda (keyval)..
0590: 09 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 .(let* ((key
05a0: 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 65 79 76 (vector-ref keyv
05b0: 61 6c 20 30 29 29 0a 09 09 20 20 20 20 20 20 20 al 0))...
05c0: 28 66 75 6c 6b 65 79 20 28 63 6f 6e 63 20 22 3a (fulkey (conc ":
05d0: 22 20 6b 65 79 29 29 0a 09 09 20 20 20 20 20 20 " key))...
05e0: 20 28 70 61 74 74 20 20 20 28 61 72 67 73 3a 67 (patt (args:g
05f0: 65 74 2d 61 72 67 20 66 75 6c 6b 65 79 29 29 0a et-arg fulkey)).
0600: 09 09 20 20 20 20 20 20 20 28 77 69 6c 64 74 79 .. (wildty
0610: 70 65 20 28 69 66 20 28 73 75 62 73 74 72 69 6e pe (if (substrin
0620: 67 2d 69 6e 64 65 78 20 22 25 22 20 70 61 74 74 g-index "%" patt
0630: 29 20 22 6c 69 6b 65 22 20 22 67 6c 6f 62 22 29 ) "like" "glob")
0640: 29 29 0a 09 09 20 20 28 69 66 20 70 61 74 74 0a ))... (if patt.
0650: 09 09 20 20 20 20 20 20 28 73 65 74 21 20 6b 65 .. (set! ke
0660: 79 2d 70 61 74 74 20 28 63 6f 6e 63 20 6b 65 79 y-patt (conc key
0670: 2d 70 61 74 74 20 22 20 41 4e 44 20 22 20 6b 65 -patt " AND " ke
0680: 79 20 22 20 22 20 77 69 6c 64 74 79 70 65 20 22 y " " wildtype "
0690: 20 27 22 20 70 61 74 74 20 22 27 22 29 29 0a 09 '" patt "'"))..
06a0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
06b0: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
06c0: 22 45 52 52 4f 52 3a 20 73 65 61 72 63 68 69 6e "ERROR: searchin
06d0: 67 20 66 6f 72 20 72 75 6e 73 20 77 69 74 68 20 g for runs with
06e0: 6e 6f 20 70 61 74 74 65 72 6e 20 73 65 74 20 66 no pattern set f
06f0: 6f 72 20 22 20 66 75 6c 6b 65 79 29 0a 09 09 09 or " fulkey)....
0700: 28 65 78 69 74 20 36 29 29 29 29 29 0a 09 20 20 (exit 6)))))..
0710: 20 20 20 20 6b 65 79 73 29 0a 20 20 20 20 28 73 keys). (s
0720: 65 74 21 20 71 72 79 2d 73 74 72 20 28 63 6f 6e et! qry-str (con
0730: 63 20 22 53 45 4c 45 43 54 20 22 20 6b 65 79 73 c "SELECT " keys
0740: 74 72 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 tr " FROM runs W
0750: 48 45 52 45 20 72 75 6e 6e 61 6d 65 20 22 20 72 HERE runname " r
0760: 75 6e 77 69 6c 64 74 79 70 65 20 22 20 3f 20 22 unwildtype " ? "
0770: 20 6b 65 79 2d 70 61 74 74 20 22 3b 22 29 29 0a key-patt ";")).
0780: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
0790: 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 67 65 -info 4 "runs:ge
07a0: 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 71 t-runs-by-patt q
07b0: 72 79 3d 22 20 71 72 79 2d 73 74 72 20 22 20 22 ry=" qry-str " "
07c0: 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 0a 20 20 runnamepatt).
07d0: 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 (sqlite3:for-e
07e0: 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 28 6c ach-row . (l
07f0: 61 6d 62 64 61 20 28 61 20 2e 20 72 29 0a 20 20 ambda (a . r).
0800: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 (set! res (
0810: 63 6f 6e 73 20 28 6c 69 73 74 2d 3e 76 65 63 74 cons (list->vect
0820: 6f 72 20 28 63 6f 6e 73 20 61 20 72 29 29 20 72 or (cons a r)) r
0830: 65 73 29 29 29 0a 20 20 20 20 20 64 62 20 0a 20 es))). db .
0840: 20 20 20 20 71 72 79 2d 73 74 72 0a 20 20 20 20 qry-str.
0850: 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 0a 20 20 runnamepatt).
0860: 20 20 28 76 65 63 74 6f 72 20 68 65 61 64 65 72 (vector header
0870: 20 72 65 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 res)))..(define
0880: 20 28 72 75 6e 73 3a 74 65 73 74 2d 67 65 74 2d (runs:test-get-
0890: 66 75 6c 6c 2d 70 61 74 68 20 74 65 73 74 29 0a full-path test).
08a0: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 (let* ((testna
08b0: 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d me (db:test-get-
08c0: 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 74 29 testname test)
08d0: 29 0a 09 20 28 69 74 65 6d 70 61 74 68 20 28 64 ).. (itempath (d
08e0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
08f0: 70 61 74 68 20 74 65 73 74 29 29 29 0a 20 20 20 path test))).
0900: 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 (conc testname
0910: 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d (if (equal? item
0920: 70 61 74 68 20 22 22 29 20 22 22 20 28 63 6f 6e path "") "" (con
0930: 63 20 22 28 22 20 69 74 65 6d 70 61 74 68 20 22 c "(" itempath "
0940: 29 22 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )")))))..(define
0950: 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 (set-megatest-e
0960: 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 23 nv-vars run-id #
0970: 21 6b 65 79 20 28 69 6e 6b 65 79 73 20 23 66 29 !key (inkeys #f)
0980: 28 69 6e 72 75 6e 6e 61 6d 65 20 23 66 29 29 0a (inrunname #f)).
0990: 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 28 69 (let ((keys (i
09a0: 66 20 69 6e 6b 65 79 73 20 69 6e 6b 65 79 73 20 f inkeys inkeys
09b0: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
09c0: 64 62 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 db:get-keys #f))
09d0: 29 0a 09 28 76 61 6c 73 20 28 68 61 73 68 2d 74 )..(vals (hash-t
09e0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
09f0: 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 *env-vars-by-ru
0a00: 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 23 66 29 n-id* run-id #f)
0a10: 29 29 0a 20 20 20 20 3b 3b 20 67 65 74 20 74 68 )). ;; get th
0a20: 65 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 20 e info from the
0a30: 64 62 20 61 6e 64 20 70 75 74 20 69 74 20 69 6e db and put it in
0a40: 20 74 68 65 20 63 61 63 68 65 0a 20 20 20 20 28 the cache. (
0a50: 69 66 20 28 6e 6f 74 20 76 61 6c 73 29 0a 09 28 if (not vals)..(
0a60: 6c 65 74 20 28 28 68 74 20 28 6d 61 6b 65 2d 68 let ((ht (make-h
0a70: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 20 ash-table)))..
0a80: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
0a90: 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 *env-vars-by-ru
0aa0: 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 68 74 29 n-id* run-id ht)
0ab0: 0a 09 20 20 28 73 65 74 21 20 76 61 6c 73 20 68 .. (set! vals h
0ac0: 74 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 0a t).. (for-each.
0ad0: 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 . (lambda (key
0ae0: 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 ).. (hash-ta
0af0: 62 6c 65 2d 73 65 74 21 20 76 61 6c 73 20 6b 65 ble-set! vals ke
0b00: 79 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 y (cdb:remote-ru
0b10: 6e 20 64 62 3a 67 65 74 2d 72 75 6e 2d 6b 65 79 n db:get-run-key
0b20: 2d 76 61 6c 20 23 66 20 72 75 6e 2d 69 64 20 6b -val #f run-id k
0b30: 65 79 29 29 29 0a 09 20 20 20 6b 65 79 73 29 29 ey))).. keys))
0b40: 29 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 74 68 ). ;; from th
0b50: 65 20 63 61 63 68 65 64 20 64 61 74 61 20 73 65 e cached data se
0b60: 74 20 74 68 65 20 76 61 72 73 0a 20 20 20 20 28 t the vars. (
0b70: 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 hash-table-for-e
0b80: 61 63 68 0a 20 20 20 20 20 76 61 6c 73 0a 20 20 ach. vals.
0b90: 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 20 (lambda (key
0ba0: 76 61 6c 29 0a 20 20 20 20 20 20 20 28 64 65 62 val). (deb
0bb0: 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 74 65 ug:print 2 "sete
0bc0: 6e 76 20 22 20 6b 65 79 20 22 20 22 20 76 61 6c nv " key " " val
0bd0: 29 0a 20 20 20 20 20 20 20 28 73 65 74 65 6e 76 ). (setenv
0be0: 20 6b 65 79 20 76 61 6c 29 29 29 0a 20 20 20 20 key val))).
0bf0: 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 (alist->env-vars
0c00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
0c10: 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 67 /default *config
0c20: 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 69 dat* "env-overri
0c30: 64 65 22 20 27 28 29 29 29 0a 20 20 20 20 3b 3b de" '())). ;;
0c40: 20 4c 65 74 73 20 75 73 65 20 74 68 69 73 20 61 Lets use this a
0c50: 73 20 61 6e 20 6f 70 70 6f 72 74 75 6e 69 74 79 s an opportunity
0c60: 20 74 6f 20 70 75 74 20 4d 54 5f 52 55 4e 4e 41 to put MT_RUNNA
0c70: 4d 45 20 69 6e 20 74 68 65 20 65 6e 76 69 72 6f ME in the enviro
0c80: 6e 6d 65 6e 74 0a 20 20 20 20 28 73 65 74 65 6e nment. (seten
0c90: 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 28 v "MT_RUNNAME" (
0ca0: 69 66 20 69 6e 72 75 6e 6e 61 6d 65 20 69 6e 72 if inrunname inr
0cb0: 75 6e 6e 61 6d 65 20 28 63 64 62 3a 72 65 6d 6f unname (cdb:remo
0cc0: 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 72 75 te-run db:get-ru
0cd0: 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 20 23 n-name-from-id #
0ce0: 66 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 f run-id))).
0cf0: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f (setenv "MT_RUN_
0d00: 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 AREA_HOME" *topp
0d10: 61 74 68 2a 29 29 29 0a 0a 28 64 65 66 69 6e 65 ath*)))..(define
0d20: 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 (set-item-env-v
0d30: 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 20 28 ars itemdat). (
0d40: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
0d50: 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 20 28 (item).. (
0d60: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 debug:print 2 "s
0d70: 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 74 65 etenv " (car ite
0d80: 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 74 65 m) " " (cadr ite
0d90: 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 74 65 m)).. (sete
0da0: 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 28 63 nv (car item) (c
0db0: 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 20 20 adr item)))..
0dc0: 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 65 66 itemdat))..(def
0dd0: 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 ine *last-num-ru
0de0: 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 30 29 0a nning-tests* 0).
0df0: 0a 3b 3b 20 45 76 65 72 79 20 74 69 6d 65 20 63 .;; Every time c
0e00: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
0e10: 73 20 69 73 20 63 61 6c 6c 65 64 20 69 6e 63 72 s is called incr
0e20: 65 6d 65 6e 74 20 74 68 65 20 64 65 6c 61 79 0a ement the delay.
0e30: 3b 3b 20 69 66 20 74 68 65 20 63 6f 75 0a 28 64 ;; if the cou.(d
0e40: 65 66 69 6e 65 20 2a 72 75 6e 73 3a 63 61 6e 2d efine *runs:can-
0e50: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
0e60: 6f 75 6e 74 2a 20 30 29 0a 28 64 65 66 69 6e 65 ount* 0).(define
0e70: 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d 63 61 (runs:shrink-ca
0e80: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
0e90: 2d 63 6f 75 6e 74 29 0a 20 20 28 73 65 74 21 20 -count). (set!
0ea0: 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f *runs:can-run-mo
0eb0: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 re-tests-count*
0ec0: 30 29 29 20 3b 3b 20 28 2f 20 2a 72 75 6e 73 3a 0)) ;; (/ *runs:
0ed0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
0ee0: 74 73 2d 63 6f 75 6e 74 2a 20 32 29 29 29 0a 0a ts-count* 2)))..
0ef0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 (define (runs:ca
0f00: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
0f10: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 61 78 test-record max
0f20: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
0f30: 29 0a 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ). (thread-slee
0f40: 70 21 20 28 63 6f 6e 64 0a 09 09 20 20 28 28 3e p! (cond... ((>
0f50: 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d *runs:can-run-m
0f60: 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a ore-tests-count*
0f70: 20 32 30 29 20 32 29 3b 3b 20 6f 62 76 69 6f 75 20) 2);; obviou
0f80: 73 6c 79 20 68 61 76 65 6e 27 74 20 68 61 64 20 sly haven't had
0f90: 61 6e 79 20 77 6f 72 6b 20 74 6f 20 64 6f 20 66 any work to do f
0fa0: 6f 72 20 61 20 77 68 69 6c 65 0a 09 09 20 20 28 or a while... (
0fb0: 65 6c 73 65 20 30 29 29 29 0a 20 20 28 6c 65 74 else 0))). (let
0fc0: 2a 20 28 28 74 63 6f 6e 66 69 67 20 20 20 20 20 * ((tconfig
0fd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 (tes
0fe0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
0ff0: 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 -testconfig test
1000: 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 6a 6f 62 -record)).. (job
1010: 67 72 6f 75 70 20 20 20 20 20 20 20 20 20 20 20 group
1020: 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (config-loo
1030: 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 kup tconfig "req
1040: 75 69 72 65 6d 65 6e 74 73 22 20 22 6a 6f 62 67 uirements" "jobg
1050: 72 6f 75 70 22 29 29 0a 09 20 28 6e 75 6d 2d 72 roup")).. (num-r
1060: 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 20 20 unning
1070: 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 (cdb:remote-r
1080: 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d un db:get-count-
1090: 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 23 66 tests-running #f
10a0: 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e )).. (num-runnin
10b0: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 63 g-in-jobgroup (c
10c0: 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 db:remote-run db
10d0: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
10e0: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
10f0: 72 6f 75 70 20 23 66 20 6a 6f 62 67 72 6f 75 70 roup #f jobgroup
1100: 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 70 2d )).. (job-group-
1110: 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 63 limit (c
1120: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f onfig-lookup *co
1130: 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 67 72 6f nfigdat* "jobgro
1140: 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 29 29 29 ups" jobgroup)))
1150: 0a 20 20 20 20 28 69 66 20 28 3e 20 28 2b 20 6e . (if (> (+ n
1160: 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 um-running num-r
1170: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
1180: 75 70 29 20 30 29 0a 09 28 73 65 74 21 20 2a 72 up) 0)..(set! *r
1190: 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 uns:can-run-more
11a0: 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 28 2b -tests-count* (+
11b0: 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d *runs:can-run-m
11c0: 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a ore-tests-count*
11d0: 20 31 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 1))). (if (n
11e0: 6f 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d 6e 75 ot (eq? *last-nu
11f0: 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a m-running-tests*
1200: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 0a 09 num-running))..
1210: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
1220: 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f :print 2 "max-co
1230: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 ncurrent-jobs: "
1240: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1250: 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e jobs ", num-runn
1260: 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 ing: " num-runni
1270: 6e 67 29 0a 09 20 20 28 73 65 74 21 20 2a 6c 61 ng).. (set! *la
1280: 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 st-num-running-t
1290: 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e ests* num-runnin
12a0: 67 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f g))). (if (no
12b0: 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 61 6c t (eq? 0 *global
12c0: 65 78 69 74 73 74 61 74 75 73 2a 29 29 0a 09 28 exitstatus*))..(
12d0: 6c 69 73 74 20 23 66 20 6e 75 6d 2d 72 75 6e 6e list #f num-runn
12e0: 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d ing num-running-
12f0: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d in-jobgroup max-
1300: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
1310: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 job-group-limit)
1320: 0a 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e 6f 74 ..(let ((can-not
1330: 2d 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a -run-more (cond.
1340: 09 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 2d 63 .... ;; if max-c
1350: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 69 oncurrent-jobs i
1360: 73 20 73 65 74 20 61 6e 64 20 74 68 65 20 6e 75 s set and the nu
1370: 6d 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 73 20 mber running is
1380: 67 72 65 61 74 65 72 20 0a 09 09 09 09 20 3b 3b greater ..... ;;
1390: 20 74 68 61 6e 20 69 74 20 74 68 61 6e 20 63 61 than it than ca
13a0: 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f nnot run more jo
13b0: 62 73 0a 09 09 09 09 20 28 28 61 6e 64 20 6d 61 bs..... ((and ma
13c0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
13d0: 73 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e s (>= num-runnin
13e0: 67 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 g max-concurrent
13f0: 2d 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 28 64 -jobs))..... (d
1400: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
1410: 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e 6e 69 RNING: Max runni
1420: 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 64 65 64 ng jobs exceeded
1430: 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 65 72 , current number
1440: 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d running: " num-
1450: 72 75 6e 6e 69 6e 67 20 0a 09 09 09 09 09 20 20 running ......
1460: 20 20 20 20 20 22 2c 20 6d 61 78 5f 63 6f 6e 63 ", max_conc
1470: 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 20 6d urrent_jobs: " m
1480: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
1490: 62 73 29 0a 09 09 09 09 20 20 23 74 29 0a 09 09 bs)..... #t)...
14a0: 09 09 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 72 6f .. ;; if job-gro
14b0: 75 70 2d 6c 69 6d 69 74 20 69 73 20 73 65 74 20 up-limit is set
14c0: 61 6e 64 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f and number of jo
14d0: 62 73 20 69 6e 20 74 68 65 20 67 72 6f 75 70 20 bs in the group
14e0: 69 73 20 67 72 65 61 74 65 72 0a 09 09 09 09 20 is greater.....
14f0: 3b 3b 20 74 68 61 6e 20 74 68 65 20 6c 69 6d 69 ;; than the limi
1500: 74 20 74 68 65 6e 20 63 61 6e 6e 6f 74 20 72 75 t then cannot ru
1510: 6e 20 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 20 74 n more jobs of t
1520: 68 69 73 20 6b 69 6e 64 0a 09 09 09 09 20 28 28 his kind..... ((
1530: 61 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 and job-group-li
1540: 6d 69 74 0a 09 09 09 09 20 20 20 20 20 20 20 28 mit..... (
1550: 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 >= num-running-i
1560: 6e 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 2d 67 n-jobgroup job-g
1570: 72 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 09 09 roup-limit))....
1580: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
1590: 31 20 22 57 41 52 4e 49 4e 47 3a 20 6e 75 6d 62 1 "WARNING: numb
15a0: 65 72 20 6f 66 20 6a 6f 62 73 20 22 20 6e 75 6d er of jobs " num
15b0: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
15c0: 72 6f 75 70 20 0a 09 09 09 09 09 20 20 20 20 20 roup ......
15d0: 20 20 22 20 69 6e 20 22 20 6a 6f 62 67 72 6f 75 " in " jobgrou
15e0: 70 20 22 20 65 78 63 65 65 64 65 64 2c 20 77 69 p " exceeded, wi
15f0: 6c 6c 20 6e 6f 74 20 72 75 6e 20 22 20 28 74 65 ll not run " (te
1600: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
1610: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d t-testname test-
1620: 72 65 63 6f 72 64 29 29 0a 09 09 09 09 20 20 23 record))..... #
1630: 74 29 0a 09 09 09 09 20 28 65 6c 73 65 20 23 66 t)..... (else #f
1640: 29 29 29 29 0a 09 20 20 28 6c 69 73 74 20 28 6e )))).. (list (n
1650: 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d ot can-not-run-m
1660: 6f 72 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 ore) num-running
1670: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d num-running-in-
1680: 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 6f 6e jobgroup max-con
1690: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a 6f 62 current-jobs job
16a0: 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 29 29 -group-limit))))
16b0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
16c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e ===========.;; N
1700: 65 77 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 2e 20 ew methodology.
1710: 54 68 65 73 65 20 72 6f 75 74 69 6e 65 73 20 77 These routines w
1720: 69 6c 6c 20 72 65 70 6c 61 63 65 20 74 68 65 20 ill replace the
1730: 61 62 6f 76 65 20 69 6e 20 74 69 6d 65 2e 20 46 above in time. F
1740: 6f 72 0a 3b 3b 20 6e 6f 77 20 74 68 65 20 63 6f or.;; now the co
1750: 64 65 20 69 73 20 64 75 70 6c 69 63 61 74 65 64 de is duplicated
1760: 2e 20 54 68 69 73 20 73 74 75 66 66 20 69 73 20 . This stuff is
1770: 69 6e 69 74 69 61 6c 6c 79 20 75 73 65 64 20 69 initially used i
1780: 6e 20 74 68 65 20 6d 6f 6e 69 74 6f 72 0a 3b 3b n the monitor.;;
1790: 20 62 61 73 65 64 20 63 6f 64 65 2e 0a 3b 3b 3d based code..;;=
17a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
17e0: 3d 3d 3d 3d 3d 0a 0a 0a 3b 3b 20 54 68 69 73 20 =====...;; This
17f0: 69 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 6f is a duplicate o
1800: 66 20 72 75 6e 2d 74 65 73 74 73 20 28 77 68 69 f run-tests (whi
1810: 63 68 20 68 61 73 20 62 65 65 6e 20 64 65 70 72 ch has been depr
1820: 65 63 61 74 65 64 29 2e 20 55 73 65 20 74 68 69 ecated). Use thi
1830: 73 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 s one instead of
1840: 20 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b run tests..;; k
1850: 65 79 76 61 6c 73 2e 0a 3b 3b 0a 3b 3b 20 20 74 eyvals..;;.;; t
1860: 65 73 74 2d 6e 61 6d 65 73 3a 20 43 6f 6d 6d 61 est-names: Comma
1870: 20 73 65 70 61 72 61 74 65 64 20 70 61 74 74 65 separated patte
1880: 72 6e 73 20 73 61 6d 65 20 61 73 20 74 65 73 74 rns same as test
1890: 2d 70 61 74 74 73 20 62 75 74 20 75 73 65 64 20 -patts but used
18a0: 69 6e 20 73 65 6c 65 63 74 69 6f 6e 20 0a 3b 3b in selection .;;
18b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 6f 66 of
18c0: 20 74 65 73 74 73 20 74 6f 20 72 75 6e 2e 20 54 tests to run. T
18d0: 68 65 20 69 74 65 6d 20 70 6f 72 74 69 6f 6e 73 he item portions
18e0: 20 61 72 65 20 6e 6f 74 20 72 65 73 70 65 63 74 are not respect
18f0: 65 64 2e 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ed..;;
1900: 20 20 20 20 46 49 58 4d 45 3a 20 65 72 72 6f 72 FIXME: error
1910: 20 6f 75 74 20 69 66 20 2f 70 61 74 74 20 73 70 out if /patt sp
1920: 65 63 69 66 69 65 64 0a 3b 3b 20 20 20 20 20 20 ecified.;;
1930: 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 .(define (
1940: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 74 runs:run-tests t
1950: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 arget runname te
1960: 73 74 2d 6e 61 6d 65 73 20 74 65 73 74 2d 70 61 st-names test-pa
1970: 74 74 73 20 75 73 65 72 20 66 6c 61 67 73 29 0a tts user flags).
1980: 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d (common:clear-
1990: 63 61 63 68 65 73 29 20 3b 3b 20 63 6c 65 61 72 caches) ;; clear
19a0: 20 61 6c 6c 20 63 61 63 68 65 73 0a 20 20 28 6c all caches. (l
19b0: 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 et* ((db
19c0: 20 20 23 66 29 0a 09 20 28 6b 65 79 73 20 20 20 #f).. (keys
19d0: 20 20 20 20 20 28 6b 65 79 73 3a 63 6f 6e 66 69 (keys:confi
19e0: 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f g-get-fields *co
19f0: 6e 66 69 67 64 61 74 2a 29 29 0a 09 20 28 6b 65 nfigdat*)).. (ke
1a00: 79 76 61 6c 73 20 20 20 20 20 28 6b 65 79 73 3a yvals (keys:
1a10: 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b target->keyval k
1a20: 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 28 eys target)).. (
1a30: 72 75 6e 2d 69 64 20 20 20 20 20 20 28 63 64 62 run-id (cdb
1a40: 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 72 :remote-run db:r
1a50: 65 67 69 73 74 65 72 2d 72 75 6e 20 23 66 20 6b egister-run #f k
1a60: 65 79 73 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e eys keyvals runn
1a70: 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 ame "new" "n/a"
1a80: 75 73 65 72 29 29 20 20 3b 3b 20 20 74 65 73 74 user)) ;; test
1a90: 2d 6e 61 6d 65 29 29 29 0a 09 20 28 64 65 66 65 -name))).. (defe
1aa0: 72 72 65 64 20 20 20 20 27 28 29 29 20 3b 3b 20 rred '()) ;;
1ab0: 64 65 6c 61 79 20 72 75 6e 6e 69 6e 67 20 74 68 delay running th
1ac0: 65 73 65 20 73 69 6e 63 65 20 74 68 65 79 20 68 ese since they h
1ad0: 61 76 65 20 61 20 77 61 69 74 6f 6e 20 63 6c 61 ave a waiton cla
1ae0: 75 73 65 0a 09 20 3b 3b 20 6b 65 65 70 67 6f 69 use.. ;; keepgoi
1af0: 6e 67 20 69 73 20 74 68 65 20 64 65 66 61 63 74 ng is the defact
1b00: 6f 20 6d 6f 64 61 6c 69 74 79 20 6e 6f 77 2c 20 o modality now,
1b10: 77 69 6c 6c 20 61 64 64 20 68 69 74 2d 6e 2d 72 will add hit-n-r
1b20: 75 6e 20 61 20 62 69 74 20 6c 61 74 65 72 0a 09 un a bit later..
1b30: 20 3b 3b 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 ;; (keepgoing
1b40: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
1b50: 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 /default flags "
1b60: 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 -keepgoing" #f))
1b70: 0a 09 20 28 72 75 6e 63 6f 6e 66 69 67 66 20 20 .. (runconfigf
1b80: 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 (conc *toppath
1b90: 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 * "/runconfigs.c
1ba0: 6f 6e 66 69 67 22 29 29 0a 09 20 28 72 65 71 75 onfig")).. (requ
1bb0: 69 72 65 64 2d 74 65 73 74 73 20 27 28 29 29 0a ired-tests '()).
1bc0: 09 20 28 74 65 73 74 2d 72 65 63 6f 72 64 73 20 . (test-records
1bd0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1be0: 29 29 29 0a 0a 20 20 20 20 28 73 65 74 2d 6d 65 ))).. (set-me
1bf0: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars
1c00: 72 75 6e 2d 69 64 20 69 6e 6b 65 79 73 3a 20 6b run-id inkeys: k
1c10: 65 79 73 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 eys) ;; these ma
1c20: 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 y be needed by t
1c30: 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f he launching pro
1c40: 63 65 73 73 0a 0a 20 20 20 20 28 69 66 20 28 66 cess.. (if (f
1c50: 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 63 ile-exists? runc
1c60: 6f 6e 66 69 67 66 29 0a 09 28 73 65 74 75 70 2d onfigf)..(setup-
1c70: 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 72 75 6e env-defaults run
1c80: 63 6f 6e 66 69 67 66 20 72 75 6e 2d 69 64 20 2a configf run-id *
1c90: 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e already-seen-run
1ca0: 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 6b 65 79 config-info* key
1cb0: 73 20 6b 65 79 76 61 6c 73 20 22 70 72 65 2d 6c s keyvals "pre-l
1cc0: 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 22 29 aunch-env-vars")
1cd0: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
1ce0: 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 "WARNING: You d
1cf0: 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e o not have a run
1d00: 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 config file: "
1d10: 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 runconfigf)).
1d20: 20 0a 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 . ;; look up
1d30: 20 61 6c 6c 20 74 65 73 74 73 20 6d 61 74 63 68 all tests match
1d40: 69 6e 67 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 ing the comma se
1d50: 70 61 72 61 74 65 64 20 6c 69 73 74 20 6f 66 20 parated list of
1d60: 67 6c 6f 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 globs in. ;;
1d70: 74 65 73 74 2d 70 61 74 74 73 20 28 75 73 69 6e test-patts (usin
1d80: 67 20 25 20 61 73 20 77 69 6c 64 63 61 72 64 29 g % as wildcard)
1d90: 0a 0a 20 20 20 20 28 73 65 74 21 20 74 65 73 74 .. (set! test
1da0: 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a 67 65 -names (tests:ge
1db0: 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 2a 74 t-valid-tests *t
1dc0: 6f 70 70 61 74 68 2a 20 74 65 73 74 2d 6e 61 6d oppath* test-nam
1dd0: 65 73 29 29 0a 20 20 20 20 28 73 65 74 21 20 74 es)). (set! t
1de0: 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 6c 65 74 est-names (delet
1df0: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 74 65 73 e-duplicates tes
1e00: 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 20 20 28 t-names)).. (
1e10: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
1e20: 20 30 20 22 74 65 73 74 20 6e 61 6d 65 73 20 22 0 "test names "
1e30: 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 0a 20 20 test-names)..
1e40: 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 72 73 ;; on the firs
1e50: 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c 20 74 t pass or call t
1e60: 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 74 20 o run-tests set
1e70: 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 54 41 FAILS to NOT_STA
1e80: 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b 20 2d RTED if. ;; -
1e90: 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 70 65 keepgoing is spe
1ea0: 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 20 28 cified. (if (
1eb0: 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 30 29 eq? *passnum* 0)
1ec0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 20 68 ..(begin.. ;; h
1ed0: 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 74 65 ave to delete te
1ee0: 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 72 65 st records where
1ef0: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 69 6e NOT_STARTED sin
1f00: 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 75 73 ce they can caus
1f10: 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 6f 20 e -keepgoing to
1f20: 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 63 6b .. ;; get stuck
1f30: 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 6e 67 due to becoming
1f40: 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 66 72 inaccessible fr
1f50: 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 73 74 om a failed test
1f60: 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 20 42 . I.e. if test B
1f70: 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b 3b 20 depends .. ;;
1f80: 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 74 65 on test A but te
1f90: 73 74 20 42 20 72 65 61 63 68 65 64 20 74 68 65 st B reached the
1fa0: 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e 67 20 point on being
1fb0: 72 65 67 69 73 74 65 72 65 64 20 61 73 20 4e 4f registered as NO
1fc0: 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 74 65 T_STARTED and te
1fd0: 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 6c 65 st.. ;; A faile
1fe0: 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 73 6f d for some reaso
1ff0: 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 75 6e n then on re-run
2000: 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f 69 6e using -keepgoin
2010: 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 6e 65 g the run can ne
2020: 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a 09 20 ver complete...
2030: 20 28 63 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 (cdb:delete-tes
2040: 74 73 2d 69 6e 2d 73 74 61 74 65 20 2a 72 75 6e ts-in-state *run
2050: 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 22 remote* run-id "
2060: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 09 20 NOT_STARTED")..
2070: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
2080: 20 64 62 3a 73 65 74 2d 74 65 73 74 73 2d 73 74 db:set-tests-st
2090: 61 74 65 2d 73 74 61 74 75 73 20 23 66 20 72 75 ate-status #f ru
20a0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 n-id test-names
20b0: 23 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 5f 53 #f "FAIL" "NOT_S
20c0: 54 41 52 54 45 44 22 20 22 46 41 49 4c 22 29 29 TARTED" "FAIL"))
20d0: 29 0a 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 68 ).. ;; from h
20e0: 65 72 65 20 6f 6e 20 6f 75 74 20 74 68 65 20 64 ere on out the d
20f0: 62 20 77 69 6c 6c 20 62 65 20 6f 70 65 6e 65 64 b will be opened
2100: 20 61 6e 64 20 63 6c 6f 73 65 64 20 6f 6e 20 65 and closed on e
2110: 76 65 72 79 20 63 61 6c 6c 20 72 75 6e 73 3a 72 very call runs:r
2120: 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 0a 20 un-tests-queue.
2130: 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 ;; (sqlite3:f
2140: 69 6e 61 6c 69 7a 65 21 20 64 62 29 20 0a 20 20 inalize! db) .
2150: 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e 6f 6e ;; now add non
2160: 2d 64 69 72 65 63 74 6c 79 20 72 65 66 65 72 65 -directly refere
2170: 6e 63 65 64 20 64 65 70 65 6e 64 65 6e 63 69 65 nced dependencie
2180: 73 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e 29 0a s (i.e. waiton).
2190: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
21a0: 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ll? test-names))
21b0: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
21c0: 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 d (car test-name
21d0: 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 s))... (tal (c
21e0: 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 dr test-names)))
21f0: 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 74 ;; 'ret
2200: 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 urn-procs tells
2210: 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 65 the config reade
2220: 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e r to prep runnin
2230: 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 74 g system but ret
2240: 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 28 64 urn a proc.. (d
2250: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2260: 34 20 22 68 65 64 3d 22 20 68 65 64 20 22 20 61 4 "hed=" hed " a
2270: 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 22 29 0a t top of loop").
2280: 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 . (let* ((confi
2290: 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 g (tests:get-te
22a0: 73 74 63 6f 6e 66 69 67 20 68 65 64 20 27 72 65 stconfig hed 're
22b0: 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 09 20 turn-procs))...
22c0: 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 28 (waitons (let ((
22d0: 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 67 instr (if config
22e0: 20 0a 09 09 09 09 09 20 20 20 28 63 6f 6e 66 69 ...... (confi
22f0: 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 g-lookup config
2300: 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
2310: 77 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 20 waiton")......
2320: 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 6f (begin ;; No co
2330: 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 20 nfig means this
2340: 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 6e is a non-existan
2350: 74 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 20 t test......
2360: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2370: 22 45 52 52 4f 52 3a 20 6e 6f 6e 2d 65 78 69 73 "ERROR: non-exis
2380: 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 65 tent required te
2390: 73 74 20 5c 22 22 20 68 65 64 20 22 5c 22 22 29 st \"" hed "\"")
23a0: 0a 09 09 09 09 09 20 20 20 20 20 28 69 66 20 64 ...... (if d
23b0: 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c b (sqlite3:final
23c0: 69 7a 65 21 20 64 62 29 29 0a 09 09 09 09 09 20 ize! db))......
23d0: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 29 (exit 1)))))
23e0: 0a 09 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 .... (debug:p
23f0: 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 rint-info 8 "wai
2400: 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 22 tons string is "
2410: 20 69 6e 73 74 72 29 0a 09 09 09 20 20 20 20 28 instr).... (
2420: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 63 6f string-split (co
2430: 6e 64 0a 09 09 09 09 09 20 20 20 28 28 70 72 6f nd...... ((pro
2440: 63 65 64 75 72 65 3f 20 69 6e 73 74 72 29 0a 09 cedure? instr)..
2450: 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 28 72 .... (let ((r
2460: 65 73 20 28 69 6e 73 74 72 29 29 29 0a 09 09 09 es (instr)))....
2470: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
2480: 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 rint-info 8 "wai
2490: 74 6f 6e 20 70 72 6f 63 65 64 75 72 65 20 72 65 ton procedure re
24a0: 73 75 6c 74 73 20 69 6e 20 73 74 72 69 6e 67 20 sults in string
24b0: 22 20 72 65 73 20 22 20 66 6f 72 20 74 65 73 74 " res " for test
24c0: 20 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 20 " hed)......
24d0: 20 20 20 72 65 73 29 29 0a 09 09 09 09 09 20 20 res))......
24e0: 20 28 28 73 74 72 69 6e 67 3f 20 69 6e 73 74 72 ((string? instr
24f0: 29 20 20 20 20 20 69 6e 73 74 72 29 0a 09 09 09 ) instr)....
2500: 09 09 20 20 20 28 65 6c 73 65 20 0a 09 09 09 09 .. (else .....
2510: 09 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 . ;; NOTE: Th
2520: 69 73 20 69 73 20 61 63 74 75 61 6c 6c 79 20 74 is is actually t
2530: 68 65 20 63 61 73 65 20 6f 66 20 2a 6e 6f 2a 20 he case of *no*
2540: 77 61 69 74 6f 6e 73 21 20 3b 3b 20 28 64 65 62 waitons! ;; (deb
2550: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
2560: 52 3a 20 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e R: something wen
2570: 74 20 77 72 6f 6e 67 20 69 6e 20 70 72 6f 63 65 t wrong in proce
2580: 73 73 69 6e 67 20 77 61 69 74 6f 6e 73 20 66 6f ssing waitons fo
2590: 72 20 74 65 73 74 20 22 20 68 65 64 29 0a 09 09 r test " hed)...
25a0: 09 09 09 20 20 20 20 22 22 29 29 29 29 29 29 0a ... "")))))).
25b0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
25c0: 74 2d 69 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e t-info 8 "waiton
25d0: 73 3a 20 22 20 77 61 69 74 6f 6e 73 29 0a 09 20 s: " waitons)..
25e0: 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 ;; check for
25f0: 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d hed in waitons =
2600: 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 > this would be
2610: 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 circular, remove
2620: 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e it and issue an
2630: 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 .. ;; error..
2640: 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 (if (member
2650: 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 hed waitons)...(
2660: 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 begin... (debug
2670: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
2680: 20 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 test " hed " ha
2690: 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 s listed itself
26a0: 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 as a waiton, ple
26b0: 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 ase correct this
26c0: 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 !")... (set! wa
26d0: 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 20 28 6c itons (filter (l
26e0: 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 ambda (x)(not (e
26f0: 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 qual? x hed))) w
2700: 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 20 20 20 aitons))))..
2710: 0a 09 20 20 20 20 3b 3b 20 28 69 74 65 6d 73 20 .. ;; (items
2720: 20 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 (items:get-ite
2730: 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 ms-from-config c
2740: 6f 6e 66 69 67 29 29 29 0a 09 20 20 20 20 28 69 onfig))).. (i
2750: 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 f (not (hash-tab
2760: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 le-ref/default t
2770: 65 73 74 2d 72 65 63 6f 72 64 73 20 68 65 64 20 est-records hed
2780: 23 66 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 #f))...(hash-tab
2790: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 le-set! test-rec
27a0: 6f 72 64 73 0a 09 09 09 09 20 68 65 64 20 28 76 ords..... hed (v
27b0: 65 63 74 6f 72 20 68 65 64 20 20 20 20 20 3b 3b ector hed ;;
27c0: 20 30 0a 09 09 09 09 09 20 20 20 20 20 63 6f 6e 0...... con
27d0: 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 09 09 20 fig ;; 1......
27e0: 20 20 20 20 77 61 69 74 6f 6e 73 20 3b 3b 20 32 waitons ;; 2
27f0: 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 66 ...... (conf
2800: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
2810: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
2820: 22 70 72 69 6f 72 69 74 79 22 29 20 20 20 20 20 "priority")
2830: 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 0a 09 09 ;; priority 3...
2840: 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 69 ... (let ((i
2850: 74 65 6d 73 20 20 20 20 20 20 28 68 61 73 68 2d tems (hash-
2860: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2870: 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 22 t config "items"
2880: 20 23 66 29 29 20 3b 3b 20 69 74 65 6d 73 20 34 #f)) ;; items 4
2890: 0a 09 09 09 09 09 09 20 20 20 28 69 74 65 6d 73 ....... (items
28a0: 74 61 62 6c 65 20 28 68 61 73 68 2d 74 61 62 6c table (hash-tabl
28b0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f e-ref/default co
28c0: 6e 66 69 67 20 22 69 74 65 6d 73 74 61 62 6c 65 nfig "itemstable
28d0: 22 20 23 66 29 29 29 20 0a 09 09 09 09 09 20 20 " #f))) ......
28e0: 20 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 ;; if eithe
28f0: 72 20 69 74 65 6d 73 20 6f 72 20 69 74 65 6d 73 r items or items
2900: 20 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 table is a proc
2910: 20 72 65 74 75 72 6e 20 69 74 20 73 6f 20 74 65 return it so te
2920: 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 09 09 09 st running......
2930: 20 20 20 20 20 20 20 3b 3b 20 70 72 6f 63 65 73 ;; proces
2940: 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f 20 63 61 s can know to ca
2950: 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 ll items:get-ite
2960: 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 0a 09 ms-from-config..
2970: 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 .... ;; if
2980: 20 65 69 74 68 65 72 20 69 73 20 61 20 6c 69 73 either is a lis
2990: 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 20 61 20 t and none is a
29a0: 70 72 6f 63 20 67 6f 20 61 68 65 61 64 20 61 6e proc go ahead an
29b0: 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 65 6d 73 d call get-items
29c0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
29d0: 6f 74 68 65 72 77 69 73 65 20 72 65 74 75 72 6e otherwise return
29e0: 20 23 66 20 2d 20 74 68 69 73 20 69 73 20 6e 6f #f - this is no
29f0: 74 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 t an iterated te
2a00: 73 74 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 st...... (
2a10: 63 6f 6e 64 0a 09 09 09 09 09 09 28 28 70 72 6f cond.......((pro
2a20: 63 65 64 75 72 65 3f 20 69 74 65 6d 73 29 20 20 cedure? items)
2a30: 20 20 20 20 0a 09 09 09 09 09 09 20 28 64 65 62 ....... (deb
2a40: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
2a50: 22 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 "items is a proc
2a60: 65 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 edure, will calc
2a70: 20 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 later").......
2a80: 69 74 65 6d 73 29 20 20 20 20 20 20 20 20 20 20 items)
2a90: 20 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a ;; calc later.
2aa0: 09 09 09 09 09 09 28 28 70 72 6f 63 65 64 75 72 ......((procedur
2ab0: 65 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 e? itemstable)..
2ac0: 09 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
2ad0: 6e 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 nt-info 4 "items
2ae0: 74 61 62 6c 65 20 69 73 20 61 20 70 72 6f 63 65 table is a proce
2af0: 64 75 72 65 2c 20 77 69 6c 6c 20 63 61 6c 63 20 dure, will calc
2b00: 6c 61 74 65 72 22 29 0a 09 09 09 09 09 09 20 69 later")....... i
2b10: 74 65 6d 73 74 61 62 6c 65 29 20 20 20 20 20 20 temstable)
2b20: 20 3b 3b 20 63 61 6c 63 20 6c 61 74 65 72 0a 09 ;; calc later..
2b30: 09 09 09 09 09 28 28 66 69 6c 74 65 72 20 28 6c .....((filter (l
2b40: 61 6d 62 64 61 20 28 78 29 0a 09 09 09 09 09 09 ambda (x).......
2b50: 09 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 . (let ((val (
2b60: 63 61 72 20 78 29 29 29 0a 09 09 09 09 09 09 09 car x)))........
2b70: 20 20 20 20 20 28 69 66 20 28 70 72 6f 63 65 64 (if (proced
2b80: 75 72 65 3f 20 76 61 6c 29 20 76 61 6c 20 23 66 ure? val) val #f
2b90: 29 29 29 0a 09 09 09 09 09 09 09 20 28 61 70 70 )))........ (app
2ba0: 65 6e 64 20 28 69 66 20 28 6c 69 73 74 3f 20 69 end (if (list? i
2bb0: 74 65 6d 73 29 20 69 74 65 6d 73 20 27 28 29 29 tems) items '())
2bc0: 0a 09 09 09 09 09 09 09 09 20 28 69 66 20 28 6c ......... (if (l
2bd0: 69 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 ist? itemstable)
2be0: 20 69 74 65 6d 73 74 61 62 6c 65 20 27 28 29 29 itemstable '())
2bf0: 29 29 0a 09 09 09 09 09 09 20 27 68 61 76 65 2d ))....... 'have-
2c00: 70 72 6f 63 65 64 75 72 65 29 0a 09 09 09 09 09 procedure)......
2c10: 09 28 28 6f 72 20 28 6c 69 73 74 3f 20 69 74 65 .((or (list? ite
2c20: 6d 73 29 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 ms)(list? itemst
2c30: 61 62 6c 65 29 29 20 3b 3b 20 63 61 6c 63 20 6e able)) ;; calc n
2c40: 6f 77 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 ow....... (debug
2c50: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 69 :print-info 4 "i
2c60: 74 65 6d 73 20 61 6e 64 20 69 74 65 6d 73 74 61 tems and itemsta
2c70: 62 6c 65 20 61 72 65 20 6c 69 73 74 73 2c 20 63 ble are lists, c
2c80: 61 6c 63 20 6e 6f 77 5c 6e 22 0a 09 09 09 09 09 alc now\n"......
2c90: 09 09 20 20 20 20 20 20 22 20 20 20 20 69 74 65 .. " ite
2ca0: 6d 73 3a 20 22 20 69 74 65 6d 73 20 22 20 69 74 ms: " items " it
2cb0: 65 6d 73 74 61 62 6c 65 3a 20 22 20 69 74 65 6d emstable: " item
2cc0: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 stable)....... (
2cd0: 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d items:get-items-
2ce0: 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 from-config conf
2cf0: 69 67 29 29 0a 09 09 09 09 09 09 28 65 6c 73 65 ig)).......(else
2d00: 20 23 66 29 29 29 20 20 20 20 20 20 20 20 20 20 #f)))
2d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d20: 20 3b 3b 20 6e 6f 74 20 69 74 65 72 61 74 65 64 ;; not iterated
2d30: 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 ...... #f
2d40: 20 20 20 3b 3b 20 69 74 65 6d 73 64 61 74 20 35 ;; itemsdat 5
2d50: 0a 09 09 09 09 09 20 20 20 20 20 23 66 20 20 20 ...... #f
2d60: 20 20 20 3b 3b 20 73 70 61 72 65 20 2d 20 75 73 ;; spare - us
2d70: 65 64 20 66 6f 72 20 69 74 65 6d 2d 70 61 74 68 ed for item-path
2d80: 0a 09 09 09 09 09 20 20 20 20 20 29 29 29 0a 09 ...... )))..
2d90: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 (for-each ..
2da0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 77 61 (lambda (wa
2db0: 69 74 6f 6e 29 0a 09 20 20 20 20 20 20 20 28 69 iton).. (i
2dc0: 66 20 28 61 6e 64 20 77 61 69 74 6f 6e 20 28 6e f (and waiton (n
2dd0: 6f 74 20 28 6d 65 6d 62 65 72 20 77 61 69 74 6f ot (member waito
2de0: 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a n test-names))).
2df0: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 .. (begin...
2e00: 20 20 20 28 73 65 74 21 20 72 65 71 75 69 72 65 (set! require
2e10: 64 2d 74 65 73 74 73 20 28 63 6f 6e 73 20 77 61 d-tests (cons wa
2e20: 69 74 6f 6e 20 72 65 71 75 69 72 65 64 2d 74 65 iton required-te
2e30: 73 74 73 29 29 0a 09 09 20 20 20 20 20 28 73 65 sts))... (se
2e40: 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 63 t! test-names (c
2e50: 6f 6e 73 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ons waiton test-
2e60: 6e 61 6d 65 73 29 29 29 29 29 20 3b 3b 20 77 61 names))))) ;; wa
2e70: 73 20 61 6e 20 61 70 70 65 6e 64 2c 20 6e 6f 77 s an append, now
2e80: 20 61 20 63 6f 6e 73 0a 09 20 20 20 20 20 77 61 a cons.. wa
2e90: 69 74 6f 6e 73 29 0a 09 20 20 20 20 28 6c 65 74 itons).. (let
2ea0: 20 28 28 72 65 6d 74 65 73 74 73 20 28 64 65 6c ((remtests (del
2eb0: 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 ete-duplicates (
2ec0: 61 70 70 65 6e 64 20 77 61 69 74 6f 6e 73 20 74 append waitons t
2ed0: 61 6c 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 al)))).. (i
2ee0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 f (not (null? re
2ef0: 6d 74 65 73 74 73 29 29 0a 09 09 20 20 28 6c 6f mtests))... (lo
2f00: 6f 70 20 28 63 61 72 20 72 65 6d 74 65 73 74 73 op (car remtests
2f10: 29 28 63 64 72 20 72 65 6d 74 65 73 74 73 29 29 )(cdr remtests))
2f20: 29 29 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 ))))).. (if (
2f30: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 72 65 71 75 69 not (null? requi
2f40: 72 65 64 2d 74 65 73 74 73 29 29 0a 09 28 64 65 red-tests))..(de
2f50: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
2f60: 20 22 41 64 64 69 6e 67 20 22 20 72 65 71 75 69 "Adding " requi
2f70: 72 65 64 2d 74 65 73 74 73 20 22 20 74 6f 20 74 red-tests " to t
2f80: 68 65 20 72 75 6e 20 71 75 65 75 65 22 29 29 0a he run queue")).
2f90: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 ;; NOTE: the
2fa0: 73 65 20 61 72 65 20 61 6c 6c 20 70 61 72 65 6e se are all paren
2fb0: 74 20 74 65 73 74 73 2c 20 69 74 65 6d 73 20 61 t tests, items a
2fc0: 72 65 20 6e 6f 74 20 65 78 70 61 6e 64 65 64 20 re not expanded
2fd0: 79 65 74 2e 0a 20 20 20 20 28 64 65 62 75 67 3a yet.. (debug:
2fe0: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 65 print-info 4 "te
2ff0: 73 74 2d 72 65 63 6f 72 64 73 3d 22 20 28 68 61 st-records=" (ha
3000: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
3010: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 20 test-records)).
3020: 20 20 20 28 6c 65 74 20 28 28 72 65 67 6c 65 6e (let ((reglen
3030: 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 20 28 (any->number (
3040: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
3050: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
3060: 70 22 20 22 72 75 6e 71 75 65 75 65 22 29 29 29 p" "runqueue")))
3070: 29 0a 20 20 20 20 20 20 28 69 66 20 72 65 67 6c ). (if regl
3080: 65 6e 0a 09 20 20 28 72 75 6e 73 3a 72 75 6e 2d en.. (runs:run-
3090: 74 65 73 74 73 2d 71 75 65 75 65 2d 6e 65 77 20 tests-queue-new
30a0: 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 run-id runname t
30b0: 65 73 74 2d 72 65 63 6f 72 64 73 20 66 6c 61 67 est-records flag
30c0: 73 20 74 65 73 74 2d 70 61 74 74 73 20 72 65 67 s test-patts reg
30d0: 6c 65 6e 29 0a 09 20 20 28 72 75 6e 73 3a 72 75 len).. (runs:ru
30e0: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 2d 63 6c n-tests-queue-cl
30f0: 61 73 73 69 63 20 72 75 6e 2d 69 64 20 72 75 6e assic run-id run
3100: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
3110: 73 20 66 6c 61 67 73 20 74 65 73 74 2d 70 61 74 s flags test-pat
3120: 74 73 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 ts))). (debug
3130: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 41 :print-info 4 "A
3140: 6c 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 65 22 ll done by here"
3150: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
3160: 6e 73 3a 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 ns:calc-fails pr
3170: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 ereqs-not-met).
3180: 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 (filter (lambda
3190: 20 28 74 65 73 74 29 0a 09 20 20 20 20 28 61 6e (test).. (an
31a0: 64 20 28 76 65 63 74 6f 72 3f 20 74 65 73 74 29 d (vector? test)
31b0: 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 3f ;; not (string?
31c0: 20 74 65 73 74 29 29 0a 09 09 20 28 65 71 75 61 test))... (equa
31d0: 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d l? (db:test-get-
31e0: 73 74 61 74 65 20 74 65 73 74 29 20 22 43 4f 4d state test) "COM
31f0: 50 4c 45 54 45 44 22 29 0a 09 09 20 28 6e 6f 74 PLETED")... (not
3200: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
3210: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t-get-status tes
3220: 74 29 0a 09 09 09 20 20 20 20 20 20 27 28 22 50 t).... '("P
3230: 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 ASS" "WARN" "CHE
3240: 43 4b 22 20 22 57 41 49 56 45 44 22 20 22 53 4b CK" "WAIVED" "SK
3250: 49 50 22 29 29 29 29 29 0a 09 20 20 70 72 65 72 IP"))))).. prer
3260: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 eqs-not-met))..(
3270: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c define (runs:cal
3280: 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 c-not-completed
3290: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
32a0: 0a 20 20 28 66 69 6c 74 65 72 0a 20 20 20 28 6c . (filter. (l
32b0: 61 6d 62 64 61 20 28 74 29 0a 20 20 20 20 20 28 ambda (t). (
32c0: 6f 72 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f or (not (vector?
32d0: 20 74 29 29 0a 09 20 28 6e 6f 74 20 28 65 71 75 t)).. (not (equ
32e0: 61 6c 3f 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 al? "COMPLETED"
32f0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
3300: 74 65 20 74 29 29 29 29 29 0a 20 20 20 70 72 65 te t))))). pre
3310: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 0a reqs-not-met))..
3320: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 70 72 (define (runs:pr
3330: 65 74 74 79 2d 73 74 72 69 6e 67 20 6c 73 74 29 etty-string lst)
3340: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
3350: 28 74 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 28 (t).. (if (not (
3360: 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 20 20 vector? t))..
3370: 20 20 28 63 6f 6e 63 20 74 29 0a 09 20 20 20 20 (conc t)..
3380: 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d (conc (db:test-
3390: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 get-testname t)
33a0: 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ":" (db:test-get
33b0: 2d 73 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 -state t) "/" (d
33c0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
33d0: 73 20 74 29 29 29 29 0a 20 20 20 20 20 20 20 6c s t)))). l
33e0: 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 st))..(define (r
33f0: 75 6e 73 3a 6d 61 6b 65 2d 66 75 6c 6c 2d 74 65 uns:make-full-te
3400: 73 74 2d 6e 61 6d 65 20 74 65 73 74 6e 61 6d 65 st-name testname
3410: 20 69 74 65 6d 70 61 74 68 29 0a 20 20 28 69 66 itempath). (if
3420: 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 (equal? itempat
3430: 68 20 22 22 29 20 74 65 73 74 6e 61 6d 65 20 28 h "") testname (
3440: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
3450: 22 20 69 74 65 6d 70 61 74 68 29 29 29 0a 0a 28 " itempath)))..(
3460: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 define (runs:que
3470: 75 65 2d 6e 65 78 74 2d 68 65 64 20 74 61 6c 20 ue-next-hed tal
3480: 72 65 67 20 6e 20 72 65 67 66 75 6c 29 0a 20 20 reg n regful).
3490: 28 69 66 20 72 65 67 66 75 6c 0a 20 20 20 20 20 (if regful.
34a0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 67 29 (if (null? reg)
34b0: 20 3b 3b 20 64 6f 65 73 6e 27 74 20 6d 61 6b 65 ;; doesn't make
34c0: 20 73 65 6e 73 65 2c 20 74 68 69 73 20 69 73 20 sense, this is
34d0: 70 72 6f 62 61 62 6c 79 20 4e 4f 54 20 74 68 65 probably NOT the
34e0: 20 70 72 6f 62 6c 65 6d 20 6f 66 20 74 68 65 20 problem of the
34f0: 63 61 72 0a 09 20 20 28 63 61 72 20 74 61 6c 29 car.. (car tal)
3500: 0a 09 20 20 28 63 61 72 20 72 65 67 29 29 0a 20 .. (car reg)).
3510: 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 29 29 (car tal)))
3520: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
3530: 71 75 65 75 65 2d 6e 65 78 74 2d 74 61 6c 20 74 queue-next-tal t
3540: 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 6c 29 al reg n regful)
3550: 0a 20 20 28 69 66 20 72 65 67 66 75 6c 0a 20 20 . (if regful.
3560: 20 20 20 20 74 61 6c 0a 20 20 20 20 20 20 28 6c tal. (l
3570: 65 74 20 28 28 6e 65 77 74 61 6c 20 28 63 64 72 et ((newtal (cdr
3580: 20 74 61 6c 29 29 29 0a 09 28 69 66 20 28 6e 75 tal)))..(if (nu
3590: 6c 6c 3f 20 6e 65 77 74 61 6c 29 0a 09 20 20 20 ll? newtal)..
35a0: 20 72 65 67 0a 09 20 20 20 20 6e 65 77 74 61 6c reg.. newtal
35b0: 0a 09 20 20 20 20 29 29 29 29 0a 0a 28 64 65 66 .. ))))..(def
35c0: 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d ine (runs:queue-
35d0: 6e 65 78 74 2d 72 65 67 20 74 61 6c 20 72 65 67 next-reg tal reg
35e0: 20 6e 20 72 65 67 66 75 6c 29 0a 20 20 28 69 66 n regful). (if
35f0: 20 72 65 67 66 75 6c 0a 20 20 20 20 20 20 28 63 regful. (c
3600: 64 72 20 72 65 67 29 0a 20 20 20 20 20 20 28 69 dr reg). (i
3610: 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 74 f (eq? (length t
3620: 61 6c 29 20 31 29 0a 09 20 20 27 28 29 0a 09 20 al) 1).. '()..
3630: 20 72 65 67 29 29 29 0a 0a 28 69 6e 63 6c 75 64 reg)))..(includ
3640: 65 20 22 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 e "run-tests-que
3650: 75 65 2d 63 6c 61 73 73 69 63 2e 73 63 6d 22 29 ue-classic.scm")
3660: 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 6e 2d 74 .(include "run-t
3670: 65 73 74 73 2d 71 75 65 75 65 2d 6e 65 77 2e 73 ests-queue-new.s
3680: 63 6d 22 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d cm")..;; parent-
3690: 74 65 73 74 20 69 73 20 74 68 65 72 65 20 61 73 test is there as
36a0: 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 a placeholder f
36b0: 6f 72 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 or when parent-t
36c0: 65 73 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 ests can be run
36d0: 61 73 20 61 20 73 65 74 75 70 20 73 74 65 70 0a as a setup step.
36e0: 28 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 (define (run:tes
36f0: 74 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 t run-id run-inf
3700: 6f 20 6b 65 79 2d 76 61 6c 73 20 72 75 6e 6e 61 o key-vals runna
3710: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 me test-record f
3720: 6c 61 67 73 20 70 61 72 65 6e 74 2d 74 65 73 74 lags parent-test
3730: 29 0a 20 20 3b 3b 20 41 6c 6c 20 74 68 65 73 65 ). ;; All these
3740: 20 76 61 72 73 20 6d 69 67 68 74 20 62 65 20 72 vars might be r
3750: 65 66 65 72 65 6e 63 65 64 20 62 79 20 74 68 65 eferenced by the
3760: 20 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c 65 testconfig file
3770: 20 72 65 61 64 65 72 0a 20 20 28 6c 65 74 2a 20 reader. (let*
3780: 28 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 28 ((test-name (
3790: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
37a0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 get-testname t
37b0: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
37c0: 74 65 73 74 2d 77 61 69 74 6f 6e 73 20 28 74 65 test-waitons (te
37d0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 sts:testqueue-ge
37e0: 74 2d 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 t-waitons tes
37f0: 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 65 t-record)).. (te
3800: 73 74 2d 63 6f 6e 66 20 20 20 20 28 74 65 73 74 st-conf (test
3810: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3820: 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d testconfig test-
3830: 72 65 63 6f 72 64 29 29 0a 09 20 28 69 74 65 6d record)).. (item
3840: 64 61 74 20 20 20 20 20 20 28 74 65 73 74 73 3a dat (tests:
3850: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 testqueue-get-it
3860: 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 emdat test-re
3870: 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 70 cord)).. (test-p
3880: 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f ath (conc *to
3890: 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 ppath* "/tests/"
38a0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 20 3b 3b 20 test-name)) ;;
38b0: 63 6f 75 6c 64 20 75 73 65 20 74 65 73 74 73 3a could use tests:
38c0: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 68 get-testconfig h
38d0: 65 72 65 20 2e 2e 2e 0a 09 20 28 66 6f 72 63 65 ere ..... (force
38e0: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
38f0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
3900: 66 6c 61 67 73 20 22 2d 66 6f 72 63 65 22 20 23 flags "-force" #
3910: 66 29 29 0a 09 20 28 72 65 72 75 6e 20 20 20 20 f)).. (rerun
3920: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
3930: 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 ref/default flag
3940: 73 20 22 2d 72 65 72 75 6e 22 20 23 66 29 29 0a s "-rerun" #f)).
3950: 09 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 20 20 . (keepgoing
3960: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
3970: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
3980: 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 0a keepgoing" #f)).
3990: 09 20 28 69 74 65 6d 2d 70 61 74 68 20 20 20 20 . (item-path
39a0: 20 22 22 29 0a 09 20 28 64 62 20 20 20 20 20 20 "").. (db
39b0: 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 64 #f)). (d
39c0: 65 62 75 67 3a 70 72 69 6e 74 20 34 0a 09 09 20 ebug:print 4...
39d0: 22 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 22 20 "test-config: "
39e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
39f0: 73 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a 09 09 st test-conf)...
3a00: 20 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 3a 20 "\n itemdat:
3a10: 22 20 69 74 65 6d 64 61 74 0a 09 09 20 29 0a 20 " itemdat... ).
3a20: 20 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 74 ;; setting it
3a30: 65 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 74 20 emdat to a list
3a40: 69 66 20 69 74 20 69 73 20 23 66 0a 20 20 20 20 if it is #f.
3a50: 28 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 74 (if (not itemdat
3a60: 29 28 73 65 74 21 20 69 74 65 6d 64 61 74 20 27 )(set! itemdat '
3a70: 28 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 69 ())). (set! i
3a80: 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c tem-path (item-l
3a90: 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 ist->path itemda
3aa0: 74 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 t)). (debug:p
3ab0: 72 69 6e 74 20 32 20 22 41 74 74 65 6d 70 74 69 rint 2 "Attempti
3ac0: 6e 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 ng to launch tes
3ad0: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 28 69 t " test-name (i
3ae0: 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 f (equal? item-p
3af0: 61 74 68 20 22 2f 22 29 20 22 2f 22 20 69 74 65 ath "/") "/" ite
3b00: 6d 2d 70 61 74 68 29 29 0a 20 20 20 20 28 73 65 m-path)). (se
3b10: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 tenv "MT_TEST_NA
3b20: 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b ME" test-name) ;
3b30: 3b 20 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 ; . (setenv "
3b40: 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 MT_RUNNAME" ru
3b50: 6e 6e 61 6d 65 29 0a 20 20 20 20 28 73 65 74 2d nname). (set-
3b60: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
3b70: 73 20 72 75 6e 2d 69 64 20 69 6e 72 75 6e 6e 61 s run-id inrunna
3b80: 6d 65 3a 20 72 75 6e 6e 61 6d 65 29 20 3b 3b 20 me: runname) ;;
3b90: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
3ba0: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
3bb0: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 20 hing process.
3bc0: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
3bd0: 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 20 ry *toppath*)..
3be0: 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 68 ;; Here is wh
3bf0: 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 ere the test_met
3c00: 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 20 a table is best
3c10: 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 59 updated. ;; Y
3c20: 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 20 es, another use
3c30: 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 20 of a global for
3c40: 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 20 caching. Need a
3c50: 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 20 better way?.
3c60: 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 (if (not (hash-t
3c70: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3c80: 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 *test-meta-upda
3c90: 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 ted* test-name #
3ca0: 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 67 f)). (beg
3cb0: 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 62 in.. (hash-tab
3cc0: 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d 65 le-set! *test-me
3cd0: 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 ta-updated* test
3ce0: 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 20 -name #t).
3cf0: 20 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 74 (runs:updat
3d00: 65 2d 74 65 73 74 5f 6d 65 74 61 20 74 65 73 74 e-test_meta test
3d10: 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 -name test-conf)
3d20: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 28 )). . ;; (
3d30: 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 61 74 29 lambda (itemdat)
3d40: 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 73 20 ;;; ((ripeness
3d50: 22 6f 76 65 72 72 69 70 65 22 29 20 28 74 65 6d "overripe") (tem
3d60: 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c 22 29 perature "cool")
3d70: 20 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d 65 72 (season "summer
3d80: 22 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 ")). (let* ((
3d90: 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 28 73 new-test-path (s
3da0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
3db0: 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 61 74 e (cons test-pat
3dc0: 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 65 6d h (map cadr item
3dd0: 64 61 74 29 29 20 22 2f 22 29 29 0a 09 20 20 20 dat)) "/"))..
3de0: 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 28 (new-test-name (
3df0: 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d if (equal? item-
3e00: 70 61 74 68 20 22 22 29 20 74 65 73 74 2d 6e 61 path "") test-na
3e10: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e 61 me (conc test-na
3e20: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
3e30: 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 65 64 ))) ;; just need
3e40: 20 69 74 20 74 6f 20 62 65 20 75 6e 69 71 75 65 it to be unique
3e50: 0a 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 .. (test-id
3e60: 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
3e70: 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 73 74 2d run db:get-test-
3e80: 69 64 20 23 66 20 20 72 75 6e 2d 69 64 20 74 65 id #f run-id te
3e90: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
3ea0: 68 29 29 0a 09 20 20 20 28 74 65 73 74 64 61 74 h)).. (testdat
3eb0: 20 20 20 20 20 20 20 28 63 64 62 3a 67 65 74 2d (cdb:get-
3ec0: 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 test-info-by-id
3ed0: 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 *runremote* test
3ee0: 2d 69 64 29 29 29 0a 20 20 20 20 20 20 28 69 66 -id))). (if
3ef0: 20 28 6e 6f 74 20 74 65 73 74 64 61 74 29 0a 09 (not testdat)..
3f00: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 3b 3b (begin.. ;;
3f10: 20 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 ensure that the
3f20: 20 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 path exists bef
3f30: 6f 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 ore registering
3f40: 74 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b the test.. ;;
3f50: 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 NOPE: Cannot! D
3f60: 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 on't know yet wh
3f70: 69 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 ich disk area wi
3f80: 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e ll be assigned..
3f90: 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 .... ;; (syst
3fa0: 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 em (conc "mkdir
3fb0: 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 -p " new-test-pa
3fc0: 74 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 th)).. ;;..
3fd0: 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 ;; (open-run-c
3fe0: 6c 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 lose tests:regis
3ff0: 74 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d ter-test db run-
4000: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
4010: 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a m-path).. ;;.
4020: 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 . ;; NB// for
4030: 20 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e the above line.
4040: 20 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 I want the test
4050: 20 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 to be registere
4060: 64 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 d long before th
4070: 69 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 is routine gets
4080: 63 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a called!.. ;;.
4090: 09 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d . (set! test-
40a0: 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f id (open-run-clo
40b0: 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 se db:get-test-i
40c0: 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 d db run-id test
40d0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
40e0: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
40f0: 74 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 69 test-id)...(begi
4100: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
4110: 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 74 nt 2 "WARN: Test
4120: 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 64 not pre-created
4130: 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 ? test-name=" te
4140: 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d st-name ", item-
4150: 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 68 path=" item-path
4160: 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ", run-id=" run
4170: 2d 69 64 29 0a 09 09 20 20 28 63 64 62 3a 74 65 -id)... (cdb:te
4180: 73 74 73 2d 72 65 67 69 73 74 65 72 2d 74 65 73 sts-register-tes
4190: 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 t *runremote* ru
41a0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
41b0: 74 65 6d 2d 70 61 74 68 29 0a 09 09 20 20 28 73 tem-path)... (s
41c0: 65 74 21 20 74 65 73 74 2d 69 64 20 28 6f 70 65 et! test-id (ope
41d0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
41e0: 65 74 2d 74 65 73 74 2d 69 64 20 64 62 20 72 75 et-test-id db ru
41f0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
4200: 74 65 6d 2d 70 61 74 68 29 29 29 29 0a 09 20 20 tem-path))))..
4210: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4220: 6e 66 6f 20 34 20 22 74 65 73 74 2d 69 64 3d 22 nfo 4 "test-id="
4230: 20 74 65 73 74 2d 69 64 20 22 2c 20 72 75 6e 2d test-id ", run-
4240: 69 64 3d 22 20 72 75 6e 2d 69 64 20 22 2c 20 74 id=" run-id ", t
4250: 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d est-name=" test-
4260: 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 name ", item-pat
4270: 68 3d 5c 22 22 20 69 74 65 6d 2d 70 61 74 68 20 h=\"" item-path
4280: 22 5c 22 22 29 0a 09 20 20 20 20 28 73 65 74 21 "\"").. (set!
4290: 20 74 65 73 74 64 61 74 20 28 63 64 62 3a 67 65 testdat (cdb:ge
42a0: 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
42b0: 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 74 65 d *runremote* te
42c0: 73 74 2d 69 64 29 29 29 29 0a 20 20 20 20 20 20 st-id)))).
42d0: 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 64 (set! test-id (d
42e0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
42f0: 73 74 64 61 74 29 29 0a 20 20 20 20 20 20 28 63 stdat)). (c
4300: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
4310: 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 20 test-path).
4320: 20 28 63 61 73 65 20 28 69 66 20 66 6f 72 63 65 (case (if force
4330: 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ;; (args:get-ar
4340: 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 27 4e g "-force")...'N
4350: 4f 54 5f 53 54 41 52 54 45 44 0a 09 09 28 69 66 OT_STARTED...(if
4360: 20 74 65 73 74 64 61 74 0a 09 09 20 20 20 20 28 testdat... (
4370: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
4380: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
4390: 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 20 27 estdat))... '
43a0: 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 failed-to-insert
43b0: 29 29 0a 09 28 28 66 61 69 6c 65 64 2d 74 6f 2d ))..((failed-to-
43c0: 69 6e 73 65 72 74 29 0a 09 20 28 64 65 62 75 67 insert).. (debug
43d0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
43e0: 20 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 65 72 Failed to inser
43f0: 74 20 74 68 65 20 72 65 63 6f 72 64 20 69 6e 74 t the record int
4400: 6f 20 74 68 65 20 64 62 22 29 29 0a 09 28 28 4e o the db"))..((N
4410: 4f 54 5f 53 54 41 52 54 45 44 20 43 4f 4d 50 4c OT_STARTED COMPL
4420: 45 54 45 44 20 44 45 4c 45 54 45 44 29 0a 09 20 ETED DELETED)..
4430: 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 67 20 23 (let ((runflag #
4440: 66 29 29 0a 09 20 20 20 28 63 6f 6e 64 0a 09 20 f)).. (cond..
4450: 20 20 20 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 ;; -force, ru
4460: 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 n no matter what
4470: 0a 09 20 20 20 20 28 66 6f 72 63 65 20 28 73 65 .. (force (se
4480: 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a t! runflag #t)).
4490: 09 20 20 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 . ;; NOT_STAR
44a0: 54 45 44 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 TED, run no matt
44b0: 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 28 6d er what.. ((m
44c0: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
44d0: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 27 state testdat) '
44e0: 28 22 44 45 4c 45 54 45 44 22 20 22 4e 4f 54 5f ("DELETED" "NOT_
44f0: 53 54 41 52 54 45 44 22 29 29 28 73 65 74 21 20 STARTED"))(set!
4500: 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 runflag #t))..
4510: 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 72 75 6e 20 ;; not -rerun
4520: 61 6e 64 20 50 41 53 53 2c 20 57 41 52 4e 20 6f and PASS, WARN o
4530: 72 20 43 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 72 r CHECK, do no r
4540: 75 6e 0a 09 20 20 20 20 28 28 61 6e 64 20 28 6f un.. ((and (o
4550: 72 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 r (not rerun)...
4560: 20 20 20 20 20 20 6b 65 65 70 67 6f 69 6e 67 29 keepgoing)
4570: 0a 09 09 20 20 3b 3b 20 52 65 71 75 69 72 65 20 ... ;; Require
4580: 74 6f 20 66 6f 72 63 65 20 72 65 2d 72 75 6e 20 to force re-run
4590: 66 6f 72 20 43 4f 4d 50 4c 45 54 45 44 20 6f 72 for COMPLETED or
45a0: 20 2a 61 6e 79 74 68 69 6e 67 2a 20 2b 20 50 41 *anything* + PA
45b0: 53 53 2c 57 41 52 4e 20 6f 72 20 43 48 45 43 4b SS,WARN or CHECK
45c0: 0a 09 09 20 20 28 6f 72 20 28 6d 65 6d 62 65 72 ... (or (member
45d0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
45e0: 73 20 74 65 73 74 64 61 74 29 20 27 28 22 50 41 s testdat) '("PA
45f0: 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 SS" "WARN" "CHEC
4600: 4b 22 20 22 53 4b 49 50 22 29 29 0a 09 09 20 20 K" "SKIP"))...
4610: 20 20 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 (member (tes
4620: 74 3a 67 65 74 2d 73 74 61 74 65 20 20 74 65 73 t:get-state tes
4630: 74 64 61 74 29 20 27 28 22 43 4f 4d 50 4c 45 54 tdat) '("COMPLET
4640: 45 44 22 29 29 29 29 20 0a 09 20 20 20 20 20 28 ED")))) .. (
4650: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4660: 20 32 20 22 72 75 6e 6e 69 6e 67 20 74 65 73 74 2 "running test
4670: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 " test-name "/"
4680: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 73 75 70 item-path " sup
4690: 70 72 65 73 73 65 64 20 61 73 20 69 74 20 69 73 pressed as it is
46a0: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
46b0: 74 65 20 74 65 73 74 64 61 74 29 20 22 20 61 6e te testdat) " an
46c0: 64 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 d " (test:get-st
46d0: 61 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 atus testdat))..
46e0: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
46f0: 61 67 20 23 66 29 29 0a 09 20 20 20 20 3b 3b 20 ag #f)).. ;;
4700: 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 74 75 -rerun and statu
4710: 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 s is one of the
4720: 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 69 74 specifed, run it
4730: 0a 09 20 20 20 20 28 28 61 6e 64 20 72 65 72 75 .. ((and reru
4740: 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 72 65 n... (let* ((re
4750: 72 75 6e 6c 73 74 20 20 20 28 73 74 72 69 6e 67 runlst (string
4760: 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 22 2c 22 -split rerun ","
4770: 29 29 0a 09 09 09 20 28 6d 75 73 74 2d 72 65 72 )).... (must-rer
4780: 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 un (member (test
4790: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
47a0: 64 61 74 29 20 72 65 72 75 6e 6c 73 74 29 29 29 dat) rerunlst)))
47b0: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
47c0: 69 6e 74 2d 69 6e 66 6f 20 33 20 22 2d 72 65 72 int-info 3 "-rer
47d0: 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 72 75 6e un list: " rerun
47e0: 20 22 2c 20 74 65 73 74 2d 73 74 61 74 75 73 3a ", test-status:
47f0: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
4800: 74 75 73 20 74 65 73 74 64 61 74 29 22 2c 20 6d tus testdat)", m
4810: 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 6d 75 73 ust-rerun: " mus
4820: 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 20 20 6d t-rerun)... m
4830: 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 20 20 20 ust-rerun))..
4840: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4850: 6e 66 6f 20 32 20 22 52 65 72 75 6e 20 66 6f 72 nfo 2 "Rerun for
4860: 63 65 64 20 66 6f 72 20 74 65 73 74 20 22 20 74 ced for test " t
4870: 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 est-name "/" ite
4880: 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 20 28 73 m-path).. (s
4890: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
48a0: 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f .. ;; -keepgo
48b0: 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 ing, do not reru
48c0: 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 28 61 6e n FAIL.. ((an
48d0: 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 20 20 d keepgoing...
48e0: 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 (member (test:ge
48f0: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
4900: 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a 09 20 ) '("FAIL")))..
4910: 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 (set! runfla
4920: 67 20 23 66 29 29 0a 09 20 20 20 20 28 28 61 6e g #f)).. ((an
4930: 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 d (not rerun)...
4940: 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a (member (test:
4950: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
4960: 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 6e 2f at) '("FAIL" "n/
4970: 61 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 a"))).. (set
4980: 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 ! runflag #t))..
4990: 20 20 20 20 28 65 6c 73 65 20 28 73 65 74 21 20 (else (set!
49a0: 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a 09 20 runflag #f)))..
49b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 36 (debug:print 6
49c0: 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e "RUNNING => run
49d0: 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 flag: " runflag
49e0: 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 73 74 " STATE: " (test
49f0: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
4a00: 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 22 20 at) " STATUS: "
4a10: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
4a20: 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 28 testdat)).. (
4a30: 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 if (not runflag)
4a40: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f .. (if (no
4a50: 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 t parent-test)..
4a60: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
4a70: 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 1 "NOTE: Not st
4a80: 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 6e 65 arting test " ne
4a90: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 w-test-name " as
4aa0: 20 69 74 20 69 73 20 73 74 61 74 65 20 5c 22 22 it is state \""
4ab0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
4ac0: 20 74 65 73 74 64 61 74 29 20 0a 09 09 09 09 22 testdat) ....."
4ad0: 5c 22 20 61 6e 64 20 73 74 61 74 75 73 20 5c 22 \" and status \"
4ae0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
4af0: 75 73 20 74 65 73 74 64 61 74 29 20 22 5c 22 2c us testdat) "\",
4b00: 20 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 22 20 use -rerun \""
4b10: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
4b20: 20 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 testdat).
4b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b40: 20 20 20 20 20 20 20 20 20 20 22 5c 22 20 6f 72 "\" or
4b50: 20 2d 66 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 -force to overr
4b60: 69 64 65 22 29 29 0a 09 20 20 20 20 20 20 20 3b ide")).. ;
4b70: 3b 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f 6e 67 65 ; NOTE: No longe
4b80: 72 20 62 65 20 63 68 65 63 6b 69 6e 67 20 70 72 r be checking pr
4b90: 65 72 65 71 75 69 73 69 74 65 73 20 68 65 72 65 erequisites here
4ba0: 21 20 57 69 6c 6c 20 6e 65 76 65 72 20 67 65 74 ! Will never get
4bb0: 20 68 65 72 65 20 75 6e 6c 65 73 73 20 70 72 65 here unless pre
4bc0: 72 65 71 73 20 61 72 65 0a 09 20 20 20 20 20 20 reqs are..
4bd0: 20 3b 3b 20 20 20 20 20 20 20 61 6c 72 65 61 64 ;; alread
4be0: 79 20 6d 65 74 2e 0a 09 20 20 20 20 20 20 20 3b y met... ;
4bf0: 3b 20 54 68 69 73 20 77 6f 75 6c 64 20 62 65 20 ; This would be
4c00: 61 20 67 72 65 61 74 20 70 6c 61 63 65 20 74 6f a great place to
4c10: 20 64 6f 20 74 68 65 20 70 72 6f 63 65 73 73 2d do the process-
4c20: 66 6f 72 6b 0a 09 20 20 20 20 20 20 20 28 69 66 fork.. (if
4c30: 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 2d 74 65 (not (launch-te
4c40: 73 74 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 st test-id run-i
4c50: 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 2d 76 d run-info key-v
4c60: 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 als runname test
4c70: 2d 63 6f 6e 66 20 74 65 73 74 2d 6e 61 6d 65 20 -conf test-name
4c80: 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d 64 61 test-path itemda
4c90: 74 20 66 6c 61 67 73 29 29 0a 09 09 20 20 20 28 t flags))... (
4ca0: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 70 72 begin... (pr
4cb0: 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c int "ERROR: Fail
4cc0: 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 68 65 ed to launch the
4cd0: 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 20 61 test. Exiting a
4ce0: 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 69 62 s soon as possib
4cf0: 6c 65 22 29 0a 09 09 20 20 20 20 20 28 73 65 74 le")... (set
4d00: 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 ! *globalexitsta
4d10: 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 20 20 tus* 1) ;; ...
4d20: 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e (process-sign
4d30: 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 al (current-proc
4d40: 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b ess-id) signal/k
4d50: 69 6c 6c 29 29 29 29 29 29 0a 09 28 28 4b 49 4c ill))))))..((KIL
4d60: 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 3a 70 LED) .. (debug:p
4d70: 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 22 20 rint 1 "NOTE: "
4d80: 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 new-test-name "
4d90: 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 is already runni
4da0: 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c 69 63 ng or was explic
4db0: 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 65 20 tly killed, use
4dc0: 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e 63 68 -force to launch
4dd0: 20 69 74 2e 22 29 29 0a 09 28 28 4c 41 55 4e 43 it."))..((LAUNC
4de0: 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 HED REMOTEHOSTST
4df0: 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 20 0a 09 ART RUNNING) ..
4e00: 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 (if (> (- (curr
4e10: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b 20 28 ent-seconds)(+ (
4e20: 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 65 6e db:test-get-even
4e30: 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 29 0a t_time testdat).
4e40: 09 09 09 09 20 20 20 20 20 20 20 28 64 62 3a 74 .... (db:t
4e50: 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 72 61 est-get-run_dura
4e60: 74 69 6f 6e 20 74 65 73 74 64 61 74 29 29 29 0a tion testdat))).
4e70: 09 09 36 30 30 29 20 3b 3b 20 69 2e 65 2e 20 6e ..600) ;; i.e. n
4e80: 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d 6f 72 o update for mor
4e90: 65 20 74 68 61 6e 20 36 30 30 20 73 65 63 6f 6e e than 600 secon
4ea0: 64 73 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a ds.. (begin.
4eb0: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
4ec0: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
4ed0: 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d Test " test-nam
4ee0: 65 20 22 20 61 70 70 65 61 72 73 20 74 6f 20 62 e " appears to b
4ef0: 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e 67 20 e dead. Forcing
4f00: 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e 43 4f it to state INCO
4f10: 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 74 75 MPLETE and statu
4f20: 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 09 s STUCK/DEAD")..
4f30: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 (tests:te
4f40: 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 74 st-set-status! t
4f50: 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 est-id "INCOMPLE
4f60: 54 45 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 TE" "STUCK/DEAD"
4f70: 20 22 54 65 73 74 20 69 73 20 73 74 75 63 6b 20 "Test is stuck
4f80: 6f 72 20 64 65 61 64 22 20 23 66 29 29 0a 09 20 or dead" #f))..
4f90: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4fa0: 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2 "NOTE: " test
4fb0: 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 -name " is alrea
4fc0: 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 dy running")))..
4fd0: 28 65 6c 73 65 20 20 20 20 20 20 20 28 64 65 62 (else (deb
4fe0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
4ff0: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 R: Failed to lau
5000: 6e 63 68 20 74 65 73 74 20 22 20 6e 65 77 2d 74 nch test " new-t
5010: 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 est-name ". Unre
5020: 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 20 22 cognised state "
5030: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
5040: 20 74 65 73 74 64 61 74 29 29 29 29 29 29 29 0a testdat))))))).
5050: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
5060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 =========.;; END
50a0: 20 4f 46 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b OF NEW STUFF.;;
50b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50f0: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
5100: 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 (get-dir-up-n di
5110: 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 28 r . params) . (
5120: 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 28 73 let ((dparts (s
5130: 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 tring-split dir
5140: 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 "/"))..(count
5150: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
5160: 73 29 20 31 20 28 63 61 72 20 70 61 72 61 6d 73 s) 1 (car params
5170: 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 )))). (conc "
5180: 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 /" (string-inter
5190: 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 20 20 sperse ..
51a0: 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 (take dparts (-
51b0: 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 (length dparts)
51c0: 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 20 20 count))..
51d0: 22 2f 22 29 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 "/")))).;; Remov
51e0: 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 e runs.;; fields
51f0: 20 61 72 65 20 70 61 73 73 69 6e 67 20 69 6e 20 are passing in
5200: 74 68 72 6f 75 67 68 20 0a 3b 3b 20 61 63 74 69 through .;; acti
5210: 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 65 6d 6f 76 on:.;; 'remov
5220: 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 20 27 73 65 e-runs.;; 'se
5230: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 0a 3b t-state-status.;
5240: 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 6f 75 6c 64 ;.;; NB// should
5250: 20 70 61 73 73 20 69 6e 20 6b 65 79 73 3f 0a 3b pass in keys?.;
5260: 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ;.(define (runs:
5270: 6f 70 65 72 61 74 65 2d 6f 6e 20 61 63 74 69 6f operate-on actio
5280: 6e 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 n runnamepatt te
5290: 73 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 stpatt #!key (st
52a0: 61 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 ate #f)(status #
52b0: 66 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 f)(new-state-sta
52c0: 74 75 73 20 23 66 29 29 0a 20 20 28 63 6f 6d 6d tus #f)). (comm
52d0: 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 on:clear-caches)
52e0: 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 ;; clear all ca
52f0: 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 ches. (let* ((d
5300: 62 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a b #f).
5310: 09 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 . (keys
5320: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
5330: 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db:get-keys db))
5340: 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 .. (rundat
5350: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
5360: 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 runs:get-runs-b
5370: 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 y-patt db keys r
5380: 75 6e 6e 61 6d 65 70 61 74 74 29 29 0a 09 20 28 unnamepatt)).. (
5390: 68 65 61 64 65 72 20 20 20 20 20 20 20 28 76 65 header (ve
53a0: 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 ctor-ref rundat
53b0: 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 0)).. (runs
53c0: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
53d0: 72 75 6e 64 61 74 20 31 29 29 0a 09 20 28 73 74 rundat 1)).. (st
53e0: 61 74 65 73 20 20 20 20 20 20 20 28 69 66 20 73 ates (if s
53f0: 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d 73 70 tate (string-sp
5400: 6c 69 74 20 73 74 61 74 65 20 20 22 2c 22 29 20 lit state ",")
5410: 27 28 29 29 29 0a 09 20 28 73 74 61 74 75 73 65 '())).. (statuse
5420: 73 20 20 20 20 20 28 69 66 20 73 74 61 74 75 73 s (if status
5430: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 (string-split s
5440: 74 61 74 75 73 20 22 2c 22 29 20 27 28 29 29 29 tatus ",") '()))
5450: 0a 09 20 28 73 74 61 74 65 2d 73 74 61 74 75 73 .. (state-status
5460: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6e 65 (if (string? ne
5470: 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 w-state-status)
5480: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6e 65 (string-split ne
5490: 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 22 w-state-status "
54a0: 2c 22 29 20 27 28 23 66 20 23 66 29 29 29 29 0a ,") '(#f #f)))).
54b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
54c0: 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 -info 4 "runs:op
54d0: 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 48 65 61 64 erate-on => Head
54e0: 65 72 3a 20 22 20 68 65 61 64 65 72 20 22 20 61 er: " header " a
54f0: 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 20 ction: " action
5500: 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 " new-state-stat
5510: 75 73 3a 20 22 20 6e 65 77 2d 73 74 61 74 65 2d us: " new-state-
5520: 73 74 61 74 75 73 29 0a 20 20 20 20 28 69 66 20 status). (if
5530: 28 3e 20 32 20 28 6c 65 6e 67 74 68 20 73 74 61 (> 2 (length sta
5540: 74 65 2d 73 74 61 74 75 73 29 29 0a 09 28 62 65 te-status))..(be
5550: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
5560: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 74 68 int 0 "ERROR: th
5570: 65 20 70 61 72 61 6d 65 74 65 72 20 74 6f 20 2d e parameter to -
5580: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
5590: 20 69 73 20 61 20 63 6f 6d 6d 61 20 64 65 6c 69 is a comma deli
55a0: 6d 69 74 65 64 20 73 74 72 69 6e 67 2e 20 45 2e mited string. E.
55b0: 67 2e 20 43 4f 4d 50 4c 45 54 45 44 2c 46 41 49 g. COMPLETED,FAI
55c0: 4c 22 29 0a 09 20 20 28 65 78 69 74 29 29 29 0a L").. (exit))).
55d0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
55e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 (lambda (run)
55f0: 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 . (let ((r
5600: 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 2d 69 6e unkey (string-in
5610: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 tersperse (map (
5620: 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 09 09 09 lambda (k)......
5630: 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 .(db:get-value-b
5640: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
5650: 64 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 20 der (vector-ref
5660: 6b 20 30 29 29 29 20 6b 65 79 73 29 20 22 2f 22 k 0))) keys) "/"
5670: 29 29 0a 09 20 20 20 20 20 28 64 69 72 73 2d 74 )).. (dirs-t
5680: 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 o-remove (make-h
5690: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 ash-table))).. (
56a0: 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 let* ((run-id
56b0: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
56c0: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
56d0: 64 65 72 20 22 69 64 22 29 29 0a 09 09 28 72 75 der "id"))...(ru
56e0: 6e 2d 73 74 61 74 65 20 28 64 62 3a 67 65 74 2d n-state (db:get-
56f0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
5700: 72 75 6e 20 68 65 61 64 65 72 20 22 73 74 61 74 run header "stat
5710: 65 22 29 29 0a 09 09 28 74 65 73 74 73 20 20 20 e"))...(tests
5720: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 (if (not (equa
5730: 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f l? run-state "lo
5740: 63 6b 65 64 22 29 29 0a 09 09 09 20 20 20 20 20 cked"))....
5750: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
5760: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 e db:get-tests-f
5770: 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 or-run db run-id
5780: 0a 09 09 09 09 09 09 20 20 20 20 20 20 74 65 73 ....... tes
5790: 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 tpatt states sta
57a0: 74 75 73 65 73 0a 09 09 09 09 09 09 20 20 20 20 tuses.......
57b0: 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 not-in: #f...
57c0: 09 09 09 09 20 20 20 20 20 20 73 6f 72 74 2d 62 .... sort-b
57d0: 79 3a 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a y: (case action.
57e0: 09 09 09 09 09 09 09 09 20 28 28 72 65 6d 6f 76 ........ ((remov
57f0: 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 69 72 29 e-runs) 'rundir)
5800: 0a 09 09 09 09 09 09 09 09 20 28 65 6c 73 65 20 ......... (else
5810: 20 20 20 20 20 20 20 20 20 27 65 76 65 6e 74 5f 'event_
5820: 74 69 6d 65 29 29 29 0a 09 09 09 20 20 20 20 20 time)))....
5830: 20 20 27 28 29 29 29 0a 09 09 28 6c 61 73 74 74 '()))...(lastt
5840: 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f path "/does/not/
5850: 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 29 29 0a exist/I/hope")).
5860: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
5870: 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a 6f 70 -info 4 "runs:op
5880: 65 72 61 74 65 2d 6f 6e 20 72 75 6e 3d 22 20 72 erate-on run=" r
5890: 75 6e 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 un ", header=" h
58a0: 65 61 64 65 72 29 0a 09 20 20 20 28 69 66 20 28 eader).. (if (
58b0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 73 not (null? tests
58c0: 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 )).. (begi
58d0: 6e 0a 09 09 20 28 63 61 73 65 20 61 63 74 69 6f n... (case actio
58e0: 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f 76 65 2d n... ((remove-
58f0: 72 75 6e 73 29 0a 09 09 20 20 20 20 28 64 65 62 runs)... (deb
5900: 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f ug:print 1 "Remo
5910: 76 69 6e 67 20 74 65 73 74 73 20 66 6f 72 20 72 ving tests for r
5920: 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
5930: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
5940: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
5950: 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 der "runname")))
5960: 0a 09 09 20 20 20 28 28 73 65 74 2d 73 74 61 74 ... ((set-stat
5970: 65 2d 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 e-status)...
5980: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
5990: 4d 6f 64 69 66 79 69 6e 67 20 73 74 61 74 65 20 Modifying state
59a0: 61 6e 64 20 73 74 61 75 73 20 66 6f 72 20 74 65 and staus for te
59b0: 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 sts for run: " r
59c0: 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 unkey " " (db:ge
59d0: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
59e0: 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 r run header "ru
59f0: 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 nname")))... (
5a00: 28 70 72 69 6e 74 2d 72 75 6e 29 0a 09 09 20 20 (print-run)...
5a10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
5a20: 20 22 50 72 69 6e 74 69 6e 67 20 69 6e 66 6f 20 "Printing info
5a30: 66 6f 72 20 72 75 6e 20 22 20 72 75 6e 6b 65 79 for run " runkey
5a40: 20 22 2c 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c ", run=" run ",
5a50: 20 74 65 73 74 73 3d 22 20 74 65 73 74 73 20 22 tests=" tests "
5a60: 2c 20 68 65 61 64 65 72 3d 22 20 68 65 61 64 65 , header=" heade
5a70: 72 29 0a 09 09 20 20 20 20 61 63 74 69 6f 6e 29 r)... action)
5a80: 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 20 20 ... (else...
5a90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
5aa0: 6e 66 6f 20 30 20 22 61 63 74 69 6f 6e 20 6e 6f nfo 0 "action no
5ab0: 74 20 72 65 63 6f 67 6e 69 73 65 64 20 22 20 61 t recognised " a
5ac0: 63 74 69 6f 6e 29 29 29 0a 09 09 20 28 66 6f 72 ction)))... (for
5ad0: 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 64 -each... (lambd
5ae0: 61 20 28 74 65 73 74 29 0a 09 09 20 20 20 20 28 a (test)... (
5af0: 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 let* ((item-path
5b00: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
5b10: 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 0a 09 em-path test))..
5b20: 09 09 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 20 .. (test-name
5b30: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
5b40: 74 6e 61 6d 65 20 74 65 73 74 29 29 0a 09 09 09 tname test))....
5b50: 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 28 64 (run-dir (d
5b60: 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 b:test-get-rundi
5b70: 72 20 74 65 73 74 29 29 20 20 20 20 3b 3b 20 72 r test)) ;; r
5b80: 75 6e 20 64 69 72 20 69 73 20 66 72 6f 6d 20 74 un dir is from t
5b90: 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a 09 09 09 he link tree....
5ba0: 20 20 20 28 72 65 61 6c 2d 64 69 72 20 20 28 69 (real-dir (i
5bb0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
5bc0: 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 20 20 run-dir)......
5bd0: 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d (resolve-pathnam
5be0: 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 e run-dir)......
5bf0: 20 20 23 66 29 29 0a 09 09 09 20 20 20 28 74 65 #f)).... (te
5c00: 73 74 2d 69 64 20 20 20 28 64 62 3a 74 65 73 74 st-id (db:test
5c10: 2d 67 65 74 2d 69 64 20 74 65 73 74 29 29 29 0a -get-id test))).
5c20: 09 09 20 20 20 20 20 20 3b 3b 20 20 20 28 74 64 .. ;; (td
5c30: 62 20 20 20 20 20 20 20 28 64 62 3a 6f 70 65 6e b (db:open
5c40: 2d 74 65 73 74 2d 64 62 20 72 75 6e 2d 64 69 72 -test-db run-dir
5c50: 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 )))... (deb
5c60: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
5c70: 22 74 65 73 74 3d 22 20 74 65 73 74 29 20 3b 3b "test=" test) ;;
5c80: 20 20 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 " (db:test-ge
5c90: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 t-testname test)
5ca0: 20 22 20 69 64 3a 20 22 20 28 64 62 3a 74 65 73 " id: " (db:tes
5cb0: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 22 t-get-id test) "
5cc0: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 " item-path " a
5cd0: 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 29 ction: " action)
5ce0: 0a 09 09 20 20 20 20 20 20 28 63 61 73 65 20 61 ... (case a
5cf0: 63 74 69 6f 6e 0a 09 09 09 28 28 72 65 6d 6f 76 ction....((remov
5d00: 65 2d 72 75 6e 73 29 20 3b 3b 20 74 68 65 20 74 e-runs) ;; the t
5d10: 64 62 20 69 73 20 66 6f 72 20 66 75 74 75 72 65 db is for future
5d20: 20 70 6f 73 73 69 62 6c 65 2e 20 0a 09 09 09 20 possible. ....
5d30: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
5d40: 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 72 db:delete-test-r
5d50: 65 63 6f 72 64 73 20 64 62 20 23 66 20 28 64 62 ecords db #f (db
5d60: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
5d70: 74 29 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 t)).... (debug:p
5d80: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 41 74 74 rint-info 1 "Att
5d90: 65 6d 70 74 69 6e 67 20 74 6f 20 72 65 6d 6f 76 empting to remov
5da0: 65 20 22 20 28 69 66 20 72 65 61 6c 2d 64 69 72 e " (if real-dir
5db0: 20 28 63 6f 6e 63 20 22 20 64 69 72 20 22 20 72 (conc " dir " r
5dc0: 65 61 6c 2d 64 69 72 20 22 20 61 6e 64 20 22 29 eal-dir " and ")
5dd0: 20 22 22 29 20 22 20 6c 69 6e 6b 20 22 20 72 75 "") " link " ru
5de0: 6e 2d 64 69 72 29 0a 09 09 09 20 28 69 66 20 28 n-dir).... (if (
5df0: 61 6e 64 20 72 65 61 6c 2d 64 69 72 20 0a 09 09 and real-dir ...
5e00: 09 09 20 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c .. (> (string-l
5e10: 65 6e 67 74 68 20 72 65 61 6c 2d 64 69 72 29 20 ength real-dir)
5e20: 35 29 0a 09 09 09 09 20 20 28 66 69 6c 65 2d 65 5)..... (file-e
5e30: 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 xists? real-dir)
5e40: 29 20 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 ) ;; bad heurist
5e50: 69 63 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 ic but should pr
5e60: 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 event /tmp /home
5e70: 20 65 74 63 2e 0a 09 09 09 20 20 20 20 20 28 62 etc..... (b
5e80: 65 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 28 28 72 egin ;; let* ((r
5e90: 65 61 6c 70 61 74 68 20 28 72 65 73 6f 6c 76 65 ealpath (resolve
5ea0: 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 -pathname run-di
5eb0: 72 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 r))).... (
5ec0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5ed0: 20 31 20 22 52 65 63 75 72 73 69 76 65 6c 79 20 1 "Recursively
5ee0: 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d removing " real-
5ef0: 64 69 72 29 0a 09 09 09 20 20 20 20 20 20 20 28 dir).... (
5f00: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
5f10: 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 09 20 real-dir).....
5f20: 20 20 28 69 66 20 28 3e 20 28 73 79 73 74 65 6d (if (> (system
5f30: 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 (conc "rm -rf "
5f40: 20 72 65 61 6c 2d 64 69 72 29 29 20 30 29 0a 09 real-dir)) 0)..
5f50: 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
5f60: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
5f70: 20 54 68 65 72 65 20 77 61 73 20 61 20 70 72 6f There was a pro
5f80: 62 6c 65 6d 20 72 65 6d 6f 76 69 6e 67 20 22 20 blem removing "
5f90: 72 65 61 6c 2d 64 69 72 20 22 20 77 69 74 68 20 real-dir " with
5fa0: 72 6d 20 2d 66 22 29 29 0a 09 09 09 09 20 20 20 rm -f")).....
5fb0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
5fc0: 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 20 64 69 WARNING: test di
5fd0: 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 61 r " real-dir " a
5fe0: 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 20 65 78 ppears to not ex
5ff0: 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 72 65 ist or is not re
6000: 61 64 61 62 6c 65 22 29 29 29 0a 09 09 09 20 20 adable")))....
6010: 20 20 20 28 69 66 20 72 65 61 6c 2d 64 69 72 20 (if real-dir
6020: 0a 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 ..... (debug:pri
6030: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 nt 0 "WARNING: d
6040: 69 72 65 63 74 6f 72 79 20 22 20 72 65 61 6c 2d irectory " real-
6050: 64 69 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 dir " does not e
6060: 78 69 73 74 22 29 0a 09 09 09 09 20 28 64 65 62 xist")..... (deb
6070: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
6080: 49 4e 47 3a 20 6e 6f 20 72 65 61 6c 20 64 69 72 ING: no real dir
6090: 65 63 74 6f 72 79 20 63 6f 72 72 6f 73 70 6f 6e ectory corrospon
60a0: 64 69 6e 67 20 74 6f 20 6c 69 6e 6b 20 22 20 72 ding to link " r
60b0: 75 6e 2d 64 69 72 20 22 2c 20 6e 6f 74 68 69 6e un-dir ", nothin
60c0: 67 20 64 6f 6e 65 22 29 29 29 0a 09 09 09 20 28 g done"))).... (
60d0: 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e if (symbolic-lin
60e0: 6b 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 k? run-dir)....
60f0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 (begin....
6100: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6110: 74 2d 69 6e 66 6f 20 31 20 22 52 65 6d 6f 76 69 t-info 1 "Removi
6120: 6e 67 20 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e ng symlink " run
6130: 2d 64 69 72 29 0a 09 09 09 20 20 20 20 20 20 20 -dir)....
6140: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
6150: 6e 73 0a 09 09 09 09 65 78 6e 0a 09 09 09 09 28 ns.....exn.....(
6160: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
6170: 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 6f RROR: Failed to
6180: 20 72 65 6d 6f 76 65 20 73 79 6d 6c 69 6e 6b 20 remove symlink
6190: 22 20 72 75 6e 2d 64 69 72 20 28 28 63 6f 6e 64 " run-dir ((cond
61a0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
61b0: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
61c0: 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c 20 61 ssage) exn) ", a
61d0: 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 6f 6e ttempting to con
61e0: 74 69 6e 75 65 22 29 0a 09 09 09 09 28 64 65 6c tinue").....(del
61f0: 65 74 65 2d 66 69 6c 65 20 72 75 6e 2d 64 69 72 ete-file run-dir
6200: 29 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 ))).... (if
6210: 28 64 69 72 65 63 74 6f 72 79 3f 20 72 75 6e 2d (directory? run-
6220: 64 69 72 29 0a 09 09 09 09 20 28 69 66 20 28 3e dir)..... (if (>
6230: 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 (directory-fold
6240: 20 28 6c 61 6d 62 64 61 20 28 66 20 78 29 28 2b (lambda (f x)(+
6250: 20 31 20 78 29 29 20 30 20 72 75 6e 2d 64 69 72 1 x)) 0 run-dir
6260: 29 20 30 29 0a 09 09 09 09 20 20 20 20 20 28 64 ) 0)..... (d
6270: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
6280: 52 4e 49 4e 47 3a 20 72 65 66 75 73 69 6e 67 20 RNING: refusing
6290: 74 6f 20 72 65 6d 6f 76 65 20 22 20 72 75 6e 2d to remove " run-
62a0: 64 69 72 20 22 20 61 73 20 69 74 20 69 73 20 6e dir " as it is n
62b0: 6f 74 20 65 6d 70 74 79 22 29 0a 09 09 09 09 20 ot empty").....
62c0: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
62d0: 65 70 74 69 6f 6e 73 0a 09 09 09 09 20 20 20 20 eptions.....
62e0: 20 20 20 65 78 6e 0a 09 09 09 09 20 20 20 20 20 exn.....
62f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
6300: 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 "ERROR: Failed
6310: 20 74 6f 20 72 65 6d 6f 76 65 20 64 69 72 65 63 to remove direc
6320: 74 6f 72 79 20 22 20 72 75 6e 2d 64 69 72 20 28 tory " run-dir (
6330: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
6340: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
6350: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
6360: 20 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 ", attempting t
6370: 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 09 09 o continue")....
6380: 09 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d . (delete-
6390: 64 69 72 65 63 74 6f 72 79 20 72 75 6e 2d 64 69 directory run-di
63a0: 72 29 29 29 0a 09 09 09 09 20 28 69 66 20 72 75 r)))..... (if ru
63b0: 6e 2d 64 69 72 0a 09 09 09 09 20 20 20 20 20 28 n-dir..... (
63c0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
63d0: 41 52 4e 49 4e 47 3a 20 6e 6f 74 20 72 65 6d 6f ARNING: not remo
63e0: 76 69 6e 67 20 22 20 72 75 6e 2d 64 69 72 20 22 ving " run-dir "
63f0: 20 61 73 20 69 74 20 65 69 74 68 65 72 20 64 6f as it either do
6400: 65 73 6e 27 74 20 65 78 69 73 74 20 6f 72 20 69 esn't exist or i
6410: 73 20 6e 6f 74 20 61 20 73 79 6d 6c 69 6e 6b 22 s not a symlink"
6420: 29 0a 09 09 09 09 20 20 20 20 20 28 64 65 62 75 )..... (debu
6430: 67 3a 70 72 69 6e 74 20 30 20 22 4e 4f 54 45 3a g:print 0 "NOTE:
6440: 20 74 68 65 20 72 75 6e 20 64 69 72 20 66 6f 72 the run dir for
6450: 20 74 68 69 73 20 74 65 73 74 20 69 73 20 75 6e this test is un
6460: 64 65 66 69 6e 65 64 2e 20 54 65 73 74 20 6d 61 defined. Test ma
6470: 79 20 68 61 76 65 20 61 6c 72 65 61 64 79 20 62 y have already b
6480: 65 65 6e 20 64 65 6c 65 74 65 64 2e 22 29 29 0a een deleted.")).
6490: 09 09 09 09 20 29 29 29 0a 09 09 09 28 28 73 65 .... )))....((se
64a0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a t-state-status).
64b0: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
64c0: 2d 69 6e 66 6f 20 32 20 22 6e 65 77 20 73 74 61 -info 2 "new sta
64d0: 74 65 20 22 20 28 63 61 72 20 73 74 61 74 65 2d te " (car state-
64e0: 73 74 61 74 75 73 29 20 22 2c 20 6e 65 77 20 73 status) ", new s
64f0: 74 61 74 75 73 20 22 20 28 63 61 64 72 20 73 74 tatus " (cadr st
6500: 61 74 65 2d 73 74 61 74 75 73 29 29 0a 09 09 09 ate-status))....
6510: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
6520: 20 64 62 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 db:test-set-sta
6530: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 te-status-by-id
6540: 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d db (db:test-get-
6550: 69 64 20 74 65 73 74 29 20 28 63 61 72 20 73 74 id test) (car st
6560: 61 74 65 2d 73 74 61 74 75 73 29 28 63 61 64 72 ate-status)(cadr
6570: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 23 state-status) #
6580: 66 29 29 29 29 29 0a 09 09 20 20 28 73 6f 72 74 f)))))... (sort
6590: 20 74 65 73 74 73 20 28 6c 61 6d 62 64 61 20 28 tests (lambda (
65a0: 61 20 62 29 28 6c 65 74 20 28 28 64 69 72 61 20 a b)(let ((dira
65b0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e (db:test-get-run
65c0: 64 69 72 20 61 29 29 0a 09 09 09 09 09 09 20 28 dir a))....... (
65d0: 64 69 72 62 20 28 64 62 3a 74 65 73 74 2d 67 65 dirb (db:test-ge
65e0: 74 2d 72 75 6e 64 69 72 20 62 29 29 29 0a 09 09 t-rundir b)))...
65f0: 09 09 09 20 20 20 20 20 28 69 66 20 28 61 6e 64 ... (if (and
6600: 20 28 73 74 72 69 6e 67 3f 20 64 69 72 61 29 28 (string? dira)(
6610: 73 74 72 69 6e 67 3f 20 64 69 72 62 29 29 0a 09 string? dirb))..
6620: 09 09 09 09 09 20 28 3e 20 28 73 74 72 69 6e 67 ..... (> (string
6630: 2d 6c 65 6e 67 74 68 20 64 69 72 61 29 28 73 74 -length dira)(st
6640: 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 62 ring-length dirb
6650: 29 29 0a 09 09 09 09 09 09 20 23 66 29 29 29 29 ))....... #f))))
6660: 29 29 29 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 ))).. ;; remov
6670: 65 20 74 68 65 20 72 75 6e 20 69 66 20 7a 65 72 e the run if zer
6680: 6f 20 74 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 o tests remain..
6690: 20 20 20 28 69 66 20 28 65 71 3f 20 61 63 74 69 (if (eq? acti
66a0: 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 on 'remove-runs)
66b0: 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
66c0: 72 65 6d 74 65 73 74 73 20 28 6f 70 65 6e 2d 72 remtests (open-r
66d0: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
66e0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
66f0: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
6700: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
6710: 64 65 72 20 22 69 64 22 29 20 23 66 20 27 28 22 der "id") #f '("
6720: 44 45 4c 45 54 45 44 22 29 20 27 28 22 6e 2f 61 DELETED") '("n/a
6730: 22 29 20 6e 6f 74 2d 69 6e 3a 20 23 74 29 29 29 ") not-in: #t)))
6740: 0a 09 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 ... (if (null? r
6750: 65 6d 74 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d emtests) ;; no m
6760: 6f 72 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e ore tests remain
6770: 69 6e 67 0a 09 09 20 20 20 20 20 28 6c 65 74 2a ing... (let*
6780: 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 69 ((dparts (stri
6790: 6e 67 2d 73 70 6c 69 74 20 6c 61 73 74 74 70 61 ng-split lasttpa
67a0: 74 68 20 22 2f 22 29 29 0a 09 09 09 20 20 20 20 th "/"))....
67b0: 28 72 75 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 (runpath (conc "
67c0: 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 /" (string-inter
67d0: 73 70 65 72 73 65 20 0a 09 09 09 09 09 09 28 74 sperse .......(t
67e0: 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c ake dparts (- (l
67f0: 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 31 29 ength dparts) 1)
6800: 29 0a 09 09 09 09 09 09 22 2f 22 29 29 29 29 0a )......."/")))).
6810: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
6820: 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e print 1 "Removin
6830: 67 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 g run: " runkey
6840: 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 " " (db:get-valu
6850: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
6860: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
6870: 29 20 22 20 61 6e 64 20 72 65 6c 61 74 65 64 20 ) " and related
6880: 72 65 63 6f 72 64 22 29 0a 09 09 20 20 20 20 20 record")...
6890: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
68a0: 65 20 64 62 3a 64 65 6c 65 74 65 2d 72 75 6e 20 e db:delete-run
68b0: 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 db run-id)...
68c0: 20 20 20 20 3b 3b 20 54 68 69 73 20 69 73 20 61 ;; This is a
68d0: 20 70 72 65 74 74 79 20 67 6f 6f 64 20 70 6c 61 pretty good pla
68e0: 63 65 20 74 6f 20 70 75 72 67 65 20 6f 6c 64 20 ce to purge old
68f0: 44 45 4c 45 54 45 44 20 74 65 73 74 73 0a 09 09 DELETED tests...
6900: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
6910: 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 -close db:delete
6920: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 -tests-for-run d
6930: 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 20 20 20 b run-id)...
6940: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
6950: 73 65 20 64 62 3a 64 65 6c 65 74 65 2d 6f 6c 64 se db:delete-old
6960: 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 2d 72 65 -deleted-test-re
6970: 63 6f 72 64 73 20 64 62 29 0a 09 09 20 20 20 20 cords db)...
6980: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
6990: 73 65 20 64 62 3a 73 65 74 2d 76 61 72 20 64 62 se db:set-var db
69a0: 20 22 44 45 4c 45 54 45 44 5f 54 45 53 54 53 22 "DELETED_TESTS"
69b0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
69c0: 73 29 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 s))... ;;
69d0: 6e 65 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f need to figure o
69e0: 75 74 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 ut the path to t
69f0: 68 65 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 he run dir and r
6a00: 65 6d 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 emove it if empt
6a10: 79 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 y... ;;
6a20: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f (if (null? (glo
6a30: 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 b (conc runpath
6a40: 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 20 20 20 "/*")))...
6a50: 20 3b 3b 20 20 20 20 20 20 20 20 28 62 65 67 69 ;; (begi
6a60: 6e 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 n... ;; .
6a70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
6a80: 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 Removing run dir
6a90: 20 22 20 72 75 6e 70 61 74 68 29 0a 09 09 20 20 " runpath)...
6aa0: 20 20 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 ;; . (syste
6ab0: 6d 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d m (conc "rmdir -
6ac0: 70 20 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a p " runpath)))).
6ad0: 09 09 20 20 20 20 20 20 20 29 29 29 29 29 0a 09 .. )))))..
6ae0: 20 29 29 0a 20 20 20 20 20 72 75 6e 73 29 29 0a )). runs)).
6af0: 20 20 23 74 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d #t)..;;=======
6b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
6b40: 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 6f 72 20 ;; Routines for
6b50: 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 72 75 6e manipulating run
6b60: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
6b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 ==========..;; S
6bb0: 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c 6c 73 20 ince many calls
6bc0: 74 6f 20 61 20 72 75 6e 20 72 65 71 75 69 72 65 to a run require
6bd0: 20 70 72 65 74 74 79 20 6d 75 63 68 20 74 68 65 pretty much the
6be0: 20 73 61 6d 65 20 73 65 74 75 70 20 0a 3b 3b 20 same setup .;;
6bf0: 74 68 69 73 20 77 72 61 70 70 65 72 20 69 73 20 this wrapper is
6c00: 75 73 65 64 20 74 6f 20 72 65 64 75 63 65 20 74 used to reduce t
6c10: 68 65 20 72 65 70 6c 69 63 61 74 69 6f 6e 20 6f he replication o
6c20: 66 20 63 6f 64 65 0a 28 64 65 66 69 6e 65 20 28 f code.(define (
6c30: 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 61 6c 6c general-run-call
6c40: 20 73 77 69 74 63 68 6e 61 6d 65 20 61 63 74 69 switchname acti
6c50: 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 0a 20 20 on-desc proc).
6c60: 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d 65 20 28 (let ((runname (
6c70: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 args:get-arg ":r
6c80: 75 6e 6e 61 6d 65 22 29 29 0a 09 28 74 61 72 67 unname"))..(targ
6c90: 65 74 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 et (if (args:ge
6ca0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
6cb0: 0a 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 65 ... (args:ge
6cc0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
6cd0: 0a 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 65 ... (args:ge
6ce0: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
6cf0: 29 29 29 29 0a 09 3b 3b 20 28 74 68 31 20 20 20 ))))..;; (th1
6d00: 20 20 23 66 29 29 0a 20 20 20 20 28 63 6f 6e 64 #f)). (cond
6d10: 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 61 72 67 . ((not targ
6d20: 65 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 et). (debug
6d30: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
6d40: 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 Missing require
6d50: 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 d parameter for
6d60: 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 " switchname ",
6d70: 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 you must specify
6d80: 20 74 68 65 20 74 61 72 67 65 74 20 77 69 74 68 the target with
6d90: 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 -target").
6da0: 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 (exit 3)).
6db0: 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 0a 20 ((not runname).
6dc0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6dd0: 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 t 0 "ERROR: Miss
6de0: 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 ing required par
6df0: 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 ameter for " swi
6e00: 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d tchname ", you m
6e10: 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 ust specify the
6e20: 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a 72 run name with :r
6e30: 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 29 unname runname")
6e40: 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 . (exit 3))
6e50: 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 . (else.
6e60: 20 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 66 (let ((db #f
6e70: 29 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 29 ).. (keys #f)
6e80: 0a 09 20 20 20 20 28 74 61 72 67 65 74 20 28 6f .. (target (o
6e90: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
6ea0: 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 09 28 "-reqtarg")....(
6eb0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
6ec0: 61 72 67 65 74 22 29 29 29 29 0a 09 28 69 66 20 arget"))))..(if
6ed0: 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d (not (setup-for-
6ee0: 72 75 6e 29 29 0a 09 20 20 20 20 28 62 65 67 69 run)).. (begi
6ef0: 6e 20 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 n .. (debug
6f00: 3a 70 72 69 6e 74 20 30 20 22 46 61 69 6c 65 64 :print 0 "Failed
6f10: 20 74 6f 20 73 65 74 75 70 2c 20 65 78 69 74 69 to setup, exiti
6f20: 6e 67 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 ng").. (exi
6f30: 74 20 31 29 29 29 0a 09 28 69 66 20 28 61 72 67 t 1)))..(if (arg
6f40: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 s:get-arg "-serv
6f50: 65 72 22 29 0a 09 20 20 20 20 28 6f 70 65 6e 2d er").. (open-
6f60: 72 75 6e 2d 63 6c 6f 73 65 20 73 65 72 76 65 72 run-close server
6f70: 3a 73 74 61 72 74 20 64 62 20 28 61 72 67 73 3a :start db (args:
6f80: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
6f90: 22 29 29 29 0a 09 28 73 65 74 21 20 6b 65 79 73 ")))..(set! keys
6fa0: 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 (keys:config-ge
6fb0: 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 t-fields *config
6fc0: 64 61 74 2a 29 29 0a 09 3b 3b 20 68 61 76 65 20 dat*))..;; have
6fd0: 65 6e 6f 75 67 68 20 74 6f 20 70 72 6f 63 65 73 enough to proces
6fe0: 73 20 2d 74 61 72 67 65 74 20 6f 72 20 2d 72 65 s -target or -re
6ff0: 71 74 61 72 67 20 68 65 72 65 0a 09 28 69 66 20 qtarg here..(if
7000: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7010: 72 65 71 74 61 72 67 22 29 0a 09 20 20 20 20 28 reqtarg").. (
7020: 6c 65 74 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 let* ((runconfig
7030: 66 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 f (conc *toppat
7040: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
7050: 63 6f 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 config")) ;; DO
7060: 4e 4f 54 20 45 56 41 4c 55 41 54 45 20 41 4c 4c NOT EVALUATE ALL
7070: 20 0a 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 ... (runconfi
7080: 67 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 g (read-config
7090: 72 75 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 74 runconfigf #f #t
70a0: 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 environ-patt: #
70b0: 66 29 29 29 20 0a 09 20 20 20 20 20 20 28 69 66 f))) .. (if
70c0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
70d0: 2f 64 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 /default runconf
70e0: 69 67 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ig (args:get-arg
70f0: 20 22 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 "-reqtarg") #f)
7100: 0a 09 09 20 20 28 6b 65 79 73 3a 74 61 72 67 65 ... (keys:targe
7110: 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 t-set-args keys
7120: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7130: 72 65 71 74 61 72 67 22 29 20 61 72 67 73 3a 61 reqtarg") args:a
7140: 72 67 2d 68 61 73 68 29 0a 09 09 20 20 20 20 0a rg-hash)... .
7150: 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 .. (begin...
7160: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
7170: 22 45 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 "ERROR: [" (args
7180: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
7190: 72 67 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e rg") "] not foun
71a0: 64 20 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 d in " runconfig
71b0: 66 29 0a 09 09 20 20 20 20 28 69 66 20 64 62 20 f)... (if db
71c0: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz
71d0: 65 21 20 64 62 29 29 0a 09 09 20 20 20 20 28 65 e! db))... (e
71e0: 78 69 74 20 31 29 29 29 29 0a 09 20 20 20 20 28 xit 1)))).. (
71f0: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
7200: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 28 6b "-target")...(k
7210: 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 eys:target-set-a
7220: 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 rgs keys (args:g
7230: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
7240: 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 20 args:arg-hash)
7250: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 29 29 args:arg-hash)))
7260: 0a 09 28 69 66 20 28 6e 6f 74 20 28 63 61 72 20 ..(if (not (car
7270: 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 *configinfo*))..
7280: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
7290: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
72a0: 20 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 "ERROR: Attempt
72b0: 65 64 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 ed to " action-d
72c0: 65 73 63 20 22 20 62 75 74 20 72 75 6e 20 61 72 esc " but run ar
72d0: 65 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e ea config file n
72e0: 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 ot found")..
72f0: 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 (exit 1))..
7300: 20 3b 3b 20 45 78 74 72 61 63 74 20 6f 75 74 20 ;; Extract out
7310: 73 74 75 66 66 20 6e 65 65 64 65 64 20 69 6e 20 stuff needed in
7320: 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c most or many cal
7330: 6c 73 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 20 ls.. ;; here
7340: 74 68 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 then call proc..
7350: 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 (let* ((keyv
7360: 61 6c 73 20 20 20 20 28 6b 65 79 73 3a 74 61 72 als (keys:tar
7370: 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 get->keyval keys
7380: 20 74 61 72 67 65 74 29 29 29 0a 09 20 20 20 20 target)))..
7390: 20 20 28 70 72 6f 63 20 74 61 72 67 65 74 20 72 (proc target r
73a0: 75 6e 6e 61 6d 65 20 6b 65 79 73 20 6b 65 79 76 unname keys keyv
73b0: 61 6c 73 29 29 29 0a 09 28 69 66 20 64 62 20 28 als)))..(if db (
73c0: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
73d0: 21 20 64 62 29 29 0a 09 28 73 65 74 21 20 2a 64 ! db))..(set! *d
73e0: 69 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 idsomething* #t)
73f0: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
7400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
7440: 3b 3b 20 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 ;; Lock/unlock r
7450: 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d uns.;;==========
7460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
74a0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 68 61 6e 64 efine (runs:hand
74b0: 6c 65 2d 6c 6f 63 6b 69 6e 67 20 74 61 72 67 65 le-locking targe
74c0: 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 6c t keys runname l
74d0: 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 ock unlock user)
74e0: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
74f0: 20 20 20 20 23 66 29 0a 09 20 28 72 75 6e 64 61 #f).. (runda
7500: 74 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c t (open-run-cl
7510: 6f 73 65 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e ose runs:get-run
7520: 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 s-by-patt db key
7530: 73 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 28 68 s runname)).. (h
7540: 65 61 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d eader (vector-
7550: 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 ref rundat 0))..
7560: 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 (runs (vect
7570: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 or-ref rundat 1)
7580: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
7590: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
75a0: 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 .(let ((run-id (
75b0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
75c0: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
75d0: 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 r "id")))... (i
75e0: 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 f (or lock....
75f0: 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 (and unlock....
7600: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
7610: 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 . (print "Do you
7620: 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 really wish to
7630: 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e unlock run " run
7640: 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 -id "?\n y/n:
7650: 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 ")..... (equal?
7660: 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 "y" (read-line))
7670: 29 29 29 0a 09 09 20 20 20 20 20 20 28 6f 70 65 )))... (ope
7680: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c n-run-close db:l
7690: 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 ock/unlock-run d
76a0: 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e b run-id lock un
76b0: 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 lock user)...
76c0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
76d0: 69 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 info 0 "Skipping
76e0: 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 lock/unlock on
76f0: 22 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 " run-id))))..
7700: 20 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d runs))).;;==
7710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7750: 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 ====.;; Rollup r
7760: 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d uns.;;==========
7770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
77b0: 20 55 70 64 61 74 65 20 74 68 65 20 74 65 73 74 Update the test
77c0: 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 _meta table for
77d0: 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e this test.(defin
77e0: 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 e (runs:update-t
77f0: 65 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 est_meta test-na
7800: 6d 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 me test-conf).
7810: 28 6c 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 (let ((currrecor
7820: 64 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 d (cdb:remote-ru
7830: 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 n db:testmeta-ge
7840: 74 2d 72 65 63 6f 72 64 20 23 66 20 74 65 73 74 t-record #f test
7850: 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 -name))). (if
7860: 20 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 (not currrecord
7870: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 )..(begin.. (se
7880: 74 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d t! currrecord (m
7890: 61 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 ake-vector 10 #f
78a0: 29 29 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 )).. (cdb:remot
78b0: 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 e-run db:testmet
78c0: 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 23 66 20 a-add-record #f
78d0: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
78e0: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
78f0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 (lambda (key).
7900: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 (let* ((id
7910: 78 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 x (cadr key))..
7920: 20 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 (fld (car
7930: 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 key)).. (va
7940: 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 l (config-lookup
7950: 20 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 test-conf "test
7960: 5f 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 _meta" fld)))..
7970: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
7980: 35 20 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 5 "idx: " idx "
7990: 66 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c fld: " fld " val
79a0: 3a 20 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 : " val).. (if (
79b0: 61 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 and val (not (eq
79c0: 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 ual? (vector-ref
79d0: 20 63 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 currrecord idx)
79e0: 20 76 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 val))).. (b
79f0: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 egin.. (pr
7a00: 69 6e 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 int "Updating "
7a10: 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c test-name " " fl
7a20: 64 20 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 d " to " val)..
7a30: 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 (cdb:remot
7a40: 65 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 e-run db:testmet
7a50: 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 23 a-update-field #
7a60: 66 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 f test-name fld
7a70: 76 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 val))))). '(
7a80: 28 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 ("author" 2)("ow
7a90: 6e 65 72 22 20 33 29 28 22 64 65 73 63 72 69 70 ner" 3)("descrip
7aa0: 74 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 tion" 4)("review
7ab0: 65 64 22 20 35 29 28 22 74 61 67 73 22 20 39 29 ed" 5)("tags" 9)
7ac0: 29 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 ))))..;; Update
7ad0: 74 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c test_meta for al
7ae0: 6c 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 l tests.(define
7af0: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c (runs:update-all
7b00: 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 -test_meta db).
7b10: 20 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d (let ((test-nam
7b20: 65 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 es (get-all-lega
7b30: 6c 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 l-tests))). (
7b40: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
7b50: 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d lambda (test-nam
7b60: 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 e). (let*
7b70: 28 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 ((test-path (
7b80: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
7b90: 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 /tests/" test-na
7ba0: 6d 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 me)).. (tes
7bb0: 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 t-configf (conc
7bc0: 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 test-path "/test
7bd0: 63 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 20 20 config"))..
7be0: 20 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 (testexists (
7bf0: 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 and (file-exists
7c00: 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 ? test-configf)(
7c10: 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 file-read-access
7c20: 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 ? test-configf))
7c30: 29 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 61 64 ).. ;; read
7c40: 20 63 6f 6e 66 69 67 73 20 77 69 74 68 20 74 72 configs with tr
7c50: 69 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 20 icks turned off
7c60: 28 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d 29 (i.e. no system)
7c70: 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f .. (test-co
7c80: 6e 66 20 20 20 20 28 69 66 20 74 65 73 74 65 78 nf (if testex
7c90: 69 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 ists (read-confi
7ca0: 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 g test-configf #
7cb0: 66 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 2d f #f)(make-hash-
7cc0: 74 61 62 6c 65 29 29 29 29 0a 09 20 3b 3b 20 75 table)))).. ;; u
7cd0: 73 65 20 74 68 65 20 6f 70 65 6e 2d 72 75 6e 2d se the open-run-
7ce0: 63 6c 6f 73 65 20 69 6e 73 74 65 61 64 20 6f 66 close instead of
7cf0: 20 70 61 73 73 69 6e 67 20 69 6e 20 64 62 0a 09 passing in db..
7d00: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 (runs:update-te
7d10: 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d st_meta test-nam
7d20: 65 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 e test-conf))).
7d30: 20 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 test-names))
7d40: 29 0a 0a 3b 3b 20 54 68 69 73 20 63 6f 75 6c 64 )..;; This could
7d50: 20 70 72 6f 62 61 62 6c 79 20 62 65 20 72 65 66 probably be ref
7d60: 61 63 74 6f 72 65 64 20 69 6e 74 6f 20 6f 6e 65 actored into one
7d70: 20 63 6f 6d 70 6c 65 78 20 71 75 65 72 79 20 2e complex query .
7d80: 2e 2e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 ...(define (runs
7d90: 3a 72 6f 6c 6c 75 70 2d 72 75 6e 20 6b 65 79 73 :rollup-run keys
7da0: 20 72 75 6e 6e 61 6d 65 20 75 73 65 72 20 6b 65 runname user ke
7db0: 79 76 61 6c 73 29 0a 20 20 28 64 65 62 75 67 3a yvals). (debug:
7dc0: 70 72 69 6e 74 20 34 20 22 72 75 6e 73 3a 72 6f print 4 "runs:ro
7dd0: 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 llup-run, keys:
7de0: 22 20 6b 65 79 73 20 22 20 3a 72 75 6e 6e 61 6d " keys " :runnam
7df0: 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 73 e " runname " us
7e00: 65 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c er: " user). (l
7e10: 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 et* ((db
7e20: 20 20 20 20 20 20 23 66 29 0a 09 20 28 6e 65 77 #f).. (new
7e30: 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 63 64 -run-id (cd
7e40: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
7e50: 72 65 67 69 73 74 65 72 2d 72 75 6e 20 23 66 20 register-run #f
7e60: 6b 65 79 73 20 6b 65 79 76 61 6c 73 20 72 75 6e keys keyvals run
7e70: 6e 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 name "new" "n/a"
7e80: 20 75 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d user)).. (prev-
7e90: 74 65 73 74 73 20 20 20 20 20 20 28 6f 70 65 6e tests (open
7ea0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 3a -run-close test:
7eb0: 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 get-matching-pre
7ec0: 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 vious-test-run-r
7ed0: 65 63 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 ecords db new-ru
7ee0: 6e 2d 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 n-id "%" "%"))..
7ef0: 20 28 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 (curr-tests
7f00: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
7f10: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 e db:get-tests-f
7f20: 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 or-run db new-ru
7f30: 6e 2d 69 64 20 22 25 2f 25 22 20 27 28 29 20 27 n-id "%/%" '() '
7f40: 28 29 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 ())).. (curr-tes
7f50: 74 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 ts-hash (make-ha
7f60: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
7f70: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
7f80: 64 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 db:update-run-ev
7f90: 65 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 2d ent_time db new-
7fa0: 72 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 69 run-id). ;; i
7fb0: 6e 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 ndex the already
7fc0: 20 73 61 76 65 64 20 74 65 73 74 73 20 62 79 20 saved tests by
7fd0: 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 testname and ite
7fe0: 6d 64 61 74 20 69 6e 20 63 75 72 72 2d 74 65 73 mdat in curr-tes
7ff0: 74 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f 72 ts-hash. (for
8000: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
8010: 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 da (testdat).
8020: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
8030: 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 name (db:test-g
8040: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
8050: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 dat)).. (it
8060: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
8070: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
8080: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 estdat))..
8090: 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 (full-name (conc
80a0: 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
80b0: 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 61 em-path))).. (ha
80c0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 sh-table-set! cu
80d0: 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 rr-tests-hash fu
80e0: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 29 ll-name testdat)
80f0: 29 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 73 )). curr-tes
8100: 74 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 3a ts). ;; NOPE:
8110: 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 70 Non-optimal app
8120: 72 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 20 roach. Try this
8130: 69 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b 20 instead.. ;;
8140: 20 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 72 1. tests are r
8150: 65 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 73 eceived in a lis
8160: 74 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 66 t, most recent f
8170: 69 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 2e irst. ;; 2.
8180: 20 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f 6c replace the rol
8190: 6c 75 70 20 74 65 73 74 20 77 69 74 68 20 74 68 lup test with th
81a0: 65 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a 20 e new *always*.
81b0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
81c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
81d0: 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 dat). (let
81e0: 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 * ((testname (d
81f0: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
8200: 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 ame testdat))..
8210: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 (item-path
8220: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
8230: 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 29 m-path testdat))
8240: 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 .. (full-na
8250: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d me (conc testnam
8260: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
8270: 29 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d 74 ).. (prev-t
8280: 65 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 61 est-dat (hash-ta
8290: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
82a0: 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 curr-tests-hash
82b0: 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a 09 full-name #f))..
82c0: 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 (test-step
82d0: 73 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 s (open-run-c
82e0: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 73 74 65 70 lose db:get-step
82f0: 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 28 64 s-for-test db (d
8300: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
8310: 73 74 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 stdat)))..
8320: 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 (new-test-record
8330: 20 23 66 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 #f)).. ;; repla
8340: 63 65 20 74 68 65 73 65 20 77 69 74 68 20 69 6e ce these with in
8350: 73 65 72 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a sert ... select.
8360: 09 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 . (apply sqlite3
8370: 3a 65 78 65 63 75 74 65 20 0a 09 09 64 62 20 0a :execute ...db .
8380: 09 09 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 ..(conc "INSERT
8390: 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 OR REPLACE INTO
83a0: 74 65 73 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 tests (run_id,te
83b0: 73 74 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 stname,state,sta
83c0: 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 tus,event_time,h
83d0: 6f 73 74 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b ost,cpuload,disk
83e0: 66 72 65 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 free,uname,rundi
83f0: 72 2c 69 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f r,item_path,run_
8400: 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c duration,final_l
8410: 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 ogf,comment) "..
8420: 09 20 20 20 20 20 20 22 56 41 4c 55 45 53 20 28 . "VALUES (
8430: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ?,?,?,?,?,?,?,?,
8440: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a ?,?,?,?,?,?);").
8450: 09 09 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 ..new-run-id (cd
8460: 64 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 dr (vector->list
8470: 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 28 73 testdat))).. (s
8480: 65 74 21 20 6e 65 77 2d 74 65 73 74 64 61 74 20 et! new-testdat
8490: 28 63 61 72 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (car (open-run-c
84a0: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 lose db:get-test
84b0: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 s-for-run db new
84c0: 2d 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 74 65 -run-id (conc te
84d0: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d stname "/" item-
84e0: 70 61 74 68 29 20 27 28 29 20 27 28 29 29 29 29 path) '() '())))
84f0: 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 .. (hash-table-s
8500: 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 et! curr-tests-h
8510: 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 ash full-name ne
8520: 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 74 68 w-testdat) ;; th
8530: 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 is could be conf
8540: 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 65 63 using, which rec
8550: 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e ord should go in
8560: 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 to the lookup ta
8570: 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 ble?.. ;; Now du
8580: 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 plicate the test
8590: 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 67 3a steps.. (debug:
85a0: 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 print 4 "Copying
85b0: 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 records in test
85c0: 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 73 74 _steps from test
85d0: 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 _id=" (db:test-g
85e0: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 et-id testdat) "
85f0: 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 to " (db:test-g
8600: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
8610: 74 29 29 0a 09 20 28 6f 70 65 6e 2d 72 75 6e 2d t)).. (open-run-
8620: 63 6c 6f 73 65 20 0a 09 20 20 28 6c 61 6d 62 64 close .. (lambd
8630: 61 20 28 29 0a 09 20 20 20 20 28 73 71 6c 69 74 a ().. (sqlit
8640: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 e3:execute ..
8650: 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e db .. (con
8660: 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 c "INSERT OR REP
8670: 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 LACE INTO test_s
8680: 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 teps (test_id,st
8690: 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 epname,state,sta
86a0: 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 tus,event_time,c
86b0: 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 omment) "... "
86c0: 53 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 SELECT " (db:tes
86d0: 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 t-get-id new-tes
86e0: 74 64 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 tdat) ",stepname
86f0: 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 ,state,status,ev
8700: 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 ent_time,comment
8710: 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 FROM test_steps
8720: 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f WHERE test_id=?
8730: 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 ;").. (db:te
8740: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
8750: 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 t)).. ;; Now
8760: 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 duplicate the te
8770: 73 74 20 64 61 74 61 0a 09 20 20 20 20 28 64 65 st data.. (de
8780: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 bug:print 4 "Cop
8790: 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 ying records in
87a0: 74 65 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 test_data from t
87b0: 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 est_id=" (db:tes
87c0: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
87d0: 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 ) " to " (db:tes
87e0: 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 t-get-id new-tes
87f0: 74 64 61 74 29 29 0a 09 20 20 20 20 28 73 71 6c tdat)).. (sql
8800: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 ite3:execute ..
8810: 20 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 db .. (c
8820: 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 onc "INSERT OR R
8830: 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 EPLACE INTO test
8840: 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 2c 63 _data (test_id,c
8850: 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 ategory,variable
8860: 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c ,value,expected,
8870: 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e tol,units,commen
8880: 74 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 43 t) "... "SELEC
8890: 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 T " (db:test-get
88a0: 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 -id new-testdat)
88b0: 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 ",category,vari
88c0: 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 able,value,expec
88d0: 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f ted,tol,units,co
88e0: 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f mment FROM test_
88f0: 64 61 74 61 20 57 48 45 52 45 20 74 65 73 74 5f data WHERE test_
8900: 69 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 id=?;").. (d
8910: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
8920: 73 74 64 61 74 29 29 29 29 0a 09 20 29 29 0a 20 stdat)))).. )).
8930: 20 20 20 20 70 72 65 76 2d 74 65 73 74 73 29 29 prev-tests))
8940: 29 0a 09 20 0a 20 20 20 20 20 0a ).. . .