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 28 64 65 66 69 6e 65 20 28 73 65 74 2d 6d ..(define (set-m
0870: 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 egatest-env-vars
0880: 20 64 62 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c db run-id). (l
0890: 65 74 20 28 28 6b 65 79 73 20 28 64 62 3a 67 65 et ((keys (db:ge
08a0: 74 2d 6b 65 79 73 20 64 62 29 29 29 0a 20 20 20 t-keys db))).
08b0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
08c0: 64 61 20 28 6b 65 79 29 0a 09 09 28 73 71 6c 69 da (key)...(sqli
08d0: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
08e0: 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 76 61 6c ... (lambda (val
08f0: 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 )... (debug:pr
0900: 69 6e 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 int 2 "setenv "
0910: 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 (key:get-fieldna
0920: 6d 65 20 6b 65 79 29 20 22 20 22 20 76 61 6c 29 me key) " " val)
0930: 0a 09 09 20 20 20 28 73 65 74 65 6e 76 20 28 6b ... (setenv (k
0940: 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 ey:get-fieldname
0950: 20 6b 65 79 29 20 76 61 6c 29 29 0a 09 09 20 64 key) val))... d
0960: 62 20 0a 09 09 20 28 63 6f 6e 63 20 22 53 45 4c b ... (conc "SEL
0970: 45 43 54 20 22 20 28 6b 65 79 3a 67 65 74 2d 66 ECT " (key:get-f
0980: 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 20 22 20 ieldname key) "
0990: 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 FROM runs WHERE
09a0: 69 64 3d 3f 3b 22 29 0a 09 09 20 72 75 6e 2d 69 id=?;")... run-i
09b0: 64 29 29 0a 09 20 20 20 20 20 20 6b 65 79 73 29 d)).. keys)
09c0: 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 . (alist->env
09d0: 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 62 6c -vars (hash-tabl
09e0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 e-ref/default *c
09f0: 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d 6f onfigdat* "env-o
0a00: 76 65 72 72 69 64 65 22 20 27 28 29 29 29 0a 20 verride" '())).
0a10: 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 20 74 ;; Lets use t
0a20: 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f 72 74 his as an opport
0a30: 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d 54 5f unity to put MT_
0a40: 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 20 65 RUNNAME in the e
0a50: 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 28 nvironment. (
0a60: 73 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 sqlite3:for-each
0a70: 2d 72 6f 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 -row. (lambd
0a80: 61 20 28 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 a (runname).
0a90: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 (setenv "MT_R
0aa0: 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d 65 29 UNNAME" runname)
0ab0: 29 0a 20 20 20 20 20 64 62 0a 20 20 20 20 20 22 ). db. "
0ac0: 53 45 4c 45 43 54 20 72 75 6e 6e 61 6d 65 20 46 SELECT runname F
0ad0: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 69 ROM runs WHERE i
0ae0: 64 3d 3f 3b 22 0a 20 20 20 20 20 72 75 6e 2d 69 d=?;". run-i
0af0: 64 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 d). ))..(defi
0b00: 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 ne (set-item-env
0b10: 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 -vars itemdat).
0b20: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
0b30: 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 da (item)..
0b40: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
0b50: 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 "setenv " (car i
0b60: 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 tem) " " (cadr i
0b70: 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 tem)).. (se
0b80: 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 tenv (car item)
0b90: 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 (cadr item)))..
0ba0: 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 itemdat))..(d
0bb0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6e 2d efine (runs:can-
0bc0: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 run-more-tests d
0bd0: 62 20 74 65 73 74 2d 72 65 63 6f 72 64 29 0a 20 b test-record).
0be0: 20 28 6c 65 74 2a 20 28 28 74 63 6f 6e 66 69 67 (let* ((tconfig
0bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c00: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
0c10: 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 e-get-testconfig
0c20: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
0c30: 20 28 6a 6f 62 67 72 6f 75 70 20 20 20 20 20 20 (jobgroup
0c40: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 66 69 (confi
0c50: 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 g-lookup tconfig
0c60: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
0c70: 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 20 28 "jobgroup")).. (
0c80: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 num-running
0c90: 20 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d (db:get-
0ca0: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
0cb0: 69 6e 67 20 64 62 29 29 0a 09 20 28 6e 75 6d 2d ing db)).. (num-
0cc0: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
0cd0: 6f 75 70 20 28 64 62 3a 67 65 74 2d 63 6f 75 6e oup (db:get-coun
0ce0: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d t-tests-running-
0cf0: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 64 62 20 6a in-jobgroup db j
0d00: 6f 62 67 72 6f 75 70 29 29 0a 09 20 28 6d 61 78 obgroup)).. (max
0d10: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
0d20: 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f (config-loo
0d30: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
0d40: 22 73 65 74 75 70 22 20 20 20 20 20 22 6d 61 78 "setup" "max
0d50: 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 _concurrent_jobs
0d60: 22 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 70 ")).. (job-group
0d70: 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 28 -limit (
0d80: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
0d90: 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 67 72 onfigdat* "jobgr
0da0: 6f 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 29 29 oups" jobgroup))
0db0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
0dc0: 6e 74 20 32 20 22 6d 61 78 2d 63 6f 6e 63 75 72 nt 2 "max-concur
0dd0: 72 65 6e 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 rent-jobs: " max
0de0: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
0df0: 20 22 2c 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a ", num-running:
0e00: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a " num-running).
0e10: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
0e20: 3f 20 30 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 ? 0 *globalexits
0e30: 74 61 74 75 73 2a 29 29 0a 09 23 66 0a 09 28 6c tatus*))..#f..(l
0e40: 65 74 20 28 28 63 61 6e 2d 6e 6f 74 2d 72 75 6e et ((can-not-run
0e50: 2d 6d 6f 72 65 20 28 63 6f 6e 64 0a 09 09 09 09 -more (cond.....
0e60: 20 3b 3b 20 69 66 20 6d 61 78 2d 63 6f 6e 63 75 ;; if max-concu
0e70: 72 72 65 6e 74 2d 6a 6f 62 73 20 69 73 20 73 65 rrent-jobs is se
0e80: 74 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 t and the number
0e90: 20 72 75 6e 6e 69 6e 67 20 69 73 20 67 72 65 61 running is grea
0ea0: 74 65 72 20 0a 09 09 09 09 20 3b 3b 20 74 68 61 ter ..... ;; tha
0eb0: 6e 20 69 74 20 74 68 61 6e 20 63 61 6e 6e 6f 74 n it than cannot
0ec0: 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 0a 09 run more jobs..
0ed0: 09 09 09 20 28 28 61 6e 64 20 6d 61 78 2d 63 6f ... ((and max-co
0ee0: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 0a 09 09 ncurrent-jobs...
0ef0: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
0f00: 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e ->number max-con
0f10: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 current-jobs)...
0f20: 09 09 20 20 20 20 20 20 20 28 3e 3d 20 6e 75 6d .. (>= num
0f30: 2d 72 75 6e 6e 69 6e 67 20 28 73 74 72 69 6e 67 -running (string
0f40: 2d 3e 6e 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e ->number max-con
0f50: 63 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 29 0a current-jobs))).
0f60: 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
0f70: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d nt 0 "WARNING: M
0f80: 61 78 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 ax running jobs
0f90: 65 78 63 65 65 64 65 64 2c 20 63 75 72 72 65 6e exceeded, curren
0fa0: 74 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 t number running
0fb0: 3a 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 : " num-running
0fc0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 22 2c 20 ...... ",
0fd0: 6d 61 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a max_concurrent_j
0fe0: 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 obs: " max-concu
0ff0: 72 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 09 09 rrent-jobs).....
1000: 20 20 23 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 #t)..... ;; if
1010: 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 job-group-limit
1020: 20 69 73 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 is set and numb
1030: 65 72 20 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 er of jobs in th
1040: 65 20 67 72 6f 75 70 20 69 73 20 67 72 65 61 74 e group is great
1050: 65 72 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 er..... ;; than
1060: 74 68 65 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 the limit then c
1070: 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a annot run more j
1080: 6f 62 73 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 obs of this kind
1090: 0a 09 09 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d ..... ((and job-
10a0: 67 72 6f 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 group-limit.....
10b0: 20 20 20 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 (>= num-r
10c0: 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f unning-in-jobgro
10d0: 75 70 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d up job-group-lim
10e0: 69 74 29 29 0a 09 09 09 09 20 20 28 64 65 62 75 it))..... (debu
10f0: 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 g:print 1 "WARNI
1100: 4e 47 3a 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f NG: number of jo
1110: 62 73 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 bs " num-running
1120: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 -in-jobgroup ...
1130: 09 09 09 20 20 20 20 20 20 20 22 20 69 6e 20 22 ... " in "
1140: 20 6a 6f 62 67 72 6f 75 70 20 22 20 65 78 63 65 jobgroup " exce
1150: 65 64 65 64 2c 20 77 69 6c 6c 20 6e 6f 74 20 72 eded, will not r
1160: 75 6e 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 un " (tests:test
1170: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 queue-get-testna
1180: 6d 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 me test-record))
1190: 0a 09 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 ..... #t).....
11a0: 28 65 6c 73 65 20 23 66 29 29 29 29 0a 09 20 20 (else #f))))..
11b0: 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e (not can-not-run
11c0: 2d 6d 6f 72 65 29 29 29 29 29 0a 0a 3b 3b 3d 3d -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 0a 3b 3b 20 4e 65 77 20 6d 65 74 68 ====.;; New meth
1220: 6f 64 6f 6c 6f 67 79 2e 20 54 68 65 73 65 20 72 odology. These r
1230: 6f 75 74 69 6e 65 73 20 77 69 6c 6c 20 72 65 70 outines will rep
1240: 6c 61 63 65 20 74 68 65 20 61 62 6f 76 65 20 69 lace the above i
1250: 6e 20 74 69 6d 65 2e 20 46 6f 72 0a 3b 3b 20 6e n time. For.;; n
1260: 6f 77 20 74 68 65 20 63 6f 64 65 20 69 73 20 64 ow the code is d
1270: 75 70 6c 69 63 61 74 65 64 2e 20 54 68 69 73 20 uplicated. This
1280: 73 74 75 66 66 20 69 73 20 69 6e 69 74 69 61 6c stuff is initial
1290: 6c 79 20 75 73 65 64 20 69 6e 20 74 68 65 20 6d ly used in the m
12a0: 6f 6e 69 74 6f 72 0a 3b 3b 20 62 61 73 65 64 20 onitor.;; based
12b0: 63 6f 64 65 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 0a ==============..
1300: 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 74 65 ;; register a te
1310: 73 74 20 72 75 6e 20 77 69 74 68 20 74 68 65 20 st run with the
1320: 64 62 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 db.(define (runs
1330: 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 20 64 62 :register-run db
1340: 20 6b 65 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 keys keyvallst
1350: 72 75 6e 6e 61 6d 65 20 73 74 61 74 65 20 73 74 runname state st
1360: 61 74 75 73 20 75 73 65 72 29 0a 20 20 28 64 65 atus user). (de
1370: 62 75 67 3a 70 72 69 6e 74 20 33 20 22 72 75 6e bug:print 3 "run
1380: 73 3a 72 65 67 69 73 74 65 72 2d 72 75 6e 2c 20 s:register-run,
1390: 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 6b keys: " keys " k
13a0: 65 79 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 eyvallst: " keyv
13b0: 61 6c 6c 73 74 20 22 20 72 75 6e 6e 61 6d 65 3a allst " runname:
13c0: 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 73 74 61 " runname " sta
13d0: 74 65 3a 20 22 20 73 74 61 74 65 20 22 20 73 74 te: " state " st
13e0: 61 74 75 73 3a 20 22 20 73 74 61 74 75 73 20 22 atus: " status "
13f0: 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a 20 user: " user).
1400: 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 74 72 20 (let* ((keystr
1410: 20 20 20 28 6b 65 79 73 2d 3e 6b 65 79 73 74 72 (keys->keystr
1420: 20 6b 65 79 73 29 29 0a 09 20 28 63 6f 6d 6d 61 keys)).. (comma
1430: 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e (if (> (len
1440: 67 74 68 20 6b 65 79 73 29 20 30 29 20 22 2c 22 gth keys) 0) ","
1450: 20 22 22 29 29 0a 09 20 28 61 6e 64 73 74 72 20 "")).. (andstr
1460: 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 (if (> (lengt
1470: 68 20 6b 65 79 73 29 20 30 29 20 22 20 41 4e 44 h keys) 0) " AND
1480: 20 22 20 22 22 29 29 0a 09 20 28 76 61 6c 73 6c " "")).. (valsl
1490: 6f 74 73 20 20 28 6b 65 79 73 2d 3e 76 61 6c 73 ots (keys->vals
14a0: 6c 6f 74 73 20 6b 65 79 73 29 29 20 3b 3b 20 3f lots keys)) ;; ?
14b0: 2c 3f 2c 3f 20 2e 2e 2e 0a 09 20 28 6b 65 79 76 ,?,? ..... (keyv
14c0: 61 6c 73 20 20 20 28 6d 61 70 20 63 61 64 72 20 als (map cadr
14d0: 6b 65 79 76 61 6c 6c 73 74 29 29 0a 09 20 28 61 keyvallst)).. (a
14e0: 6c 6c 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 llvals (append
14f0: 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 20 73 (list runname s
1500: 74 61 74 65 20 73 74 61 74 75 73 20 75 73 65 72 tate status user
1510: 29 20 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 71 ) keyvals)).. (q
1520: 72 79 76 61 6c 73 20 20 20 28 61 70 70 65 6e 64 ryvals (append
1530: 20 28 6c 69 73 74 20 72 75 6e 6e 61 6d 65 29 20 (list runname)
1540: 6b 65 79 76 61 6c 73 29 29 0a 09 20 28 6b 65 79 keyvals)).. (key
1550: 3d 3f 73 74 72 20 20 28 73 74 72 69 6e 67 2d 69 =?str (string-i
1560: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
1570: 28 6c 61 6d 62 64 61 20 28 6b 29 28 63 6f 6e 63 (lambda (k)(conc
1580: 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e (key:get-fieldn
1590: 61 6d 65 20 6b 29 20 22 3d 3f 22 29 29 20 6b 65 ame k) "=?")) ke
15a0: 79 73 29 20 22 20 41 4e 44 20 22 29 29 29 0a 20 ys) " AND "))).
15b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
15c0: 33 20 22 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 3 "keys: " keys
15d0: 22 20 61 6c 6c 76 61 6c 73 3a 20 22 20 61 6c 6c " allvals: " all
15e0: 76 61 6c 73 20 22 20 6b 65 79 76 61 6c 73 3a 20 vals " keyvals:
15f0: 22 20 6b 65 79 76 61 6c 73 29 0a 20 20 20 20 28 " keyvals). (
1600: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e debug:print 2 "N
1610: 4f 54 45 3a 20 75 73 69 6e 67 20 74 61 72 67 65 OTE: using targe
1620: 74 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 t " (string-inte
1630: 72 73 70 65 72 73 65 20 6b 65 79 76 61 6c 73 20 rsperse keyvals
1640: 22 2f 22 29 20 22 20 66 6f 72 20 74 68 69 73 20 "/") " for this
1650: 72 75 6e 22 29 0a 20 20 20 20 28 69 66 20 28 61 run"). (if (a
1660: 6e 64 20 72 75 6e 6e 61 6d 65 20 28 6e 75 6c 6c nd runname (null
1670: 3f 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 ? (filter (lambd
1680: 61 20 28 78 29 28 6e 6f 74 20 78 29 29 20 6b 65 a (x)(not x)) ke
1690: 79 76 61 6c 73 29 29 29 20 3b 3b 20 74 68 65 72 yvals))) ;; ther
16a0: 65 20 6d 75 73 74 20 62 65 20 61 20 62 65 74 74 e must be a bett
16b0: 65 72 20 77 61 79 20 74 6f 20 22 61 70 70 6c 79 er way to "apply
16c0: 20 61 6e 64 22 0a 09 28 6c 65 74 20 28 28 72 65 and"..(let ((re
16d0: 73 20 23 66 29 29 0a 09 20 20 28 61 70 70 6c 79 s #f)).. (apply
16e0: 20 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 sqlite3:execute
16f0: 20 64 62 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 db (conc "INSER
1700: 54 20 4f 52 20 49 47 4e 4f 52 45 20 49 4e 54 4f T OR IGNORE INTO
1710: 20 72 75 6e 73 20 28 72 75 6e 6e 61 6d 65 2c 73 runs (runname,s
1720: 74 61 74 65 2c 73 74 61 74 75 73 2c 6f 77 6e 65 tate,status,owne
1730: 72 2c 65 76 65 6e 74 5f 74 69 6d 65 22 20 63 6f r,event_time" co
1740: 6d 6d 61 20 6b 65 79 73 74 72 20 22 29 20 56 41 mma keystr ") VA
1750: 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 73 74 LUES (?,?,?,?,st
1760: 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 rftime('%s','now
1770: 27 29 22 20 63 6f 6d 6d 61 20 76 61 6c 73 6c 6f ')" comma valslo
1780: 74 73 20 22 29 3b 22 29 0a 09 09 20 61 6c 6c 76 ts ");")... allv
1790: 61 6c 73 29 0a 09 20 20 28 61 70 70 6c 79 20 73 als).. (apply s
17a0: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
17b0: 72 6f 77 20 0a 09 20 20 20 28 6c 61 6d 62 64 61 row .. (lambda
17c0: 20 28 69 64 29 0a 09 20 20 20 20 20 28 73 65 74 (id).. (set
17d0: 21 20 72 65 73 20 69 64 29 29 0a 09 20 20 20 64 ! res id)).. d
17e0: 62 0a 09 20 20 20 28 6c 65 74 20 28 28 71 72 79 b.. (let ((qry
17f0: 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 (conc "SELECT i
1800: 64 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 d FROM runs WHER
1810: 45 20 28 72 75 6e 6e 61 6d 65 3d 3f 20 22 20 61 E (runname=? " a
1820: 6e 64 73 74 72 20 6b 65 79 3d 3f 73 74 72 20 22 ndstr key=?str "
1830: 29 3b 22 29 29 29 0a 09 20 20 20 20 20 3b 28 64 );"))).. ;(d
1840: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 71 72 ebug:print 4 "qr
1850: 79 3a 20 22 20 71 72 79 29 20 0a 09 20 20 20 20 y: " qry) ..
1860: 20 71 72 79 29 0a 09 20 20 20 71 72 79 76 61 6c qry).. qryval
1870: 73 29 0a 09 20 20 28 73 71 6c 69 74 65 33 3a 65 s).. (sqlite3:e
1880: 78 65 63 75 74 65 20 64 62 20 22 55 50 44 41 54 xecute db "UPDAT
1890: 45 20 72 75 6e 73 20 53 45 54 20 73 74 61 74 65 E runs SET state
18a0: 3d 3f 2c 73 74 61 74 75 73 3d 3f 20 57 48 45 52 =?,status=? WHER
18b0: 45 20 69 64 3d 3f 3b 22 20 73 74 61 74 65 20 73 E id=?;" state s
18c0: 74 61 74 75 73 20 72 65 73 29 0a 09 20 20 72 65 tatus res).. re
18d0: 73 29 20 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 s) ..(begin.. (
18e0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
18f0: 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 77 69 74 RROR: Called wit
1900: 68 6f 75 74 20 61 6c 6c 20 6e 65 63 65 73 73 61 hout all necessa
1910: 72 79 20 6b 65 79 73 22 29 0a 09 20 20 23 66 29 ry keys").. #f)
1920: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 )))..;; This is
1930: 61 20 64 75 70 6c 69 63 61 74 65 20 6f 66 20 72 a duplicate of r
1940: 75 6e 2d 74 65 73 74 73 20 28 77 68 69 63 68 20 un-tests (which
1950: 68 61 73 20 62 65 65 6e 20 64 65 70 72 65 63 61 has been depreca
1960: 74 65 64 29 2e 20 55 73 65 20 74 68 69 73 20 6f ted). Use this o
1970: 6e 65 20 69 6e 73 74 65 61 64 20 6f 66 20 72 75 ne instead of ru
1980: 6e 20 74 65 73 74 73 2e 0a 3b 3b 20 6b 65 79 76 n tests..;; keyv
1990: 61 6c 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e als.(define (run
19a0: 73 3a 72 75 6e 2d 74 65 73 74 73 20 64 62 20 74 s:run-tests db t
19b0: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 arget runname te
19c0: 73 74 2d 70 61 74 74 73 20 75 73 65 72 20 66 6c st-patts user fl
19d0: 61 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b ags). (let* ((k
19e0: 65 79 73 20 20 20 20 20 20 20 20 28 72 64 62 3a eys (rdb:
19f0: 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 get-keys db))..
1a00: 28 6b 65 79 76 61 6c 6c 73 74 20 20 20 28 6b 65 (keyvallst (ke
1a10: 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 ys:target->keyva
1a20: 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a l keys target)).
1a30: 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 20 28 . (run-id (
1a40: 72 75 6e 73 3a 72 65 67 69 73 74 65 72 2d 72 75 runs:register-ru
1a50: 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 76 61 6c n db keys keyval
1a60: 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 lst runname "new
1a70: 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 " "n/a" user))
1a80: 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 ;; test-name)))
1a90: 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 20 20 .. (deferred
1aa0: 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 '()) ;; delay ru
1ab0: 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 nning these sinc
1ac0: 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 61 e they have a wa
1ad0: 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b iton clause.. ;;
1ae0: 20 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 74 68 keepgoing is th
1af0: 65 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 e defacto modali
1b00: 74 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 ty now, will add
1b10: 20 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 hit-n-run a bit
1b20: 20 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 later.. ;; (kee
1b30: 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 pgoing (hash-t
1b40: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
1b50: 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 flags "-keepgoi
1b60: 6e 67 22 20 23 66 29 29 0a 09 20 28 74 65 73 74 ng" #f)).. (test
1b70: 2d 6e 61 6d 65 73 20 20 27 28 29 29 0a 09 20 28 -names '()).. (
1b80: 72 75 6e 63 6f 6e 66 69 67 66 20 20 20 28 63 6f runconfigf (co
1b90: 6e 63 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f nc *toppath* "/
1ba0: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
1bb0: 67 22 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 g")).. (required
1bc0: 2d 74 65 73 74 73 20 27 28 29 29 0a 09 20 28 74 -tests '()).. (t
1bd0: 65 73 74 2d 72 65 63 6f 72 64 73 20 28 6d 61 6b est-records (mak
1be0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
1bf0: 0a 20 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 . (set-megate
1c00: 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 st-env-vars db r
1c10: 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 un-id) ;; these
1c20: 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 may be needed by
1c30: 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 the launching p
1c40: 72 6f 63 65 73 73 0a 0a 20 20 20 20 28 69 66 20 rocess.. (if
1c50: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 (file-exists? ru
1c60: 6e 63 6f 6e 66 69 67 66 29 0a 09 28 73 65 74 75 nconfigf)..(setu
1c70: 70 2d 65 6e 76 2d 64 65 66 61 75 6c 74 73 20 64 p-env-defaults d
1c80: 62 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 6e b runconfigf run
1c90: 2d 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 -id *already-see
1ca0: 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f n-runconfig-info
1cb0: 2a 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e * "pre-launch-en
1cc0: 76 2d 76 61 72 73 22 29 0a 09 28 64 65 62 75 67 v-vars")..(debug
1cd0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
1ce0: 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 G: You do not ha
1cf0: 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 ve a run config
1d00: 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 file: " runconfi
1d10: 67 66 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b gf)). . ;;
1d20: 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 look up all tes
1d30: 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 20 ts matching the
1d40: 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 comma separated
1d50: 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e list of globs in
1d60: 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 . ;; test-pat
1d70: 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 77 ts (using % as w
1d80: 69 6c 64 63 61 72 64 29 0a 20 20 20 20 28 66 6f ildcard). (fo
1d90: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
1da0: 6d 62 64 61 20 28 70 61 74 74 29 0a 20 20 20 20 mbda (patt).
1db0: 20 20 20 28 6c 65 74 20 28 28 74 65 73 74 73 20 (let ((tests
1dc0: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 2a 74 6f 70 (glob (conc *top
1dd0: 70 61 74 68 2a 20 22 2f 74 65 73 74 73 2f 22 20 path* "/tests/"
1de0: 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 (string-translat
1df0: 65 20 70 61 74 74 20 22 25 22 20 22 2a 22 29 29 e patt "%" "*"))
1e00: 29 29 29 0a 09 20 28 73 65 74 21 20 74 65 73 74 ))).. (set! test
1e10: 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 s (filter (lambd
1e20: 61 20 28 74 65 73 74 29 28 66 69 6c 65 2d 65 78 a (test)(file-ex
1e30: 69 73 74 73 3f 20 28 63 6f 6e 63 20 74 65 73 74 ists? (conc test
1e40: 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 29 "/testconfig"))
1e50: 29 20 74 65 73 74 73 29 29 0a 09 20 28 73 65 74 ) tests)).. (set
1e60: 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 61 70 ! test-names (ap
1e70: 70 65 6e 64 20 74 65 73 74 2d 6e 61 6d 65 73 20 pend test-names
1e80: 0a 09 09 09 09 20 20 28 6d 61 70 20 28 6c 61 6d ..... (map (lam
1e90: 62 64 61 20 28 74 65 73 74 70 29 0a 09 09 09 09 bda (testp).....
1ea0: 09 20 28 6c 61 73 74 20 28 73 74 72 69 6e 67 2d . (last (string-
1eb0: 73 70 6c 69 74 20 74 65 73 74 70 20 22 2f 22 29 split testp "/")
1ec0: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 74 65 ))..... te
1ed0: 73 74 73 29 29 29 29 29 0a 20 20 20 20 20 28 69 sts))))). (i
1ee0: 66 20 74 65 73 74 2d 70 61 74 74 73 20 28 73 74 f test-patts (st
1ef0: 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 73 74 2d ring-split test-
1f00: 70 61 74 74 73 20 22 2c 22 29 28 6c 69 73 74 20 patts ",")(list
1f10: 22 25 22 29 29 29 0a 0a 20 20 20 20 20 3b 3b 20 "%"))).. ;;
1f20: 6e 6f 77 20 72 65 6d 6f 76 65 20 64 75 70 6c 69 now remove dupli
1f30: 63 61 74 65 73 0a 20 20 20 20 28 73 65 74 21 20 cates. (set!
1f40: 74 65 73 74 2d 6e 61 6d 65 73 20 28 64 65 6c 65 test-names (dele
1f50: 74 65 2d 64 75 70 6c 69 63 61 74 65 73 20 74 65 te-duplicates te
1f60: 73 74 2d 6e 61 6d 65 73 29 29 0a 0a 20 20 20 20 st-names))..
1f70: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
1f80: 49 4e 46 4f 3a 20 74 65 73 74 20 6e 61 6d 65 73 INFO: test names
1f90: 20 22 20 74 65 73 74 2d 6e 61 6d 65 73 29 0a 0a " test-names)..
1fa0: 20 20 20 20 3b 3b 20 6f 6e 20 74 68 65 20 66 69 ;; on the fi
1fb0: 72 73 74 20 70 61 73 73 20 6f 72 20 63 61 6c 6c rst pass or call
1fc0: 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 73 65 to run-tests se
1fd0: 74 20 46 41 49 4c 53 20 74 6f 20 4e 4f 54 5f 53 t FAILS to NOT_S
1fe0: 54 41 52 54 45 44 20 69 66 0a 20 20 20 20 3b 3b TARTED if. ;;
1ff0: 20 2d 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 73 -keepgoing is s
2000: 70 65 63 69 66 69 65 64 0a 20 20 20 20 28 69 66 pecified. (if
2010: 20 28 65 71 3f 20 2a 70 61 73 73 6e 75 6d 2a 20 (eq? *passnum*
2020: 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 3b 3b 0)..(begin.. ;;
2030: 20 68 61 76 65 20 74 6f 20 64 65 6c 65 74 65 20 have to delete
2040: 74 65 73 74 20 72 65 63 6f 72 64 73 20 77 68 65 test records whe
2050: 72 65 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 73 re NOT_STARTED s
2060: 69 6e 63 65 20 74 68 65 79 20 63 61 6e 20 63 61 ince they can ca
2070: 75 73 65 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 use -keepgoing t
2080: 6f 20 0a 09 20 20 3b 3b 20 67 65 74 20 73 74 75 o .. ;; get stu
2090: 63 6b 20 64 75 65 20 74 6f 20 62 65 63 6f 6d 69 ck due to becomi
20a0: 6e 67 20 69 6e 61 63 63 65 73 73 69 62 6c 65 20 ng inaccessible
20b0: 66 72 6f 6d 20 61 20 66 61 69 6c 65 64 20 74 65 from a failed te
20c0: 73 74 2e 20 49 2e 65 2e 20 69 66 20 74 65 73 74 st. I.e. if test
20d0: 20 42 20 64 65 70 65 6e 64 73 20 0a 09 20 20 3b B depends .. ;
20e0: 3b 20 6f 6e 20 74 65 73 74 20 41 20 62 75 74 20 ; on test A but
20f0: 74 65 73 74 20 42 20 72 65 61 63 68 65 64 20 74 test B reached t
2100: 68 65 20 70 6f 69 6e 74 20 6f 6e 20 62 65 69 6e he point on bein
2110: 67 20 72 65 67 69 73 74 65 72 65 64 20 61 73 20 g registered as
2120: 4e 4f 54 5f 53 54 41 52 54 45 44 20 61 6e 64 20 NOT_STARTED and
2130: 74 65 73 74 0a 09 20 20 3b 3b 20 41 20 66 61 69 test.. ;; A fai
2140: 6c 65 64 20 66 6f 72 20 73 6f 6d 65 20 72 65 61 led for some rea
2150: 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 72 65 2d 72 son then on re-r
2160: 75 6e 20 75 73 69 6e 67 20 2d 6b 65 65 70 67 6f un using -keepgo
2170: 69 6e 67 20 74 68 65 20 72 75 6e 20 63 61 6e 20 ing the run can
2180: 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 65 2e 0a never complete..
2190: 09 20 20 28 64 62 3a 64 65 6c 65 74 65 2d 74 65 . (db:delete-te
21a0: 73 74 73 2d 69 6e 2d 73 74 61 74 65 20 64 62 20 sts-in-state db
21b0: 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 run-id "NOT_STAR
21c0: 54 45 44 22 29 0a 09 20 20 28 72 64 62 3a 73 65 TED").. (rdb:se
21d0: 74 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 t-tests-state-st
21e0: 61 74 75 73 20 64 62 20 72 75 6e 2d 69 64 20 74 atus db run-id t
21f0: 65 73 74 2d 6e 61 6d 65 73 20 23 66 20 22 46 41 est-names #f "FA
2200: 49 4c 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 IL" "NOT_STARTED
2210: 22 20 22 46 41 49 4c 22 29 29 29 0a 0a 20 20 20 " "FAIL")))..
2220: 20 3b 3b 20 66 72 6f 6d 20 68 65 72 65 20 6f 6e ;; from here on
2230: 20 6f 75 74 20 74 68 65 20 64 62 20 77 69 6c 6c out the db will
2240: 20 62 65 20 6f 70 65 6e 65 64 20 61 6e 64 20 63 be opened and c
2250: 6c 6f 73 65 64 20 6f 6e 20 65 76 65 72 79 20 63 losed on every c
2260: 61 6c 6c 20 72 75 6e 73 3a 72 75 6e 2d 74 65 73 all runs:run-tes
2270: 74 73 2d 71 75 65 75 65 0a 20 20 20 20 28 73 71 ts-queue. (sq
2280: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
2290: 64 62 29 20 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 db) . ;; now
22a0: 61 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 add non-directly
22b0: 20 72 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 referenced depe
22c0: 6e 64 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 ndencies (i.e. w
22d0: 61 69 74 6f 6e 29 0a 20 20 20 20 28 69 66 20 28 aiton). (if (
22e0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d not (null? test-
22f0: 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f names))..(let lo
2300: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 65 op ((hed (car te
2310: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 st-names))...
2320: 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e (tal (cdr test-n
2330: 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 20 ames)))
2340: 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ;; 'return-procs
2350: 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 tells the confi
2360: 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 g reader to prep
2370: 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 running system
2380: 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f but return a pro
2390: 63 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e c.. (let* ((con
23a0: 66 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d fig (tests:get-
23b0: 74 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 27 testconfig hed '
23c0: 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 return-procs))..
23d0: 09 20 28 77 61 69 74 6f 6e 73 20 28 69 66 20 63 . (waitons (if c
23e0: 6f 6e 66 69 67 20 28 73 74 72 69 6e 67 2d 73 70 onfig (string-sp
23f0: 6c 69 74 20 28 6c 65 74 20 28 28 77 20 28 63 6f lit (let ((w (co
2400: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 nfig-lookup conf
2410: 69 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 ig "requirements
2420: 22 20 22 77 61 69 74 6f 6e 22 29 29 29 0a 09 09 " "waiton")))...
2430: 09 09 09 09 20 20 20 20 20 28 69 66 20 77 20 77 .... (if w w
2440: 20 22 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 "")))....
2450: 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 (begin.....(debu
2460: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
2470: 3a 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 : non-existent r
2480: 65 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 equired test \""
2490: 20 68 65 64 20 22 5c 22 22 29 0a 20 20 20 20 20 hed "\"").
24a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24b0: 20 20 20 20 20 20 20 20 20 20 20 28 73 71 6c 69 (sqli
24c0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
24d0: 29 0a 09 09 09 09 28 65 78 69 74 20 31 29 29 29 ).....(exit 1)))
24e0: 29 29 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b )).. ;; check
24f0: 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 for hed in wait
2500: 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c ons => this woul
2510: 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 d be circular, r
2520: 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 emove it and iss
2530: 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 ue an.. ;; er
2540: 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 ror.. (if (me
2550: 6d 62 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 mber hed waitons
2560: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
2570: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
2580: 52 52 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 RROR: test " hed
2590: 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 " has listed it
25a0: 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e self as a waiton
25b0: 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 , please correct
25c0: 20 74 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 this!")... (se
25d0: 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 t! waitons (filt
25e0: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e er (lambda (x)(n
25f0: 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 ot (equal? x hed
2600: 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a ))) waitons)))).
2610: 09 20 20 20 20 0a 09 20 20 20 20 3b 3b 20 28 69 . .. ;; (i
2620: 74 65 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 tems (items:ge
2630: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
2640: 66 69 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 20 fig config)))..
2650: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 (if (not (has
2660: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
2670: 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ult test-records
2680: 20 68 65 64 20 23 66 29 29 0a 09 09 28 68 61 73 hed #f))...(has
2690: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
26a0: 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 20 68 t-records..... h
26b0: 65 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 ed (vector hed
26c0: 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 20 20 20 ;; 0......
26d0: 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 config ;; 1..
26e0: 09 09 09 09 20 20 20 20 20 77 61 69 74 6f 6e 73 .... waitons
26f0: 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 20 20 20 ;; 2......
2700: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
2710: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
2720: 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 nts" "priority")
2730: 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 ;; priority
2740: 20 33 0a 09 09 09 09 09 20 20 20 20 20 28 6c 65 3...... (le
2750: 74 20 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 t ((items (
2760: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
2770: 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
2780: 74 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 tems" #f)) ;; it
2790: 65 6d 73 20 34 0a 09 09 09 09 09 09 20 20 20 28 ems 4....... (
27a0: 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 itemstable (hash
27b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
27c0: 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 lt config "items
27d0: 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 09 09 table" #f))) ...
27e0: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ... ;; if
27f0: 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 either items or
2800: 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 items table is a
2810: 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 proc return it
2820: 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a so test running.
2830: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 70 ..... ;; p
2840: 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 rocess can know
2850: 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 to call items:ge
2860: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
2870: 66 69 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 fig......
2880: 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 ;; if either is
2890: 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 a list and none
28a0: 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 is a proc go ahe
28b0: 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d ad and call get-
28c0: 69 74 65 6d 73 0a 09 09 09 09 09 20 20 20 20 20 items......
28d0: 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 ;; otherwise r
28e0: 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 eturn #f - this
28f0: 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 is not an iterat
2900: 65 64 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 ed test......
2910: 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 (cond.......
2920: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 ((procedure? ite
2930: 6d 73 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 ms) .......
2940: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
2950: 22 49 4e 46 4f 3a 20 69 74 65 6d 73 20 69 73 20 "INFO: items is
2960: 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
2970: 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 l calc later")..
2980: 09 09 09 09 09 20 69 74 65 6d 73 29 20 20 20 20 ..... items)
2990: 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 ;; calc
29a0: 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 70 72 later.......((pr
29b0: 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 ocedure? itemsta
29c0: 62 6c 65 29 0a 09 09 09 09 09 09 20 28 64 65 62 ble)....... (deb
29d0: 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 4f ug:print 4 "INFO
29e0: 3a 20 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 : itemstable is
29f0: 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c a procedure, wil
2a00: 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 l calc later")..
2a10: 09 09 09 09 09 20 69 74 65 6d 73 74 61 62 6c 65 ..... itemstable
2a20: 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 ) ;; calc
2a30: 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 66 69 later.......((fi
2a40: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
2a50: 0a 09 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 ........ (let
2a60: 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a ((val (car x))).
2a70: 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 20 ....... (if
2a80: 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 (procedure? val)
2a90: 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 09 09 val #f)))......
2aa0: 09 09 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 .. (append (if (
2ab0: 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 list? items) ite
2ac0: 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 09 ms '()).........
2ad0: 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d (if (list? item
2ae0: 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 stable) itemstab
2af0: 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 09 09 le '()))).......
2b00: 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 'have-procedure
2b10: 29 0a 09 09 09 09 09 09 28 28 6f 72 20 28 6c 69 ).......((or (li
2b20: 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f st? items)(list?
2b30: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b itemstable)) ;;
2b40: 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 calc now.......
2b50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
2b60: 22 49 4e 46 4f 3a 20 69 74 65 6d 73 20 61 6e 64 "INFO: items and
2b70: 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 itemstable are
2b80: 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c lists, calc now\
2b90: 6e 22 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 n"........
2ba0: 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 " items: " it
2bb0: 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 ems " itemstable
2bc0: 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a : " itemstable).
2bd0: 09 09 09 09 09 09 20 28 69 74 65 6d 73 3a 67 65 ...... (items:ge
2be0: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
2bf0: 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 fig config))....
2c00: 09 09 09 28 65 6c 73 65 20 23 66 29 29 29 20 20 ...(else #f)))
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c20: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 ;; not
2c30: 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 20 20 iterated......
2c40: 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 69 74 #f ;; it
2c50: 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 20 20 emsdat 5......
2c60: 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 #f ;; sp
2c70: 61 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 are - used for i
2c80: 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 20 20 tem-path......
2c90: 20 20 20 29 29 29 0a 09 20 20 20 20 28 66 6f 72 ))).. (for
2ca0: 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 6c 61 -each .. (la
2cb0: 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 mbda (waiton)..
2cc0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 (if (and w
2cd0: 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 aiton (not (memb
2ce0: 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e er waiton test-n
2cf0: 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 62 65 ames)))... (be
2d00: 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 21 gin... (set!
2d10: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 required-tests
2d20: 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 (cons waiton req
2d30: 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 uired-tests))...
2d40: 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d (set! test-
2d50: 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 74 names (cons wait
2d60: 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 on test-names)))
2d70: 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 )) ;; was an app
2d80: 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a end, now a cons.
2d90: 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 . waitons)..
2da0: 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 (let ((remte
2db0: 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c sts (delete-dupl
2dc0: 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 icates (append w
2dd0: 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 aitons tal))))..
2de0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
2df0: 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 null? remtests))
2e00: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
2e10: 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 remtests)(cdr re
2e20: 6d 74 65 73 74 73 29 29 29 29 29 29 29 0a 0a 20 mtests)))))))..
2e30: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
2e40: 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 l? required-test
2e50: 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e s))..(debug:prin
2e60: 74 20 31 20 22 49 4e 46 4f 3a 20 41 64 64 69 6e t 1 "INFO: Addin
2e70: 67 20 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 g " required-tes
2e80: 74 73 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 ts " to the run
2e90: 71 75 65 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 queue")). ;;
2ea0: 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 72 65 20 NOTE: these are
2eb0: 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 74 73 all parent tests
2ec0: 2c 20 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 , items are not
2ed0: 65 78 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 expanded yet..
2ee0: 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 (runs:run-test
2ef0: 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 s-queue run-id r
2f00: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f unname test-reco
2f10: 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c rds keyvallst fl
2f20: 61 67 73 29 0a 20 20 20 20 28 64 65 62 75 67 3a ags). (debug:
2f30: 70 72 69 6e 74 20 34 20 22 49 4e 46 4f 3a 20 41 print 4 "INFO: A
2f40: 6c 6c 20 64 6f 6e 65 20 62 79 20 68 65 72 65 22 ll done by here"
2f50: 29 29 29 0a 0a 3b 3b 20 74 65 73 74 2d 72 65 63 )))..;; test-rec
2f60: 6f 72 64 73 20 69 73 20 61 20 68 61 73 68 20 74 ords is a hash t
2f70: 61 62 6c 65 20 74 65 73 74 6e 61 6d 65 3a 69 74 able testname:it
2f80: 65 6d 5f 70 61 74 68 20 3d 3e 20 76 65 63 74 6f em_path => vecto
2f90: 72 20 3c 20 74 65 73 74 6e 61 6d 65 20 74 65 73 r < testname tes
2fa0: 74 63 6f 6e 66 69 67 20 77 61 69 74 6f 6e 73 20 tconfig waitons
2fb0: 70 72 69 6f 72 69 74 79 20 69 74 65 6d 73 2d 69 priority items-i
2fc0: 6e 66 6f 20 2e 2e 2e 20 3e 0a 28 64 65 66 69 6e nfo ... >.(defin
2fd0: 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 e (runs:run-test
2fe0: 73 2d 71 75 65 75 65 20 72 75 6e 2d 69 64 20 72 s-queue run-id r
2ff0: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f unname test-reco
3000: 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c rds keyvallst fl
3010: 61 67 73 29 0a 20 20 20 20 3b 3b 20 41 74 20 74 ags). ;; At t
3020: 68 69 73 20 70 6f 69 6e 74 20 74 68 65 20 6c 69 his point the li
3030: 73 74 20 6f 66 20 70 61 72 65 6e 74 20 74 65 73 st of parent tes
3040: 74 73 20 69 73 20 65 78 70 61 6e 64 65 64 20 0a ts is expanded .
3050: 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 6f 75 ;; NB// Shou
3060: 6c 64 20 65 78 70 61 6e 64 20 69 74 65 6d 73 20 ld expand items
3070: 68 65 72 65 20 61 6e 64 20 74 68 65 6e 20 69 6e here and then in
3080: 73 65 72 74 20 69 6e 74 6f 20 74 68 65 20 72 75 sert into the ru
3090: 6e 20 71 75 65 75 65 2e 0a 20 20 28 64 65 62 75 n queue.. (debu
30a0: 67 3a 70 72 69 6e 74 20 35 20 22 74 65 73 74 2d g:print 5 "test-
30b0: 72 65 63 6f 72 64 73 3a 20 22 20 74 65 73 74 2d records: " test-
30c0: 72 65 63 6f 72 64 73 20 22 2c 20 6b 65 79 76 61 records ", keyva
30d0: 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c 73 llst: " keyvalls
30e0: 74 20 22 20 66 6c 61 67 73 3a 20 22 20 28 68 61 t " flags: " (ha
30f0: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
3100: 66 6c 61 67 73 29 29 0a 20 20 28 6c 65 74 20 28 flags)). (let (
3110: 28 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d (sorted-test-nam
3120: 65 73 20 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 es (tests:sort-b
3130: 79 2d 70 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 y-priority-and-w
3140: 61 69 74 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 aiton test-recor
3150: 64 73 29 29 0a 09 28 69 74 65 6d 2d 70 61 74 74 ds))..(item-patt
3160: 73 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 s (hash-t
3170: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3180: 20 66 6c 61 67 73 20 22 2d 69 74 65 6d 70 61 74 flags "-itempat
3190: 74 22 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 t" #f))). (if
31a0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 73 6f 72 (not (null? sor
31b0: 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 ted-test-names))
31c0: 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 ..(let loop ((he
31d0: 64 20 20 20 20 20 20 20 20 20 28 63 61 72 20 73 d (car s
31e0: 6f 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 orted-test-names
31f0: 29 29 0a 09 09 20 20 20 28 74 61 6c 20 20 20 20 ))... (tal
3200: 20 20 20 20 20 28 63 64 72 20 73 6f 72 74 65 64 (cdr sorted
3210: 2d 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a 09 -test-names)))..
3220: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
3230: 20 2a 67 6c 6f 62 61 6c 2d 64 65 6c 74 61 2a 29 *global-delta*)
3240: 20 3b 3b 20 67 69 76 65 20 6f 74 68 65 72 20 61 ;; give other a
3250: 70 70 6c 69 63 61 74 69 6f 6e 73 20 73 6f 6d 65 pplications some
3260: 20 74 69 6d 65 20 77 69 74 68 20 74 68 65 20 64 time with the d
3270: 62 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 65 73 b.. (let* ((tes
3280: 74 2d 72 65 63 6f 72 64 20 28 68 61 73 68 2d 74 t-record (hash-t
3290: 61 62 6c 65 2d 72 65 66 20 74 65 73 74 2d 72 65 able-ref test-re
32a0: 63 6f 72 64 73 20 68 65 64 29 29 0a 09 09 20 28 cords hed))... (
32b0: 74 63 6f 6e 66 69 67 20 20 20 20 20 28 74 65 73 tconfig (tes
32c0: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
32d0: 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 73 74 -testconfig test
32e0: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 74 65 -record))... (te
32f0: 73 74 6d 6f 64 65 20 20 20 20 28 6c 65 74 20 28 stmode (let (
3300: 28 6d 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (m (config-looku
3310: 70 20 74 63 6f 6e 66 69 67 20 22 72 65 71 75 69 p tconfig "requi
3320: 72 65 6d 65 6e 74 73 22 20 22 6d 6f 64 65 22 29 rements" "mode")
3330: 29 29 0a 09 09 09 09 28 69 66 20 6d 20 28 73 74 )).....(if m (st
3340: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 6d 29 20 ring->symbol m)
3350: 27 6e 6f 72 6d 61 6c 29 29 29 0a 09 09 20 28 77 'normal)))... (w
3360: 61 69 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 aitons (test
3370: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
3380: 77 61 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d waitons test-
3390: 72 65 63 6f 72 64 29 29 0a 09 09 20 28 70 72 69 record))... (pri
33a0: 6f 72 69 74 79 20 20 20 20 28 74 65 73 74 73 3a ority (tests:
33b0: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 72 testqueue-get-pr
33c0: 69 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 65 iority test-re
33d0: 63 6f 72 64 29 29 0a 09 09 20 28 69 74 65 6d 64 cord))... (itemd
33e0: 61 74 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 at (tests:te
33f0: 73 74 71 75 65 75 65 2d 67 65 74 2d 69 74 65 6d stqueue-get-item
3400: 64 61 74 20 20 20 20 74 65 73 74 2d 72 65 63 6f dat test-reco
3410: 72 64 29 29 20 3b 3b 20 69 74 65 6d 64 61 74 20 rd)) ;; itemdat
3420: 63 61 6e 20 62 65 20 61 20 73 74 72 69 6e 67 2c can be a string,
3430: 20 6c 69 73 74 20 6f 72 20 23 66 0a 09 09 20 28 list or #f... (
3440: 69 74 65 6d 73 20 20 20 20 20 20 20 28 74 65 73 items (tes
3450: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
3460: 2d 69 74 65 6d 73 20 20 20 20 20 20 74 65 73 74 -items test
3470: 2d 72 65 63 6f 72 64 29 29 0a 09 09 20 28 69 74 -record))... (it
3480: 65 6d 2d 70 61 74 68 20 20 20 28 69 74 65 6d 2d em-path (item-
3490: 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 list->path itemd
34a0: 61 74 29 29 0a 09 09 20 28 6e 65 77 74 61 6c 20 at))... (newtal
34b0: 20 20 20 20 20 28 61 70 70 65 6e 64 20 74 61 6c (append tal
34c0: 20 28 6c 69 73 74 20 68 65 64 29 29 29 0a 09 09 (list hed)))...
34d0: 20 28 63 61 6c 63 2d 66 61 69 6c 73 20 20 28 6c (calc-fails (l
34e0: 61 6d 62 64 61 20 28 70 72 65 72 65 71 73 2d 6e ambda (prereqs-n
34f0: 6f 74 2d 6d 65 74 29 0a 09 09 09 09 28 66 69 6c ot-met).....(fil
3500: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
3510: 74 29 0a 09 09 09 09 09 20 20 28 64 65 62 75 67 t)...... (debug
3520: 3a 70 72 69 6e 74 20 39 20 22 74 65 73 74 3a 20 :print 9 "test:
3530: 22 20 74 65 73 74 29 0a 09 09 09 09 09 20 20 28 " test)...... (
3540: 61 6e 64 20 28 76 65 63 74 6f 72 3f 20 74 65 73 and (vector? tes
3550: 74 29 20 3b 3b 20 6e 6f 74 20 28 73 74 72 69 6e t) ;; not (strin
3560: 67 3f 20 74 65 73 74 29 29 0a 09 09 09 09 09 20 g? test))......
3570: 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 64 (equal? (d
3580: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
3590: 20 74 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 test) "COMPLETE
35a0: 44 22 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 D")......
35b0: 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 62 (not (member (db
35c0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
35d0: 20 74 65 73 74 29 0a 09 09 09 09 09 09 09 20 20 test)........
35e0: 20 20 27 28 22 50 41 53 53 22 20 22 57 41 52 4e '("PASS" "WARN
35f0: 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 " "CHECK" "WAIVE
3600: 44 22 29 29 29 29 29 0a 09 09 09 09 09 70 72 65 D")))))......pre
3610: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a reqs-not-met))).
3620: 09 09 20 28 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d .. (calc-not-com
3630: 70 6c 65 74 65 64 20 28 6c 61 6d 62 64 61 20 28 pleted (lambda (
3640: 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 prereqs-not-met)
3650: 0a 09 09 09 09 20 20 20 20 20 20 20 28 66 69 6c ..... (fil
3660: 74 65 72 0a 09 09 09 09 09 28 6c 61 6d 62 64 61 ter......(lambda
3670: 20 28 74 29 0a 09 09 09 09 09 20 20 28 6f 72 20 (t)...... (or
3680: 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 (not (vector? t)
3690: 29 0a 09 09 09 09 09 20 20 20 20 20 20 28 6e 6f )...... (no
36a0: 74 20 28 65 71 75 61 6c 3f 20 22 43 4f 4d 50 4c t (equal? "COMPL
36b0: 45 54 45 44 22 20 28 64 62 3a 74 65 73 74 2d 67 ETED" (db:test-g
36c0: 65 74 2d 73 74 61 74 65 20 74 29 29 29 29 29 0a et-state t))))).
36d0: 09 09 09 09 09 70 72 65 72 65 71 73 2d 6e 6f 74 .....prereqs-not
36e0: 2d 6d 65 74 29 29 29 0a 09 09 20 28 70 72 65 74 -met)))... (pret
36f0: 74 79 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 64 ty-string (lambd
3700: 61 20 28 6c 73 74 29 0a 09 09 09 09 20 20 28 6d a (lst)..... (m
3710: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 ap (lambda (t)..
3720: 09 09 09 09 20 28 69 66 20 28 6e 6f 74 20 28 76 .... (if (not (v
3730: 65 63 74 6f 72 3f 20 74 29 29 0a 09 09 09 09 09 ector? t))......
3740: 20 20 20 20 20 28 63 6f 6e 63 20 74 29 0a 09 09 (conc t)...
3750: 09 09 09 20 20 20 20 20 28 63 6f 6e 63 20 28 64 ... (conc (d
3760: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
3770: 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 3a 74 ame t) ":" (db:t
3780: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 est-get-state t)
3790: 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 65 "/" (db:test-ge
37a0: 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 0a 09 t-status t))))..
37b0: 09 09 09 20 20 20 20 20 20 20 6c 73 74 29 29 29 ... lst)))
37c0: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
37d0: 69 6e 74 20 36 0a 09 09 09 20 22 69 74 65 6d 64 int 6.... "itemd
37e0: 61 74 3a 20 20 20 20 20 22 20 69 74 65 6d 64 61 at: " itemda
37f0: 74 0a 09 09 09 20 22 5c 6e 20 20 69 74 65 6d 73 t.... "\n items
3800: 3a 20 20 20 20 20 22 20 69 74 65 6d 73 0a 09 09 : " items...
3810: 09 20 22 5c 6e 20 20 69 74 65 6d 2d 70 61 74 68 . "\n item-path
3820: 3a 20 22 20 69 74 65 6d 2d 70 61 74 68 0a 09 09 : " item-path...
3830: 09 20 22 5c 6e 20 20 77 61 69 74 6f 6e 73 3a 20 . "\n waitons:
3840: 20 20 22 20 77 61 69 74 6f 6e 73 29 0a 0a 09 20 " waitons)...
3850: 20 20 20 3b 3b 20 63 68 65 63 6b 20 66 6f 72 20 ;; check for
3860: 68 65 64 20 69 6e 20 77 61 69 74 6f 6e 73 20 3d hed in waitons =
3870: 3e 20 74 68 69 73 20 77 6f 75 6c 64 20 62 65 20 > this would be
3880: 63 69 72 63 75 6c 61 72 2c 20 72 65 6d 6f 76 65 circular, remove
3890: 20 69 74 20 61 6e 64 20 69 73 73 75 65 20 61 6e it and issue an
38a0: 0a 09 20 20 20 20 3b 3b 20 65 72 72 6f 72 0a 09 .. ;; error..
38b0: 20 20 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 (if (member
38c0: 68 65 64 20 77 61 69 74 6f 6e 73 29 0a 09 09 28 hed waitons)...(
38d0: 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 begin... (debug
38e0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
38f0: 20 74 65 73 74 20 22 20 68 65 64 20 22 20 68 61 test " hed " ha
3900: 73 20 6c 69 73 74 65 64 20 69 74 73 65 6c 66 20 s listed itself
3910: 61 73 20 61 20 77 61 69 74 6f 6e 2c 20 70 6c 65 as a waiton, ple
3920: 61 73 65 20 63 6f 72 72 65 63 74 20 74 68 69 73 ase correct this
3930: 21 22 29 0a 09 09 20 20 28 73 65 74 21 20 77 61 !")... (set! wa
3940: 69 74 6f 6e 20 28 66 69 6c 74 65 72 20 28 6c 61 iton (filter (la
3950: 6d 62 64 61 20 28 78 29 28 6e 6f 74 20 28 65 71 mbda (x)(not (eq
3960: 75 61 6c 3f 20 78 20 68 65 64 29 29 29 20 77 61 ual? x hed))) wa
3970: 69 74 6f 6e 73 29 29 29 29 0a 0a 09 20 20 20 20 itons))))...
3980: 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 28 6e 6f (cond.. ((no
3990: 74 20 69 74 65 6d 73 29 20 3b 3b 20 77 68 65 6e t items) ;; when
39a0: 20 66 61 6c 73 65 20 74 68 65 20 74 65 73 74 20 false the test
39b0: 69 73 20 6f 6b 20 74 6f 20 62 65 20 68 61 6e 64 is ok to be hand
39c0: 65 64 20 6f 66 66 20 74 6f 20 6c 61 75 6e 63 68 ed off to launch
39d0: 20 28 62 75 74 20 6e 6f 74 20 62 65 66 6f 72 65 (but not before
39e0: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ).. (let* (
39f0: 28 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 20 (have-resources
3a00: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
3a10: 20 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f runs:can-run-mo
3a20: 72 65 2d 74 65 73 74 73 20 23 66 20 74 65 73 74 re-tests #f test
3a30: 2d 72 65 63 6f 72 64 29 29 20 3b 3b 20 6c 6f 6f -record)) ;; loo
3a40: 6b 20 61 74 20 74 68 65 20 74 65 73 74 20 6a 6f k at the test jo
3a50: 62 67 72 6f 75 70 20 61 6e 64 20 74 6f 74 20 6a bgroup and tot j
3a60: 6f 62 73 20 72 75 6e 6e 69 6e 67 0a 09 09 20 20 obs running...
3a70: 20 20 20 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d (prereqs-not-
3a80: 6d 65 74 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c met (open-run-cl
3a90: 6f 73 65 20 64 62 3a 67 65 74 2d 70 72 65 72 65 ose db:get-prere
3aa0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 23 66 20 72 75 qs-not-met #f ru
3ab0: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite
3ac0: 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 74 65 73 m-path mode: tes
3ad0: 74 6d 6f 64 65 29 29 0a 09 09 20 20 20 20 20 28 tmode))... (
3ae0: 66 61 69 6c 73 20 20 20 20 20 20 20 20 20 20 20 fails
3af0: 28 63 61 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 (calc-fails prer
3b00: 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 0a 09 09 eqs-not-met))...
3b10: 20 20 20 20 20 28 6e 6f 6e 2d 63 6f 6d 70 6c 65 (non-comple
3b20: 74 65 64 20 20 20 28 63 61 6c 63 2d 6e 6f 74 2d ted (calc-not-
3b30: 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 completed prereq
3b40: 73 2d 6e 6f 74 2d 6d 65 74 29 29 29 0a 09 09 28 s-not-met)))...(
3b50: 64 65 62 75 67 3a 70 72 69 6e 74 20 38 20 22 49 debug:print 8 "I
3b60: 4e 46 4f 3a 20 68 61 76 65 2d 72 65 73 6f 75 72 NFO: have-resour
3b70: 63 65 73 3a 20 22 20 68 61 76 65 2d 72 65 73 6f ces: " have-reso
3b80: 75 72 63 65 73 20 22 20 70 72 65 72 65 71 73 2d urces " prereqs-
3b90: 6e 6f 74 2d 6d 65 74 3a 20 22 20 0a 09 09 09 20 not-met: " ....
3ba0: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
3bb0: 72 73 70 65 72 73 65 20 0a 09 09 09 20 20 20 20 rsperse ....
3bc0: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
3bd0: 74 29 0a 09 09 09 09 20 20 20 20 20 28 69 66 20 t)..... (if
3be0: 28 76 65 63 74 6f 72 3f 20 74 29 0a 09 09 09 09 (vector? t).....
3bf0: 09 20 28 63 6f 6e 63 20 28 64 62 3a 74 65 73 74 . (conc (db:test
3c00: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 20 22 2f -get-state t) "/
3c10: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 " (db:test-get-s
3c20: 74 61 74 75 73 20 74 29 29 0a 09 09 09 09 09 20 tatus t))......
3c30: 28 63 6f 6e 63 20 22 20 57 41 52 4e 49 4e 47 3a (conc " WARNING:
3c40: 20 74 20 69 73 20 6e 6f 74 20 61 20 76 65 63 74 t is not a vect
3c50: 6f 72 3d 22 20 74 20 29 29 29 0a 09 09 09 09 20 or=" t ))).....
3c60: 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 prereqs-not-me
3c70: 74 29 20 22 2c 20 22 29 20 22 20 66 61 69 6c 73 t) ", ") " fails
3c80: 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 3b 3b 20 : " fails)...;;
3c90: 44 6f 6e 27 74 20 6b 6e 6f 77 20 61 74 20 74 68 Don't know at th
3ca0: 69 73 20 74 69 6d 65 20 69 66 20 74 68 65 20 74 is time if the t
3cb0: 65 73 74 20 68 61 76 65 20 62 65 65 6e 20 6c 61 est have been la
3cc0: 75 6e 63 68 65 64 20 61 74 20 73 6f 6d 65 20 74 unched at some t
3cd0: 69 6d 65 20 69 6e 20 74 68 65 20 70 61 73 74 0a ime in the past.
3ce0: 09 09 3b 3b 20 69 2e 65 2e 20 69 73 20 74 68 69 ..;; i.e. is thi
3cf0: 73 20 61 20 72 65 2d 6c 61 75 6e 63 68 3f 0a 09 s a re-launch?..
3d00: 09 28 63 6f 6e 64 0a 09 09 20 28 28 61 6e 64 20 .(cond... ((and
3d10: 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 0a 09 have-resources..
3d20: 09 20 20 20 20 20 20 20 28 6f 72 20 28 6e 75 6c . (or (nul
3d30: 6c 3f 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d l? prereqs-not-m
3d40: 65 74 29 0a 09 09 09 20 20 20 28 61 6e 64 20 28 et).... (and (
3d50: 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f eq? testmode 'to
3d60: 70 6c 65 76 65 6c 29 0a 09 09 09 09 28 6e 75 6c plevel).....(nul
3d70: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
3d80: 29 29 29 29 0a 09 09 20 20 3b 3b 20 6e 6f 20 6c ))))... ;; no l
3d90: 6f 6f 70 20 68 65 72 65 2c 20 6a 75 73 74 20 64 oop here, just d
3da0: 72 6f 70 20 74 68 6f 75 67 68 20 61 6e 64 20 75 rop though and u
3db0: 73 65 20 74 68 65 20 6c 6f 6f 70 20 61 74 20 74 se the loop at t
3dc0: 68 65 20 62 6f 74 74 6f 6d 20 0a 09 09 20 20 28 he bottom ... (
3dd0: 69 66 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 if (patt-list-ma
3de0: 74 63 68 20 69 74 65 6d 2d 70 61 74 68 20 69 74 tch item-path it
3df0: 65 6d 2d 70 61 74 74 73 29 0a 09 09 20 20 20 20 em-patts)...
3e00: 20 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d (run:test run-
3e10: 69 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 id runname keyva
3e20: 6c 6c 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 llst test-record
3e30: 20 66 6c 61 67 73 20 23 66 29 0a 09 09 20 20 20 flags #f)...
3e40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3e50: 31 20 22 49 4e 46 4f 3a 20 53 6b 69 70 70 69 6e 1 "INFO: Skippin
3e60: 67 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 g " (tests:testq
3e70: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d ueue-get-testnam
3e80: 65 20 74 65 73 74 2d 72 65 63 6f 72 64 29 20 22 e test-record) "
3e90: 20 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 61 " item-path " a
3ea0: 73 20 69 74 20 64 6f 65 73 6e 27 74 20 6d 61 74 s it doesn't mat
3eb0: 63 68 20 22 20 69 74 65 6d 2d 70 61 74 74 73 29 ch " item-patts)
3ec0: 29 0a 09 09 20 20 3b 3b 20 65 6c 73 65 20 74 68 )... ;; else th
3ed0: 65 20 72 75 6e 20 69 73 20 73 74 75 63 6b 2c 20 e run is stuck,
3ee0: 74 65 6d 70 6f 72 61 72 69 6c 79 20 6f 72 20 70 temporarily or p
3ef0: 65 72 6d 61 6e 65 6e 74 6c 79 0a 09 09 20 20 3b ermanently... ;
3f00: 3b 20 62 75 74 20 73 68 6f 75 6c 64 20 63 68 65 ; but should che
3f10: 63 6b 20 69 66 20 69 74 20 69 73 20 64 75 65 20 ck if it is due
3f20: 74 6f 20 6c 61 63 6b 20 6f 66 20 72 65 73 6f 75 to lack of resou
3f30: 72 63 65 73 20 76 73 2e 20 70 72 65 72 65 71 75 rces vs. prerequ
3f40: 69 73 69 74 65 73 0a 09 09 20 20 29 0a 09 09 20 isites... )...
3f50: 28 28 6e 6f 74 20 68 61 76 65 2d 72 65 73 6f 75 ((not have-resou
3f60: 72 63 65 73 29 20 3b 3b 20 73 69 6d 70 6c 79 20 rces) ;; simply
3f70: 74 72 79 20 61 67 61 69 6e 20 61 66 74 65 72 20 try again after
3f80: 77 61 69 74 69 6e 67 20 61 20 73 65 63 6f 6e 64 waiting a second
3f90: 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
3fa0: 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f 62 61 6c ep! (+ 1 *global
3fb0: 2d 64 65 6c 74 61 2a 29 29 0a 09 09 20 20 28 64 -delta*))... (d
3fc0: 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 49 4e ebug:print 1 "IN
3fd0: 46 4f 3a 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 FO: no resources
3fe0: 20 74 6f 20 72 75 6e 20 6e 65 77 20 74 65 73 74 to run new test
3ff0: 73 2c 20 77 61 69 74 69 6e 67 20 2e 2e 2e 22 29 s, waiting ...")
4000: 0a 09 09 20 20 3b 3b 20 63 6f 75 6c 64 20 68 61 ... ;; could ha
4010: 76 65 20 64 6f 6e 65 20 68 65 64 20 74 61 6c 20 ve done hed tal
4020: 68 65 72 65 20 62 75 74 20 64 6f 69 6e 67 20 63 here but doing c
4030: 61 72 2f 63 64 72 20 6f 66 20 6e 65 77 74 61 6c ar/cdr of newtal
4040: 20 74 6f 20 72 6f 74 61 74 65 20 74 65 73 74 73 to rotate tests
4050: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
4060: 6e 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 newtal)(cdr newt
4070: 61 6c 29 29 29 0a 09 09 20 28 65 6c 73 65 20 3b al)))... (else ;
4080: 3b 20 6d 75 73 74 20 62 65 20 77 65 20 68 61 76 ; must be we hav
4090: 65 20 75 6e 6d 65 74 20 70 72 65 72 65 71 75 69 e unmet prerequi
40a0: 73 69 74 65 73 0a 09 09 20 20 20 20 28 64 65 62 sites... (deb
40b0: 75 67 3a 70 72 69 6e 74 20 34 20 22 46 41 49 4c ug:print 4 "FAIL
40c0: 53 3a 20 22 20 66 61 69 6c 73 29 0a 09 09 20 20 S: " fails)...
40d0: 20 20 3b 3b 20 49 66 20 6f 6e 65 20 6f 72 20 6d ;; If one or m
40e0: 6f 72 65 20 6f 66 20 74 68 65 20 70 72 65 72 65 ore of the prere
40f0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 61 72 65 20 46 qs-not-met are F
4100: 41 49 4c 20 74 68 65 6e 20 77 65 20 63 61 6e 20 AIL then we can
4110: 69 73 73 75 65 0a 09 09 20 20 20 20 3b 3b 20 61 issue... ;; a
4120: 20 6d 65 73 73 61 67 65 20 61 6e 64 20 64 72 6f message and dro
4130: 70 20 68 65 64 20 66 72 6f 6d 20 74 68 65 20 69 p hed from the i
4140: 74 65 6d 73 20 74 6f 20 62 65 20 70 72 6f 63 65 tems to be proce
4150: 73 73 65 64 2e 0a 09 09 20 20 20 20 28 69 66 20 ssed.... (if
4160: 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 0a 09 09 (null? fails)...
4170: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 3b 3b 20 .(begin.... ;;
4180: 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 74 61 couldn't run, ta
4190: 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a 09 09 ke a breather...
41a0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
41b0: 34 20 22 49 4e 46 4f 3a 20 53 68 6f 75 6c 64 6e 4 "INFO: Shouldn
41c0: 27 74 20 72 65 61 6c 6c 79 20 67 65 74 20 68 65 't really get he
41d0: 72 65 2c 20 72 61 63 65 20 63 6f 6e 64 69 74 69 re, race conditi
41e0: 6f 6e 3f 20 55 6e 61 62 6c 65 20 74 6f 20 6c 61 on? Unable to la
41f0: 75 6e 63 68 20 6d 6f 72 65 20 74 65 73 74 73 20 unch more tests
4200: 61 74 20 74 68 69 73 20 6d 6f 6d 65 6e 74 2c 20 at this moment,
4210: 6b 69 6c 6c 69 6e 67 20 74 69 6d 65 20 2e 2e 2e killing time ...
4220: 22 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 2d ").... (thread-
4230: 73 6c 65 65 70 21 20 28 2b 20 31 20 2a 67 6c 6f sleep! (+ 1 *glo
4240: 62 61 6c 2d 64 65 6c 74 61 2a 29 29 20 3b 3b 20 bal-delta*)) ;;
4250: 6c 6f 6e 67 20 73 6c 65 65 70 20 68 65 72 65 20 long sleep here
4260: 2d 20 6e 6f 20 72 65 73 6f 75 72 63 65 73 2c 20 - no resources,
4270: 6d 61 79 20 61 73 20 77 65 6c 6c 20 62 65 20 70 may as well be p
4280: 61 74 69 65 6e 74 0a 09 09 09 20 20 3b 3b 20 77 atient.... ;; w
4290: 65 20 6d 61 64 65 20 6e 65 77 20 74 61 6c 20 62 e made new tal b
42a0: 79 20 73 74 69 63 6b 69 6e 67 20 68 65 64 20 61 y sticking hed a
42b0: 74 20 74 68 65 20 62 61 63 6b 20 6f 66 20 74 68 t the back of th
42c0: 65 20 6c 69 73 74 0a 09 09 09 20 20 28 6c 6f 6f e list.... (loo
42d0: 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 p (car newtal)(c
42e0: 64 72 20 6e 65 77 74 61 6c 29 29 29 0a 09 09 09 dr newtal)))....
42f0: 3b 3b 20 74 68 65 20 77 61 69 74 6f 6e 20 69 73 ;; the waiton is
4300: 20 46 41 49 4c 20 73 6f 20 6e 6f 20 70 6f 69 6e FAIL so no poin
4310: 74 20 69 6e 20 74 72 79 69 6e 67 20 74 6f 20 72 t in trying to r
4320: 75 6e 20 68 65 64 20 65 76 65 72 20 61 67 61 69 un hed ever agai
4330: 6e 0a 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e n....(if (not (n
4340: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 20 20 ull? tal))....
4350: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 (begin....
4360: 20 20 28 69 66 20 28 76 65 63 74 6f 72 3f 20 68 (if (vector? h
4370: 65 64 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 ed)..... (debug
4380: 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a 20 :print 1 "WARN:
4390: 44 72 6f 70 70 69 6e 67 20 74 65 73 74 20 22 20 Dropping test "
43a0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
43b0: 74 6e 61 6d 65 20 68 65 64 29 20 22 2f 22 20 28 tname hed) "/" (
43c0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
43d0: 2d 70 61 74 68 20 68 65 64 29 0a 09 09 09 09 09 -path hed)......
43e0: 20 20 20 20 20 20 20 22 20 66 72 6f 6d 20 74 68 " from th
43f0: 65 20 6c 61 75 6e 63 68 20 6c 69 73 74 20 61 73 e launch list as
4400: 20 69 74 20 68 61 73 20 70 72 65 72 65 71 75 69 it has prerequi
4410: 73 74 65 73 20 74 68 61 74 20 61 72 65 20 46 41 stes that are FA
4420: 49 4c 22 29 0a 09 09 09 09 20 20 28 64 65 62 75 IL")..... (debu
4430: 67 3a 70 72 69 6e 74 20 31 20 22 57 41 52 4e 3a g:print 1 "WARN:
4440: 20 44 72 6f 70 70 69 6e 67 20 74 65 73 74 20 22 Dropping test "
4450: 20 68 65 64 20 22 20 61 73 20 69 74 20 68 61 73 hed " as it has
4460: 20 70 72 65 72 65 71 75 69 73 74 65 73 20 74 68 prerequistes th
4470: 61 74 20 61 72 65 20 46 41 49 4c 2e 20 28 4e 4f at are FAIL. (NO
4480: 54 45 3a 20 68 65 64 20 69 73 20 6e 6f 74 20 61 TE: hed is not a
4490: 20 76 65 63 74 6f 72 29 22 29 29 0a 09 09 09 20 vector)"))....
44a0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
44b0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
44c0: 29 29 29 29 29 0a 09 20 20 20 20 20 0a 09 20 20 ))))).. ..
44d0: 20 20 20 3b 3b 20 63 61 73 65 20 77 68 65 72 65 ;; case where
44e0: 20 61 6e 20 69 74 65 6d 73 20 63 61 6d 65 20 69 an items came i
44f0: 6e 20 61 73 20 61 20 6c 69 73 74 20 62 65 65 6e n as a list been
4500: 20 70 72 6f 63 65 73 73 65 64 0a 09 20 20 20 20 processed..
4510: 20 28 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 ((and (list? it
4520: 65 6d 73 29 20 20 20 20 20 3b 3b 20 74 68 75 73 ems) ;; thus
4530: 20 77 65 20 6b 6e 6f 77 20 6f 75 72 20 69 74 65 we know our ite
4540: 6d 73 20 61 72 65 20 61 6c 72 65 61 64 79 20 63 ms are already c
4550: 61 6c 63 75 6c 61 74 65 64 0a 09 09 20 20 20 28 alculated... (
4560: 6e 6f 74 20 20 20 69 74 65 6d 64 61 74 29 29 20 not itemdat))
4570: 3b 3b 20 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 ;; and not yet e
4580: 78 70 61 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 xpanded into the
4590: 20 6c 69 73 74 20 6f 66 20 74 68 69 6e 67 73 20 list of things
45a0: 74 6f 20 62 65 20 64 6f 6e 65 0a 09 20 20 20 20 to be done..
45b0: 20 20 28 69 66 20 28 61 6e 64 20 28 3e 3d 20 2a (if (and (>= *
45c0: 76 65 72 62 6f 73 69 74 79 2a 20 31 29 0a 09 09 verbosity* 1)...
45d0: 20 20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 (> (lengt
45e0: 68 20 69 74 65 6d 73 29 20 30 29 0a 09 09 20 20 h items) 0)...
45f0: 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 (> (length
4600: 28 63 61 72 20 69 74 65 6d 73 29 29 20 30 29 29 (car items)) 0))
4610: 0a 09 09 20 20 28 70 70 20 69 74 65 6d 73 29 29 ... (pp items))
4620: 0a 09 20 20 20 20 20 20 3b 3b 20 28 69 66 20 28 .. ;; (if (
4630: 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 35 >= *verbosity* 5
4640: 29 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ).. ;;
4650: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 3b 3b (begin.. ;;
4660: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 69 (print "i
4670: 74 65 6d 73 3a 20 22 29 20 20 20 20 20 28 70 70 tems: ") (pp
4680: 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e 69 74 (item-assoc->it
4690: 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 29 29 0a em-list items)).
46a0: 09 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 . ;;
46b0: 28 70 72 69 6e 74 20 22 69 74 65 6d 73 74 61 62 (print "itemstab
46c0: 6c 65 3a 20 22 29 28 70 70 20 28 69 74 65 6d 2d le: ")(pp (item-
46d0: 74 61 62 6c 65 2d 3e 69 74 65 6d 2d 6c 69 73 74 table->item-list
46e0: 20 69 74 65 6d 73 74 61 62 6c 65 29 29 29 29 0a itemstable)))).
46f0: 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
4700: 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
4710: 20 28 6d 79 2d 69 74 65 6d 64 61 74 29 0a 09 09 (my-itemdat)...
4720: 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 (let* ((new-tes
4730: 74 2d 72 65 63 6f 72 64 20 28 6c 65 74 20 28 28 t-record (let ((
4740: 6e 65 77 72 65 63 20 28 6d 61 6b 65 2d 74 65 73 newrec (make-tes
4750: 74 73 3a 74 65 73 74 71 75 65 75 65 29 29 29 0a ts:testqueue))).
4760: 09 09 09 09 09 20 20 20 28 76 65 63 74 6f 72 2d ..... (vector-
4770: 63 6f 70 79 21 20 74 65 73 74 2d 72 65 63 6f 72 copy! test-recor
4780: 64 20 6e 65 77 72 65 63 29 0a 09 09 09 09 09 20 d newrec)......
4790: 20 20 6e 65 77 72 65 63 29 29 0a 09 09 09 28 6d newrec))....(m
47a0: 79 2d 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 y-item-path (ite
47b0: 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 6d 79 2d m-list->path my-
47c0: 69 74 65 6d 64 61 74 29 29 29 0a 09 09 20 20 20 itemdat)))...
47d0: 28 69 66 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d (if (patt-list-m
47e0: 61 74 63 68 20 6d 79 2d 69 74 65 6d 2d 70 61 74 atch my-item-pat
47f0: 68 20 69 74 65 6d 2d 70 61 74 74 73 29 20 20 20 h item-patts)
4800: 20 20 20 20 20 20 20 20 3b 3b 20 79 65 73 2c 20 ;; yes,
4810: 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f 63 65 we want to proce
4820: 73 73 20 74 68 69 73 20 69 74 65 6d 2c 20 4e 4f ss this item, NO
4830: 54 45 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 20 6e TE: Should not n
4840: 65 65 64 20 74 68 69 73 20 63 68 65 63 6b 20 68 eed this check h
4850: 65 72 65 21 0a 09 09 20 20 20 20 20 20 20 28 6c ere!... (l
4860: 65 74 20 28 28 6e 65 77 74 65 73 74 6e 61 6d 65 et ((newtestname
4870: 20 28 63 6f 6e 63 20 68 65 64 20 22 2f 22 20 6d (conc hed "/" m
4880: 79 2d 69 74 65 6d 2d 70 61 74 68 29 29 29 20 20 y-item-path)))
4890: 20 20 3b 3b 20 74 65 73 74 20 6e 61 6d 65 73 20 ;; test names
48a0: 61 72 65 20 75 6e 69 71 75 65 20 6f 6e 20 74 65 are unique on te
48b0: 73 74 6e 61 6d 65 2f 69 74 65 6d 2d 70 61 74 68 stname/item-path
48c0: 0a 09 09 09 20 28 74 65 73 74 73 3a 74 65 73 74 .... (tests:test
48d0: 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 21 queue-set-items!
48e0: 20 20 20 20 20 6e 65 77 2d 74 65 73 74 2d 72 65 new-test-re
48f0: 63 6f 72 64 20 23 66 29 0a 09 09 09 20 28 74 65 cord #f).... (te
4900: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
4910: 74 2d 69 74 65 6d 64 61 74 21 20 20 20 6e 65 77 t-itemdat! new
4920: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d -test-record my-
4930: 69 74 65 6d 64 61 74 29 0a 09 09 09 20 28 74 65 itemdat).... (te
4940: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
4950: 74 2d 69 74 65 6d 5f 70 61 74 68 21 20 6e 65 77 t-item_path! new
4960: 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 6d 79 2d -test-record my-
4970: 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 09 20 28 item-path).... (
4980: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
4990: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 6e 65 77 test-records new
49a0: 74 65 73 74 6e 61 6d 65 20 6e 65 77 2d 74 65 73 testname new-tes
49b0: 74 2d 72 65 63 6f 72 64 29 0a 09 09 09 20 28 73 t-record).... (s
49c0: 65 74 21 20 74 61 6c 20 28 63 6f 6e 73 20 6e 65 et! tal (cons ne
49d0: 77 74 65 73 74 6e 61 6d 65 20 74 61 6c 29 29 29 wtestname tal)))
49e0: 29 29 29 20 3b 3b 20 73 69 6e 63 65 20 74 68 65 ))) ;; since the
49f0: 73 65 20 61 72 65 20 69 74 65 6d 69 7a 65 64 20 se are itemized
4a00: 63 72 65 61 74 65 20 6e 65 77 20 74 65 73 74 20 create new test
4a10: 6e 61 6d 65 73 20 74 65 73 74 6e 61 6d 65 2f 69 names testname/i
4a20: 74 65 6d 70 61 74 68 0a 09 20 20 20 20 20 20 20 tempath..
4a30: 69 74 65 6d 73 29 0a 09 20 20 20 20 20 20 28 69 items).. (i
4a40: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
4a50: 6c 29 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 l))... (loop (c
4a60: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
4a70: 29 29 29 0a 0a 09 20 20 20 20 20 3b 3b 20 69 66 )))... ;; if
4a80: 20 69 74 65 6d 73 20 69 73 20 61 20 70 72 6f 63 items is a proc
4a90: 20 74 68 65 6e 20 6e 65 65 64 20 74 6f 20 72 75 then need to ru
4aa0: 6e 20 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d n items:get-item
4ab0: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 2c 20 67 s-from-config, g
4ac0: 65 74 20 74 68 65 20 6c 69 73 74 20 61 6e 64 20 et the list and
4ad0: 6c 6f 6f 70 20 0a 09 20 20 20 20 20 3b 3b 20 20 loop .. ;;
4ae0: 20 20 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 - but only do
4af0: 74 68 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 that if resource
4b00: 73 20 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 s exist to kick
4b10: 6f 66 66 20 74 68 65 20 6a 6f 62 0a 09 20 20 20 off the job..
4b20: 20 20 28 28 6f 72 20 28 70 72 6f 63 65 64 75 72 ((or (procedur
4b30: 65 3f 20 69 74 65 6d 73 29 28 65 71 3f 20 69 74 e? items)(eq? it
4b40: 65 6d 73 20 27 68 61 76 65 2d 70 72 6f 63 65 64 ems 'have-proced
4b50: 75 72 65 29 29 0a 09 20 20 20 20 20 20 28 6c 65 ure)).. (le
4b60: 74 20 28 28 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 t ((can-run-more
4b70: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
4b80: 6f 73 65 20 72 75 6e 73 3a 63 61 6e 2d 72 75 6e ose runs:can-run
4b90: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 23 66 20 74 -more-tests #f t
4ba0: 65 73 74 2d 72 65 63 6f 72 64 29 29 29 0a 09 09 est-record)))...
4bb0: 28 69 66 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 (if can-run-more
4bc0: 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 70 ... (let* ((p
4bd0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 28 rereqs-not-met (
4be0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
4bf0: 62 3a 67 65 74 2d 70 72 65 72 65 71 73 2d 6e 6f b:get-prereqs-no
4c00: 74 2d 6d 65 74 20 23 66 20 72 75 6e 2d 69 64 20 t-met #f run-id
4c10: 77 61 69 74 6f 6e 73 20 69 74 65 6d 2d 70 61 74 waitons item-pat
4c20: 68 20 6d 6f 64 65 3a 20 74 65 73 74 6d 6f 64 65 h mode: testmode
4c30: 29 29 0a 09 09 09 20 20 20 28 66 61 69 6c 73 20 )).... (fails
4c40: 20 20 20 20 20 20 20 20 20 20 28 63 61 6c 63 2d (calc-
4c50: 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f fails prereqs-no
4c60: 74 2d 6d 65 74 29 29 0a 09 09 09 20 20 20 28 6e t-met)).... (n
4c70: 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 20 20 20 28 on-completed (
4c80: 63 61 6c 63 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 74 calc-not-complet
4c90: 65 64 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ed prereqs-not-m
4ca0: 65 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 64 et)))... (d
4cb0: 65 62 75 67 3a 70 72 69 6e 74 20 38 20 22 49 4e ebug:print 8 "IN
4cc0: 46 4f 3a 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 FO: can-run-more
4cd0: 3a 20 22 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 : " can-run-more
4ce0: 0a 09 09 09 09 20 20 20 22 5c 6e 20 70 72 65 72 ..... "\n prer
4cf0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 28 eqs-not-met: " (
4d00: 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 72 pretty-string pr
4d10: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 09 ereqs-not-met)..
4d20: 09 09 09 20 20 20 22 5c 6e 20 6e 6f 6e 2d 63 6f ... "\n non-co
4d30: 6d 70 6c 65 74 65 64 3a 20 20 20 22 20 28 70 72 mpleted: " (pr
4d40: 65 74 74 79 2d 73 74 72 69 6e 67 20 6e 6f 6e 2d etty-string non-
4d50: 63 6f 6d 70 6c 65 74 65 64 29 20 0a 09 09 09 09 completed) .....
4d60: 20 20 20 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 "\n fails:
4d70: 20 20 20 20 20 20 20 20 22 20 28 70 72 65 74 74 " (prett
4d80: 79 2d 73 74 72 69 6e 67 20 66 61 69 6c 73 29 0a y-string fails).
4d90: 09 09 09 09 20 20 20 22 5c 6e 20 74 65 73 74 6d .... "\n testm
4da0: 6f 64 65 3a 20 20 20 20 20 20 20 20 22 20 74 65 ode: " te
4db0: 73 74 6d 6f 64 65 0a 09 09 09 09 20 20 20 22 5c stmode..... "\
4dc0: 6e 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 65 20 n (eq? testmode
4dd0: 27 74 6f 70 6c 65 76 65 6c 29 20 22 20 28 65 71 'toplevel) " (eq
4de0: 3f 20 74 65 73 74 6d 6f 64 65 20 27 74 6f 70 6c ? testmode 'topl
4df0: 65 76 65 6c 29 0a 09 09 09 09 20 20 20 22 5c 6e evel)..... "\n
4e00: 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 (null? non-comp
4e10: 6c 65 74 65 64 29 20 20 20 20 22 20 28 6e 75 6c leted) " (nul
4e20: 6c 3f 20 6e 6f 6e 2d 63 6f 6d 70 6c 65 74 65 64 l? non-completed
4e30: 29 29 0a 09 09 20 20 20 20 20 20 28 63 6f 6e 64 ))... (cond
4e40: 20 0a 09 09 20 20 20 20 20 20 20 28 28 6f 72 20 ... ((or
4e50: 28 6e 75 6c 6c 3f 20 70 72 65 72 65 71 73 2d 6e (null? prereqs-n
4e60: 6f 74 2d 6d 65 74 29 20 3b 3b 20 61 6c 6c 20 70 ot-met) ;; all p
4e70: 72 65 72 65 71 73 20 6d 65 74 2c 20 66 69 72 65 rereqs met, fire
4e80: 20 6f 66 66 20 74 68 65 20 74 65 73 74 0a 09 09 off the test...
4e90: 09 20 20 20 20 3b 3b 20 6f 72 2c 20 69 66 20 69 . ;; or, if i
4ea0: 74 20 69 73 20 61 20 27 74 6f 70 6c 65 76 65 6c t is a 'toplevel
4eb0: 20 74 65 73 74 20 61 6e 64 20 61 6c 6c 20 70 72 test and all pr
4ec0: 65 72 65 71 73 20 6e 6f 74 20 6d 65 74 20 61 72 ereqs not met ar
4ed0: 65 20 43 4f 4d 50 4c 45 54 45 44 20 74 68 65 6e e COMPLETED then
4ee0: 20 6c 61 75 6e 63 68 0a 09 09 09 20 20 20 20 28 launch.... (
4ef0: 61 6e 64 20 28 65 71 3f 20 74 65 73 74 6d 6f 64 and (eq? testmod
4f00: 65 20 27 74 6f 70 6c 65 76 65 6c 29 0a 09 09 09 e 'toplevel)....
4f10: 09 20 28 6e 75 6c 6c 3f 20 6e 6f 6e 2d 63 6f 6d . (null? non-com
4f20: 70 6c 65 74 65 64 29 29 29 0a 09 09 09 28 6c 65 pleted)))....(le
4f30: 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 74 t ((test-name (t
4f40: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
4f50: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
4f60: 2d 72 65 63 6f 72 64 29 29 29 0a 09 09 09 20 20 -record)))....
4f70: 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 (setenv "MT_TEST
4f80: 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 _NAME" test-name
4f90: 29 20 3b 3b 20 0a 09 09 09 20 20 28 73 65 74 65 ) ;; .... (sete
4fa0: 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 nv "MT_RUNNAME"
4fb0: 20 20 72 75 6e 6e 61 6d 65 29 0a 09 09 09 20 20 runname)....
4fc0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 2d (open-run-close-
4fd0: 6d 65 61 73 75 72 65 20 73 65 74 2d 6d 65 67 61 measure set-mega
4fe0: 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 23 66 test-env-vars #f
4ff0: 20 72 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 run-id) ;; thes
5000: 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 e may be needed
5010: 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 by the launching
5020: 20 70 72 6f 63 65 73 73 0a 09 09 09 20 20 28 6c process.... (l
5030: 65 74 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 20 et ((items-list
5040: 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d 73 (items:get-items
5050: 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 6f -from-config tco
5060: 6e 66 69 67 29 29 29 0a 09 09 09 20 20 20 20 28 nfig))).... (
5070: 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d if (list? items-
5080: 6c 69 73 74 29 0a 09 09 09 09 28 62 65 67 69 6e list).....(begin
5090: 0a 09 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 ..... (tests:te
50a0: 73 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d stqueue-set-item
50b0: 73 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 s! test-record i
50c0: 74 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 09 20 tems-list).....
50d0: 20 28 6c 6f 6f 70 20 68 65 64 20 74 61 6c 29 29 (loop hed tal))
50e0: 0a 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 .....(begin.....
50f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
5100: 20 22 45 52 52 4f 52 3a 20 54 68 65 20 70 72 6f "ERROR: The pro
5110: 63 20 66 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 c from reading t
5120: 68 65 20 73 65 74 75 70 20 64 69 64 20 6e 6f 74 he setup did not
5130: 20 79 69 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 yield a list -
5140: 70 6c 65 61 73 65 20 72 65 70 6f 72 74 20 74 68 please report th
5150: 69 73 22 29 0a 09 09 09 09 20 20 28 65 78 69 74 is")..... (exit
5160: 20 31 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 1))))))...
5170: 20 20 28 28 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 ((null? fails)
5180: 0a 09 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 6e ....(loop (car n
5190: 65 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 ewtal)(cdr newta
51a0: 6c 29 29 29 20 3b 3b 20 61 6e 20 69 73 73 75 65 l))) ;; an issue
51b0: 20 77 69 74 68 20 70 72 65 72 65 71 73 20 6e 6f with prereqs no
51c0: 74 20 79 65 74 20 6d 65 74 3f 0a 09 09 20 20 20 t yet met?...
51d0: 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 28 ((and (not (
51e0: 6e 75 6c 6c 3f 20 66 61 69 6c 73 29 29 28 65 71 null? fails))(eq
51f0: 3f 20 74 65 73 74 6d 6f 64 65 20 27 6e 6f 72 6d ? testmode 'norm
5200: 61 6c 29 29 0a 09 09 09 28 64 65 62 75 67 3a 70 al))....(debug:p
5210: 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 74 65 rint 1 "INFO: te
5220: 73 74 20 22 20 20 68 65 64 20 22 20 28 6d 6f 64 st " hed " (mod
5230: 65 3d 22 20 74 65 73 74 6d 6f 64 65 20 22 29 20 e=" testmode ")
5240: 68 61 73 20 66 61 69 6c 65 64 20 70 72 65 72 65 has failed prere
5250: 71 75 69 73 69 74 65 28 73 29 3b 20 22 0a 09 09 quisite(s); "...
5260: 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 .. (string-i
5270: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
5280: 28 6c 61 6d 62 64 61 20 28 74 29 28 63 6f 6e 63 (lambda (t)(conc
5290: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
52a0: 73 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 stname t) ":" (d
52b0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
52c0: 20 74 29 22 2f 22 28 64 62 3a 74 65 73 74 2d 67 t)"/"(db:test-g
52d0: 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 20 66 et-status t))) f
52e0: 61 69 6c 73 29 20 22 2c 20 22 29 0a 09 09 09 09 ails) ", ").....
52f0: 20 20 20 20 20 22 2c 20 72 65 6d 6f 76 69 6e 67 ", removing
5300: 20 69 74 20 66 72 6f 6d 20 74 6f 2d 64 6f 20 6c it from to-do l
5310: 69 73 74 22 29 0a 09 09 09 28 69 66 20 28 6e 6f ist")....(if (no
5320: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
5330: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
5340: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
5350: 29 0a 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 )... (else
5360: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
5370: 20 38 20 22 45 52 52 4f 52 3a 20 4e 6f 20 68 61 8 "ERROR: No ha
5380: 6e 64 6c 65 72 20 66 6f 72 20 74 68 69 73 20 63 ndler for this c
5390: 6f 6e 64 69 74 69 6f 6e 2e 22 29 0a 09 09 09 3b ondition.")....;
53a0: 3b 20 09 20 20 20 20 20 22 5c 6e 20 20 68 65 64 ; . "\n hed
53b0: 3a 20 20 20 20 20 20 20 20 20 20 20 20 22 20 68 : " h
53c0: 65 64 20 0a 09 09 09 3b 3b 20 09 20 20 20 20 20 ed ....;; .
53d0: 22 5c 6e 20 66 61 69 6c 73 3a 20 20 20 20 20 20 "\n fails:
53e0: 20 20 20 20 20 22 20 28 73 74 72 69 6e 67 2d 69 " (string-i
53f0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
5400: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
5410: 6e 61 6d 65 20 66 61 69 6c 73 29 20 22 2c 22 29 name fails) ",")
5420: 0a 09 09 09 3b 3b 20 09 20 20 20 20 20 22 5c 6e ....;; . "\n
5430: 20 74 65 73 74 6d 6f 64 65 3a 20 20 20 20 20 20 testmode:
5440: 20 20 22 20 74 65 73 74 6d 6f 64 65 0a 09 09 09 " testmode....
5450: 3b 3b 20 09 20 20 20 20 20 22 5c 6e 20 70 72 65 ;; . "\n pre
5460: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 3a 20 22 20 reqs-not-met: "
5470: 28 70 72 65 74 74 79 2d 73 74 72 69 6e 67 20 70 (pretty-string p
5480: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a rereqs-not-met).
5490: 09 09 09 3b 3b 20 09 20 20 20 20 20 22 5c 6e 20 ...;; . "\n
54a0: 69 74 65 6d 73 3a 20 20 20 20 20 20 20 20 20 20 items:
54b0: 20 22 20 69 74 65 6d 73 29 0a 09 09 09 28 6c 6f " items)....(lo
54c0: 6f 70 20 28 63 61 72 20 6e 65 77 74 61 6c 29 28 op (car newtal)(
54d0: 63 64 72 20 6e 65 77 74 61 6c 29 29 29 29 29 0a cdr newtal))))).
54e0: 09 09 20 20 20 20 3b 3b 20 69 66 20 63 61 6e 27 .. ;; if can'
54f0: 74 20 72 75 6e 20 6d 6f 72 65 20 6a 75 73 74 20 t run more just
5500: 6c 6f 6f 70 20 77 69 74 68 20 6e 65 78 74 20 70 loop with next p
5510: 6f 73 73 69 62 6c 65 20 74 65 73 74 0a 09 09 20 ossible test...
5520: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 6e 65 (loop (car ne
5530: 77 74 61 6c 29 28 63 64 72 20 6e 65 77 74 61 6c wtal)(cdr newtal
5540: 29 29 29 29 29 0a 09 20 20 20 20 20 0a 09 20 20 ))))).. ..
5550: 20 20 20 3b 3b 20 74 68 69 73 20 63 61 73 65 20 ;; this case
5560: 73 68 6f 75 6c 64 20 6e 6f 74 20 68 61 70 70 65 should not happe
5570: 6e 2c 20 61 64 64 65 64 20 74 6f 20 68 65 6c 70 n, added to help
5580: 20 63 61 74 63 68 20 61 6e 79 20 62 75 67 73 0a catch any bugs.
5590: 09 20 20 20 20 20 28 28 61 6e 64 20 28 6c 69 73 . ((and (lis
55a0: 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 64 61 t? items) itemda
55b0: 74 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 t).. (debug
55c0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
55d0: 20 53 68 6f 75 6c 64 20 6e 6f 74 20 68 61 76 65 Should not have
55e0: 20 61 20 6c 69 73 74 20 6f 66 20 69 74 65 6d 73 a list of items
55f0: 20 69 6e 20 61 20 74 65 73 74 20 61 6e 64 20 74 in a test and t
5600: 68 65 20 69 74 65 6d 73 70 61 74 68 20 73 65 74 he itemspath set
5610: 20 2d 20 70 6c 65 61 73 65 20 72 65 70 6f 72 74 - please report
5620: 20 74 68 69 73 22 29 0a 09 20 20 20 20 20 20 28 this").. (
5630: 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 0a 09 exit 1)))).. ..
5640: 20 20 3b 3b 20 77 65 20 67 65 74 20 68 65 72 65 ;; we get here
5650: 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f 75 67 on "drop throug
5660: 68 22 20 2d 20 6c 6f 6f 70 20 66 6f 72 20 6e 65 h" - loop for ne
5670: 78 74 20 74 65 73 74 20 69 6e 20 71 75 65 75 65 xt test in queue
5680: 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 .. (if (null? t
5690: 61 6c 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 al).. (begi
56a0: 6e 0a 09 09 3b 3b 20 46 49 58 4d 45 21 21 21 21 n...;; FIXME!!!!
56b0: 20 54 48 49 53 20 53 48 4f 55 4c 44 20 4e 4f 54 THIS SHOULD NOT
56c0: 20 52 45 51 55 49 52 45 20 41 4e 20 45 58 49 54 REQUIRE AN EXIT
56d0: 21 21 21 21 21 21 21 0a 09 09 28 64 65 62 75 67 !!!!!!!...(debug
56e0: 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 :print 1 "INFO:
56f0: 41 6c 6c 20 74 65 73 74 73 20 6c 61 75 6e 63 68 All tests launch
5700: 65 64 22 29 0a 09 09 28 74 68 72 65 61 64 2d 73 ed")...(thread-s
5710: 6c 65 65 70 21 20 30 2e 35 29 0a 09 09 3b 3b 20 leep! 0.5)...;;
5720: 46 49 58 4d 45 21 20 54 68 69 73 20 68 61 72 73 FIXME! This hars
5730: 68 20 65 78 69 74 20 73 68 6f 75 6c 64 20 6e 6f h exit should no
5740: 74 20 62 65 20 6e 65 63 65 73 73 61 72 79 2e 2e t be necessary..
5750: 2e 2e 0a 09 09 28 69 66 20 28 6e 6f 74 20 2a 72 .....(if (not *r
5760: 75 6e 72 65 6d 6f 74 65 2a 29 28 65 78 69 74 29 unremote*)(exit)
5770: 29 20 3b 3b 20 0a 09 09 23 66 29 20 3b 3b 20 72 ) ;; ...#f) ;; r
5780: 65 74 75 72 6e 20 61 20 23 66 20 61 73 20 61 20 eturn a #f as a
5790: 68 69 6e 74 20 74 68 61 74 20 77 65 20 61 72 65 hint that we are
57a0: 20 64 6f 6e 65 0a 09 20 20 20 20 20 20 3b 3b 20 done.. ;;
57b0: 48 65 72 65 20 77 65 20 6e 65 65 64 20 74 6f 20 Here we need to
57c0: 63 68 65 63 6b 20 74 68 61 74 20 61 6c 6c 20 74 check that all t
57d0: 68 65 20 74 65 73 74 73 20 72 65 6d 61 69 6e 69 he tests remaini
57e0: 6e 67 20 74 6f 20 62 65 20 72 75 6e 20 61 72 65 ng to be run are
57f0: 20 65 6c 69 67 69 62 6c 65 20 74 6f 20 72 75 6e eligible to run
5800: 0a 09 20 20 20 20 20 20 3b 3b 20 61 6e 64 20 61 .. ;; and a
5810: 72 65 20 6e 6f 74 20 62 6c 6f 63 6b 65 64 20 62 re not blocked b
5820: 79 20 66 61 69 6c 65 64 0a 09 20 20 20 20 20 20 y failed..
5830: 28 6c 65 74 20 28 28 6e 65 77 6c 73 74 20 28 6f (let ((newlst (o
5840: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 pen-run-close te
5850: 73 74 73 3a 66 69 6c 74 65 72 2d 6e 6f 6e 2d 72 sts:filter-non-r
5860: 75 6e 6e 61 62 6c 65 20 23 66 20 72 75 6e 2d 69 unnable #f run-i
5870: 64 20 74 61 6c 20 74 65 73 74 2d 72 65 63 6f 72 d tal test-recor
5880: 64 73 29 29 29 20 3b 3b 20 69 2e 65 2e 20 6e 6f ds))) ;; i.e. no
5890: 74 20 46 41 49 4c 2c 20 57 41 49 56 45 44 2c 20 t FAIL, WAIVED,
58a0: 49 4e 43 4f 4d 50 4c 45 54 45 2c 20 50 41 53 53 INCOMPLETE, PASS
58b0: 2c 20 4b 49 4c 4c 45 44 2c 0a 09 09 28 74 68 72 , KILLED,...(thr
58c0: 65 61 64 2d 73 6c 65 65 70 21 20 2a 67 6c 6f 62 ead-sleep! *glob
58d0: 61 6c 2d 64 65 6c 74 61 2a 29 0a 09 09 28 69 66 al-delta*)...(if
58e0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 6e 65 77 (not (null? new
58f0: 6c 73 74 29 29 0a 09 09 20 20 20 20 28 6c 6f 6f lst))... (loo
5900: 70 20 28 63 61 72 20 6e 65 77 6c 73 74 29 28 63 p (car newlst)(c
5910: 64 72 20 6e 65 77 6c 73 74 29 29 29 29 29 29 29 dr newlst)))))))
5920: 29 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 ))..;; parent-te
5930: 73 74 20 69 73 20 74 68 65 72 65 20 61 73 20 61 st is there as a
5940: 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 placeholder for
5950: 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 when parent-tes
5960: 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 61 73 ts can be run as
5970: 20 61 20 73 65 74 75 70 20 73 74 65 70 0a 28 64 a setup step.(d
5980: 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 efine (run:test
5990: 72 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 6b run-id runname k
59a0: 65 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 72 65 eyvallst test-re
59b0: 63 6f 72 64 20 66 6c 61 67 73 20 70 61 72 65 6e cord flags paren
59c0: 74 2d 74 65 73 74 29 0a 20 20 3b 3b 20 41 6c 6c t-test). ;; All
59d0: 20 74 68 65 73 65 20 76 61 72 73 20 6d 69 67 68 these vars migh
59e0: 74 20 62 65 20 72 65 66 65 72 65 6e 63 65 64 20 t be referenced
59f0: 62 79 20 74 68 65 20 74 65 73 74 63 6f 6e 66 69 by the testconfi
5a00: 67 20 66 69 6c 65 20 72 65 61 64 65 72 0a 20 20 g file reader.
5a10: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e 61 6d (let* ((test-nam
5a20: 65 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 e (tests:test
5a30: 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 queue-get-testna
5a40: 6d 65 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 me test-record
5a50: 29 29 0a 09 20 28 74 65 73 74 2d 77 61 69 74 6f )).. (test-waito
5a60: 6e 73 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 ns (tests:testqu
5a70: 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e 73 20 eue-get-waitons
5a80: 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 test-record))
5a90: 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 .. (test-conf
5aa0: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
5ab0: 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 e-get-testconfig
5ac0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
5ad0: 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 20 28 (itemdat (
5ae0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
5af0: 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 20 74 get-itemdat t
5b00: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
5b10: 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f test-path (co
5b20: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
5b30: 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 ests/" test-name
5b40: 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 65 20 )) ;; could use
5b50: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f tests:get-testco
5b60: 6e 66 69 67 20 68 65 72 65 20 2e 2e 2e 0a 09 20 nfig here .....
5b70: 28 66 6f 72 63 65 20 20 20 20 20 20 20 20 28 68 (force (h
5b80: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
5b90: 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 66 6f fault flags "-fo
5ba0: 72 63 65 22 20 23 66 29 29 0a 09 20 28 72 65 72 rce" #f)).. (rer
5bb0: 75 6e 20 20 20 20 20 20 20 20 28 68 61 73 68 2d un (hash-
5bc0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5bd0: 74 20 66 6c 61 67 73 20 22 2d 72 65 72 75 6e 22 t flags "-rerun"
5be0: 20 23 66 29 29 0a 09 20 28 6b 65 65 70 67 6f 69 #f)).. (keepgoi
5bf0: 6e 67 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c ng (hash-tabl
5c00: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
5c10: 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 ags "-keepgoing"
5c20: 20 23 66 29 29 0a 09 20 28 69 74 65 6d 2d 70 61 #f)).. (item-pa
5c30: 74 68 20 20 20 20 20 22 22 29 0a 09 20 28 64 62 th "").. (db
5c40: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 0a #f)).
5c50: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5c60: 20 35 0a 09 09 20 22 74 65 73 74 2d 63 6f 6e 66 5... "test-conf
5c70: 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c ig: " (hash-tabl
5c80: 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f e->alist test-co
5c90: 6e 66 29 0a 09 09 20 22 5c 6e 20 20 20 69 74 65 nf)... "\n ite
5ca0: 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 61 74 0a mdat: " itemdat.
5cb0: 09 09 20 29 0a 20 20 20 20 3b 3b 20 73 65 74 74 .. ). ;; sett
5cc0: 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f 20 61 ing itemdat to a
5cd0: 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 20 23 list if it is #
5ce0: 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 f. (if (not i
5cf0: 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 74 65 temdat)(set! ite
5d00: 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 20 28 mdat '())). (
5d10: 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 20 28 set! item-path (
5d20: 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 item-list->path
5d30: 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 28 64 itemdat)). (d
5d40: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 ebug:print 2 "At
5d50: 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c 61 75 6e tempting to laun
5d60: 63 68 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e ch test " test-n
5d70: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
5d80: 68 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 h). (setenv "
5d90: 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 MT_TEST_NAME" te
5da0: 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 st-name) ;; .
5db0: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
5dc0: 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 NAME" runname)
5dd0: 0a 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 . (open-run-c
5de0: 6c 6f 73 65 2d 6d 65 61 73 75 72 65 20 73 65 74 lose-measure set
5df0: 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 -megatest-env-va
5e00: 72 73 20 64 62 20 72 75 6e 2d 69 64 29 20 3b 3b rs db run-id) ;;
5e10: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
5e20: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
5e30: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 20 20 ching process.
5e40: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
5e50: 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a ory *toppath*)..
5e60: 20 20 20 20 3b 3b 20 48 65 72 65 20 69 73 20 77 ;; Here is w
5e70: 68 65 72 65 20 74 68 65 20 74 65 73 74 5f 6d 65 here the test_me
5e80: 74 61 20 74 61 62 6c 65 20 69 73 20 62 65 73 74 ta table is best
5e90: 20 75 70 64 61 74 65 64 0a 20 20 20 20 3b 3b 20 updated. ;;
5ea0: 59 65 73 2c 20 61 6e 6f 74 68 65 72 20 75 73 65 Yes, another use
5eb0: 20 6f 66 20 61 20 67 6c 6f 62 61 6c 20 66 6f 72 of a global for
5ec0: 20 63 61 63 68 69 6e 67 2e 20 4e 65 65 64 20 61 caching. Need a
5ed0: 20 62 65 74 74 65 72 20 77 61 79 3f 0a 20 20 20 better way?.
5ee0: 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 68 2d (if (not (hash-
5ef0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
5f00: 74 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 t *test-meta-upd
5f10: 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 ated* test-name
5f20: 23 66 29 29 0a 20 20 20 20 20 20 20 20 28 62 65 #f)). (be
5f30: 67 69 6e 0a 09 20 20 20 28 68 61 73 68 2d 74 61 gin.. (hash-ta
5f40: 62 6c 65 2d 73 65 74 21 20 2a 74 65 73 74 2d 6d ble-set! *test-m
5f50: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 eta-updated* tes
5f60: 74 2d 6e 61 6d 65 20 23 74 29 0a 20 20 20 20 20 t-name #t).
5f70: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
5f80: 63 6c 6f 73 65 20 72 75 6e 73 3a 75 70 64 61 74 close runs:updat
5f90: 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 74 e-test_meta db t
5fa0: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 6f est-name test-co
5fb0: 6e 66 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b nf))). . ;
5fc0: 3b 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 ; (lambda (itemd
5fd0: 61 74 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 at) ;;; ((ripene
5fe0: 73 73 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 ss "overripe") (
5ff0: 74 65 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f temperature "coo
6000: 6c 22 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d l") (season "sum
6010: 6d 65 72 22 29 29 0a 20 20 20 20 28 6c 65 74 2a mer")). (let*
6020: 20 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 ((new-test-path
6030: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
6040: 65 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d erse (cons test-
6050: 70 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 path (map cadr i
6060: 74 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 temdat)) "/"))..
6070: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d (new-test-nam
6080: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
6090: 65 6d 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 em-path "") test
60a0: 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 -name (conc test
60b0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
60c0: 61 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e ath))) ;; just n
60d0: 65 65 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 eed it to be uni
60e0: 71 75 65 0a 09 20 20 20 28 74 65 73 74 2d 69 64 que.. (test-id
60f0: 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e (open-run
6100: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
6110: 73 74 2d 69 64 20 64 62 20 20 72 75 6e 2d 69 64 st-id db run-id
6120: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
6130: 70 61 74 68 29 29 0a 09 20 20 20 28 74 65 73 74 path)).. (test
6140: 64 61 74 20 20 20 20 20 20 20 28 6f 70 65 6e 2d dat (open-
6150: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
6160: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
6170: 20 64 62 20 74 65 73 74 2d 69 64 29 29 29 0a 20 db test-id))).
6180: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 (if (not te
6190: 73 74 64 61 74 29 0a 09 20 20 28 62 65 67 69 6e stdat).. (begin
61a0: 0a 09 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 .. ;; ensure
61b0: 74 68 61 74 20 74 68 65 20 70 61 74 68 20 65 78 that the path ex
61c0: 69 73 74 73 20 62 65 66 6f 72 65 20 72 65 67 69 ists before regi
61d0: 73 74 65 72 69 6e 67 20 74 68 65 20 74 65 73 74 stering the test
61e0: 0a 09 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 .. ;; NOPE: C
61f0: 61 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f annot! Don't kno
6200: 77 20 79 65 74 20 77 68 69 63 68 20 64 69 73 6b w yet which disk
6210: 20 61 72 65 61 20 77 69 6c 6c 20 62 65 20 61 73 area will be as
6220: 73 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 signed......
6230: 3b 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 ;; (system (conc
6240: 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 "mkdir -p " new
6250: 2d 74 65 73 74 2d 70 61 74 68 29 29 0a 09 20 20 -test-path))..
6260: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
6270: 65 20 74 65 73 74 73 3a 72 65 67 69 73 74 65 72 e tests:register
6280: 2d 74 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 -test db run-id
6290: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
62a0: 61 74 68 29 0a 09 20 20 20 20 28 73 65 74 21 20 ath).. (set!
62b0: 74 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 test-id (open-ru
62c0: 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 n-close db:get-t
62d0: 65 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 est-id db run-id
62e0: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
62f0: 70 61 74 68 29 29 0a 09 20 20 20 20 28 73 65 74 path)).. (set
6300: 21 20 74 65 73 74 64 61 74 20 28 6f 70 65 6e 2d ! testdat (open-
6310: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
6320: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
6330: 20 64 62 20 74 65 73 74 2d 69 64 29 29 29 29 0a db test-id)))).
6340: 20 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 (set! test
6350: 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 -id (db:test-get
6360: 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 20 20 -id testdat)).
6370: 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 (change-dire
6380: 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 68 29 ctory test-path)
6390: 0a 20 20 20 20 20 20 28 63 61 73 65 20 28 69 66 . (case (if
63a0: 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 67 73 3a force ;; (args:
63b0: 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 get-arg "-force"
63c0: 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 54 45 44 )...'NOT_STARTED
63d0: 0a 09 09 28 69 66 20 74 65 73 74 64 61 74 0a 09 ...(if testdat..
63e0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 . (string->sy
63f0: 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 mbol (test:get-s
6400: 74 61 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 tate testdat))..
6410: 09 20 20 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d . 'failed-to-
6420: 69 6e 73 65 72 74 29 29 0a 09 28 28 66 61 69 6c insert))..((fail
6430: 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 20 ed-to-insert)..
6440: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
6450: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
6460: 20 69 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f insert the reco
6470: 72 64 20 69 6e 74 6f 20 74 68 65 20 64 62 22 29 rd into the db")
6480: 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 )..((NOT_STARTED
6490: 20 43 4f 4d 50 4c 45 54 45 44 29 0a 09 20 28 6c COMPLETED).. (l
64a0: 65 74 20 28 28 72 75 6e 66 6c 61 67 20 23 66 29 et ((runflag #f)
64b0: 29 0a 09 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 ).. (cond..
64c0: 20 3b 3b 20 2d 66 6f 72 63 65 2c 20 72 75 6e 20 ;; -force, run
64d0: 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a 09 no matter what..
64e0: 20 20 20 20 28 66 6f 72 63 65 20 28 73 65 74 21 (force (set!
64f0: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
6500: 20 20 20 3b 3b 20 4e 4f 54 5f 53 54 41 52 54 45 ;; NOT_STARTE
6510: 44 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 D, run no matter
6520: 20 77 68 61 74 0a 09 20 20 20 20 28 28 65 71 75 what.. ((equ
6530: 61 6c 3f 20 28 74 65 73 74 3a 67 65 74 2d 73 74 al? (test:get-st
6540: 61 74 65 20 74 65 73 74 64 61 74 29 20 22 4e 4f ate testdat) "NO
6550: 54 5f 53 54 41 52 54 45 44 22 29 28 73 65 74 21 T_STARTED")(set!
6560: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
6570: 20 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 72 75 6e ;; not -rerun
6580: 20 61 6e 64 20 50 41 53 53 2c 20 57 41 52 4e 20 and PASS, WARN
6590: 6f 72 20 43 48 45 43 4b 2c 20 64 6f 20 6e 6f 20 or CHECK, do no
65a0: 72 75 6e 0a 09 20 20 20 20 28 28 61 6e 64 20 28 run.. ((and (
65b0: 6f 72 20 28 6e 6f 74 20 72 65 72 75 6e 29 0a 09 or (not rerun)..
65c0: 09 20 20 20 20 20 20 6b 65 65 70 67 6f 69 6e 67 . keepgoing
65d0: 29 0a 09 09 20 20 3b 3b 20 52 65 71 75 69 72 65 )... ;; Require
65e0: 20 74 6f 20 66 6f 72 63 65 20 72 65 2d 72 75 6e to force re-run
65f0: 20 66 6f 72 20 43 4f 4d 50 4c 45 54 45 44 20 6f for COMPLETED o
6600: 72 20 2a 61 6e 79 74 68 69 6e 67 2a 20 2b 20 50 r *anything* + P
6610: 41 53 53 2c 57 41 52 4e 20 6f 72 20 43 48 45 43 ASS,WARN or CHEC
6620: 4b 0a 09 09 20 20 28 6f 72 20 28 6d 65 6d 62 65 K... (or (membe
6630: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
6640: 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 50 us testdat) '("P
6650: 41 53 53 22 20 22 57 41 52 4e 22 20 22 43 48 45 ASS" "WARN" "CHE
6660: 43 4b 22 29 29 0a 09 09 20 20 20 20 20 20 28 6d CK"))... (m
6670: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
6680: 73 74 61 74 65 20 20 74 65 73 74 64 61 74 29 20 state testdat)
6690: 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 '("COMPLETED")))
66a0: 29 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a ) .. (debug:
66b0: 70 72 69 6e 74 20 32 20 22 49 4e 46 4f 3a 20 72 print 2 "INFO: r
66c0: 75 6e 6e 69 6e 67 20 74 65 73 74 20 22 20 74 65 unning test " te
66d0: 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d st-name "/" item
66e0: 2d 70 61 74 68 20 22 20 73 75 70 70 72 65 73 73 -path " suppress
66f0: 65 64 20 61 73 20 69 74 20 69 73 20 22 20 28 74 ed as it is " (t
6700: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
6710: 73 74 64 61 74 29 20 22 20 61 6e 64 20 22 20 28 stdat) " and " (
6720: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
6730: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
6740: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 (set! runflag #f
6750: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 )).. ;; -reru
6760: 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 73 20 n and status is
6770: 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 63 69 one of the speci
6780: 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 fed, run it..
6790: 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 ((and rerun...
67a0: 20 28 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 (let* ((rerunls
67b0: 74 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 t (string-spli
67c0: 74 20 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 t rerun ","))...
67d0: 09 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d . (must-rerun (m
67e0: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
67f0: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
6800: 72 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 rerunlst)))...
6810: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 (debug:print 3
6820: 20 22 49 4e 46 4f 3a 20 2d 72 65 72 75 6e 20 6c "INFO: -rerun l
6830: 69 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 ist: " rerun ",
6840: 74 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 28 test-status: " (
6850: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
6860: 74 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 2d testdat)", must-
6870: 72 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 rerun: " must-re
6880: 72 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 2d run)... must-
6890: 72 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 64 rerun)).. (d
68a0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 4e ebug:print 2 "IN
68b0: 46 4f 3a 20 52 65 72 75 6e 20 66 6f 72 63 65 64 FO: Rerun forced
68c0: 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
68d0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
68e0: 61 74 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 ath).. (set!
68f0: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
6900: 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 ;; -keepgoing
6910: 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 , do not rerun F
6920: 41 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b AIL.. ((and k
6930: 65 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 eepgoing... (me
6940: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
6950: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 tatus testdat) '
6960: 28 22 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 ("FAIL")))..
6970: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
6980: 66 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 f)).. ((and (
6990: 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 not rerun)... (
69a0: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
69b0: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
69c0: 20 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 '("FAIL" "n/a")
69d0: 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 )).. (set! r
69e0: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
69f0: 20 28 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e (else (set! run
6a00: 66 6c 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 flag #f))).. (
6a10: 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 52 debug:print 6 "R
6a20: 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 UNNING => runfla
6a30: 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 g: " runflag " S
6a40: 54 41 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 TATE: " (test:ge
6a50: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
6a60: 20 22 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 " STATUS: " (te
6a70: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
6a80: 73 74 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 stdat)).. (if
6a90: 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 (not runflag)..
6aa0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 (if (not p
6ab0: 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 arent-test)...
6ac0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
6ad0: 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 "NOTE: Not start
6ae0: 69 6e 67 20 74 65 73 74 20 22 20 6e 65 77 2d 74 ing test " new-t
6af0: 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 est-name " as it
6b00: 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 is state \"" (t
6b10: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
6b20: 73 74 64 61 74 29 20 0a 09 09 09 09 22 5c 22 20 stdat) ....."\"
6b30: 61 6e 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 and status \"" (
6b40: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
6b50: 74 65 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 testdat) "\", us
6b60: 65 20 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 e -rerun \"" (te
6b70: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
6b80: 73 74 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 stdat).
6b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6ba0: 20 20 20 20 20 20 20 22 5c 22 20 6f 72 20 2d 66 "\" or -f
6bb0: 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 orce to override
6bc0: 22 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e ")).. ;; N
6bd0: 4f 54 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 OTE: No longer b
6be0: 65 20 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 e checking prere
6bf0: 71 75 69 73 69 74 65 73 20 68 65 72 65 21 20 57 quisites here! W
6c00: 69 6c 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 ill never get he
6c10: 72 65 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 re unless prereq
6c20: 73 20 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b s are.. ;;
6c30: 20 20 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d already m
6c40: 65 74 2e 0a 09 20 20 20 20 20 20 20 28 69 66 20 et... (if
6c50: 28 6e 6f 74 20 28 6c 61 75 6e 63 68 2d 74 65 73 (not (launch-tes
6c60: 74 20 23 66 20 72 75 6e 2d 69 64 20 72 75 6e 6e t #f run-id runn
6c70: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 6b 65 ame test-conf ke
6c80: 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 6e 61 6d yvallst test-nam
6c90: 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d e test-path item
6ca0: 64 61 74 20 66 6c 61 67 73 29 29 0a 09 09 20 20 dat flags))...
6cb0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 (begin... (
6cc0: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 print "ERROR: Fa
6cd0: 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 iled to launch t
6ce0: 68 65 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 he test. Exiting
6cf0: 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 as soon as poss
6d00: 69 62 6c 65 22 29 0a 09 09 20 20 20 20 20 28 73 ible")... (s
6d10: 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 et! *globalexits
6d20: 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 tatus* 1) ;; ...
6d30: 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 (process-si
6d40: 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 gnal (current-pr
6d50: 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c ocess-id) signal
6d60: 2f 6b 69 6c 6c 29 29 29 29 29 29 0a 09 28 28 4b /kill))))))..((K
6d70: 49 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 ILLED) .. (debug
6d80: 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 :print 1 "NOTE:
6d90: 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 " new-test-name
6da0: 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e " is already run
6db0: 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c ning or was expl
6dc0: 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 ictly killed, us
6dd0: 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e e -force to laun
6de0: 63 68 20 69 74 2e 22 29 29 0a 09 28 28 4c 41 55 ch it."))..((LAU
6df0: 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 54 NCHED REMOTEHOST
6e00: 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 20 START RUNNING)
6e10: 0a 09 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 .. (if (> (- (cu
6e20: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b rrent-seconds)(+
6e30: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 (db:test-get-ev
6e40: 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 ent_time testdat
6e50: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 62 )..... (db
6e60: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 :test-get-run_du
6e70: 72 61 74 69 6f 6e 20 74 65 73 74 64 61 74 29 29 ration testdat))
6e80: 29 0a 09 09 36 30 30 29 20 3b 3b 20 69 2e 65 2e )...600) ;; i.e.
6e90: 20 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d no update for m
6ea0: 6f 72 65 20 74 68 61 6e 20 36 30 30 20 73 65 63 ore than 600 sec
6eb0: 6f 6e 64 73 0a 09 20 20 20 20 20 28 62 65 67 69 onds.. (begi
6ec0: 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 n.. (debug
6ed0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
6ee0: 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e G: Test " test-n
6ef0: 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 6f ame " appears to
6f00: 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e be dead. Forcin
6f10: 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e g it to state IN
6f20: 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 COMPLETE and sta
6f30: 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 tus STUCK/DEAD")
6f40: 0a 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
6f50: 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 2d 73 65 un-close test-se
6f60: 74 2d 73 74 61 74 75 73 21 20 64 62 20 74 65 73 t-status! db tes
6f70: 74 2d 69 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 t-id "INCOMPLETE
6f80: 22 20 22 53 54 55 43 4b 2f 44 45 41 44 22 20 22 " "STUCK/DEAD" "
6f90: 54 65 73 74 20 69 73 20 73 74 75 63 6b 20 6f 72 Test is stuck or
6fa0: 20 64 65 61 64 22 20 23 66 29 29 0a 09 20 20 20 dead" #f))..
6fb0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
6fc0: 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2d 6e "NOTE: " test-n
6fd0: 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 ame " is already
6fe0: 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 28 65 running")))..(e
6ff0: 6c 73 65 20 20 20 20 20 20 20 28 64 65 62 75 67 lse (debug
7000: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
7010: 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 Failed to launc
7020: 68 20 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 h test " new-tes
7030: 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 63 6f t-name ". Unreco
7040: 67 6e 69 73 65 64 20 73 74 61 74 65 20 22 20 28 gnised state " (
7050: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
7060: 65 73 74 64 61 74 29 29 29 29 29 29 29 0a 0a 3b estdat)))))))..;
7070: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70b0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 20 4f =======.;; END O
70c0: 46 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b 3d 3d F NEW STUFF.;;==
70d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
70f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7110: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 67 ====..(define (g
7120: 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 72 20 et-dir-up-n dir
7130: 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 28 6c 65 . params) . (le
7140: 74 20 28 28 64 70 61 72 74 73 20 20 28 73 74 72 t ((dparts (str
7150: 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 22 2f ing-split dir "/
7160: 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 28 69 "))..(count (i
7170: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
7180: 20 31 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 1 (car params))
7190: 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 2f 22 )). (conc "/"
71a0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
71b0: 65 72 73 65 20 0a 09 20 20 20 20 20 20 20 28 74 erse .. (t
71c0: 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 28 6c ake dparts (- (l
71d0: 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 63 6f ength dparts) co
71e0: 75 6e 74 29 29 0a 09 20 20 20 20 20 20 20 22 2f unt)).. "/
71f0: 22 29 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 65 20 ")))).;; Remove
7200: 72 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 20 61 runs.;; fields a
7210: 72 65 20 70 61 73 73 69 6e 67 20 69 6e 20 74 68 re passing in th
7220: 72 6f 75 67 68 20 0a 3b 3b 20 61 63 74 69 6f 6e rough .;; action
7230: 3a 0a 3b 3b 20 20 20 20 27 72 65 6d 6f 76 65 2d :.;; 'remove-
7240: 72 75 6e 73 0a 3b 3b 20 20 20 20 27 73 65 74 2d runs.;; 'set-
7250: 73 74 61 74 65 2d 73 74 61 74 75 73 0a 3b 3b 0a state-status.;;.
7260: 3b 3b 20 4e 42 2f 2f 20 73 68 6f 75 6c 64 20 70 ;; NB// should p
7270: 61 73 73 20 69 6e 20 6b 65 79 73 3f 0a 3b 3b 0a ass in keys?.;;.
7280: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6f 70 (define (runs:op
7290: 65 72 61 74 65 2d 6f 6e 20 64 62 20 61 63 74 69 erate-on db acti
72a0: 6f 6e 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 on runnamepatt t
72b0: 65 73 74 70 61 74 74 20 69 74 65 6d 70 61 74 74 estpatt itempatt
72c0: 20 23 21 6b 65 79 20 28 73 74 61 74 65 20 23 66 #!key (state #f
72d0: 29 28 73 74 61 74 75 73 20 23 66 29 28 6e 65 77 )(status #f)(new
72e0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 66 -state-status #f
72f0: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 )). (let* ((key
7300: 73 20 20 20 20 20 20 20 20 20 28 72 64 62 3a 67 s (rdb:g
7310: 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 28 et-keys db)).. (
7320: 72 75 6e 64 61 74 20 20 20 20 20 20 20 28 72 75 rundat (ru
7330: 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 ns:get-runs-by-p
7340: 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e att db keys runn
7350: 61 6d 65 70 61 74 74 29 29 0a 09 20 28 68 65 61 amepatt)).. (hea
7360: 64 65 72 20 20 20 20 20 20 20 28 76 65 63 74 6f der (vecto
7370: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 r-ref rundat 0))
7380: 0a 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 .. (runs
7390: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e (vector-ref run
73a0: 64 61 74 20 31 29 29 0a 09 20 28 73 74 61 74 65 dat 1)).. (state
73b0: 73 20 20 20 20 20 20 20 28 69 66 20 73 74 61 74 s (if stat
73c0: 65 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 e (string-split
73d0: 20 73 74 61 74 65 20 20 22 2c 22 29 20 27 28 29 state ",") '()
73e0: 29 29 0a 09 20 28 73 74 61 74 75 73 65 73 20 20 )).. (statuses
73f0: 20 20 20 28 69 66 20 73 74 61 74 75 73 20 28 73 (if status (s
7400: 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 tring-split stat
7410: 75 73 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 us ",") '()))..
7420: 28 73 74 61 74 65 2d 73 74 61 74 75 73 20 28 69 (state-status (i
7430: 66 20 28 73 74 72 69 6e 67 3f 20 6e 65 77 2d 73 f (string? new-s
7440: 74 61 74 65 2d 73 74 61 74 75 73 29 20 28 73 74 tate-status) (st
7450: 72 69 6e 67 2d 73 70 6c 69 74 20 6e 65 77 2d 73 ring-split new-s
7460: 74 61 74 65 2d 73 74 61 74 75 73 20 22 2c 22 29 tate-status ",")
7470: 20 27 28 23 66 20 23 66 29 29 29 29 0a 20 20 20 '(#f #f)))).
7480: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
7490: 22 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 65 "Header: " heade
74a0: 72 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 r " action: " ac
74b0: 74 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 65 tion " new-state
74c0: 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d 73 -status: " new-s
74d0: 74 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 20 tate-status).
74e0: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
74f0: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 (lambda (run).
7500: 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6b (let ((runk
7510: 65 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ey (string-inter
7520: 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d sperse (map (lam
7530: 62 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 64 bda (k).......(d
7540: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
7550: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
7560: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 20 30 (vector-ref k 0
7570: 29 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a ))) keys) "/")).
7580: 09 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 . (dirs-to-r
7590: 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 emove (make-hash
75a0: 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 6c 65 74 -table))).. (let
75b0: 2a 20 28 28 72 75 6e 2d 69 64 20 20 20 20 28 64 * ((run-id (d
75c0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
75d0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
75e0: 20 22 69 64 22 29 29 0a 09 09 28 72 75 6e 2d 73 "id"))...(run-s
75f0: 74 61 74 65 20 28 64 62 3a 67 65 74 2d 76 61 6c tate (db:get-val
7600: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
7610: 20 68 65 61 64 65 72 20 22 73 74 61 74 65 22 29 header "state")
7620: 29 0a 09 09 28 74 65 73 74 73 20 20 20 20 20 28 )...(tests (
7630: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal?
7640: 72 75 6e 2d 73 74 61 74 65 20 22 6c 6f 63 6b 65 run-state "locke
7650: 64 22 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 d")).... (
7660: 72 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f rdb:get-tests-fo
7670: 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 r-run db (db:get
7680: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
7690: 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
76a0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 74 65 )....... te
76b0: 73 74 70 61 74 74 20 69 74 65 6d 70 61 74 74 20 stpatt itempatt
76c0: 73 74 61 74 65 73 20 73 74 61 74 75 73 65 73 0a states statuses.
76d0: 09 09 09 09 09 09 20 20 20 20 20 20 6e 6f 74 2d ...... not-
76e0: 69 6e 3a 20 20 23 66 0a 09 09 09 09 09 09 20 20 in: #f.......
76f0: 20 20 20 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 sort-by: (ca
7700: 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 se action.......
7710: 09 09 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 .. ((remove-runs
7720: 29 20 27 72 75 6e 64 69 72 29 0a 09 09 09 09 09 ) 'rundir)......
7730: 09 09 09 20 28 65 6c 73 65 20 20 20 20 20 20 20 ... (else
7740: 20 20 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 'event_time))
7750: 29 0a 09 09 09 20 20 20 20 20 20 20 27 28 29 29 ).... '())
7760: 29 0a 09 09 28 6c 61 73 74 74 70 61 74 68 20 22 )...(lasttpath "
7770: 2f 64 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f /does/not/exist/
7780: 49 2f 68 6f 70 65 22 29 29 0a 0a 09 20 20 20 28 I/hope"))... (
7790: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
77a0: 65 73 74 73 29 29 0a 09 20 20 20 20 20 20 20 28 ests)).. (
77b0: 62 65 67 69 6e 0a 09 09 20 28 63 61 73 65 20 61 begin... (case a
77c0: 63 74 69 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d ction... ((rem
77d0: 6f 76 65 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 ove-runs)...
77e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
77f0: 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 20 66 Removing tests f
7800: 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 or run: " runkey
7810: 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c " " (db:get-val
7820: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
7830: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
7840: 22 29 29 29 0a 09 09 20 20 20 28 28 73 65 74 2d ")))... ((set-
7850: 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 state-status)...
7860: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
7870: 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 74 1 "Modifying st
7880: 61 74 65 20 61 6e 64 20 73 74 61 75 73 20 66 6f ate and staus fo
7890: 72 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a r tests for run:
78a0: 20 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 " runkey " " (d
78b0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
78c0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
78d0: 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 "runname")))...
78e0: 20 20 20 28 65 6c 73 65 0a 09 09 20 20 20 20 28 (else... (
78f0: 70 72 69 6e 74 20 22 49 4e 46 4f 3a 20 61 63 74 print "INFO: act
7900: 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 ion not recognis
7910: 65 64 20 22 20 61 63 74 69 6f 6e 29 29 29 0a 09 ed " action)))..
7920: 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 . (for-each...
7930: 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a 09 (lambda (test)..
7940: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 . (let* ((ite
7950: 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d m-path (db:test-
7960: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
7970: 73 74 29 29 0a 09 09 09 20 20 20 28 74 65 73 74 st)).... (test
7980: 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 -name (db:test-g
7990: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
79a0: 29 29 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 69 )).... (run-di
79b0: 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 r (db:test-get
79c0: 2d 72 75 6e 64 69 72 20 74 65 73 74 29 29 29 0a -rundir test))).
79d0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
79e0: 72 69 6e 74 20 31 20 22 20 20 22 20 28 64 62 3a rint 1 " " (db:
79f0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
7a00: 65 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 20 e test) " id: "
7a10: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
7a20: 74 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d 70 test) " " item-p
7a30: 61 74 68 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 ath " action: "
7a40: 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 action)...
7a50: 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 (case action....
7a60: 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 ((remove-runs)..
7a70: 09 09 20 28 72 64 62 3a 64 65 6c 65 74 65 2d 74 .. (rdb:delete-t
7a80: 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 20 28 est-records db (
7a90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
7aa0: 65 73 74 29 29 0a 09 09 09 20 28 64 65 62 75 67 est)).... (debug
7ab0: 3a 70 72 69 6e 74 20 31 20 22 49 4e 46 4f 3a 20 :print 1 "INFO:
7ac0: 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 65 Attempting to re
7ad0: 6d 6f 76 65 20 64 69 72 20 22 20 72 75 6e 2d 64 move dir " run-d
7ae0: 69 72 29 0a 09 09 09 20 28 69 66 20 28 61 6e 64 ir).... (if (and
7af0: 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 (> (string-leng
7b00: 74 68 20 72 75 6e 2d 64 69 72 29 20 35 29 0a 09 th run-dir) 5)..
7b10: 09 09 09 20 20 28 66 69 6c 65 2d 65 78 69 73 74 ... (file-exist
7b20: 73 3f 20 72 75 6e 2d 64 69 72 29 29 20 3b 3b 20 s? run-dir)) ;;
7b30: 62 61 64 20 68 65 75 72 69 73 74 69 63 20 62 75 bad heuristic bu
7b40: 74 20 73 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 t should prevent
7b50: 20 2f 74 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e /tmp /home etc.
7b60: 0a 09 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 .... (let* (
7b70: 28 72 65 61 6c 70 61 74 68 20 28 72 65 73 6f 6c (realpath (resol
7b80: 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d ve-pathname run-
7b90: 64 69 72 29 29 29 0a 09 09 09 20 20 20 20 20 20 dir)))....
7ba0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
7bb0: 22 49 4e 46 4f 3a 20 52 65 61 6c 20 70 61 74 68 "INFO: Real path
7bc0: 20 6f 66 20 69 73 20 22 20 72 65 61 6c 70 61 74 of is " realpat
7bd0: 68 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 h).... (if
7be0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 (file-exists? r
7bf0: 65 61 6c 70 61 74 68 29 0a 09 09 09 09 20 20 20 ealpath).....
7c00: 28 69 66 20 28 3e 20 28 73 79 73 74 65 6d 20 28 (if (> (system (
7c10: 63 6f 6e 63 20 22 72 6d 20 2d 72 66 20 22 20 72 conc "rm -rf " r
7c20: 65 61 6c 70 61 74 68 29 29 20 30 29 0a 09 09 09 ealpath)) 0)....
7c30: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
7c40: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 54 rint 0 "ERROR: T
7c50: 68 65 72 65 20 77 61 73 20 61 20 70 72 6f 62 6c here was a probl
7c60: 65 6d 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 em removing " re
7c70: 61 6c 70 61 74 68 20 22 20 77 69 74 68 20 72 6d alpath " with rm
7c80: 20 2d 66 22 29 29 0a 09 09 09 09 20 20 20 28 64 -f"))..... (d
7c90: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
7ca0: 52 4e 49 4e 47 3a 20 74 65 73 74 20 72 75 6e 20 RNING: test run
7cb0: 64 69 72 20 22 20 72 65 61 6c 70 61 74 68 20 22 dir " realpath "
7cc0: 20 61 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 20 appears to not
7cd0: 65 78 69 73 74 22 29 29 0a 09 09 09 20 20 20 20 exist"))....
7ce0: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
7cf0: 73 74 73 3f 20 72 75 6e 2d 64 69 72 29 20 3b 3b sts? run-dir) ;;
7d00: 20 74 68 65 20 6c 69 6e 6b 0a 09 09 09 09 20 20 the link.....
7d10: 20 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c (if (symbolic-l
7d20: 69 6e 6b 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 ink? run-dir)...
7d30: 09 09 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 .. (delete
7d40: 2d 66 69 6c 65 20 72 75 6e 2d 64 69 72 29 0a 09 -file run-dir)..
7d50: 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 64 ... (if (d
7d60: 69 72 65 63 74 6f 72 79 3f 20 72 75 6e 2d 64 69 irectory? run-di
7d70: 72 29 0a 09 09 09 09 09 20 20 20 28 69 66 20 28 r)...... (if (
7d80: 3e 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c > (directory-fol
7d90: 64 20 28 6c 61 6d 62 64 61 20 28 66 20 78 29 28 d (lambda (f x)(
7da0: 2b 20 31 20 78 29 29 20 30 20 72 75 6e 2d 64 69 + 1 x)) 0 run-di
7db0: 72 29 20 30 29 0a 09 09 09 09 09 20 20 20 20 20 r) 0)......
7dc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
7dd0: 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 73 "WARNING: refus
7de0: 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 ing to remove "
7df0: 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 run-dir " as it
7e00: 69 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a 09 is not empty")..
7e10: 09 09 09 09 20 20 20 20 20 20 20 28 64 65 6c 65 .... (dele
7e20: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 75 6e te-directory run
7e30: 2d 64 69 72 29 29 20 3b 3b 20 69 74 20 73 68 6f -dir)) ;; it sho
7e40: 75 6c 64 20 62 65 20 65 6d 70 74 79 20 62 79 20 uld be empty by
7e50: 68 65 72 65 20 42 55 47 20 42 55 47 2c 20 61 64 here BUG BUG, ad
7e60: 64 20 65 72 72 6f 72 20 63 61 74 63 68 0a 09 09 d error catch...
7e70: 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ... (debug:pri
7e80: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 72 65 66 nt 0 "ERROR: ref
7e90: 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 using to remove
7ea0: 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 69 " run-dir " as i
7eb0: 74 20 69 73 20 6e 65 69 74 68 65 72 20 61 20 73 t is neither a s
7ec0: 79 6d 6c 69 6e 6b 20 6e 6f 72 20 61 20 64 69 72 ymlink nor a dir
7ed0: 65 63 74 6f 72 79 22 29 0a 09 09 09 09 09 20 20 ectory")......
7ee0: 20 29 29 29 29 0a 09 09 09 20 20 20 20 20 28 64 )))).... (d
7ef0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
7f00: 52 4e 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 RNING: directory
7f10: 20 61 6c 72 65 61 64 79 20 72 65 6d 6f 76 65 64 already removed
7f20: 20 22 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 " run-dir)))...
7f30: 09 28 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 .((set-state-sta
7f40: 74 75 73 29 0a 09 09 09 20 28 64 65 62 75 67 3a tus).... (debug:
7f50: 70 72 69 6e 74 20 32 20 22 49 4e 46 4f 3a 20 6e print 2 "INFO: n
7f60: 65 77 20 73 74 61 74 65 20 22 20 28 63 61 72 20 ew state " (car
7f70: 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 2c state-status) ",
7f80: 20 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 63 new status " (c
7f90: 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 adr state-status
7fa0: 29 29 0a 09 09 09 20 28 64 62 3a 74 65 73 74 2d )).... (db:test-
7fb0: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
7fc0: 2d 62 79 2d 69 64 20 64 62 20 28 64 62 3a 74 65 -by-id db (db:te
7fd0: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
7fe0: 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 (car state-statu
7ff0: 73 29 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 s)(cadr state-st
8000: 61 74 75 73 29 20 23 66 29 29 29 29 29 0a 09 09 atus) #f)))))...
8010: 20 20 74 65 73 74 73 29 29 29 0a 09 20 20 20 0a tests))).. .
8020: 09 20 20 20 3b 3b 20 72 65 6d 6f 76 65 20 74 68 . ;; remove th
8030: 65 20 72 75 6e 20 69 66 20 7a 65 72 6f 20 74 65 e run if zero te
8040: 73 74 73 20 72 65 6d 61 69 6e 0a 09 20 20 20 28 sts remain.. (
8050: 69 66 20 28 65 71 3f 20 61 63 74 69 6f 6e 20 27 if (eq? action '
8060: 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 20 20 remove-runs)..
8070: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 (let ((remt
8080: 65 73 74 73 20 28 72 64 62 3a 67 65 74 2d 74 65 ests (rdb:get-te
8090: 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 28 sts-for-run db (
80a0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
80b0: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
80c0: 72 20 22 69 64 22 29 20 23 66 20 23 66 20 27 28 r "id") #f #f '(
80d0: 29 20 27 28 29 29 29 29 0a 09 09 20 28 69 66 20 ) '())))... (if
80e0: 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 (null? remtests)
80f0: 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 ;; no more test
8100: 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 s remaining...
8110: 20 20 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 (let* ((dpart
8120: 73 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 s (string-split
8130: 20 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 lasttpath "/"))
8140: 0a 09 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 .... (runpath
8150: 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
8160: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
8170: 09 09 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 ......(take dpar
8180: 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 ts (- (length dp
8190: 61 72 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 arts) 1)).......
81a0: 22 2f 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 "/"))))...
81b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
81c0: 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 "Removing run: "
81d0: 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a runkey " " (db:
81e0: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
81f0: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
8200: 72 75 6e 6e 61 6d 65 22 29 29 0a 09 09 20 20 20 runname"))...
8210: 20 20 20 20 28 64 62 3a 64 65 6c 65 74 65 2d 72 (db:delete-r
8220: 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 un db run-id)...
8230: 20 20 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 ;; need t
8240: 6f 20 66 69 67 75 72 65 20 6f 75 74 20 74 68 65 o figure out the
8250: 20 70 61 74 68 20 74 6f 20 74 68 65 20 72 75 6e path to the run
8260: 20 64 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 dir and remove
8270: 69 74 20 69 66 20 65 6d 70 74 79 0a 09 09 20 20 it if empty...
8280: 20 20 20 20 20 3b 3b 20 20 20 20 28 69 66 20 28 ;; (if (
8290: 6e 75 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e null? (glob (con
82a0: 63 20 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 c runpath "/*"))
82b0: 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 )... ;;
82c0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 (begin...
82d0: 20 20 20 20 20 3b 3b 20 09 20 28 64 65 62 75 67 ;; . (debug
82e0: 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 :print 1 "Removi
82f0: 6e 67 20 72 75 6e 20 64 69 72 20 22 20 72 75 6e ng run dir " run
8300: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 3b path)... ;
8310: 3b 20 09 20 28 73 79 73 74 65 6d 20 28 63 6f 6e ; . (system (con
8320: 63 20 22 72 6d 64 69 72 20 2d 70 20 22 20 72 75 c "rmdir -p " ru
8330: 6e 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 20 npath))))...
8340: 20 20 20 29 29 29 29 29 0a 09 20 29 29 0a 20 20 ))))).. )).
8350: 20 20 20 72 75 6e 73 29 29 29 0a 0a 3b 3b 3d 3d runs)))..;;==
8360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83a0: 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 ====.;; Routines
83b0: 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e for manipulatin
83c0: 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d g runs.;;=======
83d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8410: 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 .;; Since many c
8420: 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 alls to a run re
8430: 71 75 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 quire pretty muc
8440: 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 h the same setup
8450: 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 .;; this wrappe
8460: 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 r is used to red
8470: 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 uce the replicat
8480: 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 ion of code.(def
8490: 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e ine (general-run
84a0: 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 -call switchname
84b0: 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f action-desc pro
84c0: 63 29 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e c). (let ((runn
84d0: 61 6d 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ame (args:get-ar
84e0: 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 09 g ":runname"))..
84f0: 28 74 61 72 67 65 74 20 20 28 69 66 20 28 61 72 (target (if (ar
8500: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
8510: 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 get")... (ar
8520: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
8530: 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 get")... (ar
8540: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
8550: 74 61 72 67 22 29 29 29 0a 09 28 74 68 31 20 20 targ")))..(th1
8560: 20 20 20 23 66 29 29 0a 20 20 20 20 28 63 6f 6e #f)). (con
8570: 64 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 61 72 d. ((not tar
8580: 67 65 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 get). (debu
8590: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
85a0: 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 : Missing requir
85b0: 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 ed parameter for
85c0: 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c " switchname ",
85d0: 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 you must specif
85e0: 79 20 74 68 65 20 74 61 72 67 65 74 20 77 69 74 y the target wit
85f0: 68 20 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 h -target").
8600: 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 (exit 3)).
8610: 20 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 0a ((not runname).
8620: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
8630: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 nt 0 "ERROR: Mis
8640: 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 sing required pa
8650: 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 rameter for " sw
8660: 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 itchname ", you
8670: 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 68 65 must specify the
8680: 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a run name with :
8690: 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 runname runname"
86a0: 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 ). (exit 3)
86b0: 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 ). (else.
86c0: 20 20 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 (let ((db #
86d0: 66 29 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 f).. (keys #f
86e0: 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 ))..(if (not (se
86f0: 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 tup-for-run))..
8700: 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 (begin ..
8710: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
8720: 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 "Failed to setu
8730: 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 p, exiting")..
8740: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 (exit 1)))..
8750: 28 73 65 74 21 20 64 62 20 20 20 28 6f 70 65 6e (set! db (open
8760: 2d 64 62 29 29 0a 09 28 69 66 20 28 61 72 67 73 -db))..(if (args
8770: 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 :get-arg "-serve
8780: 72 22 29 0a 09 20 20 20 20 28 73 65 72 76 65 72 r").. (server
8790: 3a 73 74 61 72 74 20 64 62 20 28 61 72 67 73 3a :start db (args:
87a0: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
87b0: 22 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f ")).. (if (no
87c0: 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d t (or (args:get-
87d0: 61 72 67 20 22 2d 72 75 6e 61 6c 6c 22 29 0a 09 arg "-runall")..
87e0: 09 09 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 .. (args:get-ar
87f0: 67 20 22 2d 72 75 6e 74 65 73 74 73 22 29 29 29 g "-runtests")))
8800: 0a 09 09 28 73 65 72 76 65 72 3a 63 6c 69 65 6e ...(server:clien
8810: 74 2d 73 65 74 75 70 20 64 62 29 29 29 0a 09 28 t-setup db)))..(
8820: 73 65 74 21 20 6b 65 79 73 20 28 72 64 62 3a 67 set! keys (rdb:g
8830: 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 3b 3b et-keys db))..;;
8840: 20 68 61 76 65 20 65 6e 6f 75 67 68 20 74 6f 20 have enough to
8850: 70 72 6f 63 65 73 73 20 2d 74 61 72 67 65 74 20 process -target
8860: 6f 72 20 2d 72 65 71 74 61 72 67 20 68 65 72 65 or -reqtarg here
8870: 0a 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d ..(if (args:get-
8880: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a arg "-reqtarg").
8890: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 6e . (let* ((run
88a0: 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 20 2a configf (conc *
88b0: 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f toppath* "/runco
88c0: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 20 nfigs.config"))
88d0: 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 41 4c 55 41 ;; DO NOT EVALUA
88e0: 54 45 20 41 4c 4c 20 0a 09 09 20 20 20 28 72 75 TE ALL ... (ru
88f0: 6e 63 6f 6e 66 69 67 20 20 28 72 65 61 64 2d 63 nconfig (read-c
8900: 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 66 onfig runconfigf
8910: 20 23 66 20 23 66 20 65 6e 76 69 72 6f 6e 2d 70 #f #f environ-p
8920: 61 74 74 3a 20 23 66 29 29 29 20 0a 09 20 20 20 att: #f))) ..
8930: 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 (if (hash-tab
8940: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 72 le-ref/default r
8950: 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 3a 67 unconfig (args:g
8960: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
8970: 22 29 20 23 66 29 0a 09 09 20 20 28 6b 65 79 73 ") #f)... (keys
8980: 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 73 :target-set-args
8990: 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 2d keys (args:get-
89a0: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
89b0: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 0a 09 args:arg-hash)..
89c0: 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
89d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
89e0: 45 52 52 4f 52 3a 20 5b 22 20 28 61 72 67 73 3a ERROR: [" (args:
89f0: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
8a00: 67 22 29 20 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 g") "] not found
8a10: 20 69 6e 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 in " runconfigf
8a20: 29 0a 09 09 20 20 20 20 28 73 71 6c 69 74 65 33 )... (sqlite3
8a30: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 :finalize! db)..
8a40: 09 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 . (exit 1))))
8a50: 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 73 3a .. (if (args:
8a60: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
8a70: 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 65 ")...(keys:targe
8a80: 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 t-set-args keys
8a90: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8aa0: 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 72 67 target" args:arg
8ab0: 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 67 2d -hash) args:arg-
8ac0: 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 6e 6f hash)))..(if (no
8ad0: 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e t (car *configin
8ae0: 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 67 69 fo*)).. (begi
8af0: 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a n.. (debug:
8b00: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
8b10: 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 61 Attempted to " a
8b20: 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 ction-desc " but
8b30: 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 run area config
8b40: 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 file not found"
8b50: 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 31 ).. (exit 1
8b60: 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 61 )).. ;; Extra
8b70: 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 65 ct out stuff nee
8b80: 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d ded in most or m
8b90: 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b any calls.. ;
8ba0: 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c 6c ; here then call
8bb0: 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a proc.. (let*
8bc0: 20 28 28 6b 65 79 6e 61 6d 65 73 20 20 20 28 6d ((keynames (m
8bd0: 61 70 20 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 ap key:get-field
8be0: 6e 61 6d 65 20 6b 65 79 73 29 29 0a 09 09 20 20 name keys))...
8bf0: 20 28 6b 65 79 76 61 6c 6c 73 74 20 20 28 6b 65 (keyvallst (ke
8c00: 79 73 2d 3e 76 61 6c 6c 69 73 74 20 6b 65 79 73 ys->vallist keys
8c10: 20 23 74 29 29 29 0a 09 20 20 20 20 20 20 28 70 #t))).. (p
8c20: 72 6f 63 20 64 62 20 74 61 72 67 65 74 20 72 75 roc db target ru
8c30: 6e 6e 61 6d 65 20 6b 65 79 73 20 6b 65 79 6e 61 nname keys keyna
8c40: 6d 65 73 20 6b 65 79 76 61 6c 6c 73 74 29 29 29 mes keyvallst)))
8c50: 0a 09 28 69 66 20 74 68 31 20 28 74 68 72 65 61 ..(if th1 (threa
8c60: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 0a 09 28 d-join! th1))..(
8c70: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
8c80: 21 20 64 62 29 0a 09 28 73 65 74 21 20 2a 64 69 ! db)..(set! *di
8c90: 64 73 6f 6d 65 74 68 69 6e 67 2a 20 23 74 29 29 dsomething* #t))
8ca0: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
8cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b ==============.;
8cf0: 3b 20 4c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 72 75 ; Lock/unlock ru
8d00: 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ns.;;===========
8d10: 3d 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 0a 0a 28 64 65 ===========..(de
8d50: 66 69 6e 65 20 28 72 75 6e 73 3a 68 61 6e 64 6c fine (runs:handl
8d60: 65 2d 6c 6f 63 6b 69 6e 67 20 64 62 20 74 61 72 e-locking db tar
8d70: 67 65 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 get keys runname
8d80: 20 6c 6f 63 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 lock unlock use
8d90: 72 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 75 6e r). (let* ((run
8da0: 64 61 74 20 20 20 28 72 75 6e 73 3a 67 65 74 2d dat (runs:get-
8db0: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
8dc0: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 29 29 0a 09 keys runname))..
8dd0: 20 28 68 65 61 64 65 72 20 20 20 28 76 65 63 74 (header (vect
8de0: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 or-ref rundat 0)
8df0: 29 0a 09 20 28 72 75 6e 73 20 20 20 20 20 28 76 ).. (runs (v
8e00: 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 ector-ref rundat
8e10: 20 31 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 1))). (for-e
8e20: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 72 75 6e ach (lambda (run
8e30: 29 0a 09 09 28 6c 65 74 20 28 28 72 75 6e 2d 69 )...(let ((run-i
8e40: 64 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d d (db:get-value-
8e50: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
8e60: 61 64 65 72 20 22 69 64 22 29 29 29 0a 09 09 20 ader "id")))...
8e70: 20 28 69 66 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 (if (or lock...
8e80: 09 20 20 28 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 . (and unlock..
8e90: 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
8ea0: 09 09 09 09 20 28 70 72 69 6e 74 20 22 44 6f 20 .... (print "Do
8eb0: 79 6f 75 20 72 65 61 6c 6c 79 20 77 69 73 68 20 you really wish
8ec0: 74 6f 20 75 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 to unlock run "
8ed0: 72 75 6e 2d 69 64 20 22 3f 5c 6e 20 20 20 79 2f run-id "?\n y/
8ee0: 6e 3a 20 22 29 0a 09 09 09 09 20 28 65 71 75 61 n: ")..... (equa
8ef0: 6c 3f 20 22 79 22 20 28 72 65 61 64 2d 6c 69 6e l? "y" (read-lin
8f00: 65 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 28 e)))))... (
8f10: 64 62 3a 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 db:lock/unlock-r
8f20: 75 6e 20 64 62 20 72 75 6e 2d 69 64 20 6c 6f 63 un db run-id loc
8f30: 6b 20 75 6e 6c 6f 63 6b 20 75 73 65 72 29 0a 09 k unlock user)..
8f40: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
8f50: 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 53 6b 69 int 0 "INFO: Ski
8f60: 70 70 69 6e 67 20 6c 6f 63 6b 2f 75 6e 6c 6f 63 pping lock/unloc
8f70: 6b 20 6f 6e 20 22 20 72 75 6e 2d 69 64 29 29 29 k on " run-id)))
8f80: 29 0a 09 20 20 20 20 20 20 72 75 6e 73 29 29 29 ).. runs)))
8f90: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
8fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 6c =========.;; Rol
8fe0: 6c 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d lup runs.;;=====
8ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9030: 3d 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 68 65 =..;; Update the
9040: 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 test_meta table
9050: 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 0a 28 for this test.(
9060: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 64 define (runs:upd
9070: 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 ate-test_meta db
9080: 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
9090: 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 28 63 conf). (let ((c
90a0: 75 72 72 72 65 63 6f 72 64 20 28 64 62 3a 74 65 urrrecord (db:te
90b0: 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f 72 stmeta-get-recor
90c0: 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 29 d db test-name))
90d0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 ). (if (not c
90e0: 75 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 67 urrrecord)..(beg
90f0: 69 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 72 in.. (set! curr
9100: 72 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 63 record (make-vec
9110: 74 6f 72 20 31 30 20 23 66 29 29 0a 09 20 20 28 tor 10 #f)).. (
9120: 64 62 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 2d db:testmeta-add-
9130: 72 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d 6e record db test-n
9140: 61 6d 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d ame))). (for-
9150: 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
9160: 64 61 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 da (key).
9170: 28 6c 65 74 2a 20 28 28 69 64 78 20 28 63 61 64 (let* ((idx (cad
9180: 72 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 28 r key)).. (
9190: 66 6c 64 20 28 63 61 72 20 20 6b 65 79 29 29 0a fld (car key)).
91a0: 09 20 20 20 20 20 20 28 76 61 6c 20 28 63 6f 6e . (val (con
91b0: 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d fig-lookup test-
91c0: 63 6f 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 22 conf "test_meta"
91d0: 20 66 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 65 fld))).. ;; (de
91e0: 62 75 67 3a 70 72 69 6e 74 20 35 20 22 69 64 78 bug:print 5 "idx
91f0: 3a 20 22 20 69 64 78 20 22 20 66 6c 64 3a 20 22 : " idx " fld: "
9200: 20 66 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 61 fld " val: " va
9210: 6c 29 0a 09 20 28 69 66 20 28 61 6e 64 20 76 61 l).. (if (and va
9220: 6c 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 l (not (equal? (
9230: 76 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 72 vector-ref currr
9240: 65 63 6f 72 64 20 69 64 78 29 20 76 61 6c 29 29 ecord idx) val))
9250: 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ).. (begin..
9260: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 55 (print "U
9270: 70 64 61 74 69 6e 67 20 22 20 74 65 73 74 2d 6e pdating " test-n
9280: 61 6d 65 20 22 20 22 20 66 6c 64 20 22 20 74 6f ame " " fld " to
9290: 20 22 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 " val)..
92a0: 28 64 62 3a 74 65 73 74 6d 65 74 61 2d 75 70 64 (db:testmeta-upd
92b0: 61 74 65 2d 66 69 65 6c 64 20 64 62 20 74 65 73 ate-field db tes
92c0: 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 29 t-name fld val))
92d0: 29 29 29 0a 20 20 20 20 20 27 28 28 22 61 75 74 ))). '(("aut
92e0: 68 6f 72 22 20 32 29 28 22 6f 77 6e 65 72 22 20 hor" 2)("owner"
92f0: 33 29 28 22 64 65 73 63 72 69 70 74 69 6f 6e 22 3)("description"
9300: 20 34 29 28 22 72 65 76 69 65 77 65 64 22 20 35 4)("reviewed" 5
9310: 29 28 22 74 61 67 73 22 20 39 29 29 29 29 29 0a )("tags" 9))))).
9320: 0a 3b 3b 20 55 70 64 61 74 65 20 74 65 73 74 5f .;; Update test_
9330: 6d 65 74 61 20 66 6f 72 20 61 6c 6c 20 74 65 73 meta for all tes
9340: 74 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 ts.(define (runs
9350: 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 74 :update-all-test
9360: 5f 6d 65 74 61 20 64 62 29 0a 20 20 28 6c 65 74 _meta db). (let
9370: 20 28 28 74 65 73 74 2d 6e 61 6d 65 73 20 28 67 ((test-names (g
9380: 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 73 et-all-legal-tes
9390: 74 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 ts))). (for-e
93a0: 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 ach . (lambd
93b0: 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 a (test-name).
93c0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
93d0: 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 t-path (conc
93e0: 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 74 *toppath* "/test
93f0: 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 0a s/" test-name)).
9400: 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e . (test-con
9410: 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 2d figf (conc test-
9420: 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 69 path "/testconfi
9430: 67 22 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 g")).. (tes
9440: 74 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 28 texists (and (
9450: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 73 file-exists? tes
9460: 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 2d t-configf)(file-
9470: 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 73 read-access? tes
9480: 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 20 20 t-configf)))..
9490: 20 20 20 20 3b 3b 20 72 65 61 64 20 63 6f 6e 66 ;; read conf
94a0: 69 67 73 20 77 69 74 68 20 74 72 69 63 6b 73 20 igs with tricks
94b0: 74 75 72 6e 65 64 20 6f 66 66 20 28 69 2e 65 2e turned off (i.e.
94c0: 20 6e 6f 20 73 79 73 74 65 6d 29 0a 09 20 20 20 no system)..
94d0: 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 20 (test-conf
94e0: 20 28 69 66 20 74 65 73 74 65 78 69 73 74 73 20 (if testexists
94f0: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 73 (read-config tes
9500: 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 23 66 29 t-configf #f #f)
9510: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
9520: 29 29 29 29 0a 09 20 28 72 75 6e 73 3a 75 70 64 )))).. (runs:upd
9530: 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 ate-test_meta db
9540: 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d test-name test-
9550: 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 74 65 73 conf))). tes
9560: 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 54 t-names)))..;; T
9570: 68 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 61 62 his could probab
9580: 6c 79 20 62 65 20 72 65 66 61 63 74 6f 72 65 64 ly be refactored
9590: 20 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c 65 into one comple
95a0: 78 20 71 75 65 72 79 20 2e 2e 2e 0a 28 64 65 66 x query ....(def
95b0: 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 70 ine (runs:rollup
95c0: 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 -run db keys key
95d0: 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 75 vallst runname u
95e0: 73 65 72 29 20 3b 3b 20 77 61 73 20 74 61 72 67 ser) ;; was targ
95f0: 65 74 2c 20 6e 6f 77 20 6b 65 79 76 61 6c 6c 73 et, now keyvalls
9600: 74 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 t. (debug:print
9610: 20 34 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 2d 4 "runs:rollup-
9620: 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 79 run, keys: " key
9630: 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 22 s " keyvallst: "
9640: 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 3a 72 75 keyvallst " :ru
9650: 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 20 nname " runname
9660: 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 0a " user: " user).
9670: 20 20 28 6c 65 74 2a 20 28 3b 20 28 6b 65 79 76 (let* (; (keyv
9680: 61 6c 6c 6c 73 74 20 20 20 20 20 20 28 6b 65 79 alllst (key
9690: 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c s:target->keyval
96a0: 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 keys target))..
96b0: 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 20 (new-run-id
96c0: 20 20 28 72 75 6e 73 3a 72 65 67 69 73 74 65 72 (runs:register
96d0: 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 79 -run db keys key
96e0: 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 22 vallst runname "
96f0: 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 new" "n/a" user)
9700: 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 20 ).. (prev-tests
9710: 20 20 20 20 20 28 74 65 73 74 3a 67 65 74 2d 6d (test:get-m
9720: 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 73 atching-previous
9730: 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 64 -test-run-record
9740: 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 s db new-run-id
9750: 22 25 22 20 22 25 22 29 29 0a 09 20 28 63 75 72 "%" "%")).. (cur
9760: 72 2d 74 65 73 74 73 20 20 20 20 20 20 28 72 64 r-tests (rd
9770: 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d b:get-tests-for-
9780: 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 run db new-run-i
9790: 64 20 22 25 22 20 22 25 22 20 27 28 29 20 27 28 d "%" "%" '() '(
97a0: 29 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 ))).. (curr-test
97b0: 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 s-hash (make-has
97c0: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 h-table))). (
97d0: 64 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 db:update-run-ev
97e0: 65 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 2d ent_time db new-
97f0: 72 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 69 run-id). ;; i
9800: 6e 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 ndex the already
9810: 20 73 61 76 65 64 20 74 65 73 74 73 20 62 79 20 saved tests by
9820: 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 testname and ite
9830: 6d 64 61 74 20 69 6e 20 63 75 72 72 2d 74 65 73 mdat in curr-tes
9840: 74 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f 72 ts-hash. (for
9850: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
9860: 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 da (testdat).
9870: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
9880: 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 name (db:test-g
9890: 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 et-testname test
98a0: 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 dat)).. (it
98b0: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
98c0: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
98d0: 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 estdat))..
98e0: 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 (full-name (conc
98f0: 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
9900: 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 61 em-path))).. (ha
9910: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 sh-table-set! cu
9920: 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 rr-tests-hash fu
9930: 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 29 ll-name testdat)
9940: 29 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 73 )). curr-tes
9950: 74 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 3a ts). ;; NOPE:
9960: 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 70 Non-optimal app
9970: 72 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 20 roach. Try this
9980: 69 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b 20 instead.. ;;
9990: 20 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 72 1. tests are r
99a0: 65 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 73 eceived in a lis
99b0: 74 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 66 t, most recent f
99c0: 69 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 2e irst. ;; 2.
99d0: 20 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f 6c replace the rol
99e0: 6c 75 70 20 74 65 73 74 20 77 69 74 68 20 74 68 lup test with th
99f0: 65 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a 20 e new *always*.
9a00: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
9a10: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 (lambda (test
9a20: 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 dat). (let
9a30: 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 * ((testname (d
9a40: 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e b:test-get-testn
9a50: 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 ame testdat))..
9a60: 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 (item-path
9a70: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
9a80: 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 29 m-path testdat))
9a90: 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 .. (full-na
9aa0: 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d me (conc testnam
9ab0: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
9ac0: 29 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d 74 ).. (prev-t
9ad0: 65 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 61 est-dat (hash-ta
9ae0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
9af0: 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 curr-tests-hash
9b00: 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a 09 full-name #f))..
9b10: 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 (test-step
9b20: 73 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 73 s (db:get-s
9b30: 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 62 teps-for-test db
9b40: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
9b50: 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 20 testdat)))..
9b60: 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 (new-test-rec
9b70: 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 65 ord #f)).. ;; re
9b80: 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 68 place these with
9b90: 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c 65 insert ... sele
9ba0: 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c 69 ct.. (apply sqli
9bb0: 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 64 te3:execute ...d
9bc0: 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 45 b ...(conc "INSE
9bd0: 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e RT OR REPLACE IN
9be0: 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 64 TO tests (run_id
9bf0: 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 2c ,testname,state,
9c00: 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d status,event_tim
9c10: 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c 64 e,host,cpuload,d
9c20: 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 75 iskfree,uname,ru
9c30: 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c 72 ndir,item_path,r
9c40: 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e 61 un_duration,fina
9c50: 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 l_logf,comment)
9c60: 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 45 "... "VALUE
9c70: 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f S (?,?,?,?,?,?,?
9c80: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b ,?,?,?,?,?,?,?);
9c90: 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 20 ")...new-run-id
9ca0: 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e 6c (cddr (vector->l
9cb0: 69 73 74 20 74 65 73 74 64 61 74 29 29 29 0a 09 ist testdat)))..
9cc0: 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 64 (set! new-testd
9cd0: 61 74 20 28 63 61 72 20 28 72 64 62 3a 67 65 74 at (car (rdb:get
9ce0: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 -tests-for-run d
9cf0: 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 74 65 73 b new-run-id tes
9d00: 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 tname item-path
9d10: 27 28 29 20 27 28 29 29 29 29 0a 09 20 28 68 61 '() '()))).. (ha
9d20: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 sh-table-set! cu
9d30: 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 rr-tests-hash fu
9d40: 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 65 73 74 ll-name new-test
9d50: 64 61 74 29 20 3b 3b 20 74 68 69 73 20 63 6f 75 dat) ;; this cou
9d60: 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 6e 67 2c ld be confusing,
9d70: 20 77 68 69 63 68 20 72 65 63 6f 72 64 20 73 68 which record sh
9d80: 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 74 68 65 ould go into the
9d90: 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 3f 0a 09 lookup table?..
9da0: 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 ;; Now duplicat
9db0: 65 20 74 68 65 20 74 65 73 74 20 73 74 65 70 73 e the test steps
9dc0: 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
9dd0: 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 4 "Copying recor
9de0: 64 73 20 69 6e 20 74 65 73 74 5f 73 74 65 70 73 ds in test_steps
9df0: 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 from test_id="
9e00: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
9e10: 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 testdat) " to "
9e20: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
9e30: 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 new-testdat))..
9e40: 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 (sqlite3:execute
9e50: 20 0a 09 20 20 64 62 20 0a 09 20 20 28 63 6f 6e .. db .. (con
9e60: 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 c "INSERT OR REP
9e70: 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 LACE INTO test_s
9e80: 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 teps (test_id,st
9e90: 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 epname,state,sta
9ea0: 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 tus,event_time,c
9eb0: 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 22 53 45 4c omment) "..."SEL
9ec0: 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d 67 ECT " (db:test-g
9ed0: 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 et-id new-testda
9ee0: 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 74 t) ",stepname,st
9ef0: 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 ate,status,event
9f00: 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 52 _time,comment FR
9f10: 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 48 OM test_steps WH
9f20: 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 ERE test_id=?;")
9f30: 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 .. (db:test-get
9f40: 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 09 20 -id testdat))..
9f50: 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 65 ;; Now duplicate
9f60: 20 74 68 65 20 74 65 73 74 20 64 61 74 61 0a 09 the test data..
9f70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
9f80: 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 73 "Copying records
9f90: 20 69 6e 20 74 65 73 74 5f 64 61 74 61 20 66 72 in test_data fr
9fa0: 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 62 om test_id=" (db
9fb0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
9fc0: 74 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 62 tdat) " to " (db
9fd0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 :test-get-id new
9fe0: 2d 74 65 73 74 64 61 74 29 29 0a 09 20 28 73 71 -testdat)).. (sq
9ff0: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 lite3:execute ..
a000: 20 20 64 62 20 0a 09 20 20 28 63 6f 6e 63 20 22 db .. (conc "
a010: 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 INSERT OR REPLAC
a020: 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 74 61 E INTO test_data
a030: 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 67 6f (test_id,catego
a040: 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c 75 ry,variable,valu
a050: 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c 75 e,expected,tol,u
a060: 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a nits,comment) ".
a070: 09 09 22 53 45 4c 45 43 54 20 22 20 28 64 62 3a .."SELECT " (db:
a080: 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 2d test-get-id new-
a090: 74 65 73 74 64 61 74 29 20 22 2c 63 61 74 65 67 testdat) ",categ
a0a0: 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c ory,variable,val
a0b0: 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c ue,expected,tol,
a0c0: 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 20 46 52 units,comment FR
a0d0: 4f 4d 20 74 65 73 74 5f 64 61 74 61 20 57 48 45 OM test_data WHE
a0e0: 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 0a RE test_id=?;").
a0f0: 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d . (db:test-get-
a100: 69 64 20 74 65 73 74 64 61 74 29 29 0a 09 20 29 id testdat)).. )
a110: 29 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 74 ). prev-test
a120: 73 29 29 29 0a 09 20 0a 20 20 20 20 20 0a s))).. . .