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 0a 28 64 65 66 69 6e 65 20 28 73 65 74 2d ...(define (set-
0870: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
0880: 73 20 64 62 20 72 75 6e 2d 69 64 29 0a 20 20 28 s db run-id). (
0890: 6c 65 74 20 28 28 6b 65 79 73 20 28 72 64 62 3a let ((keys (rdb:
08a0: 67 65 74 2d 6b 65 79 73 20 64 62 29 29 29 0a 20 get-keys db))).
08b0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
08c0: 6d 62 64 61 20 28 6b 65 79 29 0a 09 09 28 73 71 mbda (key)...(sq
08d0: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
08e0: 6f 77 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 76 ow... (lambda (v
08f0: 61 6c 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a al)... (debug:
0900: 70 72 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 print 2 "setenv
0910: 22 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 " (key:get-field
0920: 6e 61 6d 65 20 6b 65 79 29 20 22 20 22 20 76 61 name key) " " va
0930: 6c 29 0a 09 09 20 20 20 28 73 65 74 65 6e 76 20 l)... (setenv
0940: 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 (key:get-fieldna
0950: 6d 65 20 6b 65 79 29 20 76 61 6c 29 29 0a 09 09 me key) val))...
0960: 20 64 62 20 0a 09 09 20 28 63 6f 6e 63 20 22 53 db ... (conc "S
0970: 45 4c 45 43 54 20 22 20 28 6b 65 79 3a 67 65 74 ELECT " (key:get
0980: 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 -fieldname key)
0990: 22 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 " FROM runs WHER
09a0: 45 20 69 64 3d 3f 3b 22 29 0a 09 09 20 72 75 6e E id=?;")... run
09b0: 2d 69 64 29 29 0a 09 20 20 20 20 20 20 6b 65 79 -id)).. key
09c0: 73 29 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 s). (alist->e
09d0: 6e 76 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 nv-vars (hash-ta
09e0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
09f0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 *configdat* "env
0a00: 2d 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 29 -override" '()))
0a10: 0a 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 . ;; Lets use
0a20: 20 74 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f this as an oppo
0a30: 72 74 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d rtunity to put M
0a40: 54 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 T_RUNNAME in the
0a50: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 environment.
0a60: 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 (sqlite3:for-ea
0a70: 63 68 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d ch-row. (lam
0a80: 62 64 61 20 28 72 75 6e 6e 61 6d 65 29 0a 20 20 bda (runname).
0a90: 20 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 (setenv "MT
0aa0: 5f 52 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d _RUNNAME" runnam
0ab0: 65 29 29 0a 20 20 20 20 20 64 62 0a 20 20 20 20 e)). db.
0ac0: 20 22 53 45 4c 45 43 54 20 72 75 6e 6e 61 6d 65 "SELECT runname
0ad0: 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 FROM runs WHERE
0ae0: 20 69 64 3d 3f 3b 22 0a 20 20 20 20 20 72 75 6e id=?;". run
0af0: 2d 69 64 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 -id). ))..(de
0b00: 66 69 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 fine (set-item-e
0b10: 6e 76 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 nv-vars itemdat)
0b20: 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 . (for-each (la
0b30: 6d 62 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 mbda (item)..
0b40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
0b50: 32 20 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 2 "setenv " (car
0b60: 20 69 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 item) " " (cadr
0b70: 20 69 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 item)).. (
0b80: 73 65 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d setenv (car item
0b90: 29 20 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a ) (cadr item))).
0ba0: 09 20 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a . itemdat))..
0bb0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 (define (runs:ca
0bc0: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
0bd0: 20 64 62 20 74 65 73 74 2d 72 65 63 6f 72 64 29 db test-record)
0be0: 0a 20 20 28 6c 65 74 2a 20 28 28 74 63 6f 6e 66 . (let* ((tconf
0bf0: 69 67 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ig
0c00: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
0c10: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
0c20: 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ig test-record))
0c30: 0a 09 20 28 6a 6f 62 67 72 6f 75 70 20 20 20 20 .. (jobgroup
0c40: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
0c50: 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 fig-lookup tconf
0c60: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
0c70: 22 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 " "jobgroup"))..
0c80: 20 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 (num-running
0c90: 20 20 20 20 20 20 20 20 20 20 28 64 62 3a 67 65 (db:ge
0ca0: 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 t-count-tests-ru
0cb0: 6e 6e 69 6e 67 20 64 62 29 29 0a 09 20 28 6e 75 nning db)).. (nu
0cc0: 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 m-running-in-job
0cd0: 67 72 6f 75 70 20 28 64 62 3a 67 65 74 2d 63 6f group (db:get-co
0ce0: 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e unt-tests-runnin
0cf0: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 64 62 g-in-jobgroup db
0d00: 20 6a 6f 62 67 72 6f 75 70 29 29 0a 09 20 28 6d jobgroup)).. (m
0d10: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
0d20: 62 73 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c bs (config-l
0d30: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
0d40: 2a 20 22 73 65 74 75 70 22 20 20 20 20 20 22 6d * "setup" "m
0d50: 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f ax_concurrent_jo
0d60: 62 73 22 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f bs")).. (job-gro
0d70: 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 up-limit
0d80: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
0d90: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 *configdat* "job
0da0: 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 groups" jobgroup
0db0: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
0dc0: 72 69 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e 63 rint 2 "max-conc
0dd0: 75 72 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d urrent-jobs: " m
0de0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
0df0: 62 73 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e bs ", num-runnin
0e00: 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 g: " num-running
0e10: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
0e20: 65 71 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 69 eq? 0 *globalexi
0e30: 74 73 74 61 74 75 73 2a 29 29 0a 09 23 66 0a 09 tstatus*))..#f..
0e40: 28 6c 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d 72 (let ((can-not-r
0e50: 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 09 un-more (cond...
0e60: 09 09 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f 6e .. ;; if max-con
0e70: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 20 current-jobs is
0e80: 73 65 74 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 set and the numb
0e90: 65 72 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 72 er running is gr
0ea0: 65 61 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 74 eater ..... ;; t
0eb0: 68 61 6e 20 69 74 20 74 68 61 6e 20 63 61 6e 6e han it than cann
0ec0: 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 ot run more jobs
0ed0: 0a 09 09 09 09 20 28 28 61 6e 64 20 6d 61 78 2d ..... ((and max-
0ee0: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 0a concurrent-jobs.
0ef0: 09 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 .... (stri
0f00: 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 ng->number max-c
0f10: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a oncurrent-jobs).
0f20: 09 09 09 09 20 20 20 20 20 20 20 28 3e 3d 20 6e .... (>= n
0f30: 75 6d 2d 72 75 6e 6e 69 6e 67 20 28 73 74 72 69 um-running (stri
0f40: 6e 67 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 ng->number max-c
0f50: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 oncurrent-jobs))
0f60: 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 )..... (debug:p
0f70: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
0f80: 20 4d 61 78 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 Max running job
0f90: 73 20 65 78 63 65 65 64 65 64 2c 20 63 75 72 72 s exceeded, curr
0fa0: 65 6e 74 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 ent number runni
0fb0: 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e ng: " num-runnin
0fc0: 67 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 22 g ...... "
0fd0: 2c 20 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 , max_concurrent
0fe0: 5f 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e _jobs: " max-con
0ff0: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 current-jobs)...
1000: 09 09 20 20 23 74 29 0a 09 09 09 09 20 3b 3b 20 .. #t)..... ;;
1010: 69 66 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d if job-group-lim
1020: 69 74 20 69 73 20 73 65 74 20 61 6e 64 20 6e 75 it is set and nu
1030: 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 69 6e 20 mber of jobs in
1040: 74 68 65 20 67 72 6f 75 70 20 69 73 20 67 72 65 the group is gre
1050: 61 74 65 72 0a 09 09 09 09 20 3b 3b 20 74 68 61 ater..... ;; tha
1060: 6e 20 74 68 65 20 6c 69 6d 69 74 20 74 68 65 6e n the limit then
1070: 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 cannot run more
1080: 20 6a 6f 62 73 20 6f 66 20 74 68 69 73 20 6b 69 jobs of this ki
1090: 6e 64 0a 09 09 09 09 20 28 28 61 6e 64 20 6a 6f nd..... ((and jo
10a0: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 0a 09 09 b-group-limit...
10b0: 09 09 20 20 20 20 20 20 20 28 3e 3d 20 6e 75 6d .. (>= num
10c0: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
10d0: 72 6f 75 70 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c roup job-group-l
10e0: 69 6d 69 74 29 29 0a 09 09 09 09 20 20 28 64 65 imit))..... (de
10f0: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 bug:print 1 "WAR
1100: 4e 49 4e 47 3a 20 6e 75 6d 62 65 72 20 6f 66 20 NING: number of
1110: 6a 6f 62 73 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 jobs " num-runni
1120: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 0a ng-in-jobgroup .
1130: 09 09 09 09 09 20 20 20 20 20 20 20 22 20 69 6e ..... " in
1140: 20 22 20 6a 6f 62 67 72 6f 75 70 20 22 20 65 78 " jobgroup " ex
1150: 63 65 65 64 65 64 2c 20 77 69 6c 6c 20 6e 6f 74 ceeded, will not
1160: 20 72 75 6e 20 22 20 28 74 65 73 74 73 3a 74 65 run " (tests:te
1170: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
1180: 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 name test-record
1190: 29 29 0a 09 09 09 09 20 20 23 74 29 0a 09 09 09 ))..... #t)....
11a0: 09 20 28 65 6c 73 65 20 23 66 29 29 29 29 0a 09 . (else #f))))..
11b0: 20 20 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 (not can-not-r
11c0: 75 6e 2d 6d 6f 72 65 29 29 29 29 29 0a 0a 3b 3b un-more)))))..;;
11d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1210: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 65 77 20 6d 65 ======.;; New me
1220: 74 68 6f 64 6f 6c 6f 67 79 2e 20 54 68 65 73 65 thodology. These
1230: 20 72 6f 75 74 69 6e 65 73 20 77 69 6c 6c 20 72 routines will r
1240: 65 70 6c 61 63 65 20 74 68 65 20 61 62 6f 76 65 eplace the above
1250: 20 69 6e 20 74 69 6d 65 2e 20 46 6f 72 0a 3b 3b in time. For.;;
1260: 20 6e 6f 77 20 74 68 65 20 63 6f 64 65 20 69 73 now the code is
1270: 20 64 75 70 6c 69 63 61 74 65 64 2e 20 54 68 69 duplicated. Thi
1280: 73 20 73 74 75 66 66 20 69 73 20 69 6e 69 74 69 s stuff is initi
1290: 61 6c 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 ally used in the
12a0: 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 20 62 61 73 65 monitor.;; base
12b0: 64 20 63 6f 64 65 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d d code..;;======
12c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1300: 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 ..;; register a
1310: 74 65 73 74 20 72 75 6e 20 77 69 74 68 20 74 68 test run with th
1320: 65 20 64 62 0a 28 64 65 66 69 6e 65 20 28 72 75 e db.(define (ru
1330: 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 ns:register-run
1340: 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 db keys keyvalls
1350: 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 t runname state
1360: 73 74 61 74 75 73 20 75 73 65 72 29 0a 20 20 28 status user). (
1370: 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 72 debug:print 3 "r
1380: 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e uns:register-run
1390: 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 , keys: " keys "
13a0: 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 keyvallst: " ke
13b0: 79 76 61 6c 6c 73 74 20 22 20 72 75 6e 6e 61 6d yvallst " runnam
13c0: 65 3a 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 73 e: " runname " s
13d0: 74 61 74 65 3a 20 22 20 73 74 61 74 65 20 22 20 tate: " state "
13e0: 73 74 61 74 75 73 3a 20 22 20 73 74 61 74 75 73 status: " status
13f0: 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 " user: " user)
1400: 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 74 . (let* ((keyst
1410: 72 20 20 20 20 28 6b 65 79 73 2d 3e 6b 65 79 73 r (keys->keys
1420: 74 72 20 6b 65 79 73 29 29 0a 09 20 28 63 6f 6d tr keys)).. (com
1430: 6d 61 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c ma (if (> (l
1440: 65 6e 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 ength keys) 0) "
1450: 2c 22 20 22 22 29 29 0a 09 20 28 61 6e 64 73 74 ," "")).. (andst
1460: 72 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e r (if (> (len
1470: 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 20 41 gth keys) 0) " A
1480: 4e 44 20 22 20 22 22 29 29 0a 09 20 28 76 61 6c ND " "")).. (val
1490: 73 6c 6f 74 73 20 20 28 6b 65 79 73 2d 3e 76 61 slots (keys->va
14a0: 6c 73 6c 6f 74 73 20 6b 65 79 73 29 29 20 3b 3b lslots keys)) ;;
14b0: 20 3f 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 6b 65 ?,?,? ..... (ke
14c0: 79 76 61 6c 73 20 20 20 28 6d 61 70 20 63 61 64 yvals (map cad
14d0: 72 20 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 20 r keyvallst))..
14e0: 28 61 6c 6c 76 61 6c 73 20 20 20 28 61 70 70 65 (allvals (appe
14f0: 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 nd (list runname
1500: 20 73 74 61 74 65 20 73 74 61 74 75 73 20 75 73 state status us
1510: 65 72 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 20 er) keyvals))..
1520: 28 71 72 79 76 61 6c 73 20 20 20 28 61 70 70 65 (qryvals (appe
1530: 6e 64 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 nd (list runname
1540: 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 6b ) keyvals)).. (k
1550: 65 79 3d 3f 73 74 72 20 20 28 73 74 72 69 6e 67 ey=?str (string
1560: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
1570: 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 28 63 6f p (lambda (k)(co
1580: 6e 63 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c nc (key:get-fiel
1590: 64 6e 61 6d 65 20 6b 29 20 22 3d 3f 22 29 29 20 dname k) "=?"))
15a0: 6b 65 79 73 29 20 22 20 41 4e 44 20 22 29 29 29 keys) " AND ")))
15b0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
15c0: 74 20 33 20 22 6b 65 79 73 3a 20 22 20 6b 65 79 t 3 "keys: " key
15d0: 73 20 22 20 61 6c 6c 76 61 6c 73 3a 20 22 20 61 s " allvals: " a
15e0: 6c 6c 76 61 6c 73 20 22 20 6b 65 79 76 61 6c 73 llvals " keyvals
15f0: 3a 20 22 20 6b 65 79 76 61 6c 73 29 0a 20 20 20 : " keyvals).
1600: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
1610: 22 4e 4f 54 45 3a 20 75 73 69 6e 67 20 74 61 72 "NOTE: using tar
1620: 67 65 74 20 22 20 28 73 74 72 69 6e 67 2d 69 6e get " (string-in
1630: 74 65 72 73 70 65 72 73 65 20 6b 65 79 76 61 6c tersperse keyval
1640: 73 20 22 2f 22 29 20 22 20 66 6f 72 20 74 68 69 s "/") " for thi
1650: 73 20 72 75 6e 22 29 0a 20 20 20 20 28 69 66 20 s run"). (if
1660: 28 61 6e 64 20 72 75 6e 6e 61 6d 65 20 28 6e 75 (and runname (nu
1670: 6c 6c 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 6d ll? (filter (lam
1680: 62 64 61 20 28 78 29 28 6e 6f 74 20 78 29 29 20 bda (x)(not x))
1690: 6b 65 79 76 61 6c 73 29 29 29 20 3b 3b 20 74 68 keyvals))) ;; th
16a0: 65 72 65 20 6d 75 73 74 20 62 65 20 61 20 62 65 ere must be a be
16b0: 74 74 65 72 20 77 61 79 20 74 6f 20 22 61 70 70 tter way to "app
16c0: 6c 79 20 61 6e 64 22 0a 09 28 6c 65 74 20 28 28 ly and"..(let ((
16d0: 72 65 73 20 23 66 29 29 0a 09 20 20 28 61 70 70 res #f)).. (app
16e0: 6c 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 ly sqlite3:execu
16f0: 74 65 20 64 62 20 28 63 6f 6e 63 20 22 49 4e 53 te db (conc "INS
1700: 45 52 54 20 4f 52 20 49 47 4e 4f 52 45 20 49 4e ERT OR IGNORE IN
1710: 54 4f 20 72 75 6e 73 20 28 72 75 6e 6e 61 6d 65 TO runs (runname
1720: 2c 73 74 61 74 65 2c 73 74 61 74 75 73 2c 6f 77 ,state,status,ow
1730: 6e 65 72 2c 65 76 65 6e 74 5f 74 69 6d 65 22 20 ner,event_time"
1740: 63 6f 6d 6d 61 20 6b 65 79 73 74 72 20 22 29 20 comma keystr ")
1750: 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c VALUES (?,?,?,?,
1760: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
1770: 6f 77 27 29 22 20 63 6f 6d 6d 61 20 76 61 6c 73 ow')" comma vals
1780: 6c 6f 74 73 20 22 29 3b 22 29 0a 09 09 20 61 6c lots ");")... al
1790: 6c 76 61 6c 73 29 0a 09 20 20 28 61 70 70 6c 79 lvals).. (apply
17a0: 20 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 sqlite3:for-eac
17b0: 68 2d 72 6f 77 20 0a 09 20 20 20 28 6c 61 6d 62 h-row .. (lamb
17c0: 64 61 20 28 69 64 29 0a 09 20 20 20 20 20 28 73 da (id).. (s
17d0: 65 74 21 20 72 65 73 20 69 64 29 29 0a 09 20 20 et! res id))..
17e0: 20 64 62 0a 09 20 20 20 28 6c 65 74 20 28 28 71 db.. (let ((q
17f0: 72 79 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 ry (conc "SELECT
1800: 20 69 64 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 id FROM runs WH
1810: 45 52 45 20 28 72 75 6e 6e 61 6d 65 3d 3f 20 22 ERE (runname=? "
1820: 20 61 6e 64 73 74 72 20 6b 65 79 3d 3f 73 74 72 andstr key=?str
1830: 20 22 29 3b 22 29 29 29 0a 09 20 20 20 20 20 3b ");"))).. ;
1840: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
1850: 71 72 79 3a 20 22 20 71 72 79 29 20 0a 09 20 20 qry: " qry) ..
1860: 20 20 20 71 72 79 29 0a 09 20 20 20 71 72 79 76 qry).. qryv
1870: 61 6c 73 29 0a 09 20 20 28 73 71 6c 69 74 65 33 als).. (sqlite3
1880: 3a 65 78 65 63 75 74 65 20 64 62 20 22 55 50 44 :execute db "UPD
1890: 41 54 45 20 72 75 6e 73 20 53 45 54 20 73 74 61 ATE runs SET sta
18a0: 74 65 3d 3f 2c 73 74 61 74 75 73 3d 3f 20 57 48 te=?,status=? WH
18b0: 45 52 45 20 69 64 3d 3f 3b 22 20 73 74 61 74 65 ERE id=?;" state
18c0: 20 73 74 61 74 75 73 20 72 65 73 29 0a 09 20 20 status res)..
18d0: 72 65 73 29 20 0a 09 28 62 65 67 69 6e 0a 09 20 res) ..(begin..
18e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
18f0: 22 45 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 77 "ERROR: Called w
1900: 69 74 68 6f 75 74 20 61 6c 6c 20 6e 65 63 65 73 ithout all neces
1910: 73 61 72 79 20 6b 65 79 73 22 29 0a 09 20 20 23 sary keys").. #
1920: 66 29 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 f))))..;; This i
1930: 73 20 61 20 64 75 70 6c 69 63 61 74 65 20 6f 66 s a duplicate of
1940: 20 72 75 6e 2d 74 65 73 74 73 20 28 77 68 69 63 run-tests (whic
1950: 68 20 68 61 73 20 62 65 65 6e 20 64 65 70 72 65 h has been depre
1960: 63 61 74 65 64 29 2e 20 55 73 65 20 74 68 69 73 cated). Use this
1970: 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 20 one instead of
1980: 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b 65 run tests..;; ke
1990: 79 76 61 6c 73 0a 28 64 65 66 69 6e 65 20 28 72 yvals.(define (r
19a0: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 20 64 62 uns:run-tests db
19b0: 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 target runname
19c0: 74 65 73 74 2d 70 61 74 74 73 20 75 73 65 72 20 test-patts user
19d0: 66 6c 61 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 flags). (let* (
19e0: 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 72 64 (keys (rd
19f0: 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b:get-keys db)).
1a00: 09 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 28 . (keyvallst (
1a10: 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 keys:target->key
1a20: 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 val keys target)
1a30: 29 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 ).. (run-id
1a40: 20 28 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d (runs:register-
1a50: 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 run db keys keyv
1a60: 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e allst runname "n
1a70: 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 ew" "n/a" user))
1a80: 20 20 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 ;; test-name)
1a90: 29 29 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 )).. (deferred
1aa0: 20 20 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 '()) ;; delay
1ab0: 72 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 running these si
1ac0: 6e 63 65 20 74 68 65 79 20 68 61 76 65 20 61 20 nce they have a
1ad0: 77 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 waiton clause..
1ae0: 3b 3b 20 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 ;; keepgoing is
1af0: 74 68 65 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 the defacto moda
1b00: 6c 69 74 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 lity now, will a
1b10: 64 64 20 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 dd hit-n-run a b
1b20: 69 74 20 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b it later.. ;; (k
1b30: 65 65 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 eepgoing (hash
1b40: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
1b50: 6c 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 lt flags "-keepg
1b60: 6f 69 6e 67 22 20 23 66 29 29 0a 09 20 28 74 65 oing" #f)).. (te
1b70: 73 74 2d 6e 61 6d 65 73 20 20 27 28 29 29 0a 09 st-names '())..
1b80: 20 28 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 28 (runconfigf (
1b90: 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 conc *toppath*
1ba0: 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "/runconfigs.con
1bb0: 66 69 67 22 29 29 0a 09 20 28 72 65 71 75 69 72 fig")).. (requir
1bc0: 65 64 2d 74 65 73 74 73 20 27 28 29 29 0a 09 20 ed-tests '())..
1bd0: 28 74 65 73 74 2d 72 65 63 6f 72 64 73 20 28 6d (test-records (m
1be0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1bf0: 29 0a 0a 20 20 20 20 28 73 65 74 2d 6d 65 67 61 ).. (set-mega
1c00: 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 test-env-vars db
1c10: 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 run-id) ;; thes
1c20: 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 e may be needed
1c30: 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 by the launching
1c40: 20 70 72 6f 63 65 73 73 0a 0a 20 20 20 20 28 69 process.. (i
1c50: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
1c60: 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 28 73 65 runconfigf)..(se
1c70: 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 tup-env-defaults
1c80: 20 64 62 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 db runconfigf r
1c90: 75 6e 2d 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 un-id *already-s
1ca0: 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e een-runconfig-in
1cb0: 66 6f 2a 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d fo* "pre-launch-
1cc0: 65 6e 76 2d 76 61 72 73 22 29 0a 09 28 64 65 62 env-vars")..(deb
1cd0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
1ce0: 49 4e 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 ING: You do not
1cf0: 68 61 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 have a run confi
1d00: 67 20 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e g file: " runcon
1d10: 66 69 67 66 29 29 0a 20 20 20 20 0a 20 20 20 20 figf)). .
1d20: 3b 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 ;; look up all t
1d30: 65 73 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 ests matching th
1d40: 65 20 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 e comma separate
1d50: 64 20 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 d list of globs
1d60: 69 6e 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 in. ;; test-p
1d70: 61 74 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 atts (using % as
1d80: 20 77 69 6c 64 63 61 72 64 29 0a 20 20 20 20 28 wildcard). (
1d90: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
1da0: 6c 61 6d 62 64 61 20 28 70 61 74 74 29 0a 20 20 lambda (patt).
1db0: 20 20 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 (let ((test
1dc0: 73 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 2a 74 s (glob (conc *t
1dd0: 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f oppath* "/tests/
1de0: 22 20 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c " (string-transl
1df0: 61 74 65 20 70 61 74 74 20 22 25 22 20 22 2a 22 ate patt "%" "*"
1e00: 29 29 29 29 29 0a 09 20 28 73 65 74 21 20 74 65 ))))).. (set! te
1e10: 73 74 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d sts (filter (lam
1e20: 62 64 61 20 28 74 65 73 74 29 28 66 69 6c 65 2d bda (test)(file-
1e30: 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 exists? (conc te
1e40: 73 74 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 st "/testconfig"
1e50: 29 29 29 20 74 65 73 74 73 29 29 0a 09 20 28 73 ))) tests)).. (s
1e60: 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 et! test-names (
1e70: 61 70 70 65 6e 64 20 74 65 73 74 2d 6e 61 6d 65 append test-name
1e80: 73 20 0a 09 09 09 09 20 20 28 6d 61 70 20 28 6c s ..... (map (l
1e90: 61 6d 62 64 61 20 28 74 65 73 74 70 29 0a 09 09 ambda (testp)...
1ea0: 09 09 09 20 28 6c 61 73 74 20 28 73 74 72 69 6e ... (last (strin
1eb0: 67 2d 73 70 6c 69 74 20 74 65 73 74 70 20 22 2f g-split testp "/
1ec0: 22 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 "))).....
1ed0: 74 65 73 74 73 29 29 29 29 29 0a 20 20 20 20 20 tests))))).
1ee0: 28 69 66 20 74 65 73 74 2d 70 61 74 74 73 20 28 (if test-patts (
1ef0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 string-split tes
1f00: 74 2d 70 61 74 74 73 20 22 2c 22 29 28 6c 69 73 t-patts ",")(lis
1f10: 74 20 22 25 22 29 29 29 0a 0a 20 20 20 20 20 3b t "%"))).. ;
1f20: 3b 20 6e 6f 77 20 72 65 6d 6f 76 65 20 64 75 70 ; now remove dup
1f30: 6c 69 63 61 74 65 73 0a 20 20 20 20 28 73 65 74 licates. (set
1f40: 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 ! test-names (de
1f50: 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 lete-duplicates
1f60: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 test-names))..
1f70: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
1f80: 20 22 49 4e 46 4f 3a 20 74 65 73 74 20 6e 61 6d "INFO: test nam
1f90: 65 73 20 22 20 74 65 73 74 2d 6e 61 6d 65 73 29 es " test-names)
1fa0: 0a 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 68 65 20 .. ;; on the
1fb0: 66 69 72 73 74 20 70 61 73 73 20 6f 72 20 63 61 first pass or ca
1fc0: 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 ll to run-tests
1fd0: 73 65 74 20 46 41 49 4c 53 20 74 6f 20 4e 4f 54 set FAILS to NOT
1fe0: 5f 53 54 41 52 54 45 44 20 69 66 0a 20 20 20 20 _STARTED if.
1ff0: 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 20 69 73 ;; -keepgoing is
2000: 20 73 70 65 63 69 66 69 65 64 0a 20 20 20 20 28 specified. (
2010: 69 66 20 28 65 71 3f 20 2a 70 61 73 73 6e 75 6d if (eq? *passnum
2020: 2a 20 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 * 0)..(begin..
2030: 3b 3b 20 68 61 76 65 20 74 6f 20 64 65 6c 65 74 ;; have to delet
2040: 65 20 74 65 73 74 20 72 65 63 6f 72 64 73 20 77 e test records w
2050: 68 65 72 65 20 4e 4f 54 5f 53 54 41 52 54 45 44 here NOT_STARTED
2060: 20 73 69 6e 63 65 20 74 68 65 79 20 63 61 6e 20 since they can
2070: 63 61 75 73 65 20 2d 6b 65 65 70 67 6f 69 6e 67 cause -keepgoing
2080: 20 74 6f 20 0a 09 20 20 3b 3b 20 67 65 74 20 73 to .. ;; get s
2090: 74 75 63 6b 20 64 75 65 20 74 6f 20 62 65 63 6f tuck due to beco
20a0: 6d 69 6e 67 20 69 6e 61 63 63 65 73 73 69 62 6c ming inaccessibl
20b0: 65 20 66 72 6f 6d 20 61 20 66 61 69 6c 65 64 20 e from a failed
20c0: 74 65 73 74 2e 20 49 2e 65 2e 20 69 66 20 74 65 test. I.e. if te
20d0: 73 74 20 42 20 64 65 70 65 6e 64 73 20 0a 09 20 st B depends ..
20e0: 20 3b 3b 20 6f 6e 20 74 65 73 74 20 41 20 62 75 ;; on test A bu
20f0: 74 20 74 65 73 74 20 42 20 72 65 61 63 68 65 64 t test B reached
2100: 20 74 68 65 20 70 6f 69 6e 74 20 6f 6e 20 62 65 the point on be
2110: 69 6e 67 20 72 65 67 69 73 74 65 72 65 64 20 61 ing registered a
2120: 73 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e s NOT_STARTED an
2130: 64 20 74 65 73 74 0a 09 20 20 3b 3b 20 41 20 66 d test.. ;; A f
2140: 61 69 6c 65 64 20 66 6f 72 20 73 6f 6d 65 20 72 ailed for some r
2150: 65 61 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 72 65 eason then on re
2160: 2d 72 75 6e 20 75 73 69 6e 67 20 2d 6b 65 65 70 -run using -keep
2170: 67 6f 69 6e 67 20 74 68 65 20 72 75 6e 20 63 61 going the run ca
2180: 6e 20 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 65 n never complete
2190: 2e 0a 09 20 20 28 64 62 3a 64 65 6c 65 74 65 2d ... (db:delete-
21a0: 74 65 73 74 73 2d 69 6e 2d 73 74 61 74 65 20 64 tests-in-state d
21b0: 62 20 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 b run-id "NOT_ST
21c0: 41 52 54 45 44 22 29 0a 09 20 20 28 72 64 62 3a ARTED").. (rdb:
21d0: 73 65 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d set-tests-state-
21e0: 73 74 61 74 75 73 20 64 62 20 72 75 6e 2d 69 64 status db run-id
21f0: 20 74 65 73 74 2d 6e 61 6d 65 73 20 23 66 20 22 test-names #f "
2200: 46 41 49 4c 22 20 22 4e 4f 54 5f 53 54 41 52 54 FAIL" "NOT_START
2210: 45 44 22 20 22 46 41 49 4c 22 29 29 29 0a 0a 20 ED" "FAIL")))..
2220: 20 20 20 3b 3b 20 6e 6f 77 20 61 64 64 20 6e 6f ;; now add no
2230: 6e 2d 64 69 72 65 63 74 6c 79 20 72 65 66 65 72 n-directly refer
2240: 65 6e 63 65 64 20 64 65 70 65 6e 64 65 6e 63 69 enced dependenci
2250: 65 73 20 28 69 2e 65 2e 20 77 61 69 74 6f 6e 29 es (i.e. waiton)
2260: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e . (if (not (n
2270: 75 6c 6c 3f 20 74 65 73 74 2d 6e 61 6d 65 73 29 ull? test-names)
2280: 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 )..(let loop ((h
2290: 65 64 20 28 63 61 72 20 74 65 73 74 2d 6e 61 6d ed (car test-nam
22a0: 65 73 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 es))... (tal (
22b0: 63 64 72 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 cdr test-names))
22c0: 29 20 20 20 20 20 20 20 20 20 3b 3b 20 27 72 65 ) ;; 're
22d0: 74 75 72 6e 2d 70 72 6f 63 73 20 74 65 6c 6c 73 turn-procs tells
22e0: 20 74 68 65 20 63 6f 6e 66 69 67 20 72 65 61 64 the config read
22f0: 65 72 20 74 6f 20 70 72 65 70 20 72 75 6e 6e 69 er to prep runni
2300: 6e 67 20 73 79 73 74 65 6d 20 62 75 74 20 72 65 ng system but re
2310: 74 75 72 6e 20 61 20 70 72 6f 63 0a 09 20 20 28 turn a proc.. (
2320: 6c 65 74 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 let* ((config (
2330: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f tests:get-testco
2340: 6e 66 69 67 20 68 65 64 20 27 72 65 74 75 72 6e nfig hed 'return
2350: 2d 70 72 6f 63 73 29 29 0a 09 09 20 28 77 61 69 -procs))... (wai
2360: 74 6f 6e 73 20 28 69 66 20 63 6f 6e 66 69 67 20 tons (if config
2370: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 28 6c (string-split (l
2380: 65 74 20 28 28 77 20 28 63 6f 6e 66 69 67 2d 6c et ((w (config-l
2390: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 72 65 ookup config "re
23a0: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 77 61 69 quirements" "wai
23b0: 74 6f 6e 22 29 29 29 0a 09 09 09 09 09 09 20 20 ton"))).......
23c0: 20 20 20 28 69 66 20 77 20 77 20 22 22 29 29 29 (if w w "")))
23d0: 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e .... (begin
23e0: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
23f0: 74 20 30 20 22 45 52 52 4f 52 3a 20 6e 6f 6e 2d t 0 "ERROR: non-
2400: 65 78 69 73 74 61 6e 74 20 72 65 71 75 69 72 65 existant require
2410: 64 20 74 65 73 74 20 5c 22 22 20 68 65 64 20 22 d test \"" hed "
2420: 5c 22 22 29 0a 09 09 09 09 28 65 78 69 74 20 31 \"").....(exit 1
2430: 29 29 29 29 29 0a 09 20 20 20 20 3b 3b 20 63 68 ))))).. ;; ch
2440: 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 eck for hed in w
2450: 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 aitons => this w
2460: 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 ould be circular
2470: 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 , remove it and
2480: 69 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b issue an.. ;;
2490: 20 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 error.. (if
24a0: 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 74 (member hed wait
24b0: 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 ons)...(begin...
24c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
24d0: 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 "ERROR: test "
24e0: 68 65 64 20 22 20 68 61 73 20 6c 69 73 74 65 64 hed " has listed
24f0: 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 itself as a wai
2500: 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 ton, please corr
2510: 65 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 20 ect this!")...
2520: 28 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 66 (set! waitons (f
2530: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
2540: 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 )(not (equal? x
2550: 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 hed))) waitons))
2560: 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b 3b )).. .. ;;
2570: 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d 73 (items (items
2580: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
2590: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 29 config config)))
25a0: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
25b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
25c0: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f efault test-reco
25d0: 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 28 rds hed #f))...(
25e0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
25f0: 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 test-records....
2600: 09 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 65 . hed (vector he
2610: 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 d ;; 0......
2620: 20 20 20 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 config ;;
2630: 31 0a 09 09 09 09 09 20 20 20 20 20 77 61 69 74 1...... wait
2640: 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 ons ;; 2......
2650: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
2660: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
2670: 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 ements" "priorit
2680: 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 y") ;; prior
2690: 69 74 79 20 33 0a 09 09 09 09 09 20 20 20 20 20 ity 3......
26a0: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
26b0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
26c0: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
26d0: 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b 3b "items" #f)) ;;
26e0: 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 20 items 4.......
26f0: 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 (itemstable (h
2700: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2710: 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 fault config "it
2720: 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 emstable" #f)))
2730: 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
2740: 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 20 if either items
2750: 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 69 or items table i
2760: 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e 20 s a proc return
2770: 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 it so test runni
2780: 6e 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b ng...... ;
2790: 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e ; process can kn
27a0: 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 ow to call items
27b0: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
27c0: 63 6f 6e 66 69 67 0a 09 09 09 09 09 20 20 20 20 config......
27d0: 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 ;; if either
27e0: 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f is a list and no
27f0: 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f 20 ne is a proc go
2800: 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 ahead and call g
2810: 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 20 20 et-items......
2820: 20 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 ;; otherwis
2830: 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 e return #f - th
2840: 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 is is not an ite
2850: 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 09 rated test......
2860: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 (cond....
2870: 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ...((procedure?
2880: 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 09 items) ....
2890: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
28a0: 20 34 20 22 49 4e 46 4f 3a 20 69 74 65 6d 73 20 4 "INFO: items
28b0: 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
28c0: 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
28d0: 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 29 20 )....... items)
28e0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 ;; ca
28f0: 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 lc later.......(
2900: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
2910: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 stable)....... (
2920: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 debug:print 4 "I
2930: 4e 46 4f 3a 20 69 74 65 6d 73 74 61 62 6c 65 20 NFO: itemstable
2940: 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
2950: 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
2960: 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 74 61 )....... itemsta
2970: 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 ble) ;; ca
2980: 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 lc later.......(
2990: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
29a0: 28 78 29 0a 09 09 09 09 09 09 09 20 20 20 28 6c (x)........ (l
29b0: 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 et ((val (car x)
29c0: 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 ))........ (
29d0: 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 if (procedure? v
29e0: 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 al) val #f)))...
29f0: 09 09 09 09 09 20 28 61 70 70 65 6e 64 20 28 69 ..... (append (i
2a00: 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 f (list? items)
2a10: 69 74 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 items '())......
2a20: 09 09 09 20 28 69 66 20 28 6c 69 73 74 3f 20 69 ... (if (list? i
2a30: 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 temstable) items
2a40: 74 61 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 table '())))....
2a50: 09 09 09 20 27 68 61 76 65 2d 70 72 6f 63 65 64 ... 'have-proced
2a60: 75 72 65 29 0a 09 09 09 09 09 09 28 28 6f 72 20 ure).......((or
2a70: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 (list? items)(li
2a80: 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 st? itemstable))
2a90: 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 ;; calc now....
2aa0: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
2ab0: 20 34 20 22 49 4e 46 4f 3a 20 69 74 65 6d 73 20 4 "INFO: items
2ac0: 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 and itemstable a
2ad0: 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e re lists, calc n
2ae0: 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 20 20 20 ow\n"........
2af0: 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 " items: "
2b00: 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 items " itemsta
2b10: 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c ble: " itemstabl
2b20: 65 29 0a 09 09 09 09 09 09 20 28 69 74 65 6d 73 e)....... (items
2b30: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
2b40: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a config config)).
2b50: 09 09 09 09 09 09 28 65 6c 73 65 20 23 66 29 29 ......(else #f))
2b60: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
2b70: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e ;; n
2b80: 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 ot iterated.....
2b90: 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b . #f ;;
2ba0: 20 69 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 itemsdat 5.....
2bb0: 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b . #f ;;
2bc0: 20 73 70 61 72 65 20 2d 20 75 73 65 64 20 66 6f spare - used fo
2bd0: 72 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 r item-path.....
2be0: 09 20 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 . ))).. (
2bf0: 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 for-each ..
2c00: 28 6c 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 (lambda (waiton)
2c10: 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e .. (if (an
2c20: 64 20 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d d waiton (not (m
2c30: 65 6d 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 ember waiton tes
2c40: 74 2d 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 t-names)))...
2c50: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 (begin... (s
2c60: 65 74 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 et! required-tes
2c70: 74 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 ts (cons waiton
2c80: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
2c90: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 74 65 ... (set! te
2ca0: 73 74 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 st-names (cons w
2cb0: 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 aiton test-names
2cc0: 29 29 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 ))))) ;; was an
2cd0: 61 70 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f append, now a co
2ce0: 6e 73 0a 09 20 20 20 20 20 77 61 69 74 6f 6e 73 ns.. waitons
2cf0: 29 0a 09 20 20 20 20 28 6c 65 74 20 28 28 72 65 ).. (let ((re
2d00: 6d 74 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 mtests (delete-d
2d10: 75 70 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e uplicates (appen
2d20: 64 20 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 d waitons tal)))
2d30: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f ).. (if (no
2d40: 74 20 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 t (null? remtest
2d50: 73 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 s))... (loop (c
2d60: 61 72 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 ar remtests)(cdr
2d70: 20 72 65 6d 74 65 73 74 73 29 29 29 29 29 29 29 remtests)))))))
2d80: 0a 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
2d90: 6e 75 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 null? required-t
2da0: 65 73 74 73 29 29 0a 09 28 64 65 62 75 67 3a 70 ests))..(debug:p
2db0: 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 41 64 rint 1 "INFO: Ad
2dc0: 64 69 6e 67 20 22 20 72 65 71 75 69 72 65 64 2d ding " required-
2dd0: 74 65 73 74 73 20 22 20 74 6f 20 74 68 65 20 72 tests " to the r
2de0: 75 6e 20 71 75 65 75 65 22 29 29 0a 20 20 20 20 un queue")).
2df0: 3b 3b 20 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 ;; NOTE: these a
2e00: 72 65 20 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 re all parent te
2e10: 73 74 73 2c 20 69 74 65 6d 73 20 61 72 65 20 6e sts, items are n
2e20: 6f 74 20 65 78 70 61 6e 64 65 64 20 79 65 74 2e ot expanded yet.
2e30: 0a 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 . (runs:run-t
2e40: 65 73 74 73 2d 71 75 65 75 65 20 64 62 20 72 75 ests-queue db ru
2e50: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
2e60: 74 2d 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c t-records keyval
2e70: 6c 73 74 20 66 6c 61 67 73 29 0a 20 20 20 20 28 lst flags). (
2e80: 69 66 20 2a 72 70 63 3a 6c 69 73 74 65 6e 65 72 if *rpc:listener
2e90: 2a 20 28 73 65 72 76 65 72 3a 6b 65 65 70 2d 72 * (server:keep-r
2ea0: 75 6e 6e 69 6e 67 20 64 62 29 29 0a 20 20 20 20 unning db)).
2eb0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
2ec0: 49 4e 46 4f 3a 20 41 6c 6c 20 64 6f 6e 65 20 62 INFO: All done b
2ed0: 79 20 68 65 72 65 22 29 29 29 0a 0a 3b 3b 20 74 y here")))..;; t
2ee0: 65 73 74 2d 72 65 63 6f 72 64 73 20 69 73 20 61 est-records is a
2ef0: 20 68 61 73 68 20 74 61 62 6c 65 20 74 65 73 74 hash table test
2f00: 6e 61 6d 65 3a 69 74 65 6d 5f 70 61 74 68 20 3d name:item_path =
2f10: 3e 20 76 65 63 74 6f 72 20 3c 20 74 65 73 74 6e > vector < testn
2f20: 61 6d 65 20 74 65 73 74 63 6f 6e 66 69 67 20 77 ame testconfig w
2f30: 61 69 74 6f 6e 73 20 70 72 69 6f 72 69 74 79 20 aitons priority
2f40: 69 74 65 6d 73 2d 69 6e 66 6f 20 2e 2e 2e 20 3e items-info ... >
2f50: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 .(define (runs:r
2f60: 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 20 64 un-tests-queue d
2f70: 62 20 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 b run-id runname
2f80: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6b 65 test-records ke
2f90: 79 76 61 6c 6c 73 74 20 66 6c 61 67 73 29 0a 20 yvallst flags).
2fa0: 20 20 20 3b 3b 20 41 74 20 74 68 69 73 20 70 6f ;; At this po
2fb0: 69 6e 74 20 74 68 65 20 6c 69 73 74 20 6f 66 20 int the list of
2fc0: 70 61 72 65 6e 74 20 74 65 73 74 73 20 69 73 20 parent tests is
2fd0: 65 78 70 61 6e 64 65 64 20 0a 20 20 20 20 3b 3b expanded . ;;
2fe0: 20 4e 42 2f 2f 20 53 68 6f 75 6c 64 20 65 78 70 NB// Should exp
2ff0: 61 6e 64 20 69 74 65 6d 73 20 68 65 72 65 20 61 and items here a
3000: 6e 64 20 74 68 65 6e 20 69 6e 73 65 72 74 20 69 nd then insert i
3010: 6e 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 nto the run queu
3020: 65 2e 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e e.. (debug:prin
3030: 74 20 35 20 22 74 65 73 74 2d 72 65 63 6f 72 64 t 5 "test-record
3040: 73 3a 20 22 20 74 65 73 74 2d 72 65 63 6f 72 64 s: " test-record
3050: 73 20 22 2c 20 6b 65 79 76 61 6c 6c 73 74 3a 20 s ", keyvallst:
3060: 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 66 6c " keyvallst " fl
3070: 61 67 73 3a 20 22 20 28 68 61 73 68 2d 74 61 62 ags: " (hash-tab
3080: 6c 65 2d 3e 61 6c 69 73 74 20 66 6c 61 67 73 29 le->alist flags)
3090: 29 0a 20 20 28 6c 65 74 20 28 28 73 6f 72 74 65 ). (let ((sorte
30a0: 64 2d 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 d-test-names (te
30b0: 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 72 69 6f sts:sort-by-prio
30c0: 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 6f 6e 20 rity-and-waiton
30d0: 74 65 73 74 2d 72 65 63 6f 72 64 73 29 29 0a 09 test-records))..
30e0: 28 69 74 65 6d 2d 70 61 74 74 73 20 20 20 20 20 (item-patts
30f0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
3100: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
3110: 20 22 2d 69 74 65 6d 70 61 74 74 22 20 23 66 29 "-itempatt" #f)
3120: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
3130: 28 6e 75 6c 6c 3f 20 73 6f 72 74 65 64 2d 74 65 (null? sorted-te
3140: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 st-names))..(let
3150: 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 loop ((hed
3160: 20 20 20 20 28 63 61 72 20 73 6f 72 74 65 64 2d (car sorted-
3170: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 test-names))...
3180: 20 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 28 (tal (
3190: 63 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d cdr sorted-test-
31a0: 6e 61 6d 65 73 29 29 29 0a 09 20 20 28 74 68 72 names))).. (thr
31b0: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 31 29 20 ead-sleep! 0.1)
31c0: 3b 3b 20 67 69 76 65 20 6f 74 68 65 72 20 61 70 ;; give other ap
31d0: 70 6c 69 63 61 74 69 6f 6e 73 20 73 6f 6d 65 20 plications some
31e0: 74 69 6d 65 20 77 69 74 68 20 74 68 65 20 64 62 time with the db
31f0: 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 .. (let* ((test
3200: 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 61 -record (hash-ta
3210: 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 63 ble-ref test-rec
3220: 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 74 ords hed))... (t
3230: 63 6f 6e 66 69 67 20 20 20 20 20 28 74 65 73 74 config (test
3240: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3250: 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d testconfig test-
3260: 72 65 63 6f 72 64 29 29 0a 09 09 20 28 74 65 73 record))... (tes
3270: 74 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 28 tmode (let ((
3280: 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 m (config-lookup
3290: 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 tconfig "requir
32a0: 65 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 29 ements" "mode"))
32b0: 29 0a 09 09 09 09 28 69 66 20 6d 20 28 73 74 72 ).....(if m (str
32c0: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 6d 29 20 27 ing->symbol m) '
32d0: 6e 6f 72 6d 61 6c 29 29 29 0a 09 09 20 28 77 61 normal)))... (wa
32e0: 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 itons (tests
32f0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 :testqueue-get-w
3300: 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 aitons test-r
3310: 65 63 6f 72 64 29 29 0a 09 09 20 28 70 72 69 6f ecord))... (prio
3320: 72 69 74 79 20 20 20 20 28 74 65 73 74 73 3a 74 rity (tests:t
3330: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 69 estqueue-get-pri
3340: 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 65 63 ority test-rec
3350: 6f 72 64 29 29 0a 09 09 20 28 69 74 65 6d 64 61 ord))... (itemda
3360: 74 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 t (tests:tes
3370: 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 tqueue-get-itemd
3380: 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 at test-recor
3390: 64 29 29 20 3b 3b 20 69 74 65 6d 64 61 74 20 63 d)) ;; itemdat c
33a0: 61 6e 20 62 65 20 61 20 73 74 72 69 6e 67 2c 20 an be a string,
33b0: 6c 69 73 74 20 6f 72 20 23 66 0a 09 09 20 28 69 list or #f... (i
33c0: 74 65 6d 73 20 20 20 20 20 20 20 28 74 65 73 74 tems (test
33d0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
33e0: 69 74 65 6d 73 20 20 20 20 20 20 74 65 73 74 2d items test-
33f0: 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 65 record))... (ite
3400: 6d 2d 70 61 74 68 20 20 20 28 69 74 65 6d 2d 6c m-path (item-l
3410: 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 ist->path itemda
3420: 74 29 29 0a 09 09 20 28 6e 65 77 74 61 6c 20 20 t))... (newtal
3430: 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c 20 (append tal
3440: 28 6c 69 73 74 20 68 65 64 29 29 29 0a 09 09 20 (list hed)))...
3450: 28 63 61 6c 63 2d 66 61 69 6c 73 20 20 28 6c 61 (calc-fails (la
3460: 6d 62 64 61 20 28 70 72 65 72 65 71 73 2d 6e 6f mbda (prereqs-no
3470: 74 2d 6d 65 74 29 0a 09 09 09 09 28 66 69 6c 74 t-met).....(filt
3480: 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 er (lambda (test
3490: 29 0a 09 09 09 09 09 20 20 28 64 65 62 75 67 3a )...... (debug:
34a0: 70 72 69 6e 74 20 39 20 22 74 65 73 74 3a 20 22 print 9 "test: "
34b0: 20 74 65 73 74 29 0a 09 09 09 09 09 20 20 28 61 test)...... (a
34c0: 6e 64 20 28 76 65 63 74 6f 72 3f 20 74 65 73 74 nd (vector? test
34d0: 29 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e 67 ) ;; not (string
34e0: 3f 20 74 65 73 74 29 29 0a 09 09 09 09 09 20 20 ? test))......
34f0: 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 64 62 (equal? (db
3500: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
3510: 74 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 test) "COMPLETED
3520: 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 ")...... (
3530: 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 62 3a not (member (db:
3540: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
3550: 74 65 73 74 29 0a 09 09 09 09 09 09 09 20 20 20 test)........
3560: 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 '("PASS" "WARN"
3570: 20 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 44 "CHECK" "WAIVED
3580: 22 29 29 29 29 29 0a 09 09 09 09 09 70 72 65 72 ")))))......prer
3590: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 eqs-not-met)))..
35a0: 09 20 28 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 . (calc-not-comp
35b0: 6c 65 74 65 64 20 28 6c 61 6d 62 64 61 20 28 70 leted (lambda (p
35c0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
35d0: 09 09 09 09 20 20 20 20 20 20 20 28 66 69 6c 74 .... (filt
35e0: 65 72 0a 09 09 09 09 09 28 6c 61 6d 62 64 61 20 er......(lambda
35f0: 28 74 29 0a 09 09 09 09 09 20 20 28 6f 72 20 28 (t)...... (or (
3600: 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 not (vector? t))
3610: 0a 09 09 09 09 09 20 20 20 20 20 20 28 6e 6f 74 ...... (not
3620: 20 28 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c 45 (equal? "COMPLE
3630: 54 45 44 22 20 28 64 62 3a 74 65 73 74 2d 67 65 TED" (db:test-ge
3640: 74 2d 73 74 61 74 65 20 74 29 29 29 29 29 0a 09 t-state t)))))..
3650: 09 09 09 09 70 72 65 72 65 71 73 2d 6e 6f 74 2d ....prereqs-not-
3660: 6d 65 74 29 29 29 0a 09 09 20 28 70 72 65 74 74 met)))... (prett
3670: 79 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 64 61 y-string (lambda
3680: 20 28 6c 73 74 29 0a 09 09 09 09 20 20 28 6d 61 (lst)..... (ma
3690: 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 09 p (lambda (t)...
36a0: 09 09 09 20 28 69 66 20 28 73 74 72 69 6e 67 3f ... (if (string?
36b0: 20 74 29 0a 09 09 09 09 09 20 20 20 20 20 74 0a t)...... t.
36c0: 09 09 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 ..... (conc
36d0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
36e0: 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 tname t) ":" (db
36f0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
3700: 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d t) "/" (db:test-
3710: 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 get-status t))))
3720: 0a 09 09 09 09 20 20 20 20 20 20 20 6c 73 74 29 ..... lst)
3730: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
3740: 70 72 69 6e 74 20 36 0a 09 09 09 20 22 69 74 65 print 6.... "ite
3750: 6d 64 61 74 3a 20 20 20 20 20 22 20 69 74 65 6d mdat: " item
3760: 64 61 74 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 dat.... "\n ite
3770: 6d 73 3a 20 20 20 20 20 22 20 69 74 65 6d 73 0a ms: " items.
3780: 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 ... "\n item-pa
3790: 74 68 3a 20 22 20 69 74 65 6d 2d 70 61 74 68 0a th: " item-path.
37a0: 09 09 09 20 22 5c 6e 20 20 77 61 69 74 6f 6e 73 ... "\n waitons
37b0: 3a 20 20 20 22 20 77 61 69 74 6f 6e 73 29 0a 0a : " waitons)..
37c0: 09 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f . ;; check fo
37d0: 72 20 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 r hed in waitons
37e0: 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 => this would b
37f0: 65 20 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f e circular, remo
3800: 76 65 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 ve it and issue
3810: 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 an.. ;; error
3820: 0a 09 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 .. (if (membe
3830: 72 20 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 r hed waitons)..
3840: 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 .(begin... (deb
3850: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
3860: 52 3a 20 74 65 73 74 20 22 20 68 65 64 20 22 20 R: test " hed "
3870: 68 61 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c has listed itsel
3880: 66 20 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 f as a waiton, p
3890: 6c 65 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 lease correct th
38a0: 69 73 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 is!")... (set!
38b0: 77 61 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 28 waiton (filter (
38c0: 6c 61 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 lambda (x)(not (
38d0: 65 71 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 equal? x hed)))
38e0: 77 61 69 74 6f 6e 73 29 29 29 29 0a 0a 09 20 20 waitons))))...
38f0: 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 28 (cond.. ((
3900: 6e 6f 74 20 69 74 65 6d 73 29 20 3b 3b 20 77 68 not items) ;; wh
3910: 65 6e 20 66 61 6c 73 65 20 74 68 65 20 74 65 73 en false the tes
3920: 74 20 69 73 20 6f 6b 20 74 6f 20 62 65 20 68 61 t is ok to be ha
3930: 6e 64 65 64 20 6f 66 66 20 74 6f 20 6c 61 75 6e nded off to laun
3940: 63 68 20 28 62 75 74 20 6e 6f 74 20 62 65 66 6f ch (but not befo
3950: 72 65 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a re).. (let*
3960: 20 28 28 68 61 76 65 2d 72 65 73 6f 75 72 63 65 ((have-resource
3970: 73 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e s (runs:can-run
3980: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 20 74 -more-tests db t
3990: 65 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 est-record)) ;;
39a0: 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 74 look at the test
39b0: 20 6a 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 6f jobgroup and to
39c0: 74 20 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 t jobs running..
39d0: 09 20 20 20 20 20 28 70 72 65 72 65 71 73 2d 6e . (prereqs-n
39e0: 6f 74 2d 6d 65 74 20 28 64 62 3a 67 65 74 2d 70 ot-met (db:get-p
39f0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 64 rereqs-not-met d
3a00: 62 20 72 75 6e 2d 69 64 20 77 61 69 74 6f 6e 73 b run-id waitons
3a10: 20 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a item-path mode:
3a20: 20 74 65 73 74 6d 6f 64 65 29 29 0a 09 09 20 20 testmode))...
3a30: 20 20 20 28 66 61 69 6c 73 20 20 20 20 20 20 20 (fails
3a40: 20 20 20 20 28 63 61 6c 63 2d 66 61 69 6c 73 20 (calc-fails
3a50: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
3a60: 29 0a 09 09 20 20 20 20 20 28 6e 6f 6e 2d 63 6f )... (non-co
3a70: 6d 70 6c 65 74 65 64 20 20 20 28 63 61 6c 63 2d mpleted (calc-
3a80: 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 not-completed pr
3a90: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 ereqs-not-met)))
3aa0: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
3ab0: 38 20 22 49 4e 46 4f 3a 20 68 61 76 65 2d 72 65 8 "INFO: have-re
3ac0: 73 6f 75 72 63 65 73 3a 20 22 20 68 61 76 65 2d sources: " have-
3ad0: 72 65 73 6f 75 72 63 65 73 20 22 20 70 72 65 72 resources " prer
3ae0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 0a eqs-not-met: " .
3af0: 09 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ... (string-
3b00: 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 intersperse ....
3b10: 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 (map (lamb
3b20: 64 61 20 28 74 29 0a 09 09 09 09 20 20 20 20 20 da (t).....
3b30: 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d 67 (conc (db:test-g
3b40: 65 74 2d 73 74 61 74 65 20 74 29 22 2f 22 28 64 et-state t)"/"(d
3b50: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
3b60: 73 20 74 29 29 29 0a 09 09 09 09 20 20 20 70 72 s t)))..... pr
3b70: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 20 22 ereqs-not-met) "
3b80: 2c 20 22 29 20 22 20 66 61 69 6c 73 3a 20 22 20 , ") " fails: "
3b90: 66 61 69 6c 73 29 0a 09 09 3b 3b 20 44 6f 6e 27 fails)...;; Don'
3ba0: 74 20 6b 6e 6f 77 20 61 74 20 74 68 69 73 20 74 t know at this t
3bb0: 69 6d 65 20 69 66 20 74 68 65 20 74 65 73 74 20 ime if the test
3bc0: 68 61 76 65 20 62 65 65 6e 20 6c 61 75 6e 63 68 have been launch
3bd0: 65 64 20 61 74 20 73 6f 6d 65 20 74 69 6d 65 20 ed at some time
3be0: 69 6e 20 74 68 65 20 70 61 73 74 0a 09 09 3b 3b in the past...;;
3bf0: 20 69 2e 65 2e 20 69 73 20 74 68 69 73 20 61 20 i.e. is this a
3c00: 72 65 2d 6c 61 75 6e 63 68 3f 0a 09 09 28 63 6f re-launch?...(co
3c10: 6e 64 0a 09 09 20 28 28 61 6e 64 20 68 61 76 65 nd... ((and have
3c20: 2d 72 65 73 6f 75 72 63 65 73 0a 09 09 20 20 20 -resources...
3c30: 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 70 (or (null? p
3c40: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
3c50: 09 09 09 20 20 20 28 61 6e 64 20 28 65 71 3f 20 ... (and (eq?
3c60: 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 testmode 'toplev
3c70: 65 6c 29 0a 09 09 09 09 28 6e 75 6c 6c 3f 20 6e el).....(null? n
3c80: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 29 29 on-completed))))
3c90: 0a 09 09 20 20 3b 3b 20 6e 6f 20 6c 6f 6f 70 20 ... ;; no loop
3ca0: 68 65 72 65 2c 20 6a 75 73 74 20 64 72 6f 70 20 here, just drop
3cb0: 74 68 6f 75 67 68 20 61 6e 64 20 75 73 65 20 74 though and use t
3cc0: 68 65 20 6c 6f 6f 70 20 61 74 20 74 68 65 20 62 he loop at the b
3cd0: 6f 74 74 6f 6d 20 0a 09 09 20 20 28 69 66 20 28 ottom ... (if (
3ce0: 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 patt-list-match
3cf0: 69 74 65 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 item-path item-p
3d00: 61 74 74 73 29 0a 09 09 20 20 20 20 20 20 28 72 atts)... (r
3d10: 75 6e 3a 74 65 73 74 20 64 62 20 72 75 6e 2d 69 un:test db run-i
3d20: 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c d runname keyval
3d30: 6c 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 20 lst test-record
3d40: 66 6c 61 67 73 20 23 66 29 0a 09 09 20 20 20 20 flags #f)...
3d50: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 (debug:print 1
3d60: 20 22 49 4e 46 4f 3a 20 53 6b 69 70 70 69 6e 67 "INFO: Skipping
3d70: 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 " (tests:testqu
3d80: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
3d90: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 22 20 test-record) "
3da0: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 73 " item-path " as
3db0: 20 69 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 63 it doesn't matc
3dc0: 68 20 22 20 69 74 65 6d 2d 70 61 74 74 73 29 29 h " item-patts))
3dd0: 0a 09 09 20 20 3b 3b 20 65 6c 73 65 20 74 68 65 ... ;; else the
3de0: 20 72 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 74 run is stuck, t
3df0: 65 6d 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 65 emporarily or pe
3e00: 72 6d 61 6e 65 6e 74 6c 79 0a 09 09 20 20 3b 3b rmanently... ;;
3e10: 20 62 75 74 20 73 68 6f 75 6c 64 20 63 68 65 63 but should chec
3e20: 6b 20 69 66 20 69 74 20 69 73 20 64 75 65 20 74 k if it is due t
3e30: 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 72 o lack of resour
3e40: 63 65 73 20 76 73 2e 20 70 72 65 72 65 71 75 69 ces vs. prerequi
3e50: 73 69 74 65 73 0a 09 09 20 20 29 0a 09 09 20 28 sites... )... (
3e60: 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 72 (not have-resour
3e70: 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 74 ces) ;; simply t
3e80: 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 77 ry again after w
3e90: 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 0a aiting a second.
3ea0: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
3eb0: 70 21 20 31 2e 30 29 0a 09 09 20 20 28 64 65 62 p! 1.0)... (deb
3ec0: 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f ug:print 1 "INFO
3ed0: 3a 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 20 74 : no resources t
3ee0: 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 74 73 2c o run new tests,
3ef0: 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 29 0a 09 waiting ...")..
3f00: 09 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 76 65 . ;; could have
3f10: 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 68 65 done hed tal he
3f20: 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 61 72 re but doing car
3f30: 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c 20 74 /cdr of newtal t
3f40: 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 0a 09 o rotate tests..
3f50: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 . (loop (car ne
3f60: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal
3f70: 29 29 29 0a 09 09 20 28 65 6c 73 65 20 3b 3b 20 )))... (else ;;
3f80: 6d 75 73 74 20 62 65 20 77 65 20 68 61 76 65 20 must be we have
3f90: 75 6e 6d 65 74 20 70 72 65 72 65 71 75 69 73 69 unmet prerequisi
3fa0: 74 65 73 0a 09 09 20 20 20 20 28 64 65 62 75 67 tes... (debug
3fb0: 3a 70 72 69 6e 74 20 34 20 22 46 41 49 4c 53 3a :print 4 "FAILS:
3fc0: 20 22 20 66 61 69 6c 73 29 0a 09 09 20 20 20 20 " fails)...
3fd0: 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 20 6d 6f 72 ;; If one or mor
3fe0: 65 20 6f 66 20 74 68 65 20 70 72 65 72 65 71 73 e of the prereqs
3ff0: 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 20 46 41 49 -not-met are FAI
4000: 4c 20 74 68 65 6e 20 77 65 20 63 61 6e 20 69 73 L then we can is
4010: 73 75 65 0a 09 09 20 20 20 20 3b 3b 20 61 20 6d sue... ;; a m
4020: 65 73 73 61 67 65 20 61 6e 64 20 64 72 6f 70 20 essage and drop
4030: 68 65 64 20 66 72 6f 6d 20 74 68 65 20 69 74 65 hed from the ite
4040: 6d 73 20 74 6f 20 62 65 20 70 72 6f 63 65 73 73 ms to be process
4050: 65 64 2e 0a 09 09 20 20 20 20 28 69 66 20 28 6e ed.... (if (n
4060: 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 09 28 ull? fails)....(
4070: 62 65 67 69 6e 0a 09 09 09 20 20 3b 3b 20 63 6f begin.... ;; co
4080: 75 6c 64 6e 27 74 20 72 75 6e 2c 20 74 61 6b 65 uldn't run, take
4090: 20 61 20 62 72 65 61 74 68 65 72 0a 09 09 09 20 a breather....
40a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
40b0: 22 49 4e 46 4f 3a 20 53 68 6f 75 6c 64 6e 27 74 "INFO: Shouldn't
40c0: 20 72 65 61 6c 6c 79 20 67 65 74 20 68 65 72 65 really get here
40d0: 2c 20 72 61 63 65 20 63 6f 6e 64 69 74 69 6f 6e , race condition
40e0: 3f 20 55 6e 61 62 6c 65 20 74 6f 20 6c 61 75 6e ? Unable to laun
40f0: 63 68 20 6d 6f 72 65 20 74 65 73 74 73 20 61 74 ch more tests at
4100: 20 74 68 69 73 20 6d 6f 6d 65 6e 74 2c 20 6b 69 this moment, ki
4110: 6c 6c 69 6e 67 20 74 69 6d 65 20 2e 2e 2e 22 29 lling time ...")
4120: 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c .... (thread-sl
4130: 65 65 70 21 20 30 2e 31 29 20 3b 3b 20 6c 6f 6e eep! 0.1) ;; lon
4140: 67 20 73 6c 65 65 70 20 68 65 72 65 20 2d 20 6e g sleep here - n
4150: 6f 20 72 65 73 6f 75 72 63 65 73 2c 20 6d 61 79 o resources, may
4160: 20 61 73 20 77 65 6c 6c 20 62 65 20 70 61 74 69 as well be pati
4170: 65 6e 74 0a 09 09 09 20 20 3b 3b 20 77 65 20 6d ent.... ;; we m
4180: 61 64 65 20 6e 65 77 20 74 61 6c 20 62 79 20 73 ade new tal by s
4190: 74 69 63 6b 69 6e 67 20 68 65 64 20 61 74 20 74 ticking hed at t
41a0: 68 65 20 62 61 63 6b 20 6f 66 20 74 68 65 20 6c he back of the l
41b0: 69 73 74 0a 09 09 09 20 20 28 6c 6f 6f 70 20 28 ist.... (loop (
41c0: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
41d0: 6e 65 77 74 61 6c 29 29 29 0a 09 09 09 3b 3b 20 newtal)))....;;
41e0: 74 68 65 20 77 61 69 74 6f 6e 20 69 73 20 46 41 the waiton is FA
41f0: 49 4c 20 73 6f 20 6e 6f 20 70 6f 69 6e 74 20 69 IL so no point i
4200: 6e 20 74 72 79 69 6e 67 20 74 6f 20 72 75 6e 20 n trying to run
4210: 68 65 64 20 65 76 65 72 20 61 67 61 69 6e 0a 09 hed ever again..
4220: 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c ..(if (not (null
4230: 3f 20 74 61 6c 29 29 0a 09 09 09 20 20 20 20 28 ? tal)).... (
4240: 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 28 begin.... (
4250: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 57 debug:print 1 "W
4260: 41 52 4e 3a 20 44 72 6f 70 70 69 6e 67 20 74 65 ARN: Dropping te
4270: 73 74 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 st " (db:test-ge
4280: 74 2d 74 65 73 74 2d 6e 61 6d 65 20 68 65 64 29 t-test-name hed)
4290: 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 "/" (db:test-ge
42a0: 74 2d 69 74 65 6d 2d 70 61 74 68 20 68 65 64 29 t-item-path hed)
42b0: 0a 09 09 09 09 09 20 20 20 22 20 66 72 6f 6d 20 ...... " from
42c0: 74 68 65 20 6c 61 75 6e 63 68 20 6c 69 73 74 20 the launch list
42d0: 61 73 20 69 74 20 68 61 73 20 70 72 65 72 65 71 as it has prereq
42e0: 75 69 73 74 65 73 20 74 68 61 74 20 61 72 65 20 uistes that are
42f0: 46 41 49 4c 22 29 0a 09 09 09 20 20 20 20 20 20 FAIL")....
4300: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
4310: 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 29 cdr tal)))))))))
4320: 0a 09 20 20 20 20 20 0a 09 20 20 20 20 20 3b 3b .. .. ;;
4330: 20 63 61 73 65 20 77 68 65 72 65 20 61 6e 20 69 case where an i
4340: 74 65 6d 73 20 63 61 6d 65 20 69 6e 20 61 73 20 tems came in as
4350: 61 20 6c 69 73 74 20 62 65 65 6e 20 70 72 6f 63 a list been proc
4360: 65 73 73 65 64 0a 09 20 20 20 20 20 28 28 61 6e essed.. ((an
4370: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 d (list? items)
4380: 20 20 20 20 3b 3b 20 74 68 75 73 20 77 65 20 6b ;; thus we k
4390: 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 20 61 72 now our items ar
43a0: 65 20 61 6c 72 65 61 64 79 20 63 61 6c 63 75 6c e already calcul
43b0: 61 74 65 64 0a 09 09 20 20 20 28 6e 6f 74 20 20 ated... (not
43c0: 20 69 74 65 6d 64 61 74 29 29 20 3b 3b 20 61 6e itemdat)) ;; an
43d0: 64 20 6e 6f 74 20 79 65 74 20 65 78 70 61 6e 64 d not yet expand
43e0: 65 64 20 69 6e 74 6f 20 74 68 65 20 6c 69 73 74 ed into the list
43f0: 20 6f 66 20 74 68 69 6e 67 73 20 74 6f 20 62 65 of things to be
4400: 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 28 69 66 done.. (if
4410: 20 28 61 6e 64 20 28 3e 3d 20 2a 76 65 72 62 6f (and (>= *verbo
4420: 73 69 74 79 2a 20 31 29 0a 09 09 20 20 20 20 20 sity* 1)...
4430: 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 69 74 65 (> (length ite
4440: 6d 73 29 20 30 29 0a 09 09 20 20 20 20 20 20 20 ms) 0)...
4450: 28 3e 20 28 6c 65 6e 67 74 68 20 28 63 61 72 20 (> (length (car
4460: 69 74 65 6d 73 29 29 20 30 29 29 0a 09 09 20 20 items)) 0))...
4470: 28 70 70 20 69 74 65 6d 73 29 29 0a 09 20 20 20 (pp items))..
4480: 20 20 20 3b 3b 20 28 69 66 20 28 3e 3d 20 2a 76 ;; (if (>= *v
4490: 65 72 62 6f 73 69 74 79 2a 20 35 29 0a 09 20 20 erbosity* 5)..
44a0: 20 20 20 20 3b 3b 20 20 20 20 20 28 62 65 67 69 ;; (begi
44b0: 6e 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 20 20 n.. ;;
44c0: 20 20 28 70 72 69 6e 74 20 22 69 74 65 6d 73 3a (print "items:
44d0: 20 22 29 20 20 20 20 20 28 70 70 20 28 69 74 65 ") (pp (ite
44e0: 6d 2d 61 73 73 6f 63 2d 3e 69 74 65 6d 2d 6c 69 m-assoc->item-li
44f0: 73 74 20 69 74 65 6d 73 29 29 0a 09 20 20 20 20 st items))..
4500: 20 20 3b 3b 20 20 20 20 20 20 20 28 70 72 69 6e ;; (prin
4510: 74 20 22 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 t "itemstable: "
4520: 29 28 70 70 20 28 69 74 65 6d 2d 74 61 62 6c 65 )(pp (item-table
4530: 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d ->item-list item
4540: 73 74 61 62 6c 65 29 29 29 29 0a 09 20 20 20 20 stable))))..
4550: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 (for-each..
4560: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 79 2d (lambda (my-
4570: 69 74 65 6d 64 61 74 29 0a 09 09 20 28 6c 65 74 itemdat)... (let
4580: 2a 20 28 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 * ((new-test-rec
4590: 6f 72 64 20 28 6c 65 74 20 28 28 6e 65 77 72 65 ord (let ((newre
45a0: 63 20 28 6d 61 6b 65 2d 74 65 73 74 73 3a 74 65 c (make-tests:te
45b0: 73 74 71 75 65 75 65 29 29 29 0a 09 09 09 09 09 stqueue)))......
45c0: 20 20 20 28 76 65 63 74 6f 72 2d 63 6f 70 79 21 (vector-copy!
45d0: 20 74 65 73 74 2d 72 65 63 6f 72 64 20 6e 65 77 test-record new
45e0: 72 65 63 29 0a 09 09 09 09 09 20 20 20 6e 65 77 rec)...... new
45f0: 72 65 63 29 29 0a 09 09 09 28 6d 79 2d 69 74 65 rec))....(my-ite
4600: 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 m-path (item-lis
4610: 74 2d 3e 70 61 74 68 20 6d 79 2d 69 74 65 6d 64 t->path my-itemd
4620: 61 74 29 29 29 0a 09 09 20 20 20 28 69 66 20 28 at)))... (if (
4630: 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 patt-list-match
4640: 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 69 74 65 my-item-path ite
4650: 6d 2d 70 61 74 74 73 29 20 20 20 20 20 20 20 20 m-patts)
4660: 20 20 20 3b 3b 20 79 65 73 2c 20 77 65 20 77 61 ;; yes, we wa
4670: 6e 74 20 74 6f 20 70 72 6f 63 65 73 73 20 74 68 nt to process th
4680: 69 73 20 69 74 65 6d 2c 20 4e 4f 54 45 3a 20 53 is item, NOTE: S
4690: 68 6f 75 6c 64 20 6e 6f 74 20 6e 65 65 64 20 74 hould not need t
46a0: 68 69 73 20 63 68 65 63 6b 20 68 65 72 65 21 0a his check here!.
46b0: 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
46c0: 6e 65 77 74 65 73 74 6e 61 6d 65 20 28 63 6f 6e newtestname (con
46d0: 63 20 68 65 64 20 22 2f 22 20 6d 79 2d 69 74 65 c hed "/" my-ite
46e0: 6d 2d 70 61 74 68 29 29 29 20 20 20 20 3b 3b 20 m-path))) ;;
46f0: 74 65 73 74 20 6e 61 6d 65 73 20 61 72 65 20 75 test names are u
4700: 6e 69 71 75 65 20 6f 6e 20 74 65 73 74 6e 61 6d nique on testnam
4710: 65 2f 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 20 e/item-path....
4720: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
4730: 2d 73 65 74 2d 69 74 65 6d 73 21 20 20 20 20 20 -set-items!
4740: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 new-test-record
4750: 23 66 29 0a 09 09 09 20 28 74 65 73 74 73 3a 74 #f).... (tests:t
4760: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
4770: 6d 64 61 74 21 20 20 20 6e 65 77 2d 74 65 73 74 mdat! new-test
4780: 2d 72 65 63 6f 72 64 20 6d 79 2d 69 74 65 6d 64 -record my-itemd
4790: 61 74 29 0a 09 09 09 20 28 74 65 73 74 73 3a 74 at).... (tests:t
47a0: 65 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 estqueue-set-ite
47b0: 6d 5f 70 61 74 68 21 20 6e 65 77 2d 74 65 73 74 m_path! new-test
47c0: 2d 72 65 63 6f 72 64 20 6d 79 2d 69 74 65 6d 2d -record my-item-
47d0: 70 61 74 68 29 0a 09 09 09 20 28 68 61 73 68 2d path).... (hash-
47e0: 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 74 2d table-set! test-
47f0: 72 65 63 6f 72 64 73 20 6e 65 77 74 65 73 74 6e records newtestn
4800: 61 6d 65 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 ame new-test-rec
4810: 6f 72 64 29 0a 09 09 09 20 28 73 65 74 21 20 74 ord).... (set! t
4820: 61 6c 20 28 63 6f 6e 73 20 6e 65 77 74 65 73 74 al (cons newtest
4830: 6e 61 6d 65 20 74 61 6c 29 29 29 29 29 29 20 3b name tal)))))) ;
4840: 3b 20 73 69 6e 63 65 20 74 68 65 73 65 20 61 72 ; since these ar
4850: 65 20 69 74 65 6d 69 7a 65 64 20 63 72 65 61 74 e itemized creat
4860: 65 20 6e 65 77 20 74 65 73 74 20 6e 61 6d 65 73 e new test names
4870: 20 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d 70 61 testname/itempa
4880: 74 68 0a 09 20 20 20 20 20 20 20 69 74 65 6d 73 th.. items
4890: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f ).. (if (no
48a0: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
48b0: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
48c0: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 0a 0a l)(cdr tal))))..
48d0: 09 20 20 20 20 20 3b 3b 20 69 66 20 69 74 65 6d . ;; if item
48e0: 73 20 69 73 20 61 20 70 72 6f 63 20 74 68 65 6e s is a proc then
48f0: 20 6e 65 65 64 20 74 6f 20 72 75 6e 20 69 74 65 need to run ite
4900: 6d 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f ms:get-items-fro
4910: 6d 2d 63 6f 6e 66 69 67 2c 20 67 65 74 20 74 68 m-config, get th
4920: 65 20 6c 69 73 74 20 61 6e 64 20 6c 6f 6f 70 20 e list and loop
4930: 0a 09 20 20 20 20 20 3b 3b 20 20 20 20 2d 20 62 .. ;; - b
4940: 75 74 20 6f 6e 6c 79 20 64 6f 20 74 68 61 74 20 ut only do that
4950: 69 66 20 72 65 73 6f 75 72 63 65 73 20 65 78 69 if resources exi
4960: 73 74 20 74 6f 20 6b 69 63 6b 20 6f 66 66 20 74 st to kick off t
4970: 68 65 20 6a 6f 62 0a 09 20 20 20 20 20 28 28 6f he job.. ((o
4980: 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 r (procedure? it
4990: 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 20 27 ems)(eq? items '
49a0: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 29 have-procedure))
49b0: 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 .. (let ((c
49c0: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 20 20 20 20 28 an-run-more (
49d0: 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 runs:can-run-mor
49e0: 65 2d 74 65 73 74 73 20 64 62 20 74 65 73 74 2d e-tests db test-
49f0: 72 65 63 6f 72 64 29 29 29 0a 09 09 28 69 66 20 record)))...(if
4a00: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 20 can-run-more...
4a10: 20 20 20 28 6c 65 74 2a 20 28 28 70 72 65 72 65 (let* ((prere
4a20: 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 64 62 3a 67 qs-not-met (db:g
4a30: 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d et-prereqs-not-m
4a40: 65 74 20 64 62 20 72 75 6e 2d 69 64 20 77 61 69 et db run-id wai
4a50: 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 68 20 6d tons item-path m
4a60: 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 29 29 0a ode: testmode)).
4a70: 09 09 09 20 20 20 28 66 61 69 6c 73 20 20 20 20 ... (fails
4a80: 20 20 20 20 20 20 20 28 63 61 6c 63 2d 66 61 69 (calc-fai
4a90: 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ls prereqs-not-m
4aa0: 65 74 29 29 0a 09 09 09 20 20 20 28 6e 6f 6e 2d et)).... (non-
4ab0: 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 63 61 6c completed (cal
4ac0: 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 64 20 c-not-completed
4ad0: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
4ae0: 29 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 ))... (debu
4af0: 67 3a 70 72 69 6e 74 20 38 20 22 49 4e 46 4f 3a g:print 8 "INFO:
4b00: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 3a 20 22 can-run-more: "
4b10: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 0a 09 09 can-run-more...
4b20: 09 09 20 20 20 22 5c 6e 20 70 72 65 72 65 71 73 .. "\n prereqs
4b30: 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 28 70 72 65 -not-met: " (pre
4b40: 74 74 79 2d 73 74 72 69 6e 67 20 70 72 65 72 65 tty-string prere
4b50: 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 09 09 09 qs-not-met).....
4b60: 20 20 20 22 5c 6e 20 6e 6f 6e 2d 63 6f 6d 70 6c "\n non-compl
4b70: 65 74 65 64 3a 20 20 20 22 20 28 70 72 65 74 74 eted: " (prett
4b80: 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d 63 6f 6d y-string non-com
4b90: 70 6c 65 74 65 64 29 20 0a 09 09 09 09 20 20 20 pleted) .....
4ba0: 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 20 "\n fails:
4bb0: 20 20 20 20 20 22 20 28 70 72 65 74 74 79 2d 73 " (pretty-s
4bc0: 74 72 69 6e 67 20 66 61 69 6c 73 29 0a 09 09 09 tring fails)....
4bd0: 09 20 20 20 22 5c 6e 20 74 65 73 74 6d 6f 64 65 . "\n testmode
4be0: 3a 20 20 20 20 20 20 20 20 22 20 74 65 73 74 6d : " testm
4bf0: 6f 64 65 0a 09 09 09 09 20 20 20 22 5c 6e 20 28 ode..... "\n (
4c00: 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f eq? testmode 'to
4c10: 70 6c 65 76 65 6c 29 20 22 20 28 65 71 3f 20 74 plevel) " (eq? t
4c20: 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c 65 76 65 estmode 'topleve
4c30: 6c 29 0a 09 09 09 09 20 20 20 22 5c 6e 20 28 6e l)..... "\n (n
4c40: 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 ull? non-complet
4c50: 65 64 29 20 20 20 20 22 20 28 6e 75 6c 6c 3f 20 ed) " (null?
4c60: 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 29 29 0a non-completed)).
4c70: 09 09 20 20 20 20 20 20 28 63 6f 6e 64 20 0a 09 .. (cond ..
4c80: 09 20 20 20 20 20 20 20 28 28 6f 72 20 28 6e 75 . ((or (nu
4c90: 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d ll? prereqs-not-
4ca0: 6d 65 74 29 20 3b 3b 20 61 6c 6c 20 70 72 65 72 met) ;; all prer
4cb0: 65 71 73 20 6d 65 74 2c 20 66 69 72 65 20 6f 66 eqs met, fire of
4cc0: 66 20 74 68 65 20 74 65 73 74 0a 09 09 09 20 20 f the test....
4cd0: 20 20 3b 3b 20 6f 72 2c 20 69 66 20 69 74 20 69 ;; or, if it i
4ce0: 73 20 61 20 27 74 6f 70 6c 65 76 65 6c 20 74 65 s a 'toplevel te
4cf0: 73 74 20 61 6e 64 20 61 6c 6c 20 70 72 65 72 65 st and all prere
4d00: 71 73 20 6e 6f 74 20 6d 65 74 20 61 72 65 20 43 qs not met are C
4d10: 4f 4d 50 4c 45 54 45 44 20 74 68 65 6e 20 6c 61 OMPLETED then la
4d20: 75 6e 63 68 0a 09 09 09 20 20 20 20 28 61 6e 64 unch.... (and
4d30: 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 (eq? testmode '
4d40: 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 09 20 28 toplevel)..... (
4d50: 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 null? non-comple
4d60: 74 65 64 29 29 29 0a 09 09 09 28 6c 65 74 20 28 ted)))....(let (
4d70: 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 65 73 74 (test-name (test
4d80: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
4d90: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 2d 72 65 testname test-re
4da0: 63 6f 72 64 29 29 29 0a 09 09 09 20 20 28 73 65 cord))).... (se
4db0: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 tenv "MT_TEST_NA
4dc0: 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 20 3b ME" test-name) ;
4dd0: 3b 20 0a 09 09 09 20 20 28 73 65 74 65 6e 76 20 ; .... (setenv
4de0: 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 "MT_RUNNAME" r
4df0: 75 6e 6e 61 6d 65 29 0a 09 09 09 20 20 28 73 65 unname).... (se
4e00: 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 t-megatest-env-v
4e10: 61 72 73 20 64 62 20 72 75 6e 2d 69 64 29 20 3b ars db run-id) ;
4e20: 3b 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e ; these may be n
4e30: 65 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 eeded by the lau
4e40: 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 09 nching process..
4e50: 09 09 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 .. (let ((items
4e60: 2d 6c 69 73 74 20 28 69 74 65 6d 73 3a 67 65 74 -list (items:get
4e70: 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 -items-from-conf
4e80: 69 67 20 74 63 6f 6e 66 69 67 29 29 29 0a 09 09 ig tconfig)))...
4e90: 09 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 . (if (list?
4ea0: 69 74 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 items-list).....
4eb0: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 28 74 65 (begin..... (te
4ec0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
4ed0: 74 2d 69 74 65 6d 73 21 20 74 65 73 74 2d 72 65 t-items! test-re
4ee0: 63 6f 72 64 20 69 74 65 6d 73 2d 6c 69 73 74 29 cord items-list)
4ef0: 0a 09 09 09 09 20 20 28 6c 6f 6f 70 20 68 65 64 ..... (loop hed
4f00: 20 74 61 6c 29 29 0a 09 09 09 09 28 62 65 67 69 tal)).....(begi
4f10: 6e 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 n..... (debug:p
4f20: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 rint 0 "ERROR: T
4f30: 68 65 20 70 72 6f 63 20 66 72 6f 6d 20 72 65 61 he proc from rea
4f40: 64 69 6e 67 20 74 68 65 20 73 65 74 75 70 20 64 ding the setup d
4f50: 69 64 20 6e 6f 74 20 79 69 65 6c 64 20 61 20 6c id not yield a l
4f60: 69 73 74 20 2d 20 70 6c 65 61 73 65 20 72 65 70 ist - please rep
4f70: 6f 72 74 20 74 68 69 73 22 29 0a 09 09 09 09 20 ort this").....
4f80: 20 28 65 78 69 74 20 31 29 29 29 29 29 29 0a 09 (exit 1))))))..
4f90: 09 20 20 20 20 20 20 20 28 28 6e 75 6c 6c 3f 20 . ((null?
4fa0: 66 61 69 6c 73 29 0a 09 09 09 28 6c 6f 6f 70 20 fails)....(loop
4fb0: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
4fc0: 20 6e 65 77 74 61 6c 29 29 29 20 3b 3b 20 61 6e newtal))) ;; an
4fd0: 20 69 73 73 75 65 20 77 69 74 68 20 70 72 65 72 issue with prer
4fe0: 65 71 73 20 6e 6f 74 20 79 65 74 20 6d 65 74 3f eqs not yet met?
4ff0: 0a 09 09 20 20 20 20 20 20 20 28 28 61 6e 64 20 ... ((and
5000: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 66 61 69 6c (not (null? fail
5010: 73 29 29 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 s))(eq? testmode
5020: 20 27 6e 6f 72 6d 61 6c 29 29 0a 09 09 09 28 64 'normal))....(d
5030: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e ebug:print 1 "IN
5040: 46 4f 3a 20 74 65 73 74 20 22 20 20 68 65 64 20 FO: test " hed
5050: 22 20 28 6d 6f 64 65 3d 22 20 74 65 73 74 6d 6f " (mode=" testmo
5060: 64 65 20 22 29 20 68 61 73 20 66 61 69 6c 65 64 de ") has failed
5070: 20 70 72 65 72 65 71 75 69 73 69 74 65 28 73 29 prerequisite(s)
5080: 3b 20 22 0a 09 09 09 09 20 20 20 20 20 28 73 74 ; "..... (st
5090: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
50a0: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 (map (lambda (t
50b0: 29 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 2d )(conc (db:test-
50c0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 29 20 get-testname t)
50d0: 22 3a 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ":" (db:test-get
50e0: 2d 73 74 61 74 65 20 74 29 22 2f 22 28 64 62 3a -state t)"/"(db:
50f0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
5100: 74 29 29 29 20 66 61 69 6c 73 29 20 22 2c 20 22 t))) fails) ", "
5110: 29 0a 09 09 09 09 20 20 20 20 20 22 2c 20 72 65 )..... ", re
5120: 6d 6f 76 69 6e 67 20 69 74 20 66 72 6f 6d 20 74 moving it from t
5130: 6f 2d 64 6f 20 6c 69 73 74 22 29 0a 09 09 09 28 o-do list")....(
5140: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
5150: 61 6c 29 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f al)).... (loo
5160: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
5170: 74 61 6c 29 29 29 29 0a 09 09 20 20 20 20 20 20 tal))))...
5180: 20 28 65 6c 73 65 0a 09 09 09 28 64 65 62 75 67 (else....(debug
5190: 3a 70 72 69 6e 74 20 38 20 22 45 52 52 4f 52 3a :print 8 "ERROR:
51a0: 20 4e 6f 20 68 61 6e 64 6c 65 72 20 66 6f 72 20 No handler for
51b0: 74 68 69 73 20 63 6f 6e 64 69 74 69 6f 6e 2e 22 this condition."
51c0: 29 0a 09 09 09 3b 3b 20 09 20 20 20 20 20 22 5c )....;; . "\
51d0: 6e 20 20 68 65 64 3a 20 20 20 20 20 20 20 20 20 n hed:
51e0: 20 20 20 22 20 68 65 64 20 0a 09 09 09 3b 3b 20 " hed ....;;
51f0: 09 20 20 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a . "\n fails:
5200: 20 20 20 20 20 20 20 20 20 20 20 22 20 28 73 74 " (st
5210: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
5220: 20 28 6d 61 70 20 64 62 3a 74 65 73 74 2d 67 65 (map db:test-ge
5230: 74 2d 74 65 73 74 6e 61 6d 65 20 66 61 69 6c 73 t-testname fails
5240: 29 20 22 2c 22 29 0a 09 09 09 3b 3b 20 09 20 20 ) ",")....;; .
5250: 20 20 20 22 5c 6e 20 74 65 73 74 6d 6f 64 65 3a "\n testmode:
5260: 20 20 20 20 20 20 20 20 22 20 74 65 73 74 6d 6f " testmo
5270: 64 65 0a 09 09 09 3b 3b 20 09 20 20 20 20 20 22 de....;; . "
5280: 5c 6e 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d \n prereqs-not-m
5290: 65 74 3a 20 22 20 28 70 72 65 74 74 79 2d 73 74 et: " (pretty-st
52a0: 72 69 6e 67 20 70 72 65 72 65 71 73 2d 6e 6f 74 ring prereqs-not
52b0: 2d 6d 65 74 29 0a 09 09 09 3b 3b 20 09 20 20 20 -met)....;; .
52c0: 20 20 22 5c 6e 20 69 74 65 6d 73 3a 20 20 20 20 "\n items:
52d0: 20 20 20 20 20 20 20 22 20 69 74 65 6d 73 29 0a " items).
52e0: 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 ...(loop (car ne
52f0: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal
5300: 29 29 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 69 )))))... ;; i
5310: 66 20 63 61 6e 27 74 20 72 75 6e 20 6d 6f 72 65 f can't run more
5320: 20 6a 75 73 74 20 6c 6f 6f 70 20 77 69 74 68 20 just loop with
5330: 6e 65 78 74 20 70 6f 73 73 69 62 6c 65 20 74 65 next possible te
5340: 73 74 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 st... (loop (
5350: 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 20 car newtal)(cdr
5360: 6e 65 77 74 61 6c 29 29 29 29 29 0a 09 20 20 20 newtal)))))..
5370: 20 20 0a 09 20 20 20 20 20 3b 3b 20 74 68 69 73 .. ;; this
5380: 20 63 61 73 65 20 73 68 6f 75 6c 64 20 6e 6f 74 case should not
5390: 20 68 61 70 70 65 6e 2c 20 61 64 64 65 64 20 74 happen, added t
53a0: 6f 20 68 65 6c 70 20 63 61 74 63 68 20 61 6e 79 o help catch any
53b0: 20 62 75 67 73 0a 09 20 20 20 20 20 28 28 61 6e bugs.. ((an
53c0: 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 d (list? items)
53d0: 69 74 65 6d 64 61 74 29 0a 09 20 20 20 20 20 20 itemdat)..
53e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
53f0: 45 52 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f ERROR: Should no
5400: 74 20 68 61 76 65 20 61 20 6c 69 73 74 20 6f 66 t have a list of
5410: 20 69 74 65 6d 73 20 69 6e 20 61 20 74 65 73 74 items in a test
5420: 20 61 6e 64 20 74 68 65 20 69 74 65 6d 73 70 61 and the itemspa
5430: 74 68 20 73 65 74 20 2d 20 70 6c 65 61 73 65 20 th set - please
5440: 72 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 20 report this")..
5450: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 (exit 1))))
5460: 0a 09 20 20 0a 09 20 20 3b 3b 20 77 65 20 67 65 .. .. ;; we ge
5470: 74 20 68 65 72 65 20 6f 6e 20 22 64 72 6f 70 20 t here on "drop
5480: 74 68 72 6f 75 67 68 22 20 2d 20 6c 6f 6f 70 20 through" - loop
5490: 66 6f 72 20 6e 65 78 74 20 74 65 73 74 20 69 6e for next test in
54a0: 20 71 75 65 75 65 0a 09 20 20 28 69 66 20 28 6e queue.. (if (n
54b0: 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 20 ull? tal)..
54c0: 20 28 62 65 67 69 6e 0a 09 09 3b 3b 20 46 49 58 (begin...;; FIX
54d0: 4d 45 21 21 21 21 20 54 48 49 53 20 53 48 4f 55 ME!!!! THIS SHOU
54e0: 4c 44 20 4e 4f 54 20 52 45 51 55 49 52 45 20 41 LD NOT REQUIRE A
54f0: 4e 20 45 58 49 54 21 21 21 21 21 21 21 0a 09 09 N EXIT!!!!!!!...
5500: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
5510: 49 4e 46 4f 3a 20 41 6c 6c 20 74 65 73 74 73 20 INFO: All tests
5520: 6c 61 75 6e 63 68 65 64 22 29 0a 09 09 28 74 68 launched")...(th
5530: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 35 29 read-sleep! 0.5)
5540: 0a 09 09 3b 3b 20 46 49 58 4d 45 21 20 54 68 69 ...;; FIXME! Thi
5550: 73 20 68 61 72 73 68 20 65 78 69 74 20 73 68 6f s harsh exit sho
5560: 75 6c 64 20 6e 6f 74 20 62 65 20 6e 65 63 65 73 uld not be neces
5570: 73 61 72 79 2e 2e 2e 2e 0a 09 09 28 69 66 20 28 sary.......(if (
5580: 6e 6f 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 not *runremote*)
5590: 28 65 78 69 74 29 29 20 3b 3b 20 0a 09 09 23 66 (exit)) ;; ...#f
55a0: 29 20 3b 3b 20 72 65 74 75 72 6e 20 61 20 23 66 ) ;; return a #f
55b0: 20 61 73 20 61 20 68 69 6e 74 20 74 68 61 74 20 as a hint that
55c0: 77 65 20 61 72 65 20 64 6f 6e 65 0a 09 20 20 20 we are done..
55d0: 20 20 20 3b 3b 20 48 65 72 65 20 77 65 20 6e 65 ;; Here we ne
55e0: 65 64 20 74 6f 20 63 68 65 63 6b 20 74 68 61 74 ed to check that
55f0: 20 61 6c 6c 20 74 68 65 20 74 65 73 74 73 20 72 all the tests r
5600: 65 6d 61 69 6e 69 6e 67 20 74 6f 20 62 65 20 72 emaining to be r
5610: 75 6e 20 61 72 65 20 65 6c 69 67 69 62 6c 65 20 un are eligible
5620: 74 6f 20 72 75 6e 0a 09 20 20 20 20 20 20 3b 3b to run.. ;;
5630: 20 61 6e 64 20 61 72 65 20 6e 6f 74 20 62 6c 6f and are not blo
5640: 63 6b 65 64 20 62 79 20 66 61 69 6c 65 64 0a 09 cked by failed..
5650: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 (let ((new
5660: 6c 73 74 20 28 74 65 73 74 73 3a 66 69 6c 74 65 lst (tests:filte
5670: 72 2d 6e 6f 6e 2d 72 75 6e 6e 61 62 6c 65 20 64 r-non-runnable d
5680: 62 20 72 75 6e 2d 69 64 20 74 61 6c 20 74 65 73 b run-id tal tes
5690: 74 2d 72 65 63 6f 72 64 73 29 29 29 20 3b 3b 20 t-records))) ;;
56a0: 69 2e 65 2e 20 6e 6f 74 20 46 41 49 4c 2c 20 57 i.e. not FAIL, W
56b0: 41 49 56 45 44 2c 20 49 4e 43 4f 4d 50 4c 45 54 AIVED, INCOMPLET
56c0: 45 2c 20 50 41 53 53 2c 20 4b 49 4c 4c 45 44 2c E, PASS, KILLED,
56d0: 0a 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
56e0: 21 20 30 2e 31 29 0a 09 09 28 69 66 20 28 6e 6f ! 0.1)...(if (no
56f0: 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 6c 73 74 29 t (null? newlst)
5700: 29 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 )... (loop (c
5710: 61 72 20 6e 65 77 6c 73 74 29 28 63 64 72 20 6e ar newlst)(cdr n
5720: 65 77 6c 73 74 29 29 29 29 29 29 29 29 29 0a 0a ewlst)))))))))..
5730: 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 20 69 ;; parent-test i
5740: 73 20 74 68 65 72 65 20 61 73 20 61 20 70 6c 61 s there as a pla
5750: 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 ceholder for whe
5760: 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 73 20 63 n parent-tests c
5770: 61 6e 20 62 65 20 72 75 6e 20 61 73 20 61 20 73 an be run as a s
5780: 65 74 75 70 20 73 74 65 70 0a 28 64 65 66 69 6e etup step.(defin
5790: 65 20 28 72 75 6e 3a 74 65 73 74 20 64 62 20 72 e (run:test db r
57a0: 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 un-id runname ke
57b0: 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 yvallst test-rec
57c0: 6f 72 64 20 66 6c 61 67 73 20 70 61 72 65 6e 74 ord flags parent
57d0: 2d 74 65 73 74 29 0a 20 20 3b 3b 20 41 6c 6c 20 -test). ;; All
57e0: 74 68 65 73 65 20 76 61 72 73 20 6d 69 67 68 74 these vars might
57f0: 20 62 65 20 72 65 66 65 72 65 6e 63 65 64 20 62 be referenced b
5800: 79 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 67 y the testconfig
5810: 20 66 69 6c 65 20 72 65 61 64 65 72 0a 20 20 28 file reader. (
5820: 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d 65 let* ((test-name
5830: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
5840: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
5850: 65 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 e test-record)
5860: 29 0a 09 20 28 74 65 73 74 2d 77 61 69 74 6f 6e ).. (test-waiton
5870: 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 s (tests:testque
5880: 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 20 ue-get-waitons
5890: 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a test-record)).
58a0: 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 20 . (test-conf
58b0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
58c0: 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 -get-testconfig
58d0: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 test-record))..
58e0: 28 69 74 65 6d 64 61 74 20 20 20 20 20 20 28 74 (itemdat (t
58f0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
5900: 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 74 65 et-itemdat te
5910: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 74 st-record)).. (t
5920: 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e est-path (con
5930: 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 c *toppath* "/te
5940: 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 sts/" test-name)
5950: 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 74 ) ;; could use t
5960: 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e ests:get-testcon
5970: 66 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 28 fig here ..... (
5980: 66 6f 72 63 65 20 20 20 20 20 20 20 20 28 68 61 force (ha
5990: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
59a0: 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 66 6f 72 ault flags "-for
59b0: 63 65 22 20 23 66 29 29 0a 09 20 28 72 65 72 75 ce" #f)).. (reru
59c0: 6e 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 n (hash-t
59d0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
59e0: 20 66 6c 61 67 73 20 22 2d 72 65 72 75 6e 22 20 flags "-rerun"
59f0: 23 66 29 29 0a 09 20 28 6b 65 65 70 67 6f 69 6e #f)).. (keepgoin
5a00: 67 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 g (hash-table
5a10: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 -ref/default fla
5a20: 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 20 gs "-keepgoing"
5a30: 23 66 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 74 #f)).. (item-pat
5a40: 68 20 20 20 20 20 22 22 29 29 0a 20 20 20 20 28 h "")). (
5a50: 64 65 62 75 67 3a 70 72 69 6e 74 20 35 0a 09 09 debug:print 5...
5a60: 20 22 74 65 73 74 2d 63 6f 6e 66 69 67 3a 20 22 "test-config: "
5a70: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
5a80: 69 73 74 20 74 65 73 74 2d 63 6f 6e 66 29 0a 09 ist test-conf)..
5a90: 09 20 22 5c 6e 20 20 20 69 74 65 6d 64 61 74 3a . "\n itemdat:
5aa0: 20 22 20 69 74 65 6d 64 61 74 0a 09 09 20 29 0a " itemdat... ).
5ab0: 20 20 20 20 3b 3b 20 73 65 74 74 69 6e 67 20 69 ;; setting i
5ac0: 74 65 6d 64 61 74 20 74 6f 20 61 20 6c 69 73 74 temdat to a list
5ad0: 20 69 66 20 69 74 20 69 73 20 23 66 0a 20 20 20 if it is #f.
5ae0: 20 28 69 66 20 28 6e 6f 74 20 69 74 65 6d 64 61 (if (not itemda
5af0: 74 29 28 73 65 74 21 20 69 74 65 6d 64 61 74 20 t)(set! itemdat
5b00: 27 28 29 29 29 0a 20 20 20 20 28 73 65 74 21 20 '())). (set!
5b10: 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d item-path (item-
5b20: 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 list->path itemd
5b30: 61 74 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a at)). (debug:
5b40: 70 72 69 6e 74 20 32 20 22 41 74 74 65 6d 70 74 print 2 "Attempt
5b50: 69 6e 67 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 ing to launch te
5b60: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name "
5b70: 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 /" item-path).
5b80: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 (setenv "MT_TE
5b90: 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 ST_NAME" test-na
5ba0: 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 73 65 74 me) ;; . (set
5bb0: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
5bc0: 20 20 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 runname).
5bd0: 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e (set-megatest-en
5be0: 76 2d 76 61 72 73 20 64 62 20 72 75 6e 2d 69 64 v-vars db run-id
5bf0: 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 20 62 ) ;; these may b
5c00: 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 65 20 e needed by the
5c10: 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 launching proces
5c20: 73 0a 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 s. (change-di
5c30: 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 rectory *toppath
5c40: 2a 29 0a 0a 20 20 20 20 3b 3b 20 48 65 72 65 20 *).. ;; Here
5c50: 69 73 20 77 68 65 72 65 20 74 68 65 20 74 65 73 is where the tes
5c60: 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 69 73 20 t_meta table is
5c70: 62 65 73 74 20 75 70 64 61 74 65 64 0a 20 20 20 best updated.
5c80: 20 3b 3b 20 59 65 73 2c 20 61 6e 6f 74 68 65 72 ;; Yes, another
5c90: 20 75 73 65 20 6f 66 20 61 20 67 6c 6f 62 61 6c use of a global
5ca0: 20 66 6f 72 20 63 61 63 68 69 6e 67 2e 20 4e 65 for caching. Ne
5cb0: 65 64 20 61 20 62 65 74 74 65 72 20 77 61 79 3f ed a better way?
5cc0: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 . (if (not (h
5cd0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5ce0: 66 61 75 6c 74 20 2a 74 65 73 74 2d 6d 65 74 61 fault *test-meta
5cf0: 2d 75 70 64 61 74 65 64 2a 20 74 65 73 74 2d 6e -updated* test-n
5d00: 61 6d 65 20 23 66 29 29 0a 20 20 20 20 20 20 20 ame #f)).
5d10: 20 28 62 65 67 69 6e 0a 09 20 20 20 28 68 61 73 (begin.. (has
5d20: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 65 h-table-set! *te
5d30: 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a st-meta-updated*
5d40: 20 74 65 73 74 2d 6e 61 6d 65 20 23 74 29 0a 20 test-name #t).
5d50: 20 20 20 20 20 20 20 20 20 20 28 72 75 6e 73 3a (runs:
5d60: 75 70 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 update-test_meta
5d70: 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 db test-name te
5d80: 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 0a st-conf))). .
5d90: 20 20 20 20 3b 3b 20 28 6c 61 6d 62 64 61 20 28 ;; (lambda (
5da0: 69 74 65 6d 64 61 74 29 20 3b 3b 3b 20 28 28 72 itemdat) ;;; ((r
5db0: 69 70 65 6e 65 73 73 20 22 6f 76 65 72 72 69 70 ipeness "overrip
5dc0: 65 22 29 20 28 74 65 6d 70 65 72 61 74 75 72 65 e") (temperature
5dd0: 20 22 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e "cool") (season
5de0: 20 22 73 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 "summer")).
5df0: 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 (let* ((new-test
5e00: 2d 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e -path (string-in
5e10: 74 65 72 73 70 65 72 73 65 20 28 63 6f 6e 73 20 tersperse (cons
5e20: 74 65 73 74 2d 70 61 74 68 20 28 6d 61 70 20 63 test-path (map c
5e30: 61 64 72 20 69 74 65 6d 64 61 74 29 29 20 22 2f adr itemdat)) "/
5e40: 22 29 29 0a 09 20 20 20 28 6e 65 77 2d 74 65 73 ")).. (new-tes
5e50: 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 t-name (if (equa
5e60: 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 l? item-path "")
5e70: 20 74 65 73 74 2d 6e 61 6d 65 20 28 63 6f 6e 63 test-name (conc
5e80: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
5e90: 74 65 6d 2d 70 61 74 68 29 29 29 20 3b 3b 20 6a tem-path))) ;; j
5ea0: 75 73 74 20 6e 65 65 64 20 69 74 20 74 6f 20 62 ust need it to b
5eb0: 65 20 75 6e 69 71 75 65 0a 09 20 20 20 28 74 65 e unique.. (te
5ec0: 73 74 64 61 74 20 20 20 20 20 20 20 28 64 62 3a stdat (db:
5ed0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 20 64 62 get-test-info db
5ee0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
5ef0: 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 e item-path))..
5f00: 20 20 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 (test-id
5f10: 20 23 66 29 29 0a 20 20 20 20 20 20 28 69 66 20 #f)). (if
5f20: 28 6e 6f 74 20 74 65 73 74 64 61 74 29 0a 09 20 (not testdat)..
5f30: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 3b 3b 20 (begin.. ;;
5f40: 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 65 20 ensure that the
5f50: 70 61 74 68 20 65 78 69 73 74 73 20 62 65 66 6f path exists befo
5f60: 72 65 20 72 65 67 69 73 74 65 72 69 6e 67 20 74 re registering t
5f70: 68 65 20 74 65 73 74 0a 09 20 20 20 20 3b 3b 20 he test.. ;;
5f80: 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 21 20 44 6f NOPE: Cannot! Do
5f90: 6e 27 74 20 6b 6e 6f 77 20 79 65 74 20 77 68 69 n't know yet whi
5fa0: 63 68 20 64 69 73 6b 20 61 72 65 61 20 77 69 6c ch disk area wil
5fb0: 6c 20 62 65 20 61 73 73 69 67 6e 65 64 2e 2e 2e l be assigned...
5fc0: 2e 0a 09 20 20 20 20 3b 3b 20 28 73 79 73 74 65 ... ;; (syste
5fd0: 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 2d m (conc "mkdir -
5fe0: 70 20 22 20 6e 65 77 2d 74 65 73 74 2d 70 61 74 p " new-test-pat
5ff0: 68 29 29 0a 09 20 20 20 20 28 72 74 65 73 74 73 h)).. (rtests
6000: 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 20 64 :register-test d
6010: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 b run-id test-na
6020: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 me item-path)..
6030: 20 20 20 28 73 65 74 21 20 74 65 73 74 64 61 74 (set! testdat
6040: 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e (db:get-test-in
6050: 66 6f 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 fo db run-id tes
6060: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
6070: 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 )))). (set!
6080: 20 74 65 73 74 2d 69 64 20 28 64 62 3a 74 65 73 test-id (db:tes
6090: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
60a0: 29 29 0a 20 20 20 20 20 20 28 63 68 61 6e 67 65 )). (change
60b0: 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d -directory test-
60c0: 70 61 74 68 29 0a 20 20 20 20 20 20 28 63 61 73 path). (cas
60d0: 65 20 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 28 e (if force ;; (
60e0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 args:get-arg "-f
60f0: 6f 72 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 54 orce")...'NOT_ST
6100: 41 52 54 45 44 0a 09 09 28 69 66 20 74 65 73 74 ARTED...(if test
6110: 64 61 74 0a 09 09 20 20 20 20 28 73 74 72 69 6e dat... (strin
6120: 67 2d 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 3a g->symbol (test:
6130: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
6140: 74 29 29 0a 09 09 20 20 20 20 27 66 61 69 6c 65 t))... 'faile
6150: 64 2d 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 28 d-to-insert))..(
6160: 28 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 (failed-to-inser
6170: 74 29 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e t).. (debug:prin
6180: 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c t 0 "ERROR: Fail
6190: 65 64 20 74 6f 20 69 6e 73 65 72 74 20 74 68 65 ed to insert the
61a0: 20 72 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 65 record into the
61b0: 20 64 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 54 db"))..((NOT_ST
61c0: 41 52 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 29 ARTED COMPLETED)
61d0: 0a 09 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 .. (let ((runfla
61e0: 67 20 23 66 29 29 0a 09 20 20 20 28 63 6f 6e 64 g #f)).. (cond
61f0: 0a 09 20 20 20 20 3b 3b 20 2d 66 6f 72 63 65 2c .. ;; -force,
6200: 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 run no matter w
6210: 68 61 74 0a 09 20 20 20 20 28 66 6f 72 63 65 20 hat.. (force
6220: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
6230: 29 29 0a 09 20 20 20 20 3b 3b 20 4e 4f 54 5f 53 )).. ;; NOT_S
6240: 54 41 52 54 45 44 2c 20 72 75 6e 20 6e 6f 20 6d TARTED, run no m
6250: 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 atter what..
6260: 28 28 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 ((equal? (test:g
6270: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
6280: 29 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 ) "NOT_STARTED")
6290: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
62a0: 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 2d )).. ;; not -
62b0: 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 2c 20 rerun and PASS,
62c0: 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 64 WARN or CHECK, d
62d0: 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 28 o no run.. ((
62e0: 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 72 and (or (not rer
62f0: 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 65 70 un)... keep
6300: 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 65 going)... ;; Re
6310: 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 20 72 quire to force r
6320: 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 e-run for COMPLE
6330: 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e 67 TED or *anything
6340: 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f 72 * + PASS,WARN or
6350: 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 28 CHECK... (or (
6360: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
6370: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
6380: 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 '("PASS" "WARN"
6390: 20 22 43 48 45 43 4b 22 29 29 0a 09 09 20 20 20 "CHECK"))...
63a0: 20 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 (member (test
63b0: 3a 67 65 74 2d 73 74 61 74 65 20 20 74 65 73 74 :get-state test
63c0: 64 61 74 29 20 27 28 22 43 4f 4d 50 4c 45 54 45 dat) '("COMPLETE
63d0: 44 22 29 29 29 29 20 0a 09 20 20 20 20 20 28 64 D")))) .. (d
63e0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 4e ebug:print 2 "IN
63f0: 46 4f 3a 20 72 75 6e 6e 69 6e 67 20 74 65 73 74 FO: running test
6400: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 " test-name "/"
6410: 20 69 74 65 6d 2d 70 61 74 68 20 22 20 73 75 70 item-path " sup
6420: 70 72 65 73 73 65 64 20 61 73 20 69 74 20 69 73 pressed as it is
6430: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
6440: 74 65 20 74 65 73 74 64 61 74 29 20 22 20 61 6e te testdat) " an
6450: 64 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 d " (test:get-st
6460: 61 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 atus testdat))..
6470: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
6480: 61 67 20 23 66 29 29 0a 09 20 20 20 20 3b 3b 20 ag #f)).. ;;
6490: 2d 72 65 72 75 6e 20 61 6e 64 20 73 74 61 74 75 -rerun and statu
64a0: 73 20 69 73 20 6f 6e 65 20 6f 66 20 74 68 65 20 s is one of the
64b0: 73 70 65 63 69 66 65 64 2c 20 72 75 6e 20 69 74 specifed, run it
64c0: 0a 09 20 20 20 20 28 28 61 6e 64 20 72 65 72 75 .. ((and reru
64d0: 6e 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 72 65 n... (let* ((re
64e0: 72 75 6e 6c 73 74 20 20 20 28 73 74 72 69 6e 67 runlst (string
64f0: 2d 73 70 6c 69 74 20 72 65 72 75 6e 20 22 2c 22 -split rerun ","
6500: 29 29 0a 09 09 09 20 28 6d 75 73 74 2d 72 65 72 )).... (must-rer
6510: 75 6e 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 un (member (test
6520: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
6530: 64 61 74 29 20 72 65 72 75 6e 6c 73 74 29 29 29 dat) rerunlst)))
6540: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
6550: 69 6e 74 20 33 20 22 49 4e 46 4f 3a 20 2d 72 65 int 3 "INFO: -re
6560: 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 65 72 75 run list: " reru
6570: 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 74 75 73 n ", test-status
6580: 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 : " (test:get-st
6590: 61 74 75 73 20 74 65 73 74 64 61 74 29 22 2c 20 atus testdat)",
65a0: 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 20 6d 75 must-rerun: " mu
65b0: 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 20 20 20 st-rerun)...
65c0: 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a 09 20 20 must-rerun))..
65d0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
65e0: 32 20 22 49 4e 46 4f 3a 20 52 65 72 75 6e 20 66 2 "INFO: Rerun f
65f0: 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 20 22 orced for test "
6600: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
6610: 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 20 tem-path)..
6620: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
6630: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 65 70 )).. ;; -keep
6640: 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 72 65 going, do not re
6650: 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 28 28 run FAIL.. ((
6660: 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a 09 09 and keepgoing...
6670: 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a (member (test:
6680: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
6690: 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 29 0a at) '("FAIL"))).
66a0: 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 . (set! runf
66b0: 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 28 28 lag #f)).. ((
66c0: 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a and (not rerun).
66d0: 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 .. (member (tes
66e0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
66f0: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 20 22 tdat) '("FAIL" "
6700: 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 28 73 n/a"))).. (s
6710: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
6720: 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 65 74 .. (else (set
6730: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 29 0a ! runflag #f))).
6740: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
6750: 20 36 20 22 52 55 4e 4e 49 4e 47 20 3d 3e 20 72 6 "RUNNING => r
6760: 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 6c 61 unflag: " runfla
6770: 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 74 65 g " STATE: " (te
6780: 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 st:get-state tes
6790: 74 64 61 74 29 20 22 20 53 54 41 54 55 53 3a 20 tdat) " STATUS:
67a0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
67b0: 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 us testdat))..
67c0: 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 6c 61 (if (not runfla
67d0: 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 g).. (if (
67e0: 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 74 29 not parent-test)
67f0: 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
6800: 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f 74 20 nt 1 "NOTE: Not
6810: 73 74 61 72 74 69 6e 67 20 74 65 73 74 20 22 20 starting test "
6820: 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 20 new-test-name "
6830: 61 73 20 69 74 20 69 73 20 73 74 61 74 65 20 5c as it is state \
6840: 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 "" (test:get-sta
6850: 74 65 20 74 65 73 74 64 61 74 29 20 0a 09 09 09 te testdat) ....
6860: 09 22 5c 22 20 61 6e 64 20 73 74 61 74 75 73 20 ."\" and status
6870: 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 \"" (test:get-st
6880: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 22 5c atus testdat) "\
6890: 22 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 5c 22 ", use -rerun \"
68a0: 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 " (test:get-stat
68b0: 75 73 20 74 65 73 74 64 61 74 29 0a 20 20 20 20 us testdat).
68c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
68d0: 20 20 20 20 20 20 20 20 20 20 20 20 22 5c 22 20 "\"
68e0: 6f 72 20 2d 66 6f 72 63 65 20 74 6f 20 6f 76 65 or -force to ove
68f0: 72 72 69 64 65 22 29 29 0a 09 20 20 20 20 20 20 rride"))..
6900: 20 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 6c 6f 6e ;; NOTE: No lon
6910: 67 65 72 20 62 65 20 63 68 65 63 6b 69 6e 67 20 ger be checking
6920: 70 72 65 72 65 71 75 69 73 69 74 65 73 20 68 65 prerequisites he
6930: 72 65 21 20 57 69 6c 6c 20 6e 65 76 65 72 20 67 re! Will never g
6940: 65 74 20 68 65 72 65 20 75 6e 6c 65 73 73 20 70 et here unless p
6950: 72 65 72 65 71 73 20 61 72 65 0a 09 20 20 20 20 rereqs are..
6960: 20 20 20 3b 3b 20 20 20 20 20 20 20 61 6c 72 65 ;; alre
6970: 61 64 79 20 6d 65 74 2e 0a 09 20 20 20 20 20 20 ady met...
6980: 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 (if (not (launc
6990: 68 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 h-test db run-id
69a0: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 63 6f runname test-co
69b0: 6e 66 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 nf keyvallst tes
69c0: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 t-name test-path
69d0: 20 69 74 65 6d 64 61 74 20 66 6c 61 67 73 29 29 itemdat flags))
69e0: 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 ... (begin...
69f0: 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f (print "ERRO
6a00: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 R: Failed to lau
6a10: 6e 63 68 20 74 68 65 20 74 65 73 74 2e 20 45 78 nch the test. Ex
6a20: 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 iting as soon as
6a30: 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 20 20 possible")...
6a40: 20 20 20 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c (set! *global
6a50: 65 78 69 74 73 74 61 74 75 73 2a 20 31 29 20 3b exitstatus* 1) ;
6a60: 3b 20 0a 09 09 20 20 20 20 20 28 70 72 6f 63 65 ; ... (proce
6a70: 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 65 ss-signal (curre
6a80: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 73 nt-process-id) s
6a90: 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 29 ignal/kill))))))
6aa0: 0a 09 28 28 4b 49 4c 4c 45 44 29 20 0a 09 20 28 ..((KILLED) .. (
6ab0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4e debug:print 1 "N
6ac0: 4f 54 45 3a 20 22 20 6e 65 77 2d 74 65 73 74 2d OTE: " new-test-
6ad0: 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 name " is alread
6ae0: 79 20 72 75 6e 6e 69 6e 67 20 6f 72 20 77 61 73 y running or was
6af0: 20 65 78 70 6c 69 63 74 6c 79 20 6b 69 6c 6c 65 explictly kille
6b00: 64 2c 20 75 73 65 20 2d 66 6f 72 63 65 20 74 6f d, use -force to
6b10: 20 6c 61 75 6e 63 68 20 69 74 2e 22 29 29 0a 09 launch it."))..
6b20: 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 ((LAUNCHED REMOT
6b30: 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e 49 EHOSTSTART RUNNI
6b40: 4e 47 29 20 20 0a 09 20 28 69 66 20 28 3e 20 28 NG) .. (if (> (
6b50: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
6b60: 64 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 ds)(+ (db:test-g
6b70: 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 et-event_time te
6b80: 73 74 64 61 74 29 0a 09 09 09 09 20 20 20 20 20 stdat).....
6b90: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
6ba0: 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 un_duration test
6bb0: 64 61 74 29 29 29 0a 09 09 36 30 30 29 20 3b 3b dat)))...600) ;;
6bc0: 20 69 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 20 i.e. no update
6bd0: 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 36 30 for more than 60
6be0: 30 20 73 65 63 6f 6e 64 73 0a 09 20 20 20 20 20 0 seconds..
6bf0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 (begin.. (
6c00: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
6c10: 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 74 ARNING: Test " t
6c20: 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 est-name " appea
6c30: 72 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 46 rs to be dead. F
6c40: 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 61 orcing it to sta
6c50: 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e te INCOMPLETE an
6c60: 64 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f 44 d status STUCK/D
6c70: 45 41 44 22 29 0a 09 20 20 20 20 20 20 20 28 74 EAD").. (t
6c80: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
6c90: 64 62 20 74 65 73 74 2d 69 64 20 22 49 4e 43 4f db test-id "INCO
6ca0: 4d 50 4c 45 54 45 22 20 22 53 54 55 43 4b 2f 44 MPLETE" "STUCK/D
6cb0: 45 41 44 22 20 22 54 65 73 74 20 69 73 20 73 74 EAD" "Test is st
6cc0: 75 63 6b 20 6f 72 20 64 65 61 64 22 20 23 66 29 uck or dead" #f)
6cd0: 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ).. (debug:p
6ce0: 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 rint 2 "NOTE: "
6cf0: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 test-name " is a
6d00: 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 lready running")
6d10: 29 29 0a 09 28 65 6c 73 65 20 20 20 20 20 20 20 ))..(else
6d20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
6d30: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
6d40: 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 6e launch test " n
6d50: 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 ew-test-name ".
6d60: 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 74 61 Unrecognised sta
6d70: 74 65 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 te " (test:get-s
6d80: 74 61 74 65 20 74 65 73 74 64 61 74 29 29 29 29 tate testdat))))
6d90: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
6da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
6de0: 20 45 4e 44 20 4f 46 20 4e 45 57 20 53 54 55 46 END OF NEW STUF
6df0: 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F.;;============
6e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
6e40: 69 6e 65 20 28 67 65 74 2d 64 69 72 2d 75 70 2d ine (get-dir-up-
6e50: 6e 20 64 69 72 20 2e 20 70 61 72 61 6d 73 29 20 n dir . params)
6e60: 0a 20 20 28 6c 65 74 20 28 28 64 70 61 72 74 73 . (let ((dparts
6e70: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
6e80: 64 69 72 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e dir "/"))..(coun
6e90: 74 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 t (if (null? p
6ea0: 61 72 61 6d 73 29 20 31 20 28 63 61 72 20 70 61 arams) 1 (car pa
6eb0: 72 61 6d 73 29 29 29 29 0a 20 20 20 20 28 63 6f rams)))). (co
6ec0: 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 nc "/" (string-i
6ed0: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 ntersperse ..
6ee0: 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 (take dparts
6ef0: 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 (- (length dpar
6f00: 74 73 29 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 ts) count))..
6f10: 20 20 20 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 "/")))).;; R
6f20: 65 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 emove runs.;; fi
6f30: 65 6c 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 elds are passing
6f40: 20 69 6e 20 74 68 72 6f 75 67 68 20 0a 3b 3b 20 in through .;;
6f50: 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 action:.;; 'r
6f60: 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 emove-runs.;;
6f70: 20 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 'set-state-stat
6f80: 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 us.;;.;; NB// sh
6f90: 6f 75 6c 64 20 70 61 73 73 20 69 6e 20 6b 65 79 ould pass in key
6fa0: 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 s?.;;.(define (r
6fb0: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 64 uns:operate-on d
6fc0: 62 20 61 63 74 69 6f 6e 20 72 75 6e 6e 61 6d 65 b action runname
6fd0: 70 61 74 74 20 74 65 73 74 70 61 74 74 20 69 74 patt testpatt it
6fe0: 65 6d 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 empatt #!key (st
6ff0: 61 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 ate #f)(status #
7000: 66 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 f)(new-state-sta
7010: 74 75 73 20 23 66 29 29 0a 20 20 28 6c 65 74 2a tus #f)). (let*
7020: 20 28 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 ((keys
7030: 28 72 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 (rdb:get-keys db
7040: 29 29 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 )).. (rundat
7050: 20 20 20 28 72 75 6e 73 3a 67 65 74 2d 72 75 6e (runs:get-run
7060: 73 2d 62 79 2d 70 61 74 74 20 64 62 20 6b 65 79 s-by-patt db key
7070: 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 29 0a s runnamepatt)).
7080: 09 20 28 68 65 61 64 65 72 20 20 20 20 20 20 20 . (header
7090: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 (vector-ref rund
70a0: 61 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 at 0)).. (runs
70b0: 20 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 (vector-r
70c0: 65 66 20 72 75 6e 64 61 74 20 31 29 29 0a 09 20 ef rundat 1))..
70d0: 28 73 74 61 74 65 73 20 20 20 20 20 20 20 28 69 (states (i
70e0: 66 20 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 f state (string
70f0: 2d 73 70 6c 69 74 20 73 74 61 74 65 20 20 22 2c -split state ",
7100: 22 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 ") '())).. (stat
7110: 75 73 65 73 20 20 20 20 20 28 69 66 20 73 74 61 uses (if sta
7120: 74 75 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 tus (string-spli
7130: 74 20 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 t status ",") '(
7140: 29 29 29 0a 09 20 28 73 74 61 74 65 2d 73 74 61 ))).. (state-sta
7150: 74 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f tus (if (string?
7160: 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 new-state-statu
7170: 73 29 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 s) (string-split
7180: 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 new-state-statu
7190: 73 20 22 2c 22 29 20 27 28 23 66 20 23 66 29 29 s ",") '(#f #f))
71a0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
71b0: 69 6e 74 20 32 20 22 48 65 61 64 65 72 3a 20 22 int 2 "Header: "
71c0: 20 68 65 61 64 65 72 20 22 20 61 63 74 69 6f 6e header " action
71d0: 3a 20 22 20 61 63 74 69 6f 6e 20 22 20 6e 65 77 : " action " new
71e0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 3a 20 22 -state-status: "
71f0: 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 new-state-statu
7200: 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s). (for-each
7210: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 . (lambda (r
7220: 75 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 un). (let
7230: 28 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 ((runkey (string
7240: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
7250: 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 p (lambda (k)...
7260: 09 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 ....(db:get-valu
7270: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
7280: 68 65 61 64 65 72 20 28 76 65 63 74 6f 72 2d 72 header (vector-r
7290: 65 66 20 6b 20 30 29 29 29 20 6b 65 79 73 29 20 ef k 0))) keys)
72a0: 22 2f 22 29 29 0a 09 20 20 20 20 20 28 64 69 72 "/")).. (dir
72b0: 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b s-to-remove (mak
72c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
72d0: 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 . (let* ((run-id
72e0: 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 (db:get-valu
72f0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
7300: 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 09 09 header "id"))...
7310: 28 72 75 6e 2d 73 74 61 74 65 20 28 64 62 3a 67 (run-state (db:g
7320: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
7330: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 73 er run header "s
7340: 74 61 74 65 22 29 29 0a 09 09 28 74 65 73 74 73 tate"))...(tests
7350: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
7360: 71 75 61 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 qual? run-state
7370: 22 6c 6f 63 6b 65 64 22 29 29 0a 09 09 09 20 20 "locked"))....
7380: 20 20 20 20 20 28 72 64 62 3a 67 65 74 2d 74 65 (rdb:get-te
7390: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 sts-for-run db (
73a0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
73b0: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
73c0: 72 20 22 69 64 22 29 0a 09 09 09 09 09 09 20 20 r "id").......
73d0: 20 20 20 20 74 65 73 74 70 61 74 74 20 69 74 65 testpatt ite
73e0: 6d 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 mpatt states sta
73f0: 74 75 73 65 73 0a 09 09 09 09 09 09 20 20 20 20 tuses.......
7400: 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 66 0a 09 09 not-in: #f...
7410: 09 09 09 09 20 20 20 20 20 20 73 6f 72 74 2d 62 .... sort-b
7420: 79 3a 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a y: (case action.
7430: 09 09 09 09 09 09 09 09 20 28 28 72 65 6d 6f 76 ........ ((remov
7440: 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 69 72 29 e-runs) 'rundir)
7450: 0a 09 09 09 09 09 09 09 09 20 28 65 6c 73 65 20 ......... (else
7460: 20 20 20 20 20 20 20 20 20 27 65 76 65 6e 74 5f 'event_
7470: 74 69 6d 65 29 29 29 0a 09 09 09 20 20 20 20 20 time)))....
7480: 20 20 27 28 29 29 29 0a 09 09 28 6c 61 73 74 74 '()))...(lastt
7490: 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e 6f 74 2f path "/does/not/
74a0: 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 29 29 0a exist/I/hope")).
74b0: 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e .. (if (not (n
74c0: 75 6c 6c 3f 20 74 65 73 74 73 29 29 0a 09 20 20 ull? tests))..
74d0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 (begin... (
74e0: 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 case action...
74f0: 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a ((remove-runs).
7500: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
7510: 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 nt 1 "Removing t
7520: 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 ests for run: "
7530: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
7540: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
7550: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
7560: 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 unname")))...
7570: 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 ((set-state-stat
7580: 75 73 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 us)... (debug
7590: 3a 70 72 69 6e 74 20 31 20 22 4d 6f 64 69 66 79 :print 1 "Modify
75a0: 69 6e 67 20 73 74 61 74 65 20 61 6e 64 20 73 74 ing state and st
75b0: 61 75 73 20 66 6f 72 20 74 65 73 74 73 20 66 6f aus for tests fo
75c0: 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 r run: " runkey
75d0: 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 " " (db:get-valu
75e0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
75f0: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
7600: 29 29 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 )))... (else..
7610: 09 20 20 20 20 28 70 72 69 6e 74 20 22 49 4e 46 . (print "INF
7620: 4f 3a 20 61 63 74 69 6f 6e 20 6e 6f 74 20 72 65 O: action not re
7630: 63 6f 67 6e 69 73 65 64 20 22 20 61 63 74 69 6f cognised " actio
7640: 6e 29 29 29 0a 09 09 20 28 66 6f 72 2d 65 61 63 n)))... (for-eac
7650: 68 0a 09 09 20 20 28 6c 61 6d 62 64 61 20 28 74 h... (lambda (t
7660: 65 73 74 29 0a 09 09 20 20 20 20 28 6c 65 74 2a est)... (let*
7670: 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 64 62 ((item-path (db
7680: 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 :test-get-item-p
7690: 61 74 68 20 74 65 73 74 29 29 0a 09 09 09 20 20 ath test))....
76a0: 20 28 74 65 73 74 2d 6e 61 6d 65 20 28 64 62 3a (test-name (db:
76b0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
76c0: 65 20 74 65 73 74 29 29 0a 09 09 09 20 20 20 28 e test)).... (
76d0: 72 75 6e 2d 64 69 72 20 20 20 28 64 62 3a 74 65 run-dir (db:te
76e0: 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 74 65 st-get-rundir te
76f0: 73 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 st)))... (d
7700: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 20 20 ebug:print 1 "
7710: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 " (db:test-get-t
7720: 65 73 74 6e 61 6d 65 20 74 65 73 74 29 20 22 20 estname test) "
7730: 69 64 3a 20 22 20 28 64 62 3a 74 65 73 74 2d 67 id: " (db:test-g
7740: 65 74 2d 69 64 20 74 65 73 74 29 20 22 20 22 20 et-id test) " "
7750: 69 74 65 6d 2d 70 61 74 68 20 22 20 61 63 74 69 item-path " acti
7760: 6f 6e 3a 20 22 20 61 63 74 69 6f 6e 29 0a 09 09 on: " action)...
7770: 20 20 20 20 20 20 28 63 61 73 65 20 61 63 74 69 (case acti
7780: 6f 6e 0a 09 09 09 28 28 72 65 6d 6f 76 65 2d 72 on....((remove-r
7790: 75 6e 73 29 0a 09 09 09 20 28 72 64 62 3a 64 65 uns).... (rdb:de
77a0: 6c 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 lete-test-record
77b0: 73 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 s db (db:test-ge
77c0: 74 2d 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 t-id test))....
77d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
77e0: 49 4e 46 4f 3a 20 41 74 74 65 6d 70 74 69 6e 67 INFO: Attempting
77f0: 20 74 6f 20 72 65 6d 6f 76 65 20 64 69 72 20 22 to remove dir "
7800: 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 28 69 run-dir).... (i
7810: 66 20 28 61 6e 64 20 28 3e 20 28 73 74 72 69 6e f (and (> (strin
7820: 67 2d 6c 65 6e 67 74 68 20 72 75 6e 2d 64 69 72 g-length run-dir
7830: 29 20 35 29 0a 09 09 09 09 20 20 28 66 69 6c 65 ) 5)..... (file
7840: 2d 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 69 72 -exists? run-dir
7850: 29 29 20 3b 3b 20 62 61 64 20 68 65 75 72 69 73 )) ;; bad heuris
7860: 74 69 63 20 62 75 74 20 73 68 6f 75 6c 64 20 70 tic but should p
7870: 72 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 6f 6d revent /tmp /hom
7880: 65 20 65 74 63 2e 0a 09 09 09 20 20 20 20 20 28 e etc..... (
7890: 6c 65 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 let* ((realpath
78a0: 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d (resolve-pathnam
78b0: 65 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 e run-dir)))....
78c0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
78d0: 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 52 65 61 int 1 "INFO: Rea
78e0: 6c 20 70 61 74 68 20 6f 66 20 69 73 20 22 20 72 l path of is " r
78f0: 65 61 6c 70 61 74 68 29 0a 09 09 09 20 20 20 20 ealpath)....
7900: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
7910: 73 74 73 3f 20 72 65 61 6c 70 61 74 68 29 0a 09 sts? realpath)..
7920: 09 09 09 20 20 20 28 69 66 20 28 3e 20 28 73 79 ... (if (> (sy
7930: 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d stem (conc "rm -
7940: 72 66 20 22 20 72 65 61 6c 70 61 74 68 29 29 20 rf " realpath))
7950: 30 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 0)..... (d
7960: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
7970: 52 4f 52 3a 20 54 68 65 72 65 20 77 61 73 20 61 ROR: There was a
7980: 20 70 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 69 6e problem removin
7990: 67 20 22 20 72 65 61 6c 70 61 74 68 20 22 20 77 g " realpath " w
79a0: 69 74 68 20 72 6d 20 2d 66 22 29 29 0a 09 09 09 ith rm -f"))....
79b0: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
79c0: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 0 "WARNING: tes
79d0: 74 20 72 75 6e 20 64 69 72 20 22 20 72 65 61 6c t run dir " real
79e0: 70 61 74 68 20 22 20 61 70 70 65 61 72 73 20 74 path " appears t
79f0: 6f 20 6e 6f 74 20 65 78 69 73 74 22 29 29 0a 09 o not exist"))..
7a00: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 66 69 .. (if (fi
7a10: 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 le-exists? run-d
7a20: 69 72 29 20 3b 3b 20 74 68 65 20 6c 69 6e 6b 0a ir) ;; the link.
7a30: 09 09 09 09 20 20 20 28 69 66 20 28 73 79 6d 62 .... (if (symb
7a40: 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 olic-link? run-d
7a50: 69 72 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 ir)..... (
7a60: 64 65 6c 65 74 65 2d 66 69 6c 65 20 72 75 6e 2d delete-file run-
7a70: 64 69 72 29 0a 09 09 09 09 20 20 20 20 20 20 20 dir).....
7a80: 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 (if (directory?
7a90: 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 09 20 20 run-dir)......
7aa0: 20 28 69 66 20 28 3e 20 28 64 69 72 65 63 74 6f (if (> (directo
7ab0: 72 79 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 ry-fold (lambda
7ac0: 28 66 20 78 29 28 2b 20 31 20 78 29 29 20 30 20 (f x)(+ 1 x)) 0
7ad0: 72 75 6e 2d 64 69 72 29 20 30 29 0a 09 09 09 09 run-dir) 0).....
7ae0: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
7af0: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
7b00: 20 72 65 66 75 73 69 6e 67 20 74 6f 20 72 65 6d refusing to rem
7b10: 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 20 22 20 ove " run-dir "
7b20: 61 73 20 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 as it is not emp
7b30: 74 79 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 ty")......
7b40: 20 28 64 65 6c 65 74 65 2d 64 69 72 65 63 74 6f (delete-directo
7b50: 72 79 20 72 75 6e 2d 64 69 72 29 29 20 3b 3b 20 ry run-dir)) ;;
7b60: 69 74 20 73 68 6f 75 6c 64 20 62 65 20 65 6d 70 it should be emp
7b70: 74 79 20 62 79 20 68 65 72 65 20 42 55 47 20 42 ty by here BUG B
7b80: 55 47 2c 20 61 64 64 20 65 72 72 6f 72 20 63 61 UG, add error ca
7b90: 74 63 68 0a 09 09 09 09 09 20 20 20 28 64 65 62 tch...... (deb
7ba0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
7bb0: 52 3a 20 72 65 66 75 73 69 6e 67 20 74 6f 20 72 R: refusing to r
7bc0: 65 6d 6f 76 65 20 22 20 72 75 6e 2d 64 69 72 20 emove " run-dir
7bd0: 22 20 61 73 20 69 74 20 69 73 20 6e 65 69 74 68 " as it is neith
7be0: 65 72 20 61 20 73 79 6d 6c 69 6e 6b 20 6e 6f 72 er a symlink nor
7bf0: 20 61 20 64 69 72 65 63 74 6f 72 79 22 29 0a 09 a directory")..
7c00: 09 09 09 09 20 20 20 29 29 29 29 0a 09 09 09 20 .... ))))....
7c10: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7c20: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 72 0 "WARNING: dir
7c30: 65 63 74 6f 72 79 20 61 6c 72 65 61 64 79 20 72 ectory already r
7c40: 65 6d 6f 76 65 64 20 22 20 72 75 6e 2d 64 69 72 emoved " run-dir
7c50: 29 29 29 0a 09 09 09 28 28 73 65 74 2d 73 74 61 )))....((set-sta
7c60: 74 65 2d 73 74 61 74 75 73 29 0a 09 09 09 20 28 te-status).... (
7c70: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 debug:print 2 "I
7c80: 4e 46 4f 3a 20 6e 65 77 20 73 74 61 74 65 20 22 NFO: new state "
7c90: 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 (car state-stat
7ca0: 75 73 29 20 22 2c 20 6e 65 77 20 73 74 61 74 75 us) ", new statu
7cb0: 73 20 22 20 28 63 61 64 72 20 73 74 61 74 65 2d s " (cadr state-
7cc0: 73 74 61 74 75 73 29 29 0a 09 09 09 20 28 64 62 status)).... (db
7cd0: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
7ce0: 73 74 61 74 75 73 2d 62 79 2d 69 64 20 64 62 20 status-by-id db
7cf0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
7d00: 74 65 73 74 29 20 28 63 61 72 20 73 74 61 74 65 test) (car state
7d10: 2d 73 74 61 74 75 73 29 28 63 61 64 72 20 73 74 -status)(cadr st
7d20: 61 74 65 2d 73 74 61 74 75 73 29 20 23 66 29 29 ate-status) #f))
7d30: 29 29 29 0a 09 09 20 20 74 65 73 74 73 29 29 29 )))... tests)))
7d40: 0a 09 20 20 20 0a 09 20 20 20 3b 3b 20 72 65 6d .. .. ;; rem
7d50: 6f 76 65 20 74 68 65 20 72 75 6e 20 69 66 20 7a ove the run if z
7d60: 65 72 6f 20 74 65 73 74 73 20 72 65 6d 61 69 6e ero tests remain
7d70: 0a 09 20 20 20 28 69 66 20 28 65 71 3f 20 61 63 .. (if (eq? ac
7d80: 74 69 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 75 6e tion 'remove-run
7d90: 73 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 s).. (let
7da0: 28 28 72 65 6d 74 65 73 74 73 20 28 72 64 62 3a ((remtests (rdb:
7db0: 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 get-tests-for-ru
7dc0: 6e 20 64 62 20 28 64 62 3a 67 65 74 2d 76 61 6c n db (db:get-val
7dd0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
7de0: 20 68 65 61 64 65 72 20 22 69 64 22 29 20 23 66 header "id") #f
7df0: 20 23 66 20 27 28 29 20 27 28 29 29 29 29 0a 09 #f '() '())))..
7e00: 09 20 28 69 66 20 28 6e 75 6c 6c 3f 20 72 65 6d . (if (null? rem
7e10: 74 65 73 74 73 29 20 3b 3b 20 6e 6f 20 6d 6f 72 tests) ;; no mor
7e20: 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 6e e tests remainin
7e30: 67 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 g... (let* (
7e40: 28 64 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 (dparts (string
7e50: 2d 73 70 6c 69 74 20 6c 61 73 74 74 70 61 74 68 -split lasttpath
7e60: 20 22 2f 22 29 29 0a 09 09 09 20 20 20 20 28 72 "/")).... (r
7e70: 75 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 2f 22 unpath (conc "/"
7e80: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
7e90: 65 72 73 65 20 0a 09 09 09 09 09 09 28 74 61 6b erse .......(tak
7ea0: 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c 65 6e e dparts (- (len
7eb0: 67 74 68 20 64 70 61 72 74 73 29 20 31 29 29 0a gth dparts) 1)).
7ec0: 09 09 09 09 09 09 22 2f 22 29 29 29 29 0a 09 09 ......"/"))))...
7ed0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
7ee0: 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 int 1 "Removing
7ef0: 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 run: " runkey "
7f00: 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d " (db:get-value-
7f10: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
7f20: 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 ader "runname"))
7f30: 0a 09 09 20 20 20 20 20 20 20 28 64 62 3a 64 65 ... (db:de
7f40: 6c 65 74 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d lete-run db run-
7f50: 69 64 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 id)... ;;
7f60: 6e 65 65 64 20 74 6f 20 66 69 67 75 72 65 20 6f need to figure o
7f70: 75 74 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 ut the path to t
7f80: 68 65 20 72 75 6e 20 64 69 72 20 61 6e 64 20 72 he run dir and r
7f90: 65 6d 6f 76 65 20 69 74 20 69 66 20 65 6d 70 74 emove it if empt
7fa0: 79 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 y... ;;
7fb0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 67 6c 6f (if (null? (glo
7fc0: 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 74 68 20 b (conc runpath
7fd0: 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 20 20 20 "/*")))...
7fe0: 20 3b 3b 20 20 20 20 20 20 20 20 28 62 65 67 69 ;; (begi
7ff0: 6e 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 20 n... ;; .
8000: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
8010: 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 Removing run dir
8020: 20 22 20 72 75 6e 70 61 74 68 29 0a 09 09 20 20 " runpath)...
8030: 20 20 20 20 20 3b 3b 20 09 20 28 73 79 73 74 65 ;; . (syste
8040: 6d 20 28 63 6f 6e 63 20 22 72 6d 64 69 72 20 2d m (conc "rmdir -
8050: 70 20 22 20 72 75 6e 70 61 74 68 29 29 29 29 0a p " runpath)))).
8060: 09 09 20 20 20 20 20 20 20 29 29 29 29 29 0a 09 .. )))))..
8070: 20 29 29 0a 20 20 20 20 20 72 75 6e 73 29 29 29 )). runs)))
8080: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
8090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
80c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f ==========.;; Ro
80d0: 75 74 69 6e 65 73 20 66 6f 72 20 6d 61 6e 69 70 utines for manip
80e0: 75 6c 61 74 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d ulating runs.;;=
80f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8130: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 =====..;; Since
8140: 6d 61 6e 79 20 63 61 6c 6c 73 20 74 6f 20 61 20 many calls to a
8150: 72 75 6e 20 72 65 71 75 69 72 65 20 70 72 65 74 run require pret
8160: 74 79 20 6d 75 63 68 20 74 68 65 20 73 61 6d 65 ty much the same
8170: 20 73 65 74 75 70 20 0a 3b 3b 20 74 68 69 73 20 setup .;; this
8180: 77 72 61 70 70 65 72 20 69 73 20 75 73 65 64 20 wrapper is used
8190: 74 6f 20 72 65 64 75 63 65 20 74 68 65 20 72 65 to reduce the re
81a0: 70 6c 69 63 61 74 69 6f 6e 20 6f 66 20 63 6f 64 plication of cod
81b0: 65 0a 28 64 65 66 69 6e 65 20 28 67 65 6e 65 72 e.(define (gener
81c0: 61 6c 2d 72 75 6e 2d 63 61 6c 6c 20 73 77 69 74 al-run-call swit
81d0: 63 68 6e 61 6d 65 20 61 63 74 69 6f 6e 2d 64 65 chname action-de
81e0: 73 63 20 70 72 6f 63 29 0a 20 20 28 6c 65 74 20 sc proc). (let
81f0: 28 28 72 75 6e 6e 61 6d 65 20 28 61 72 67 73 3a ((runname (args:
8200: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
8210: 65 22 29 29 0a 09 28 74 61 72 67 65 74 20 20 28 e"))..(target (
8220: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
8230: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 "-target")...
8240: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
8250: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 20 "-target")...
8260: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg
8270: 20 22 2d 72 65 71 74 61 72 67 22 29 29 29 0a 09 "-reqtarg")))..
8280: 28 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 20 (th1 #f)).
8290: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e (cond. ((n
82a0: 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 20 ot target).
82b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
82c0: 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 "ERROR: Missing
82d0: 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 required paramet
82e0: 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e er for " switchn
82f0: 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 ame ", you must
8300: 73 70 65 63 69 66 79 20 74 68 65 20 74 61 72 67 specify the targ
8310: 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 22 et with -target"
8320: 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 ). (exit 3)
8330: 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 6e ). ((not run
8340: 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 62 name). (deb
8350: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
8360: 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 R: Missing requi
8370: 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f red parameter fo
8380: 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 r " switchname "
8390: 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 , you must speci
83a0: 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 fy the run name
83b0: 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 75 with :runname ru
83c0: 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 65 nname"). (e
83d0: 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 6c xit 3)). (el
83e0: 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 se. (let ((
83f0: 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b db #f).. (k
8400: 65 79 73 20 23 66 29 29 0a 09 28 69 66 20 28 6e eys #f))..(if (n
8410: 6f 74 20 28 73 65 74 75 70 2d 66 6f 72 2d 72 75 ot (setup-for-ru
8420: 6e 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e 20 n)).. (begin
8430: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
8440: 72 69 6e 74 20 30 20 22 46 61 69 6c 65 64 20 74 rint 0 "Failed t
8450: 6f 20 73 65 74 75 70 2c 20 65 78 69 74 69 6e 67 o setup, exiting
8460: 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit
8470: 31 29 29 29 0a 09 28 73 65 74 21 20 64 62 20 20 1)))..(set! db
8480: 20 28 6f 70 65 6e 2d 64 62 29 29 0a 09 28 69 66 (open-db))..(if
8490: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
84a0: 2d 73 65 72 76 65 72 22 29 0a 09 20 20 20 20 28 -server").. (
84b0: 73 65 72 76 65 72 3a 73 74 61 72 74 20 64 62 20 server:start db
84c0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
84d0: 73 65 72 76 65 72 22 29 29 0a 09 20 20 20 20 28 server")).. (
84e0: 69 66 20 28 6e 6f 74 20 28 6f 72 20 28 61 72 67 if (not (or (arg
84f0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 61 s:get-arg "-runa
8500: 6c 6c 22 29 0a 09 09 09 20 20 28 61 72 67 73 3a ll").... (args:
8510: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 get-arg "-runtes
8520: 74 73 22 29 29 29 0a 09 09 28 73 65 72 76 65 72 ts")))...(server
8530: 3a 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 64 62 :client-setup db
8540: 29 29 29 0a 09 28 73 65 74 21 20 6b 65 79 73 20 )))..(set! keys
8550: 28 72 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 (rdb:get-keys db
8560: 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 ))..;; have enou
8570: 67 68 20 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 gh to process -t
8580: 61 72 67 65 74 20 6f 72 20 2d 72 65 71 74 61 72 arget or -reqtar
8590: 67 20 68 65 72 65 0a 09 28 69 66 20 28 61 72 67 g here..(if (arg
85a0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
85b0: 61 72 67 22 29 0a 09 20 20 20 20 28 6c 65 74 2a arg").. (let*
85c0: 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 ((runconfigf (c
85d0: 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 onc *toppath* "
85e0: 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 /runconfigs.conf
85f0: 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 ig")) ;; DO NOT
8600: 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 EVALUATE ALL ...
8610: 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 (runconfig (
8620: 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 read-config runc
8630: 6f 6e 66 69 67 66 20 23 66 20 23 66 20 65 6e 76 onfigf #f #f env
8640: 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 iron-patt: #f)))
8650: 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 61 .. (if (ha
8660: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
8670: 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 20 28 ault runconfig (
8680: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
8690: 65 71 74 61 72 67 22 29 20 23 66 29 0a 09 09 20 eqtarg") #f)...
86a0: 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 73 65 (keys:target-se
86b0: 74 2d 61 72 67 73 20 6b 65 79 73 20 28 61 72 67 t-args keys (arg
86c0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 s:get-arg "-reqt
86d0: 61 72 67 22 29 20 61 72 67 73 3a 61 72 67 2d 68 arg") args:arg-h
86e0: 61 73 68 29 0a 09 09 20 20 28 62 65 67 69 6e 0a ash)... (begin.
86f0: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
8700: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 5b 22 20 nt 0 "ERROR: ["
8710: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8720: 72 65 71 74 61 72 67 22 29 20 22 5d 20 6e 6f 74 reqtarg") "] not
8730: 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 75 6e 63 found in " runc
8740: 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 20 28 73 onfigf)... (s
8750: 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
8760: 20 64 62 29 0a 09 09 20 20 20 20 28 65 78 69 74 db)... (exit
8770: 20 31 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 1)))).. (if
8780: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8790: 74 61 72 67 65 74 22 29 0a 09 09 28 6b 65 79 73 target")...(keys
87a0: 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 :target-set-args
87b0: 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d keys (args:get-
87c0: 61 72 67 20 22 2d 74 61 72 67 65 74 22 20 61 72 arg "-target" ar
87d0: 67 73 3a 61 72 67 2d 68 61 73 68 29 20 61 72 67 gs:arg-hash) arg
87e0: 73 3a 61 72 67 2d 68 61 73 68 29 29 29 0a 09 28 s:arg-hash)))..(
87f0: 69 66 20 28 6e 6f 74 20 28 63 61 72 20 2a 63 6f if (not (car *co
8800: 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 20 20 20 nfiginfo*))..
8810: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
8820: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
8830: 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 65 64 20 RROR: Attempted
8840: 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 65 73 63 to " action-desc
8850: 20 22 20 62 75 74 20 72 75 6e 20 61 72 65 61 20 " but run area
8860: 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e 6f 74 20 config file not
8870: 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 20 20 28 found").. (
8880: 65 78 69 74 20 31 29 29 0a 09 20 20 20 20 3b 3b exit 1)).. ;;
8890: 20 45 78 74 72 61 63 74 20 6f 75 74 20 73 74 75 Extract out stu
88a0: 66 66 20 6e 65 65 64 65 64 20 69 6e 20 6d 6f 73 ff needed in mos
88b0: 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c 6c 73 0a t or many calls.
88c0: 09 20 20 20 20 3b 3b 20 68 65 72 65 20 74 68 65 . ;; here the
88d0: 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 20 20 20 n call proc..
88e0: 20 28 6c 65 74 2a 20 28 28 6b 65 79 6e 61 6d 65 (let* ((keyname
88f0: 73 20 20 20 28 6d 61 70 20 6b 65 79 3a 67 65 74 s (map key:get
8900: 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 73 29 -fieldname keys)
8910: 29 0a 09 09 20 20 20 28 6b 65 79 76 61 6c 6c 73 )... (keyvalls
8920: 74 20 20 28 6b 65 79 73 2d 3e 76 61 6c 6c 69 73 t (keys->vallis
8930: 74 20 6b 65 79 73 20 23 74 29 29 29 0a 09 20 20 t keys #t)))..
8940: 20 20 20 20 28 70 72 6f 63 20 64 62 20 74 61 72 (proc db tar
8950: 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b 65 79 73 get runname keys
8960: 20 6b 65 79 6e 61 6d 65 73 20 6b 65 79 76 61 6c keynames keyval
8970: 6c 73 74 29 29 29 0a 09 28 69 66 20 74 68 31 20 lst)))..(if th1
8980: 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 (thread-join! th
8990: 31 29 29 0a 09 28 73 71 6c 69 74 65 33 3a 66 69 1))..(sqlite3:fi
89a0: 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 28 73 65 nalize! db)..(se
89b0: 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 6e 67 t! *didsomething
89c0: 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d * #t))))))..;;==
89d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a10: 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 6b 2f 75 6e 6c ====.;; Lock/unl
8a20: 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d ock runs.;;=====
8a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8a70: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 =..(define (runs
8a80: 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 6e 67 20 :handle-locking
8a90: 64 62 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 db target keys r
8aa0: 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f unname lock unlo
8ab0: 63 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a ck user). (let*
8ac0: 20 28 28 72 75 6e 64 61 74 20 20 20 28 72 75 6e ((rundat (run
8ad0: 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 s:get-runs-by-pa
8ae0: 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 tt db keys runna
8af0: 6d 65 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 me)).. (header
8b00: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
8b10: 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 dat 0)).. (runs
8b20: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
8b30: 72 75 6e 64 61 74 20 31 29 29 29 0a 20 20 20 20 rundat 1))).
8b40: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
8b50: 61 20 28 72 75 6e 29 0a 09 09 28 6c 65 74 20 28 a (run)...(let (
8b60: 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 65 74 2d (run-id (db:get-
8b70: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
8b80: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
8b90: 29 29 0a 09 09 20 20 28 69 66 20 28 6f 72 20 6c ))... (if (or l
8ba0: 6f 63 6b 0a 09 09 09 20 20 28 61 6e 64 20 75 6e ock.... (and un
8bb0: 6c 6f 63 6b 0a 09 09 09 20 20 20 20 20 20 20 28 lock.... (
8bc0: 62 65 67 69 6e 0a 09 09 09 09 20 28 70 72 69 6e begin..... (prin
8bd0: 74 20 22 44 6f 20 79 6f 75 20 72 65 61 6c 6c 79 t "Do you really
8be0: 20 77 69 73 68 20 74 6f 20 75 6e 6c 6f 63 6b 20 wish to unlock
8bf0: 72 75 6e 20 22 20 72 75 6e 2d 69 64 20 22 3f 5c run " run-id "?\
8c00: 6e 20 20 20 79 2f 6e 3a 20 22 29 0a 09 09 09 09 n y/n: ").....
8c10: 20 28 65 71 75 61 6c 3f 20 22 79 22 20 28 72 65 (equal? "y" (re
8c20: 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a 09 09 20 ad-line)))))...
8c30: 20 20 20 20 20 28 64 62 3a 6c 6f 63 6b 2f 75 6e (db:lock/un
8c40: 6c 6f 63 6b 2d 72 75 6e 20 64 62 20 72 75 6e 2d lock-run db run-
8c50: 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 id lock unlock u
8c60: 73 65 72 29 0a 09 09 20 20 20 20 20 20 28 64 65 ser)... (de
8c70: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 49 4e 46 bug:print 0 "INF
8c80: 4f 3a 20 53 6b 69 70 70 69 6e 67 20 6c 6f 63 6b O: Skipping lock
8c90: 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 72 75 6e /unlock on " run
8ca0: 2d 69 64 29 29 29 29 0a 09 20 20 20 20 20 20 72 -id)))).. r
8cb0: 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d uns))).;;=======
8cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8d00: 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e 73 0a 3b ;; Rollup runs.;
8d10: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
8d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d50: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 55 70 64 61 =======..;; Upda
8d60: 74 65 20 74 68 65 20 74 65 73 74 5f 6d 65 74 61 te the test_meta
8d70: 20 74 61 62 6c 65 20 66 6f 72 20 74 68 69 73 20 table for this
8d80: 74 65 73 74 0a 28 64 65 66 69 6e 65 20 28 72 75 test.(define (ru
8d90: 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d ns:update-test_m
8da0: 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 eta db test-name
8db0: 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 6c test-conf). (l
8dc0: 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 20 et ((currrecord
8dd0: 28 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 (db:testmeta-get
8de0: 2d 72 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d -record db test-
8df0: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 name))). (if
8e00: 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 (not currrecord)
8e10: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 ..(begin.. (set
8e20: 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 ! currrecord (ma
8e30: 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 29 ke-vector 10 #f)
8e40: 29 0a 09 20 20 28 64 62 3a 74 65 73 74 6d 65 74 ).. (db:testmet
8e50: 61 2d 61 64 64 2d 72 65 63 6f 72 64 20 64 62 20 a-add-record db
8e60: 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 test-name))).
8e70: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
8e80: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 (lambda (key).
8e90: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 (let* ((id
8ea0: 78 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 x (cadr key))..
8eb0: 20 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 (fld (car
8ec0: 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 key)).. (va
8ed0: 6c 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 l (config-lookup
8ee0: 20 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 test-conf "test
8ef0: 5f 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 _meta" fld)))..
8f00: 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;; (debug:print
8f10: 35 20 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 5 "idx: " idx "
8f20: 66 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c fld: " fld " val
8f30: 3a 20 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 : " val).. (if (
8f40: 61 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 and val (not (eq
8f50: 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 ual? (vector-ref
8f60: 20 63 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 currrecord idx)
8f70: 20 76 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 val))).. (b
8f80: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 egin.. (pr
8f90: 69 6e 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 int "Updating "
8fa0: 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c test-name " " fl
8fb0: 64 20 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 d " to " val)..
8fc0: 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 6d 65 (db:testme
8fd0: 74 61 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 ta-update-field
8fe0: 64 62 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 db test-name fld
8ff0: 20 76 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 val))))). '
9000: 28 28 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f (("author" 2)("o
9010: 77 6e 65 72 22 20 33 29 28 22 64 65 73 63 72 69 wner" 3)("descri
9020: 70 74 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 ption" 4)("revie
9030: 77 65 64 22 20 35 29 28 22 74 61 67 73 22 20 39 wed" 5)("tags" 9
9040: 29 29 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 )))))..;; Update
9050: 20 74 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 test_meta for a
9060: 6c 6c 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 ll tests.(define
9070: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c (runs:update-al
9080: 6c 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a l-test_meta db).
9090: 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 (let ((test-na
90a0: 6d 65 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 mes (get-all-leg
90b0: 61 6c 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 al-tests))).
90c0: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
90d0: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 (lambda (test-na
90e0: 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a me). (let*
90f0: 20 28 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 ((test-path
9100: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
9110: 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e "/tests/" test-n
9120: 61 6d 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 ame)).. (te
9130: 73 74 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 st-configf (conc
9140: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 test-path "/tes
9150: 74 63 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 20 tconfig"))..
9160: 20 20 28 74 65 73 74 65 78 69 73 74 73 20 20 20 (testexists
9170: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
9180: 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 s? test-configf)
9190: 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 (file-read-acces
91a0: 73 3f 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 s? test-configf)
91b0: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 61 )).. ;; rea
91c0: 64 20 63 6f 6e 66 69 67 73 20 77 69 74 68 20 74 d configs with t
91d0: 72 69 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 ricks turned off
91e0: 20 28 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d (i.e. no system
91f0: 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 ).. (test-c
9200: 6f 6e 66 20 20 20 20 28 69 66 20 74 65 73 74 65 onf (if teste
9210: 78 69 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 xists (read-conf
9220: 69 67 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 ig test-configf
9230: 23 66 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 #f #f)(make-hash
9240: 2d 74 61 62 6c 65 29 29 29 29 0a 09 20 28 72 75 -table)))).. (ru
9250: 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d ns:update-test_m
9260: 65 74 61 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 eta db test-name
9270: 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 test-conf))).
9280: 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 test-names)))
9290: 0a 0a 3b 3b 20 54 68 69 73 20 63 6f 75 6c 64 20 ..;; This could
92a0: 70 72 6f 62 61 62 6c 79 20 62 65 20 72 65 66 61 probably be refa
92b0: 63 74 6f 72 65 64 20 69 6e 74 6f 20 6f 6e 65 20 ctored into one
92c0: 63 6f 6d 70 6c 65 78 20 71 75 65 72 79 20 2e 2e complex query ..
92d0: 2e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
92e0: 72 6f 6c 6c 75 70 2d 72 75 6e 20 64 62 20 6b 65 rollup-run db ke
92f0: 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e ys keyvallst run
9300: 6e 61 6d 65 20 75 73 65 72 29 20 3b 3b 20 77 61 name user) ;; wa
9310: 73 20 74 61 72 67 65 74 2c 20 6e 6f 77 20 6b 65 s target, now ke
9320: 79 76 61 6c 6c 73 74 0a 20 20 28 64 65 62 75 67 yvallst. (debug
9330: 3a 70 72 69 6e 74 20 34 20 22 72 75 6e 73 3a 72 :print 4 "runs:r
9340: 6f 6c 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 73 3a ollup-run, keys:
9350: 20 22 20 6b 65 79 73 20 22 20 6b 65 79 76 61 6c " keys " keyval
9360: 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 74 lst: " keyvallst
9370: 20 22 20 3a 72 75 6e 6e 61 6d 65 20 22 20 72 75 " :runname " ru
9380: 6e 6e 61 6d 65 20 22 20 75 73 65 72 3a 20 22 20 nname " user: "
9390: 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 28 3b user). (let* (;
93a0: 20 28 6b 65 79 76 61 6c 6c 6c 73 74 20 20 20 20 (keyvalllst
93b0: 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e (keys:target->
93c0: 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 keyval keys targ
93d0: 65 74 29 29 0a 09 20 28 6e 65 77 2d 72 75 6e 2d et)).. (new-run-
93e0: 69 64 20 20 20 20 20 20 28 72 75 6e 73 3a 72 65 id (runs:re
93f0: 67 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 gister-run db ke
9400: 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e ys keyvallst run
9410: 6e 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 name "new" "n/a"
9420: 20 75 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d user)).. (prev-
9430: 74 65 73 74 73 20 20 20 20 20 20 28 74 65 73 74 tests (test
9440: 3a 67 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 :get-matching-pr
9450: 65 76 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d evious-test-run-
9460: 72 65 63 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 records db new-r
9470: 75 6e 2d 69 64 20 22 25 22 20 22 25 22 29 29 0a un-id "%" "%")).
9480: 09 20 28 63 75 72 72 2d 74 65 73 74 73 20 20 20 . (curr-tests
9490: 20 20 20 28 72 64 62 3a 67 65 74 2d 74 65 73 74 (rdb:get-test
94a0: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 s-for-run db new
94b0: 2d 72 75 6e 2d 69 64 20 22 25 22 20 22 25 22 20 -run-id "%" "%"
94c0: 27 28 29 20 27 28 29 29 29 0a 09 20 28 63 75 72 '() '())).. (cur
94d0: 72 2d 74 65 73 74 73 2d 68 61 73 68 20 28 6d 61 r-tests-hash (ma
94e0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
94f0: 0a 20 20 20 20 28 64 62 3a 75 70 64 61 74 65 2d . (db:update-
9500: 72 75 6e 2d 65 76 65 6e 74 5f 74 69 6d 65 20 64 run-event_time d
9510: 62 20 6e 65 77 2d 72 75 6e 2d 69 64 29 0a 20 20 b new-run-id).
9520: 20 20 3b 3b 20 69 6e 64 65 78 20 74 68 65 20 61 ;; index the a
9530: 6c 72 65 61 64 79 20 73 61 76 65 64 20 74 65 73 lready saved tes
9540: 74 73 20 62 79 20 74 65 73 74 6e 61 6d 65 20 61 ts by testname a
9550: 6e 64 20 69 74 65 6d 64 61 74 20 69 6e 20 63 75 nd itemdat in cu
9560: 72 72 2d 74 65 73 74 73 2d 68 61 73 68 0a 20 20 rr-tests-hash.
9570: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
9580: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 (lambda (testda
9590: 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 t). (let*
95a0: 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a ((testname (db:
95b0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
95c0: 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 e testdat))..
95d0: 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 (item-path (d
95e0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
95f0: 70 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 path testdat))..
9600: 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 (full-name
9610: 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 (conc testname
9620: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
9630: 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 .. (hash-table-s
9640: 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 et! curr-tests-h
9650: 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 74 65 ash full-name te
9660: 73 74 64 61 74 29 29 29 0a 20 20 20 20 20 63 75 stdat))). cu
9670: 72 72 2d 74 65 73 74 73 29 0a 20 20 20 20 3b 3b rr-tests). ;;
9680: 20 4e 4f 50 45 3a 20 4e 6f 6e 2d 6f 70 74 69 6d NOPE: Non-optim
9690: 61 6c 20 61 70 70 72 6f 61 63 68 2e 20 54 72 79 al approach. Try
96a0: 20 74 68 69 73 20 69 6e 73 74 65 61 64 2e 0a 20 this instead..
96b0: 20 20 20 3b 3b 20 20 20 31 2e 20 74 65 73 74 73 ;; 1. tests
96c0: 20 61 72 65 20 72 65 63 65 69 76 65 64 20 69 6e are received in
96d0: 20 61 20 6c 69 73 74 2c 20 6d 6f 73 74 20 72 65 a list, most re
96e0: 63 65 6e 74 20 66 69 72 73 74 0a 20 20 20 20 3b cent first. ;
96f0: 3b 20 20 20 32 2e 20 72 65 70 6c 61 63 65 20 74 ; 2. replace t
9700: 68 65 20 72 6f 6c 6c 75 70 20 74 65 73 74 20 77 he rollup test w
9710: 69 74 68 20 74 68 65 20 6e 65 77 20 2a 61 6c 77 ith the new *alw
9720: 61 79 73 2a 0a 20 20 20 20 28 66 6f 72 2d 65 61 ays*. (for-ea
9730: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
9740: 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 (testdat).
9750: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 (let* ((testna
9760: 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 me (db:test-get
9770: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 -testname testda
9780: 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d t)).. (item
9790: 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 -path (db:test-g
97a0: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
97b0: 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 tdat)).. (f
97c0: 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 ull-name (conc t
97d0: 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d estname "/" item
97e0: 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 28 -path)).. (
97f0: 70 72 65 76 2d 74 65 73 74 2d 64 61 74 20 28 68 prev-test-dat (h
9800: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
9810: 66 61 75 6c 74 20 63 75 72 72 2d 74 65 73 74 73 fault curr-tests
9820: 2d 68 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 -hash full-name
9830: 23 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 #f)).. (tes
9840: 74 2d 73 74 65 70 73 20 20 20 20 20 20 28 64 62 t-steps (db
9850: 3a 67 65 74 2d 73 74 65 70 73 2d 66 6f 72 2d 74 :get-steps-for-t
9860: 65 73 74 20 64 62 20 28 64 62 3a 74 65 73 74 2d est db (db:test-
9870: 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 get-id testdat))
9880: 29 0a 09 20 20 20 20 20 20 28 6e 65 77 2d 74 65 ).. (new-te
9890: 73 74 2d 72 65 63 6f 72 64 20 23 66 29 29 0a 09 st-record #f))..
98a0: 20 3b 3b 20 72 65 70 6c 61 63 65 20 74 68 65 73 ;; replace thes
98b0: 65 20 77 69 74 68 20 69 6e 73 65 72 74 20 2e 2e e with insert ..
98c0: 2e 20 73 65 6c 65 63 74 0a 09 20 28 61 70 70 6c . select.. (appl
98d0: 79 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 y sqlite3:execut
98e0: 65 20 0a 09 09 64 62 20 0a 09 09 28 63 6f 6e 63 e ...db ...(conc
98f0: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
9900: 41 43 45 20 49 4e 54 4f 20 74 65 73 74 73 20 28 ACE INTO tests (
9910: 72 75 6e 5f 69 64 2c 74 65 73 74 6e 61 6d 65 2c run_id,testname,
9920: 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 state,status,eve
9930: 6e 74 5f 74 69 6d 65 2c 68 6f 73 74 2c 63 70 75 nt_time,host,cpu
9940: 6c 6f 61 64 2c 64 69 73 6b 66 72 65 65 2c 75 6e load,diskfree,un
9950: 61 6d 65 2c 72 75 6e 64 69 72 2c 69 74 65 6d 5f ame,rundir,item_
9960: 70 61 74 68 2c 72 75 6e 5f 64 75 72 61 74 69 6f path,run_duratio
9970: 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 66 2c 63 6f 6d n,final_logf,com
9980: 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 20 20 20 ment) "...
9990: 22 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f "VALUES (?,?,?,?
99a0: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
99b0: 2c 3f 2c 3f 29 3b 22 29 0a 09 09 6e 65 77 2d 72 ,?,?);")...new-r
99c0: 75 6e 2d 69 64 20 28 63 64 64 72 20 28 76 65 63 un-id (cddr (vec
99d0: 74 6f 72 2d 3e 6c 69 73 74 20 74 65 73 74 64 61 tor->list testda
99e0: 74 29 29 29 0a 09 20 28 73 65 74 21 20 6e 65 77 t))).. (set! new
99f0: 2d 74 65 73 74 64 61 74 20 28 63 61 72 20 28 72 -testdat (car (r
9a00: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
9a10: 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d -run db new-run-
9a20: 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d id testname item
9a30: 2d 70 61 74 68 20 27 28 29 20 27 28 29 29 29 29 -path '() '())))
9a40: 0a 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 .. (hash-table-s
9a50: 65 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 et! curr-tests-h
9a60: 61 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 ash full-name ne
9a70: 77 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 74 68 w-testdat) ;; th
9a80: 69 73 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 is could be conf
9a90: 75 73 69 6e 67 2c 20 77 68 69 63 68 20 72 65 63 using, which rec
9aa0: 6f 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e ord should go in
9ab0: 74 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 to the lookup ta
9ac0: 62 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 ble?.. ;; Now du
9ad0: 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 plicate the test
9ae0: 20 73 74 65 70 73 0a 09 20 28 64 65 62 75 67 3a steps.. (debug:
9af0: 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 print 4 "Copying
9b00: 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 records in test
9b10: 5f 73 74 65 70 73 20 66 72 6f 6d 20 74 65 73 74 _steps from test
9b20: 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 _id=" (db:test-g
9b30: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 et-id testdat) "
9b40: 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 to " (db:test-g
9b50: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
9b60: 74 29 29 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 t)).. (sqlite3:e
9b70: 78 65 63 75 74 65 20 0a 09 20 20 64 62 20 0a 09 xecute .. db ..
9b80: 20 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 (conc "INSERT
9b90: 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 OR REPLACE INTO
9ba0: 74 65 73 74 5f 73 74 65 70 73 20 28 74 65 73 74 test_steps (test
9bb0: 5f 69 64 2c 73 74 65 70 6e 61 6d 65 2c 73 74 61 _id,stepname,sta
9bc0: 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f te,status,event_
9bd0: 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a time,comment) ".
9be0: 09 09 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a .."SELECT " (db:
9bf0: 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d test-get-id new-
9c00: 74 65 73 74 64 61 74 29 20 22 2c 73 74 65 70 6e testdat) ",stepn
9c10: 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 73 ame,state,status
9c20: 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d ,event_time,comm
9c30: 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 73 74 ent FROM test_st
9c40: 65 70 73 20 57 48 45 52 45 20 74 65 73 74 5f 69 eps WHERE test_i
9c50: 64 3d 3f 3b 22 29 0a 09 20 20 28 64 62 3a 74 65 d=?;").. (db:te
9c60: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 st-get-id testda
9c70: 74 29 29 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 t)).. ;; Now dup
9c80: 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 licate the test
9c90: 64 61 74 61 0a 09 20 28 64 65 62 75 67 3a 70 72 data.. (debug:pr
9ca0: 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 72 int 4 "Copying r
9cb0: 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f 64 ecords in test_d
9cc0: 61 74 61 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 ata from test_id
9cd0: 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d =" (db:test-get-
9ce0: 69 64 20 74 65 73 74 64 61 74 29 20 22 20 74 6f id testdat) " to
9cf0: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
9d00: 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 id new-testdat))
9d10: 0a 09 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 .. (sqlite3:exec
9d20: 75 74 65 20 0a 09 20 20 64 62 20 0a 09 20 20 28 ute .. db .. (
9d30: 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 conc "INSERT OR
9d40: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 REPLACE INTO tes
9d50: 74 5f 64 61 74 61 20 28 74 65 73 74 5f 69 64 2c t_data (test_id,
9d60: 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c category,variabl
9d70: 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 e,value,expected
9d80: 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 ,tol,units,comme
9d90: 6e 74 29 20 22 0a 09 09 22 53 45 4c 45 43 54 20 nt) "..."SELECT
9da0: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 " (db:test-get-i
9db0: 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 d new-testdat) "
9dc0: 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 ,category,variab
9dd0: 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 le,value,expecte
9de0: 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d d,tol,units,comm
9df0: 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 ent FROM test_da
9e00: 74 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 ta WHERE test_id
9e10: 3d 3f 3b 22 29 0a 09 20 20 28 64 62 3a 74 65 73 =?;").. (db:tes
9e20: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
9e30: 29 29 0a 09 20 29 29 0a 20 20 20 20 20 70 72 65 )).. )). pre
9e40: 76 2d 74 65 73 74 73 29 29 29 0a 09 20 0a 20 20 v-tests))).. .
9e50: 20 20 20 0a .