0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 0a 28 uses server))..(
02b0: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
02c0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
02d0: 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f nclude "key_reco
02e0: 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 rds.scm").(inclu
02f0: 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 de "db_records.s
0300: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 cm").(include "r
0310: 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 un_records.scm")
0320: 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f .(include "test_
0330: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b records.scm")..;
0340: 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d ; runs:get-runs-
0350: 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 72 by-patt.;; get r
0360: 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 63 uns by list of c
0370: 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 73 riteria.;; regis
0380: 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 ter a test run w
0390: 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b 3b ith the db.;;.;;
03a0: 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 61 Use: (db-get-va
03b0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 64 lue-by-header (d
03c0: 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 6e b:get-header run
03d0: 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f 77 info)(db:get-row
03e0: 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 20 74 runinfo)).;; t
03f0: 6f 20 65 78 74 72 61 63 74 20 69 6e 66 6f 20 66 o extract info f
0400: 72 6f 6d 20 74 68 65 20 73 74 72 75 63 74 75 72 rom the structur
0410: 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a 28 64 e returned.;;.(d
0420: 65 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d efine (runs:get-
0430: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
0440: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
0450: 20 2e 20 70 61 72 61 6d 73 29 20 3b 3b 20 74 65 . params) ;; te
0460: 73 74 2d 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a st-name). (let*
0470: 20 28 28 6b 65 79 76 61 6c 6c 73 74 20 28 6b 65 ((keyvallst (ke
0480: 79 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 ys->vallist keys
0490: 29 29 0a 09 20 28 74 6d 70 20 20 20 20 20 20 28 )).. (tmp (
04a0: 72 75 6e 73 3a 67 65 74 2d 73 74 64 2d 72 75 6e runs:get-std-run
04b0: 2d 66 69 65 6c 64 73 20 6b 65 79 73 20 27 28 22 -fields keys '("
04c0: 69 64 22 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 id" "runname" "s
04d0: 74 61 74 65 22 20 22 73 74 61 74 75 73 22 20 22 tate" "status" "
04e0: 6f 77 6e 65 72 22 20 22 65 76 65 6e 74 5f 74 69 owner" "event_ti
04f0: 6d 65 22 29 29 29 0a 09 20 28 6b 65 79 73 74 72 me"))).. (keystr
0500: 20 20 20 28 63 61 72 20 74 6d 70 29 29 0a 09 20 (car tmp))..
0510: 28 68 65 61 64 65 72 20 20 20 28 63 61 64 72 20 (header (cadr
0520: 74 6d 70 29 29 0a 09 20 28 72 65 73 20 20 20 20 tmp)).. (res
0530: 20 27 28 29 29 0a 09 20 28 6b 65 79 2d 70 61 74 '()).. (key-pat
0540: 74 20 22 22 29 29 0a 20 20 20 20 28 66 6f 72 2d t "")). (for-
0550: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
0560: 79 76 61 6c 29 0a 09 09 28 6c 65 74 2a 20 28 28 yval)...(let* ((
0570: 6b 65 79 20 20 20 20 28 76 65 63 74 6f 72 2d 72 key (vector-r
0580: 65 66 20 6b 65 79 76 61 6c 20 30 29 29 0a 09 09 ef keyval 0))...
0590: 20 20 20 20 20 20 20 28 66 75 6c 6b 65 79 20 28 (fulkey (
05a0: 63 6f 6e 63 20 22 3a 22 20 6b 65 79 29 29 0a 09 conc ":" key))..
05b0: 09 20 20 20 20 20 20 20 28 70 61 74 74 20 20 20 . (patt
05c0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 66 75 (args:get-arg fu
05d0: 6c 6b 65 79 29 29 29 0a 09 09 20 20 28 69 66 20 lkey)))... (if
05e0: 70 61 74 74 0a 09 09 20 20 20 20 20 20 28 73 65 patt... (se
05f0: 74 21 20 6b 65 79 2d 70 61 74 74 20 28 63 6f 6e t! key-patt (con
0600: 63 20 6b 65 79 2d 70 61 74 74 20 22 20 41 4e 44 c key-patt " AND
0610: 20 22 20 6b 65 79 20 22 20 6c 69 6b 65 20 27 22 " key " like '"
0620: 20 70 61 74 74 20 22 27 22 29 29 0a 09 09 20 20 patt "'"))...
0630: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 (begin....(d
0640: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
0650: 52 4f 52 3a 20 73 65 61 72 63 68 69 6e 67 20 66 ROR: searching f
0660: 6f 72 20 72 75 6e 73 20 77 69 74 68 20 6e 6f 20 or runs with no
0670: 70 61 74 74 65 72 6e 20 73 65 74 20 66 6f 72 20 pattern set for
0680: 22 20 66 75 6c 6b 65 79 29 0a 09 09 09 28 65 78 " fulkey)....(ex
0690: 69 74 20 36 29 29 29 29 29 0a 09 20 20 20 20 20 it 6)))))..
06a0: 20 6b 65 79 73 29 0a 20 20 20 20 28 73 71 6c 69 keys). (sqli
06b0: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
06c0: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
06d0: 61 20 2e 20 72 29 0a 20 20 20 20 20 20 20 28 73 a . r). (s
06e0: 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c et! res (cons (l
06f0: 69 73 74 2d 3e 76 65 63 74 6f 72 20 28 63 6f 6e ist->vector (con
0700: 73 20 61 20 72 29 29 20 72 65 73 29 29 29 0a 20 s a r)) res))).
0710: 20 20 20 20 64 62 20 0a 20 20 20 20 20 28 63 6f db . (co
0720: 6e 63 20 22 53 45 4c 45 43 54 20 22 20 6b 65 79 nc "SELECT " key
0730: 73 74 72 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 str " FROM runs
0740: 57 48 45 52 45 20 72 75 6e 6e 61 6d 65 20 6c 69 WHERE runname li
0750: 6b 65 20 3f 20 22 20 6b 65 79 2d 70 61 74 74 20 ke ? " key-patt
0760: 22 3b 22 29 0a 20 20 20 20 20 72 75 6e 6e 61 6d ";"). runnam
0770: 65 70 61 74 74 29 0a 20 20 20 20 28 76 65 63 74 epatt). (vect
0780: 6f 72 20 68 65 61 64 65 72 20 72 65 73 29 29 29 or header res)))
0790: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
07a0: 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c 2d 70 61 test-get-full-pa
07b0: 74 68 20 74 65 73 74 29 0a 20 20 28 6c 65 74 2a th test). (let*
07c0: 20 28 28 74 65 73 74 6e 61 6d 65 20 28 64 62 3a ((testname (db:
07d0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
07e0: 65 20 20 20 74 65 73 74 29 29 0a 09 20 28 69 74 e test)).. (it
07f0: 65 6d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d empath (db:test-
0800: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
0810: 73 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 st))). (conc
0820: 74 65 73 74 6e 61 6d 65 20 28 69 66 20 28 65 71 testname (if (eq
0830: 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 20 22 22 ual? itempath ""
0840: 29 20 22 22 20 28 63 6f 6e 63 20 22 28 22 20 69 ) "" (conc "(" i
0850: 74 65 6d 70 61 74 68 20 22 29 22 29 29 29 29 29 tempath ")")))))
0860: 0a 0a 3b 3b 20 41 77 66 75 6c 2e 20 50 6c 65 61 ..;; Awful. Plea
0870: 73 65 20 46 49 58 4d 45 0a 28 64 65 66 69 6e 65 se FIXME.(define
0880: 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 *env-vars-by-ru
0890: 6e 2d 69 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 n-id* (make-hash
08a0: 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 -table)).(define
08b0: 20 2a 63 75 72 72 65 6e 74 2d 72 75 6e 2d 6e 61 *current-run-na
08c0: 6d 65 2a 20 20 20 23 66 29 0a 0a 28 64 65 66 69 me* #f)..(defi
08d0: 6e 65 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 ne (set-megatest
08e0: 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 6e -env-vars db run
08f0: 2d 69 64 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 -id). (let ((ke
0900: 79 73 20 28 64 62 3a 67 65 74 2d 6b 65 79 73 20 ys (db:get-keys
0910: 64 62 29 29 0a 09 28 76 61 6c 73 20 28 68 61 73 db))..(vals (has
0920: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
0930: 75 6c 74 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 ult *env-vars-by
0940: 2d 72 75 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 -run-id* run-id
0950: 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 67 65 74 #f))). ;; get
0960: 20 74 68 65 20 69 6e 66 6f 20 66 72 6f 6d 20 74 the info from t
0970: 68 65 20 64 62 20 61 6e 64 20 70 75 74 20 69 74 he db and put it
0980: 20 69 6e 20 74 68 65 20 63 61 63 68 65 0a 20 20 in the cache.
0990: 20 20 28 69 66 20 28 6e 6f 74 20 76 61 6c 73 29 (if (not vals)
09a0: 0a 09 28 6c 65 74 20 28 28 68 74 20 28 6d 61 6b ..(let ((ht (mak
09b0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
09c0: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
09d0: 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 et! *env-vars-by
09e0: 2d 72 75 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 -run-id* run-id
09f0: 68 74 29 0a 09 20 20 28 73 65 74 21 20 76 61 6c ht).. (set! val
0a00: 73 20 68 74 29 0a 09 20 20 28 66 6f 72 2d 65 61 s ht).. (for-ea
0a10: 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 ch.. (lambda (
0a20: 6b 65 79 29 0a 09 20 20 20 20 20 28 73 71 6c 69 key).. (sqli
0a30: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
0a40: 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
0a50: 28 76 61 6c 29 0a 09 09 28 68 61 73 68 2d 74 61 (val)...(hash-ta
0a60: 62 6c 65 2d 73 65 74 21 20 76 61 6c 73 20 6b 65 ble-set! vals ke
0a70: 79 20 76 61 6c 29 29 0a 09 20 20 20 20 20 20 64 y val)).. d
0a80: 62 20 0a 09 20 20 20 20 20 20 28 63 6f 6e 63 20 b .. (conc
0a90: 22 53 45 4c 45 43 54 20 22 20 28 6b 65 79 3a 67 "SELECT " (key:g
0aa0: 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 et-fieldname key
0ab0: 29 20 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 ) " FROM runs WH
0ac0: 45 52 45 20 69 64 3d 3f 3b 22 29 0a 09 20 20 20 ERE id=?;")..
0ad0: 20 20 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 run-id))..
0ae0: 6b 65 79 73 29 29 29 0a 20 20 20 20 3b 3b 20 66 keys))). ;; f
0af0: 72 6f 6d 20 74 68 65 20 63 61 63 68 65 64 20 64 rom the cached d
0b00: 61 74 61 20 73 65 74 20 74 68 65 20 76 61 72 73 ata set the vars
0b10: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
0b20: 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 76 -for-each. v
0b30: 61 6c 73 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 als. (lambda
0b40: 20 28 6b 65 79 20 76 61 6c 29 0a 20 20 20 20 20 (key val).
0b50: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
0b60: 20 22 73 65 74 65 6e 76 20 22 20 28 6b 65 79 3a "setenv " (key:
0b70: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
0b80: 79 29 20 22 20 22 20 76 61 6c 29 0a 20 20 20 20 y) " " val).
0b90: 20 20 20 28 73 65 74 65 6e 76 20 28 6b 65 79 3a (setenv (key:
0ba0: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
0bb0: 79 29 20 76 61 6c 29 29 29 0a 20 20 20 20 28 61 y) val))). (a
0bc0: 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 28 list->env-vars (
0bd0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
0be0: 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 67 64 61 efault *configda
0bf0: 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 65 t* "env-override
0c00: 22 20 27 28 29 29 29 0a 20 20 20 20 3b 3b 20 4c " '())). ;; L
0c10: 65 74 73 20 75 73 65 20 74 68 69 73 20 61 73 20 ets use this as
0c20: 61 6e 20 6f 70 70 6f 72 74 75 6e 69 74 79 20 74 an opportunity t
0c30: 6f 20 70 75 74 20 4d 54 5f 52 55 4e 4e 41 4d 45 o put MT_RUNNAME
0c40: 20 69 6e 20 74 68 65 20 65 6e 76 69 72 6f 6e 6d in the environm
0c50: 65 6e 74 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ent. (if (not
0c60: 20 2a 63 75 72 72 65 6e 74 2d 72 75 6e 2d 6e 61 *current-run-na
0c70: 6d 65 2a 29 0a 09 28 73 71 6c 69 74 65 33 3a 66 me*)..(sqlite3:f
0c80: 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 20 28 6c or-each-row.. (l
0c90: 61 6d 62 64 61 20 28 72 75 6e 6e 61 6d 65 29 0a ambda (runname).
0ca0: 09 20 20 20 28 73 65 74 21 20 2a 63 75 72 72 65 . (set! *curre
0cb0: 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a 20 72 75 6e nt-run-name* run
0cc0: 6e 61 6d 65 29 29 0a 0a 09 20 64 62 0a 09 20 22 name))... db.. "
0cd0: 53 45 4c 45 43 54 20 72 75 6e 6e 61 6d 65 20 46 SELECT runname F
0ce0: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 69 ROM runs WHERE i
0cf0: 64 3d 3f 3b 22 0a 09 20 72 75 6e 2d 69 64 29 29 d=?;".. run-id))
0d00: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT
0d10: 5f 52 55 4e 4e 41 4d 45 22 20 2a 63 75 72 72 65 _RUNNAME" *curre
0d20: 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a 29 0a 20 20 nt-run-name*).
0d30: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
0d40: 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f N_AREA_HOME" *to
0d50: 70 70 61 74 68 2a 29 0a 20 20 20 20 29 29 0a 0a ppath*). ))..
0d60: 28 64 65 66 69 6e 65 20 28 73 65 74 2d 69 74 65 (define (set-ite
0d70: 6d 2d 65 6e 76 2d 76 61 72 73 20 69 74 65 6d 64 m-env-vars itemd
0d80: 61 74 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 at). (for-each
0d90: 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a 09 (lambda (item)..
0da0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
0db0: 6e 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 28 nt 2 "setenv " (
0dc0: 63 61 72 20 69 74 65 6d 29 20 22 20 22 20 28 63 car item) " " (c
0dd0: 61 64 72 20 69 74 65 6d 29 29 0a 09 20 20 20 20 adr item))..
0de0: 20 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 69 (setenv (car i
0df0: 74 65 6d 29 20 28 63 61 64 72 20 69 74 65 6d 29 tem) (cadr item)
0e00: 29 29 0a 09 20 20 20 20 69 74 65 6d 64 61 74 29 )).. itemdat)
0e10: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 )..(define *last
0e20: 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 -num-running-tes
0e30: 74 73 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 28 ts* 0).(define (
0e40: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
0e50: 65 2d 74 65 73 74 73 20 64 62 20 74 65 73 74 2d e-tests db test-
0e60: 72 65 63 6f 72 64 29 0a 20 20 28 6c 65 74 2a 20 record). (let*
0e70: 28 28 74 63 6f 6e 66 69 67 20 20 20 20 20 20 20 ((tconfig
0e80: 20 20 20 20 20 20 20 20 20 20 28 74 65 73 74 73 (tests
0e90: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
0ea0: 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 estconfig test-r
0eb0: 65 63 6f 72 64 29 29 0a 09 20 28 6a 6f 62 67 72 ecord)).. (jobgr
0ec0: 6f 75 70 20 20 20 20 20 20 20 20 20 20 20 20 20 oup
0ed0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
0ee0: 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 p tconfig "requi
0ef0: 72 65 6d 65 6e 74 73 22 20 22 6a 6f 62 67 72 6f rements" "jobgro
0f00: 75 70 22 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e up")).. (num-run
0f10: 6e 69 6e 67 20 20 20 20 20 20 20 20 20 20 20 20 ning
0f20: 20 28 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (db:get-count-t
0f30: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 64 62 29 ests-running db)
0f40: 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 ).. (num-running
0f50: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 28 64 62 -in-jobgroup (db
0f60: 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 :get-count-tests
0f70: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
0f80: 72 6f 75 70 20 64 62 20 6a 6f 62 67 72 6f 75 70 roup db jobgroup
0f90: 29 29 0a 09 20 28 6d 61 78 2d 63 6f 6e 63 75 72 )).. (max-concur
0fa0: 72 65 6e 74 2d 6a 6f 62 73 20 20 20 20 20 28 63 rent-jobs (c
0fb0: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f onfig-lookup *co
0fc0: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
0fd0: 20 20 20 20 20 22 6d 61 78 5f 63 6f 6e 63 75 72 "max_concur
0fe0: 72 65 6e 74 5f 6a 6f 62 73 22 29 29 0a 09 20 28 rent_jobs")).. (
0ff0: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 job-group-limit
1000: 20 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d (config-
1010: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
1020: 74 2a 20 22 6a 6f 62 67 72 6f 75 70 73 22 20 6a t* "jobgroups" j
1030: 6f 62 67 72 6f 75 70 29 29 29 0a 20 20 20 20 28 obgroup))). (
1040: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a 6c 61 if (not (eq? *la
1050: 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 st-num-running-t
1060: 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e ests* num-runnin
1070: 67 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 g))..(begin.. (
1080: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 6d debug:print 2 "m
1090: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
10a0: 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 bs: " max-concur
10b0: 72 65 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d rent-jobs ", num
10c0: 2d 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d -running: " num-
10d0: 72 75 6e 6e 69 6e 67 29 0a 09 20 20 28 73 65 74 running).. (set
10e0: 21 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e ! *last-num-runn
10f0: 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d 2d 72 ing-tests* num-r
1100: 75 6e 6e 69 6e 67 29 29 29 0a 20 20 20 20 28 69 unning))). (i
1110: 66 20 28 6e 6f 74 20 28 65 71 3f 20 30 20 2a 67 f (not (eq? 0 *g
1120: 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a lobalexitstatus*
1130: 29 29 0a 09 23 66 0a 09 28 6c 65 74 20 28 28 63 ))..#f..(let ((c
1140: 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 20 an-not-run-more
1150: 28 63 6f 6e 64 0a 09 09 09 09 20 3b 3b 20 69 66 (cond..... ;; if
1160: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1170: 6a 6f 62 73 20 69 73 20 73 65 74 20 61 6e 64 20 jobs is set and
1180: 74 68 65 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 the number runni
1190: 6e 67 20 69 73 20 67 72 65 61 74 65 72 20 0a 09 ng is greater ..
11a0: 09 09 09 20 3b 3b 20 74 68 61 6e 20 69 74 20 74 ... ;; than it t
11b0: 68 61 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d han cannot run m
11c0: 6f 72 65 20 6a 6f 62 73 0a 09 09 09 09 20 28 28 ore jobs..... ((
11d0: 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 and max-concurre
11e0: 6e 74 2d 6a 6f 62 73 0a 09 09 09 09 20 20 20 20 nt-jobs.....
11f0: 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 (string->numb
1200: 65 72 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e er max-concurren
1210: 74 2d 6a 6f 62 73 29 0a 09 09 09 09 20 20 20 20 t-jobs).....
1220: 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 (>= num-runni
1230: 6e 67 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 ng (string->numb
1240: 65 72 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e er max-concurren
1250: 74 2d 6a 6f 62 73 29 29 29 0a 09 09 09 09 20 20 t-jobs))).....
1260: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
1270: 57 41 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e WARNING: Max run
1280: 6e 69 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 64 ning jobs exceed
1290: 65 64 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 ed, current numb
12a0: 65 72 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 er running: " nu
12b0: 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 09 09 09 09 m-running ......
12c0: 20 20 20 20 20 20 20 22 2c 20 6d 61 78 5f 63 6f ", max_co
12d0: 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 ncurrent_jobs: "
12e0: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
12f0: 6a 6f 62 73 29 0a 09 09 09 09 20 20 23 74 29 0a jobs)..... #t).
1300: 09 09 09 09 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 .... ;; if job-g
1310: 72 6f 75 70 2d 6c 69 6d 69 74 20 69 73 20 73 65 roup-limit is se
1320: 74 20 61 6e 64 20 6e 75 6d 62 65 72 20 6f 66 20 t and number of
1330: 6a 6f 62 73 20 69 6e 20 74 68 65 20 67 72 6f 75 jobs in the grou
1340: 70 20 69 73 20 67 72 65 61 74 65 72 0a 09 09 09 p is greater....
1350: 09 20 3b 3b 20 74 68 61 6e 20 74 68 65 20 6c 69 . ;; than the li
1360: 6d 69 74 20 74 68 65 6e 20 63 61 6e 6e 6f 74 20 mit then cannot
1370: 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 run more jobs of
1380: 20 74 68 69 73 20 6b 69 6e 64 0a 09 09 09 09 20 this kind.....
1390: 28 28 61 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 2d ((and job-group-
13a0: 6c 69 6d 69 74 0a 09 09 09 09 20 20 20 20 20 20 limit.....
13b0: 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (>= num-running
13c0: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 -in-jobgroup job
13d0: 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 -group-limit))..
13e0: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
13f0: 74 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 6e 75 t 1 "WARNING: nu
1400: 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 22 20 6e mber of jobs " n
1410: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f um-running-in-jo
1420: 62 67 72 6f 75 70 20 0a 09 09 09 09 09 20 20 20 bgroup ......
1430: 20 20 20 20 22 20 69 6e 20 22 20 6a 6f 62 67 72 " in " jobgr
1440: 6f 75 70 20 22 20 65 78 63 65 65 64 65 64 2c 20 oup " exceeded,
1450: 77 69 6c 6c 20 6e 6f 74 20 72 75 6e 20 22 20 28 will not run " (
1460: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
1470: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
1480: 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 09 09 20 t-record)).....
1490: 20 23 74 29 0a 09 09 09 09 20 28 65 6c 73 65 20 #t)..... (else
14a0: 23 66 29 29 29 29 0a 09 20 20 28 6e 6f 74 20 63 #f)))).. (not c
14b0: 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 29 an-not-run-more)
14c0: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
14d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
1510: 3b 20 4e 65 77 20 6d 65 74 68 6f 64 6f 6c 6f 67 ; New methodolog
1520: 79 2e 20 54 68 65 73 65 20 72 6f 75 74 69 6e 65 y. These routine
1530: 73 20 77 69 6c 6c 20 72 65 70 6c 61 63 65 20 74 s will replace t
1540: 68 65 20 61 62 6f 76 65 20 69 6e 20 74 69 6d 65 he above in time
1550: 2e 20 46 6f 72 0a 3b 3b 20 6e 6f 77 20 74 68 65 . For.;; now the
1560: 20 63 6f 64 65 20 69 73 20 64 75 70 6c 69 63 61 code is duplica
1570: 74 65 64 2e 20 54 68 69 73 20 73 74 75 66 66 20 ted. This stuff
1580: 69 73 20 69 6e 69 74 69 61 6c 6c 79 20 75 73 65 is initially use
1590: 64 20 69 6e 20 74 68 65 20 6d 6f 6e 69 74 6f 72 d in the monitor
15a0: 0a 3b 3b 20 62 61 73 65 64 20 63 6f 64 65 2e 0a .;; based code..
15b0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
15c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15f0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 72 65 67 ========..;; reg
1600: 69 73 74 65 72 20 61 20 74 65 73 74 20 72 75 6e ister a test run
1610: 20 77 69 74 68 20 74 68 65 20 64 62 0a 28 64 65 with the db.(de
1620: 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 67 69 73 fine (runs:regis
1630: 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 ter-run db keys
1640: 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d keyvallst runnam
1650: 65 20 73 74 61 74 65 20 73 74 61 74 75 73 20 75 e state status u
1660: 73 65 72 29 0a 20 20 28 64 65 62 75 67 3a 70 72 ser). (debug:pr
1670: 69 6e 74 20 33 20 22 72 75 6e 73 3a 72 65 67 69 int 3 "runs:regi
1680: 73 74 65 72 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 ster-run, keys:
1690: 22 20 6b 65 79 73 20 22 20 6b 65 79 76 61 6c 6c " keys " keyvall
16a0: 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 20 st: " keyvallst
16b0: 22 20 72 75 6e 6e 61 6d 65 3a 20 22 20 72 75 6e " runname: " run
16c0: 6e 61 6d 65 20 22 20 73 74 61 74 65 3a 20 22 20 name " state: "
16d0: 73 74 61 74 65 20 22 20 73 74 61 74 75 73 3a 20 state " status:
16e0: 22 20 73 74 61 74 75 73 20 22 20 75 73 65 72 3a " status " user:
16f0: 20 22 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a " user). (let*
1700: 20 28 28 6b 65 79 73 74 72 20 20 20 20 28 6b 65 ((keystr (ke
1710: 79 73 2d 3e 6b 65 79 73 74 72 20 6b 65 79 73 29 ys->keystr keys)
1720: 29 0a 09 20 28 63 6f 6d 6d 61 20 20 20 20 20 28 ).. (comma (
1730: 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 6b 65 if (> (length ke
1740: 79 73 29 20 30 29 20 22 2c 22 20 22 22 29 29 0a ys) 0) "," "")).
1750: 09 20 28 61 6e 64 73 74 72 20 20 20 20 28 69 66 . (andstr (if
1760: 20 28 3e 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 (> (length keys
1770: 29 20 30 29 20 22 20 41 4e 44 20 22 20 22 22 29 ) 0) " AND " "")
1780: 29 0a 09 20 28 76 61 6c 73 6c 6f 74 73 20 20 28 ).. (valslots (
1790: 6b 65 79 73 2d 3e 76 61 6c 73 6c 6f 74 73 20 6b keys->valslots k
17a0: 65 79 73 29 29 20 3b 3b 20 3f 2c 3f 2c 3f 20 2e eys)) ;; ?,?,? .
17b0: 2e 2e 0a 09 20 28 6b 65 79 76 61 6c 73 20 20 20 .... (keyvals
17c0: 28 6d 61 70 20 63 61 64 72 20 6b 65 79 76 61 6c (map cadr keyval
17d0: 6c 73 74 29 29 0a 09 20 28 61 6c 6c 76 61 6c 73 lst)).. (allvals
17e0: 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 (append (list
17f0: 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 runname state s
1800: 74 61 74 75 73 20 75 73 65 72 29 20 6b 65 79 76 tatus user) keyv
1810: 61 6c 73 29 29 0a 09 20 28 71 72 79 76 61 6c 73 als)).. (qryvals
1820: 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 (append (list
1830: 20 72 75 6e 6e 61 6d 65 29 20 6b 65 79 76 61 6c runname) keyval
1840: 73 29 29 0a 09 20 28 6b 65 79 3d 3f 73 74 72 20 s)).. (key=?str
1850: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
1860: 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 erse (map (lambd
1870: 61 20 28 6b 29 28 63 6f 6e 63 20 28 6b 65 79 3a a (k)(conc (key:
1880: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 29 get-fieldname k)
1890: 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 20 22 20 "=?")) keys) "
18a0: 41 4e 44 20 22 29 29 29 0a 20 20 20 20 28 64 65 AND "))). (de
18b0: 62 75 67 3a 70 72 69 6e 74 20 33 20 22 6b 65 79 bug:print 3 "key
18c0: 73 3a 20 22 20 6b 65 79 73 20 22 20 61 6c 6c 76 s: " keys " allv
18d0: 61 6c 73 3a 20 22 20 61 6c 6c 76 61 6c 73 20 22 als: " allvals "
18e0: 20 6b 65 79 76 61 6c 73 3a 20 22 20 6b 65 79 76 keyvals: " keyv
18f0: 61 6c 73 29 0a 20 20 20 20 28 64 65 62 75 67 3a als). (debug:
1900: 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 75 print 2 "NOTE: u
1910: 73 69 6e 67 20 74 61 72 67 65 74 20 22 20 28 73 sing target " (s
1920: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
1930: 65 20 6b 65 79 76 61 6c 73 20 22 2f 22 29 20 22 e keyvals "/") "
1940: 20 66 6f 72 20 74 68 69 73 20 72 75 6e 22 29 0a for this run").
1950: 20 20 20 20 28 69 66 20 28 61 6e 64 20 72 75 6e (if (and run
1960: 6e 61 6d 65 20 28 6e 75 6c 6c 3f 20 28 66 69 6c name (null? (fil
1970: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 ter (lambda (x)(
1980: 6e 6f 74 20 78 29 29 20 6b 65 79 76 61 6c 73 29 not x)) keyvals)
1990: 29 29 20 3b 3b 20 74 68 65 72 65 20 6d 75 73 74 )) ;; there must
19a0: 20 62 65 20 61 20 62 65 74 74 65 72 20 77 61 79 be a better way
19b0: 20 74 6f 20 22 61 70 70 6c 79 20 61 6e 64 22 0a to "apply and".
19c0: 09 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 .(let ((res #f))
19d0: 0a 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 .. (apply sqlit
19e0: 65 33 3a 65 78 65 63 75 74 65 20 64 62 20 28 63 e3:execute db (c
19f0: 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 49 onc "INSERT OR I
1a00: 47 4e 4f 52 45 20 49 4e 54 4f 20 72 75 6e 73 20 GNORE INTO runs
1a10: 28 72 75 6e 6e 61 6d 65 2c 73 74 61 74 65 2c 73 (runname,state,s
1a20: 74 61 74 75 73 2c 6f 77 6e 65 72 2c 65 76 65 6e tatus,owner,even
1a30: 74 5f 74 69 6d 65 22 20 63 6f 6d 6d 61 20 6b 65 t_time" comma ke
1a40: 79 73 74 72 20 22 29 20 56 41 4c 55 45 53 20 28 ystr ") VALUES (
1a50: 3f 2c 3f 2c 3f 2c 3f 2c 73 74 72 66 74 69 6d 65 ?,?,?,?,strftime
1a60: 28 27 25 73 27 2c 27 6e 6f 77 27 29 22 20 63 6f ('%s','now')" co
1a70: 6d 6d 61 20 76 61 6c 73 6c 6f 74 73 20 22 29 3b mma valslots ");
1a80: 22 29 0a 09 09 20 61 6c 6c 76 61 6c 73 29 0a 09 ")... allvals)..
1a90: 20 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 (apply sqlite3
1aa0: 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 20 0a 09 :for-each-row ..
1ab0: 20 20 20 28 6c 61 6d 62 64 61 20 28 69 64 29 0a (lambda (id).
1ac0: 09 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 . (set! res
1ad0: 69 64 29 29 0a 09 20 20 20 64 62 0a 09 20 20 20 id)).. db..
1ae0: 28 6c 65 74 20 28 28 71 72 79 20 28 63 6f 6e 63 (let ((qry (conc
1af0: 20 22 53 45 4c 45 43 54 20 69 64 20 46 52 4f 4d "SELECT id FROM
1b00: 20 72 75 6e 73 20 57 48 45 52 45 20 28 72 75 6e runs WHERE (run
1b10: 6e 61 6d 65 3d 3f 20 22 20 61 6e 64 73 74 72 20 name=? " andstr
1b20: 6b 65 79 3d 3f 73 74 72 20 22 29 3b 22 29 29 29 key=?str ");")))
1b30: 0a 09 20 20 20 20 20 3b 28 64 65 62 75 67 3a 70 .. ;(debug:p
1b40: 72 69 6e 74 20 34 20 22 71 72 79 3a 20 22 20 71 rint 4 "qry: " q
1b50: 72 79 29 20 0a 09 20 20 20 20 20 71 72 79 29 0a ry) .. qry).
1b60: 09 20 20 20 71 72 79 76 61 6c 73 29 0a 09 20 20 . qryvals)..
1b70: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
1b80: 20 64 62 20 22 55 50 44 41 54 45 20 72 75 6e 73 db "UPDATE runs
1b90: 20 53 45 54 20 73 74 61 74 65 3d 3f 2c 73 74 61 SET state=?,sta
1ba0: 74 75 73 3d 3f 20 57 48 45 52 45 20 69 64 3d 3f tus=? WHERE id=?
1bb0: 3b 22 20 73 74 61 74 65 20 73 74 61 74 75 73 20 ;" state status
1bc0: 72 65 73 29 0a 09 20 20 72 65 73 29 20 0a 09 28 res).. res) ..(
1bd0: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
1be0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
1bf0: 43 61 6c 6c 65 64 20 77 69 74 68 6f 75 74 20 61 Called without a
1c00: 6c 6c 20 6e 65 63 65 73 73 61 72 79 20 6b 65 79 ll necessary key
1c10: 73 22 29 0a 09 20 20 23 66 29 29 29 29 0a 0a 3b s").. #f))))..;
1c20: 3b 20 54 68 69 73 20 69 73 20 61 20 64 75 70 6c ; This is a dupl
1c30: 69 63 61 74 65 20 6f 66 20 72 75 6e 2d 74 65 73 icate of run-tes
1c40: 74 73 20 28 77 68 69 63 68 20 68 61 73 20 62 65 ts (which has be
1c50: 65 6e 20 64 65 70 72 65 63 61 74 65 64 29 2e 20 en deprecated).
1c60: 55 73 65 20 74 68 69 73 20 6f 6e 65 20 69 6e 73 Use this one ins
1c70: 74 65 61 64 20 6f 66 20 72 75 6e 20 74 65 73 74 tead of run test
1c80: 73 2e 0a 3b 3b 20 6b 65 79 76 61 6c 73 0a 28 64 s..;; keyvals.(d
1c90: 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d efine (runs:run-
1ca0: 74 65 73 74 73 20 64 62 20 74 61 72 67 65 74 20 tests db target
1cb0: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 runname test-pat
1cc0: 74 73 20 75 73 65 72 20 66 6c 61 67 73 29 0a 20 ts user flags).
1cd0: 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 (let* ((keys
1ce0: 20 20 20 20 20 28 64 62 3a 67 65 74 2d 6b 65 79 (db:get-key
1cf0: 73 20 64 62 29 29 0a 09 20 28 6b 65 79 76 61 6c s db)).. (keyval
1d00: 6c 73 74 20 20 20 28 6b 65 79 73 3a 74 61 72 67 lst (keys:targ
1d10: 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 et->keyval keys
1d20: 74 61 72 67 65 74 29 29 0a 09 20 28 72 75 6e 2d target)).. (run-
1d30: 69 64 20 20 20 20 20 20 28 72 75 6e 73 3a 72 65 id (runs:re
1d40: 67 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 gister-run db ke
1d50: 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e ys keyvallst run
1d60: 6e 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 name "new" "n/a"
1d70: 20 75 73 65 72 29 29 20 20 3b 3b 20 20 74 65 73 user)) ;; tes
1d80: 74 2d 6e 61 6d 65 29 29 29 0a 09 20 28 64 65 66 t-name))).. (def
1d90: 65 72 72 65 64 20 20 20 20 27 28 29 29 20 3b 3b erred '()) ;;
1da0: 20 64 65 6c 61 79 20 72 75 6e 6e 69 6e 67 20 74 delay running t
1db0: 68 65 73 65 20 73 69 6e 63 65 20 74 68 65 79 20 hese since they
1dc0: 68 61 76 65 20 61 20 77 61 69 74 6f 6e 20 63 6c have a waiton cl
1dd0: 61 75 73 65 0a 09 20 3b 3b 20 6b 65 65 70 67 6f ause.. ;; keepgo
1de0: 69 6e 67 20 69 73 20 74 68 65 20 64 65 66 61 63 ing is the defac
1df0: 74 6f 20 6d 6f 64 61 6c 69 74 79 20 6e 6f 77 2c to modality now,
1e00: 20 77 69 6c 6c 20 61 64 64 20 68 69 74 2d 6e 2d will add hit-n-
1e10: 72 75 6e 20 61 20 62 69 74 20 6c 61 74 65 72 0a run a bit later.
1e20: 09 20 3b 3b 20 28 6b 65 65 70 67 6f 69 6e 67 20 . ;; (keepgoing
1e30: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
1e40: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
1e50: 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 "-keepgoing" #f)
1e60: 29 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 73 20 ).. (test-names
1e70: 20 27 28 29 29 0a 09 20 28 72 75 6e 63 6f 6e 66 '()).. (runconf
1e80: 69 67 66 20 20 20 28 63 6f 6e 63 20 20 2a 74 6f igf (conc *to
1e90: 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 ppath* "/runconf
1ea0: 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 igs.config"))..
1eb0: 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 (required-tests
1ec0: 27 28 29 29 0a 09 20 28 74 65 73 74 2d 72 65 63 '()).. (test-rec
1ed0: 6f 72 64 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d ords (make-hash-
1ee0: 74 61 62 6c 65 29 29 29 0a 0a 20 20 20 20 28 73 table))).. (s
1ef0: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d et-megatest-env-
1f00: 76 61 72 73 20 64 62 20 72 75 6e 2d 69 64 29 20 vars db run-id)
1f10: 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 ;; these may be
1f20: 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 needed by the la
1f30: 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a unching process.
1f40: 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 . (if (file-e
1f50: 78 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 xists? runconfig
1f60: 66 29 0a 09 28 73 65 74 75 70 2d 65 6e 76 2d 64 f)..(setup-env-d
1f70: 65 66 61 75 6c 74 73 20 64 62 20 72 75 6e 63 6f efaults db runco
1f80: 6e 66 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c nfigf run-id *al
1f90: 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f ready-seen-runco
1fa0: 6e 66 69 67 2d 69 6e 66 6f 2a 20 22 70 72 65 2d nfig-info* "pre-
1fb0: 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 22 launch-env-vars"
1fc0: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
1fd0: 30 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 0 "WARNING: You
1fe0: 64 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 do not have a ru
1ff0: 6e 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 n config file: "
2000: 20 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 20 20 runconfigf)).
2010: 20 20 0a 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 . ;; look u
2020: 70 20 61 6c 6c 20 74 65 73 74 73 20 6d 61 74 63 p all tests matc
2030: 68 69 6e 67 20 74 68 65 20 63 6f 6d 6d 61 20 73 hing the comma s
2040: 65 70 61 72 61 74 65 64 20 6c 69 73 74 20 6f 66 eparated list of
2050: 20 67 6c 6f 62 73 20 69 6e 0a 20 20 20 20 3b 3b globs in. ;;
2060: 20 74 65 73 74 2d 70 61 74 74 73 20 28 75 73 69 test-patts (usi
2070: 6e 67 20 25 20 61 73 20 77 69 6c 64 63 61 72 64 ng % as wildcard
2080: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
2090: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 . (lambda (p
20a0: 61 74 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 att). (let
20b0: 20 28 28 74 65 73 74 73 20 28 67 6c 6f 62 20 28 ((tests (glob (
20c0: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
20d0: 2f 74 65 73 74 73 2f 22 20 28 73 74 72 69 6e 67 /tests/" (string
20e0: 2d 74 72 61 6e 73 6c 61 74 65 20 70 61 74 74 20 -translate patt
20f0: 22 25 22 20 22 2a 22 29 29 29 29 29 0a 09 20 28 "%" "*"))))).. (
2100: 73 65 74 21 20 74 65 73 74 73 20 28 66 69 6c 74 set! tests (filt
2110: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 er (lambda (test
2120: 29 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 )(file-exists? (
2130: 63 6f 6e 63 20 74 65 73 74 20 22 2f 74 65 73 74 conc test "/test
2140: 63 6f 6e 66 69 67 22 29 29 29 20 74 65 73 74 73 config"))) tests
2150: 29 29 0a 09 20 28 73 65 74 21 20 74 65 73 74 2d )).. (set! test-
2160: 6e 61 6d 65 73 20 28 61 70 70 65 6e 64 20 74 65 names (append te
2170: 73 74 2d 6e 61 6d 65 73 20 0a 09 09 09 09 20 20 st-names .....
2180: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 (map (lambda (te
2190: 73 74 70 29 0a 09 09 09 09 09 20 28 6c 61 73 74 stp)...... (last
21a0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 (string-split t
21b0: 65 73 74 70 20 22 2f 22 29 29 29 0a 09 09 09 09 estp "/"))).....
21c0: 20 20 20 20 20 20 20 74 65 73 74 73 29 29 29 29 tests))))
21d0: 29 0a 20 20 20 20 20 28 69 66 20 74 65 73 74 2d ). (if test-
21e0: 70 61 74 74 73 20 28 73 74 72 69 6e 67 2d 73 70 patts (string-sp
21f0: 6c 69 74 20 74 65 73 74 2d 70 61 74 74 73 20 22 lit test-patts "
2200: 2c 22 29 28 6c 69 73 74 20 22 25 22 29 29 29 0a ,")(list "%"))).
2210: 0a 20 20 20 20 20 3b 3b 20 6e 6f 77 20 72 65 6d . ;; now rem
2220: 6f 76 65 20 64 75 70 6c 69 63 61 74 65 73 0a 20 ove duplicates.
2230: 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 (set! test-na
2240: 6d 65 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c mes (delete-dupl
2250: 69 63 61 74 65 73 20 74 65 73 74 2d 6e 61 6d 65 icates test-name
2260: 73 29 29 0a 0a 20 20 20 20 28 64 65 62 75 67 3a s)).. (debug:
2270: 70 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 74 print 0 "INFO: t
2280: 65 73 74 20 6e 61 6d 65 73 20 22 20 74 65 73 74 est names " test
2290: 2d 6e 61 6d 65 73 29 0a 0a 20 20 20 20 3b 3b 20 -names).. ;;
22a0: 6f 6e 20 74 68 65 20 66 69 72 73 74 20 70 61 73 on the first pas
22b0: 73 20 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e s or call to run
22c0: 2d 74 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 -tests set FAILS
22d0: 20 74 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 to NOT_STARTED
22e0: 69 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 if. ;; -keepg
22f0: 6f 69 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 oing is specifie
2300: 64 0a 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a d. (if (eq? *
2310: 70 61 73 73 6e 75 6d 2a 20 30 29 0a 09 28 62 65 passnum* 0)..(be
2320: 67 69 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 gin.. ;; have t
2330: 6f 20 64 65 6c 65 74 65 20 74 65 73 74 20 72 65 o delete test re
2340: 63 6f 72 64 73 20 77 68 65 72 65 20 4e 4f 54 5f cords where NOT_
2350: 53 54 41 52 54 45 44 20 73 69 6e 63 65 20 74 68 STARTED since th
2360: 65 79 20 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 ey can cause -ke
2370: 65 70 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b epgoing to .. ;
2380: 3b 20 67 65 74 20 73 74 75 63 6b 20 64 75 65 20 ; get stuck due
2390: 74 6f 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 to becoming inac
23a0: 63 65 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 cessible from a
23b0: 66 61 69 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 failed test. I.e
23c0: 2e 20 69 66 20 74 65 73 74 20 42 20 64 65 70 65 . if test B depe
23d0: 6e 64 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 nds .. ;; on te
23e0: 73 74 20 41 20 62 75 74 20 74 65 73 74 20 42 20 st A but test B
23f0: 72 65 61 63 68 65 64 20 74 68 65 20 70 6f 69 6e reached the poin
2400: 74 20 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 73 t on being regis
2410: 74 65 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 tered as NOT_STA
2420: 52 54 45 44 20 61 6e 64 20 74 65 73 74 0a 09 20 RTED and test..
2430: 20 3b 3b 20 41 20 66 61 69 6c 65 64 20 66 6f 72 ;; A failed for
2440: 20 73 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 some reason the
2450: 6e 20 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e n on re-run usin
2460: 67 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 g -keepgoing the
2470: 20 72 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 run can never c
2480: 6f 6d 70 6c 65 74 65 2e 0a 09 20 20 28 64 62 3a omplete... (db:
2490: 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d delete-tests-in-
24a0: 73 74 61 74 65 20 64 62 20 72 75 6e 2d 69 64 20 state db run-id
24b0: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 09 "NOT_STARTED")..
24c0: 20 20 28 64 62 3a 73 65 74 2d 74 65 73 74 73 2d (db:set-tests-
24d0: 73 74 61 74 65 2d 73 74 61 74 75 73 20 64 62 20 state-status db
24e0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
24f0: 73 20 23 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 s #f "FAIL" "NOT
2500: 5f 53 54 41 52 54 45 44 22 20 22 46 41 49 4c 22 _STARTED" "FAIL"
2510: 29 29 29 0a 0a 20 20 20 20 3b 3b 20 66 72 6f 6d ))).. ;; from
2520: 20 68 65 72 65 20 6f 6e 20 6f 75 74 20 74 68 65 here on out the
2530: 20 64 62 20 77 69 6c 6c 20 62 65 20 6f 70 65 6e db will be open
2540: 65 64 20 61 6e 64 20 63 6c 6f 73 65 64 20 6f 6e ed and closed on
2550: 20 65 76 65 72 79 20 63 61 6c 6c 20 72 75 6e 73 every call runs
2560: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
2570: 0a 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 . (sqlite3:fi
2580: 6e 61 6c 69 7a 65 21 20 64 62 29 20 0a 20 20 20 nalize! db) .
2590: 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e 6f 6e 2d ;; now add non-
25a0: 64 69 72 65 63 74 6c 79 20 72 65 66 65 72 65 6e directly referen
25b0: 63 65 64 20 64 65 70 65 6e 64 65 6e 63 69 65 73 ced dependencies
25c0: 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e 29 0a 20 (i.e. waiton).
25d0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
25e0: 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a l? test-names)).
25f0: 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 .(let loop ((hed
2600: 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d 65 73 (car test-names
2610: 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 64 ))... (tal (cd
2620: 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 20 r test-names)))
2630: 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 74 75 ;; 'retu
2640: 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 20 74 rn-procs tells t
2650: 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 65 72 he config reader
2660: 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 6e 67 to prep running
2670: 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 74 75 system but retu
2680: 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 28 64 65 rn a proc.. (de
2690: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 bug:print 4 "INF
26a0: 4f 3a 20 68 65 64 3d 22 20 68 65 64 20 22 20 61 O: hed=" hed " a
26b0: 74 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 22 29 0a t top of loop").
26c0: 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 66 69 . (let* ((confi
26d0: 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 g (tests:get-te
26e0: 73 74 63 6f 6e 66 69 67 20 68 65 64 20 27 72 65 stconfig hed 're
26f0: 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 09 20 turn-procs))...
2700: 28 77 61 69 74 6f 6e 73 20 28 69 66 20 63 6f 6e (waitons (if con
2710: 66 69 67 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 fig (string-spli
2720: 74 20 28 6c 65 74 20 28 28 77 20 28 63 6f 6e 66 t (let ((w (conf
2730: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
2740: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
2750: 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 09 09 09 "waiton"))).....
2760: 09 09 20 20 20 20 20 28 69 66 20 77 20 77 20 22 .. (if w w "
2770: 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 "))).... (b
2780: 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a egin.....(debug:
2790: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
27a0: 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 non-existent req
27b0: 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 68 uired test \"" h
27c0: 65 64 20 22 5c 22 22 29 0a 20 20 20 20 20 20 20 ed "\"").
27d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27e0: 20 20 20 20 20 20 20 20 20 28 73 71 6c 69 74 65 (sqlite
27f0: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 3:finalize! db).
2800: 09 09 09 09 28 65 78 69 74 20 31 29 29 29 29 29 ....(exit 1)))))
2810: 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 .. ;; check f
2820: 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e or hed in waiton
2830: 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 s => this would
2840: 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d be circular, rem
2850: 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 ove it and issue
2860: 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f an.. ;; erro
2870: 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 r.. (if (memb
2880: 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a er hed waitons).
2890: 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 ..(begin... (de
28a0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
28b0: 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 OR: test " hed "
28c0: 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 has listed itse
28d0: 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 lf as a waiton,
28e0: 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 please correct t
28f0: 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 his!")... (set!
2900: 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 65 72 waitons (filter
2910: 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 (lambda (x)(not
2920: 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 (equal? x hed))
2930: 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a 09 20 ) waitons))))..
2940: 20 20 20 0a 09 20 20 20 20 3b 3b 20 28 69 74 65 .. ;; (ite
2950: 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 74 2d ms (items:get-
2960: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
2970: 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 20 20 20 g config)))..
2980: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
2990: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
29a0: 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 t test-records h
29b0: 65 64 20 23 66 29 29 0a 09 09 28 68 61 73 68 2d ed #f))...(hash-
29c0: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
29d0: 72 65 63 6f 72 64 73 0a 09 09 09 09 20 68 65 64 records..... hed
29e0: 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 20 20 (vector hed
29f0: 20 3b 3b 20 30 0a 09 09 09 09 09 20 20 20 20 20 ;; 0......
2a00: 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 09 09 config ;; 1....
2a10: 09 09 20 20 20 20 20 77 61 69 74 6f 6e 73 20 3b .. waitons ;
2a20: 3b 20 32 0a 09 09 09 09 09 20 20 20 20 20 28 63 ; 2...... (c
2a30: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e onfig-lookup con
2a40: 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 fig "requirement
2a50: 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 20 20 s" "priority")
2a60: 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 33 ;; priority 3
2a70: 0a 09 09 09 09 09 20 20 20 20 20 28 6c 65 74 20 ...... (let
2a80: 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 68 61 ((items (ha
2a90: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
2aa0: 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 ault config "ite
2ab0: 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 65 6d ms" #f)) ;; item
2ac0: 73 20 34 0a 09 09 09 09 09 09 20 20 20 28 69 74 s 4....... (it
2ad0: 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 2d 74 emstable (hash-t
2ae0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
2af0: 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 74 61 config "itemsta
2b00: 62 6c 65 22 20 23 66 29 29 29 20 0a 09 09 09 09 ble" #f))) .....
2b10: 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 65 69 . ;; if ei
2b20: 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 69 74 ther items or it
2b30: 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 20 70 ems table is a p
2b40: 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 73 6f roc return it so
2b50: 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a 09 09 test running...
2b60: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 70 72 6f ... ;; pro
2b70: 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 74 6f cess can know to
2b80: 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 74 2d call items:get-
2b90: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
2ba0: 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b g...... ;;
2bb0: 20 69 66 20 65 69 74 68 65 72 20 69 73 20 61 20 if either is a
2bc0: 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 69 73 list and none is
2bd0: 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 61 64 a proc go ahead
2be0: 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d 69 74 and call get-it
2bf0: 65 6d 73 0a 09 09 09 09 09 20 20 20 20 20 20 20 ems......
2c00: 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 65 74 ;; otherwise ret
2c10: 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 69 73 urn #f - this is
2c20: 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 65 64 not an iterated
2c30: 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 20 20 test......
2c40: 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 28 28 (cond.......((
2c50: 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 procedure? items
2c60: 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 20 28 ) ....... (
2c70: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 debug:print 4 "I
2c80: 4e 46 4f 3a 20 69 74 65 6d 73 20 69 73 20 61 20 NFO: items is a
2c90: 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 procedure, will
2ca0: 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 calc later")....
2cb0: 09 09 09 20 69 74 65 6d 73 29 20 20 20 20 20 20 ... items)
2cc0: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
2cd0: 74 65 72 0a 09 09 09 09 09 09 28 28 70 72 6f 63 ter.......((proc
2ce0: 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 6c edure? itemstabl
2cf0: 65 29 0a 09 09 09 09 09 09 20 28 64 65 62 75 67 e)....... (debug
2d00: 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 :print 4 "INFO:
2d10: 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 itemstable is a
2d20: 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 procedure, will
2d30: 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 calc later")....
2d40: 09 09 09 20 69 74 65 6d 73 74 61 62 6c 65 29 20 ... itemstable)
2d50: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
2d60: 74 65 72 0a 09 09 09 09 09 09 28 28 66 69 6c 74 ter.......((filt
2d70: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
2d80: 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 ...... (let ((
2d90: 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 val (car x)))...
2da0: 09 09 09 09 09 20 20 20 20 20 28 69 66 20 28 70 ..... (if (p
2db0: 72 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 rocedure? val) v
2dc0: 61 6c 20 23 66 29 29 29 0a 09 09 09 09 09 09 09 al #f)))........
2dd0: 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 (append (if (li
2de0: 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 73 st? items) items
2df0: 20 27 28 29 29 0a 09 09 09 09 09 09 09 09 20 28 '())......... (
2e00: 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 if (list? itemst
2e10: 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 able) itemstable
2e20: 20 27 28 29 29 29 29 0a 09 09 09 09 09 09 20 27 '())))....... '
2e30: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 0a have-procedure).
2e40: 09 09 09 09 09 09 28 28 6f 72 20 28 6c 69 73 74 ......((or (list
2e50: 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 ? items)(list? i
2e60: 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 temstable)) ;; c
2e70: 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 28 alc now....... (
2e80: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 debug:print 4 "I
2e90: 4e 46 4f 3a 20 69 74 65 6d 73 20 61 6e 64 20 69 NFO: items and i
2ea0: 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c 69 temstable are li
2eb0: 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 sts, calc now\n"
2ec0: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 22 20 ........ "
2ed0: 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d items: " item
2ee0: 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 s " itemstable:
2ef0: 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 " itemstable)...
2f00: 09 09 09 09 20 28 69 74 65 6d 73 3a 67 65 74 2d .... (items:get-
2f10: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
2f20: 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 g config))......
2f30: 09 28 65 6c 73 65 20 23 66 29 29 29 20 20 20 20 .(else #f)))
2f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f50: 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 ;; not it
2f60: 65 72 61 74 65 64 0a 09 09 09 09 09 20 20 20 20 erated......
2f70: 20 23 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d #f ;; item
2f80: 73 64 61 74 20 35 0a 09 09 09 09 09 20 20 20 20 sdat 5......
2f90: 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 #f ;; spar
2fa0: 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 e - used for ite
2fb0: 6d 2d 70 61 74 68 0a 09 09 09 09 09 20 20 20 20 m-path......
2fc0: 20 29 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 ))).. (for-e
2fd0: 61 63 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 ach .. (lamb
2fe0: 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 da (waiton)..
2ff0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 (if (and wai
3000: 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 ton (not (member
3010: 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d waiton test-nam
3020: 65 73 29 29 29 0a 09 09 20 20 20 28 62 65 67 69 es)))... (begi
3030: 6e 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 72 n... (set! r
3040: 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 equired-tests (c
3050: 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 ons waiton requi
3060: 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 red-tests))...
3070: 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 (set! test-na
3080: 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e mes (cons waiton
3090: 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 test-names)))))
30a0: 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e ;; was an appen
30b0: 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 20 d, now a cons..
30c0: 20 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 waitons)..
30d0: 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 (let ((remtest
30e0: 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 s (delete-duplic
30f0: 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 ates (append wai
3100: 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 tons tal))))..
3110: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
3120: 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 ll? remtests))..
3130: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 . (loop (car re
3140: 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 mtests)(cdr remt
3150: 65 73 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 ests)))))))..
3160: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
3170: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 required-tests)
3180: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
3190: 31 20 22 49 4e 46 4f 3a 20 41 64 64 69 6e 67 20 1 "INFO: Adding
31a0: 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 " required-tests
31b0: 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 " to the run qu
31c0: 65 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f eue")). ;; NO
31d0: 54 45 3a 20 74 68 65 73 65 20 61 72 65 20 61 6c TE: these are al
31e0: 6c 20 70 61 72 65 6e 74 20 74 65 73 74 73 2c 20 l parent tests,
31f0: 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 items are not ex
3200: 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 20 panded yet..
3210: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
3220: 49 4e 46 4f 3a 20 74 65 73 74 2d 72 65 63 6f 72 INFO: test-recor
3230: 64 73 3d 22 20 28 68 61 73 68 2d 74 61 62 6c 65 ds=" (hash-table
3240: 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 72 65 63 ->alist test-rec
3250: 6f 72 64 73 29 29 0a 20 20 20 20 28 72 75 6e 73 ords)). (runs
3260: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
3270: 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 run-id runname
3280: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 test-records key
3290: 76 61 6c 6c 73 74 20 66 6c 61 67 73 29 0a 20 20 vallst flags).
32a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
32b0: 20 22 49 4e 46 4f 3a 20 72 75 6e 6e 69 6e 67 20 "INFO: running
32c0: 71 75 65 75 65 20 6f 6e 65 20 6d 6f 72 65 20 74 queue one more t
32d0: 69 6d 65 20 74 6f 20 63 61 74 63 68 20 61 6e 79 ime to catch any
32e0: 20 63 68 61 6e 67 65 64 20 74 65 73 74 20 73 74 changed test st
32f0: 61 74 65 73 22 29 0a 20 20 20 20 28 72 75 6e 73 ates"). (runs
3300: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
3310: 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 run-id runname
3320: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 test-records key
3330: 76 61 6c 6c 73 74 20 66 6c 61 67 73 29 0a 20 20 vallst flags).
3340: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
3350: 20 22 49 4e 46 4f 3a 20 41 6c 6c 20 64 6f 6e 65 "INFO: All done
3360: 20 62 79 20 68 65 72 65 22 29 29 29 0a 0a 3b 3b by here")))..;;
3370: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 69 73 test-records is
3380: 20 61 20 68 61 73 68 20 74 61 62 6c 65 20 74 65 a hash table te
3390: 73 74 6e 61 6d 65 3a 69 74 65 6d 5f 70 61 74 68 stname:item_path
33a0: 20 3d 3e 20 76 65 63 74 6f 72 20 3c 20 74 65 73 => vector < tes
33b0: 74 6e 61 6d 65 20 74 65 73 74 63 6f 6e 66 69 67 tname testconfig
33c0: 20 77 61 69 74 6f 6e 73 20 70 72 69 6f 72 69 74 waitons priorit
33d0: 79 20 69 74 65 6d 73 2d 69 6e 66 6f 20 2e 2e 2e y items-info ...
33e0: 20 3e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 >.(define (runs
33f0: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
3400: 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 run-id runname
3410: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 test-records key
3420: 76 61 6c 6c 73 74 20 66 6c 61 67 73 29 0a 20 20 vallst flags).
3430: 20 20 3b 3b 20 41 74 20 74 68 69 73 20 70 6f 69 ;; At this poi
3440: 6e 74 20 74 68 65 20 6c 69 73 74 20 6f 66 20 70 nt the list of p
3450: 61 72 65 6e 74 20 74 65 73 74 73 20 69 73 20 65 arent tests is e
3460: 78 70 61 6e 64 65 64 20 0a 20 20 20 20 3b 3b 20 xpanded . ;;
3470: 4e 42 2f 2f 20 53 68 6f 75 6c 64 20 65 78 70 61 NB// Should expa
3480: 6e 64 20 69 74 65 6d 73 20 68 65 72 65 20 61 6e nd items here an
3490: 64 20 74 68 65 6e 20 69 6e 73 65 72 74 20 69 6e d then insert in
34a0: 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 65 to the run queue
34b0: 2e 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
34c0: 20 35 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 5 "test-records
34d0: 3a 20 22 20 74 65 73 74 2d 72 65 63 6f 72 64 73 : " test-records
34e0: 20 22 2c 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 ", keyvallst: "
34f0: 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 66 6c 61 keyvallst " fla
3500: 67 73 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c gs: " (hash-tabl
3510: 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 29 e->alist flags))
3520: 0a 20 20 28 6c 65 74 20 28 28 73 6f 72 74 65 64 . (let ((sorted
3530: 2d 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 73 -test-names (tes
3540: 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f 72 ts:sort-by-prior
3550: 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 74 ity-and-waiton t
3560: 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 28 est-records))..(
3570: 69 74 65 6d 2d 70 61 74 74 73 20 20 20 20 20 20 item-patts
3580: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
3590: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
35a0: 22 2d 69 74 65 6d 70 61 74 74 22 20 23 66 29 29 "-itempatt" #f))
35b0: 0a 09 28 74 65 73 74 2d 72 65 67 69 73 74 65 72 ..(test-register
35c0: 79 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d y (make-hash-
35d0: 74 61 62 6c 65 29 29 0a 09 28 6e 75 6d 2d 72 65 table))..(num-re
35e0: 74 72 69 65 73 20 20 20 20 20 20 20 20 30 29 0a tries 0).
35f0: 09 28 6d 61 78 2d 72 65 74 72 69 65 73 20 20 20 .(max-retries
3600: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
3610: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
3620: 73 65 74 75 70 22 20 22 6d 61 78 72 65 74 72 69 setup" "maxretri
3630: 65 73 22 29 29 29 0a 20 20 20 20 28 73 65 74 21 es"))). (set!
3640: 20 6d 61 78 2d 72 65 74 72 69 65 73 20 28 69 66 max-retries (if
3650: 20 28 61 6e 64 20 6d 61 78 2d 72 65 74 72 69 65 (and max-retrie
3660: 73 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 s (string->numbe
3670: 72 20 6d 61 78 2d 72 65 74 72 69 65 73 29 29 28 r max-retries))(
3680: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d string->number m
3690: 61 78 2d 72 65 74 72 69 65 73 29 20 31 30 30 29 ax-retries) 100)
36a0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
36b0: 6e 75 6c 6c 3f 20 73 6f 72 74 65 64 2d 74 65 73 null? sorted-tes
36c0: 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 t-names))..(let
36d0: 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 loop ((hed
36e0: 20 20 20 28 63 61 72 20 73 6f 72 74 65 64 2d 74 (car sorted-t
36f0: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 est-names))...
3700: 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 28 63 (tal (c
3710: 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e dr sorted-test-n
3720: 61 6d 65 73 29 29 0a 09 09 20 20 20 28 72 65 72 ames))... (rer
3730: 75 6e 73 20 20 20 20 20 20 27 28 29 29 29 0a 09 uns '()))..
3740: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
3750: 3f 20 72 65 72 75 6e 73 29 29 28 64 65 62 75 67 ? reruns))(debug
3760: 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 :print 4 "INFO:
3770: 72 65 72 75 6e 73 3d 22 20 72 65 72 75 6e 73 29 reruns=" reruns)
3780: 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 65 73 ).. (let* ((tes
3790: 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 t-record (hash-t
37a0: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
37b0: 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 cords hed))... (
37c0: 74 65 73 74 2d 6e 61 6d 65 20 20 20 28 74 65 73 test-name (tes
37d0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
37e0: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 -testname test-r
37f0: 65 63 6f 72 64 29 29 0a 09 09 20 28 74 63 6f 6e ecord))... (tcon
3800: 66 69 67 20 20 20 20 20 28 74 65 73 74 73 3a 74 fig (tests:t
3810: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
3820: 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 tconfig test-rec
3830: 6f 72 64 29 29 0a 09 09 20 28 74 65 73 74 6d 6f ord))... (testmo
3840: 64 65 20 20 20 20 28 6c 65 74 20 28 28 6d 20 28 de (let ((m (
3850: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 config-lookup tc
3860: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
3870: 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 29 0a 09 nts" "mode")))..
3880: 09 09 09 28 69 66 20 6d 20 28 73 74 72 69 6e 67 ...(if m (string
3890: 2d 3e 73 79 6d 62 6f 6c 20 6d 29 20 27 6e 6f 72 ->symbol m) 'nor
38a0: 6d 61 6c 29 29 29 0a 09 09 20 28 77 61 69 74 6f mal)))... (waito
38b0: 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 ns (tests:te
38c0: 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
38d0: 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 63 6f ons test-reco
38e0: 72 64 29 29 0a 09 09 20 28 70 72 69 6f 72 69 74 rd))... (priorit
38f0: 79 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 y (tests:test
3900: 71 75 65 75 65 2d 67 65 74 2d 70 72 69 6f 72 69 queue-get-priori
3910: 74 79 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 ty test-record
3920: 29 29 0a 09 09 20 28 69 74 65 6d 64 61 74 20 20 ))... (itemdat
3930: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
3940: 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 eue-get-itemdat
3950: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
3960: 20 3b 3b 20 69 74 65 6d 64 61 74 20 63 61 6e 20 ;; itemdat can
3970: 62 65 20 61 20 73 74 72 69 6e 67 2c 20 6c 69 73 be a string, lis
3980: 74 20 6f 72 20 23 66 0a 09 09 20 28 69 74 65 6d t or #f... (item
3990: 73 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 s (tests:t
39a0: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 estqueue-get-ite
39b0: 6d 73 20 20 20 20 20 20 74 65 73 74 2d 72 65 63 ms test-rec
39c0: 6f 72 64 29 29 0a 09 09 20 28 69 74 65 6d 2d 70 ord))... (item-p
39d0: 61 74 68 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 ath (item-list
39e0: 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 ->path itemdat))
39f0: 0a 09 09 20 28 6e 65 77 74 61 6c 20 20 20 20 20 ... (newtal
3a00: 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 (append tal (li
3a10: 73 74 20 68 65 64 29 29 29 0a 09 09 20 28 63 61 st hed)))... (ca
3a20: 6c 63 2d 66 61 69 6c 73 20 20 28 6c 61 6d 62 64 lc-fails (lambd
3a30: 61 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d a (prereqs-not-m
3a40: 65 74 29 0a 09 09 09 09 28 66 69 6c 74 65 72 20 et).....(filter
3a50: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 (lambda (test)..
3a60: 09 09 09 09 20 20 28 61 6e 64 20 28 76 65 63 74 .... (and (vect
3a70: 6f 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 or? test) ;; not
3a80: 20 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 (string? test))
3a90: 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 65 71 ...... (eq
3aa0: 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 ual? (db:test-ge
3ab0: 74 2d 73 74 61 74 65 20 74 65 73 74 29 20 22 43 t-state test) "C
3ac0: 4f 4d 50 4c 45 54 45 44 22 29 0a 09 09 09 09 09 OMPLETED")......
3ad0: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 6d 65 6d (not (mem
3ae0: 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
3af0: 2d 73 74 61 74 75 73 20 74 65 73 74 29 0a 09 09 -status test)...
3b00: 09 09 09 09 09 20 20 20 20 27 28 22 50 41 53 53 ..... '("PASS
3b10: 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 " "WARN" "CHECK"
3b20: 20 22 57 41 49 56 45 44 22 29 29 29 29 29 0a 09 "WAIVED")))))..
3b30: 09 09 09 09 70 72 65 72 65 71 73 2d 6e 6f 74 2d ....prereqs-not-
3b40: 6d 65 74 29 29 29 0a 09 09 20 28 63 61 6c 63 2d met)))... (calc-
3b50: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 28 6c not-completed (l
3b60: 61 6d 62 64 61 20 28 70 72 65 72 65 71 73 2d 6e ambda (prereqs-n
3b70: 6f 74 2d 6d 65 74 29 0a 09 09 09 09 20 20 20 20 ot-met).....
3b80: 20 20 20 28 66 69 6c 74 65 72 0a 09 09 09 09 09 (filter......
3b90: 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 09 09 09 (lambda (t).....
3ba0: 09 20 20 28 6f 72 20 28 6e 6f 74 20 28 76 65 63 . (or (not (vec
3bb0: 74 6f 72 3f 20 74 29 29 0a 09 09 09 09 09 20 20 tor? t))......
3bc0: 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (not (equal?
3bd0: 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 28 64 62 "COMPLETED" (db
3be0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
3bf0: 74 29 29 29 29 29 0a 09 09 09 09 09 70 72 65 72 t)))))......prer
3c00: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 eqs-not-met)))..
3c10: 09 20 28 70 72 65 74 74 79 2d 73 74 72 69 6e 67 . (pretty-string
3c20: 20 28 6c 61 6d 62 64 61 20 28 6c 73 74 29 0a 09 (lambda (lst)..
3c30: 09 09 09 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 ... (map (lambd
3c40: 61 20 28 74 29 0a 09 09 09 09 09 20 28 69 66 20 a (t)...... (if
3c50: 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 (not (vector? t)
3c60: 29 0a 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e )...... (con
3c70: 63 20 74 29 0a 09 09 09 09 09 20 20 20 20 20 28 c t)...... (
3c80: 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 65 conc (db:test-ge
3c90: 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 22 3a t-testname t) ":
3ca0: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
3cb0: 74 61 74 65 20 74 29 20 22 2f 22 20 28 64 62 3a tate t) "/" (db:
3cc0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
3cd0: 74 29 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 t)))).....
3ce0: 20 6c 73 74 29 29 29 29 0a 09 20 20 20 20 0a 09 lst)))).. ..
3cf0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3d00: 20 36 0a 09 09 09 20 22 74 65 73 74 2d 6e 61 6d 6.... "test-nam
3d10: 65 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 0a 09 e: " test-name..
3d20: 09 09 20 22 5c 6e 20 20 68 65 64 3a 20 20 20 20 .. "\n hed:
3d30: 20 20 20 20 20 22 20 68 65 64 0a 09 09 09 20 22 " hed.... "
3d40: 5c 6e 20 20 69 74 65 6d 64 61 74 3a 20 20 20 20 \n itemdat:
3d50: 20 22 20 69 74 65 6d 64 61 74 0a 09 09 09 20 22 " itemdat.... "
3d60: 5c 6e 20 20 69 74 65 6d 73 3a 20 20 20 20 20 20 \n items:
3d70: 20 22 20 69 74 65 6d 73 0a 09 09 09 20 22 5c 6e " items.... "\n
3d80: 20 20 69 74 65 6d 2d 70 61 74 68 3a 20 20 20 22 item-path: "
3d90: 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 20 22 item-path.... "
3da0: 5c 6e 20 20 77 61 69 74 6f 6e 73 3a 20 20 20 20 \n waitons:
3db0: 20 22 20 77 61 69 74 6f 6e 73 0a 09 09 09 20 22 " waitons.... "
3dc0: 5c 6e 20 20 6e 75 6d 2d 72 65 74 72 69 65 73 3a \n num-retries:
3dd0: 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 73 29 0a " num-retries).
3de0: 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 .. ;; check f
3df0: 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e or hed in waiton
3e00: 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 s => this would
3e10: 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d be circular, rem
3e20: 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 ove it and issue
3e30: 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f an.. ;; erro
3e40: 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 r.. (if (memb
3e50: 65 72 20 74 65 73 74 2d 6e 61 6d 65 20 77 61 69 er test-name wai
3e60: 74 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 tons)...(begin..
3e70: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
3e80: 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 0 "ERROR: test "
3e90: 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 68 61 73 test-name " has
3ea0: 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 61 listed itself a
3eb0: 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 61 s a waiton, plea
3ec0: 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 21 se correct this!
3ed0: 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 69 ")... (set! wai
3ee0: 74 6f 6e 20 28 66 69 6c 74 65 72 20 28 6c 61 6d ton (filter (lam
3ef0: 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 75 bda (x)(not (equ
3f00: 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 69 al? x hed))) wai
3f10: 74 6f 6e 73 29 29 29 29 0a 0a 09 20 20 20 20 28 tons))))... (
3f20: 63 6f 6e 64 0a 09 20 20 20 20 20 28 28 6e 6f 74 cond.. ((not
3f30: 20 69 74 65 6d 73 29 20 3b 3b 20 77 68 65 6e 20 items) ;; when
3f40: 66 61 6c 73 65 20 74 68 65 20 74 65 73 74 20 69 false the test i
3f50: 73 20 6f 6b 20 74 6f 20 62 65 20 68 61 6e 64 65 s ok to be hande
3f60: 64 20 6f 66 66 20 74 6f 20 6c 61 75 6e 63 68 20 d off to launch
3f70: 28 62 75 74 20 6e 6f 74 20 62 65 66 6f 72 65 29 (but not before)
3f80: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
3f90: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 20 20 have-resources
3fa0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
3fb0: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
3fc0: 65 2d 74 65 73 74 73 20 23 66 20 74 65 73 74 2d e-tests #f test-
3fd0: 72 65 63 6f 72 64 29 29 20 3b 3b 20 6c 6f 6f 6b record)) ;; look
3fe0: 20 61 74 20 74 68 65 20 74 65 73 74 20 6a 6f 62 at the test job
3ff0: 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 20 6a 6f group and tot jo
4000: 62 73 20 72 75 6e 6e 69 6e 67 0a 09 09 20 20 20 bs running...
4010: 20 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d (prereqs-not-m
4020: 65 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f et (open-run-clo
4030: 73 65 20 64 62 3a 67 65 74 2d 70 72 65 72 65 71 se db:get-prereq
4040: 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 72 75 6e s-not-met #f run
4050: 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 6d -id waitons item
4060: 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 74 -path mode: test
4070: 6d 6f 64 65 29 29 0a 09 09 20 20 20 20 20 28 66 mode))... (f
4080: 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 28 ails (
4090: 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 calc-fails prere
40a0: 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 20 qs-not-met))...
40b0: 20 20 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 (non-complet
40c0: 65 64 20 20 20 28 63 61 6c 63 2d 6e 6f 74 2d 63 ed (calc-not-c
40d0: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
40e0: 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 28 64 -not-met)))...(d
40f0: 65 62 75 67 3a 70 72 69 6e 74 20 38 20 22 49 4e ebug:print 8 "IN
4100: 46 4f 3a 20 68 61 76 65 2d 72 65 73 6f 75 72 63 FO: have-resourc
4110: 65 73 3a 20 22 20 68 61 76 65 2d 72 65 73 6f 75 es: " have-resou
4120: 72 63 65 73 20 22 20 70 72 65 72 65 71 73 2d 6e rces " prereqs-n
4130: 6f 74 2d 6d 65 74 3a 20 22 20 0a 09 09 09 20 20 ot-met: " ....
4140: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
4150: 73 70 65 72 73 65 20 0a 09 09 09 20 20 20 20 20 sperse ....
4160: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 (map (lambda (t
4170: 29 0a 09 09 09 09 20 20 20 20 20 28 69 66 20 28 )..... (if (
4180: 76 65 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 09 vector? t)......
4190: 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d (conc (db:test-
41a0: 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f 22 get-state t) "/"
41b0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
41c0: 61 74 75 73 20 74 29 29 0a 09 09 09 09 09 20 28 atus t))...... (
41d0: 63 6f 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a 20 conc " WARNING:
41e0: 74 20 69 73 20 6e 6f 74 20 61 20 76 65 63 74 6f t is not a vecto
41f0: 72 3d 22 20 74 20 29 29 29 0a 09 09 09 09 20 20 r=" t ))).....
4200: 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 prereqs-not-met
4210: 29 20 22 2c 20 22 29 20 22 20 66 61 69 6c 73 3a ) ", ") " fails:
4220: 20 22 20 66 61 69 6c 73 29 0a 09 09 28 64 65 62 " fails)...(deb
4230: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
4240: 3a 20 68 65 64 3d 22 20 68 65 64 29 0a 09 09 3b : hed=" hed)...;
4250: 3b 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 61 74 20 ; Don't know at
4260: 74 68 69 73 20 74 69 6d 65 20 69 66 20 74 68 65 this time if the
4270: 20 74 65 73 74 20 68 61 76 65 20 62 65 65 6e 20 test have been
4280: 6c 61 75 6e 63 68 65 64 20 61 74 20 73 6f 6d 65 launched at some
4290: 20 74 69 6d 65 20 69 6e 20 74 68 65 20 70 61 73 time in the pas
42a0: 74 0a 09 09 3b 3b 20 69 2e 65 2e 20 69 73 20 74 t...;; i.e. is t
42b0: 68 69 73 20 61 20 72 65 2d 6c 61 75 6e 63 68 3f his a re-launch?
42c0: 0a 09 09 28 63 6f 6e 64 0a 09 09 20 28 28 6e 6f ...(cond... ((no
42d0: 74 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 t (patt-list-mat
42e0: 63 68 20 69 74 65 6d 2d 70 61 74 68 20 69 74 65 ch item-path ite
42f0: 6d 2d 70 61 74 74 73 29 29 0a 09 09 20 20 3b 3b m-patts))... ;;
4300: 20 65 6c 73 65 20 74 68 65 20 72 75 6e 20 69 73 else the run is
4310: 20 73 74 75 63 6b 2c 20 74 65 6d 70 6f 72 61 72 stuck, temporar
4320: 69 6c 79 20 6f 72 20 70 65 72 6d 61 6e 65 6e 74 ily or permanent
4330: 6c 79 0a 09 09 20 20 3b 3b 20 62 75 74 20 73 68 ly... ;; but sh
4340: 6f 75 6c 64 20 63 68 65 63 6b 20 69 66 20 69 74 ould check if it
4350: 20 69 73 20 64 75 65 20 74 6f 20 6c 61 63 6b 20 is due to lack
4360: 6f 66 20 72 65 73 6f 75 72 63 65 73 20 76 73 2e of resources vs.
4370: 20 70 72 65 72 65 71 75 69 73 69 74 65 73 0a 09 prerequisites..
4380: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
4390: 31 20 22 49 4e 46 4f 3a 20 53 6b 69 70 70 69 6e 1 "INFO: Skippin
43a0: 67 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 g " (tests:testq
43b0: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
43c0: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 22 e test-record) "
43d0: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 " item-path " a
43e0: 73 20 69 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 s it doesn't mat
43f0: 63 68 20 22 20 69 74 65 6d 2d 70 61 74 74 73 29 ch " item-patts)
4400: 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6e ... (if (not (n
4410: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 20 ull? tal))...
4420: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
4430: 6c 29 28 63 64 72 20 74 61 6c 29 20 72 65 72 75 l)(cdr tal) reru
4440: 6e 73 29 29 29 0a 09 09 20 28 28 6e 6f 74 20 28 ns)))... ((not (
4450: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4460: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 67 69 efault test-regi
4470: 73 74 65 72 79 20 28 63 6f 6e 63 20 74 65 73 74 stery (conc test
4480: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
4490: 61 74 68 29 20 23 66 29 29 0a 09 09 20 20 28 6f ath) #f))... (o
44a0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
44b0: 3a 74 65 73 74 73 2d 72 65 67 69 73 74 65 72 2d :tests-register-
44c0: 74 65 73 74 20 23 66 20 72 75 6e 2d 69 64 20 74 test #f run-id t
44d0: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
44e0: 74 68 29 0a 09 09 20 20 28 68 61 73 68 2d 74 61 th)... (hash-ta
44f0: 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 ble-set! test-re
4500: 67 69 73 74 65 72 79 20 28 63 6f 6e 63 20 74 65 gistery (conc te
4510: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
4520: 2d 70 61 74 68 29 20 23 74 29 0a 09 09 20 20 28 -path) #t)... (
4530: 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c loop (car newtal
4540: 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 )(cdr newtal) re
4550: 72 75 6e 73 29 29 0a 09 09 20 28 28 6e 6f 74 20 runs))... ((not
4560: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 29 20 have-resources)
4570: 3b 3b 20 73 69 6d 70 6c 79 20 74 72 79 20 61 67 ;; simply try ag
4580: 61 69 6e 20 61 66 74 65 72 20 77 61 69 74 69 6e ain after waitin
4590: 67 20 61 20 73 65 63 6f 6e 64 0a 09 09 20 20 28 g a second... (
45a0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2b thread-sleep! (+
45b0: 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 1 *global-delta
45c0: 2a 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a 70 *))... (debug:p
45d0: 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 6e 6f rint 1 "INFO: no
45e0: 20 72 65 73 6f 75 72 63 65 73 20 74 6f 20 72 75 resources to ru
45f0: 6e 20 6e 65 77 20 74 65 73 74 73 2c 20 77 61 69 n new tests, wai
4600: 74 69 6e 67 20 2e 2e 2e 22 29 0a 09 09 20 20 3b ting ...")... ;
4610: 3b 20 63 6f 75 6c 64 20 68 61 76 65 20 64 6f 6e ; could have don
4620: 65 20 68 65 64 20 74 61 6c 20 68 65 72 65 20 62 e hed tal here b
4630: 75 74 20 64 6f 69 6e 67 20 63 61 72 2f 63 64 72 ut doing car/cdr
4640: 20 6f 66 20 6e 65 77 74 61 6c 20 74 6f 20 72 6f of newtal to ro
4650: 74 61 74 65 20 74 65 73 74 73 0a 09 09 20 20 28 tate tests... (
4660: 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c loop (car newtal
4670: 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 )(cdr newtal) re
4680: 72 75 6e 73 29 29 0a 09 09 20 28 28 61 6e 64 20 runs))... ((and
4690: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 0a 09 have-resources..
46a0: 09 20 20 20 20 20 20 20 28 6f 72 20 28 6e 75 6c . (or (nul
46b0: 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d l? prereqs-not-m
46c0: 65 74 29 0a 09 09 09 20 20 20 28 61 6e 64 20 28 et).... (and (
46d0: 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f eq? testmode 'to
46e0: 70 6c 65 76 65 6c 29 0a 09 09 09 09 28 6e 75 6c plevel).....(nul
46f0: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
4700: 29 29 29 29 0a 09 09 20 20 3b 3b 20 6e 6f 20 6c ))))... ;; no l
4710: 6f 6f 70 20 68 65 72 65 2c 20 6a 75 73 74 20 64 oop here, just d
4720: 72 6f 70 20 74 68 6f 75 67 68 20 61 6e 64 20 75 rop though and u
4730: 73 65 20 74 68 65 20 6c 6f 6f 70 20 61 74 20 74 se the loop at t
4740: 68 65 20 62 6f 74 74 6f 6d 20 0a 09 09 20 20 28 he bottom ... (
4750: 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 20 run:test run-id
4760: 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c 6c 73 runname keyvalls
4770: 74 20 74 65 73 74 2d 72 65 63 6f 72 64 20 66 6c t test-record fl
4780: 61 67 73 20 23 66 29 29 0a 09 09 20 28 65 6c 73 ags #f))... (els
4790: 65 20 3b 3b 20 6d 75 73 74 20 62 65 20 77 65 20 e ;; must be we
47a0: 68 61 76 65 20 75 6e 6d 65 74 20 70 72 65 72 65 have unmet prere
47b0: 71 75 69 73 69 74 65 73 0a 09 09 20 20 20 20 28 quisites... (
47c0: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 46 debug:print 4 "F
47d0: 41 49 4c 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 AILS: " fails)..
47e0: 09 20 20 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f . ;; If one o
47f0: 72 20 6d 6f 72 65 20 6f 66 20 74 68 65 20 70 72 r more of the pr
4800: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 ereqs-not-met ar
4810: 65 20 46 41 49 4c 20 74 68 65 6e 20 77 65 20 63 e FAIL then we c
4820: 61 6e 20 69 73 73 75 65 0a 09 09 20 20 20 20 3b an issue... ;
4830: 3b 20 61 20 6d 65 73 73 61 67 65 20 61 6e 64 20 ; a message and
4840: 64 72 6f 70 20 68 65 64 20 66 72 6f 6d 20 74 68 drop hed from th
4850: 65 20 69 74 65 6d 73 20 74 6f 20 62 65 20 70 72 e items to be pr
4860: 6f 63 65 73 73 65 64 2e 0a 09 09 20 20 20 20 28 ocessed.... (
4870: 69 66 20 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 if (null? fails)
4880: 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 ....(begin....
4890: 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c ;; couldn't run,
48a0: 20 74 61 6b 65 20 61 20 62 72 65 61 74 68 65 72 take a breather
48b0: 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
48c0: 6e 74 20 34 20 22 49 4e 46 4f 3a 20 53 68 6f 75 nt 4 "INFO: Shou
48d0: 6c 64 6e 27 74 20 72 65 61 6c 6c 79 20 67 65 74 ldn't really get
48e0: 20 68 65 72 65 2c 20 72 61 63 65 20 63 6f 6e 64 here, race cond
48f0: 69 74 69 6f 6e 3f 20 55 6e 61 62 6c 65 20 74 6f ition? Unable to
4900: 20 6c 61 75 6e 63 68 20 6d 6f 72 65 20 74 65 73 launch more tes
4910: 74 73 20 61 74 20 74 68 69 73 20 6d 6f 6d 65 6e ts at this momen
4920: 74 2c 20 6b 69 6c 6c 69 6e 67 20 74 69 6d 65 20 t, killing time
4930: 2e 2e 2e 22 29 0a 09 09 09 20 20 28 74 68 72 65 ...").... (thre
4940: 61 64 2d 73 6c 65 65 70 21 20 28 2b 20 31 20 2a ad-sleep! (+ 1 *
4950: 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 29 20 global-delta*))
4960: 3b 3b 20 6c 6f 6e 67 20 73 6c 65 65 70 20 68 65 ;; long sleep he
4970: 72 65 20 2d 20 6e 6f 20 72 65 73 6f 75 72 63 65 re - no resource
4980: 73 2c 20 6d 61 79 20 61 73 20 77 65 6c 6c 20 62 s, may as well b
4990: 65 20 70 61 74 69 65 6e 74 0a 09 09 09 20 20 3b e patient.... ;
49a0: 3b 20 77 65 20 6d 61 64 65 20 6e 65 77 20 74 61 ; we made new ta
49b0: 6c 20 62 79 20 73 74 69 63 6b 69 6e 67 20 68 65 l by sticking he
49c0: 64 20 61 74 20 74 68 65 20 62 61 63 6b 20 6f 66 d at the back of
49d0: 20 74 68 65 20 6c 69 73 74 0a 09 09 09 20 20 28 the list.... (
49e0: 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c loop (car newtal
49f0: 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 )(cdr newtal) re
4a00: 72 75 6e 73 29 29 0a 09 09 09 3b 3b 20 74 68 65 runs))....;; the
4a10: 20 77 61 69 74 6f 6e 20 69 73 20 46 41 49 4c 20 waiton is FAIL
4a20: 73 6f 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 74 so no point in t
4a30: 72 79 69 6e 67 20 74 6f 20 72 75 6e 20 68 65 64 rying to run hed
4a40: 20 65 76 65 72 20 61 67 61 69 6e 0a 09 09 09 28 ever again....(
4a50: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
4a60: 61 6c 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 al)).... (if
4a70: 28 76 65 63 74 6f 72 3f 20 68 65 64 29 0a 09 09 (vector? hed)...
4a80: 09 09 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a ..(begin (debug:
4a90: 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 44 print 1 "WARN: D
4aa0: 72 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 28 ropping test " (
4ab0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
4ac0: 6e 61 6d 65 20 68 65 64 29 20 22 2f 22 20 28 64 name hed) "/" (d
4ad0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
4ae0: 70 61 74 68 20 68 65 64 29 0a 09 09 09 09 09 09 path hed).......
4af0: 20 20 20 20 22 20 66 72 6f 6d 20 74 68 65 20 6c " from the l
4b00: 61 75 6e 63 68 20 6c 69 73 74 20 61 73 20 69 74 aunch list as it
4b10: 20 68 61 73 20 70 72 65 72 65 71 75 69 73 74 65 has prerequiste
4b20: 73 20 74 68 61 74 20 61 72 65 20 46 41 49 4c 22 s that are FAIL"
4b30: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 6c 6f )..... (lo
4b40: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
4b50: 20 74 61 6c 29 20 28 63 6f 6e 73 20 68 65 64 20 tal) (cons hed
4b60: 72 65 72 75 6e 73 29 29 29 0a 09 09 09 09 28 62 reruns))).....(b
4b70: 65 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 75 egin..... (debu
4b80: 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a g:print 1 "WARN:
4b90: 20 54 65 73 74 20 6e 6f 74 20 70 72 6f 63 65 73 Test not proces
4ba0: 73 65 64 20 63 6f 72 72 65 63 74 6c 79 2e 20 43 sed correctly. C
4bb0: 6f 75 6c 64 20 62 65 20 61 20 72 61 63 65 20 63 ould be a race c
4bc0: 6f 6e 64 69 74 69 6f 6e 20 69 6e 20 79 6f 75 72 ondition in your
4bd0: 20 74 65 73 74 20 69 6d 70 6c 65 6d 65 6e 74 61 test implementa
4be0: 74 69 6f 6e 3f 20 22 20 68 65 64 29 20 3b 3b 20 tion? " hed) ;;
4bf0: 20 22 20 61 73 20 69 74 20 68 61 73 20 70 72 65 " as it has pre
4c00: 72 65 71 75 69 73 74 65 73 20 74 68 61 74 20 61 requistes that a
4c10: 72 65 20 46 41 49 4c 2e 20 28 4e 4f 54 45 3a 20 re FAIL. (NOTE:
4c20: 68 65 64 20 69 73 20 6e 6f 74 20 61 20 76 65 63 hed is not a vec
4c30: 74 6f 72 29 22 29 0a 09 09 09 09 20 20 28 6c 6f tor)")..... (lo
4c40: 6f 70 20 68 65 64 20 74 61 6c 20 72 65 72 75 6e op hed tal rerun
4c50: 73 29 29 29 29 29 29 29 29 29 0a 09 20 20 20 20 s)))))))))..
4c60: 20 0a 09 20 20 20 20 20 3b 3b 20 63 61 73 65 20 .. ;; case
4c70: 77 68 65 72 65 20 61 6e 20 69 74 65 6d 73 20 63 where an items c
4c80: 61 6d 65 20 69 6e 20 61 73 20 61 20 6c 69 73 74 ame in as a list
4c90: 20 62 65 65 6e 20 70 72 6f 63 65 73 73 65 64 0a been processed.
4ca0: 09 20 20 20 20 20 28 28 61 6e 64 20 28 6c 69 73 . ((and (lis
4cb0: 74 3f 20 69 74 65 6d 73 29 20 20 20 20 20 3b 3b t? items) ;;
4cc0: 20 74 68 75 73 20 77 65 20 6b 6e 6f 77 20 6f 75 thus we know ou
4cd0: 72 20 69 74 65 6d 73 20 61 72 65 20 61 6c 72 65 r items are alre
4ce0: 61 64 79 20 63 61 6c 63 75 6c 61 74 65 64 0a 09 ady calculated..
4cf0: 09 20 20 20 28 6e 6f 74 20 20 20 69 74 65 6d 64 . (not itemd
4d00: 61 74 29 29 20 3b 3b 20 61 6e 64 20 6e 6f 74 20 at)) ;; and not
4d10: 79 65 74 20 65 78 70 61 6e 64 65 64 20 69 6e 74 yet expanded int
4d20: 6f 20 74 68 65 20 6c 69 73 74 20 6f 66 20 74 68 o the list of th
4d30: 69 6e 67 73 20 74 6f 20 62 65 20 64 6f 6e 65 0a ings to be done.
4d40: 09 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
4d50: 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 (>= *verbosity*
4d60: 31 29 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 1)... (> (
4d70: 6c 65 6e 67 74 68 20 69 74 65 6d 73 29 20 30 29 length items) 0)
4d80: 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 6c 65 ... (> (le
4d90: 6e 67 74 68 20 28 63 61 72 20 69 74 65 6d 73 29 ngth (car items)
4da0: 29 20 30 29 29 0a 09 09 20 20 28 70 70 20 69 74 ) 0))... (pp it
4db0: 65 6d 73 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 ems)).. ;;
4dc0: 28 69 66 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 (if (>= *verbosi
4dd0: 74 79 2a 20 35 29 0a 09 20 20 20 20 20 20 3b 3b ty* 5).. ;;
4de0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
4df0: 20 20 20 3b 3b 20 20 20 20 20 20 20 28 70 72 69 ;; (pri
4e00: 6e 74 20 22 69 74 65 6d 73 3a 20 22 29 20 20 20 nt "items: ")
4e10: 20 20 28 70 70 20 28 69 74 65 6d 2d 61 73 73 6f (pp (item-asso
4e20: 63 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 c->item-list ite
4e30: 6d 73 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 20 ms)).. ;;
4e40: 20 20 20 20 20 28 70 72 69 6e 74 20 22 69 74 65 (print "ite
4e50: 6d 73 74 61 62 6c 65 3a 20 22 29 28 70 70 20 28 mstable: ")(pp (
4e60: 69 74 65 6d 2d 74 61 62 6c 65 2d 3e 69 74 65 6d item-table->item
4e70: 2d 6c 69 73 74 20 69 74 65 6d 73 74 61 62 6c 65 -list itemstable
4e80: 29 29 29 29 0a 09 20 20 20 20 20 20 28 66 6f 72 )))).. (for
4e90: 2d 65 61 63 68 0a 09 20 20 20 20 20 20 20 28 6c -each.. (l
4ea0: 61 6d 62 64 61 20 28 6d 79 2d 69 74 65 6d 64 61 ambda (my-itemda
4eb0: 74 29 0a 09 09 20 28 6c 65 74 2a 20 28 28 6e 65 t)... (let* ((ne
4ec0: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 28 6c w-test-record (l
4ed0: 65 74 20 28 28 6e 65 77 72 65 63 20 28 6d 61 6b et ((newrec (mak
4ee0: 65 2d 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 e-tests:testqueu
4ef0: 65 29 29 29 0a 09 09 09 09 09 20 20 20 28 76 65 e)))...... (ve
4f00: 63 74 6f 72 2d 63 6f 70 79 21 20 74 65 73 74 2d ctor-copy! test-
4f10: 72 65 63 6f 72 64 20 6e 65 77 72 65 63 29 0a 09 record newrec)..
4f20: 09 09 09 09 20 20 20 6e 65 77 72 65 63 29 29 0a .... newrec)).
4f30: 09 09 09 28 6d 79 2d 69 74 65 6d 2d 70 61 74 68 ...(my-item-path
4f40: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat
4f50: 68 20 6d 79 2d 69 74 65 6d 64 61 74 29 29 29 0a h my-itemdat))).
4f60: 09 09 20 20 20 28 69 66 20 28 70 61 74 74 2d 6c .. (if (patt-l
4f70: 69 73 74 2d 6d 61 74 63 68 20 6d 79 2d 69 74 65 ist-match my-ite
4f80: 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 74 74 m-path item-patt
4f90: 73 29 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 s) ;;
4fa0: 79 65 73 2c 20 77 65 20 77 61 6e 74 20 74 6f 20 yes, we want to
4fb0: 70 72 6f 63 65 73 73 20 74 68 69 73 20 69 74 65 process this ite
4fc0: 6d 2c 20 4e 4f 54 45 3a 20 53 68 6f 75 6c 64 20 m, NOTE: Should
4fd0: 6e 6f 74 20 6e 65 65 64 20 74 68 69 73 20 63 68 not need this ch
4fe0: 65 63 6b 20 68 65 72 65 21 0a 09 09 20 20 20 20 eck here!...
4ff0: 20 20 20 28 6c 65 74 20 28 28 6e 65 77 74 65 73 (let ((newtes
5000: 74 6e 61 6d 65 20 28 63 6f 6e 63 20 68 65 64 20 tname (conc hed
5010: 22 2f 22 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 "/" my-item-path
5020: 29 29 29 20 20 20 20 3b 3b 20 74 65 73 74 20 6e ))) ;; test n
5030: 61 6d 65 73 20 61 72 65 20 75 6e 69 71 75 65 20 ames are unique
5040: 6f 6e 20 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d on testname/item
5050: 2d 70 61 74 68 0a 09 09 09 20 28 74 65 73 74 73 -path.... (tests
5060: 3a 74 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 :testqueue-set-i
5070: 74 65 6d 73 21 20 20 20 20 20 6e 65 77 2d 74 65 tems! new-te
5080: 73 74 2d 72 65 63 6f 72 64 20 23 66 29 0a 09 09 st-record #f)...
5090: 09 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 . (tests:testque
50a0: 75 65 2d 73 65 74 2d 69 74 65 6d 64 61 74 21 20 ue-set-itemdat!
50b0: 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 new-test-recor
50c0: 64 20 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 d my-itemdat)...
50d0: 09 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 . (tests:testque
50e0: 75 65 2d 73 65 74 2d 69 74 65 6d 5f 70 61 74 68 ue-set-item_path
50f0: 21 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 ! new-test-recor
5100: 64 20 6d 79 2d 69 74 65 6d 2d 70 61 74 68 29 0a d my-item-path).
5110: 09 09 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ... (hash-table-
5120: 73 65 74 21 20 74 65 73 74 2d 72 65 63 6f 72 64 set! test-record
5130: 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 6e 65 s newtestname ne
5140: 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 29 0a 09 w-test-record)..
5150: 09 09 20 28 73 65 74 21 20 74 61 6c 20 28 63 6f .. (set! tal (co
5160: 6e 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 20 74 ns newtestname t
5170: 61 6c 29 29 29 29 29 29 20 3b 3b 20 73 69 6e 63 al)))))) ;; sinc
5180: 65 20 74 68 65 73 65 20 61 72 65 20 69 74 65 6d e these are item
5190: 69 7a 65 64 20 63 72 65 61 74 65 20 6e 65 77 20 ized create new
51a0: 74 65 73 74 20 6e 61 6d 65 73 20 74 65 73 74 6e test names testn
51b0: 61 6d 65 2f 69 74 65 6d 70 61 74 68 0a 09 20 20 ame/itempath..
51c0: 20 20 20 20 20 69 74 65 6d 73 29 0a 09 20 20 20 items)..
51d0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
51e0: 6c 3f 20 74 61 6c 29 29 0a 09 09 20 20 28 6c 6f l? tal))... (lo
51f0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
5200: 20 74 61 6c 29 20 72 65 72 75 6e 73 29 29 29 0a tal) reruns))).
5210: 0a 09 20 20 20 20 20 3b 3b 20 69 66 20 69 74 65 .. ;; if ite
5220: 6d 73 20 69 73 20 61 20 70 72 6f 63 20 74 68 65 ms is a proc the
5230: 6e 20 6e 65 65 64 20 74 6f 20 72 75 6e 20 69 74 n need to run it
5240: 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 ems:get-items-fr
5250: 6f 6d 2d 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 om-config, get t
5260: 68 65 20 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 he list and loop
5270: 20 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 2d 20 .. ;; -
5280: 62 75 74 20 6f 6e 6c 79 20 64 6f 20 74 68 61 74 but only do that
5290: 20 69 66 20 72 65 73 6f 75 72 63 65 73 20 65 78 if resources ex
52a0: 69 73 74 20 74 6f 20 6b 69 63 6b 20 6f 66 66 20 ist to kick off
52b0: 74 68 65 20 6a 6f 62 0a 09 20 20 20 20 20 28 28 the job.. ((
52c0: 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 69 or (procedure? i
52d0: 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 20 tems)(eq? items
52e0: 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 'have-procedure)
52f0: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ).. (let ((
5300: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 can-run-more
5310: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
5320: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
5330: 65 2d 74 65 73 74 73 20 23 66 20 74 65 73 74 2d e-tests #f test-
5340: 72 65 63 6f 72 64 29 29 29 0a 09 09 28 69 66 20 record)))...(if
5350: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 20 can-run-more...
5360: 20 20 20 28 6c 65 74 2a 20 28 28 70 72 65 72 65 (let* ((prere
5370: 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 6f 70 65 6e qs-not-met (open
5380: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 -run-close db:ge
5390: 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 t-prereqs-not-me
53a0: 74 20 23 66 20 72 75 6e 2d 69 64 20 77 61 69 74 t #f run-id wait
53b0: 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f ons item-path mo
53c0: 64 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 de: testmode))..
53d0: 09 09 20 20 20 28 66 61 69 6c 73 20 20 20 20 20 .. (fails
53e0: 20 20 20 20 20 20 28 63 61 6c 63 2d 66 61 69 6c (calc-fail
53f0: 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 s prereqs-not-me
5400: 74 29 29 0a 09 09 09 20 20 20 28 6e 6f 6e 2d 63 t)).... (non-c
5410: 6f 6d 70 6c 65 74 65 64 20 20 20 28 63 61 6c 63 ompleted (calc
5420: 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 -not-completed p
5430: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
5440: 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 )... (debug
5450: 3a 70 72 69 6e 74 20 38 20 22 49 4e 46 4f 3a 20 :print 8 "INFO:
5460: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 22 20 can-run-more: "
5470: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 09 can-run-more....
5480: 09 20 20 20 22 5c 6e 20 74 65 73 74 6e 61 6d 65 . "\n testname
5490: 3a 20 20 20 20 20 20 20 20 22 20 68 65 64 0a 09 : " hed..
54a0: 09 09 09 20 20 20 22 5c 6e 20 70 72 65 72 65 71 ... "\n prereq
54b0: 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 28 70 72 s-not-met: " (pr
54c0: 65 74 74 79 2d 73 74 72 69 6e 67 20 70 72 65 72 etty-string prer
54d0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 eqs-not-met)....
54e0: 09 20 20 20 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 . "\n non-comp
54f0: 6c 65 74 65 64 3a 20 20 20 22 20 28 70 72 65 74 leted: " (pret
5500: 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 6f ty-string non-co
5510: 6d 70 6c 65 74 65 64 29 20 0a 09 09 09 09 20 20 mpleted) .....
5520: 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 "\n fails:
5530: 20 20 20 20 20 20 22 20 28 70 72 65 74 74 79 2d " (pretty-
5540: 73 74 72 69 6e 67 20 66 61 69 6c 73 29 0a 09 09 string fails)...
5550: 09 09 20 20 20 22 5c 6e 20 74 65 73 74 6d 6f 64 .. "\n testmod
5560: 65 3a 20 20 20 20 20 20 20 20 22 20 74 65 73 74 e: " test
5570: 6d 6f 64 65 0a 09 09 09 09 20 20 20 22 5c 6e 20 mode..... "\n
5580: 6e 75 6d 2d 72 65 74 72 69 65 73 3a 20 20 20 20 num-retries:
5590: 20 22 20 6e 75 6d 2d 72 65 74 72 69 65 73 0a 09 " num-retries..
55a0: 09 09 09 20 20 20 22 5c 6e 20 28 65 71 3f 20 74 ... "\n (eq? t
55b0: 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 estmode 'topleve
55c0: 6c 29 3a 20 22 20 28 65 71 3f 20 74 65 73 74 6d l): " (eq? testm
55d0: 6f 64 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 ode 'toplevel)..
55e0: 09 09 09 20 20 20 22 5c 6e 20 28 6e 75 6c 6c 3f ... "\n (null?
55f0: 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 3a non-completed):
5600: 20 20 20 20 22 20 28 6e 75 6c 6c 3f 20 6e 6f 6e " (null? non
5610: 2d 63 6f 6d 70 6c 65 74 65 64 29 0a 09 09 09 09 -completed).....
5620: 20 20 20 22 5c 6e 20 72 65 72 75 6e 73 3a 20 22 "\n reruns: "
5630: 20 72 65 72 75 6e 73 29 0a 09 09 20 20 20 20 20 reruns)...
5640: 20 28 63 6f 6e 64 20 0a 09 09 20 20 20 20 20 20 (cond ...
5650: 20 28 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 72 65 ((or (null? pre
5660: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 3b 3b reqs-not-met) ;;
5670: 20 61 6c 6c 20 70 72 65 72 65 71 73 20 6d 65 74 all prereqs met
5680: 2c 20 66 69 72 65 20 6f 66 66 20 74 68 65 20 74 , fire off the t
5690: 65 73 74 0a 09 09 09 20 20 20 20 3b 3b 20 6f 72 est.... ;; or
56a0: 2c 20 69 66 20 69 74 20 69 73 20 61 20 27 74 6f , if it is a 'to
56b0: 70 6c 65 76 65 6c 20 74 65 73 74 20 61 6e 64 20 plevel test and
56c0: 61 6c 6c 20 70 72 65 72 65 71 73 20 6e 6f 74 20 all prereqs not
56d0: 6d 65 74 20 61 72 65 20 43 4f 4d 50 4c 45 54 45 met are COMPLETE
56e0: 44 20 74 68 65 6e 20 6c 61 75 6e 63 68 0a 09 09 D then launch...
56f0: 09 20 20 20 20 28 61 6e 64 20 28 65 71 3f 20 74 . (and (eq? t
5700: 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 estmode 'topleve
5710: 6c 29 0a 09 09 09 09 20 28 6e 75 6c 6c 3f 20 6e l)..... (null? n
5720: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 0a on-completed))).
5730: 09 09 09 28 6c 65 74 20 28 28 74 65 73 74 2d 6e ...(let ((test-n
5740: 61 6d 65 20 28 74 65 73 74 73 3a 74 65 73 74 71 ame (tests:testq
5750: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
5760: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 29 e test-record)))
5770: 0a 09 09 09 20 20 28 73 65 74 65 6e 76 20 22 4d .... (setenv "M
5780: 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 T_TEST_NAME" tes
5790: 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 09 09 09 20 t-name) ;; ....
57a0: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
57b0: 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 NAME" runname)
57c0: 0a 09 09 09 20 20 28 6f 70 65 6e 2d 72 75 6e 2d .... (open-run-
57d0: 63 6c 6f 73 65 20 73 65 74 2d 6d 65 67 61 74 65 close set-megate
57e0: 73 74 2d 65 6e 76 2d 76 61 72 73 20 23 66 20 72 st-env-vars #f r
57f0: 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 un-id) ;; these
5800: 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 may be needed by
5810: 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 the launching p
5820: 72 6f 63 65 73 73 0a 09 09 09 20 20 28 6c 65 74 rocess.... (let
5830: 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 20 28 69 ((items-list (i
5840: 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 tems:get-items-f
5850: 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f 6e 66 rom-config tconf
5860: 69 67 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 ig))).... (if
5870: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d 6c 69 (list? items-li
5880: 73 74 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 st).....(begin..
5890: 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 ... (tests:test
58a0: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 queue-set-items!
58b0: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 74 65 test-record ite
58c0: 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 20 20 28 ms-list)..... (
58d0: 6c 6f 6f 70 20 68 65 64 20 74 61 6c 20 72 65 72 loop hed tal rer
58e0: 75 6e 73 29 29 0a 09 09 09 09 28 62 65 67 69 6e uns)).....(begin
58f0: 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 ..... (debug:pr
5900: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 68 int 0 "ERROR: Th
5910: 65 20 70 72 6f 63 20 66 72 6f 6d 20 72 65 61 64 e proc from read
5920: 69 6e 67 20 74 68 65 20 73 65 74 75 70 20 64 69 ing the setup di
5930: 64 20 6e 6f 74 20 79 69 65 6c 64 20 61 20 6c 69 d not yield a li
5940: 73 74 20 2d 20 70 6c 65 61 73 65 20 72 65 70 6f st - please repo
5950: 72 74 20 74 68 69 73 22 29 0a 09 09 09 09 20 20 rt this").....
5960: 28 65 78 69 74 20 31 29 29 29 29 29 29 0a 09 09 (exit 1))))))...
5970: 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 66 ((null? f
5980: 61 69 6c 73 29 0a 09 09 09 28 64 65 62 75 67 3a ails)....(debug:
5990: 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 66 print 4 "INFO: f
59a0: 61 69 6c 73 20 69 73 20 6e 75 6c 6c 2c 20 6d 6f ails is null, mo
59b0: 76 69 6e 67 20 6f 6e 20 69 6e 20 74 68 65 20 71 ving on in the q
59c0: 75 65 75 65 20 62 75 74 20 6b 65 65 70 69 6e 67 ueue but keeping
59d0: 20 22 20 68 65 64 20 22 20 66 6f 72 20 6e 6f 77 " hed " for now
59e0: 22 29 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 ")....(loop (car
59f0: 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 newtal)(cdr new
5a00: 74 61 6c 29 20 72 65 72 75 6e 73 29 29 20 3b 3b tal) reruns)) ;;
5a10: 20 61 6e 20 69 73 73 75 65 20 77 69 74 68 20 70 an issue with p
5a20: 72 65 72 65 71 73 20 6e 6f 74 20 79 65 74 20 6d rereqs not yet m
5a30: 65 74 3f 0a 09 09 20 20 20 20 20 20 20 28 28 61 et?... ((a
5a40: 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 nd (not (null? f
5a50: 61 69 6c 73 29 29 28 65 71 3f 20 74 65 73 74 6d ails))(eq? testm
5a60: 6f 64 65 20 27 6e 6f 72 6d 61 6c 29 29 0a 09 09 ode 'normal))...
5a70: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 .(debug:print 1
5a80: 22 49 4e 46 4f 3a 20 74 65 73 74 20 22 20 20 68 "INFO: test " h
5a90: 65 64 20 22 20 28 6d 6f 64 65 3d 22 20 74 65 73 ed " (mode=" tes
5aa0: 74 6d 6f 64 65 20 22 29 20 68 61 73 20 66 61 69 tmode ") has fai
5ab0: 6c 65 64 20 70 72 65 72 65 71 75 69 73 69 74 65 led prerequisite
5ac0: 28 73 29 3b 20 22 0a 09 09 09 09 20 20 20 20 20 (s); ".....
5ad0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
5ae0: 72 73 65 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 rse (map (lambda
5af0: 20 28 74 29 28 63 6f 6e 63 20 28 64 62 3a 74 65 (t)(conc (db:te
5b00: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
5b10: 74 29 20 22 3a 22 20 28 64 62 3a 74 65 73 74 2d t) ":" (db:test-
5b20: 67 65 74 2d 73 74 61 74 65 20 74 29 22 2f 22 28 get-state t)"/"(
5b30: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
5b40: 75 73 20 74 29 29 29 20 66 61 69 6c 73 29 20 22 us t))) fails) "
5b50: 2c 20 22 29 0a 09 09 09 09 20 20 20 20 20 22 2c , ")..... ",
5b60: 20 72 65 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f removing it fro
5b70: 6d 20 74 6f 2d 64 6f 20 6c 69 73 74 22 29 0a 09 m to-do list")..
5b80: 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c ..(if (not (null
5b90: 3f 20 74 61 6c 29 29 0a 09 09 09 20 20 20 20 28 ? tal)).... (
5ba0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
5bb0: 64 72 20 74 61 6c 29 28 63 6f 6e 73 20 68 65 64 dr tal)(cons hed
5bc0: 20 72 65 72 75 6e 73 29 29 29 29 0a 09 09 20 20 reruns))))...
5bd0: 20 20 20 20 20 28 65 6c 73 65 0a 09 09 09 28 64 (else....(d
5be0: 65 62 75 67 3a 70 72 69 6e 74 20 38 20 22 45 52 ebug:print 8 "ER
5bf0: 52 4f 52 3a 20 4e 6f 20 68 61 6e 64 6c 65 72 20 ROR: No handler
5c00: 66 6f 72 20 74 68 69 73 20 63 6f 6e 64 69 74 69 for this conditi
5c10: 6f 6e 2e 22 29 0a 09 09 09 3b 3b 20 09 20 20 20 on.")....;; .
5c20: 20 20 22 5c 6e 20 20 68 65 64 3a 20 20 20 20 20 "\n hed:
5c30: 20 20 20 20 20 20 20 22 20 68 65 64 20 0a 09 09 " hed ...
5c40: 09 3b 3b 20 09 20 20 20 20 20 22 5c 6e 20 66 61 .;; . "\n fa
5c50: 69 6c 73 3a 20 20 20 20 20 20 20 20 20 20 20 22 ils: "
5c60: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
5c70: 65 72 73 65 20 28 6d 61 70 20 64 62 3a 74 65 73 erse (map db:tes
5c80: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 66 t-get-testname f
5c90: 61 69 6c 73 29 20 22 2c 22 29 0a 09 09 09 3b 3b ails) ",")....;;
5ca0: 20 09 20 20 20 20 20 22 5c 6e 20 74 65 73 74 6d . "\n testm
5cb0: 6f 64 65 3a 20 20 20 20 20 20 20 20 22 20 74 65 ode: " te
5cc0: 73 74 6d 6f 64 65 0a 09 09 09 3b 3b 20 09 20 20 stmode....;; .
5cd0: 20 20 20 22 5c 6e 20 70 72 65 72 65 71 73 2d 6e "\n prereqs-n
5ce0: 6f 74 2d 6d 65 74 3a 20 22 20 28 70 72 65 74 74 ot-met: " (prett
5cf0: 79 2d 73 74 72 69 6e 67 20 70 72 65 72 65 71 73 y-string prereqs
5d00: 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 3b 3b 20 -not-met)....;;
5d10: 09 20 20 20 20 20 22 5c 6e 20 69 74 65 6d 73 3a . "\n items:
5d20: 20 20 20 20 20 20 20 20 20 20 20 22 20 69 74 65 " ite
5d30: 6d 73 29 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 ms)....(loop (ca
5d40: 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 r newtal)(cdr ne
5d50: 77 74 61 6c 29 20 72 65 72 75 6e 73 29 29 29 29 wtal) reruns))))
5d60: 0a 09 09 20 20 20 20 3b 3b 20 69 66 20 63 61 6e ... ;; if can
5d70: 27 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 73 74 't run more just
5d80: 20 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 74 20 loop with next
5d90: 70 6f 73 73 69 62 6c 65 20 74 65 73 74 0a 09 09 possible test...
5da0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 (begin...
5db0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5dc0: 34 20 22 49 4e 46 4f 3a 20 70 72 6f 63 65 73 73 4 "INFO: process
5dd0: 69 6e 67 20 74 68 65 20 63 61 73 65 20 77 69 74 ing the case wit
5de0: 68 20 61 20 6c 61 6d 62 64 61 20 66 6f 72 20 69 h a lambda for i
5df0: 74 65 6d 73 20 6f 72 20 27 68 61 76 65 2d 70 72 tems or 'have-pr
5e00: 6f 63 65 64 75 72 65 2e 20 4d 6f 76 69 6e 67 20 ocedure. Moving
5e10: 74 68 72 6f 75 67 68 20 74 68 65 20 71 75 65 75 through the queu
5e20: 65 20 77 69 74 68 6f 75 74 20 64 72 6f 70 70 69 e without droppi
5e30: 6e 67 20 22 20 68 65 64 29 0a 09 09 20 20 20 20 ng " hed)...
5e40: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5e50: 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c 2d 64 65 (+ 1 *global-de
5e60: 6c 74 61 2a 29 29 0a 09 09 20 20 20 20 20 20 28 lta*))... (
5e70: 6c 6f 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c loop (car newtal
5e80: 29 28 63 64 72 20 6e 65 77 74 61 6c 29 20 72 65 )(cdr newtal) re
5e90: 72 75 6e 73 29 29 29 29 29 0a 09 20 20 20 20 20 runs)))))..
5ea0: 0a 09 20 20 20 20 20 3b 3b 20 74 68 69 73 20 63 .. ;; this c
5eb0: 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 20 68 ase should not h
5ec0: 61 70 70 65 6e 2c 20 61 64 64 65 64 20 74 6f 20 appen, added to
5ed0: 68 65 6c 70 20 63 61 74 63 68 20 61 6e 79 20 62 help catch any b
5ee0: 75 67 73 0a 09 20 20 20 20 20 28 28 61 6e 64 20 ugs.. ((and
5ef0: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
5f00: 65 6d 64 61 74 29 0a 09 20 20 20 20 20 20 28 64 emdat).. (d
5f10: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
5f20: 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 ROR: Should not
5f30: 68 61 76 65 20 61 20 6c 69 73 74 20 6f 66 20 69 have a list of i
5f40: 74 65 6d 73 20 69 6e 20 61 20 74 65 73 74 20 61 tems in a test a
5f50: 6e 64 20 74 68 65 20 69 74 65 6d 73 70 61 74 68 nd the itemspath
5f60: 20 73 65 74 20 2d 20 70 6c 65 61 73 65 20 72 65 set - please re
5f70: 70 6f 72 74 20 74 68 69 73 22 29 0a 09 20 20 20 port this")..
5f80: 20 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 (exit 1))))..
5f90: 20 20 0a 09 20 20 3b 3b 20 77 65 20 67 65 74 20 .. ;; we get
5fa0: 68 65 72 65 20 6f 6e 20 22 64 72 6f 70 20 74 68 here on "drop th
5fb0: 72 6f 75 67 68 22 20 2d 20 6c 6f 6f 70 20 66 6f rough" - loop fo
5fc0: 72 20 6e 65 78 74 20 74 65 73 74 20 69 6e 20 71 r next test in q
5fd0: 75 65 75 65 0a 09 20 20 28 69 66 20 28 6e 75 6c ueue.. (if (nul
5fe0: 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 l? tal).. (
5ff0: 62 65 67 69 6e 0a 09 09 3b 3b 20 46 49 58 4d 45 begin...;; FIXME
6000: 21 21 21 21 20 54 48 49 53 20 53 48 4f 55 4c 44 !!!! THIS SHOULD
6010: 20 4e 4f 54 20 52 45 51 55 49 52 45 20 41 4e 20 NOT REQUIRE AN
6020: 45 58 49 54 21 21 21 21 21 21 21 0a 09 09 28 64 EXIT!!!!!!!...(d
6030: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e ebug:print 1 "IN
6040: 46 4f 3a 20 41 6c 6c 20 74 65 73 74 73 20 6c 61 FO: All tests la
6050: 75 6e 63 68 65 64 22 29 0a 09 09 28 74 68 72 65 unched")...(thre
6060: 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 0a 09 ad-sleep! 0.5)..
6070: 09 3b 3b 20 46 49 58 4d 45 21 20 54 68 69 73 20 .;; FIXME! This
6080: 68 61 72 73 68 20 65 78 69 74 20 73 68 6f 75 6c harsh exit shoul
6090: 64 20 6e 6f 74 20 62 65 20 6e 65 63 65 73 73 61 d not be necessa
60a0: 72 79 2e 2e 2e 2e 0a 09 09 28 69 66 20 28 6e 6f ry.......(if (no
60b0: 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 28 65 t *runremote*)(e
60c0: 78 69 74 29 29 20 3b 3b 20 0a 09 09 23 66 29 20 xit)) ;; ...#f)
60d0: 3b 3b 20 72 65 74 75 72 6e 20 61 20 23 66 20 61 ;; return a #f a
60e0: 73 20 61 20 68 69 6e 74 20 74 68 61 74 20 77 65 s a hint that we
60f0: 20 61 72 65 20 64 6f 6e 65 0a 09 20 20 20 20 20 are done..
6100: 20 3b 3b 20 48 65 72 65 20 77 65 20 6e 65 65 64 ;; Here we need
6110: 20 74 6f 20 63 68 65 63 6b 20 74 68 61 74 20 61 to check that a
6120: 6c 6c 20 74 68 65 20 74 65 73 74 73 20 72 65 6d ll the tests rem
6130: 61 69 6e 69 6e 67 20 74 6f 20 62 65 20 72 75 6e aining to be run
6140: 20 61 72 65 20 65 6c 69 67 69 62 6c 65 20 74 6f are eligible to
6150: 20 72 75 6e 0a 09 20 20 20 20 20 20 3b 3b 20 61 run.. ;; a
6160: 6e 64 20 61 72 65 20 6e 6f 74 20 62 6c 6f 63 6b nd are not block
6170: 65 64 20 62 79 20 66 61 69 6c 65 64 0a 09 20 20 ed by failed..
6180: 20 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 6c (let* ((newl
6190: 73 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f st (open-run-clo
61a0: 73 65 20 74 65 73 74 73 3a 66 69 6c 74 65 72 2d se tests:filter-
61b0: 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 23 66 20 non-runnable #f
61c0: 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 73 74 2d run-id tal test-
61d0: 72 65 63 6f 72 64 73 29 29 20 3b 3b 20 69 2e 65 records)) ;; i.e
61e0: 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 41 49 56 . not FAIL, WAIV
61f0: 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 45 2c 20 ED, INCOMPLETE,
6200: 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c 0a 09 09 PASS, KILLED,...
6210: 20 20 20 20 20 28 6a 75 6e 6b 65 64 20 28 6c 73 (junked (ls
6220: 65 74 2d 64 69 66 66 65 72 65 6e 63 65 20 65 71 et-difference eq
6230: 75 61 6c 3f 20 74 61 6c 20 6e 65 77 6c 73 74 29 ual? tal newlst)
6240: 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e ))...(debug:prin
6250: 74 20 34 20 22 49 4e 46 4f 3a 20 66 75 6c 6c 20 t 4 "INFO: full
6260: 64 72 6f 70 20 74 68 72 6f 75 67 68 2c 20 69 66 drop through, if
6270: 20 72 65 72 75 6e 73 20 69 73 20 6c 65 73 73 20 reruns is less
6280: 74 68 61 6e 20 31 30 30 20 77 65 20 77 69 6c 6c than 100 we will
6290: 20 66 6f 72 63 65 20 72 65 74 72 79 20 74 68 65 force retry the
62a0: 6d 3a 20 22 20 72 65 72 75 6e 73 29 0a 09 09 28 m: " reruns)...(
62b0: 69 66 20 28 3c 20 6e 75 6d 2d 72 65 74 72 69 65 if (< num-retrie
62c0: 73 20 6d 61 78 2d 72 65 74 72 69 65 73 29 0a 09 s max-retries)..
62d0: 09 20 20 20 20 28 73 65 74 21 20 6e 65 77 6c 73 . (set! newls
62e0: 74 20 28 61 70 70 65 6e 64 20 72 65 72 75 6e 73 t (append reruns
62f0: 20 6e 65 77 6c 73 74 29 29 29 0a 09 09 28 73 65 newlst)))...(se
6300: 74 21 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 28 t! num-retries (
6310: 2b 20 6e 75 6d 2d 72 65 74 72 69 65 73 20 31 29 + num-retries 1)
6320: 29 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 )...(thread-slee
6330: 70 21 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 p! *global-delta
6340: 2a 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 6e *)...(if (not (n
6350: 75 6c 6c 3f 20 6e 65 77 6c 73 74 29 29 0a 09 09 ull? newlst))...
6360: 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 72 65 72 ;; since rer
6370: 75 6e 73 20 68 61 76 65 20 62 65 65 6e 20 74 61 uns have been ta
6380: 63 6b 65 64 20 6f 6e 20 74 6f 20 6e 65 77 6c 73 cked on to newls
6390: 74 20 63 72 65 61 74 65 20 6e 65 77 20 72 65 72 t create new rer
63a0: 75 6e 73 20 66 72 6f 6d 20 6a 75 6e 6b 65 64 0a uns from junked.
63b0: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
63c0: 20 6e 65 77 6c 73 74 29 28 63 64 72 20 6e 65 77 newlst)(cdr new
63d0: 6c 73 74 29 28 64 65 6c 65 74 65 2d 64 75 70 6c lst)(delete-dupl
63e0: 69 63 61 74 65 73 20 6a 75 6e 6b 65 64 29 29 29 icates junked)))
63f0: 29 29 29 29 29 29 0a 0a 3b 3b 20 70 61 72 65 6e ))))))..;; paren
6400: 74 2d 74 65 73 74 20 69 73 20 74 68 65 72 65 20 t-test is there
6410: 61 73 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 as a placeholder
6420: 20 66 6f 72 20 77 68 65 6e 20 70 61 72 65 6e 74 for when parent
6430: 2d 74 65 73 74 73 20 63 61 6e 20 62 65 20 72 75 -tests can be ru
6440: 6e 20 61 73 20 61 20 73 65 74 75 70 20 73 74 65 n as a setup ste
6450: 70 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 p.(define (run:t
6460: 65 73 74 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 est run-id runna
6470: 6d 65 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 me keyvallst tes
6480: 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 20 70 t-record flags p
6490: 61 72 65 6e 74 2d 74 65 73 74 29 0a 20 20 3b 3b arent-test). ;;
64a0: 20 41 6c 6c 20 74 68 65 73 65 20 76 61 72 73 20 All these vars
64b0: 6d 69 67 68 74 20 62 65 20 72 65 66 65 72 65 6e might be referen
64c0: 63 65 64 20 62 79 20 74 68 65 20 74 65 73 74 63 ced by the testc
64d0: 6f 6e 66 69 67 20 66 69 6c 65 20 72 65 61 64 65 onfig file reade
64e0: 72 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 r. (let* ((test
64f0: 2d 6e 61 6d 65 20 20 20 20 28 74 65 73 74 73 3a -name (tests:
6500: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 testqueue-get-te
6510: 73 74 6e 61 6d 65 20 20 20 74 65 73 74 2d 72 65 stname test-re
6520: 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 77 cord)).. (test-w
6530: 61 69 74 6f 6e 73 20 28 74 65 73 74 73 3a 74 65 aitons (tests:te
6540: 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 stqueue-get-wait
6550: 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 63 6f ons test-reco
6560: 72 64 29 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e rd)).. (test-con
6570: 66 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 f (tests:test
6580: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f queue-get-testco
6590: 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 nfig test-record
65a0: 29 29 0a 09 20 28 69 74 65 6d 64 61 74 20 20 20 )).. (itemdat
65b0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
65c0: 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 eue-get-itemdat
65d0: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
65e0: 0a 09 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 .. (test-path
65f0: 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a (conc *toppath*
6600: 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d "/tests/" test-
6610: 6e 61 6d 65 29 29 20 3b 3b 20 63 6f 75 6c 64 20 name)) ;; could
6620: 75 73 65 20 74 65 73 74 73 3a 67 65 74 2d 74 65 use tests:get-te
6630: 73 74 63 6f 6e 66 69 67 20 68 65 72 65 20 2e 2e stconfig here ..
6640: 2e 0a 09 20 28 66 6f 72 63 65 20 20 20 20 20 20 ... (force
6650: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
6660: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
6670: 22 2d 66 6f 72 63 65 22 20 23 66 29 29 0a 09 20 "-force" #f))..
6680: 28 72 65 72 75 6e 20 20 20 20 20 20 20 20 28 68 (rerun (h
6690: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
66a0: 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 65 fault flags "-re
66b0: 72 75 6e 22 20 23 66 29 29 0a 09 20 28 6b 65 65 run" #f)).. (kee
66c0: 70 67 6f 69 6e 67 20 20 20 20 28 68 61 73 68 2d pgoing (hash-
66d0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
66e0: 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f t flags "-keepgo
66f0: 69 6e 67 22 20 23 66 29 29 0a 09 20 28 69 74 65 ing" #f)).. (ite
6700: 6d 2d 70 61 74 68 20 20 20 20 20 22 22 29 0a 09 m-path "")..
6710: 20 28 64 62 20 20 20 20 20 20 20 20 20 20 20 23 (db #
6720: 66 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 f)). (debug:p
6730: 72 69 6e 74 20 34 0a 09 09 20 22 74 65 73 74 2d rint 4... "test-
6740: 63 6f 6e 66 69 67 3a 20 22 20 28 68 61 73 68 2d config: " (hash-
6750: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 table->alist tes
6760: 74 2d 63 6f 6e 66 29 0a 09 09 20 22 5c 6e 20 20 t-conf)... "\n
6770: 20 69 74 65 6d 64 61 74 3a 20 22 20 69 74 65 6d itemdat: " item
6780: 64 61 74 0a 09 09 20 29 0a 20 20 20 20 3b 3b 20 dat... ). ;;
6790: 73 65 74 74 69 6e 67 20 69 74 65 6d 64 61 74 20 setting itemdat
67a0: 74 6f 20 61 20 6c 69 73 74 20 69 66 20 69 74 20 to a list if it
67b0: 69 73 20 23 66 0a 20 20 20 20 28 69 66 20 28 6e is #f. (if (n
67c0: 6f 74 20 69 74 65 6d 64 61 74 29 28 73 65 74 21 ot itemdat)(set!
67d0: 20 69 74 65 6d 64 61 74 20 27 28 29 29 29 0a 20 itemdat '())).
67e0: 20 20 20 28 73 65 74 21 20 69 74 65 6d 2d 70 61 (set! item-pa
67f0: 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 th (item-list->p
6800: 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a 20 20 ath itemdat)).
6810: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
6820: 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 "Attempting to
6830: 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 74 65 launch test " te
6840: 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 st-name (if (equ
6850: 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 2f al? item-path "/
6860: 22 29 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 ") "/" item-path
6870: 29 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 )). (setenv "
6880: 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 MT_TEST_NAME" te
6890: 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 st-name) ;; .
68a0: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
68b0: 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 NAME" runname)
68c0: 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 . (open-run-c
68d0: 6c 6f 73 65 20 73 65 74 2d 6d 65 67 61 74 65 73 lose set-megates
68e0: 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 t-env-vars db ru
68f0: 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d n-id) ;; these m
6900: 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 ay be needed by
6910: 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 the launching pr
6920: 6f 63 65 73 73 0a 20 20 20 20 28 63 68 61 6e 67 ocess. (chang
6930: 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 e-directory *top
6940: 70 61 74 68 2a 29 0a 0a 20 20 20 20 3b 3b 20 48 path*).. ;; H
6950: 65 72 65 20 69 73 20 77 68 65 72 65 20 74 68 65 ere is where the
6960: 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 test_meta table
6970: 20 69 73 20 62 65 73 74 20 75 70 64 61 74 65 64 is best updated
6980: 0a 20 20 20 20 3b 3b 20 59 65 73 2c 20 61 6e 6f . ;; Yes, ano
6990: 74 68 65 72 20 75 73 65 20 6f 66 20 61 20 67 6c ther use of a gl
69a0: 6f 62 61 6c 20 66 6f 72 20 63 61 63 68 69 6e 67 obal for caching
69b0: 2e 20 4e 65 65 64 20 61 20 62 65 74 74 65 72 20 . Need a better
69c0: 77 61 79 3f 0a 20 20 20 20 28 69 66 20 28 6e 6f way?. (if (no
69d0: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
69e0: 66 2f 64 65 66 61 75 6c 74 20 2a 74 65 73 74 2d f/default *test-
69f0: 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 meta-updated* te
6a00: 73 74 2d 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 st-name #f)).
6a10: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
6a20: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
6a30: 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 *test-meta-upda
6a40: 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 ted* test-name #
6a50: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 6f t). (o
6a60: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 pen-run-close ru
6a70: 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d ns:update-test_m
6a80: 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 eta db test-name
6a90: 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 test-conf))).
6aa0: 20 20 0a 20 20 20 20 3b 3b 20 28 6c 61 6d 62 64 . ;; (lambd
6ab0: 61 20 28 69 74 65 6d 64 61 74 29 20 3b 3b 3b 20 a (itemdat) ;;;
6ac0: 28 28 72 69 70 65 6e 65 73 73 20 22 6f 76 65 72 ((ripeness "over
6ad0: 72 69 70 65 22 29 20 28 74 65 6d 70 65 72 61 74 ripe") (temperat
6ae0: 75 72 65 20 22 63 6f 6f 6c 22 29 20 28 73 65 61 ure "cool") (sea
6af0: 73 6f 6e 20 22 73 75 6d 6d 65 72 22 29 29 0a 20 son "summer")).
6b00: 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 (let* ((new-t
6b10: 65 73 74 2d 70 61 74 68 20 28 73 74 72 69 6e 67 est-path (string
6b20: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 63 6f -intersperse (co
6b30: 6e 73 20 74 65 73 74 2d 70 61 74 68 20 28 6d 61 ns test-path (ma
6b40: 70 20 63 61 64 72 20 69 74 65 6d 64 61 74 29 29 p cadr itemdat))
6b50: 20 22 2f 22 29 29 0a 09 20 20 20 28 6e 65 77 2d "/")).. (new-
6b60: 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 test-name (if (e
6b70: 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 qual? item-path
6b80: 22 22 29 20 74 65 73 74 2d 6e 61 6d 65 20 28 63 "") test-name (c
6b90: 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f onc test-name "/
6ba0: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 20 3b " item-path))) ;
6bb0: 3b 20 6a 75 73 74 20 6e 65 65 64 20 69 74 20 74 ; just need it t
6bc0: 6f 20 62 65 20 75 6e 69 71 75 65 0a 09 20 20 20 o be unique..
6bd0: 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 20 28 (test-id (
6be0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
6bf0: 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 b:get-test-id db
6c00: 20 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 run-id test-na
6c10: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 me item-path))..
6c20: 20 20 20 28 74 65 73 74 64 61 74 20 20 20 20 20 (testdat
6c30: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
6c40: 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e e db:get-test-in
6c50: 66 6f 2d 62 79 2d 69 64 20 64 62 20 74 65 73 74 fo-by-id db test
6c60: 2d 69 64 29 29 29 0a 20 20 20 20 20 20 28 69 66 -id))). (if
6c70: 20 28 6e 6f 74 20 74 65 73 74 64 61 74 29 0a 09 (not testdat)..
6c80: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 3b 3b (begin.. ;;
6c90: 20 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 ensure that the
6ca0: 20 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 path exists bef
6cb0: 6f 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 ore registering
6cc0: 74 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b the test.. ;;
6cd0: 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 NOPE: Cannot! D
6ce0: 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 on't know yet wh
6cf0: 69 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 ich disk area wi
6d00: 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e ll be assigned..
6d10: 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 .... ;; (syst
6d20: 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 em (conc "mkdir
6d30: 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 -p " new-test-pa
6d40: 74 68 29 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 th)).. ;;..
6d50: 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 ;; (open-run-c
6d60: 6c 6f 73 65 20 74 65 73 74 73 3a 72 65 67 69 73 lose tests:regis
6d70: 74 65 72 2d 74 65 73 74 20 64 62 20 72 75 6e 2d ter-test db run-
6d80: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
6d90: 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 3b 3b 0a m-path).. ;;.
6da0: 09 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 66 6f 72 . ;; NB// for
6db0: 20 74 68 65 20 61 62 6f 76 65 20 6c 69 6e 65 2e the above line.
6dc0: 20 49 20 77 61 6e 74 20 74 68 65 20 74 65 73 74 I want the test
6dd0: 20 74 6f 20 62 65 20 72 65 67 69 73 74 65 72 65 to be registere
6de0: 64 20 6c 6f 6e 67 20 62 65 66 6f 72 65 20 74 68 d long before th
6df0: 69 73 20 72 6f 75 74 69 6e 65 20 67 65 74 73 20 is routine gets
6e00: 63 61 6c 6c 65 64 21 0a 09 20 20 20 20 3b 3b 0a called!.. ;;.
6e10: 09 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d . (set! test-
6e20: 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f id (open-run-clo
6e30: 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 se db:get-test-i
6e40: 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 d db run-id test
6e50: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
6e60: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
6e70: 74 65 73 74 2d 69 64 29 0a 09 09 28 62 65 67 69 test-id)...(begi
6e80: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
6e90: 6e 74 20 32 20 22 57 41 52 4e 3a 20 54 65 73 74 nt 2 "WARN: Test
6ea0: 20 6e 6f 74 20 70 72 65 2d 63 72 65 61 74 65 64 not pre-created
6eb0: 3f 20 74 65 73 74 2d 6e 61 6d 65 3d 22 20 74 65 ? test-name=" te
6ec0: 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 65 6d 2d st-name ", item-
6ed0: 70 61 74 68 3d 22 20 69 74 65 6d 2d 70 61 74 68 path=" item-path
6ee0: 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ", run-id=" run
6ef0: 2d 69 64 29 0a 09 09 20 20 28 6f 70 65 6e 2d 72 -id)... (open-r
6f00: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 un-close db:test
6f10: 73 2d 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 s-register-test
6f20: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
6f30: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 ame item-path)..
6f40: 09 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 64 . (set! test-id
6f50: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
6f60: 20 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 db:get-test-id
6f70: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e db run-id test-n
6f80: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
6f90: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
6fa0: 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 74 65 73 int 4 "INFO: tes
6fb0: 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 20 22 t-id=" test-id "
6fc0: 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 , run-id=" run-i
6fd0: 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 3d 22 d ", test-name="
6fe0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 69 74 test-name ", it
6ff0: 65 6d 2d 70 61 74 68 3d 5c 22 22 20 69 74 65 6d em-path=\"" item
7000: 2d 70 61 74 68 20 22 5c 22 22 29 0a 09 20 20 20 -path "\"")..
7010: 20 28 73 65 74 21 20 74 65 73 74 64 61 74 20 28 (set! testdat (
7020: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
7030: 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d b:get-test-info-
7040: 62 79 2d 69 64 20 64 62 20 74 65 73 74 2d 69 64 by-id db test-id
7050: 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 )))). (set!
7060: 20 74 65 73 74 2d 69 64 20 28 64 62 3a 74 65 73 test-id (db:tes
7070: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
7080: 29 29 0a 20 20 20 20 20 20 28 63 68 61 6e 67 65 )). (change
7090: 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d -directory test-
70a0: 70 61 74 68 29 0a 20 20 20 20 20 20 28 63 61 73 path). (cas
70b0: 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 28 e (if force ;; (
70c0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 args:get-arg "-f
70d0: 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 54 orce")...'NOT_ST
70e0: 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 73 74 ARTED...(if test
70f0: 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 69 6e dat... (strin
7100: 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 3a g->symbol (test:
7110: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
7120: 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 6c 65 t))... 'faile
7130: 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 28 d-to-insert))..(
7140: 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 (failed-to-inser
7150: 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e t).. (debug:prin
7160: 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c t 0 "ERROR: Fail
7170: 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 68 65 ed to insert the
7180: 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 65 record into the
7190: 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 54 db"))..((NOT_ST
71a0: 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 29 ARTED COMPLETED)
71b0: 0a 09 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 .. (let ((runfla
71c0: 67 20 23 66 29 29 0a 09 20 20 20 28 63 6f 6e 64 g #f)).. (cond
71d0: 0a 09 20 20 20 20 3b 3b 20 2d 66 6f 72 63 65 2c .. ;; -force,
71e0: 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 run no matter w
71f0: 68 61 74 0a 09 20 20 20 20 28 66 6f 72 63 65 20 hat.. (force
7200: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
7210: 29 29 0a 09 20 20 20 20 3b 3b 20 4e 4f 54 5f 53 )).. ;; NOT_S
7220: 54 41 52 54 45 44 2c 20 72 75 6e 20 6e 6f 20 6d TARTED, run no m
7230: 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 atter what..
7240: 28 28 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 ((equal? (test:g
7250: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
7260: 29 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 ) "NOT_STARTED")
7270: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
7280: 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 2d )).. ;; not -
7290: 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 2c 20 rerun and PASS,
72a0: 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 64 WARN or CHECK, d
72b0: 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 28 o no run.. ((
72c0: 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 72 and (or (not rer
72d0: 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 65 70 un)... keep
72e0: 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 65 going)... ;; Re
72f0: 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 20 72 quire to force r
7300: 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 e-run for COMPLE
7310: 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e 67 TED or *anything
7320: 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f 72 * + PASS,WARN or
7330: 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 28 CHECK... (or (
7340: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
7350: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
7360: 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 '("PASS" "WARN"
7370: 20 22 43 48 45 43 4b 22 29 29 0a 09 09 20 20 20 "CHECK"))...
7380: 20 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 (member (test
7390: 3a 67 65 74 2d 73 74 61 74 65 20 20 74 65 73 74 :get-state test
73a0: 64 61 74 29 20 27 28 22 43 4f 4d 50 4c 45 54 45 dat) '("COMPLETE
73b0: 44 22 29 29 29 29 20 0a 09 20 20 20 20 20 28 64 D")))) .. (d
73c0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 4e ebug:print 2 "IN
73d0: 46 4f 3a 20 72 75 6e 6e 69 6e 67 20 74 65 73 74 FO: running test
73e0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 " test-name "/"
73f0: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 73 75 70 item-path " sup
7400: 70 72 65 73 73 65 64 20 61 73 20 69 74 20 69 73 pressed as it is
7410: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
7420: 74 65 20 74 65 73 74 64 61 74 29 20 22 20 61 6e te testdat) " an
7430: 64 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 d " (test:get-st
7440: 61 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 atus testdat))..
7450: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
7460: 61 67 20 23 66 29 29 0a 09 20 20 20 20 3b 3b 20 ag #f)).. ;;
7470: 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 74 75 -rerun and statu
7480: 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 s is one of the
7490: 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 69 74 specifed, run it
74a0: 0a 09 20 20 20 20 28 28 61 6e 64 20 72 65 72 75 .. ((and reru
74b0: 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 72 65 n... (let* ((re
74c0: 72 75 6e 6c 73 74 20 20 20 28 73 74 72 69 6e 67 runlst (string
74d0: 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 22 2c 22 -split rerun ","
74e0: 29 29 0a 09 09 09 20 28 6d 75 73 74 2d 72 65 72 )).... (must-rer
74f0: 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 un (member (test
7500: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
7510: 64 61 74 29 20 72 65 72 75 6e 6c 73 74 29 29 29 dat) rerunlst)))
7520: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
7530: 69 6e 74 20 33 20 22 49 4e 46 4f 3a 20 2d 72 65 int 3 "INFO: -re
7540: 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 72 75 run list: " reru
7550: 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 74 75 73 n ", test-status
7560: 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 : " (test:get-st
7570: 61 74 75 73 20 74 65 73 74 64 61 74 29 22 2c 20 atus testdat)",
7580: 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 6d 75 must-rerun: " mu
7590: 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 20 20 st-rerun)...
75a0: 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 20 20 must-rerun))..
75b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
75c0: 32 20 22 49 4e 46 4f 3a 20 52 65 72 75 6e 20 66 2 "INFO: Rerun f
75d0: 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 20 22 orced for test "
75e0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
75f0: 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 20 tem-path)..
7600: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
7610: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 70 )).. ;; -keep
7620: 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 going, do not re
7630: 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 28 run FAIL.. ((
7640: 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 and keepgoing...
7650: 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a (member (test:
7660: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
7670: 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a at) '("FAIL"))).
7680: 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 . (set! runf
7690: 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 28 28 lag #f)).. ((
76a0: 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a and (not rerun).
76b0: 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 .. (member (tes
76c0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
76d0: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 tdat) '("FAIL" "
76e0: 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 28 73 n/a"))).. (s
76f0: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
7700: 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 65 74 .. (else (set
7710: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a ! runflag #f))).
7720: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
7730: 20 36 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 6 "RUNNING => r
7740: 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 unflag: " runfla
7750: 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 g " STATE: " (te
7760: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
7770: 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 tdat) " STATUS:
7780: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
7790: 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 us testdat))..
77a0: 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 (if (not runfla
77b0: 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 g).. (if (
77c0: 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 not parent-test)
77d0: 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
77e0: 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 nt 1 "NOTE: Not
77f0: 73 74 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 starting test "
7800: 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 new-test-name "
7810: 61 73 20 69 74 20 69 73 20 73 74 61 74 65 20 5c as it is state \
7820: 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 "" (test:get-sta
7830: 74 65 20 74 65 73 74 64 61 74 29 20 0a 09 09 09 te testdat) ....
7840: 09 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 20 ."\" and status
7850: 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 \"" (test:get-st
7860: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 22 5c atus testdat) "\
7870: 22 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 ", use -rerun \"
7880: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
7890: 75 73 20 74 65 73 74 64 61 74 29 0a 20 20 20 20 us testdat).
78a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
78b0: 20 20 20 20 20 20 20 20 20 20 20 20 22 5c 22 20 "\"
78c0: 6f 72 20 2d 66 6f 72 63 65 20 74 6f 20 6f 76 65 or -force to ove
78d0: 72 72 69 64 65 22 29 29 0a 09 20 20 20 20 20 20 rride"))..
78e0: 20 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f 6e ;; NOTE: No lon
78f0: 67 65 72 20 62 65 20 63 68 65 63 6b 69 6e 67 20 ger be checking
7900: 70 72 65 72 65 71 75 69 73 69 74 65 73 20 68 65 prerequisites he
7910: 72 65 21 20 57 69 6c 6c 20 6e 65 76 65 72 20 67 re! Will never g
7920: 65 74 20 68 65 72 65 20 75 6e 6c 65 73 73 20 70 et here unless p
7930: 72 65 72 65 71 73 20 61 72 65 0a 09 20 20 20 20 rereqs are..
7940: 20 20 20 3b 3b 20 20 20 20 20 20 20 61 6c 72 65 ;; alre
7950: 61 64 79 20 6d 65 74 2e 0a 09 20 20 20 20 20 20 ady met...
7960: 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 (if (not (launc
7970: 68 2d 74 65 73 74 20 23 66 20 72 75 6e 2d 69 64 h-test #f run-id
7980: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 63 6f runname test-co
7990: 6e 66 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 nf keyvallst tes
79a0: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 t-name test-path
79b0: 20 69 74 65 6d 64 61 74 20 66 6c 61 67 73 29 29 itemdat flags))
79c0: 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 ... (begin...
79d0: 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f (print "ERRO
79e0: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 R: Failed to lau
79f0: 6e 63 68 20 74 68 65 20 74 65 73 74 2e 20 45 78 nch the test. Ex
7a00: 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 iting as soon as
7a10: 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 20 20 possible")...
7a20: 20 20 20 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c (set! *global
7a30: 65 78 69 74 73 74 61 74 75 73 2a 20 31 29 20 3b exitstatus* 1) ;
7a40: 3b 20 0a 09 09 20 20 20 20 20 28 70 72 6f 63 65 ; ... (proce
7a50: 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 65 ss-signal (curre
7a60: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 73 nt-process-id) s
7a70: 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 29 ignal/kill))))))
7a80: 0a 09 28 28 4b 49 4c 4c 45 44 29 20 0a 09 20 28 ..((KILLED) .. (
7a90: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4e debug:print 1 "N
7aa0: 4f 54 45 3a 20 22 20 6e 65 77 2d 74 65 73 74 2d OTE: " new-test-
7ab0: 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 name " is alread
7ac0: 79 20 72 75 6e 6e 69 6e 67 20 6f 72 20 77 61 73 y running or was
7ad0: 20 65 78 70 6c 69 63 74 6c 79 20 6b 69 6c 6c 65 explictly kille
7ae0: 64 2c 20 75 73 65 20 2d 66 6f 72 63 65 20 74 6f d, use -force to
7af0: 20 6c 61 75 6e 63 68 20 69 74 2e 22 29 29 0a 09 launch it."))..
7b00: 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 ((LAUNCHED REMOT
7b10: 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e 49 EHOSTSTART RUNNI
7b20: 4e 47 29 20 20 0a 09 20 28 69 66 20 28 3e 20 28 NG) .. (if (> (
7b30: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
7b40: 64 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 ds)(+ (db:test-g
7b50: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 et-event_time te
7b60: 73 74 64 61 74 29 0a 09 09 09 09 20 20 20 20 20 stdat).....
7b70: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
7b80: 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 un_duration test
7b90: 64 61 74 29 29 29 0a 09 09 36 30 30 29 20 3b 3b dat)))...600) ;;
7ba0: 20 69 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 20 i.e. no update
7bb0: 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 36 30 for more than 60
7bc0: 30 20 73 65 63 6f 6e 64 73 0a 09 20 20 20 20 20 0 seconds..
7bd0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 (begin.. (
7be0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
7bf0: 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 ARNING: Test " t
7c00: 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 est-name " appea
7c10: 72 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 rs to be dead. F
7c20: 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 orcing it to sta
7c30: 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e te INCOMPLETE an
7c40: 64 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 d status STUCK/D
7c50: 45 41 44 22 29 0a 09 20 20 20 20 20 20 20 28 6f EAD").. (o
7c60: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 pen-run-close te
7c70: 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 st-set-status! d
7c80: 62 20 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d b test-id "INCOM
7c90: 50 4c 45 54 45 22 20 22 53 54 55 43 4b 2f 44 45 PLETE" "STUCK/DE
7ca0: 41 44 22 20 22 54 65 73 74 20 69 73 20 73 74 75 AD" "Test is stu
7cb0: 63 6b 20 6f 72 20 64 65 61 64 22 20 23 66 29 29 ck or dead" #f))
7cc0: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
7cd0: 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 int 2 "NOTE: " t
7ce0: 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c est-name " is al
7cf0: 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 ready running"))
7d00: 29 0a 09 28 65 6c 73 65 20 20 20 20 20 20 20 28 )..(else (
7d10: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
7d20: 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 RROR: Failed to
7d30: 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 6e 65 launch test " ne
7d40: 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 w-test-name ". U
7d50: 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 74 61 74 nrecognised stat
7d60: 65 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 e " (test:get-st
7d70: 61 74 65 20 74 65 73 74 64 61 74 29 29 29 29 29 ate testdat)))))
7d80: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
7d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
7dd0: 45 4e 44 20 4f 46 20 4e 45 57 20 53 54 55 46 46 END OF NEW STUFF
7de0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
7df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
7e30: 6e 65 20 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e ne (get-dir-up-n
7e40: 20 64 69 72 20 2e 20 70 61 72 61 6d 73 29 20 0a dir . params) .
7e50: 20 20 28 6c 65 74 20 28 28 64 70 61 72 74 73 20 (let ((dparts
7e60: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 (string-split d
7e70: 69 72 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 ir "/"))..(count
7e80: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 (if (null? pa
7e90: 72 61 6d 73 29 20 31 20 28 63 61 72 20 70 61 72 rams) 1 (car par
7ea0: 61 6d 73 29 29 29 29 0a 20 20 20 20 28 63 6f 6e ams)))). (con
7eb0: 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e c "/" (string-in
7ec0: 74 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 20 tersperse ..
7ed0: 20 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 20 (take dparts
7ee0: 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 (- (length dpart
7ef0: 73 29 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 s) count))..
7f00: 20 20 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 65 "/")))).;; Re
7f10: 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 move runs.;; fie
7f20: 6c 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 20 lds are passing
7f30: 69 6e 20 74 68 72 6f 75 67 68 20 0a 3b 3b 20 61 in through .;; a
7f40: 63 74 69 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 65 ction:.;; 're
7f50: 6d 6f 76 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 20 move-runs.;;
7f60: 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 'set-state-statu
7f70: 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 6f s.;;.;; NB// sho
7f80: 75 6c 64 20 70 61 73 73 20 69 6e 20 6b 65 79 73 uld pass in keys
7f90: 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 ?.;;.(define (ru
7fa0: 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 64 62 ns:operate-on db
7fb0: 20 61 63 74 69 6f 6e 20 72 75 6e 6e 61 6d 65 70 action runnamep
7fc0: 61 74 74 20 74 65 73 74 70 61 74 74 20 69 74 65 att testpatt ite
7fd0: 6d 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 61 mpatt #!key (sta
7fe0: 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 66 te #f)(status #f
7ff0: 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 )(new-state-stat
8000: 75 73 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 us #f)). (let*
8010: 28 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 ((keys (
8020: 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db:get-keys db))
8030: 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 .. (rundat
8040: 20 28 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d (runs:get-runs-
8050: 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 by-patt db keys
8060: 72 75 6e 6e 61 6d 65 70 61 74 74 29 29 0a 09 20 runnamepatt))..
8070: 28 68 65 61 64 65 72 20 20 20 20 20 20 20 28 76 (header (v
8080: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 ector-ref rundat
8090: 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 20 0)).. (runs
80a0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
80b0: 20 72 75 6e 64 61 74 20 31 29 29 0a 09 20 28 73 rundat 1)).. (s
80c0: 74 61 74 65 73 20 20 20 20 20 20 20 28 69 66 20 tates (if
80d0: 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d 73 state (string-s
80e0: 70 6c 69 74 20 73 74 61 74 65 20 20 22 2c 22 29 plit state ",")
80f0: 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 75 73 '())).. (status
8100: 65 73 20 20 20 20 20 28 69 66 20 73 74 61 74 75 es (if statu
8110: 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
8120: 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 29 29 status ",") '())
8130: 29 0a 09 20 28 73 74 61 74 65 2d 73 74 61 74 75 ).. (state-statu
8140: 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 6e s (if (string? n
8150: 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 ew-state-status)
8160: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6e (string-split n
8170: 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 ew-state-status
8180: 22 2c 22 29 20 27 28 23 66 20 23 66 29 29 29 29 ",") '(#f #f))))
8190: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
81a0: 74 20 32 20 22 48 65 61 64 65 72 3a 20 22 20 68 t 2 "Header: " h
81b0: 65 61 64 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 eader " action:
81c0: 22 20 61 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 " action " new-s
81d0: 74 61 74 65 2d 73 74 61 74 75 73 3a 20 22 20 6e tate-status: " n
81e0: 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 ew-state-status)
81f0: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
8200: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 6e (lambda (run
8210: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 ). (let ((
8220: 72 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 2d 69 runkey (string-i
8230: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
8240: 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 09 09 (lambda (k).....
8250: 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d ..(db:get-value-
8260: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
8270: 61 64 65 72 20 28 76 65 63 74 6f 72 2d 72 65 66 ader (vector-ref
8280: 20 6b 20 30 29 29 29 20 6b 65 79 73 29 20 22 2f k 0))) keys) "/
8290: 22 29 29 0a 09 20 20 20 20 20 28 64 69 72 73 2d ")).. (dirs-
82a0: 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b 65 2d to-remove (make-
82b0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 20 hash-table)))..
82c0: 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 20 20 (let* ((run-id
82d0: 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d (db:get-value-
82e0: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
82f0: 61 64 65 72 20 22 69 64 22 29 29 0a 09 09 28 72 ader "id"))...(r
8300: 75 6e 2d 73 74 61 74 65 20 28 64 62 3a 67 65 74 un-state (db:get
8310: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
8320: 20 72 75 6e 20 68 65 61 64 65 72 20 22 73 74 61 run header "sta
8330: 74 65 22 29 29 0a 09 09 28 74 65 73 74 73 20 20 te"))...(tests
8340: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 (if (not (equ
8350: 61 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 22 6c al? run-state "l
8360: 6f 63 6b 65 64 22 29 29 0a 09 09 09 20 20 20 20 ocked"))....
8370: 20 20 20 28 64 62 3a 67 65 74 2d 74 65 73 74 73 (db:get-tests
8380: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 3a -for-run db (db:
8390: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
83a0: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
83b0: 69 64 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 id").......
83c0: 20 74 65 73 74 70 61 74 74 20 69 74 65 6d 70 61 testpatt itempa
83d0: 74 74 20 73 74 61 74 65 73 20 73 74 61 74 75 73 tt states status
83e0: 65 73 0a 09 09 09 09 09 09 20 20 20 20 20 20 6e es....... n
83f0: 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 09 09 09 ot-in: #f......
8400: 09 20 20 20 20 20 20 73 6f 72 74 2d 62 79 3a 20 . sort-by:
8410: 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 (case action....
8420: 09 09 09 09 09 20 28 28 72 65 6d 6f 76 65 2d 72 ..... ((remove-r
8430: 75 6e 73 29 20 27 72 75 6e 64 69 72 29 0a 09 09 uns) 'rundir)...
8440: 09 09 09 09 09 09 20 28 65 6c 73 65 20 20 20 20 ...... (else
8450: 20 20 20 20 20 20 27 65 76 65 6e 74 5f 74 69 6d 'event_tim
8460: 65 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 27 e))).... '
8470: 28 29 29 29 0a 09 09 28 6c 61 73 74 74 70 61 74 ()))...(lasttpat
8480: 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 h "/does/not/exi
8490: 73 74 2f 49 2f 68 6f 70 65 22 29 29 0a 0a 09 20 st/I/hope"))...
84a0: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
84b0: 3f 20 74 65 73 74 73 29 29 0a 09 20 20 20 20 20 ? tests))..
84c0: 20 20 28 62 65 67 69 6e 0a 09 09 20 28 63 61 73 (begin... (cas
84d0: 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 28 28 e action... ((
84e0: 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 20 remove-runs)...
84f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
8500: 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 1 "Removing test
8510: 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e s for run: " run
8520: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
8530: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
8540: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
8550: 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 73 ame")))... ((s
8560: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 et-state-status)
8570: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
8580: 69 6e 74 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 int 1 "Modifying
8590: 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 75 73 state and staus
85a0: 20 66 6f 72 20 74 65 73 74 73 20 66 6f 72 20 72 for tests for r
85b0: 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
85c0: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
85d0: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
85e0: 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 der "runname")))
85f0: 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 09 20 20 ... (else...
8600: 20 20 28 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 (print "INFO:
8610: 61 63 74 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 action not recog
8620: 6e 69 73 65 64 20 22 20 61 63 74 69 6f 6e 29 29 nised " action))
8630: 29 0a 09 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 )... (for-each..
8640: 09 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 . (lambda (test
8650: 29 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 )... (let* ((
8660: 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 item-path (db:te
8670: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
8680: 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 28 74 test)).... (t
8690: 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 est-name (db:tes
86a0: 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 t-get-testname t
86b0: 65 73 74 29 29 0a 09 09 09 20 20 20 28 72 75 6e est)).... (run
86c0: 2d 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d -dir (db:test-
86d0: 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 29 get-rundir test)
86e0: 29 0a 09 09 09 20 20 20 28 74 65 73 74 2d 69 64 ).... (test-id
86f0: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
8700: 69 64 20 74 65 73 74 29 29 29 0a 09 09 20 20 20 id test)))...
8710: 20 20 20 3b 3b 20 20 20 28 74 64 62 20 20 20 20 ;; (tdb
8720: 20 20 20 28 64 62 3a 6f 70 65 6e 2d 74 65 73 74 (db:open-test
8730: 2d 64 62 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 -db run-dir)))..
8740: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
8750: 69 6e 74 20 31 20 22 20 20 22 20 28 64 62 3a 74 int 1 " " (db:t
8760: 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 est-get-testname
8770: 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 20 28 test) " id: " (
8780: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
8790: 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d 70 61 est) " " item-pa
87a0: 74 68 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 th " action: " a
87b0: 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 28 ction)... (
87c0: 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 28 case action....(
87d0: 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 3b 3b (remove-runs) ;;
87e0: 20 74 68 65 20 74 64 62 20 69 73 20 66 6f 72 20 the tdb is for
87f0: 66 75 74 75 72 65 20 70 6f 73 73 69 62 6c 65 2e future possible.
8800: 20 0a 09 09 09 20 28 64 62 3a 64 65 6c 65 74 65 .... (db:delete
8810: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 -test-records db
8820: 20 23 66 20 28 64 62 3a 74 65 73 74 2d 67 65 74 #f (db:test-get
8830: 2d 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 28 -id test)).... (
8840: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 debug:print 1 "I
8850: 4e 46 4f 3a 20 41 74 74 65 6d 70 74 69 6e 67 20 NFO: Attempting
8860: 74 6f 20 72 65 6d 6f 76 65 20 64 69 72 20 22 20 to remove dir "
8870: 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 28 69 66 run-dir).... (if
8880: 20 28 61 6e 64 20 28 3e 20 28 73 74 72 69 6e 67 (and (> (string
8890: 2d 6c 65 6e 67 74 68 20 72 75 6e 2d 64 69 72 29 -length run-dir)
88a0: 20 35 29 0a 09 09 09 09 20 20 28 66 69 6c 65 2d 5)..... (file-
88b0: 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 69 72 29 exists? run-dir)
88c0: 29 20 3b 3b 20 62 61 64 20 68 65 75 72 69 73 74 ) ;; bad heurist
88d0: 69 63 20 62 75 74 20 73 68 6f 75 6c 64 20 70 72 ic but should pr
88e0: 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d 65 event /tmp /home
88f0: 20 65 74 63 2e 0a 09 09 09 20 20 20 20 20 28 6c etc..... (l
8900: 65 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 28 et* ((realpath (
8910: 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 resolve-pathname
8920: 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 run-dir)))....
8930: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8940: 6e 74 20 31 20 22 49 4e 46 4f 3a 20 52 65 61 6c nt 1 "INFO: Real
8950: 20 70 61 74 68 20 6f 66 20 69 73 20 22 20 72 65 path of is " re
8960: 61 6c 70 61 74 68 29 0a 09 09 09 20 20 20 20 20 alpath)....
8970: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
8980: 74 73 3f 20 72 65 61 6c 70 61 74 68 29 0a 09 09 ts? realpath)...
8990: 09 09 20 20 20 28 69 66 20 28 3e 20 28 73 79 73 .. (if (> (sys
89a0: 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 tem (conc "rm -r
89b0: 66 20 22 20 72 65 61 6c 70 61 74 68 29 29 20 30 f " realpath)) 0
89c0: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 )..... (de
89d0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
89e0: 4f 52 3a 20 54 68 65 72 65 20 77 61 73 20 61 20 OR: There was a
89f0: 70 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 69 6e 67 problem removing
8a00: 20 22 20 72 65 61 6c 70 61 74 68 20 22 20 77 69 " realpath " wi
8a10: 74 68 20 72 6d 20 2d 66 22 29 29 0a 09 09 09 09 th rm -f")).....
8a20: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
8a30: 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 0 "WARNING: test
8a40: 20 72 75 6e 20 64 69 72 20 22 20 72 65 61 6c 70 run dir " realp
8a50: 61 74 68 20 22 20 61 70 70 65 61 72 73 20 74 6f ath " appears to
8a60: 20 6e 6f 74 20 65 78 69 73 74 22 29 29 0a 09 09 not exist"))...
8a70: 09 20 20 20 20 20 20 20 28 69 66 20 28 66 69 6c . (if (fil
8a80: 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 69 e-exists? run-di
8a90: 72 29 20 3b 3b 20 74 68 65 20 6c 69 6e 6b 0a 09 r) ;; the link..
8aa0: 09 09 09 20 20 20 28 69 66 20 28 73 79 6d 62 6f ... (if (symbo
8ab0: 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 69 lic-link? run-di
8ac0: 72 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 r)..... (d
8ad0: 65 6c 65 74 65 2d 66 69 6c 65 20 72 75 6e 2d 64 elete-file run-d
8ae0: 69 72 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 ir)..... (
8af0: 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 72 if (directory? r
8b00: 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 20 20 20 un-dir)......
8b10: 28 69 66 20 28 3e 20 28 64 69 72 65 63 74 6f 72 (if (> (director
8b20: 79 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 y-fold (lambda (
8b30: 66 20 78 29 28 2b 20 31 20 78 29 29 20 30 20 72 f x)(+ 1 x)) 0 r
8b40: 75 6e 2d 64 69 72 29 20 30 29 0a 09 09 09 09 09 un-dir) 0)......
8b50: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
8b60: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
8b70: 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f refusing to remo
8b80: 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 ve " run-dir " a
8b90: 73 20 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 74 s it is not empt
8ba0: 79 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 y")......
8bb0: 28 64 65 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 (delete-director
8bc0: 79 20 72 75 6e 2d 64 69 72 29 29 20 3b 3b 20 69 y run-dir)) ;; i
8bd0: 74 20 73 68 6f 75 6c 64 20 62 65 20 65 6d 70 74 t should be empt
8be0: 79 20 62 79 20 68 65 72 65 20 42 55 47 20 42 55 y by here BUG BU
8bf0: 47 2c 20 61 64 64 20 65 72 72 6f 72 20 63 61 74 G, add error cat
8c00: 63 68 0a 09 09 09 09 09 20 20 20 28 64 65 62 75 ch...... (debu
8c10: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
8c20: 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 : refusing to re
8c30: 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 move " run-dir "
8c40: 20 61 73 20 69 74 20 69 73 20 6e 65 69 74 68 65 as it is neithe
8c50: 72 20 61 20 73 79 6d 6c 69 6e 6b 20 6e 6f 72 20 r a symlink nor
8c60: 61 20 64 69 72 65 63 74 6f 72 79 22 29 0a 09 09 a directory")...
8c70: 09 09 09 20 20 20 29 29 29 29 0a 09 09 09 20 20 ... ))))....
8c80: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
8c90: 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 65 0 "WARNING: dire
8ca0: 63 74 6f 72 79 20 61 6c 72 65 61 64 79 20 72 65 ctory already re
8cb0: 6d 6f 76 65 64 20 22 20 72 75 6e 2d 64 69 72 29 moved " run-dir)
8cc0: 29 29 0a 09 09 09 28 28 73 65 74 2d 73 74 61 74 ))....((set-stat
8cd0: 65 2d 73 74 61 74 75 73 29 0a 09 09 09 20 28 64 e-status).... (d
8ce0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 4e ebug:print 2 "IN
8cf0: 46 4f 3a 20 6e 65 77 20 73 74 61 74 65 20 22 20 FO: new state "
8d00: 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 (car state-statu
8d10: 73 29 20 22 2c 20 6e 65 77 20 73 74 61 74 75 73 s) ", new status
8d20: 20 22 20 28 63 61 64 72 20 73 74 61 74 65 2d 73 " (cadr state-s
8d30: 74 61 74 75 73 29 29 0a 09 09 09 20 28 6f 70 65 tatus)).... (ope
8d40: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 n-run-close db:t
8d50: 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 est-set-state-st
8d60: 61 74 75 73 2d 62 79 2d 69 64 20 64 62 20 28 64 atus-by-id db (d
8d70: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
8d80: 73 74 29 20 28 63 61 72 20 73 74 61 74 65 2d 73 st) (car state-s
8d90: 74 61 74 75 73 29 28 63 61 64 72 20 73 74 61 74 tatus)(cadr stat
8da0: 65 2d 73 74 61 74 75 73 29 20 23 66 29 29 29 29 e-status) #f))))
8db0: 29 0a 09 09 20 20 74 65 73 74 73 29 29 29 0a 09 )... tests)))..
8dc0: 20 20 20 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 .. ;; remov
8dd0: 65 20 74 68 65 20 72 75 6e 20 69 66 20 7a 65 72 e the run if zer
8de0: 6f 20 74 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 o tests remain..
8df0: 20 20 20 28 69 66 20 28 65 71 3f 20 61 63 74 69 (if (eq? acti
8e00: 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 29 on 'remove-runs)
8e10: 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
8e20: 72 65 6d 74 65 73 74 73 20 28 64 62 3a 67 65 74 remtests (db:get
8e30: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 -tests-for-run d
8e40: 62 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d b (db:get-value-
8e50: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
8e60: 61 64 65 72 20 22 69 64 22 29 20 23 66 20 23 66 ader "id") #f #f
8e70: 20 27 28 22 44 45 4c 45 54 45 44 22 29 20 27 28 '("DELETED") '(
8e80: 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e 3a 20 23 "n/a") not-in: #
8e90: 74 29 29 29 0a 09 09 20 28 69 66 20 28 6e 75 6c t)))... (if (nul
8ea0: 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 3b 3b 20 l? remtests) ;;
8eb0: 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 20 72 65 no more tests re
8ec0: 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 maining... (
8ed0: 6c 65 74 2a 20 28 28 64 70 61 72 74 73 20 20 28 let* ((dparts (
8ee0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 73 string-split las
8ef0: 74 74 70 61 74 68 20 22 2f 22 29 29 0a 09 09 09 ttpath "/"))....
8f00: 20 20 20 20 28 72 75 6e 70 61 74 68 20 28 63 6f (runpath (co
8f10: 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 nc "/" (string-i
8f20: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 ntersperse .....
8f30: 09 09 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 ..(take dparts (
8f40: 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 - (length dparts
8f50: 29 20 31 29 29 0a 09 09 09 09 09 09 22 2f 22 29 ) 1))......."/")
8f60: 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 )))... (de
8f70: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d bug:print 1 "Rem
8f80: 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e oving run: " run
8f90: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
8fa0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
8fb0: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
8fc0: 61 6d 65 22 29 20 22 20 61 6e 64 20 72 65 6c 61 ame") " and rela
8fd0: 74 65 64 20 72 65 63 6f 72 64 22 29 0a 09 09 20 ted record")...
8fe0: 20 20 20 20 20 20 28 64 62 3a 64 65 6c 65 74 65 (db:delete
8ff0: 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a -run db run-id).
9000: 09 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 .. ;; This
9010: 20 69 73 20 61 20 70 72 65 74 74 79 20 67 6f 6f is a pretty goo
9020: 64 20 70 6c 61 63 65 20 74 6f 20 70 75 72 67 65 d place to purge
9030: 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 74 65 73 old DELETED tes
9040: 74 73 0a 09 09 20 20 20 20 20 20 20 28 64 62 3a ts... (db:
9050: 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 6f 72 delete-tests-for
9060: 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a -run db run-id).
9070: 09 09 20 20 20 20 20 20 20 28 64 62 3a 64 65 6c .. (db:del
9080: 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d ete-old-deleted-
9090: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 29 test-records db)
90a0: 0a 09 09 20 20 20 20 20 20 20 28 64 62 3a 73 65 ... (db:se
90b0: 74 2d 76 61 72 20 64 62 20 22 44 45 4c 45 54 45 t-var db "DELETE
90c0: 44 5f 54 45 53 54 53 22 20 28 63 75 72 72 65 6e D_TESTS" (curren
90d0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 t-seconds))...
90e0: 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 ;; need to
90f0: 66 69 67 75 72 65 20 6f 75 74 20 74 68 65 20 70 figure out the p
9100: 61 74 68 20 74 6f 20 74 68 65 20 72 75 6e 20 64 ath to the run d
9110: 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 ir and remove it
9120: 20 69 66 20 65 6d 70 74 79 0a 09 09 20 20 20 20 if empty...
9130: 20 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 ;; (if (nu
9140: 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 ll? (glob (conc
9150: 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a runpath "/*"))).
9160: 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 .. ;;
9170: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
9180: 20 20 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 ;; . (debug:p
9190: 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 rint 1 "Removing
91a0: 20 72 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 run dir " runpa
91b0: 74 68 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 th)... ;;
91c0: 09 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 . (system (conc
91d0: 22 72 6d 64 69 72 20 2d 70 20 22 20 72 75 6e 70 "rmdir -p " runp
91e0: 61 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 ath))))...
91f0: 20 29 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 ))))).. )).
9200: 20 72 75 6e 73 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d runs)))..;;====
9210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9250: 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 ==.;; Routines f
9260: 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 or manipulating
9270: 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d runs.;;=========
9280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
92b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
92c0: 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c ; Since many cal
92d0: 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 71 75 ls to a run requ
92e0: 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 68 20 ire pretty much
92f0: 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 20 0a the same setup .
9300: 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 72 20 ;; this wrapper
9310: 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 75 63 is used to reduc
9320: 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 69 6f e the replicatio
9330: 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 6e n of code.(defin
9340: 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 e (general-run-c
9350: 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 61 all switchname a
9360: 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 ction-desc proc)
9370: 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d . (let ((runnam
9380: 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 e (args:get-arg
9390: 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 09 28 74 ":runname"))..(t
93a0: 61 72 67 65 74 20 20 28 69 66 20 28 61 72 67 73 arget (if (args
93b0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
93c0: 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 t")... (args
93d0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
93e0: 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 t")... (args
93f0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
9400: 72 67 22 29 29 29 0a 09 28 74 68 31 20 20 20 20 rg")))..(th1
9410: 20 23 66 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a #f)). (cond.
9420: 20 20 20 20 20 28 28 6e 6f 74 20 74 61 72 67 65 ((not targe
9430: 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a t). (debug:
9440: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
9450: 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 Missing required
9460: 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 parameter for "
9470: 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 switchname ", y
9480: 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 ou must specify
9490: 74 68 65 20 74 61 72 67 65 74 20 77 69 74 68 20 the target with
94a0: 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 20 -target").
94b0: 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 (exit 3)). (
94c0: 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 (not runname).
94d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
94e0: 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 0 "ERROR: Missi
94f0: 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 61 ng required para
9500: 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 meter for " swit
9510: 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 chname ", you mu
9520: 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 72 st specify the r
9530: 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a 72 75 un name with :ru
9540: 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 29 0a nname runname").
9550: 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 0a (exit 3)).
9560: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
9570: 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 66 29 (let ((db #f)
9580: 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 29 29 .. (keys #f))
9590: 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 75 ..(if (not (setu
95a0: 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 p-for-run))..
95b0: 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 20 (begin ..
95c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
95d0: 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 2c Failed to setup,
95e0: 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 exiting")..
95f0: 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 73 (exit 1)))..(s
9600: 65 74 21 20 64 62 20 20 20 28 6f 70 65 6e 2d 64 et! db (open-d
9610: 62 29 29 0a 09 28 69 66 20 28 61 72 67 73 3a 67 b))..(if (args:g
9620: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
9630: 29 0a 09 20 20 20 20 28 73 65 72 76 65 72 3a 73 ).. (server:s
9640: 74 61 72 74 20 64 62 20 28 61 72 67 73 3a 67 65 tart db (args:ge
9650: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
9660: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
9670: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
9680: 67 20 22 2d 72 75 6e 61 6c 6c 22 29 0a 09 09 09 g "-runall")....
9690: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
96a0: 22 2d 72 75 6e 74 65 73 74 73 22 29 29 29 0a 09 "-runtests")))..
96b0: 09 28 73 65 72 76 65 72 3a 63 6c 69 65 6e 74 2d .(server:client-
96c0: 73 65 74 75 70 20 64 62 29 29 29 0a 09 28 73 65 setup db)))..(se
96d0: 74 21 20 6b 65 79 73 20 28 64 62 3a 67 65 74 2d t! keys (db:get-
96e0: 6b 65 79 73 20 64 62 29 29 0a 09 3b 3b 20 68 61 keys db))..;; ha
96f0: 76 65 20 65 6e 6f 75 67 68 20 74 6f 20 70 72 6f ve enough to pro
9700: 63 65 73 73 20 2d 74 61 72 67 65 74 20 6f 72 20 cess -target or
9710: 2d 72 65 71 74 61 72 67 20 68 65 72 65 0a 09 28 -reqtarg here..(
9720: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
9730: 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 20 20 "-reqtarg")..
9740: 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 63 6f 6e (let* ((runcon
9750: 66 69 67 66 20 28 63 6f 6e 63 20 20 2a 74 6f 70 figf (conc *top
9760: 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 path* "/runconfi
9770: 67 73 2e 63 6f 6e 66 69 67 22 29 29 20 3b 3b 20 gs.config")) ;;
9780: 44 4f 20 4e 4f 54 20 45 56 41 4c 55 41 54 45 20 DO NOT EVALUATE
9790: 41 4c 4c 20 0a 09 09 20 20 20 28 72 75 6e 63 6f ALL ... (runco
97a0: 6e 66 69 67 20 20 28 72 65 61 64 2d 63 6f 6e 66 nfig (read-conf
97b0: 69 67 20 72 75 6e 63 6f 6e 66 69 67 66 20 23 66 ig runconfigf #f
97c0: 20 23 66 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 #f environ-patt
97d0: 3a 20 23 66 29 29 29 20 0a 09 20 20 20 20 20 20 : #f))) ..
97e0: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
97f0: 72 65 66 2f 64 65 66 61 75 6c 74 20 72 75 6e 63 ref/default runc
9800: 6f 6e 66 69 67 20 28 61 72 67 73 3a 67 65 74 2d onfig (args:get-
9810: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
9820: 23 66 29 0a 09 09 20 20 28 6b 65 79 73 3a 74 61 #f)... (keys:ta
9830: 72 67 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 rget-set-args ke
9840: 79 73 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ys (args:get-arg
9850: 20 22 2d 72 65 71 74 61 72 67 22 29 20 61 72 67 "-reqtarg") arg
9860: 73 3a 61 72 67 2d 68 61 73 68 29 0a 09 09 20 20 s:arg-hash)...
9870: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 64 65 (begin... (de
9880: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
9890: 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 OR: [" (args:get
98a0: 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 -arg "-reqtarg")
98b0: 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e "] not found in
98c0: 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 " runconfigf)..
98d0: 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 . (sqlite3:fi
98e0: 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 09 20 20 nalize! db)...
98f0: 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 (exit 1))))..
9900: 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 (if (args:get
9910: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a -arg "-target").
9920: 09 09 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 ..(keys:target-s
9930: 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 et-args keys (ar
9940: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
9950: 67 65 74 22 20 61 72 67 73 3a 61 72 67 2d 68 61 get" args:arg-ha
9960: 73 68 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 sh) args:arg-has
9970: 68 29 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 h)))..(if (not (
9980: 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a car *configinfo*
9990: 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )).. (begin..
99a0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
99b0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 41 74 74 nt 0 "ERROR: Att
99c0: 65 6d 70 74 65 64 20 74 6f 20 22 20 61 63 74 69 empted to " acti
99d0: 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 20 72 75 on-desc " but ru
99e0: 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 20 66 69 n area config fi
99f0: 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 29 0a 09 le not found")..
9a00: 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a (exit 1)).
9a10: 09 20 20 20 20 3b 3b 20 45 78 74 72 61 63 74 20 . ;; Extract
9a20: 6f 75 74 20 73 74 75 66 66 20 6e 65 65 64 65 64 out stuff needed
9a30: 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 in most or many
9a40: 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b 3b 20 68 calls.. ;; h
9a50: 65 72 65 20 74 68 65 6e 20 63 61 6c 6c 20 70 72 ere then call pr
9a60: 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 oc.. (let* ((
9a70: 6b 65 79 6e 61 6d 65 73 20 20 20 28 6d 61 70 20 keynames (map
9a80: 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d key:get-fieldnam
9a90: 65 20 6b 65 79 73 29 29 0a 09 09 20 20 20 28 6b e keys))... (k
9aa0: 65 79 76 61 6c 6c 73 74 20 20 28 6b 65 79 73 2d eyvallst (keys-
9ab0: 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 20 23 74 >vallist keys #t
9ac0: 29 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 ))).. (proc
9ad0: 20 64 62 20 74 61 72 67 65 74 20 72 75 6e 6e 61 db target runna
9ae0: 6d 65 20 6b 65 79 73 20 6b 65 79 6e 61 6d 65 73 me keys keynames
9af0: 20 6b 65 79 76 61 6c 6c 73 74 29 29 29 0a 09 28 keyvallst)))..(
9b00: 69 66 20 74 68 31 20 28 74 68 72 65 61 64 2d 6a if th1 (thread-j
9b10: 6f 69 6e 21 20 74 68 31 29 29 0a 09 28 73 71 6c oin! th1))..(sql
9b20: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
9b30: 62 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f b)..(set! *didso
9b40: 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 29 mething* #t)))))
9b50: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
9b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c ===========.;; L
9ba0: 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a ock/unlock runs.
9bb0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
9bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9bf0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
9c00: 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c e (runs:handle-l
9c10: 6f 63 6b 69 6e 67 20 64 62 20 74 61 72 67 65 74 ocking db target
9c20: 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 20 6c 6f keys runname lo
9c30: 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a ck unlock user).
9c40: 20 20 28 6c 65 74 2a 20 28 28 72 75 6e 64 61 74 (let* ((rundat
9c50: 20 20 20 28 72 75 6e 73 3a 67 65 74 2d 72 75 6e (runs:get-run
9c60: 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 s-by-patt db key
9c70: 73 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 28 68 s runname)).. (h
9c80: 65 61 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d eader (vector-
9c90: 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 ref rundat 0))..
9ca0: 20 28 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 (runs (vect
9cb0: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 or-ref rundat 1)
9cc0: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
9cd0: 20 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 (lambda (run)..
9ce0: 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 .(let ((run-id (
9cf0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
9d00: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
9d10: 72 20 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 r "id")))... (i
9d20: 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 f (or lock....
9d30: 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 (and unlock....
9d40: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
9d50: 09 20 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 . (print "Do you
9d60: 20 72 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 really wish to
9d70: 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e unlock run " run
9d80: 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 -id "?\n y/n:
9d90: 22 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 ")..... (equal?
9da0: 22 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 "y" (read-line))
9db0: 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 62 3a )))... (db:
9dc0: 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 lock/unlock-run
9dd0: 64 62 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 db run-id lock u
9de0: 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 20 nlock user)...
9df0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9e00: 20 30 20 22 49 4e 46 4f 3a 20 53 6b 69 70 70 69 0 "INFO: Skippi
9e10: 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f ng lock/unlock o
9e20: 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 n " run-id))))..
9e30: 20 20 20 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b runs))).;;
9e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e80: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 ======.;; Rollup
9e90: 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d runs.;;========
9ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
9ee0: 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 74 65 ;; Update the te
9ef0: 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 66 6f st_meta table fo
9f00: 72 20 74 68 69 73 20 74 65 73 74 0a 28 64 65 66 r this test.(def
9f10: 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 61 74 65 ine (runs:update
9f20: 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 -test_meta db te
9f30: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e st-name test-con
9f40: 66 29 0a 20 20 28 6c 65 74 20 28 28 63 75 72 72 f). (let ((curr
9f50: 72 65 63 6f 72 64 20 28 64 62 3a 74 65 73 74 6d record (db:testm
9f60: 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 64 20 64 eta-get-record d
9f70: 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 b test-name))).
9f80: 20 20 20 28 69 66 20 28 6e 6f 74 20 63 75 72 72 (if (not curr
9f90: 72 65 63 6f 72 64 29 0a 09 28 62 65 67 69 6e 0a record)..(begin.
9fa0: 09 20 20 28 73 65 74 21 20 63 75 72 72 72 65 63 . (set! currrec
9fb0: 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 74 6f 72 ord (make-vector
9fc0: 20 31 30 20 23 66 29 29 0a 09 20 20 28 64 62 3a 10 #f)).. (db:
9fd0: 74 65 73 74 6d 65 74 61 2d 61 64 64 2d 72 65 63 testmeta-add-rec
9fe0: 6f 72 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 ord db test-name
9ff0: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
a000: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
a010: 28 6b 65 79 29 0a 20 20 20 20 20 20 20 28 6c 65 (key). (le
a020: 74 2a 20 28 28 69 64 78 20 28 63 61 64 72 20 6b t* ((idx (cadr k
a030: 65 79 29 29 0a 09 20 20 20 20 20 20 28 66 6c 64 ey)).. (fld
a040: 20 28 63 61 72 20 20 6b 65 79 29 29 0a 09 20 20 (car key))..
a050: 20 20 20 20 28 76 61 6c 20 28 63 6f 6e 66 69 67 (val (config
a060: 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e -lookup test-con
a070: 66 20 22 74 65 73 74 5f 6d 65 74 61 22 20 66 6c f "test_meta" fl
a080: 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 62 75 67 d))).. ;; (debug
a090: 3a 70 72 69 6e 74 20 35 20 22 69 64 78 3a 20 22 :print 5 "idx: "
a0a0: 20 69 64 78 20 22 20 66 6c 64 3a 20 22 20 66 6c idx " fld: " fl
a0b0: 64 20 22 20 76 61 6c 3a 20 22 20 76 61 6c 29 0a d " val: " val).
a0c0: 09 20 28 69 66 20 28 61 6e 64 20 76 61 6c 20 28 . (if (and val (
a0d0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 76 65 63 not (equal? (vec
a0e0: 74 6f 72 2d 72 65 66 20 63 75 72 72 72 65 63 6f tor-ref currreco
a0f0: 72 64 20 69 64 78 29 20 76 61 6c 29 29 29 0a 09 rd idx) val)))..
a100: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
a110: 20 20 20 20 28 70 72 69 6e 74 20 22 55 70 64 61 (print "Upda
a120: 74 69 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 ting " test-name
a130: 20 22 20 22 20 66 6c 64 20 22 20 74 6f 20 22 20 " " fld " to "
a140: 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 64 62 val).. (db
a150: 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 61 74 65 :testmeta-update
a160: 2d 66 69 65 6c 64 20 64 62 20 74 65 73 74 2d 6e -field db test-n
a170: 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 29 29 29 ame fld val)))))
a180: 0a 20 20 20 20 20 27 28 28 22 61 75 74 68 6f 72 . '(("author
a190: 22 20 32 29 28 22 6f 77 6e 65 72 22 20 33 29 28 " 2)("owner" 3)(
a1a0: 22 64 65 73 63 72 69 70 74 69 6f 6e 22 20 34 29 "description" 4)
a1b0: 28 22 72 65 76 69 65 77 65 64 22 20 35 29 28 22 ("reviewed" 5)("
a1c0: 74 61 67 73 22 20 39 29 29 29 29 29 0a 0a 3b 3b tags" 9)))))..;;
a1d0: 20 55 70 64 61 74 65 20 74 65 73 74 5f 6d 65 74 Update test_met
a1e0: 61 20 66 6f 72 20 61 6c 6c 20 74 65 73 74 73 0a a for all tests.
a1f0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 (define (runs:up
a200: 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 5f 6d 65 date-all-test_me
a210: 74 61 20 64 62 29 0a 20 20 28 6c 65 74 20 28 28 ta db). (let ((
a220: 74 65 73 74 2d 6e 61 6d 65 73 20 28 67 65 74 2d test-names (get-
a230: 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 74 73 29 all-legal-tests)
a240: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
a250: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
a260: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 20 20 20 test-name).
a270: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 70 (let* ((test-p
a280: 61 74 68 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f ath (conc *to
a290: 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 ppath* "/tests/"
a2a0: 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 test-name))..
a2b0: 20 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 69 67 (test-config
a2c0: 66 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 f (conc test-pat
a2d0: 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 h "/testconfig")
a2e0: 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 65 78 ).. (testex
a2f0: 69 73 74 73 20 20 20 28 61 6e 64 20 28 66 69 6c ists (and (fil
a300: 65 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 63 e-exists? test-c
a310: 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d 72 65 61 onfigf)(file-rea
a320: 64 2d 61 63 63 65 73 73 3f 20 74 65 73 74 2d 63 d-access? test-c
a330: 6f 6e 66 69 67 66 29 29 29 0a 09 20 20 20 20 20 onfigf)))..
a340: 20 3b 3b 20 72 65 61 64 20 63 6f 6e 66 69 67 73 ;; read configs
a350: 20 77 69 74 68 20 74 72 69 63 6b 73 20 74 75 72 with tricks tur
a360: 6e 65 64 20 6f 66 66 20 28 69 2e 65 2e 20 6e 6f ned off (i.e. no
a370: 20 73 79 73 74 65 6d 29 0a 09 20 20 20 20 20 20 system)..
a380: 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 28 69 (test-conf (i
a390: 66 20 74 65 73 74 65 78 69 73 74 73 20 28 72 65 f testexists (re
a3a0: 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 63 ad-config test-c
a3b0: 6f 6e 66 69 67 66 20 23 66 20 23 66 29 28 6d 61 onfigf #f #f)(ma
a3c0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
a3d0: 29 0a 09 20 28 72 75 6e 73 3a 75 70 64 61 74 65 ).. (runs:update
a3e0: 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 65 -test_meta db te
a3f0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e st-name test-con
a400: 66 29 29 29 0a 20 20 20 20 20 74 65 73 74 2d 6e f))). test-n
a410: 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 54 68 69 73 ames)))..;; This
a420: 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 6c 79 20 could probably
a430: 62 65 20 72 65 66 61 63 74 6f 72 65 64 20 69 6e be refactored in
a440: 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 78 20 71 to one complex q
a450: 75 65 72 79 20 2e 2e 2e 0a 28 64 65 66 69 6e 65 uery ....(define
a460: 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 (runs:rollup-ru
a470: 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c n db keys keyval
a480: 6c 73 74 20 72 75 6e 6e 61 6d 65 20 75 73 65 72 lst runname user
a490: 29 20 3b 3b 20 77 61 73 20 74 61 72 67 65 74 2c ) ;; was target,
a4a0: 20 6e 6f 77 20 6b 65 79 76 61 6c 6c 73 74 0a 20 now keyvallst.
a4b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
a4c0: 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 72 75 6e "runs:rollup-run
a4d0: 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 , keys: " keys "
a4e0: 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 keyvallst: " ke
a4f0: 79 76 61 6c 6c 73 74 20 22 20 3a 72 75 6e 6e 61 yvallst " :runna
a500: 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 me " runname " u
a510: 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 ser: " user). (
a520: 6c 65 74 2a 20 28 3b 20 28 6b 65 79 76 61 6c 6c let* (; (keyvall
a530: 6c 73 74 20 20 20 20 20 20 28 6b 65 79 73 3a 74 lst (keys:t
a540: 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 arget->keyval ke
a550: 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 28 6e ys target)).. (n
a560: 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 20 20 28 ew-run-id (
a570: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
a580: 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c n db keys keyval
a590: 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 lst runname "new
a5a0: 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 0a 09 " "n/a" user))..
a5b0: 20 28 70 72 65 76 2d 74 65 73 74 73 20 20 20 20 (prev-tests
a5c0: 20 20 28 74 65 73 74 3a 67 65 74 2d 6d 61 74 63 (test:get-matc
a5d0: 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 2d 74 65 hing-previous-te
a5e0: 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 73 20 64 st-run-records d
a5f0: 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 22 b new-run-id "%"
a600: 20 22 25 22 29 29 0a 09 20 28 63 75 72 72 2d 74 "%")).. (curr-t
a610: 65 73 74 73 20 20 20 20 20 20 28 64 62 3a 67 65 ests (db:ge
a620: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
a630: 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 22 25 db new-run-id "%
a640: 22 20 22 25 22 20 27 28 29 20 27 28 29 29 29 0a " "%" '() '())).
a650: 09 20 28 63 75 72 72 2d 74 65 73 74 73 2d 68 61 . (curr-tests-ha
a660: 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 sh (make-hash-ta
a670: 62 6c 65 29 29 29 0a 20 20 20 20 28 64 62 3a 75 ble))). (db:u
a680: 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e 74 5f pdate-run-event_
a690: 74 69 6d 65 20 64 62 20 6e 65 77 2d 72 75 6e 2d time db new-run-
a6a0: 69 64 29 0a 20 20 20 20 3b 3b 20 69 6e 64 65 78 id). ;; index
a6b0: 20 74 68 65 20 61 6c 72 65 61 64 79 20 73 61 76 the already sav
a6c0: 65 64 20 74 65 73 74 73 20 62 79 20 74 65 73 74 ed tests by test
a6d0: 6e 61 6d 65 20 61 6e 64 20 69 74 65 6d 64 61 74 name and itemdat
a6e0: 20 69 6e 20 63 75 72 72 2d 74 65 73 74 73 2d 68 in curr-tests-h
a6f0: 61 73 68 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ash. (for-eac
a700: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
a710: 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 testdat).
a720: 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 (let* ((testname
a730: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 (db:test-get-t
a740: 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 74 29 estname testdat)
a750: 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d 2d 70 ).. (item-p
a760: 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
a770: 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 64 -item-path testd
a780: 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 75 6c at)).. (ful
a790: 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 l-name (conc tes
a7a0: 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 tname "/" item-p
a7b0: 61 74 68 29 29 29 0a 09 20 28 68 61 73 68 2d 74 ath))).. (hash-t
a7c0: 61 62 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 able-set! curr-t
a7d0: 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e ests-hash full-n
a7e0: 61 6d 65 20 74 65 73 74 64 61 74 29 29 29 0a 20 ame testdat))).
a7f0: 20 20 20 20 63 75 72 72 2d 74 65 73 74 73 29 0a curr-tests).
a800: 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 4e 6f 6e ;; NOPE: Non
a810: 2d 6f 70 74 69 6d 61 6c 20 61 70 70 72 6f 61 63 -optimal approac
a820: 68 2e 20 54 72 79 20 74 68 69 73 20 69 6e 73 74 h. Try this inst
a830: 65 61 64 2e 0a 20 20 20 20 3b 3b 20 20 20 31 2e ead.. ;; 1.
a840: 20 74 65 73 74 73 20 61 72 65 20 72 65 63 65 69 tests are recei
a850: 76 65 64 20 69 6e 20 61 20 6c 69 73 74 2c 20 6d ved in a list, m
a860: 6f 73 74 20 72 65 63 65 6e 74 20 66 69 72 73 74 ost recent first
a870: 0a 20 20 20 20 3b 3b 20 20 20 32 2e 20 72 65 70 . ;; 2. rep
a880: 6c 61 63 65 20 74 68 65 20 72 6f 6c 6c 75 70 20 lace the rollup
a890: 74 65 73 74 20 77 69 74 68 20 74 68 65 20 6e 65 test with the ne
a8a0: 77 20 2a 61 6c 77 61 79 73 2a 0a 20 20 20 20 28 w *always*. (
a8b0: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
a8c0: 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 74 29 lambda (testdat)
a8d0: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
a8e0: 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 testname (db:te
a8f0: 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 st-get-testname
a900: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
a910: 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 3a (item-path (db:
a920: 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 test-get-item-pa
a930: 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 th testdat))..
a940: 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 (full-name (
a950: 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 22 2f conc testname "/
a960: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 " item-path))..
a970: 20 20 20 20 20 28 70 72 65 76 2d 74 65 73 74 2d (prev-test-
a980: 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d dat (hash-table-
a990: 72 65 66 2f 64 65 66 61 75 6c 74 20 63 75 72 72 ref/default curr
a9a0: 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c -tests-hash full
a9b0: 2d 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 20 20 -name #f))..
a9c0: 20 20 28 74 65 73 74 2d 73 74 65 70 73 20 20 20 (test-steps
a9d0: 20 20 20 28 64 62 3a 67 65 74 2d 73 74 65 70 73 (db:get-steps
a9e0: 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 28 64 62 -for-test db (db
a9f0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
aa00: 74 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 tdat))).. (
aa10: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 new-test-record
aa20: 23 66 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 #f)).. ;; replac
aa30: 65 20 74 68 65 73 65 20 77 69 74 68 20 69 6e 73 e these with ins
aa40: 65 72 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 ert ... select..
aa50: 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a (apply sqlite3:
aa60: 65 78 65 63 75 74 65 20 0a 09 09 64 62 20 0a 09 execute ...db ..
aa70: 09 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f .(conc "INSERT O
aa80: 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 R REPLACE INTO t
aa90: 65 73 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 ests (run_id,tes
aaa0: 74 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 tname,state,stat
aab0: 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f us,event_time,ho
aac0: 73 74 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 st,cpuload,diskf
aad0: 72 65 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 ree,uname,rundir
aae0: 2c 69 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 ,item_path,run_d
aaf0: 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f uration,final_lo
ab00: 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 gf,comment) "...
ab10: 20 20 20 20 20 20 22 56 41 4c 55 45 53 20 28 3f "VALUES (?
ab20: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
ab30: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 ,?,?,?,?,?);")..
ab40: 09 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 .new-run-id (cdd
ab50: 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 r (vector->list
ab60: 74 65 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 testdat))).. (se
ab70: 74 21 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 t! new-testdat (
ab80: 63 61 72 20 28 64 62 3a 67 65 74 2d 74 65 73 74 car (db:get-test
ab90: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 s-for-run db new
aba0: 2d 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 -run-id testname
abb0: 20 69 74 65 6d 2d 70 61 74 68 20 27 28 29 20 27 item-path '() '
abc0: 28 29 29 29 29 0a 09 20 28 68 61 73 68 2d 74 61 ()))).. (hash-ta
abd0: 62 6c 65 2d 73 65 74 21 20 63 75 72 72 2d 74 65 ble-set! curr-te
abe0: 73 74 73 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 sts-hash full-na
abf0: 6d 65 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 me new-testdat)
ac00: 3b 3b 20 74 68 69 73 20 63 6f 75 6c 64 20 62 65 ;; this could be
ac10: 20 63 6f 6e 66 75 73 69 6e 67 2c 20 77 68 69 63 confusing, whic
ac20: 68 20 72 65 63 6f 72 64 20 73 68 6f 75 6c 64 20 h record should
ac30: 67 6f 20 69 6e 74 6f 20 74 68 65 20 6c 6f 6f 6b go into the look
ac40: 75 70 20 74 61 62 6c 65 3f 0a 09 20 3b 3b 20 4e up table?.. ;; N
ac50: 6f 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 ow duplicate the
ac60: 20 74 65 73 74 20 73 74 65 70 73 0a 09 20 28 64 test steps.. (d
ac70: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f ebug:print 4 "Co
ac80: 70 79 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e pying records in
ac90: 20 74 65 73 74 5f 73 74 65 70 73 20 66 72 6f 6d test_steps from
aca0: 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 test_id=" (db:t
acb0: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 est-get-id testd
acc0: 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 3a 74 at) " to " (db:t
acd0: 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 est-get-id new-t
ace0: 65 73 74 64 61 74 29 29 0a 09 20 28 73 71 6c 69 estdat)).. (sqli
acf0: 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 te3:execute ..
ad00: 64 62 20 0a 09 20 20 28 63 6f 6e 63 20 22 49 4e db .. (conc "IN
ad10: 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 SERT OR REPLACE
ad20: 49 4e 54 4f 20 74 65 73 74 5f 73 74 65 70 73 20 INTO test_steps
ad30: 28 74 65 73 74 5f 69 64 2c 73 74 65 70 6e 61 6d (test_id,stepnam
ad40: 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 e,state,status,e
ad50: 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e vent_time,commen
ad60: 74 29 20 22 0a 09 09 22 53 45 4c 45 43 54 20 22 t) "..."SELECT "
ad70: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
ad80: 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 2c new-testdat) ",
ad90: 73 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 stepname,state,s
ada0: 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 tatus,event_time
adb0: 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 ,comment FROM te
adc0: 73 74 5f 73 74 65 70 73 20 57 48 45 52 45 20 74 st_steps WHERE t
add0: 65 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 28 est_id=?;").. (
ade0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
adf0: 65 73 74 64 61 74 29 29 0a 09 20 3b 3b 20 4e 6f estdat)).. ;; No
ae00: 77 20 64 75 70 6c 69 63 61 74 65 20 74 68 65 20 w duplicate the
ae10: 74 65 73 74 20 64 61 74 61 0a 09 20 28 64 65 62 test data.. (deb
ae20: 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 ug:print 4 "Copy
ae30: 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 ing records in t
ae40: 65 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 est_data from te
ae50: 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
ae60: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
ae70: 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
ae80: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
ae90: 64 61 74 29 29 0a 09 20 28 73 71 6c 69 74 65 33 dat)).. (sqlite3
aea0: 3a 65 78 65 63 75 74 65 20 0a 09 20 20 64 62 20 :execute .. db
aeb0: 0a 09 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 .. (conc "INSER
aec0: 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
aed0: 4f 20 74 65 73 74 5f 64 61 74 61 20 28 74 65 73 O test_data (tes
aee0: 74 5f 69 64 2c 63 61 74 65 67 6f 72 79 2c 76 61 t_id,category,va
aef0: 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 riable,value,exp
af00: 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c ected,tol,units,
af10: 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 22 53 45 comment) "..."SE
af20: 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d LECT " (db:test-
af30: 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
af40: 61 74 29 20 22 2c 63 61 74 65 67 6f 72 79 2c 76 at) ",category,v
af50: 61 72 69 61 62 6c 65 2c 76 61 6c 75 65 2c 65 78 ariable,value,ex
af60: 70 65 63 74 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 pected,tol,units
af70: 2c 63 6f 6d 6d 65 6e 74 20 46 52 4f 4d 20 74 65 ,comment FROM te
af80: 73 74 5f 64 61 74 61 20 57 48 45 52 45 20 74 65 st_data WHERE te
af90: 73 74 5f 69 64 3d 3f 3b 22 29 0a 09 20 20 28 64 st_id=?;").. (d
afa0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
afb0: 73 74 64 61 74 29 29 0a 09 20 29 29 0a 20 20 20 stdat)).. )).
afc0: 20 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 0a prev-tests))).
afd0: 09 20 0a 20 20 20 20 20 0a . . .