0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 69 dot-locking (
01c0: 73 72 66 69 20 31 38 29 20 70 6f 73 69 78 2d 65 srfi 18) posix-e
01d0: 78 74 72 61 73 20 64 69 72 65 63 74 6f 72 79 2d xtras directory-
01e0: 75 74 69 6c 73 29 0a 28 69 6d 70 6f 72 74 20 28 utils).(import (
01f0: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0200: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
0210: 61 72 65 20 28 75 6e 69 74 20 72 75 6e 73 29 29 are (unit runs))
0220: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0230: 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 db)).(declare (u
0240: 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 ses common)).(de
0250: 63 6c 61 72 65 20 28 75 73 65 73 20 69 74 65 6d clare (uses item
0260: 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 s)).(declare (us
0270: 65 73 20 72 75 6e 63 6f 6e 66 69 67 29 29 0a 28 es runconfig)).(
0280: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 74 65 declare (uses te
0290: 73 74 73 29 29 0a 28 64 65 63 6c 61 72 65 20 28 sts)).(declare (
02a0: 75 73 65 73 20 73 65 72 76 65 72 29 29 0a 0a 28 uses server))..(
02b0: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
02c0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
02d0: 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f nclude "key_reco
02e0: 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 rds.scm").(inclu
02f0: 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 de "db_records.s
0300: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 cm").(include "r
0310: 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 un_records.scm")
0320: 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f .(include "test_
0330: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b records.scm")..;
0340: 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d ; runs:get-runs-
0350: 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 72 by-patt.;; get r
0360: 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 63 uns by list of c
0370: 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 73 riteria.;; regis
0380: 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 77 ter a test run w
0390: 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b 3b ith the db.;;.;;
03a0: 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 61 Use: (db-get-va
03b0: 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 64 lue-by-header (d
03c0: 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 6e b:get-header run
03d0: 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f 77 info)(db:get-row
03e0: 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 20 74 runinfo)).;; t
03f0: 6f 20 65 78 74 72 61 63 74 20 69 6e 66 6f 20 66 o extract info f
0400: 72 6f 6d 20 74 68 65 20 73 74 72 75 63 74 75 72 rom the structur
0410: 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a 28 64 e returned.;;.(d
0420: 65 66 69 6e 65 20 28 72 75 6e 73 3a 67 65 74 2d efine (runs:get-
0430: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 64 62 20 runs-by-patt db
0440: 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 keys runnamepatt
0450: 20 74 61 72 67 70 61 74 74 29 20 3b 3b 20 74 65 targpatt) ;; 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 74 6d 70 20 20 20 20 20 20 28 72 75 6e ((tmp (run
0480: 73 3a 67 65 74 2d 73 74 64 2d 72 75 6e 2d 66 69 s:get-std-run-fi
0490: 65 6c 64 73 20 6b 65 79 73 20 27 28 22 69 64 22 elds keys '("id"
04a0: 20 22 72 75 6e 6e 61 6d 65 22 20 22 73 74 61 74 "runname" "stat
04b0: 65 22 20 22 73 74 61 74 75 73 22 20 22 6f 77 6e e" "status" "own
04c0: 65 72 22 20 22 65 76 65 6e 74 5f 74 69 6d 65 22 er" "event_time"
04d0: 29 29 29 0a 09 20 28 6b 65 79 73 74 72 20 20 20 ))).. (keystr
04e0: 28 63 61 72 20 74 6d 70 29 29 0a 09 20 28 68 65 (car tmp)).. (he
04f0: 61 64 65 72 20 20 20 28 63 61 64 72 20 74 6d 70 ader (cadr tmp
0500: 29 29 0a 09 20 28 72 65 73 20 20 20 20 20 27 28 )).. (res '(
0510: 29 29 0a 09 20 28 6b 65 79 2d 70 61 74 74 20 22 )).. (key-patt "
0520: 22 29 0a 09 20 28 72 75 6e 77 69 6c 64 74 79 70 ").. (runwildtyp
0530: 65 20 28 69 66 20 28 73 75 62 73 74 72 69 6e 67 e (if (substring
0540: 2d 69 6e 64 65 78 20 22 25 22 20 72 75 6e 6e 61 -index "%" runna
0550: 6d 65 70 61 74 74 29 20 22 6c 69 6b 65 22 20 22 mepatt) "like" "
0560: 67 6c 6f 62 22 29 29 0a 09 20 28 71 72 79 2d 73 glob")).. (qry-s
0570: 74 72 20 20 23 66 29 0a 09 20 28 6b 65 79 76 61 tr #f).. (keyva
0580: 6c 73 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 ls (keys:target
0590: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
05a0: 72 67 70 61 74 74 29 29 29 0a 20 20 20 20 28 66 rgpatt))). (f
05b0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
05c0: 28 6b 65 79 76 61 6c 29 0a 09 09 28 6c 65 74 2a (keyval)...(let*
05d0: 20 28 28 6b 65 79 20 20 20 20 28 63 61 72 20 6b ((key (car k
05e0: 65 79 76 61 6c 29 29 0a 09 09 20 20 20 20 20 20 eyval))...
05f0: 20 28 70 61 74 74 20 20 20 28 63 61 64 72 20 6b (patt (cadr k
0600: 65 79 76 61 6c 29 29 0a 09 09 20 20 20 20 20 20 eyval))...
0610: 20 28 66 75 6c 6b 65 79 20 28 63 6f 6e 63 20 22 (fulkey (conc "
0620: 3a 22 20 6b 65 79 29 29 0a 09 09 20 20 20 20 20 :" key))...
0630: 20 20 28 77 69 6c 64 74 79 70 65 20 28 69 66 20 (wildtype (if
0640: 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 78 (substring-index
0650: 20 22 25 22 20 70 61 74 74 29 20 22 6c 69 6b 65 "%" patt) "like
0660: 22 20 22 67 6c 6f 62 22 29 29 29 0a 09 09 20 20 " "glob")))...
0670: 28 69 66 20 70 61 74 74 0a 09 09 20 20 20 20 20 (if patt...
0680: 20 28 73 65 74 21 20 6b 65 79 2d 70 61 74 74 20 (set! key-patt
0690: 28 63 6f 6e 63 20 6b 65 79 2d 70 61 74 74 20 22 (conc key-patt "
06a0: 20 41 4e 44 20 22 20 6b 65 79 20 22 20 22 20 77 AND " key " " w
06b0: 69 6c 64 74 79 70 65 20 22 20 27 22 20 70 61 74 ildtype " '" pat
06c0: 74 20 22 27 22 29 29 0a 09 09 20 20 20 20 20 20 t "'"))...
06d0: 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 67 (begin....(debug
06e0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
06f0: 20 73 65 61 72 63 68 69 6e 67 20 66 6f 72 20 72 searching for r
0700: 75 6e 73 20 77 69 74 68 20 6e 6f 20 70 61 74 74 uns with no patt
0710: 65 72 6e 20 73 65 74 20 66 6f 72 20 22 20 66 75 ern set for " fu
0720: 6c 6b 65 79 29 0a 09 09 09 28 65 78 69 74 20 36 lkey)....(exit 6
0730: 29 29 29 29 29 0a 09 20 20 20 20 20 20 6b 65 79 ))))).. key
0740: 76 61 6c 73 29 0a 20 20 20 20 28 73 65 74 21 20 vals). (set!
0750: 71 72 79 2d 73 74 72 20 28 63 6f 6e 63 20 22 53 qry-str (conc "S
0760: 45 4c 45 43 54 20 22 20 6b 65 79 73 74 72 20 22 ELECT " keystr "
0770: 20 46 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 FROM runs WHERE
0780: 20 72 75 6e 6e 61 6d 65 20 22 20 72 75 6e 77 69 runname " runwi
0790: 6c 64 74 79 70 65 20 22 20 3f 20 22 20 6b 65 79 ldtype " ? " key
07a0: 2d 70 61 74 74 20 22 3b 22 29 29 0a 20 20 20 20 -patt ";")).
07b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
07c0: 6f 20 34 20 22 72 75 6e 73 3a 67 65 74 2d 72 75 o 4 "runs:get-ru
07d0: 6e 73 2d 62 79 2d 70 61 74 74 20 71 72 79 3d 22 ns-by-patt qry="
07e0: 20 71 72 79 2d 73 74 72 20 22 20 22 20 72 75 6e qry-str " " run
07f0: 6e 61 6d 65 70 61 74 74 29 0a 20 20 20 20 28 73 namepatt). (s
0800: 71 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d qlite3:for-each-
0810: 72 6f 77 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 row . (lambd
0820: 61 20 28 61 20 2e 20 72 29 0a 20 20 20 20 20 20 a (a . r).
0830: 20 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 (set! res (cons
0840: 20 28 6c 69 73 74 2d 3e 76 65 63 74 6f 72 20 28 (list->vector (
0850: 63 6f 6e 73 20 61 20 72 29 29 20 72 65 73 29 29 cons a r)) res))
0860: 29 0a 20 20 20 20 20 64 62 20 0a 20 20 20 20 20 ). db .
0870: 71 72 79 2d 73 74 72 0a 20 20 20 20 20 72 75 6e qry-str. run
0880: 6e 61 6d 65 70 61 74 74 29 0a 20 20 20 20 28 76 namepatt). (v
0890: 65 63 74 6f 72 20 68 65 61 64 65 72 20 72 65 73 ector header res
08a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
08b0: 6e 73 3a 74 65 73 74 2d 67 65 74 2d 66 75 6c 6c ns:test-get-full
08c0: 2d 70 61 74 68 20 74 65 73 74 29 0a 20 20 28 6c -path test). (l
08d0: 65 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 28 et* ((testname (
08e0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
08f0: 6e 61 6d 65 20 20 20 74 65 73 74 29 29 0a 09 20 name test))..
0900: 28 69 74 65 6d 70 61 74 68 20 28 64 62 3a 74 65 (itempath (db:te
0910: 73 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 st-get-item-path
0920: 20 74 65 73 74 29 29 29 0a 20 20 20 20 28 63 6f test))). (co
0930: 6e 63 20 74 65 73 74 6e 61 6d 65 20 28 69 66 20 nc testname (if
0940: 28 65 71 75 61 6c 3f 20 69 74 65 6d 70 61 74 68 (equal? itempath
0950: 20 22 22 29 20 22 22 20 28 63 6f 6e 63 20 22 28 "") "" (conc "(
0960: 22 20 69 74 65 6d 70 61 74 68 20 22 29 22 29 29 " itempath ")"))
0970: 29 29 29 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 )))..;; This is
0980: 74 68 65 20 2a 6e 65 77 2a 20 6d 65 74 68 6f 64 the *new* method
0990: 6f 6c 6f 67 79 2e 20 4f 6e 65 20 72 65 63 6f 72 ology. One recor
09a0: 64 20 74 6f 20 69 6e 66 6f 72 6d 20 74 68 65 6d d to inform them
09b0: 20 61 6e 64 20 69 6e 20 74 68 65 20 63 68 61 6f and in the chao
09c0: 73 2c 20 6f 72 67 61 6e 69 73 65 20 74 68 65 6d s, organise them
09d0: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 75 ..;;.(define (ru
09e0: 6e 73 3a 63 72 65 61 74 65 2d 72 75 6e 2d 72 65 ns:create-run-re
09f0: 63 6f 72 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 cord). (let* ((
0a00: 6d 63 6f 6e 66 69 67 20 20 20 20 20 20 28 69 66 mconfig (if
0a10: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 09 20 *configdat*...
0a20: 20 20 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 *confi
0a30: 67 64 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 gdat*...
0a40: 20 20 20 28 69 66 20 28 73 65 74 75 70 2d 66 6f (if (setup-fo
0a50: 72 2d 72 75 6e 29 0a 09 09 20 20 20 20 20 20 20 r-run)...
0a60: 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 64 *configd
0a70: 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 20 20 at*...
0a80: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 (begin...
0a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0aa0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
0ab0: 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 73 65 74 RROR: Called set
0ac0: 75 70 20 69 6e 20 61 20 6e 6f 6e 2d 6d 65 67 61 up in a non-mega
0ad0: 74 65 73 74 20 61 72 65 61 2c 20 65 78 69 74 69 test area, exiti
0ae0: 6e 67 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 ng")...
0af0: 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 (exit 1)
0b00: 29 29 29 29 0a 09 20 20 28 72 75 6e 72 65 63 20 )))).. (runrec
0b10: 20 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 72 65 (runs:runre
0b20: 63 2d 6d 61 6b 65 2d 72 65 63 6f 72 64 29 29 0a c-make-record)).
0b30: 09 20 20 28 74 61 72 67 65 74 20 20 20 20 20 20 . (target
0b40: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
0b50: 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 g "-reqtarg")...
0b60: 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 73 (args
0b70: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
0b80: 74 22 29 29 29 0a 09 20 20 28 72 75 6e 6e 61 6d t"))).. (runnam
0b90: 65 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a e (or (args:
0ba0: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
0bb0: 65 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 e")...
0bc0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
0bd0: 2d 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 20 20 -runname")))..
0be0: 28 74 65 73 74 70 61 74 74 20 20 20 20 28 6f 72 (testpatt (or
0bf0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
0c00: 2d 74 65 73 74 70 61 74 74 22 29 0a 09 09 20 20 -testpatt")...
0c10: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 (args:g
0c20: 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 et-arg "-runtest
0c30: 73 22 29 29 29 0a 09 20 20 28 6b 65 79 73 20 20 s"))).. (keys
0c40: 20 20 20 20 20 20 28 6b 65 79 73 3a 63 6f 6e 66 (keys:conf
0c50: 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 6d 63 ig-get-fields mc
0c60: 6f 6e 66 69 67 29 29 0a 09 20 20 28 6b 65 79 76 onfig)).. (keyv
0c70: 61 6c 73 20 20 20 20 20 28 6b 65 79 73 3a 74 61 als (keys:ta
0c80: 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 rget->keyval key
0c90: 73 20 74 61 72 67 65 74 29 29 0a 09 20 20 28 74 s target)).. (t
0ca0: 6f 70 70 61 74 68 20 20 20 20 20 2a 74 6f 70 70 oppath *topp
0cb0: 61 74 68 2a 29 0a 09 20 20 28 65 6e 76 64 61 74 ath*).. (envdat
0cc0: 20 20 20 20 20 20 6b 65 79 76 61 6c 73 29 20 3b keyvals) ;
0cd0: 3b 20 69 6e 69 74 69 61 6c 20 76 61 6c 75 65 73 ; initial values
0ce0: 20 73 74 61 72 74 20 77 69 74 68 20 6b 65 79 76 start with keyv
0cf0: 61 6c 73 0a 09 20 20 28 72 75 6e 63 6f 6e 66 69 als.. (runconfi
0d00: 67 20 20 20 23 66 29 0a 09 20 20 28 73 65 72 76 g #f).. (serv
0d10: 65 72 64 61 74 20 20 20 28 69 66 20 28 61 72 67 erdat (if (arg
0d20: 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 s:get-arg "-serv
0d30: 65 72 22 29 0a 09 09 09 20 20 20 2a 72 75 6e 72 er").... *runr
0d40: 65 6d 6f 74 65 2a 0a 09 09 09 20 20 20 23 66 29 emote*.... #f)
0d50: 29 20 3b 3b 20 74 6f 20 62 65 20 75 73 65 64 20 ) ;; to be used
0d60: 6c 61 74 65 72 0a 09 20 20 28 74 72 61 6e 73 70 later.. (transp
0d70: 6f 72 74 20 20 20 28 6f 72 20 28 61 72 67 73 3a ort (or (args:
0d80: 67 65 74 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 get-arg "-transp
0d90: 6f 72 74 22 29 20 27 68 74 74 70 29 29 0a 09 20 ort") 'http))..
0da0: 20 28 64 62 20 20 20 20 20 20 20 20 20 20 28 69 (db (i
0db0: 66 20 28 61 6e 64 20 6d 63 6f 6e 66 69 67 0a 09 f (and mconfig..
0dc0: 09 09 09 28 6f 72 20 28 61 72 67 73 3a 67 65 74 ...(or (args:get
0dd0: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 0a -arg "-server").
0de0: 09 09 09 09 20 20 20 20 28 65 71 3f 20 74 72 61 .... (eq? tra
0df0: 6e 73 70 6f 72 74 20 27 66 73 29 29 29 0a 09 09 nsport 'fs)))...
0e00: 09 20 20 20 28 6f 70 65 6e 2d 64 62 29 0a 09 09 . (open-db)...
0e10: 09 20 20 20 23 66 29 29 0a 09 20 20 28 72 75 6e . #f)).. (run
0e20: 2d 69 64 20 20 20 20 20 20 23 66 29 29 0a 20 20 -id #f)).
0e30: 20 20 3b 3b 20 53 65 74 20 61 6c 6c 20 74 68 65 ;; Set all the
0e40: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 environment var
0e50: 73 20 77 65 20 6b 6e 6f 77 20 73 6f 20 66 61 72 s we know so far
0e60: 2c 20 73 74 61 72 74 20 77 69 74 68 20 6b 65 79 , start with key
0e70: 73 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 s. (for-each
0e80: 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 (lambda (keyval)
0e90: 0a 09 09 28 73 65 74 65 6e 76 20 28 63 61 72 20 ...(setenv (car
0ea0: 6b 65 79 76 61 6c 29 28 63 61 64 72 20 6b 65 79 keyval)(cadr key
0eb0: 76 61 6c 29 29 29 0a 09 20 20 20 20 20 20 6b 65 val))).. ke
0ec0: 79 76 61 6c 73 29 0a 20 20 20 20 3b 3b 20 53 65 yvals). ;; Se
0ed0: 74 20 75 70 20 76 61 72 69 6f 75 73 20 61 6e 64 t up various and
0ee0: 20 73 75 6e 64 72 79 20 6b 6e 6f 77 6e 20 76 61 sundry known va
0ef0: 72 73 20 68 65 72 65 0a 20 20 20 20 28 73 65 74 rs here. (set
0f00: 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 env "MT_RUN_AREA
0f10: 5f 48 4f 4d 45 22 20 74 6f 70 70 61 74 68 29 0a _HOME" toppath).
0f20: 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f (setenv "MT_
0f30: 52 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d 65 RUNNAME" runname
0f40: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d ). (setenv "M
0f50: 54 5f 54 41 52 47 45 54 22 20 20 74 61 72 67 65 T_TARGET" targe
0f60: 74 29 0a 20 20 20 20 28 73 65 74 21 20 65 6e 76 t). (set! env
0f70: 64 61 74 20 28 61 70 70 65 6e 64 20 0a 09 09 20 dat (append ...
0f80: 20 65 6e 76 64 61 74 0a 09 09 20 20 28 6c 69 73 envdat... (lis
0f90: 74 20 28 6c 69 73 74 20 22 4d 54 5f 52 55 4e 5f t (list "MT_RUN_
0fa0: 41 52 45 41 5f 48 4f 4d 45 22 20 74 6f 70 70 61 AREA_HOME" toppa
0fb0: 74 68 29 0a 09 09 09 28 6c 69 73 74 20 22 4d 54 th)....(list "MT
0fc0: 5f 52 55 4e 4e 41 4d 45 22 20 20 20 20 20 20 20 _RUNNAME"
0fd0: 72 75 6e 6e 61 6d 65 29 0a 09 09 09 28 6c 69 73 runname)....(lis
0fe0: 74 20 22 4d 54 5f 54 41 52 47 45 54 22 20 20 20 t "MT_TARGET"
0ff0: 20 20 20 20 20 74 61 72 67 65 74 29 29 29 29 0a target)))).
1000: 20 20 20 20 3b 3b 20 4e 6f 77 20 63 61 6e 20 72 ;; Now can r
1010: 65 61 64 20 74 68 65 20 72 75 6e 63 6f 6e 66 69 ead the runconfi
1020: 67 73 20 66 69 6c 65 0a 20 20 20 20 3b 3b 20 0a gs file. ;; .
1030: 20 20 20 20 28 73 65 74 21 20 72 75 6e 63 6f 6e (set! runcon
1040: 66 69 67 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 fig (read-config
1050: 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 (conc *toppath
1060: 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 * "/runconfigs.c
1070: 6f 6e 66 69 67 22 29 20 23 66 20 23 74 20 73 65 onfig") #f #t se
1080: 63 74 69 6f 6e 73 3a 20 28 6c 69 73 74 20 22 64 ctions: (list "d
1090: 65 66 61 75 6c 74 22 20 74 61 72 67 65 74 29 29 efault" target))
10a0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
10b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
10c0: 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 67 efault runconfig
10d0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
10e0: 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 29 0a -reqtarg") #f)).
10f0: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
1100: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
1110: 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 : [" (args:get-a
1120: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 rg "-reqtarg") "
1130: 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 ] not found in "
1140: 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 20 20 runconfigf)..
1150: 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
1160: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
1170: 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 20 (exit 1))).
1180: 20 3b 3b 20 4e 6f 77 20 68 61 76 65 20 72 75 6e ;; Now have run
1190: 63 6f 6e 66 69 67 73 20 64 61 74 61 20 6c 6f 61 configs data loa
11a0: 64 65 64 2c 20 73 65 74 20 65 6e 76 69 72 6f 6e ded, set environ
11b0: 6d 65 6e 74 20 76 61 72 73 0a 20 20 20 20 28 66 ment vars. (f
11c0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
11d0: 28 73 65 63 74 69 6f 6e 29 0a 09 09 28 66 6f 72 (section)...(for
11e0: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 -each (lambda (v
11f0: 61 72 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 arval).... (s
1200: 65 74 21 20 65 6e 76 64 61 74 20 28 61 70 70 65 et! envdat (appe
1210: 6e 64 20 65 6e 76 64 61 74 20 28 6c 69 73 74 20 nd envdat (list
1220: 76 61 72 76 61 6c 29 29 29 0a 09 09 09 20 20 20 varval)))....
1230: 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 76 61 (setenv (car va
1240: 72 76 61 6c 29 28 63 61 64 72 20 76 61 72 76 61 rval)(cadr varva
1250: 6c 29 29 29 0a 09 09 09 20 20 28 63 6f 6e 66 69 l))).... (confi
1260: 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 72 gf:get-section r
1270: 75 6e 63 6f 6e 66 69 67 20 73 65 63 74 69 6f 6e unconfig section
1280: 29 29 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 ))).. (list
1290: 20 22 64 65 66 61 75 6c 74 22 20 74 61 72 67 65 "default" targe
12a0: 74 29 29 0a 20 20 20 20 28 76 65 63 74 6f 72 20 t)). (vector
12b0: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 74 target runname t
12c0: 65 73 74 70 61 74 74 20 6b 65 79 73 20 6b 65 79 estpatt keys key
12d0: 76 61 6c 73 20 65 6e 76 64 61 74 20 6d 63 6f 6e vals envdat mcon
12e0: 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 20 73 65 fig runconfig se
12f0: 72 76 65 72 64 61 74 20 74 72 61 6e 73 70 6f 72 rverdat transpor
1300: 74 20 64 62 20 74 6f 70 70 61 74 68 20 72 75 6e t db toppath run
1310: 2d 69 64 29 29 29 0a 0a 09 20 0a 28 64 65 66 69 -id)))... .(defi
1320: 6e 65 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 ne (set-megatest
1330: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
1340: 20 23 21 6b 65 79 20 28 69 6e 6b 65 79 73 20 23 #!key (inkeys #
1350: 66 29 28 69 6e 72 75 6e 6e 61 6d 65 20 23 66 29 f)(inrunname #f)
1360: 28 69 6e 6b 65 79 76 61 6c 73 20 23 66 29 29 0a (inkeyvals #f)).
1370: 20 20 28 6c 65 74 2a 20 28 28 74 61 72 67 65 74 (let* ((target
1380: 20 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 3a (or (args:
1390: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
13a0: 67 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 20 g")...
13b0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
13c0: 2d 74 61 72 67 65 74 22 29 29 29 0a 09 20 28 6b -target"))).. (k
13d0: 65 79 73 20 20 20 20 28 69 66 20 69 6e 6b 65 79 eys (if inkey
13e0: 73 20 20 20 20 69 6e 6b 65 79 73 20 20 20 20 28 s inkeys (
13f0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
1400: 62 3a 67 65 74 2d 6b 65 79 73 20 23 66 29 29 29 b:get-keys #f)))
1410: 0a 09 20 28 6b 65 79 76 61 6c 73 20 28 69 66 20 .. (keyvals (if
1420: 69 6e 6b 65 79 76 61 6c 73 20 69 6e 6b 65 79 76 inkeyvals inkeyv
1430: 61 6c 73 20 28 6b 65 79 73 3a 74 61 72 67 65 74 als (keys:target
1440: 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 ->keyval keys ta
1450: 72 67 65 74 29 29 29 0a 09 20 28 76 61 6c 73 20 rget))).. (vals
1460: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
1470: 64 65 66 61 75 6c 74 20 2a 65 6e 76 2d 76 61 72 default *env-var
1480: 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 6e s-by-run-id* run
1490: 2d 69 64 20 23 66 29 29 29 0a 20 20 20 20 3b 3b -id #f))). ;;
14a0: 20 67 65 74 20 74 68 65 20 69 6e 66 6f 20 66 72 get the info fr
14b0: 6f 6d 20 74 68 65 20 64 62 20 61 6e 64 20 70 75 om the db and pu
14c0: 74 20 69 74 20 69 6e 20 74 68 65 20 63 61 63 68 t it in the cach
14d0: 65 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 76 e. (if (not v
14e0: 61 6c 73 29 0a 09 28 6c 65 74 20 28 28 68 74 20 als)..(let ((ht
14f0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1500: 29 29 29 0a 09 20 20 28 68 61 73 68 2d 74 61 62 ))).. (hash-tab
1510: 6c 65 2d 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 le-set! *env-var
1520: 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 72 75 6e s-by-run-id* run
1530: 2d 69 64 20 68 74 29 0a 09 20 20 28 73 65 74 21 -id ht).. (set!
1540: 20 76 61 6c 73 20 68 74 29 0a 09 20 20 28 66 6f vals ht).. (fo
1550: 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 r-each.. (lamb
1560: 64 61 20 28 6b 65 79 29 0a 09 20 20 20 20 20 28 da (key).. (
1570: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
1580: 76 61 6c 73 20 28 63 61 72 20 6b 65 79 29 20 28 vals (car key) (
1590: 63 61 64 72 20 6b 65 79 29 29 29 20 3b 3b 20 28 cadr key))) ;; (
15a0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
15b0: 62 3a 67 65 74 2d 72 75 6e 2d 6b 65 79 2d 76 61 b:get-run-key-va
15c0: 6c 20 23 66 20 72 75 6e 2d 69 64 20 28 63 61 72 l #f run-id (car
15d0: 20 6b 65 79 29 29 29 29 0a 09 20 20 20 6b 65 79 key)))).. key
15e0: 76 61 6c 73 29 29 29 0a 20 20 20 20 3b 3b 20 66 vals))). ;; f
15f0: 72 6f 6d 20 74 68 65 20 63 61 63 68 65 64 20 64 rom the cached d
1600: 61 74 61 20 73 65 74 20 74 68 65 20 76 61 72 73 ata set the vars
1610: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
1620: 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 76 -for-each. v
1630: 61 6c 73 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 als. (lambda
1640: 20 28 6b 65 79 20 76 61 6c 29 0a 20 20 20 20 20 (key val).
1650: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
1660: 20 22 73 65 74 65 6e 76 20 22 20 6b 65 79 20 22 "setenv " key "
1670: 20 22 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 " val). (
1680: 73 65 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 29 setenv key val))
1690: 29 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e ). (alist->en
16a0: 76 2d 76 61 72 73 20 28 68 61 73 68 2d 74 61 62 v-vars (hash-tab
16b0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
16c0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d configdat* "env-
16d0: 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 29 0a override" '())).
16e0: 20 20 20 20 3b 3b 20 4c 65 74 73 20 75 73 65 20 ;; Lets use
16f0: 74 68 69 73 20 61 73 20 61 6e 20 6f 70 70 6f 72 this as an oppor
1700: 74 75 6e 69 74 79 20 74 6f 20 70 75 74 20 4d 54 tunity to put MT
1710: 5f 52 55 4e 4e 41 4d 45 20 69 6e 20 74 68 65 20 _RUNNAME in the
1720: 65 6e 76 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 environment.
1730: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
1740: 41 4d 45 22 20 28 69 66 20 69 6e 72 75 6e 6e 61 AME" (if inrunna
1750: 6d 65 20 69 6e 72 75 6e 6e 61 6d 65 20 28 63 64 me inrunname (cd
1760: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
1770: 67 65 74 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f get-run-name-fro
1780: 6d 2d 69 64 20 23 66 20 72 75 6e 2d 69 64 29 29 m-id #f run-id))
1790: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d ). (setenv "M
17a0: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
17b0: 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 0a 0a 28 *toppath*)))..(
17c0: 64 65 66 69 6e 65 20 28 73 65 74 2d 69 74 65 6d define (set-item
17d0: 2d 65 6e 76 2d 76 61 72 73 20 69 74 65 6d 64 61 -env-vars itemda
17e0: 74 29 0a 20 20 28 66 6f 72 2d 65 61 63 68 20 28 t). (for-each (
17f0: 6c 61 6d 62 64 61 20 28 69 74 65 6d 29 0a 09 20 lambda (item)..
1800: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1810: 74 20 32 20 22 73 65 74 65 6e 76 20 22 20 28 63 t 2 "setenv " (c
1820: 61 72 20 69 74 65 6d 29 20 22 20 22 20 28 63 61 ar item) " " (ca
1830: 64 72 20 69 74 65 6d 29 29 0a 09 20 20 20 20 20 dr item))..
1840: 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 69 74 (setenv (car it
1850: 65 6d 29 20 28 63 61 64 72 20 69 74 65 6d 29 29 em) (cadr item))
1860: 29 0a 09 20 20 20 20 69 74 65 6d 64 61 74 29 29 ).. itemdat))
1870: 0a 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d ..(define *last-
1880: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 num-running-test
1890: 73 2a 20 30 29 0a 0a 3b 3b 20 45 76 65 72 79 20 s* 0)..;; Every
18a0: 74 69 6d 65 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 time can-run-mor
18b0: 65 2d 74 65 73 74 73 20 69 73 20 63 61 6c 6c 65 e-tests is calle
18c0: 64 20 69 6e 63 72 65 6d 65 6e 74 20 74 68 65 20 d increment the
18d0: 64 65 6c 61 79 0a 3b 3b 20 69 66 20 74 68 65 20 delay.;; if the
18e0: 63 6f 75 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e cou.(define *run
18f0: 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 s:can-run-more-t
1900: 65 73 74 73 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 ests-count* 0).(
1910: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 73 68 72 define (runs:shr
1920: 69 6e 6b 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 ink-can-run-more
1930: 2d 74 65 73 74 73 2d 63 6f 75 6e 74 29 0a 20 20 -tests-count).
1940: 28 73 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d (set! *runs:can-
1950: 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 run-more-tests-c
1960: 6f 75 6e 74 2a 20 30 29 29 20 3b 3b 20 28 2f 20 ount* 0)) ;; (/
1970: 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f *runs:can-run-mo
1980: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 re-tests-count*
1990: 32 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 2)))..(define (r
19a0: 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 uns:can-run-more
19b0: 2d 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f -tests test-reco
19c0: 72 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e rd max-concurren
19d0: 74 2d 6a 6f 62 73 29 0a 20 20 28 74 68 72 65 61 t-jobs). (threa
19e0: 64 2d 73 6c 65 65 70 21 20 28 63 6f 6e 64 0a 09 d-sleep! (cond..
19f0: 09 20 20 28 28 3e 20 2a 72 75 6e 73 3a 63 61 6e . ((> *runs:can
1a00: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d -run-more-tests-
1a10: 63 6f 75 6e 74 2a 20 32 30 29 20 32 29 3b 3b 20 count* 20) 2);;
1a20: 6f 62 76 69 6f 75 73 6c 79 20 68 61 76 65 6e 27 obviously haven'
1a30: 74 20 68 61 64 20 61 6e 79 20 77 6f 72 6b 20 74 t had any work t
1a40: 6f 20 64 6f 20 66 6f 72 20 61 20 77 68 69 6c 65 o do for a while
1a50: 0a 09 09 20 20 28 65 6c 73 65 20 30 29 29 29 0a ... (else 0))).
1a60: 20 20 28 6c 65 74 2a 20 28 28 74 63 6f 6e 66 69 (let* ((tconfi
1a70: 67 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 g
1a80: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
1a90: 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ue-get-testconfi
1aa0: 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a g test-record)).
1ab0: 09 20 28 6a 6f 62 67 72 6f 75 70 20 20 20 20 20 . (jobgroup
1ac0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 66 (conf
1ad0: 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 ig-lookup tconfi
1ae0: 67 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 g "requirements"
1af0: 20 22 6a 6f 62 67 72 6f 75 70 22 29 29 0a 09 20 "jobgroup"))..
1b00: 28 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 (num-running
1b10: 20 20 20 20 20 20 20 20 20 28 63 64 62 3a 72 65 (cdb:re
1b20: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get-
1b30: 63 6f 75 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e count-tests-runn
1b40: 69 6e 67 20 23 66 29 29 0a 09 20 28 6e 75 6d 2d ing #f)).. (num-
1b50: 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 running-in-jobgr
1b60: 6f 75 70 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d oup (cdb:remote-
1b70: 72 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 run db:get-count
1b80: 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 -tests-running-i
1b90: 6e 2d 6a 6f 62 67 72 6f 75 70 20 23 66 20 6a 6f n-jobgroup #f jo
1ba0: 62 67 72 6f 75 70 29 29 0a 09 20 28 6a 6f 62 2d bgroup)).. (job-
1bb0: 67 72 6f 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 group-limit
1bc0: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
1bd0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
1be0: 6a 6f 62 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 jobgroups" jobgr
1bf0: 6f 75 70 29 29 29 0a 20 20 20 20 28 69 66 20 28 oup))). (if (
1c00: 3e 20 28 2b 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 > (+ num-running
1c10: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d num-running-in-
1c20: 6a 6f 62 67 72 6f 75 70 29 20 30 29 0a 09 28 73 jobgroup) 0)..(s
1c30: 65 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 et! *runs:can-ru
1c40: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 n-more-tests-cou
1c50: 6e 74 2a 20 28 2b 20 2a 72 75 6e 73 3a 63 61 6e nt* (+ *runs:can
1c60: 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d -run-more-tests-
1c70: 63 6f 75 6e 74 2a 20 31 29 29 29 0a 20 20 20 20 count* 1))).
1c80: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a 6c (if (not (eq? *l
1c90: 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d ast-num-running-
1ca0: 74 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 tests* num-runni
1cb0: 6e 67 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 ng))..(begin..
1cc0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
1cd0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
1ce0: 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 obs: " max-concu
1cf0: 72 72 65 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 rrent-jobs ", nu
1d00: 6d 2d 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d m-running: " num
1d10: 2d 72 75 6e 6e 69 6e 67 29 0a 09 20 20 28 73 65 -running).. (se
1d20: 74 21 20 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e t! *last-num-run
1d30: 6e 69 6e 67 2d 74 65 73 74 73 2a 20 6e 75 6d 2d ning-tests* num-
1d40: 72 75 6e 6e 69 6e 67 29 29 29 0a 20 20 20 20 28 running))). (
1d50: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 30 20 2a if (not (eq? 0 *
1d60: 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 globalexitstatus
1d70: 2a 29 29 0a 09 28 6c 69 73 74 20 23 66 20 6e 75 *))..(list #f nu
1d80: 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 m-running num-ru
1d90: 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 nning-in-jobgrou
1da0: 70 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 p max-concurrent
1db0: 2d 6a 6f 62 73 20 6a 6f 62 2d 67 72 6f 75 70 2d -jobs job-group-
1dc0: 6c 69 6d 69 74 29 0a 09 28 6c 65 74 20 28 28 63 limit)..(let ((c
1dd0: 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 20 an-not-run-more
1de0: 28 63 6f 6e 64 0a 09 09 09 09 20 3b 3b 20 69 66 (cond..... ;; if
1df0: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1e00: 6a 6f 62 73 20 69 73 20 73 65 74 20 61 6e 64 20 jobs is set and
1e10: 74 68 65 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 the number runni
1e20: 6e 67 20 69 73 20 67 72 65 61 74 65 72 20 0a 09 ng is greater ..
1e30: 09 09 09 20 3b 3b 20 74 68 61 6e 20 69 74 20 74 ... ;; than it t
1e40: 68 61 6e 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d han cannot run m
1e50: 6f 72 65 20 6a 6f 62 73 0a 09 09 09 09 20 28 28 ore jobs..... ((
1e60: 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 and max-concurre
1e70: 6e 74 2d 6a 6f 62 73 20 28 3e 3d 20 6e 75 6d 2d nt-jobs (>= num-
1e80: 72 75 6e 6e 69 6e 67 20 6d 61 78 2d 63 6f 6e 63 running max-conc
1e90: 75 72 72 65 6e 74 2d 6a 6f 62 73 29 29 0a 09 09 urrent-jobs))...
1ea0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
1eb0: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 78 0 "WARNING: Max
1ec0: 20 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 78 running jobs ex
1ed0: 63 65 65 64 65 64 2c 20 63 75 72 72 65 6e 74 20 ceeded, current
1ee0: 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 3a 20 number running:
1ef0: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 " num-running ..
1f00: 09 09 09 09 20 20 20 20 20 20 20 22 2c 20 6d 61 .... ", ma
1f10: 78 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 x_concurrent_job
1f20: 73 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 s: " max-concurr
1f30: 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 09 09 20 20 ent-jobs).....
1f40: 23 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 20 6a #t)..... ;; if j
1f50: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 69 ob-group-limit i
1f60: 73 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 65 72 s set and number
1f70: 20 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 65 20 of jobs in the
1f80: 67 72 6f 75 70 20 69 73 20 67 72 65 61 74 65 72 group is greater
1f90: 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 74 68 ..... ;; than th
1fa0: 65 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 61 6e e limit then can
1fb0: 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 not run more job
1fc0: 73 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 0a 09 s of this kind..
1fd0: 09 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d 67 72 ... ((and job-gr
1fe0: 6f 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 20 20 oup-limit.....
1ff0: 20 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e (>= num-run
2000: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
2010: 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 job-group-limit
2020: 29 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a ))..... (debug:
2030: 70 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 print 1 "WARNING
2040: 3a 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 : number of jobs
2050: 20 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 " num-running-i
2060: 6e 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 09 09 n-jobgroup .....
2070: 09 20 20 20 20 20 20 20 22 20 69 6e 20 22 20 6a . " in " j
2080: 6f 62 67 72 6f 75 70 20 22 20 65 78 63 65 65 64 obgroup " exceed
2090: 65 64 2c 20 77 69 6c 6c 20 6e 6f 74 20 72 75 6e ed, will not run
20a0: 20 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 " (tests:testqu
20b0: 65 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 eue-get-testname
20c0: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
20d0: 09 09 09 20 20 23 74 29 0a 09 09 09 09 20 28 65 ... #t)..... (e
20e0: 6c 73 65 20 23 66 29 29 29 29 0a 09 20 20 28 6c lse #f)))).. (l
20f0: 69 73 74 20 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 ist (not can-not
2100: 2d 72 75 6e 2d 6d 6f 72 65 29 20 6e 75 6d 2d 72 -run-more) num-r
2110: 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 unning num-runni
2120: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d ng-in-jobgroup m
2130: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
2140: 62 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d bs job-group-lim
2150: 69 74 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d it)))))..;;=====
2160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21a0: 3d 0a 3b 3b 20 4e 65 77 20 6d 65 74 68 6f 64 6f =.;; New methodo
21b0: 6c 6f 67 79 2e 20 54 68 65 73 65 20 72 6f 75 74 logy. These rout
21c0: 69 6e 65 73 20 77 69 6c 6c 20 72 65 70 6c 61 63 ines will replac
21d0: 65 20 74 68 65 20 61 62 6f 76 65 20 69 6e 20 74 e the above in t
21e0: 69 6d 65 2e 20 46 6f 72 0a 3b 3b 20 6e 6f 77 20 ime. For.;; now
21f0: 74 68 65 20 63 6f 64 65 20 69 73 20 64 75 70 6c the code is dupl
2200: 69 63 61 74 65 64 2e 20 54 68 69 73 20 73 74 75 icated. This stu
2210: 66 66 20 69 73 20 69 6e 69 74 69 61 6c 6c 79 20 ff is initially
2220: 75 73 65 64 20 69 6e 20 74 68 65 20 6d 6f 6e 69 used in the moni
2230: 74 6f 72 0a 3b 3b 20 62 61 73 65 64 20 63 6f 64 tor.;; based cod
2240: 65 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d e..;;===========
2250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 0a 3b 3b ===========...;;
2290: 20 54 68 69 73 20 69 73 20 61 20 64 75 70 6c 69 This is a dupli
22a0: 63 61 74 65 20 6f 66 20 72 75 6e 2d 74 65 73 74 cate of run-test
22b0: 73 20 28 77 68 69 63 68 20 68 61 73 20 62 65 65 s (which has bee
22c0: 6e 20 64 65 70 72 65 63 61 74 65 64 29 2e 20 55 n deprecated). U
22d0: 73 65 20 74 68 69 73 20 6f 6e 65 20 69 6e 73 74 se this one inst
22e0: 65 61 64 20 6f 66 20 72 75 6e 20 74 65 73 74 73 ead of run tests
22f0: 2e 0a 3b 3b 20 6b 65 79 76 61 6c 73 2e 0a 3b 3b ..;; keyvals..;;
2300: 0a 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 73 3a .;; test-names:
2310: 20 43 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 Comma separated
2320: 20 70 61 74 74 65 72 6e 73 20 73 61 6d 65 20 61 patterns same a
2330: 73 20 74 65 73 74 2d 70 61 74 74 73 20 62 75 74 s test-patts but
2340: 20 75 73 65 64 20 69 6e 20 73 65 6c 65 63 74 69 used in selecti
2350: 6f 6e 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 on .;;
2360: 20 20 20 20 6f 66 20 74 65 73 74 73 20 74 6f 20 of tests to
2370: 72 75 6e 2e 20 54 68 65 20 69 74 65 6d 20 70 6f run. The item po
2380: 72 74 69 6f 6e 73 20 61 72 65 20 6e 6f 74 20 72 rtions are not r
2390: 65 73 70 65 63 74 65 64 2e 0a 3b 3b 20 20 20 20 espected..;;
23a0: 20 20 20 20 20 20 20 20 20 20 46 49 58 4d 45 3a FIXME:
23b0: 20 65 72 72 6f 72 20 6f 75 74 20 69 66 20 2f 70 error out if /p
23c0: 61 74 74 20 73 70 65 63 69 66 69 65 64 0a 3b 3b att specified.;;
23d0: 20 20 20 20 20 20 20 20 20 20 20 20 0a 28 64 65 .(de
23e0: 66 69 6e 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 fine (runs:run-t
23f0: 65 73 74 73 20 74 61 72 67 65 74 20 72 75 6e 6e ests target runn
2400: 61 6d 65 20 74 65 73 74 2d 70 61 74 74 73 20 75 ame test-patts u
2410: 73 65 72 20 66 6c 61 67 73 29 20 3b 3b 20 74 65 ser flags) ;; te
2420: 73 74 2d 6e 61 6d 65 73 0a 20 20 28 63 6f 6d 6d st-names. (comm
2430: 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 on:clear-caches)
2440: 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 ;; clear all ca
2450: 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 ches. (let* ((d
2460: 62 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 b #f)..
2470: 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 28 6b (keys (k
2480: 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 eys:config-get-f
2490: 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 ields *configdat
24a0: 2a 29 29 0a 09 20 28 6b 65 79 76 61 6c 73 20 20 *)).. (keyvals
24b0: 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d (keys:target-
24c0: 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 >keyval keys tar
24d0: 67 65 74 29 29 0a 09 20 28 72 75 6e 2d 69 64 20 get)).. (run-id
24e0: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
24f0: 2d 72 75 6e 20 64 62 3a 72 65 67 69 73 74 65 72 -run db:register
2500: 2d 72 75 6e 20 23 66 20 6b 65 79 73 20 6b 65 79 -run #f keys key
2510: 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 22 6e 65 vals runname "ne
2520: 77 22 20 22 6e 2f 61 22 20 75 73 65 72 29 29 20 w" "n/a" user))
2530: 20 3b 3b 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 ;; test-name))
2540: 29 0a 09 20 28 64 65 66 65 72 72 65 64 20 20 20 ).. (deferred
2550: 20 27 28 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 '()) ;; delay r
2560: 75 6e 6e 69 6e 67 20 74 68 65 73 65 20 73 69 6e unning these sin
2570: 63 65 20 74 68 65 79 20 68 61 76 65 20 61 20 77 ce they have a w
2580: 61 69 74 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b aiton clause.. ;
2590: 3b 20 6b 65 65 70 67 6f 69 6e 67 20 69 73 20 74 ; keepgoing is t
25a0: 68 65 20 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c he defacto modal
25b0: 69 74 79 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 ity now, will ad
25c0: 64 20 68 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 d hit-n-run a bi
25d0: 74 20 6c 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 t later.. ;; (ke
25e0: 65 70 67 6f 69 6e 67 20 20 20 28 68 61 73 68 2d epgoing (hash-
25f0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2600: 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f t flags "-keepgo
2610: 69 6e 67 22 20 23 66 29 29 0a 09 20 28 72 75 6e ing" #f)).. (run
2620: 63 6f 6e 66 69 67 66 20 20 20 28 63 6f 6e 63 20 configf (conc
2630: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
2640: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
2650: 29 0a 09 20 28 72 65 71 75 69 72 65 64 2d 74 65 ).. (required-te
2660: 73 74 73 20 27 28 29 29 0a 09 20 28 74 65 73 74 sts '()).. (test
2670: 2d 72 65 63 6f 72 64 73 20 28 6d 61 6b 65 2d 68 -records (make-h
2680: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 20 20 ash-table)).
2690: 20 28 61 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 73 (all-test-names
26a0: 20 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 (tests:get-vali
26b0: 64 2d 74 65 73 74 73 20 2a 74 6f 70 70 61 74 68 d-tests *toppath
26c0: 2a 20 22 25 22 29 29 29 20 3b 3b 20 77 65 20 6e * "%"))) ;; we n
26d0: 65 65 64 20 61 20 6c 69 73 74 20 6f 66 20 61 6c eed a list of al
26e0: 6c 20 76 61 6c 69 64 20 74 65 73 74 73 20 74 6f l valid tests to
26f0: 20 63 68 65 63 6b 20 77 61 69 74 6f 6e 20 6e 61 check waiton na
2700: 6d 65 73 29 0a 09 20 28 61 6c 6c 2d 74 65 73 74 mes).. (all-test
2710: 2d 6e 61 6d 65 73 20 28 74 65 73 74 73 3a 67 65 -names (tests:ge
2720: 74 2d 76 61 6c 69 64 2d 74 65 73 74 73 20 2a 74 t-valid-tests *t
2730: 6f 70 70 61 74 68 2a 20 22 25 22 29 29 29 20 3b oppath* "%"))) ;
2740: 3b 20 77 65 20 6e 65 65 64 20 61 20 6c 69 73 74 ; we need a list
2750: 20 6f 66 20 61 6c 6c 20 76 61 6c 69 64 20 74 65 of all valid te
2760: 73 74 73 20 74 6f 20 63 68 65 63 6b 20 77 61 69 sts to check wai
2770: 74 6f 6e 20 6e 61 6d 65 73 0a 0a 20 20 20 20 28 ton names.. (
2780: 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 set-megatest-env
2790: 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 69 6e 6b -vars run-id ink
27a0: 65 79 73 3a 20 6b 65 79 73 29 20 3b 3b 20 74 68 eys: keys) ;; th
27b0: 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 ese may be neede
27c0: 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 d by the launchi
27d0: 6e 67 20 70 72 6f 63 65 73 73 0a 0a 20 20 20 20 ng process..
27e0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
27f0: 3f 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 28 ? runconfigf)..(
2800: 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c setup-env-defaul
2810: 74 73 20 72 75 6e 63 6f 6e 66 69 67 66 20 72 75 ts runconfigf ru
2820: 6e 2d 69 64 20 2a 61 6c 72 65 61 64 79 2d 73 65 n-id *already-se
2830: 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 en-runconfig-inf
2840: 6f 2a 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 20 o* keys keyvals
2850: 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d "pre-launch-env-
2860: 76 61 72 73 22 29 0a 09 28 64 65 62 75 67 3a 70 vars")..(debug:p
2870: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
2880: 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 76 65 You do not have
2890: 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 66 69 a run config fi
28a0: 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 67 66 le: " runconfigf
28b0: 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 6c )). . ;; l
28c0: 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 74 73 ook up all tests
28d0: 20 6d 61 74 63 68 69 6e 67 20 74 68 65 20 63 6f matching the co
28e0: 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 6c 69 mma separated li
28f0: 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e 0a 20 st of globs in.
2900: 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 74 73 ;; test-patts
2910: 20 28 75 73 69 6e 67 20 25 20 61 73 20 77 69 6c (using % as wil
2920: 64 63 61 72 64 29 0a 0a 20 20 20 20 28 73 65 74 dcard).. (set
2930: 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 74 65 ! test-names (te
2940: 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d 74 65 sts:get-valid-te
2950: 73 74 73 20 2a 74 6f 70 70 61 74 68 2a 20 74 65 sts *toppath* te
2960: 73 74 2d 70 61 74 74 73 29 29 0a 20 20 20 20 28 st-patts)). (
2970: 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
2980: 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 74 (delete-duplicat
2990: 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a es test-names)).
29a0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
29b0: 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 20 6e t-info 0 "test n
29c0: 61 6d 65 73 20 22 20 74 65 73 74 2d 6e 61 6d 65 ames " test-name
29d0: 73 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e 20 74 68 s).. ;; on th
29e0: 65 20 66 69 72 73 74 20 70 61 73 73 20 6f 72 20 e first pass or
29f0: 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 73 74 call to run-test
2a00: 73 20 73 65 74 20 46 41 49 4c 53 20 74 6f 20 4e s set FAILS to N
2a10: 4f 54 5f 53 54 41 52 54 45 44 20 69 66 0a 20 20 OT_STARTED if.
2a20: 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 20 ;; -keepgoing
2a30: 69 73 20 73 70 65 63 69 66 69 65 64 0a 20 20 20 is specified.
2a40: 20 28 69 66 20 28 65 71 3f 20 2a 70 61 73 73 6e (if (eq? *passn
2a50: 75 6d 2a 20 30 29 0a 09 28 62 65 67 69 6e 0a 09 um* 0)..(begin..
2a60: 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 64 65 6c ;; have to del
2a70: 65 74 65 20 74 65 73 74 20 72 65 63 6f 72 64 73 ete test records
2a80: 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 41 52 54 where NOT_START
2a90: 45 44 20 73 69 6e 63 65 20 74 68 65 79 20 63 61 ED since they ca
2aa0: 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 67 6f 69 n cause -keepgoi
2ab0: 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 67 65 74 ng to .. ;; get
2ac0: 20 73 74 75 63 6b 20 64 75 65 20 74 6f 20 62 65 stuck due to be
2ad0: 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 73 73 69 coming inaccessi
2ae0: 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 69 6c 65 ble from a faile
2af0: 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 69 66 20 d test. I.e. if
2b00: 74 65 73 74 20 42 20 64 65 70 65 6e 64 73 20 0a test B depends .
2b10: 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 20 41 20 . ;; on test A
2b20: 62 75 74 20 74 65 73 74 20 42 20 72 65 61 63 68 but test B reach
2b30: 65 64 20 74 68 65 20 70 6f 69 6e 74 20 6f 6e 20 ed the point on
2b40: 62 65 69 6e 67 20 72 65 67 69 73 74 65 72 65 64 being registered
2b50: 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 as NOT_STARTED
2b60: 61 6e 64 20 74 65 73 74 0a 09 20 20 3b 3b 20 41 and test.. ;; A
2b70: 20 66 61 69 6c 65 64 20 66 6f 72 20 73 6f 6d 65 failed for some
2b80: 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 6f 6e 20 reason then on
2b90: 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 2d 6b 65 re-run using -ke
2ba0: 65 70 67 6f 69 6e 67 20 74 68 65 20 72 75 6e 20 epgoing the run
2bb0: 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d 70 6c 65 can never comple
2bc0: 74 65 2e 0a 09 20 20 28 63 64 62 3a 64 65 6c 65 te... (cdb:dele
2bd0: 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 74 61 74 te-tests-in-stat
2be0: 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 72 75 e *runremote* ru
2bf0: 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 54 45 n-id "NOT_STARTE
2c00: 44 22 29 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f D").. (cdb:remo
2c10: 74 65 2d 72 75 6e 20 64 62 3a 73 65 74 2d 74 65 te-run db:set-te
2c20: 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 75 73 sts-state-status
2c30: 20 23 66 20 72 75 6e 2d 69 64 20 74 65 73 74 2d #f run-id test-
2c40: 6e 61 6d 65 73 20 23 66 20 22 46 41 49 4c 22 20 names #f "FAIL"
2c50: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 46 "NOT_STARTED" "F
2c60: 41 49 4c 22 29 29 29 0a 0a 20 20 20 20 3b 3b 20 AIL"))).. ;;
2c70: 66 72 6f 6d 20 68 65 72 65 20 6f 6e 20 6f 75 74 from here on out
2c80: 20 74 68 65 20 64 62 20 77 69 6c 6c 20 62 65 20 the db will be
2c90: 6f 70 65 6e 65 64 20 61 6e 64 20 63 6c 6f 73 65 opened and close
2ca0: 64 20 6f 6e 20 65 76 65 72 79 20 63 61 6c 6c 20 d on every call
2cb0: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 runs:run-tests-q
2cc0: 75 65 75 65 0a 20 20 20 20 3b 3b 20 28 73 71 6c ueue. ;; (sql
2cd0: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
2ce0: 62 29 20 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 61 b) . ;; now a
2cf0: 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 20 dd non-directly
2d00: 72 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 6e referenced depen
2d10: 64 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 61 dencies (i.e. wa
2d20: 69 74 6f 6e 29 0a 20 20 20 20 28 69 66 20 28 6e iton). (if (n
2d30: 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d 6e ot (null? test-n
2d40: 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f 6f ames))..(let loo
2d50: 70 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 p ((hed (car tes
2d60: 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 28 t-names))... (
2d70: 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e 61 tal (cdr test-na
2d80: 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 20 3b mes))) ;
2d90: 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 20 ; 'return-procs
2da0: 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 67 tells the config
2db0: 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 20 reader to prep
2dc0: 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 62 running system b
2dd0: 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f 63 ut return a proc
2de0: 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e 66 .. (let* ((conf
2df0: 69 67 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 ig (tests:get-t
2e00: 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 27 72 estconfig hed 'r
2e10: 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 09 eturn-procs))...
2e20: 20 28 77 61 69 74 6f 6e 73 20 28 6c 65 74 20 28 (waitons (let (
2e30: 28 69 6e 73 74 72 20 28 69 66 20 63 6f 6e 66 69 (instr (if confi
2e40: 67 20 0a 09 09 09 09 09 20 20 20 28 63 6f 6e 66 g ...... (conf
2e50: 69 67 2d 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 ig-lookup config
2e60: 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
2e70: 22 77 61 69 74 6f 6e 22 29 0a 09 09 09 09 09 20 "waiton")......
2e80: 20 20 28 62 65 67 69 6e 20 3b 3b 20 4e 6f 20 63 (begin ;; No c
2e90: 6f 6e 66 69 67 20 6d 65 61 6e 73 20 74 68 69 73 onfig means this
2ea0: 20 69 73 20 61 20 6e 6f 6e 2d 65 78 69 73 74 61 is a non-exista
2eb0: 6e 74 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 nt test......
2ec0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2ed0: 20 22 45 52 52 4f 52 3a 20 6e 6f 6e 2d 65 78 69 "ERROR: non-exi
2ee0: 73 74 65 6e 74 20 72 65 71 75 69 72 65 64 20 74 stent required t
2ef0: 65 73 74 20 5c 22 22 20 68 65 64 20 22 5c 22 22 est \"" hed "\""
2f00: 29 0a 09 09 09 09 09 20 20 20 20 20 28 69 66 20 )...... (if
2f10: 64 62 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 db (sqlite3:fina
2f20: 6c 69 7a 65 21 20 64 62 29 29 0a 09 09 09 09 09 lize! db))......
2f30: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 (exit 1))))
2f40: 29 0a 09 09 09 20 20 20 20 28 64 65 62 75 67 3a ).... (debug:
2f50: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 61 print-info 8 "wa
2f60: 69 74 6f 6e 73 20 73 74 72 69 6e 67 20 69 73 20 itons string is
2f70: 22 20 69 6e 73 74 72 29 0a 09 09 09 20 20 20 20 " instr)....
2f80: 28 6c 65 74 20 28 28 6e 65 77 77 61 69 74 6f 6e (let ((newwaiton
2f90: 73 0a 09 09 09 09 20 20 20 28 73 74 72 69 6e 67 s..... (string
2fa0: 2d 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 -split (cond....
2fb0: 09 09 09 20 20 28 28 70 72 6f 63 65 64 75 72 65 ... ((procedure
2fc0: 3f 20 69 6e 73 74 72 29 0a 09 09 09 09 09 09 20 ? instr).......
2fd0: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e (let ((res (in
2fe0: 73 74 72 29 29 29 0a 09 09 09 09 09 09 20 20 20 str))).......
2ff0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
3000: 6e 66 6f 20 38 20 22 77 61 69 74 6f 6e 20 70 72 nfo 8 "waiton pr
3010: 6f 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 ocedure results
3020: 69 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 in string " res
3030: 22 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 " for test " hed
3040: 29 0a 09 09 09 09 09 09 20 20 20 20 20 72 65 73 )....... res
3050: 29 29 0a 09 09 09 09 09 09 20 20 28 28 73 74 72 ))....... ((str
3060: 69 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 20 20 ing? instr)
3070: 69 6e 73 74 72 29 0a 09 09 09 09 09 09 20 20 28 instr)....... (
3080: 65 6c 73 65 20 0a 09 09 09 09 09 09 20 20 20 3b else ....... ;
3090: 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 ; NOTE: This is
30a0: 61 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 actually the cas
30b0: 65 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e e of *no* waiton
30c0: 73 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 s! ;; (debug:pri
30d0: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 73 6f 6d nt 0 "ERROR: som
30e0: 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e ething went wron
30f0: 67 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 g in processing
3100: 77 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 waitons for test
3110: 20 22 20 68 65 64 29 0a 09 09 09 09 09 09 20 20 " hed).......
3120: 20 22 22 29 29 29 29 29 0a 09 09 09 20 20 20 20 "")))))....
3130: 20 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 (filter (lambd
3140: 61 20 28 78 29 0a 09 09 09 09 09 28 69 66 20 28 a (x)......(if (
3150: 6d 65 6d 62 65 72 20 78 20 61 6c 6c 2d 74 65 73 member x all-tes
3160: 74 2d 6e 61 6d 65 73 29 0a 09 09 09 09 09 20 20 t-names)......
3170: 20 20 23 74 0a 09 09 09 09 09 20 20 20 20 28 62 #t...... (b
3180: 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 20 20 egin......
3190: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
31a0: 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 68 65 ERROR: test " he
31b0: 64 20 22 20 68 61 73 20 75 6e 72 65 63 6f 67 6e d " has unrecogn
31c0: 69 73 65 64 20 77 61 69 74 6f 6e 20 74 65 73 74 ised waiton test
31d0: 6e 61 6d 65 20 22 20 78 29 0a 09 09 09 09 09 20 name " x)......
31e0: 20 20 20 20 20 23 66 29 29 29 0a 09 09 09 09 20 #f))).....
31f0: 20 20 20 20 20 6e 65 77 77 61 69 74 6f 6e 73 29 newwaitons)
3200: 29 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 )))).. (debug
3210: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 22 77 :print-info 8 "w
3220: 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 6f 6e aitons: " waiton
3230: 73 29 0a 09 20 20 20 20 3b 3b 20 63 68 65 63 6b s).. ;; check
3240: 20 66 6f 72 20 68 65 64 20 69 6e 20 77 61 69 74 for hed in wait
3250: 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 6f 75 6c ons => this woul
3260: 64 20 62 65 20 63 69 72 63 75 6c 61 72 2c 20 72 d be circular, r
3270: 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 69 73 73 emove it and iss
3280: 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b 20 65 72 ue an.. ;; er
3290: 72 6f 72 0a 09 20 20 20 20 28 69 66 20 28 6d 65 ror.. (if (me
32a0: 6d 62 65 72 20 68 65 64 20 77 61 69 74 6f 6e 73 mber hed waitons
32b0: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
32c0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
32d0: 52 52 4f 52 3a 20 74 65 73 74 20 22 20 68 65 64 RROR: test " hed
32e0: 20 22 20 68 61 73 20 6c 69 73 74 65 64 20 69 74 " has listed it
32f0: 73 65 6c 66 20 61 73 20 61 20 77 61 69 74 6f 6e self as a waiton
3300: 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 65 63 74 , please correct
3310: 20 74 68 69 73 21 22 29 0a 09 09 20 20 28 73 65 this!")... (se
3320: 74 21 20 77 61 69 74 6f 6e 73 20 28 66 69 6c 74 t! waitons (filt
3330: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 28 6e er (lambda (x)(n
3340: 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 68 65 64 ot (equal? x hed
3350: 29 29 29 20 77 61 69 74 6f 6e 73 29 29 29 29 0a ))) waitons)))).
3360: 09 20 20 20 20 0a 09 20 20 20 20 3b 3b 20 28 69 . .. ;; (i
3370: 74 65 6d 73 20 20 20 28 69 74 65 6d 73 3a 67 65 tems (items:ge
3380: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
3390: 66 69 67 20 63 6f 6e 66 69 67 29 29 29 0a 09 20 fig config)))..
33a0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 68 61 73 (if (not (has
33b0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
33c0: 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ult test-records
33d0: 20 68 65 64 20 23 66 29 29 0a 09 09 28 68 61 73 hed #f))...(has
33e0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 74 65 73 h-table-set! tes
33f0: 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 09 20 68 t-records..... h
3400: 65 64 20 28 76 65 63 74 6f 72 20 68 65 64 20 20 ed (vector hed
3410: 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 20 20 20 ;; 0......
3420: 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 31 0a 09 config ;; 1..
3430: 09 09 09 09 20 20 20 20 20 77 61 69 74 6f 6e 73 .... waitons
3440: 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 20 20 20 ;; 2......
3450: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 63 (config-lookup c
3460: 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d 65 onfig "requireme
3470: 6e 74 73 22 20 22 70 72 69 6f 72 69 74 79 22 29 nts" "priority")
3480: 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 69 74 79 ;; priority
3490: 20 33 0a 09 09 09 09 09 20 20 20 20 20 28 6c 65 3...... (le
34a0: 74 20 28 28 69 74 65 6d 73 20 20 20 20 20 20 28 t ((items (
34b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
34c0: 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
34d0: 74 65 6d 73 22 20 23 66 29 29 20 3b 3b 20 69 74 tems" #f)) ;; it
34e0: 65 6d 73 20 34 0a 09 09 09 09 09 09 20 20 20 28 ems 4....... (
34f0: 69 74 65 6d 73 74 61 62 6c 65 20 28 68 61 73 68 itemstable (hash
3500: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3510: 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 65 6d 73 lt config "items
3520: 74 61 62 6c 65 22 20 23 66 29 29 29 20 0a 09 09 table" #f))) ...
3530: 09 09 09 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ... ;; if
3540: 65 69 74 68 65 72 20 69 74 65 6d 73 20 6f 72 20 either items or
3550: 69 74 65 6d 73 20 74 61 62 6c 65 20 69 73 20 61 items table is a
3560: 20 70 72 6f 63 20 72 65 74 75 72 6e 20 69 74 20 proc return it
3570: 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 6e 67 0a so test running.
3580: 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 70 ..... ;; p
3590: 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e 6f 77 20 rocess can know
35a0: 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 3a 67 65 to call items:ge
35b0: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
35c0: 66 69 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 fig......
35d0: 3b 3b 20 69 66 20 65 69 74 68 65 72 20 69 73 20 ;; if either is
35e0: 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f 6e 65 20 a list and none
35f0: 69 73 20 61 20 70 72 6f 63 20 67 6f 20 61 68 65 is a proc go ahe
3600: 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 65 74 2d ad and call get-
3610: 69 74 65 6d 73 0a 09 09 09 09 09 20 20 20 20 20 items......
3620: 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 65 20 72 ;; otherwise r
3630: 65 74 75 72 6e 20 23 66 20 2d 20 74 68 69 73 20 eturn #f - this
3640: 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 72 61 74 is not an iterat
3650: 65 64 20 74 65 73 74 0a 09 09 09 09 09 20 20 20 ed test......
3660: 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 09 09 09 (cond.......
3670: 28 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 ((procedure? ite
3680: 6d 73 29 20 20 20 20 20 20 0a 09 09 09 09 09 09 ms) .......
3690: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
36a0: 66 6f 20 34 20 22 69 74 65 6d 73 20 69 73 20 61 fo 4 "items is a
36b0: 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c procedure, will
36c0: 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 calc later")...
36d0: 09 09 09 09 20 69 74 65 6d 73 29 20 20 20 20 20 .... items)
36e0: 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c ;; calc l
36f0: 61 74 65 72 0a 09 09 09 09 09 09 28 28 70 72 6f ater.......((pro
3700: 63 65 64 75 72 65 3f 20 69 74 65 6d 73 74 61 62 cedure? itemstab
3710: 6c 65 29 0a 09 09 09 09 09 09 20 28 64 65 62 75 le)....... (debu
3720: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
3730: 69 74 65 6d 73 74 61 62 6c 65 20 69 73 20 61 20 itemstable is a
3740: 70 72 6f 63 65 64 75 72 65 2c 20 77 69 6c 6c 20 procedure, will
3750: 63 61 6c 63 20 6c 61 74 65 72 22 29 0a 09 09 09 calc later")....
3760: 09 09 09 20 69 74 65 6d 73 74 61 62 6c 65 29 20 ... itemstable)
3770: 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 20 6c 61 ;; calc la
3780: 74 65 72 0a 09 09 09 09 09 09 28 28 66 69 6c 74 ter.......((filt
3790: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
37a0: 09 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 ...... (let ((
37b0: 76 61 6c 20 28 63 61 72 20 78 29 29 29 0a 09 09 val (car x)))...
37c0: 09 09 09 09 09 20 20 20 20 20 28 69 66 20 28 70 ..... (if (p
37d0: 72 6f 63 65 64 75 72 65 3f 20 76 61 6c 29 20 76 rocedure? val) v
37e0: 61 6c 20 23 66 29 29 29 0a 09 09 09 09 09 09 09 al #f)))........
37f0: 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 6c 69 (append (if (li
3800: 73 74 3f 20 69 74 65 6d 73 29 20 69 74 65 6d 73 st? items) items
3810: 20 27 28 29 29 0a 09 09 09 09 09 09 09 09 20 28 '())......... (
3820: 69 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 74 if (list? itemst
3830: 61 62 6c 65 29 20 69 74 65 6d 73 74 61 62 6c 65 able) itemstable
3840: 20 27 28 29 29 29 29 0a 09 09 09 09 09 09 20 27 '())))....... '
3850: 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 0a have-procedure).
3860: 09 09 09 09 09 09 28 28 6f 72 20 28 6c 69 73 74 ......((or (list
3870: 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 3f 20 69 ? items)(list? i
3880: 74 65 6d 73 74 61 62 6c 65 29 29 20 3b 3b 20 63 temstable)) ;; c
3890: 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 09 20 28 alc now....... (
38a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
38b0: 20 34 20 22 69 74 65 6d 73 20 61 6e 64 20 69 74 4 "items and it
38c0: 65 6d 73 74 61 62 6c 65 20 61 72 65 20 6c 69 73 emstable are lis
38d0: 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c 6e 22 0a ts, calc now\n".
38e0: 09 09 09 09 09 09 09 20 20 20 20 20 20 22 20 20 ....... "
38f0: 20 20 69 74 65 6d 73 3a 20 22 20 69 74 65 6d 73 items: " items
3900: 20 22 20 69 74 65 6d 73 74 61 62 6c 65 3a 20 22 " itemstable: "
3910: 20 69 74 65 6d 73 74 61 62 6c 65 29 0a 09 09 09 itemstable)....
3920: 09 09 09 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 ... (items:get-i
3930: 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 tems-from-config
3940: 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 09 09 09 config)).......
3950: 28 65 6c 73 65 20 23 66 29 29 29 20 20 20 20 20 (else #f)))
3960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3970: 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 69 74 65 ;; not ite
3980: 72 61 74 65 64 0a 09 09 09 09 09 20 20 20 20 20 rated......
3990: 23 66 20 20 20 20 20 20 3b 3b 20 69 74 65 6d 73 #f ;; items
39a0: 64 61 74 20 35 0a 09 09 09 09 09 20 20 20 20 20 dat 5......
39b0: 23 66 20 20 20 20 20 20 3b 3b 20 73 70 61 72 65 #f ;; spare
39c0: 20 2d 20 75 73 65 64 20 66 6f 72 20 69 74 65 6d - used for item
39d0: 2d 70 61 74 68 0a 09 09 09 09 09 20 20 20 20 20 -path......
39e0: 29 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 ))).. (for-ea
39f0: 63 68 20 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 ch .. (lambd
3a00: 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 20 20 20 a (waiton)..
3a10: 20 20 20 28 69 66 20 28 61 6e 64 20 77 61 69 74 (if (and wait
3a20: 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 on (not (member
3a30: 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 waiton test-name
3a40: 73 29 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e s)))... (begin
3a50: 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 72 65 ... (set! re
3a60: 71 75 69 72 65 64 2d 74 65 73 74 73 20 28 63 6f quired-tests (co
3a70: 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 75 69 72 ns waiton requir
3a80: 65 64 2d 74 65 73 74 73 29 29 0a 09 09 20 20 20 ed-tests))...
3a90: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
3aa0: 65 73 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 es (cons waiton
3ab0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 29 29 20 test-names)))))
3ac0: 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 65 6e 64 ;; was an append
3ad0: 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a 09 20 20 , now a cons..
3ae0: 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 20 20 20 waitons)..
3af0: 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 (let ((remtests
3b00: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
3b10: 74 65 73 20 28 61 70 70 65 6e 64 20 77 61 69 74 tes (append wait
3b20: 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 20 20 20 ons tal))))..
3b30: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
3b40: 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 0a 09 09 l? remtests))...
3b50: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 72 65 6d (loop (car rem
3b60: 74 65 73 74 73 29 28 63 64 72 20 72 65 6d 74 65 tests)(cdr remte
3b70: 73 74 73 29 29 29 29 29 29 29 0a 0a 20 20 20 20 sts)))))))..
3b80: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
3b90: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 required-tests))
3ba0: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
3bb0: 6e 66 6f 20 31 20 22 41 64 64 69 6e 67 20 22 20 nfo 1 "Adding "
3bc0: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 22 required-tests "
3bd0: 20 74 6f 20 74 68 65 20 72 75 6e 20 71 75 65 75 to the run queu
3be0: 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e 4f 54 45 e")). ;; NOTE
3bf0: 3a 20 74 68 65 73 65 20 61 72 65 20 61 6c 6c 20 : these are all
3c00: 70 61 72 65 6e 74 20 74 65 73 74 73 2c 20 69 74 parent tests, it
3c10: 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 78 70 61 ems are not expa
3c20: 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 20 28 64 nded yet.. (d
3c30: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
3c40: 34 20 22 74 65 73 74 2d 72 65 63 6f 72 64 73 3d 4 "test-records=
3c50: 22 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 " (hash-table->a
3c60: 6c 69 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 list test-record
3c70: 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 72 s)). (let ((r
3c80: 65 67 6c 65 6e 20 28 61 6e 79 2d 3e 6e 75 6d 62 eglen (any->numb
3c90: 65 72 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f er (configf:loo
3ca0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
3cb0: 22 73 65 74 75 70 22 20 22 72 75 6e 71 75 65 75 "setup" "runqueu
3cc0: 65 22 29 29 29 29 0a 20 20 20 20 20 20 28 69 66 e")))). (if
3cd0: 20 72 65 67 6c 65 6e 0a 09 20 20 28 72 75 6e 73 reglen.. (runs
3ce0: 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 :run-tests-queue
3cf0: 2d 6e 65 77 20 20 20 20 20 72 75 6e 2d 69 64 20 -new run-id
3d00: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 runname test-rec
3d10: 6f 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 ords keyvallst f
3d20: 6c 61 67 73 20 74 65 73 74 2d 70 61 74 74 73 20 lags test-patts
3d30: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 72 required-tests r
3d40: 65 67 6c 65 6e 29 0a 09 20 20 28 72 75 6e 73 3a eglen).. (runs:
3d50: 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 2d run-tests-queue-
3d60: 63 6c 61 73 73 69 63 20 72 75 6e 2d 69 64 20 72 classic run-id r
3d70: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f unname test-reco
3d80: 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 20 66 6c rds keyvallst fl
3d90: 61 67 73 20 74 65 73 74 2d 70 61 74 74 73 20 72 ags test-patts r
3da0: 65 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 29 equired-tests)))
3db0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
3dc0: 74 2d 69 6e 66 6f 20 34 20 22 41 6c 6c 20 64 6f t-info 4 "All do
3dd0: 6e 65 20 62 79 20 68 65 72 65 22 29 29 29 0a 0a ne by here")))..
3de0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 (define (runs:ca
3df0: 6c 63 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 lc-fails prereqs
3e00: 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c -not-met). (fil
3e10: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 ter (lambda (tes
3e20: 74 29 0a 09 20 20 20 20 28 61 6e 64 20 28 76 65 t).. (and (ve
3e30: 63 74 6f 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e ctor? test) ;; n
3e40: 6f 74 20 28 73 74 72 69 6e 67 3f 20 74 65 73 74 ot (string? test
3e50: 29 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 64 ))... (equal? (d
3e60: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
3e70: 20 74 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 test) "COMPLETE
3e80: 44 22 29 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d D")... (not (mem
3e90: 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ber (db:test-get
3ea0: 2d 73 74 61 74 75 73 20 74 65 73 74 29 0a 09 09 -status test)...
3eb0: 09 20 20 20 20 20 20 27 28 22 50 41 53 53 22 20 . '("PASS"
3ec0: 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 "WARN" "CHECK" "
3ed0: 57 41 49 56 45 44 22 20 22 53 4b 49 50 22 29 29 WAIVED" "SKIP"))
3ee0: 29 29 29 0a 09 20 20 70 72 65 72 65 71 73 2d 6e ))).. prereqs-n
3ef0: 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e ot-met))..(defin
3f00: 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 e (runs:calc-not
3f10: 2d 63 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 -completed prere
3f20: 71 73 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 qs-not-met). (f
3f30: 69 6c 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 ilter. (lambda
3f40: 20 28 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e (t). (or (n
3f50: 6f 74 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a ot (vector? t)).
3f60: 09 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 . (not (equal? "
3f70: 43 4f 4d 50 4c 45 54 45 44 22 20 28 64 62 3a 74 COMPLETED" (db:t
3f80: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 est-get-state t)
3f90: 29 29 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d )))). prereqs-
3fa0: 6e 6f 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 not-met))..(defi
3fb0: 6e 65 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d ne (runs:pretty-
3fc0: 73 74 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 6d string lst). (m
3fd0: 61 70 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 ap (lambda (t)..
3fe0: 20 28 69 66 20 28 6e 6f 74 20 28 76 65 63 74 6f (if (not (vecto
3ff0: 72 3f 20 74 29 29 0a 09 20 20 20 20 20 28 63 6f r? t)).. (co
4000: 6e 63 20 74 29 0a 09 20 20 20 20 20 28 63 6f 6e nc t).. (con
4010: 63 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 c (db:test-get-t
4020: 65 73 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 estname t) ":" (
4030: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
4040: 65 20 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 e t) "/" (db:tes
4050: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 t-get-status t))
4060: 29 29 0a 20 20 20 20 20 20 20 6c 73 74 29 29 0a )). lst)).
4070: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6d .(define (runs:m
4080: 61 6b 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 ake-full-test-na
4090: 6d 65 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d me testname item
40a0: 70 61 74 68 29 0a 20 20 28 69 66 20 28 65 71 75 path). (if (equ
40b0: 61 6c 3f 20 69 74 65 6d 70 61 74 68 20 22 22 29 al? itempath "")
40c0: 20 74 65 73 74 6e 61 6d 65 20 28 63 6f 6e 63 20 testname (conc
40d0: 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
40e0: 6d 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e mpath)))..(defin
40f0: 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 e (runs:queue-ne
4100: 78 74 2d 68 65 64 20 74 61 6c 20 72 65 67 20 6e xt-hed tal reg n
4110: 20 72 65 67 66 75 6c 29 0a 20 20 28 69 66 20 72 regful). (if r
4120: 65 67 66 75 6c 0a 20 20 20 20 20 20 28 69 66 20 egful. (if
4130: 28 6e 75 6c 6c 3f 20 72 65 67 29 20 3b 3b 20 64 (null? reg) ;; d
4140: 6f 65 73 6e 27 74 20 6d 61 6b 65 20 73 65 6e 73 oesn't make sens
4150: 65 2c 20 74 68 69 73 20 69 73 20 70 72 6f 62 61 e, this is proba
4160: 62 6c 79 20 4e 4f 54 20 74 68 65 20 70 72 6f 62 bly NOT the prob
4170: 6c 65 6d 20 6f 66 20 74 68 65 20 63 61 72 0a 09 lem of the car..
4180: 20 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 28 (car tal).. (
4190: 63 61 72 20 72 65 67 29 29 0a 20 20 20 20 20 20 car reg)).
41a0: 28 63 61 72 20 74 61 6c 29 29 29 0a 0a 28 64 65 (car tal)))..(de
41b0: 66 69 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 fine (runs:queue
41c0: 2d 6e 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 -next-tal tal re
41d0: 67 20 6e 20 72 65 67 66 75 6c 29 0a 20 20 28 69 g n regful). (i
41e0: 66 20 72 65 67 66 75 6c 0a 20 20 20 20 20 20 74 f regful. t
41f0: 61 6c 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 al. (let ((
4200: 6e 65 77 74 61 6c 20 28 63 64 72 20 74 61 6c 29 newtal (cdr tal)
4210: 29 29 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 6e ))..(if (null? n
4220: 65 77 74 61 6c 29 0a 09 20 20 20 20 72 65 67 0a ewtal).. reg.
4230: 09 20 20 20 20 6e 65 77 74 61 6c 0a 09 20 20 20 . newtal..
4240: 20 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ))))..(define (
4250: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
4260: 72 65 67 20 74 61 6c 20 72 65 67 20 6e 20 72 65 reg tal reg n re
4270: 67 66 75 6c 29 0a 20 20 28 69 66 20 72 65 67 66 gful). (if regf
4280: 75 6c 0a 20 20 20 20 20 20 28 63 64 72 20 72 65 ul. (cdr re
4290: 67 29 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 g). (if (eq
42a0: 3f 20 28 6c 65 6e 67 74 68 20 74 61 6c 29 20 31 ? (length tal) 1
42b0: 29 0a 09 20 20 27 28 29 0a 09 20 20 72 65 67 29 ).. '().. reg)
42c0: 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 ))..(include "ru
42d0: 6e 2d 74 65 73 74 73 2d 71 75 65 75 65 2d 63 6c n-tests-queue-cl
42e0: 61 73 73 69 63 2e 73 63 6d 22 29 0a 28 69 6e 63 assic.scm").(inc
42f0: 6c 75 64 65 20 22 72 75 6e 2d 74 65 73 74 73 2d lude "run-tests-
4300: 71 75 65 75 65 2d 6e 65 77 2e 73 63 6d 22 29 0a queue-new.scm").
4310: 0a 3b 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 20 .;; parent-test
4320: 69 73 20 74 68 65 72 65 20 61 73 20 61 20 70 6c is there as a pl
4330: 61 63 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 68 aceholder for wh
4340: 65 6e 20 70 61 72 65 6e 74 2d 74 65 73 74 73 20 en parent-tests
4350: 63 61 6e 20 62 65 20 72 75 6e 20 61 73 20 61 20 can be run as a
4360: 73 65 74 75 70 20 73 74 65 70 0a 28 64 65 66 69 setup step.(defi
4370: 6e 65 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e ne (run:test run
4380: 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 -id run-info key
4390: 2d 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 -vals runname te
43a0: 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 20 st-record flags
43b0: 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 20 20 3b parent-test). ;
43c0: 3b 20 41 6c 6c 20 74 68 65 73 65 20 76 61 72 73 ; All these vars
43d0: 20 6d 69 67 68 74 20 62 65 20 72 65 66 65 72 65 might be refere
43e0: 6e 63 65 64 20 62 79 20 74 68 65 20 74 65 73 74 nced by the test
43f0: 63 6f 6e 66 69 67 20 66 69 6c 65 20 72 65 61 64 config file read
4400: 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 er. (let* ((tes
4410: 74 2d 6e 61 6d 65 20 20 20 20 28 74 65 73 74 73 t-name (tests
4420: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
4430: 65 73 74 6e 61 6d 65 20 20 20 74 65 73 74 2d 72 estname test-r
4440: 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d ecord)).. (test-
4450: 77 61 69 74 6f 6e 73 20 28 74 65 73 74 73 3a 74 waitons (tests:t
4460: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 estqueue-get-wai
4470: 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 63 tons test-rec
4480: 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 63 6f ord)).. (test-co
4490: 6e 66 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 nf (tests:tes
44a0: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 tqueue-get-testc
44b0: 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 onfig test-recor
44c0: 64 29 29 0a 09 20 28 69 74 65 6d 64 61 74 20 20 d)).. (itemdat
44d0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
44e0: 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 ueue-get-itemdat
44f0: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
4500: 29 0a 09 20 28 74 65 73 74 2d 70 61 74 68 20 20 ).. (test-path
4510: 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 (conc *toppath
4520: 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 * "/tests/" test
4530: 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 6f 75 6c 64 -name)) ;; could
4540: 20 75 73 65 20 74 65 73 74 73 3a 67 65 74 2d 74 use tests:get-t
4550: 65 73 74 63 6f 6e 66 69 67 20 68 65 72 65 20 2e estconfig here .
4560: 2e 2e 0a 09 20 28 66 6f 72 63 65 20 20 20 20 20 .... (force
4570: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
4580: 65 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 ef/default flags
4590: 20 22 2d 66 6f 72 63 65 22 20 23 66 29 29 0a 09 "-force" #f))..
45a0: 20 28 72 65 72 75 6e 20 20 20 20 20 20 20 20 28 (rerun (
45b0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
45c0: 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 efault flags "-r
45d0: 65 72 75 6e 22 20 23 66 29 29 0a 09 20 28 6b 65 erun" #f)).. (ke
45e0: 65 70 67 6f 69 6e 67 20 20 20 20 28 68 61 73 68 epgoing (hash
45f0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
4600: 6c 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 lt flags "-keepg
4610: 6f 69 6e 67 22 20 23 66 29 29 0a 09 20 28 69 74 oing" #f)).. (it
4620: 65 6d 2d 70 61 74 68 20 20 20 20 20 22 22 29 0a em-path "").
4630: 09 20 28 64 62 20 20 20 20 20 20 20 20 20 20 20 . (db
4640: 23 66 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a #f)). (debug:
4650: 70 72 69 6e 74 20 34 0a 09 09 20 22 74 65 73 74 print 4... "test
4660: 2d 63 6f 6e 66 69 67 3a 20 22 20 28 68 61 73 68 -config: " (hash
4670: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 -table->alist te
4680: 73 74 2d 63 6f 6e 66 29 0a 09 09 20 22 5c 6e 20 st-conf)... "\n
4690: 20 20 69 74 65 6d 64 61 74 3a 20 22 20 69 74 65 itemdat: " ite
46a0: 6d 64 61 74 0a 09 09 20 29 0a 20 20 20 20 3b 3b mdat... ). ;;
46b0: 20 73 65 74 74 69 6e 67 20 69 74 65 6d 64 61 74 setting itemdat
46c0: 20 74 6f 20 61 20 6c 69 73 74 20 69 66 20 69 74 to a list if it
46d0: 20 69 73 20 23 66 0a 20 20 20 20 28 69 66 20 28 is #f. (if (
46e0: 6e 6f 74 20 69 74 65 6d 64 61 74 29 28 73 65 74 not itemdat)(set
46f0: 21 20 69 74 65 6d 64 61 74 20 27 28 29 29 29 0a ! itemdat '())).
4700: 20 20 20 20 28 73 65 74 21 20 69 74 65 6d 2d 70 (set! item-p
4710: 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e ath (item-list->
4720: 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a 20 path itemdat)).
4730: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
4740: 32 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 2 "Attempting to
4750: 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 74 launch test " t
4760: 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 est-name (if (eq
4770: 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 ual? item-path "
4780: 2f 22 29 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 /") "/" item-pat
4790: 68 29 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 h)). (setenv
47a0: 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 "MT_TEST_NAME" t
47b0: 65 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 est-name) ;; .
47c0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
47d0: 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 NNAME" runname
47e0: 29 0a 20 20 20 20 28 73 65 74 2d 6d 65 67 61 74 ). (set-megat
47f0: 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e est-env-vars run
4800: 2d 69 64 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 -id inrunname: r
4810: 75 6e 6e 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 unname) ;; these
4820: 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 may be needed b
4830: 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 y the launching
4840: 70 72 6f 63 65 73 73 0a 20 20 20 20 28 63 68 61 process. (cha
4850: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 nge-directory *t
4860: 6f 70 70 61 74 68 2a 29 0a 0a 20 20 20 20 3b 3b oppath*).. ;;
4870: 20 48 65 72 65 20 69 73 20 77 68 65 72 65 20 74 Here is where t
4880: 68 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 he test_meta tab
4890: 6c 65 20 69 73 20 62 65 73 74 20 75 70 64 61 74 le is best updat
48a0: 65 64 0a 20 20 20 20 3b 3b 20 59 65 73 2c 20 61 ed. ;; Yes, a
48b0: 6e 6f 74 68 65 72 20 75 73 65 20 6f 66 20 61 20 nother use of a
48c0: 67 6c 6f 62 61 6c 20 66 6f 72 20 63 61 63 68 69 global for cachi
48d0: 6e 67 2e 20 4e 65 65 64 20 61 20 62 65 74 74 65 ng. Need a bette
48e0: 72 20 77 61 79 3f 0a 20 20 20 20 28 69 66 20 28 r way?. (if (
48f0: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
4900: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 65 73 ref/default *tes
4910: 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 t-meta-updated*
4920: 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 0a 20 test-name #f)).
4930: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 (begin..
4940: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
4950: 74 21 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 t! *test-meta-up
4960: 64 61 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 dated* test-name
4970: 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 #t).
4980: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
4990: 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 t_meta test-name
49a0: 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 test-conf))).
49b0: 20 20 0a 20 20 20 20 3b 3b 20 28 6c 61 6d 62 64 . ;; (lambd
49c0: 61 20 28 69 74 65 6d 64 61 74 29 20 3b 3b 3b 20 a (itemdat) ;;;
49d0: 28 28 72 69 70 65 6e 65 73 73 20 22 6f 76 65 72 ((ripeness "over
49e0: 72 69 70 65 22 29 20 28 74 65 6d 70 65 72 61 74 ripe") (temperat
49f0: 75 72 65 20 22 63 6f 6f 6c 22 29 20 28 73 65 61 ure "cool") (sea
4a00: 73 6f 6e 20 22 73 75 6d 6d 65 72 22 29 29 0a 20 son "summer")).
4a10: 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 (let* ((new-t
4a20: 65 73 74 2d 70 61 74 68 20 28 73 74 72 69 6e 67 est-path (string
4a30: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 63 6f -intersperse (co
4a40: 6e 73 20 74 65 73 74 2d 70 61 74 68 20 28 6d 61 ns test-path (ma
4a50: 70 20 63 61 64 72 20 69 74 65 6d 64 61 74 29 29 p cadr itemdat))
4a60: 20 22 2f 22 29 29 0a 09 20 20 20 28 6e 65 77 2d "/")).. (new-
4a70: 74 65 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 test-name (if (e
4a80: 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 qual? item-path
4a90: 22 22 29 20 74 65 73 74 2d 6e 61 6d 65 20 28 63 "") test-name (c
4aa0: 6f 6e 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f onc test-name "/
4ab0: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 20 3b " item-path))) ;
4ac0: 3b 20 6a 75 73 74 20 6e 65 65 64 20 69 74 20 74 ; just need it t
4ad0: 6f 20 62 65 20 75 6e 69 71 75 65 0a 09 20 20 20 o be unique..
4ae0: 28 74 65 73 74 2d 69 64 20 20 20 20 20 20 20 28 (test-id (
4af0: 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 cdb:remote-run d
4b00: 62 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 23 66 b:get-test-id #f
4b10: 20 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 run-id test-na
4b20: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 me item-path))..
4b30: 20 20 20 28 74 65 73 74 64 61 74 20 20 20 20 20 (testdat
4b40: 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d (cdb:get-test-
4b50: 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 info-by-id *runr
4b60: 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 emote* test-id))
4b70: 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ). (if (not
4b80: 20 74 65 73 74 64 61 74 29 0a 09 20 20 28 62 65 testdat).. (be
4b90: 67 69 6e 0a 09 20 20 20 20 3b 3b 20 65 6e 73 75 gin.. ;; ensu
4ba0: 72 65 20 74 68 61 74 20 74 68 65 20 70 61 74 68 re that the path
4bb0: 20 65 78 69 73 74 73 20 62 65 66 6f 72 65 20 72 exists before r
4bc0: 65 67 69 73 74 65 72 69 6e 67 20 74 68 65 20 74 egistering the t
4bd0: 65 73 74 0a 09 20 20 20 20 3b 3b 20 4e 4f 50 45 est.. ;; NOPE
4be0: 3a 20 43 61 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 : Cannot! Don't
4bf0: 6b 6e 6f 77 20 79 65 74 20 77 68 69 63 68 20 64 know yet which d
4c00: 69 73 6b 20 61 72 65 61 20 77 69 6c 6c 20 62 65 isk area will be
4c10: 20 61 73 73 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 assigned......
4c20: 20 20 20 3b 3b 20 28 73 79 73 74 65 6d 20 28 63 ;; (system (c
4c30: 6f 6e 63 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 onc "mkdir -p "
4c40: 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 29 29 0a new-test-path)).
4c50: 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 . ;;.. ;;
4c60: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
4c70: 74 65 73 74 73 3a 72 65 67 69 73 74 65 72 2d 74 tests:register-t
4c80: 65 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 est db run-id te
4c90: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
4ca0: 68 29 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 h).. ;;..
4cb0: 3b 3b 20 4e 42 2f 2f 20 66 6f 72 20 74 68 65 20 ;; NB// for the
4cc0: 61 62 6f 76 65 20 6c 69 6e 65 2e 20 49 20 77 61 above line. I wa
4cd0: 6e 74 20 74 68 65 20 74 65 73 74 20 74 6f 20 62 nt the test to b
4ce0: 65 20 72 65 67 69 73 74 65 72 65 64 20 6c 6f 6e e registered lon
4cf0: 67 20 62 65 66 6f 72 65 20 74 68 69 73 20 72 6f g before this ro
4d00: 75 74 69 6e 65 20 67 65 74 73 20 63 61 6c 6c 65 utine gets calle
4d10: 64 21 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 d!.. ;;..
4d20: 28 73 65 74 21 20 74 65 73 74 2d 69 64 20 28 6f (set! test-id (o
4d30: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
4d40: 3a 67 65 74 2d 74 65 73 74 2d 69 64 20 64 62 20 :get-test-id db
4d50: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4d60: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 item-path))..
4d70: 20 20 28 69 66 20 28 6e 6f 74 20 74 65 73 74 2d (if (not test-
4d80: 69 64 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 id)...(begin...
4d90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
4da0: 22 57 41 52 4e 3a 20 54 65 73 74 20 6e 6f 74 20 "WARN: Test not
4db0: 70 72 65 2d 63 72 65 61 74 65 64 3f 20 74 65 73 pre-created? tes
4dc0: 74 2d 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 t-name=" test-na
4dd0: 6d 65 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d me ", item-path=
4de0: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 2c 20 72 " item-path ", r
4df0: 75 6e 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a un-id=" run-id).
4e00: 09 09 20 20 28 63 64 62 3a 74 65 73 74 73 2d 72 .. (cdb:tests-r
4e10: 65 67 69 73 74 65 72 2d 74 65 73 74 20 2a 72 75 egister-test *ru
4e20: 6e 72 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 nremote* run-id
4e30: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
4e40: 61 74 68 29 0a 09 09 20 20 28 73 65 74 21 20 74 ath)... (set! t
4e50: 65 73 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e est-id (open-run
4e60: 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 -close db:get-te
4e70: 73 74 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 20 st-id db run-id
4e80: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
4e90: 61 74 68 29 29 29 29 0a 09 20 20 20 20 28 64 65 ath)))).. (de
4ea0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
4eb0: 20 22 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 "test-id=" test
4ec0: 2d 69 64 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 -id ", run-id="
4ed0: 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e run-id ", test-n
4ee0: 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 ame=" test-name
4ef0: 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 ", item-path=\""
4f00: 20 69 74 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 item-path "\"")
4f10: 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 74 .. (set! test
4f20: 64 61 74 20 28 63 64 62 3a 67 65 74 2d 74 65 73 dat (cdb:get-tes
4f30: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
4f40: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
4f50: 29 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 28 )))). (if (
4f60: 6e 6f 74 20 74 65 73 74 64 61 74 29 20 3b 3b 20 not testdat) ;;
4f70: 73 68 6f 75 6c 64 20 4e 4f 54 20 68 61 70 70 65 should NOT happe
4f80: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
4f90: 74 20 30 20 22 45 52 52 4f 52 3a 20 66 61 69 6c t 0 "ERROR: fail
4fa0: 65 64 20 74 6f 20 67 65 74 20 74 65 73 74 20 72 ed to get test r
4fb0: 65 63 6f 72 64 20 66 6f 72 20 74 65 73 74 2d 69 ecord for test-i
4fc0: 64 20 22 20 74 65 73 74 2d 69 64 29 29 0a 20 20 d " test-id)).
4fd0: 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d 69 (set! test-i
4fe0: 64 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 d (db:test-get-i
4ff0: 64 20 74 65 73 74 64 61 74 29 29 0a 20 20 20 20 d testdat)).
5000: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
5010: 6f 72 79 20 74 65 73 74 2d 70 61 74 68 29 0a 20 ory test-path).
5020: 20 20 20 20 20 28 63 61 73 65 20 28 69 66 20 66 (case (if f
5030: 6f 72 63 65 20 3b 3b 20 28 61 72 67 73 3a 67 65 orce ;; (args:ge
5040: 74 2d 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a t-arg "-force").
5050: 09 09 27 4e 4f 54 5f 53 54 41 52 54 45 44 0a 09 ..'NOT_STARTED..
5060: 09 28 69 66 20 74 65 73 74 64 61 74 0a 09 09 20 .(if testdat...
5070: 20 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 (string->symb
5080: 6f 6c 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 ol (test:get-sta
5090: 74 65 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 te testdat))...
50a0: 20 20 20 27 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 'failed-to-in
50b0: 73 65 72 74 29 29 0a 09 28 28 66 61 69 6c 65 64 sert))..((failed
50c0: 2d 74 6f 2d 69 6e 73 65 72 74 29 0a 09 20 28 64 -to-insert).. (d
50d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
50e0: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 69 ROR: Failed to i
50f0: 6e 73 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 nsert the record
5100: 20 69 6e 74 6f 20 74 68 65 20 64 62 22 29 29 0a into the db")).
5110: 09 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 43 .((NOT_STARTED C
5120: 4f 4d 50 4c 45 54 45 44 20 44 45 4c 45 54 45 44 OMPLETED DELETED
5130: 29 0a 09 20 28 6c 65 74 20 28 28 72 75 6e 66 6c ).. (let ((runfl
5140: 61 67 20 23 66 29 29 0a 09 20 20 20 28 63 6f 6e ag #f)).. (con
5150: 64 0a 09 20 20 20 20 3b 3b 20 2d 66 6f 72 63 65 d.. ;; -force
5160: 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 , run no matter
5170: 77 68 61 74 0a 09 20 20 20 20 28 66 6f 72 63 65 what.. (force
5180: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
5190: 74 29 29 0a 09 20 20 20 20 3b 3b 20 4e 4f 54 5f t)).. ;; NOT_
51a0: 53 54 41 52 54 45 44 2c 20 72 75 6e 20 6e 6f 20 STARTED, run no
51b0: 6d 61 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 matter what..
51c0: 20 28 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a ((member (test:
51d0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
51e0: 74 29 20 27 28 22 44 45 4c 45 54 45 44 22 20 22 t) '("DELETED" "
51f0: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 29 28 73 NOT_STARTED"))(s
5200: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 29 et! runflag #t))
5210: 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 2d 72 65 .. ;; not -re
5220: 72 75 6e 20 61 6e 64 20 50 41 53 53 2c 20 57 41 run and PASS, WA
5230: 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 64 6f 20 RN or CHECK, do
5240: 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 28 61 6e no run.. ((an
5250: 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 72 75 6e d (or (not rerun
5260: 29 0a 09 09 20 20 20 20 20 20 6b 65 65 70 67 6f )... keepgo
5270: 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 65 71 75 ing)... ;; Requ
5280: 69 72 65 20 74 6f 20 66 6f 72 63 65 20 72 65 2d ire to force re-
5290: 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 54 45 run for COMPLETE
52a0: 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e 67 2a 20 D or *anything*
52b0: 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f 72 20 43 + PASS,WARN or C
52c0: 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 28 6d 65 HECK... (or (me
52d0: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
52e0: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 tatus testdat) '
52f0: 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 22 ("PASS" "WARN" "
5300: 43 48 45 43 4b 22 20 22 53 4b 49 50 22 29 29 0a CHECK" "SKIP")).
5310: 09 09 20 20 20 20 20 20 28 6d 65 6d 62 65 72 20 .. (member
5320: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
5330: 20 74 65 73 74 64 61 74 29 20 27 28 22 43 4f 4d testdat) '("COM
5340: 50 4c 45 54 45 44 22 29 29 29 29 20 0a 09 20 20 PLETED")))) ..
5350: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5360: 69 6e 66 6f 20 32 20 22 72 75 6e 6e 69 6e 67 20 info 2 "running
5370: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
5380: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 22 "/" item-path "
5390: 20 73 75 70 70 72 65 73 73 65 64 20 61 73 20 69 suppressed as i
53a0: 74 20 69 73 20 22 20 28 74 65 73 74 3a 67 65 74 t is " (test:get
53b0: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 20 -state testdat)
53c0: 22 20 61 6e 64 20 22 20 28 74 65 73 74 3a 67 65 " and " (test:ge
53d0: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
53e0: 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 )).. (set! r
53f0: 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 unflag #f))..
5400: 20 3b 3b 20 2d 72 65 72 75 6e 20 61 6e 64 20 73 ;; -rerun and s
5410: 74 61 74 75 73 20 69 73 20 6f 6e 65 20 6f 66 20 tatus is one of
5420: 74 68 65 20 73 70 65 63 69 66 65 64 2c 20 72 75 the specifed, ru
5430: 6e 20 69 74 0a 09 20 20 20 20 28 28 61 6e 64 20 n it.. ((and
5440: 72 65 72 75 6e 0a 09 09 20 20 28 6c 65 74 2a 20 rerun... (let*
5450: 28 28 72 65 72 75 6e 6c 73 74 20 20 20 28 73 74 ((rerunlst (st
5460: 72 69 6e 67 2d 73 70 6c 69 74 20 72 65 72 75 6e ring-split rerun
5470: 20 22 2c 22 29 29 0a 09 09 09 20 28 6d 75 73 74 ",")).... (must
5480: 2d 72 65 72 75 6e 20 28 6d 65 6d 62 65 72 20 28 -rerun (member (
5490: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
54a0: 74 65 73 74 64 61 74 29 20 72 65 72 75 6e 6c 73 testdat) rerunls
54b0: 74 29 29 29 0a 09 09 20 20 20 20 28 64 65 62 75 t)))... (debu
54c0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 22 g:print-info 3 "
54d0: 2d 72 65 72 75 6e 20 6c 69 73 74 3a 20 22 20 72 -rerun list: " r
54e0: 65 72 75 6e 20 22 2c 20 74 65 73 74 2d 73 74 61 erun ", test-sta
54f0: 74 75 73 3a 20 22 20 28 74 65 73 74 3a 67 65 74 tus: " (test:get
5500: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
5510: 22 2c 20 6d 75 73 74 2d 72 65 72 75 6e 3a 20 22 ", must-rerun: "
5520: 20 6d 75 73 74 2d 72 65 72 75 6e 29 0a 09 09 20 must-rerun)...
5530: 20 20 20 6d 75 73 74 2d 72 65 72 75 6e 29 29 0a must-rerun)).
5540: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
5550: 6e 74 2d 69 6e 66 6f 20 32 20 22 52 65 72 75 6e nt-info 2 "Rerun
5560: 20 66 6f 72 63 65 64 20 66 6f 72 20 74 65 73 74 forced for test
5570: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 " test-name "/"
5580: 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 item-path)..
5590: 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 (set! runflag
55a0: 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 2d 6b 65 #t)).. ;; -ke
55b0: 65 70 67 6f 69 6e 67 2c 20 64 6f 20 6e 6f 74 20 epgoing, do not
55c0: 72 65 72 75 6e 20 46 41 49 4c 0a 09 20 20 20 20 rerun FAIL..
55d0: 28 28 61 6e 64 20 6b 65 65 70 67 6f 69 6e 67 0a ((and keepgoing.
55e0: 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 .. (member (tes
55f0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
5600: 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 29 29 tdat) '("FAIL"))
5610: 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 ).. (set! ru
5620: 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 20 nflag #f))..
5630: 28 28 61 6e 64 20 28 6e 6f 74 20 72 65 72 75 6e ((and (not rerun
5640: 29 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 28 74 )... (member (t
5650: 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 est:get-status t
5660: 65 73 74 64 61 74 29 20 27 28 22 46 41 49 4c 22 estdat) '("FAIL"
5670: 20 22 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 "n/a")))..
5680: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 (set! runflag #t
5690: 29 29 0a 09 20 20 20 20 28 65 6c 73 65 20 28 73 )).. (else (s
56a0: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 et! runflag #f))
56b0: 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
56c0: 6e 74 20 36 20 22 52 55 4e 4e 49 4e 47 20 3d 3e nt 6 "RUNNING =>
56d0: 20 72 75 6e 66 6c 61 67 3a 20 22 20 72 75 6e 66 runflag: " runf
56e0: 6c 61 67 20 22 20 53 54 41 54 45 3a 20 22 20 28 lag " STATE: " (
56f0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
5700: 65 73 74 64 61 74 29 20 22 20 53 54 41 54 55 53 estdat) " STATUS
5710: 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 : " (test:get-st
5720: 61 74 75 73 20 74 65 73 74 64 61 74 29 29 0a 09 atus testdat))..
5730: 20 20 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 66 (if (not runf
5740: 6c 61 67 29 0a 09 20 20 20 20 20 20 20 28 69 66 lag).. (if
5750: 20 28 6e 6f 74 20 70 61 72 65 6e 74 2d 74 65 73 (not parent-tes
5760: 74 29 0a 09 09 20 20 20 28 64 65 62 75 67 3a 70 t)... (debug:p
5770: 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 4e 6f rint 1 "NOTE: No
5780: 74 20 73 74 61 72 74 69 6e 67 20 74 65 73 74 20 t starting test
5790: 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 " new-test-name
57a0: 22 20 61 73 20 69 74 20 69 73 20 73 74 61 74 65 " as it is state
57b0: 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 \"" (test:get-s
57c0: 74 61 74 65 20 74 65 73 74 64 61 74 29 20 0a 09 tate testdat) ..
57d0: 09 09 09 22 5c 22 20 61 6e 64 20 73 74 61 74 75 ..."\" and statu
57e0: 73 20 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d s \"" (test:get-
57f0: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
5800: 22 5c 22 2c 20 75 73 65 20 2d 72 65 72 75 6e 20 "\", use -rerun
5810: 5c 22 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 \"" (test:get-st
5820: 61 74 75 73 20 74 65 73 74 64 61 74 29 0a 20 20 atus testdat).
5830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 5c "\
5850: 22 20 6f 72 20 2d 66 6f 72 63 65 20 74 6f 20 6f " or -force to o
5860: 76 65 72 72 69 64 65 22 29 29 0a 09 20 20 20 20 verride"))..
5870: 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 4e 6f 20 6c ;; NOTE: No l
5880: 6f 6e 67 65 72 20 62 65 20 63 68 65 63 6b 69 6e onger be checkin
5890: 67 20 70 72 65 72 65 71 75 69 73 69 74 65 73 20 g prerequisites
58a0: 68 65 72 65 21 20 57 69 6c 6c 20 6e 65 76 65 72 here! Will never
58b0: 20 67 65 74 20 68 65 72 65 20 75 6e 6c 65 73 73 get here unless
58c0: 20 70 72 65 72 65 71 73 20 61 72 65 0a 09 20 20 prereqs are..
58d0: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 61 6c ;; al
58e0: 72 65 61 64 79 20 6d 65 74 2e 0a 09 20 20 20 20 ready met...
58f0: 20 20 20 3b 3b 20 54 68 69 73 20 77 6f 75 6c 64 ;; This would
5900: 20 62 65 20 61 20 67 72 65 61 74 20 70 6c 61 63 be a great plac
5910: 65 20 74 6f 20 64 6f 20 74 68 65 20 70 72 6f 63 e to do the proc
5920: 65 73 73 2d 66 6f 72 6b 0a 09 20 20 20 20 20 20 ess-fork..
5930: 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 (if (not (launc
5940: 68 2d 74 65 73 74 20 74 65 73 74 2d 69 64 20 72 h-test test-id r
5950: 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b un-id run-info k
5960: 65 79 2d 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 ey-vals runname
5970: 74 65 73 74 2d 63 6f 6e 66 20 74 65 73 74 2d 6e test-conf test-n
5980: 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 ame test-path it
5990: 65 6d 64 61 74 20 66 6c 61 67 73 29 29 0a 09 09 emdat flags))...
59a0: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
59b0: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
59c0: 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 Failed to launch
59d0: 20 74 68 65 20 74 65 73 74 2e 20 45 78 69 74 69 the test. Exiti
59e0: 6e 67 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f ng as soon as po
59f0: 73 73 69 62 6c 65 22 29 0a 09 09 20 20 20 20 20 ssible")...
5a00: 28 73 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 (set! *globalexi
5a10: 74 73 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a tstatus* 1) ;; .
5a20: 09 09 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d .. (process-
5a30: 73 69 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d signal (current-
5a40: 70 72 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e process-id) sign
5a50: 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 29 0a 09 28 al/kill))))))..(
5a60: 28 4b 49 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 (KILLED) .. (deb
5a70: 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 ug:print 1 "NOTE
5a80: 3a 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d : " new-test-nam
5a90: 65 20 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 e " is already r
5aa0: 75 6e 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 78 unning or was ex
5ab0: 70 6c 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 plictly killed,
5ac0: 75 73 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 use -force to la
5ad0: 75 6e 63 68 20 69 74 2e 22 29 29 0a 09 28 28 4c unch it."))..((L
5ae0: 41 55 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 4f AUNCHED REMOTEHO
5af0: 53 54 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 STSTART RUNNING)
5b00: 20 20 0a 09 20 28 69 66 20 28 3e 20 28 2d 20 28 .. (if (> (- (
5b10: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
5b20: 28 2b 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (+ (db:test-get-
5b30: 65 76 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 event_time testd
5b40: 61 74 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 at)..... (
5b50: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f db:test-get-run_
5b60: 64 75 72 61 74 69 6f 6e 20 74 65 73 74 64 61 74 duration testdat
5b70: 29 29 29 0a 09 09 36 30 30 29 20 3b 3b 20 69 2e )))...600) ;; i.
5b80: 65 2e 20 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 e. no update for
5b90: 20 6d 6f 72 65 20 74 68 61 6e 20 36 30 30 20 73 more than 600 s
5ba0: 65 63 6f 6e 64 73 0a 09 20 20 20 20 20 28 62 65 econds.. (be
5bb0: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 gin.. (deb
5bc0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN
5bd0: 49 4e 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 ING: Test " test
5be0: 2d 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 -name " appears
5bf0: 74 6f 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 to be dead. Forc
5c00: 69 6e 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 ing it to state
5c10: 49 4e 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 INCOMPLETE and s
5c20: 74 61 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 tatus STUCK/DEAD
5c30: 22 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 ").. (test
5c40: 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 s:test-set-statu
5c50: 73 21 20 74 65 73 74 2d 69 64 20 22 49 4e 43 4f s! test-id "INCO
5c60: 4d 50 4c 45 54 45 22 20 22 53 54 55 43 4b 2f 44 MPLETE" "STUCK/D
5c70: 45 41 44 22 20 22 54 65 73 74 20 69 73 20 73 74 EAD" "Test is st
5c80: 75 63 6b 20 6f 72 20 64 65 61 64 22 20 23 66 29 uck or dead" #f)
5c90: 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ).. (debug:p
5ca0: 72 69 6e 74 20 32 20 22 4e 4f 54 45 3a 20 22 20 rint 2 "NOTE: "
5cb0: 74 65 73 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 test-name " is a
5cc0: 6c 72 65 61 64 79 20 72 75 6e 6e 69 6e 67 22 29 lready running")
5cd0: 29 29 0a 09 28 65 6c 73 65 20 20 20 20 20 20 20 ))..(else
5ce0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
5cf0: 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f ERROR: Failed to
5d00: 20 6c 61 75 6e 63 68 20 74 65 73 74 20 22 20 6e launch test " n
5d10: 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 22 2e 20 ew-test-name ".
5d20: 55 6e 72 65 63 6f 67 6e 69 73 65 64 20 73 74 61 Unrecognised sta
5d30: 74 65 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 te " (test:get-s
5d40: 74 61 74 65 20 74 65 73 74 64 61 74 29 29 29 29 tate testdat))))
5d50: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
5d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
5da0: 20 45 4e 44 20 4f 46 20 4e 45 57 20 53 54 55 46 END OF NEW STUF
5db0: 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F.;;============
5dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
5e00: 69 6e 65 20 28 67 65 74 2d 64 69 72 2d 75 70 2d ine (get-dir-up-
5e10: 6e 20 64 69 72 20 2e 20 70 61 72 61 6d 73 29 20 n dir . params)
5e20: 0a 20 20 28 6c 65 74 20 28 28 64 70 61 72 74 73 . (let ((dparts
5e30: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
5e40: 64 69 72 20 22 2f 22 29 29 0a 09 28 63 6f 75 6e dir "/"))..(coun
5e50: 74 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 t (if (null? p
5e60: 61 72 61 6d 73 29 20 31 20 28 63 61 72 20 70 61 arams) 1 (car pa
5e70: 72 61 6d 73 29 29 29 29 0a 20 20 20 20 28 63 6f rams)))). (co
5e80: 6e 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 nc "/" (string-i
5e90: 6e 74 65 72 73 70 65 72 73 65 20 0a 09 20 20 20 ntersperse ..
5ea0: 20 20 20 20 28 74 61 6b 65 20 64 70 61 72 74 73 (take dparts
5eb0: 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 72 (- (length dpar
5ec0: 74 73 29 20 63 6f 75 6e 74 29 29 0a 09 20 20 20 ts) count))..
5ed0: 20 20 20 20 22 2f 22 29 29 29 29 0a 3b 3b 20 52 "/")))).;; R
5ee0: 65 6d 6f 76 65 20 72 75 6e 73 0a 3b 3b 20 66 69 emove runs.;; fi
5ef0: 65 6c 64 73 20 61 72 65 20 70 61 73 73 69 6e 67 elds are passing
5f00: 20 69 6e 20 74 68 72 6f 75 67 68 20 0a 3b 3b 20 in through .;;
5f10: 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 20 20 27 72 action:.;; 'r
5f20: 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 3b 20 20 20 emove-runs.;;
5f30: 20 27 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 'set-state-stat
5f40: 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f 2f 20 73 68 us.;;.;; NB// sh
5f50: 6f 75 6c 64 20 70 61 73 73 20 69 6e 20 6b 65 79 ould pass in key
5f60: 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 72 s?.;;.(define (r
5f70: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 61 uns:operate-on a
5f80: 63 74 69 6f 6e 20 74 61 72 67 65 74 20 72 75 6e ction target run
5f90: 6e 61 6d 65 70 61 74 74 20 74 65 73 74 70 61 74 namepatt testpat
5fa0: 74 20 23 21 6b 65 79 20 28 73 74 61 74 65 20 23 t #!key (state #
5fb0: 66 29 28 73 74 61 74 75 73 20 23 66 29 28 6e 65 f)(status #f)(ne
5fc0: 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 23 w-state-status #
5fd0: 66 29 29 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c f)). (common:cl
5fe0: 65 61 72 2d 63 61 63 68 65 73 29 20 3b 3b 20 63 ear-caches) ;; c
5ff0: 6c 65 61 72 20 61 6c 6c 20 63 61 63 68 65 73 0a lear all caches.
6000: 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 (let* ((db
6010: 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 6b 65 #f).. (ke
6020: 79 73 20 20 20 20 20 20 20 20 20 28 6f 70 65 6e ys (open
6030: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 -run-close db:ge
6040: 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 28 72 t-keys db)).. (r
6050: 75 6e 64 61 74 20 20 20 20 20 20 20 28 6f 70 65 undat (ope
6060: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 n-run-close runs
6070: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
6080: 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 6d t db keys runnam
6090: 65 70 61 74 74 20 74 61 72 67 65 74 29 29 0a 09 epatt target))..
60a0: 20 28 68 65 61 64 65 72 20 20 20 20 20 20 20 28 (header (
60b0: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
60c0: 74 20 30 29 29 0a 09 20 28 72 75 6e 73 20 20 20 t 0)).. (runs
60d0: 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 (vector-re
60e0: 66 20 72 75 6e 64 61 74 20 31 29 29 0a 09 20 28 f rundat 1)).. (
60f0: 73 74 61 74 65 73 20 20 20 20 20 20 20 28 69 66 states (if
6100: 20 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d state (string-
6110: 73 70 6c 69 74 20 73 74 61 74 65 20 20 22 2c 22 split state ","
6120: 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 75 ) '())).. (statu
6130: 73 65 73 20 20 20 20 20 28 69 66 20 73 74 61 74 ses (if stat
6140: 75 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 us (string-split
6150: 20 73 74 61 74 75 73 20 22 2c 22 29 20 27 28 29 status ",") '()
6160: 29 29 0a 09 20 28 73 74 61 74 65 2d 73 74 61 74 )).. (state-stat
6170: 75 73 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 us (if (string?
6180: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
6190: 29 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 ) (string-split
61a0: 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 75 73 new-state-status
61b0: 20 22 2c 22 29 20 27 28 23 66 20 23 66 29 29 29 ",") '(#f #f)))
61c0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
61d0: 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 3a nt-info 4 "runs:
61e0: 6f 70 65 72 61 74 65 2d 6f 6e 20 3d 3e 20 48 65 operate-on => He
61f0: 61 64 65 72 3a 20 22 20 68 65 61 64 65 72 20 22 ader: " header "
6200: 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 6f action: " actio
6210: 6e 20 22 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 n " new-state-st
6220: 61 74 75 73 3a 20 22 20 6e 65 77 2d 73 74 61 74 atus: " new-stat
6230: 65 2d 73 74 61 74 75 73 29 0a 20 20 20 20 28 69 e-status). (i
6240: 66 20 28 3e 20 32 20 28 6c 65 6e 67 74 68 20 73 f (> 2 (length s
6250: 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a 09 28 tate-status))..(
6260: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug:
6270: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
6280: 74 68 65 20 70 61 72 61 6d 65 74 65 72 20 74 6f the parameter to
6290: 20 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 -set-state-stat
62a0: 75 73 20 69 73 20 61 20 63 6f 6d 6d 61 20 64 65 us is a comma de
62b0: 6c 69 6d 69 74 65 64 20 73 74 72 69 6e 67 2e 20 limited string.
62c0: 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 45 44 2c 46 E.g. COMPLETED,F
62d0: 41 49 4c 22 29 0a 09 20 20 28 65 78 69 74 29 29 AIL").. (exit))
62e0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
62f0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 72 75 (lambda (ru
6300: 6e 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 28 n). (let (
6310: 28 72 75 6e 6b 65 79 20 28 73 74 72 69 6e 67 2d (runkey (string-
6320: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
6330: 20 28 6c 61 6d 62 64 61 20 28 6b 29 0a 09 09 09 (lambda (k)....
6340: 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 ...(db:get-value
6350: 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 -by-header run h
6360: 65 61 64 65 72 20 6b 29 29 20 6b 65 79 73 29 20 eader k)) keys)
6370: 22 2f 22 29 29 0a 09 20 20 20 20 20 28 64 69 72 "/")).. (dir
6380: 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 28 6d 61 6b s-to-remove (mak
6390: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
63a0: 09 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 64 . (let* ((run-id
63b0: 20 20 20 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 (db:get-valu
63c0: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
63d0: 68 65 61 64 65 72 20 22 69 64 22 29 29 0a 09 09 header "id"))...
63e0: 28 72 75 6e 2d 73 74 61 74 65 20 28 64 62 3a 67 (run-state (db:g
63f0: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
6400: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 73 er run header "s
6410: 74 61 74 65 22 29 29 0a 09 09 28 74 65 73 74 73 tate"))...(tests
6420: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
6430: 71 75 61 6c 3f 20 72 75 6e 2d 73 74 61 74 65 20 qual? run-state
6440: 22 6c 6f 63 6b 65 64 22 29 29 0a 09 09 09 20 20 "locked"))....
6450: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
6460: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 lose db:get-test
6470: 73 2d 66 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e s-for-run db run
6480: 2d 69 64 0a 09 09 09 09 09 09 20 20 20 20 20 20 -id.......
6490: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
64a0: 73 74 61 74 75 73 65 73 0a 09 09 09 09 09 09 20 statuses.......
64b0: 20 20 20 20 20 6e 6f 74 2d 69 6e 3a 20 20 23 66 not-in: #f
64c0: 0a 09 09 09 09 09 09 20 20 20 20 20 20 73 6f 72 ....... sor
64d0: 74 2d 62 79 3a 20 28 63 61 73 65 20 61 63 74 69 t-by: (case acti
64e0: 6f 6e 0a 09 09 09 09 09 09 09 09 20 28 28 72 65 on......... ((re
64f0: 6d 6f 76 65 2d 72 75 6e 73 29 20 27 72 75 6e 64 move-runs) 'rund
6500: 69 72 29 0a 09 09 09 09 09 09 09 09 20 28 65 6c ir)......... (el
6510: 73 65 20 20 20 20 20 20 20 20 20 20 27 65 76 65 se 'eve
6520: 6e 74 5f 74 69 6d 65 29 29 29 0a 09 09 09 20 20 nt_time)))....
6530: 20 20 20 20 20 27 28 29 29 29 0a 09 09 28 6c 61 '()))...(la
6540: 73 74 74 70 61 74 68 20 22 2f 64 6f 65 73 2f 6e sttpath "/does/n
6550: 6f 74 2f 65 78 69 73 74 2f 49 2f 68 6f 70 65 22 ot/exist/I/hope"
6560: 29 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 )).. (debug:pr
6570: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 75 6e 73 int-info 4 "runs
6580: 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 72 75 6e 3d :operate-on run=
6590: 22 20 72 75 6e 20 22 2c 20 68 65 61 64 65 72 3d " run ", header=
65a0: 22 20 68 65 61 64 65 72 29 0a 09 20 20 20 28 69 " header).. (i
65b0: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 f (not (null? te
65c0: 73 74 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 sts)).. (b
65d0: 65 67 69 6e 0a 09 09 20 28 63 61 73 65 20 61 63 egin... (case ac
65e0: 74 69 6f 6e 0a 09 09 20 20 20 28 28 72 65 6d 6f tion... ((remo
65f0: 76 65 2d 72 75 6e 73 29 0a 09 09 20 20 20 20 28 ve-runs)... (
6600: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 debug:print 1 "R
6610: 65 6d 6f 76 69 6e 67 20 74 65 73 74 73 20 66 6f emoving tests fo
6620: 72 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 r run: " runkey
6630: 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 " " (db:get-valu
6640: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
6650: 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 header "runname"
6660: 29 29 29 0a 09 09 20 20 20 28 28 73 65 74 2d 73 )))... ((set-s
6670: 74 61 74 65 2d 73 74 61 74 75 73 29 0a 09 09 20 tate-status)...
6680: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6690: 31 20 22 4d 6f 64 69 66 79 69 6e 67 20 73 74 61 1 "Modifying sta
66a0: 74 65 20 61 6e 64 20 73 74 61 75 73 20 66 6f 72 te and staus for
66b0: 20 74 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 tests for run:
66c0: 22 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 " runkey " " (db
66d0: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
66e0: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
66f0: 22 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 09 20 "runname")))...
6700: 20 20 28 28 70 72 69 6e 74 2d 72 75 6e 29 0a 09 ((print-run)..
6710: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
6720: 74 20 31 20 22 50 72 69 6e 74 69 6e 67 20 69 6e t 1 "Printing in
6730: 66 6f 20 66 6f 72 20 72 75 6e 20 22 20 72 75 6e fo for run " run
6740: 6b 65 79 20 22 2c 20 72 75 6e 3d 22 20 72 75 6e key ", run=" run
6750: 20 22 2c 20 74 65 73 74 73 3d 22 20 74 65 73 74 ", tests=" test
6760: 73 20 22 2c 20 68 65 61 64 65 72 3d 22 20 68 65 s ", header=" he
6770: 61 64 65 72 29 0a 09 09 20 20 20 20 61 63 74 69 ader)... acti
6780: 6f 6e 29 0a 09 09 20 20 20 28 65 6c 73 65 0a 09 on)... (else..
6790: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
67a0: 74 2d 69 6e 66 6f 20 30 20 22 61 63 74 69 6f 6e t-info 0 "action
67b0: 20 6e 6f 74 20 72 65 63 6f 67 6e 69 73 65 64 20 not recognised
67c0: 22 20 61 63 74 69 6f 6e 29 29 29 0a 09 09 20 28 " action)))... (
67d0: 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 for-each... (la
67e0: 6d 62 64 61 20 28 74 65 73 74 29 0a 09 09 20 20 mbda (test)...
67f0: 20 20 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 (let* ((item-p
6800: 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ath (db:test-get
6810: 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 -item-path test)
6820: 29 0a 09 09 09 20 20 20 28 74 65 73 74 2d 6e 61 ).... (test-na
6830: 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d me (db:test-get-
6840: 74 65 73 74 6e 61 6d 65 20 74 65 73 74 29 29 0a testname test)).
6850: 09 09 09 20 20 20 28 72 75 6e 2d 64 69 72 20 20 ... (run-dir
6860: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
6870: 6e 64 69 72 20 74 65 73 74 29 29 20 20 20 20 3b ndir test)) ;
6880: 3b 20 72 75 6e 20 64 69 72 20 69 73 20 66 72 6f ; run dir is fro
6890: 6d 20 74 68 65 20 6c 69 6e 6b 20 74 72 65 65 0a m the link tree.
68a0: 09 09 09 20 20 20 28 72 65 61 6c 2d 64 69 72 20 ... (real-dir
68b0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
68c0: 73 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 s? run-dir).....
68d0: 09 20 20 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 . (resolve-path
68e0: 6e 61 6d 65 20 72 75 6e 2d 64 69 72 29 0a 09 09 name run-dir)...
68f0: 09 09 09 20 20 23 66 29 29 0a 09 09 09 20 20 20 ... #f))....
6900: 28 74 65 73 74 2d 69 64 20 20 20 28 64 62 3a 74 (test-id (db:t
6910: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
6920: 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 20 20 ))... ;;
6930: 28 74 64 62 20 20 20 20 20 20 20 28 64 62 3a 6f (tdb (db:o
6940: 70 65 6e 2d 74 65 73 74 2d 64 62 20 72 75 6e 2d pen-test-db run-
6950: 64 69 72 29 29 29 0a 09 09 20 20 20 20 20 20 28 dir)))... (
6960: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6970: 20 34 20 22 74 65 73 74 3d 22 20 74 65 73 74 29 4 "test=" test)
6980: 20 3b 3b 20 20 20 22 20 28 64 62 3a 74 65 73 74 ;; " (db:test
6990: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
69a0: 73 74 29 20 22 20 69 64 3a 20 22 20 28 64 62 3a st) " id: " (db:
69b0: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
69c0: 29 20 22 20 22 20 69 74 65 6d 2d 70 61 74 68 20 ) " " item-path
69d0: 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 63 74 69 " action: " acti
69e0: 6f 6e 29 0a 09 09 20 20 20 20 20 20 28 63 61 73 on)... (cas
69f0: 65 20 61 63 74 69 6f 6e 0a 09 09 09 28 28 72 65 e action....((re
6a00: 6d 6f 76 65 2d 72 75 6e 73 29 20 3b 3b 20 74 68 move-runs) ;; th
6a10: 65 20 74 64 62 20 69 73 20 66 6f 72 20 66 75 74 e tdb is for fut
6a20: 75 72 65 20 70 6f 73 73 69 62 6c 65 2e 20 0a 09 ure possible. ..
6a30: 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f .. (open-run-clo
6a40: 73 65 20 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 se db:delete-tes
6a50: 74 2d 72 65 63 6f 72 64 73 20 64 62 20 23 66 20 t-records db #f
6a60: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
6a70: 74 65 73 74 29 29 0a 09 09 09 20 28 64 65 62 75 test)).... (debu
6a80: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 g:print-info 1 "
6a90: 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 72 65 Attempting to re
6aa0: 6d 6f 76 65 20 22 20 28 69 66 20 72 65 61 6c 2d move " (if real-
6ab0: 64 69 72 20 28 63 6f 6e 63 20 22 20 64 69 72 20 dir (conc " dir
6ac0: 22 20 72 65 61 6c 2d 64 69 72 20 22 20 61 6e 64 " real-dir " and
6ad0: 20 22 29 20 22 22 29 20 22 20 6c 69 6e 6b 20 22 ") "") " link "
6ae0: 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 28 69 run-dir).... (i
6af0: 66 20 28 61 6e 64 20 72 65 61 6c 2d 64 69 72 20 f (and real-dir
6b00: 0a 09 09 09 09 20 20 28 3e 20 28 73 74 72 69 6e ..... (> (strin
6b10: 67 2d 6c 65 6e 67 74 68 20 72 65 61 6c 2d 64 69 g-length real-di
6b20: 72 29 20 35 29 0a 09 09 09 09 20 20 28 66 69 6c r) 5)..... (fil
6b30: 65 2d 65 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 e-exists? real-d
6b40: 69 72 29 29 20 3b 3b 20 62 61 64 20 68 65 75 72 ir)) ;; bad heur
6b50: 69 73 74 69 63 20 62 75 74 20 73 68 6f 75 6c 64 istic but should
6b60: 20 70 72 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 prevent /tmp /h
6b70: 6f 6d 65 20 65 74 63 2e 0a 09 09 09 20 20 20 20 ome etc.....
6b80: 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 2a 20 (begin ;; let*
6b90: 28 28 72 65 61 6c 70 61 74 68 20 28 72 65 73 6f ((realpath (reso
6ba0: 6c 76 65 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e lve-pathname run
6bb0: 2d 64 69 72 29 29 29 0a 09 09 09 20 20 20 20 20 -dir)))....
6bc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6bd0: 6e 66 6f 20 31 20 22 52 65 63 75 72 73 69 76 65 nfo 1 "Recursive
6be0: 6c 79 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 65 ly removing " re
6bf0: 61 6c 2d 64 69 72 29 0a 09 09 09 20 20 20 20 20 al-dir)....
6c00: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
6c10: 74 73 3f 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 ts? real-dir)...
6c20: 09 09 20 20 20 28 69 66 20 28 3e 20 28 73 79 73 .. (if (> (sys
6c30: 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 tem (conc "rm -r
6c40: 66 20 22 20 72 65 61 6c 2d 64 69 72 29 29 20 30 f " real-dir)) 0
6c50: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 65 )..... (de
6c60: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
6c70: 4f 52 3a 20 54 68 65 72 65 20 77 61 73 20 61 20 OR: There was a
6c80: 70 72 6f 62 6c 65 6d 20 72 65 6d 6f 76 69 6e 67 problem removing
6c90: 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 77 69 " real-dir " wi
6ca0: 74 68 20 72 6d 20 2d 66 22 29 29 0a 09 09 09 09 th rm -f")).....
6cb0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6cc0: 30 20 22 57 41 52 4e 49 4e 47 3a 20 74 65 73 74 0 "WARNING: test
6cd0: 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 dir " real-dir
6ce0: 22 20 61 70 70 65 61 72 73 20 74 6f 20 6e 6f 74 " appears to not
6cf0: 20 65 78 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 exist or is not
6d00: 20 72 65 61 64 61 62 6c 65 22 29 29 29 0a 09 09 readable")))...
6d10: 09 20 20 20 20 20 28 69 66 20 72 65 61 6c 2d 64 . (if real-d
6d20: 69 72 20 0a 09 09 09 09 20 28 64 65 62 75 67 3a ir ..... (debug:
6d30: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING
6d40: 3a 20 64 69 72 65 63 74 6f 72 79 20 22 20 72 65 : directory " re
6d50: 61 6c 2d 64 69 72 20 22 20 64 6f 65 73 20 6e 6f al-dir " does no
6d60: 74 20 65 78 69 73 74 22 29 0a 09 09 09 09 20 28 t exist")..... (
6d70: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 debug:print 0 "W
6d80: 41 52 4e 49 4e 47 3a 20 6e 6f 20 72 65 61 6c 20 ARNING: no real
6d90: 64 69 72 65 63 74 6f 72 79 20 63 6f 72 72 6f 73 directory corros
6da0: 70 6f 6e 64 69 6e 67 20 74 6f 20 6c 69 6e 6b 20 ponding to link
6db0: 22 20 72 75 6e 2d 64 69 72 20 22 2c 20 6e 6f 74 " run-dir ", not
6dc0: 68 69 6e 67 20 64 6f 6e 65 22 29 29 29 0a 09 09 hing done")))...
6dd0: 09 20 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d . (if (symbolic-
6de0: 6c 69 6e 6b 3f 20 72 75 6e 2d 64 69 72 29 0a 09 link? run-dir)..
6df0: 09 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 .. (begin...
6e00: 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 . (debug:p
6e10: 72 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 6d rint-info 1 "Rem
6e20: 6f 76 69 6e 67 20 73 79 6d 6c 69 6e 6b 20 22 20 oving symlink "
6e30: 72 75 6e 2d 64 69 72 29 0a 09 09 09 20 20 20 20 run-dir)....
6e40: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
6e50: 74 69 6f 6e 73 0a 09 09 09 09 65 78 6e 0a 09 09 tions.....exn...
6e60: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
6e70: 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 "ERROR: Failed
6e80: 20 74 6f 20 72 65 6d 6f 76 65 20 73 79 6d 6c 69 to remove symli
6e90: 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 28 28 63 nk " run-dir ((c
6ea0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
6eb0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
6ec0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 'message) exn) "
6ed0: 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 , attempting to
6ee0: 63 6f 6e 74 69 6e 75 65 22 29 0a 09 09 09 09 28 continue").....(
6ef0: 64 65 6c 65 74 65 2d 66 69 6c 65 20 72 75 6e 2d delete-file run-
6f00: 64 69 72 29 29 29 0a 09 09 09 20 20 20 20 20 28 dir))).... (
6f10: 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 72 if (directory? r
6f20: 75 6e 2d 64 69 72 29 0a 09 09 09 09 20 28 69 66 un-dir)..... (if
6f30: 20 28 3e 20 28 64 69 72 65 63 74 6f 72 79 2d 66 (> (directory-f
6f40: 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 66 20 78 old (lambda (f x
6f50: 29 28 2b 20 31 20 78 29 29 20 30 20 72 75 6e 2d )(+ 1 x)) 0 run-
6f60: 64 69 72 29 20 30 29 0a 09 09 09 09 20 20 20 20 dir) 0).....
6f70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
6f80: 22 57 41 52 4e 49 4e 47 3a 20 72 65 66 75 73 69 "WARNING: refusi
6f90: 6e 67 20 74 6f 20 72 65 6d 6f 76 65 20 22 20 72 ng to remove " r
6fa0: 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 69 un-dir " as it i
6fb0: 73 20 6e 6f 74 20 65 6d 70 74 79 22 29 0a 09 09 s not empty")...
6fc0: 09 09 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d .. (handle-
6fd0: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 20 exceptions.....
6fe0: 20 20 20 20 20 20 65 78 6e 0a 09 09 09 09 20 20 exn.....
6ff0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
7000: 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 61 69 t 0 "ERROR: Fai
7010: 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 64 69 led to remove di
7020: 72 65 63 74 6f 72 79 20 22 20 72 75 6e 2d 64 69 rectory " run-di
7030: 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 r ((condition-pr
7040: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
7050: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
7060: 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 69 6e xn) ", attemptin
7070: 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a g to continue").
7080: 09 09 09 09 20 20 20 20 20 20 20 28 64 65 6c 65 .... (dele
7090: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 75 6e te-directory run
70a0: 2d 64 69 72 29 29 29 0a 09 09 09 09 20 28 69 66 -dir)))..... (if
70b0: 20 72 75 6e 2d 64 69 72 0a 09 09 09 09 20 20 20 run-dir.....
70c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
70d0: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 74 20 72 "WARNING: not r
70e0: 65 6d 6f 76 69 6e 67 20 22 20 72 75 6e 2d 64 69 emoving " run-di
70f0: 72 20 22 20 61 73 20 69 74 20 65 69 74 68 65 72 r " as it either
7100: 20 64 6f 65 73 6e 27 74 20 65 78 69 73 74 20 6f doesn't exist o
7110: 72 20 69 73 20 6e 6f 74 20 61 20 73 79 6d 6c 69 r is not a symli
7120: 6e 6b 22 29 0a 09 09 09 09 20 20 20 20 20 28 64 nk")..... (d
7130: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 4e 4f ebug:print 0 "NO
7140: 54 45 3a 20 74 68 65 20 72 75 6e 20 64 69 72 20 TE: the run dir
7150: 66 6f 72 20 74 68 69 73 20 74 65 73 74 20 69 73 for this test is
7160: 20 75 6e 64 65 66 69 6e 65 64 2e 20 54 65 73 74 undefined. Test
7170: 20 6d 61 79 20 68 61 76 65 20 61 6c 72 65 61 64 may have alread
7180: 79 20 62 65 65 6e 20 64 65 6c 65 74 65 64 2e 22 y been deleted."
7190: 29 29 0a 09 09 09 09 20 29 29 29 0a 09 09 09 28 ))..... )))....(
71a0: 28 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 (set-state-statu
71b0: 73 29 0a 09 09 09 20 28 64 65 62 75 67 3a 70 72 s).... (debug:pr
71c0: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 6e 65 77 20 int-info 2 "new
71d0: 73 74 61 74 65 20 22 20 28 63 61 72 20 73 74 61 state " (car sta
71e0: 74 65 2d 73 74 61 74 75 73 29 20 22 2c 20 6e 65 te-status) ", ne
71f0: 77 20 73 74 61 74 75 73 20 22 20 28 63 61 64 72 w status " (cadr
7200: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 29 0a state-status)).
7210: 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ... (open-run-cl
7220: 6f 73 65 20 64 62 3a 74 65 73 74 2d 73 65 74 2d ose db:test-set-
7230: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d state-status-by-
7240: 69 64 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 id db (db:test-g
7250: 65 74 2d 69 64 20 74 65 73 74 29 20 28 63 61 72 et-id test) (car
7260: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 28 63 state-status)(c
7270: 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 adr state-status
7280: 29 20 23 66 29 29 29 29 29 0a 09 09 20 20 28 73 ) #f)))))... (s
7290: 6f 72 74 20 74 65 73 74 73 20 28 6c 61 6d 62 64 ort tests (lambd
72a0: 61 20 28 61 20 62 29 28 6c 65 74 20 28 28 64 69 a (a b)(let ((di
72b0: 72 61 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d ra (db:test-get-
72c0: 72 75 6e 64 69 72 20 61 29 29 0a 09 09 09 09 09 rundir a))......
72d0: 09 20 28 64 69 72 62 20 28 64 62 3a 74 65 73 74 . (dirb (db:test
72e0: 2d 67 65 74 2d 72 75 6e 64 69 72 20 62 29 29 29 -get-rundir b)))
72f0: 0a 09 09 09 09 09 20 20 20 20 20 28 69 66 20 28 ...... (if (
7300: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 64 69 72 and (string? dir
7310: 61 29 28 73 74 72 69 6e 67 3f 20 64 69 72 62 29 a)(string? dirb)
7320: 29 0a 09 09 09 09 09 09 20 28 3e 20 28 73 74 72 )....... (> (str
7330: 69 6e 67 2d 6c 65 6e 67 74 68 20 64 69 72 61 29 ing-length dira)
7340: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 (string-length d
7350: 69 72 62 29 29 0a 09 09 09 09 09 09 20 23 66 29 irb))....... #f)
7360: 29 29 29 29 29 29 0a 09 20 20 20 3b 3b 20 72 65 )))))).. ;; re
7370: 6d 6f 76 65 20 74 68 65 20 72 75 6e 20 69 66 20 move the run if
7380: 7a 65 72 6f 20 74 65 73 74 73 20 72 65 6d 61 69 zero tests remai
7390: 6e 0a 09 20 20 20 28 69 66 20 28 65 71 3f 20 61 n.. (if (eq? a
73a0: 63 74 69 6f 6e 20 27 72 65 6d 6f 76 65 2d 72 75 ction 'remove-ru
73b0: 6e 73 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 ns).. (let
73c0: 20 28 28 72 65 6d 74 65 73 74 73 20 28 6f 70 65 ((remtests (ope
73d0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
73e0: 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e et-tests-for-run
73f0: 20 64 62 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 db (db:get-valu
7400: 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 e-by-header run
7410: 68 65 61 64 65 72 20 22 69 64 22 29 20 23 66 20 header "id") #f
7420: 27 28 22 44 45 4c 45 54 45 44 22 29 20 27 28 22 '("DELETED") '("
7430: 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e 3a 20 23 74 n/a") not-in: #t
7440: 29 29 29 0a 09 09 20 28 69 66 20 28 6e 75 6c 6c )))... (if (null
7450: 3f 20 72 65 6d 74 65 73 74 73 29 20 3b 3b 20 6e ? remtests) ;; n
7460: 6f 20 6d 6f 72 65 20 74 65 73 74 73 20 72 65 6d o more tests rem
7470: 61 69 6e 69 6e 67 0a 09 09 20 20 20 20 20 28 6c aining... (l
7480: 65 74 2a 20 28 28 64 70 61 72 74 73 20 20 28 73 et* ((dparts (s
7490: 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 73 74 tring-split last
74a0: 74 70 61 74 68 20 22 2f 22 29 29 0a 09 09 09 20 tpath "/"))....
74b0: 20 20 20 28 72 75 6e 70 61 74 68 20 28 63 6f 6e (runpath (con
74c0: 63 20 22 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e c "/" (string-in
74d0: 74 65 72 73 70 65 72 73 65 20 0a 09 09 09 09 09 tersperse ......
74e0: 09 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d .(take dparts (-
74f0: 20 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 (length dparts)
7500: 20 31 29 29 0a 09 09 09 09 09 09 22 2f 22 29 29 1))......."/"))
7510: 29 29 0a 09 09 20 20 20 20 20 20 20 28 64 65 62 ))... (deb
7520: 75 67 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f ug:print 1 "Remo
7530: 76 69 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e 6b ving run: " runk
7540: 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 ey " " (db:get-v
7550: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
7560: 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 un header "runna
7570: 6d 65 22 29 20 22 20 61 6e 64 20 72 65 6c 61 74 me") " and relat
7580: 65 64 20 72 65 63 6f 72 64 22 29 0a 09 09 20 20 ed record")...
7590: 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 (open-run-c
75a0: 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d 72 lose db:delete-r
75b0: 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 un db run-id)...
75c0: 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 69 ;; This i
75d0: 73 20 61 20 70 72 65 74 74 79 20 67 6f 6f 64 20 s a pretty good
75e0: 70 6c 61 63 65 20 74 6f 20 70 75 72 67 65 20 6f place to purge o
75f0: 6c 64 20 44 45 4c 45 54 45 44 20 74 65 73 74 73 ld DELETED tests
7600: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
7610: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c run-close db:del
7620: 65 74 65 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 ete-tests-for-ru
7630: 6e 20 64 62 20 72 75 6e 2d 69 64 29 0a 09 09 20 n db run-id)...
7640: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
7650: 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 2d close db:delete-
7660: 6f 6c 64 2d 64 65 6c 65 74 65 64 2d 74 65 73 74 old-deleted-test
7670: 2d 72 65 63 6f 72 64 73 20 64 62 29 0a 09 09 20 -records db)...
7680: 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d (open-run-
7690: 63 6c 6f 73 65 20 64 62 3a 73 65 74 2d 76 61 72 close db:set-var
76a0: 20 64 62 20 22 44 45 4c 45 54 45 44 5f 54 45 53 db "DELETED_TES
76b0: 54 53 22 20 28 63 75 72 72 65 6e 74 2d 73 65 63 TS" (current-sec
76c0: 6f 6e 64 73 29 29 0a 09 09 20 20 20 20 20 20 20 onds))...
76d0: 3b 3b 20 6e 65 65 64 20 74 6f 20 66 69 67 75 72 ;; need to figur
76e0: 65 20 6f 75 74 20 74 68 65 20 70 61 74 68 20 74 e out the path t
76f0: 6f 20 74 68 65 20 72 75 6e 20 64 69 72 20 61 6e o the run dir an
7700: 64 20 72 65 6d 6f 76 65 20 69 74 20 69 66 20 65 d remove it if e
7710: 6d 70 74 79 0a 09 09 20 20 20 20 20 20 20 3b 3b mpty... ;;
7720: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 (if (null? (
7730: 67 6c 6f 62 20 28 63 6f 6e 63 20 72 75 6e 70 61 glob (conc runpa
7740: 74 68 20 22 2f 2a 22 29 29 29 0a 09 09 20 20 20 th "/*")))...
7750: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 62 ;; (b
7760: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 20 3b 3b egin... ;;
7770: 20 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
7780: 31 20 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 20 1 "Removing run
7790: 64 69 72 20 22 20 72 75 6e 70 61 74 68 29 0a 09 dir " runpath)..
77a0: 09 20 20 20 20 20 20 20 3b 3b 20 09 20 28 73 79 . ;; . (sy
77b0: 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 64 69 stem (conc "rmdi
77c0: 72 20 2d 70 20 22 20 72 75 6e 70 61 74 68 29 29 r -p " runpath))
77d0: 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 29 ))... ))))
77e0: 29 0a 09 20 29 29 0a 20 20 20 20 20 72 75 6e 73 ).. )). runs
77f0: 29 29 0a 20 20 23 74 29 0a 0a 3b 3b 3d 3d 3d 3d )). #t)..;;====
7800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7840: 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 ==.;; Routines f
7850: 6f 72 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 or manipulating
7860: 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d runs.;;=========
7870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
78b0: 3b 20 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c ; Since many cal
78c0: 6c 73 20 74 6f 20 61 20 72 75 6e 20 72 65 71 75 ls to a run requ
78d0: 69 72 65 20 70 72 65 74 74 79 20 6d 75 63 68 20 ire pretty much
78e0: 74 68 65 20 73 61 6d 65 20 73 65 74 75 70 20 0a the same setup .
78f0: 3b 3b 20 74 68 69 73 20 77 72 61 70 70 65 72 20 ;; this wrapper
7900: 69 73 20 75 73 65 64 20 74 6f 20 72 65 64 75 63 is used to reduc
7910: 65 20 74 68 65 20 72 65 70 6c 69 63 61 74 69 6f e the replicatio
7920: 6e 20 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 6e n of code.(defin
7930: 65 20 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 e (general-run-c
7940: 61 6c 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 61 all switchname a
7950: 63 74 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 ction-desc proc)
7960: 0a 20 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d . (let ((runnam
7970: 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 e (args:get-arg
7980: 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 09 28 74 ":runname"))..(t
7990: 61 72 67 65 74 20 20 28 69 66 20 28 61 72 67 73 arget (if (args
79a0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
79b0: 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 t")... (args
79c0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
79d0: 74 22 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 t")... (args
79e0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
79f0: 72 67 22 29 29 29 29 0a 09 3b 3b 20 28 74 68 31 rg"))))..;; (th1
7a00: 20 20 20 20 20 23 66 29 29 0a 20 20 20 20 28 63 #f)). (c
7a10: 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f 74 20 74 ond. ((not t
7a20: 61 72 67 65 74 29 0a 20 20 20 20 20 20 28 64 65 arget). (de
7a30: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
7a40: 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 OR: Missing requ
7a50: 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 ired parameter f
7a60: 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 or " switchname
7a70: 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 ", you must spec
7a80: 69 66 79 20 74 68 65 20 74 61 72 67 65 74 20 77 ify the target w
7a90: 69 74 68 20 2d 74 61 72 67 65 74 22 29 0a 20 20 ith -target").
7aa0: 20 20 20 20 28 65 78 69 74 20 33 29 29 0a 20 20 (exit 3)).
7ab0: 20 20 20 28 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 ((not runname
7ac0: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
7ad0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 4d rint 0 "ERROR: M
7ae0: 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 20 issing required
7af0: 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 20 parameter for "
7b00: 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 6f switchname ", yo
7b10: 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 74 u must specify t
7b20: 68 65 20 72 75 6e 20 6e 61 6d 65 20 77 69 74 68 he run name with
7b30: 20 3a 72 75 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d :runname runnam
7b40: 65 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 e"). (exit
7b50: 33 29 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 3)). (else.
7b60: 20 20 20 20 20 28 6c 65 74 20 28 28 64 62 20 20 (let ((db
7b70: 20 23 66 29 0a 09 20 20 20 20 28 6b 65 79 73 20 #f).. (keys
7b80: 23 66 29 0a 09 20 20 20 20 28 74 61 72 67 65 74 #f).. (target
7b90: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
7ba0: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 rg "-reqtarg")..
7bb0: 09 09 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ..(args:get-arg
7bc0: 22 2d 74 61 72 67 65 74 22 29 29 29 29 0a 09 28 "-target"))))..(
7bd0: 69 66 20 28 6e 6f 74 20 28 73 65 74 75 70 2d 66 if (not (setup-f
7be0: 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 20 28 62 or-run)).. (b
7bf0: 65 67 69 6e 20 0a 09 20 20 20 20 20 20 28 64 65 egin .. (de
7c00: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 46 61 69 bug:print 0 "Fai
7c10: 6c 65 64 20 74 6f 20 73 65 74 75 70 2c 20 65 78 led to setup, ex
7c20: 69 74 69 6e 67 22 29 0a 09 20 20 20 20 20 20 28 iting").. (
7c30: 65 78 69 74 20 31 29 29 29 0a 09 3b 3b 20 28 69 exit 1)))..;; (i
7c40: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
7c50: 22 2d 73 65 72 76 65 72 22 29 0a 09 3b 3b 20 20 "-server")..;;
7c60: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
7c70: 73 65 20 73 65 72 76 65 72 3a 73 74 61 72 74 20 se server:start
7c80: 64 62 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 db (args:get-arg
7c90: 20 22 2d 73 65 72 76 65 72 22 29 29 29 0a 09 28 "-server")))..(
7ca0: 73 65 74 21 20 6b 65 79 73 20 28 6b 65 79 73 3a set! keys (keys:
7cb0: 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 config-get-field
7cc0: 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 0a s *configdat*)).
7cd0: 09 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 68 20 .;; have enough
7ce0: 74 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 72 67 to process -targ
7cf0: 65 74 20 6f 72 20 2d 72 65 71 74 61 72 67 20 68 et or -reqtarg h
7d00: 65 72 65 0a 09 28 69 66 20 28 61 72 67 73 3a 67 ere..(if (args:g
7d10: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
7d20: 22 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 ").. (let* ((
7d30: 72 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 runconfigf (conc
7d40: 20 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 *toppath* "/ru
7d50: 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 nconfigs.config"
7d60: 29 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 41 )) ;; DO NOT EVA
7d70: 4c 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 20 20 LUATE ALL ...
7d80: 28 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 65 61 (runconfig (rea
7d90: 64 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 d-config runconf
7da0: 69 67 66 20 23 66 20 23 74 20 65 6e 76 69 72 6f igf #f #t enviro
7db0: 6e 2d 70 61 74 74 3a 20 23 66 29 29 29 0a 09 20 n-patt: #f)))..
7dc0: 20 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 (if (hash-t
7dd0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7de0: 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 runconfig (args
7df0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
7e00: 72 67 22 29 20 23 66 29 0a 09 09 20 20 28 6b 65 rg") #f)... (ke
7e10: 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 ys:target-set-ar
7e20: 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 gs keys (args:ge
7e30: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
7e40: 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 ) args:arg-hash)
7e50: 0a 09 09 20 20 20 20 0a 09 09 20 20 28 62 65 67 ... ... (beg
7e60: 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a in... (debug:
7e70: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
7e80: 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 [" (args:get-arg
7e90: 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 "-reqtarg") "]
7ea0: 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 not found in " r
7eb0: 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 unconfigf)...
7ec0: 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 (if db (sqlite3
7ed0: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a :finalize! db)).
7ee0: 09 09 20 20 20 20 28 65 78 69 74 20 31 29 29 29 .. (exit 1)))
7ef0: 29 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 73 ).. (if (args
7f00: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
7f10: 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 t")...(keys:targ
7f20: 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 et-set-args keys
7f30: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7f40: 2d 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 72 -target" args:ar
7f50: 67 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 67 g-hash) args:arg
7f60: 2d 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 6e -hash)))..(if (n
7f70: 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 ot (car *configi
7f80: 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 67 nfo*)).. (beg
7f90: 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 in.. (debug
7fa0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
7fb0: 20 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 Attempted to "
7fc0: 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 action-desc " bu
7fd0: 74 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 t run area confi
7fe0: 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 g file not found
7ff0: 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit
8000: 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 1)).. ;; Extr
8010: 61 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 act out stuff ne
8020: 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 eded in most or
8030: 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 many calls..
8040: 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c ;; here then cal
8050: 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 l proc.. (let
8060: 2a 20 28 28 6b 65 79 76 61 6c 73 20 20 20 20 28 * ((keyvals (
8070: 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 keys:target->key
8080: 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 val keys target)
8090: 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 )).. (proc
80a0: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b target runname k
80b0: 65 79 73 20 6b 65 79 76 61 6c 73 29 29 29 0a 09 eys keyvals)))..
80c0: 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
80d0: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
80e0: 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 (set! *didsometh
80f0: 69 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b ing* #t))))))..;
8100: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
8110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8140: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 6b 2f =======.;; Lock/
8150: 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d unlock runs.;;==
8160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81a0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
81b0: 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 uns:handle-locki
81c0: 6e 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 ng target keys r
81d0: 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f unname lock unlo
81e0: 63 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a ck user). (let*
81f0: 20 28 28 64 62 20 20 20 20 20 20 20 23 66 29 0a ((db #f).
8200: 09 20 28 72 75 6e 64 61 74 20 20 20 28 6f 70 65 . (rundat (ope
8210: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 n-run-close runs
8220: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
8230: 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 6d t db keys runnam
8240: 65 20 74 61 72 67 65 74 29 29 0a 09 20 28 68 65 e target)).. (he
8250: 61 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d 72 ader (vector-r
8260: 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 ef rundat 0))..
8270: 28 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 6f (runs (vecto
8280: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 r-ref rundat 1))
8290: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
82a0: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 (lambda (run)...
82b0: 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 64 (let ((run-id (d
82c0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
82d0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
82e0: 20 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 66 "id")))... (if
82f0: 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 (or lock.... (
8300: 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 and unlock....
8310: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
8320: 20 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 (print "Do you
8330: 72 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 really wish to u
8340: 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d nlock run " run-
8350: 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 id "?\n y/n: "
8360: 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 22 )..... (equal? "
8370: 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 y" (read-line)))
8380: 29 29 0a 09 09 20 20 20 20 20 20 28 6f 70 65 6e ))... (open
8390: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c 6f -run-close db:lo
83a0: 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 ck/unlock-run db
83b0: 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c run-id lock unl
83c0: 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 20 ock user)...
83d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
83e0: 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 20 nfo 0 "Skipping
83f0: 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 lock/unlock on "
8400: 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 run-id))))..
8410: 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d runs))).;;===
8420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8460: 3d 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 ===.;; Rollup ru
8470: 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ns.;;===========
8480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
84a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
84b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
84c0: 55 70 64 61 74 65 20 74 68 65 20 74 65 73 74 5f Update the test_
84d0: 6d 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 74 meta table for t
84e0: 68 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e 65 his test.(define
84f0: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 (runs:update-te
8500: 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d st_meta test-nam
8510: 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 e test-conf). (
8520: 6c 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 let ((currrecord
8530: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
8540: 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 db:testmeta-get
8550: 2d 72 65 63 6f 72 64 20 23 66 20 74 65 73 74 2d -record #f test-
8560: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 name))). (if
8570: 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 (not currrecord)
8580: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 ..(begin.. (set
8590: 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 ! currrecord (ma
85a0: 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 29 ke-vector 10 #f)
85b0: 29 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 ).. (cdb:remote
85c0: 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 -run db:testmeta
85d0: 2d 61 64 64 2d 72 65 63 6f 72 64 20 23 66 20 74 -add-record #f t
85e0: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 est-name))).
85f0: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
8600: 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 (lambda (key).
8610: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 78 (let* ((idx
8620: 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 20 (cadr key))..
8630: 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 6b (fld (car k
8640: 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 6c ey)).. (val
8650: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
8660: 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 5f test-conf "test_
8670: 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 3b meta" fld))).. ;
8680: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 ; (debug:print 5
8690: 20 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 66 "idx: " idx " f
86a0: 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c 3a ld: " fld " val:
86b0: 20 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 61 " val).. (if (a
86c0: 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 nd val (not (equ
86d0: 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 al? (vector-ref
86e0: 63 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 20 currrecord idx)
86f0: 76 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 val))).. (be
8700: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 gin.. (pri
8710: 6e 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 74 nt "Updating " t
8720: 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 est-name " " fld
8730: 20 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 " to " val)..
8740: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
8750: 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 -run db:testmeta
8760: 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 23 66 -update-field #f
8770: 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 test-name fld v
8780: 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 28 al))))). '((
8790: 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 6e "author" 2)("own
87a0: 65 72 22 20 33 29 28 22 64 65 73 63 72 69 70 74 er" 3)("descript
87b0: 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 65 ion" 4)("reviewe
87c0: 64 22 20 35 29 28 22 74 61 67 73 22 20 39 29 29 d" 5)("tags" 9))
87d0: 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 )))..;; Update t
87e0: 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c est_meta for all
87f0: 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 28 tests.(define (
8800: 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d runs:update-all-
8810: 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 test_meta db).
8820: 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 (let ((test-name
8830: 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c s (get-all-legal
8840: 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 -tests))). (f
8850: 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c or-each . (l
8860: 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 ambda (test-name
8870: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
8880: 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 (test-path (c
8890: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
88a0: 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d tests/" test-nam
88b0: 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 e)).. (test
88c0: 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 -configf (conc t
88d0: 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 est-path "/testc
88e0: 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 20 20 20 onfig"))..
88f0: 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 61 (testexists (a
8900: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
8910: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 test-configf)(f
8920: 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f ile-read-access?
8930: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 test-configf)))
8940: 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 61 64 20 .. ;; read
8950: 63 6f 6e 66 69 67 73 20 77 69 74 68 20 74 72 69 configs with tri
8960: 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 20 28 cks turned off (
8970: 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d 29 0a i.e. no system).
8980: 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e . (test-con
8990: 66 20 20 20 20 28 69 66 20 74 65 73 74 65 78 69 f (if testexi
89a0: 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 sts (read-config
89b0: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 test-configf #f
89c0: 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 2d 74 #f)(make-hash-t
89d0: 61 62 6c 65 29 29 29 29 0a 09 20 3b 3b 20 75 73 able)))).. ;; us
89e0: 65 20 74 68 65 20 6f 70 65 6e 2d 72 75 6e 2d 63 e the open-run-c
89f0: 6c 6f 73 65 20 69 6e 73 74 65 61 64 20 6f 66 20 lose instead of
8a00: 70 61 73 73 69 6e 67 20 69 6e 20 64 62 0a 09 20 passing in db..
8a10: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
8a20: 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 t_meta test-name
8a30: 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 test-conf))).
8a40: 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 test-names)))
8a50: 0a 0a 3b 3b 20 54 68 69 73 20 63 6f 75 6c 64 20 ..;; This could
8a60: 70 72 6f 62 61 62 6c 79 20 62 65 20 72 65 66 61 probably be refa
8a70: 63 74 6f 72 65 64 20 69 6e 74 6f 20 6f 6e 65 20 ctored into one
8a80: 63 6f 6d 70 6c 65 78 20 71 75 65 72 79 20 2e 2e complex query ..
8a90: 2e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
8aa0: 72 6f 6c 6c 75 70 2d 72 75 6e 20 6b 65 79 73 20 rollup-run keys
8ab0: 72 75 6e 6e 61 6d 65 20 75 73 65 72 20 6b 65 79 runname user key
8ac0: 76 61 6c 73 29 0a 20 20 28 64 65 62 75 67 3a 70 vals). (debug:p
8ad0: 72 69 6e 74 20 34 20 22 72 75 6e 73 3a 72 6f 6c rint 4 "runs:rol
8ae0: 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 lup-run, keys: "
8af0: 20 6b 65 79 73 20 22 20 3a 72 75 6e 6e 61 6d 65 keys " :runname
8b00: 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 73 65 " runname " use
8b10: 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c 65 r: " user). (le
8b20: 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
8b30: 20 20 20 20 20 23 66 29 0a 09 20 28 6e 65 77 2d #f).. (new-
8b40: 72 75 6e 2d 69 64 20 20 20 20 20 20 28 63 64 62 run-id (cdb
8b50: 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 72 :remote-run db:r
8b60: 65 67 69 73 74 65 72 2d 72 75 6e 20 23 66 20 6b egister-run #f k
8b70: 65 79 73 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e eys keyvals runn
8b80: 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 ame "new" "n/a"
8b90: 75 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d 74 user)).. (prev-t
8ba0: 65 73 74 73 20 20 20 20 20 20 28 6f 70 65 6e 2d ests (open-
8bb0: 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 3a 67 run-close test:g
8bc0: 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 et-matching-prev
8bd0: 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 ious-test-run-re
8be0: 63 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 6e cords db new-run
8bf0: 2d 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 20 -id "%" "%"))..
8c00: 28 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 20 (curr-tests
8c10: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
8c20: 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f db:get-tests-fo
8c30: 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e r-run db new-run
8c40: 2d 69 64 20 22 25 2f 25 22 20 27 28 29 20 27 28 -id "%/%" '() '(
8c50: 29 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 ))).. (curr-test
8c60: 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 s-hash (make-has
8c70: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 h-table))). (
8c80: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
8c90: 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 b:update-run-eve
8ca0: 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 2d 72 nt_time db new-r
8cb0: 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 69 6e un-id). ;; in
8cc0: 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 20 dex the already
8cd0: 73 61 76 65 64 20 74 65 73 74 73 20 62 79 20 74 saved tests by t
8ce0: 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 6d estname and item
8cf0: 64 61 74 20 69 6e 20 63 75 72 72 2d 74 65 73 74 dat in curr-test
8d00: 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f 72 2d s-hash. (for-
8d10: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
8d20: 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 a (testdat).
8d30: 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e (let* ((testn
8d40: 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ame (db:test-ge
8d50: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 t-testname testd
8d60: 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 at)).. (ite
8d70: 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d m-path (db:test-
8d80: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
8d90: 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 stdat)).. (
8da0: 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 full-name (conc
8db0: 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
8dc0: 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 61 73 m-path))).. (has
8dd0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 72 h-table-set! cur
8de0: 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c r-tests-hash ful
8df0: 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 l-name testdat))
8e00: 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 73 74 ). curr-test
8e10: 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 s). ;; NOPE:
8e20: 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 70 72 Non-optimal appr
8e30: 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 20 69 oach. Try this i
8e40: 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b 20 20 nstead.. ;;
8e50: 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 72 65 1. tests are re
8e60: 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 73 74 ceived in a list
8e70: 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 66 69 , most recent fi
8e80: 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 2e 20 rst. ;; 2.
8e90: 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f 6c 6c replace the roll
8ea0: 75 70 20 74 65 73 74 20 77 69 74 68 20 74 68 65 up test with the
8eb0: 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a 20 20 new *always*.
8ec0: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
8ed0: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 (lambda (testd
8ee0: 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a at). (let*
8ef0: 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 ((testname (db
8f00: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
8f10: 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 me testdat))..
8f20: 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 (item-path (
8f30: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
8f40: 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 29 0a -path testdat)).
8f50: 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d . (full-nam
8f60: 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 e (conc testname
8f70: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
8f80: 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d 74 65 .. (prev-te
8f90: 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 st-dat (hash-tab
8fa0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
8fb0: 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
8fc0: 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a 09 20 ull-name #f))..
8fd0: 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 73 (test-steps
8fe0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
8ff0: 6f 73 65 20 64 62 3a 67 65 74 2d 73 74 65 70 73 ose db:get-steps
9000: 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 28 64 62 -for-test db (db
9010: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
9020: 74 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 tdat))).. (
9030: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 new-test-record
9040: 23 66 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 #f)).. ;; replac
9050: 65 20 74 68 65 73 65 20 77 69 74 68 20 69 6e 73 e these with ins
9060: 65 72 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 ert ... select..
9070: 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a (apply sqlite3:
9080: 65 78 65 63 75 74 65 20 0a 09 09 64 62 20 0a 09 execute ...db ..
9090: 09 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f .(conc "INSERT O
90a0: 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 R REPLACE INTO t
90b0: 65 73 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 ests (run_id,tes
90c0: 74 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 tname,state,stat
90d0: 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f us,event_time,ho
90e0: 73 74 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 st,cpuload,diskf
90f0: 72 65 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 ree,uname,rundir
9100: 2c 69 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 ,item_path,run_d
9110: 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f uration,final_lo
9120: 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 gf,comment) "...
9130: 20 20 20 20 20 20 22 56 41 4c 55 45 53 20 28 3f "VALUES (?
9140: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
9150: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 ,?,?,?,?,?);")..
9160: 09 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 .new-run-id (cdd
9170: 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 r (vector->list
9180: 74 65 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 testdat))).. (se
9190: 74 21 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 t! new-testdat (
91a0: 63 61 72 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c car (open-run-cl
91b0: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 ose db:get-tests
91c0: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d -for-run db new-
91d0: 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 74 65 73 run-id (conc tes
91e0: 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 tname "/" item-p
91f0: 61 74 68 29 20 27 28 29 20 27 28 29 29 29 29 0a ath) '() '()))).
9200: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
9210: 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 t! curr-tests-ha
9220: 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 sh full-name new
9230: 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 74 68 69 -testdat) ;; thi
9240: 73 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 s could be confu
9250: 73 69 6e 67 2c 20 77 68 69 63 68 20 72 65 63 6f sing, which reco
9260: 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 rd should go int
9270: 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 o the lookup tab
9280: 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 le?.. ;; Now dup
9290: 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 licate the test
92a0: 73 74 65 70 73 0a 09 20 28 64 65 62 75 67 3a 70 steps.. (debug:p
92b0: 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 rint 4 "Copying
92c0: 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f records in test_
92d0: 73 74 65 70 73 20 66 72 6f 6d 20 74 65 73 74 5f steps from test_
92e0: 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 id=" (db:test-ge
92f0: 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 20 t-id testdat) "
9300: 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 to " (db:test-ge
9310: 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
9320: 29 29 0a 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 )).. (open-run-c
9330: 6c 6f 73 65 20 0a 09 20 20 28 6c 61 6d 62 64 61 lose .. (lambda
9340: 20 28 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 ().. (sqlite
9350: 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 3:execute ..
9360: 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 db .. (conc
9370: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
9380: 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 ACE INTO test_st
9390: 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 eps (test_id,ste
93a0: 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 pname,state,stat
93b0: 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f us,event_time,co
93c0: 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 mment) "... "S
93d0: 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 ELECT " (db:test
93e0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
93f0: 64 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c dat) ",stepname,
9400: 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 state,status,eve
9410: 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 nt_time,comment
9420: 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 FROM test_steps
9430: 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b WHERE test_id=?;
9440: 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 ").. (db:tes
9450: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
9460: 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 )).. ;; Now d
9470: 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 uplicate the tes
9480: 74 20 64 61 74 61 0a 09 20 20 20 20 28 64 65 62 t data.. (deb
9490: 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 ug:print 4 "Copy
94a0: 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 ing records in t
94b0: 65 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 est_data from te
94c0: 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
94d0: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
94e0: 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
94f0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
9500: 64 61 74 29 29 0a 09 20 20 20 20 28 73 71 6c 69 dat)).. (sqli
9510: 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 te3:execute ..
9520: 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f db .. (co
9530: 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 nc "INSERT OR RE
9540: 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f PLACE INTO test_
9550: 64 61 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 data (test_id,ca
9560: 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c tegory,variable,
9570: 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 value,expected,t
9580: 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 ol,units,comment
9590: 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 43 54 ) "... "SELECT
95a0: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
95b0: 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 id new-testdat)
95c0: 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 ",category,varia
95d0: 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 ble,value,expect
95e0: 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d ed,tol,units,com
95f0: 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 ment FROM test_d
9600: 61 74 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 ata WHERE test_i
9610: 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 d=?;").. (db
9620: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
9630: 74 64 61 74 29 29 29 29 0a 09 20 29 29 0a 20 20 tdat)))).. )).
9640: 20 20 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 prev-tests)))
9650: 0a 09 20 0a 20 20 20 20 20 0a .. . .