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: 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 79 73 20 ). (let ((keys
1370: 28 69 66 20 69 6e 6b 65 79 73 20 69 6e 6b 65 79 (if inkeys inkey
1380: 73 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 s (cdb:remote-ru
1390: 6e 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 23 66 n db:get-keys #f
13a0: 29 29 29 0a 09 28 76 61 6c 73 20 28 68 61 73 68 )))..(vals (hash
13b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
13c0: 6c 74 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d lt *env-vars-by-
13d0: 72 75 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 23 run-id* run-id #
13e0: 66 29 29 29 0a 20 20 20 20 3b 3b 20 67 65 74 20 f))). ;; get
13f0: 74 68 65 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 the info from th
1400: 65 20 64 62 20 61 6e 64 20 70 75 74 20 69 74 20 e db and put it
1410: 69 6e 20 74 68 65 20 63 61 63 68 65 0a 20 20 20 in the cache.
1420: 20 28 69 66 20 28 6e 6f 74 20 76 61 6c 73 29 0a (if (not vals).
1430: 09 28 6c 65 74 20 28 28 68 74 20 28 6d 61 6b 65 .(let ((ht (make
1440: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 -hash-table)))..
1450: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
1460: 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d t! *env-vars-by-
1470: 72 75 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 68 run-id* run-id h
1480: 74 29 0a 09 20 20 28 73 65 74 21 20 76 61 6c 73 t).. (set! vals
1490: 20 68 74 29 0a 09 20 20 28 66 6f 72 2d 65 61 63 ht).. (for-eac
14a0: 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6b h.. (lambda (k
14b0: 65 79 29 0a 09 20 20 20 20 20 28 68 61 73 68 2d ey).. (hash-
14c0: 74 61 62 6c 65 2d 73 65 74 21 20 76 61 6c 73 20 table-set! vals
14d0: 6b 65 79 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d key (cdb:remote-
14e0: 72 75 6e 20 64 62 3a 67 65 74 2d 72 75 6e 2d 6b run db:get-run-k
14f0: 65 79 2d 76 61 6c 20 23 66 20 72 75 6e 2d 69 64 ey-val #f run-id
1500: 20 6b 65 79 29 29 29 0a 09 20 20 20 6b 65 79 73 key))).. keys
1510: 29 29 29 0a 20 20 20 20 3b 3b 20 66 72 6f 6d 20 ))). ;; from
1520: 74 68 65 20 63 61 63 68 65 64 20 64 61 74 61 20 the cached data
1530: 73 65 74 20 74 68 65 20 76 61 72 73 0a 20 20 20 set the vars.
1540: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 (hash-table-for
1550: 2d 65 61 63 68 0a 20 20 20 20 20 76 61 6c 73 0a -each. vals.
1560: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b 65 (lambda (ke
1570: 79 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 64 y val). (d
1580: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 ebug:print 2 "se
1590: 74 65 6e 76 20 22 20 6b 65 79 20 22 20 22 20 76 tenv " key " " v
15a0: 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 65 al). (sete
15b0: 6e 76 20 6b 65 79 20 76 61 6c 29 29 29 0a 20 20 nv key val))).
15c0: 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 (alist->env-va
15d0: 72 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 rs (hash-table-r
15e0: 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 ef/default *conf
15f0: 69 67 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 igdat* "env-over
1600: 72 69 64 65 22 20 27 28 29 29 29 0a 20 20 20 20 ride" '())).
1610: 3b 3b 20 4c 65 74 73 20 75 73 65 20 74 68 69 73 ;; Lets use this
1620: 20 61 73 20 61 6e 20 6f 70 70 6f 72 74 75 6e 69 as an opportuni
1630: 74 79 20 74 6f 20 70 75 74 20 4d 54 5f 52 55 4e ty to put MT_RUN
1640: 4e 41 4d 45 20 69 6e 20 74 68 65 20 65 6e 76 69 NAME in the envi
1650: 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 28 73 65 74 ronment. (set
1660: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
1670: 20 28 69 66 20 69 6e 72 75 6e 6e 61 6d 65 20 69 (if inrunname i
1680: 6e 72 75 6e 6e 61 6d 65 20 28 63 64 62 3a 72 65 nrunname (cdb:re
1690: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d mote-run db:get-
16a0: 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 64 run-name-from-id
16b0: 20 23 66 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 #f run-id))).
16c0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
16d0: 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f N_AREA_HOME" *to
16e0: 70 70 61 74 68 2a 29 29 29 0a 0a 28 64 65 66 69 ppath*)))..(defi
16f0: 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 ne (set-item-env
1700: 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 20 -vars itemdat).
1710: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
1720: 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 20 da (item)..
1730: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
1740: 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 69 "setenv " (car i
1750: 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 69 tem) " " (cadr i
1760: 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 65 tem)).. (se
1770: 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 20 tenv (car item)
1780: 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 20 (cadr item)))..
1790: 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 itemdat))..(d
17a0: 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d 2d efine *last-num-
17b0: 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 30 running-tests* 0
17c0: 29 0a 0a 3b 3b 20 45 76 65 72 79 20 74 69 6d 65 )..;; Every time
17d0: 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 can-run-more-te
17e0: 73 74 73 20 69 73 20 63 61 6c 6c 65 64 20 69 6e sts is called in
17f0: 63 72 65 6d 65 6e 74 20 74 68 65 20 64 65 6c 61 crement the dela
1800: 79 0a 3b 3b 20 69 66 20 74 68 65 20 63 6f 75 0a y.;; if the cou.
1810: 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 3a 63 61 (define *runs:ca
1820: 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 n-run-more-tests
1830: 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 64 65 66 69 -count* 0).(defi
1840: 6e 65 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b 2d ne (runs:shrink-
1850: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
1860: 74 73 2d 63 6f 75 6e 74 29 0a 20 20 28 73 65 74 ts-count). (set
1870: 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d ! *runs:can-run-
1880: 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 more-tests-count
1890: 2a 20 30 29 29 20 3b 3b 20 28 2f 20 2a 72 75 6e * 0)) ;; (/ *run
18a0: 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 s:can-run-more-t
18b0: 65 73 74 73 2d 63 6f 75 6e 74 2a 20 32 29 29 29 ests-count* 2)))
18c0: 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
18d0: 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 can-run-more-tes
18e0: 74 73 20 74 65 73 74 2d 72 65 63 6f 72 64 20 6d ts test-record m
18f0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
1900: 62 73 29 0a 20 20 28 74 68 72 65 61 64 2d 73 6c bs). (thread-sl
1910: 65 65 70 21 20 28 63 6f 6e 64 0a 09 09 20 20 28 eep! (cond... (
1920: 28 3e 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e (> *runs:can-run
1930: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
1940: 74 2a 20 32 30 29 20 32 29 3b 3b 20 6f 62 76 69 t* 20) 2);; obvi
1950: 6f 75 73 6c 79 20 68 61 76 65 6e 27 74 20 68 61 ously haven't ha
1960: 64 20 61 6e 79 20 77 6f 72 6b 20 74 6f 20 64 6f d any work to do
1970: 20 66 6f 72 20 61 20 77 68 69 6c 65 0a 09 09 20 for a while...
1980: 20 28 65 6c 73 65 20 30 29 29 29 0a 20 20 28 6c (else 0))). (l
1990: 65 74 2a 20 28 28 74 63 6f 6e 66 69 67 20 20 20 et* ((tconfig
19a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
19b0: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
19c0: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 et-testconfig te
19d0: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 6a st-record)).. (j
19e0: 6f 62 67 72 6f 75 70 20 20 20 20 20 20 20 20 20 obgroup
19f0: 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c (config-l
1a00: 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 ookup tconfig "r
1a10: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6a 6f equirements" "jo
1a20: 62 67 72 6f 75 70 22 29 29 0a 09 20 28 6e 75 6d bgroup")).. (num
1a30: 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 -running
1a40: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
1a50: 2d 72 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 6e -run db:get-coun
1a60: 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 20 t-tests-running
1a70: 23 66 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e 6e #f)).. (num-runn
1a80: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
1a90: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
1aa0: 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 db:get-count-tes
1ab0: 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f ts-running-in-jo
1ac0: 62 67 72 6f 75 70 20 23 66 20 6a 6f 62 67 72 6f bgroup #f jobgro
1ad0: 75 70 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 up)).. (job-grou
1ae0: 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 20 p-limit
1af0: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a (config-lookup *
1b00: 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 67 configdat* "jobg
1b10: 72 6f 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 29 roups" jobgroup)
1b20: 29 29 0a 20 20 20 20 28 69 66 20 28 3e 20 28 2b )). (if (> (+
1b30: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 6d num-running num
1b40: 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 -running-in-jobg
1b50: 72 6f 75 70 29 20 30 29 0a 09 28 73 65 74 21 20 roup) 0)..(set!
1b60: 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f *runs:can-run-mo
1b70: 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 re-tests-count*
1b80: 28 2b 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e (+ *runs:can-run
1b90: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
1ba0: 74 2a 20 31 29 29 29 0a 20 20 20 20 28 69 66 20 t* 1))). (if
1bb0: 28 6e 6f 74 20 28 65 71 3f 20 2a 6c 61 73 74 2d (not (eq? *last-
1bc0: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 num-running-test
1bd0: 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 29 s* num-running))
1be0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
1bf0: 75 67 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 2d ug:print 2 "max-
1c00: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 3a concurrent-jobs:
1c10: 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e " max-concurren
1c20: 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 75 t-jobs ", num-ru
1c30: 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 6e nning: " num-run
1c40: 6e 69 6e 67 29 0a 09 20 20 28 73 65 74 21 20 2a ning).. (set! *
1c50: 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 last-num-running
1c60: 2d 74 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e -tests* num-runn
1c70: 69 6e 67 29 29 29 0a 20 20 20 20 28 69 66 20 28 ing))). (if (
1c80: 6e 6f 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f 62 not (eq? 0 *glob
1c90: 61 6c 65 78 69 74 73 74 61 74 75 73 2a 29 29 0a alexitstatus*)).
1ca0: 09 28 6c 69 73 74 20 23 66 20 6e 75 6d 2d 72 75 .(list #f num-ru
1cb0: 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e nning num-runnin
1cc0: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 g-in-jobgroup ma
1cd0: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
1ce0: 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 s job-group-limi
1cf0: 74 29 0a 09 28 6c 65 74 20 28 28 63 61 6e 2d 6e t)..(let ((can-n
1d00: 6f 74 2d 72 75 6e 2d 6d 6f 72 65 20 28 63 6f 6e ot-run-more (con
1d10: 64 0a 09 09 09 09 20 3b 3b 20 69 66 20 6d 61 78 d..... ;; if max
1d20: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1d30: 20 69 73 20 73 65 74 20 61 6e 64 20 74 68 65 20 is set and the
1d40: 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 20 69 number running i
1d50: 73 20 67 72 65 61 74 65 72 20 0a 09 09 09 09 20 s greater .....
1d60: 3b 3b 20 74 68 61 6e 20 69 74 20 74 68 61 6e 20 ;; than it than
1d70: 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 20 cannot run more
1d80: 6a 6f 62 73 0a 09 09 09 09 20 28 28 61 6e 64 20 jobs..... ((and
1d90: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
1da0: 6f 62 73 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e obs (>= num-runn
1db0: 69 6e 67 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 ing max-concurre
1dc0: 6e 74 2d 6a 6f 62 73 29 29 0a 09 09 09 09 20 20 nt-jobs)).....
1dd0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
1de0: 57 41 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 6e WARNING: Max run
1df0: 6e 69 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 64 ning jobs exceed
1e00: 65 64 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d 62 ed, current numb
1e10: 65 72 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 er running: " nu
1e20: 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 09 09 09 09 m-running ......
1e30: 20 20 20 20 20 20 20 22 2c 20 6d 61 78 5f 63 6f ", max_co
1e40: 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 22 ncurrent_jobs: "
1e50: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1e60: 6a 6f 62 73 29 0a 09 09 09 09 20 20 23 74 29 0a jobs)..... #t).
1e70: 09 09 09 09 20 3b 3b 20 69 66 20 6a 6f 62 2d 67 .... ;; if job-g
1e80: 72 6f 75 70 2d 6c 69 6d 69 74 20 69 73 20 73 65 roup-limit is se
1e90: 74 20 61 6e 64 20 6e 75 6d 62 65 72 20 6f 66 20 t and number of
1ea0: 6a 6f 62 73 20 69 6e 20 74 68 65 20 67 72 6f 75 jobs in the grou
1eb0: 70 20 69 73 20 67 72 65 61 74 65 72 0a 09 09 09 p is greater....
1ec0: 09 20 3b 3b 20 74 68 61 6e 20 74 68 65 20 6c 69 . ;; than the li
1ed0: 6d 69 74 20 74 68 65 6e 20 63 61 6e 6e 6f 74 20 mit then cannot
1ee0: 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 20 6f 66 run more jobs of
1ef0: 20 74 68 69 73 20 6b 69 6e 64 0a 09 09 09 09 20 this kind.....
1f00: 28 28 61 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 2d ((and job-group-
1f10: 6c 69 6d 69 74 0a 09 09 09 09 20 20 20 20 20 20 limit.....
1f20: 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 (>= num-running
1f30: 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f 62 -in-jobgroup job
1f40: 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 0a 09 -group-limit))..
1f50: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
1f60: 74 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 6e 75 t 1 "WARNING: nu
1f70: 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 22 20 6e mber of jobs " n
1f80: 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f um-running-in-jo
1f90: 62 67 72 6f 75 70 20 0a 09 09 09 09 09 20 20 20 bgroup ......
1fa0: 20 20 20 20 22 20 69 6e 20 22 20 6a 6f 62 67 72 " in " jobgr
1fb0: 6f 75 70 20 22 20 65 78 63 65 65 64 65 64 2c 20 oup " exceeded,
1fc0: 77 69 6c 6c 20 6e 6f 74 20 72 75 6e 20 22 20 28 will not run " (
1fd0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
1fe0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
1ff0: 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 09 09 20 t-record)).....
2000: 20 23 74 29 0a 09 09 09 09 20 28 65 6c 73 65 20 #t)..... (else
2010: 23 66 29 29 29 29 0a 09 20 20 28 6c 69 73 74 20 #f)))).. (list
2020: 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e (not can-not-run
2030: 2d 6d 6f 72 65 29 20 6e 75 6d 2d 72 75 6e 6e 69 -more) num-runni
2040: 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 ng num-running-i
2050: 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d 63 n-jobgroup max-c
2060: 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 6a oncurrent-jobs j
2070: 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 ob-group-limit))
2080: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
2090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
20a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
20b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
20c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
20d0: 20 4e 65 77 20 6d 65 74 68 6f 64 6f 6c 6f 67 79 New methodology
20e0: 2e 20 54 68 65 73 65 20 72 6f 75 74 69 6e 65 73 . These routines
20f0: 20 77 69 6c 6c 20 72 65 70 6c 61 63 65 20 74 68 will replace th
2100: 65 20 61 62 6f 76 65 20 69 6e 20 74 69 6d 65 2e e above in time.
2110: 20 46 6f 72 0a 3b 3b 20 6e 6f 77 20 74 68 65 20 For.;; now the
2120: 63 6f 64 65 20 69 73 20 64 75 70 6c 69 63 61 74 code is duplicat
2130: 65 64 2e 20 54 68 69 73 20 73 74 75 66 66 20 69 ed. This stuff i
2140: 73 20 69 6e 69 74 69 61 6c 6c 79 20 75 73 65 64 s initially used
2150: 20 69 6e 20 74 68 65 20 6d 6f 6e 69 74 6f 72 0a in the monitor.
2160: 3b 3b 20 62 61 73 65 64 20 63 6f 64 65 2e 0a 3b ;; based code..;
2170: 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21b0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 0a 3b 3b 20 54 68 69 =======...;; Thi
21c0: 73 20 69 73 20 61 20 64 75 70 6c 69 63 61 74 65 s is a duplicate
21d0: 20 6f 66 20 72 75 6e 2d 74 65 73 74 73 20 28 77 of run-tests (w
21e0: 68 69 63 68 20 68 61 73 20 62 65 65 6e 20 64 65 hich has been de
21f0: 70 72 65 63 61 74 65 64 29 2e 20 55 73 65 20 74 precated). Use t
2200: 68 69 73 20 6f 6e 65 20 69 6e 73 74 65 61 64 20 his one instead
2210: 6f 66 20 72 75 6e 20 74 65 73 74 73 2e 0a 3b 3b of run tests..;;
2220: 20 6b 65 79 76 61 6c 73 2e 0a 3b 3b 0a 3b 3b 20 keyvals..;;.;;
2230: 20 74 65 73 74 2d 6e 61 6d 65 73 3a 20 43 6f 6d test-names: Com
2240: 6d 61 20 73 65 70 61 72 61 74 65 64 20 70 61 74 ma separated pat
2250: 74 65 72 6e 73 20 73 61 6d 65 20 61 73 20 74 65 terns same as te
2260: 73 74 2d 70 61 74 74 73 20 62 75 74 20 75 73 65 st-patts but use
2270: 64 20 69 6e 20 73 65 6c 65 63 74 69 6f 6e 20 0a d in selection .
2280: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
2290: 6f 66 20 74 65 73 74 73 20 74 6f 20 72 75 6e 2e of tests to run.
22a0: 20 54 68 65 20 69 74 65 6d 20 70 6f 72 74 69 6f The item portio
22b0: 6e 73 20 61 72 65 20 6e 6f 74 20 72 65 73 70 65 ns are not respe
22c0: 63 74 65 64 2e 0a 3b 3b 20 20 20 20 20 20 20 20 cted..;;
22d0: 20 20 20 20 20 20 46 49 58 4d 45 3a 20 65 72 72 FIXME: err
22e0: 6f 72 20 6f 75 74 20 69 66 20 2f 70 61 74 74 20 or out if /patt
22f0: 73 70 65 63 69 66 69 65 64 0a 3b 3b 20 20 20 20 specified.;;
2300: 20 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 .(define
2310: 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 (runs:run-tests
2320: 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 target runname
2330: 74 65 73 74 2d 70 61 74 74 73 20 75 73 65 72 20 test-patts user
2340: 66 6c 61 67 73 29 20 3b 3b 20 74 65 73 74 2d 6e flags) ;; test-n
2350: 61 6d 65 73 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 63 ames. (common:c
2360: 6c 65 61 72 2d 63 61 63 68 65 73 29 20 3b 3b 20 lear-caches) ;;
2370: 63 6c 65 61 72 20 61 6c 6c 20 63 61 63 68 65 73 clear all caches
2380: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
2390: 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 6b 65 #f).. (ke
23a0: 79 73 20 20 20 20 20 20 20 20 28 6b 65 79 73 3a ys (keys:
23b0: 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 config-get-field
23c0: 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 0a s *configdat*)).
23d0: 09 20 28 6b 65 79 76 61 6c 73 20 20 20 20 20 28 . (keyvals (
23e0: 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 keys:target->key
23f0: 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 val keys target)
2400: 29 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 20 ).. (run-id
2410: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
2420: 20 64 62 3a 72 65 67 69 73 74 65 72 2d 72 75 6e db:register-run
2430: 20 23 66 20 6b 65 79 73 20 6b 65 79 76 61 6c 73 #f keys keyvals
2440: 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 22 runname "new" "
2450: 6e 2f 61 22 20 75 73 65 72 29 29 20 20 3b 3b 20 n/a" user)) ;;
2460: 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 20 test-name)))..
2470: 28 64 65 66 65 72 72 65 64 20 20 20 20 27 28 29 (deferred '()
2480: 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 6e 6e 69 ) ;; delay runni
2490: 6e 67 20 74 68 65 73 65 20 73 69 6e 63 65 20 74 ng these since t
24a0: 68 65 79 20 68 61 76 65 20 61 20 77 61 69 74 6f hey have a waito
24b0: 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b 20 6b 65 n clause.. ;; ke
24c0: 65 70 67 6f 69 6e 67 20 69 73 20 74 68 65 20 64 epgoing is the d
24d0: 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 74 79 20 efacto modality
24e0: 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 20 68 69 now, will add hi
24f0: 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 20 6c 61 t-n-run a bit la
2500: 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 70 67 6f ter.. ;; (keepgo
2510: 69 6e 67 20 20 20 28 68 61 73 68 2d 74 61 62 6c ing (hash-tabl
2520: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
2530: 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 22 ags "-keepgoing"
2540: 20 23 66 29 29 0a 09 20 28 72 75 6e 63 6f 6e 66 #f)).. (runconf
2550: 69 67 66 20 20 20 28 63 6f 6e 63 20 20 2a 74 6f igf (conc *to
2560: 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 ppath* "/runconf
2570: 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 igs.config"))..
2580: 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 (required-tests
2590: 27 28 29 29 0a 09 20 28 74 65 73 74 2d 72 65 63 '()).. (test-rec
25a0: 6f 72 64 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d ords (make-hash-
25b0: 74 61 62 6c 65 29 29 0a 09 20 28 74 65 73 74 2d table)).. (test-
25c0: 6e 61 6d 65 73 20 27 28 29 29 29 0a 0a 20 20 20 names '()))..
25d0: 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 (set-megatest-e
25e0: 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 69 nv-vars run-id i
25f0: 6e 6b 65 79 73 3a 20 6b 65 79 73 29 20 3b 3b 20 nkeys: keys) ;;
2600: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
2610: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
2620: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 0a 20 20 hing process..
2630: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
2640: 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a ts? runconfigf).
2650: 09 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 61 .(setup-env-defa
2660: 75 6c 74 73 20 72 75 6e 63 6f 6e 66 69 67 66 20 ults runconfigf
2670: 72 75 6e 2d 69 64 20 2a 61 6c 72 65 61 64 79 2d run-id *already-
2680: 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 seen-runconfig-i
2690: 6e 66 6f 2a 20 6b 65 79 73 20 6b 65 79 76 61 6c nfo* keys keyval
26a0: 73 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e s "pre-launch-en
26b0: 76 2d 76 61 72 73 22 29 0a 09 28 64 65 62 75 67 v-vars")..(debug
26c0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
26d0: 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 61 G: You do not ha
26e0: 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 20 ve a run config
26f0: 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 69 file: " runconfi
2700: 67 66 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b gf)). . ;;
2710: 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 73 look up all tes
2720: 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 20 ts matching the
2730: 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 comma separated
2740: 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 6e list of globs in
2750: 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 74 . ;; test-pat
2760: 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 77 ts (using % as w
2770: 69 6c 64 63 61 72 64 29 0a 0a 20 20 20 20 28 73 ildcard).. (s
2780: 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 28 et! test-names (
2790: 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 2d tests:get-valid-
27a0: 74 65 73 74 73 20 2a 74 6f 70 70 61 74 68 2a 20 tests *toppath*
27b0: 74 65 73 74 2d 70 61 74 74 73 29 29 0a 20 20 20 test-patts)).
27c0: 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 (set! test-name
27d0: 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 s (delete-duplic
27e0: 61 74 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 29 ates test-names)
27f0: 29 0a 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
2800: 69 6e 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 74 int-info 0 "test
2810: 20 6e 61 6d 65 73 20 22 20 74 65 73 74 2d 6e 61 names " test-na
2820: 6d 65 73 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e 20 mes).. ;; on
2830: 74 68 65 20 66 69 72 73 74 20 70 61 73 73 20 6f the first pass o
2840: 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 65 r call to run-te
2850: 73 74 73 20 73 65 74 20 46 41 49 4c 53 20 74 6f sts set FAILS to
2860: 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 66 0a NOT_STARTED if.
2870: 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e ;; -keepgoin
2880: 67 20 69 73 20 73 70 65 63 69 66 69 65 64 0a 20 g is specified.
2890: 20 20 20 28 69 66 20 28 65 71 3f 20 2a 70 61 73 (if (eq? *pas
28a0: 73 6e 75 6d 2a 20 30 29 0a 09 28 62 65 67 69 6e snum* 0)..(begin
28b0: 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 64 .. ;; have to d
28c0: 65 6c 65 74 65 20 74 65 73 74 20 72 65 63 6f 72 elete test recor
28d0: 64 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 41 ds where NOT_STA
28e0: 52 54 45 44 20 73 69 6e 63 65 20 74 68 65 79 20 RTED since they
28f0: 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 67 can cause -keepg
2900: 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 67 oing to .. ;; g
2910: 65 74 20 73 74 75 63 6b 20 64 75 65 20 74 6f 20 et stuck due to
2920: 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 73 becoming inacces
2930: 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 69 sible from a fai
2940: 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 69 led test. I.e. i
2950: 66 20 74 65 73 74 20 42 20 64 65 70 65 6e 64 73 f test B depends
2960: 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 20 .. ;; on test
2970: 41 20 62 75 74 20 74 65 73 74 20 42 20 72 65 61 A but test B rea
2980: 63 68 65 64 20 74 68 65 20 70 6f 69 6e 74 20 6f ched the point o
2990: 6e 20 62 65 69 6e 67 20 72 65 67 69 73 74 65 72 n being register
29a0: 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 45 ed as NOT_STARTE
29b0: 44 20 61 6e 64 20 74 65 73 74 0a 09 20 20 3b 3b D and test.. ;;
29c0: 20 41 20 66 61 69 6c 65 64 20 66 6f 72 20 73 6f A failed for so
29d0: 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 6f me reason then o
29e0: 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 2d n re-run using -
29f0: 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 20 72 75 keepgoing the ru
2a00: 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d 70 n can never comp
2a10: 6c 65 74 65 2e 0a 09 20 20 28 63 64 62 3a 64 65 lete... (cdb:de
2a20: 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 74 lete-tests-in-st
2a30: 61 74 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 ate *runremote*
2a40: 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 52 run-id "NOT_STAR
2a50: 54 45 44 22 29 0a 09 20 20 28 63 64 62 3a 72 65 TED").. (cdb:re
2a60: 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 73 65 74 2d mote-run db:set-
2a70: 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 74 tests-state-stat
2a80: 75 73 20 23 66 20 72 75 6e 2d 69 64 20 74 65 73 us #f run-id tes
2a90: 74 2d 6e 61 6d 65 73 20 23 66 20 22 46 41 49 4c t-names #f "FAIL
2aa0: 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 " "NOT_STARTED"
2ab0: 22 46 41 49 4c 22 29 29 29 0a 0a 20 20 20 20 3b "FAIL"))).. ;
2ac0: 3b 20 66 72 6f 6d 20 68 65 72 65 20 6f 6e 20 6f ; from here on o
2ad0: 75 74 20 74 68 65 20 64 62 20 77 69 6c 6c 20 62 ut the db will b
2ae0: 65 20 6f 70 65 6e 65 64 20 61 6e 64 20 63 6c 6f e opened and clo
2af0: 73 65 64 20 6f 6e 20 65 76 65 72 79 20 63 61 6c sed on every cal
2b00: 6c 20 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 l runs:run-tests
2b10: 2d 71 75 65 75 65 0a 20 20 20 20 3b 3b 20 28 73 -queue. ;; (s
2b20: 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 qlite3:finalize!
2b30: 20 64 62 29 20 0a 20 20 20 20 3b 3b 20 6e 6f 77 db) . ;; now
2b40: 20 61 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c add non-directl
2b50: 79 20 72 65 66 65 72 65 6e 63 65 64 20 64 65 70 y referenced dep
2b60: 65 6e 64 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 endencies (i.e.
2b70: 77 61 69 74 6f 6e 29 0a 20 20 20 20 28 69 66 20 waiton). (if
2b80: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
2b90: 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c -names))..(let l
2ba0: 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 oop ((hed (car t
2bb0: 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 est-names))...
2bc0: 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d (tal (cdr test-
2bd0: 6e 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 names)))
2be0: 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 ;; 'return-proc
2bf0: 73 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 s tells the conf
2c00: 69 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 ig reader to pre
2c10: 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d p running system
2c20: 20 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 but return a pr
2c30: 6f 63 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 oc.. (debug:pri
2c40: 6e 74 2d 69 6e 66 6f 20 34 20 22 68 65 64 3d 22 nt-info 4 "hed="
2c50: 20 68 65 64 20 22 20 61 74 20 74 6f 70 20 6f 66 hed " at top of
2c60: 20 6c 6f 6f 70 22 29 0a 09 20 20 28 6c 65 74 2a loop").. (let*
2c70: 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 74 ((config (test
2c80: 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 s:get-testconfig
2c90: 20 68 65 64 20 27 72 65 74 75 72 6e 2d 70 72 6f hed 'return-pro
2ca0: 63 73 29 29 0a 09 09 20 28 77 61 69 74 6f 6e 73 cs))... (waitons
2cb0: 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 28 69 (let ((instr (i
2cc0: 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 09 20 f config ......
2cd0: 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 (config-lookup
2ce0: 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 config "require
2cf0: 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 ments" "waiton")
2d00: 0a 09 09 09 09 09 20 20 20 28 62 65 67 69 6e 20 ...... (begin
2d10: 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 61 ;; No config mea
2d20: 6e 73 20 74 68 69 73 20 69 73 20 61 20 6e 6f 6e ns this is a non
2d30: 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 0a 09 -existant test..
2d40: 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 3a .... (debug:
2d50: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
2d60: 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 71 non-existent req
2d70: 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 68 uired test \"" h
2d80: 65 64 20 22 5c 22 22 29 0a 09 09 09 09 09 20 20 ed "\"")......
2d90: 20 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 (if db (sqlit
2da0: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 e3:finalize! db)
2db0: 29 0a 09 09 09 09 09 20 20 20 20 20 28 65 78 69 )...... (exi
2dc0: 74 20 31 29 29 29 29 29 0a 09 09 09 20 20 20 20 t 1)))))....
2dd0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2de0: 6f 20 38 20 22 77 61 69 74 6f 6e 73 20 73 74 72 o 8 "waitons str
2df0: 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 0a ing is " instr).
2e00: 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 73 ... (string-s
2e10: 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 09 plit (cond......
2e20: 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ((procedure?
2e30: 69 6e 73 74 72 29 0a 09 09 09 09 09 20 20 20 20 instr)......
2e40: 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 74 (let ((res (inst
2e50: 72 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 r)))......
2e60: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
2e70: 6f 20 38 20 22 77 61 69 74 6f 6e 20 70 72 6f 63 o 8 "waiton proc
2e80: 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 6e edure results in
2e90: 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 20 string " res "
2ea0: 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 0a for test " hed).
2eb0: 09 09 09 09 09 20 20 20 20 20 20 72 65 73 29 29 ..... res))
2ec0: 0a 09 09 09 09 09 20 20 20 28 28 73 74 72 69 6e ...... ((strin
2ed0: 67 3f 20 69 6e 73 74 72 29 20 20 20 20 20 69 6e g? instr) in
2ee0: 73 74 72 29 0a 09 09 09 09 09 20 20 20 28 65 6c str)...... (el
2ef0: 73 65 20 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 se ...... ;;
2f00: 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 63 NOTE: This is ac
2f10: 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 20 tually the case
2f20: 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 21 of *no* waitons!
2f30: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
2f40: 20 30 20 22 45 52 52 4f 52 3a 20 73 6f 6d 65 74 0 "ERROR: somet
2f50: 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 hing went wrong
2f60: 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 61 in processing wa
2f70: 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 22 itons for test "
2f80: 20 68 65 64 29 0a 09 09 09 09 09 20 20 20 20 22 hed)...... "
2f90: 22 29 29 29 29 29 29 0a 09 20 20 20 20 28 64 65 ")))))).. (de
2fa0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 bug:print-info 8
2fb0: 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 "waitons: " wai
2fc0: 74 6f 6e 73 29 0a 09 20 20 20 20 3b 3b 20 63 68 tons).. ;; ch
2fd0: 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 77 eck for hed in w
2fe0: 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 77 aitons => this w
2ff0: 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 72 ould be circular
3000: 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 , remove it and
3010: 69 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b 3b issue an.. ;;
3020: 20 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 20 error.. (if
3030: 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 74 (member hed wait
3040: 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 ons)...(begin...
3050: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3060: 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 20 "ERROR: test "
3070: 68 65 64 20 22 20 68 61 73 20 6c 69 73 74 65 64 hed " has listed
3080: 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 69 itself as a wai
3090: 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 72 ton, please corr
30a0: 65 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 20 ect this!")...
30b0: 28 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 66 (set! waitons (f
30c0: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
30d0: 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 20 )(not (equal? x
30e0: 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 29 hed))) waitons))
30f0: 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b 3b )).. .. ;;
3100: 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d 73 (items (items
3110: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
3120: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 29 config config)))
3130: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
3140: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3150: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f efault test-reco
3160: 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 28 rds hed #f))...(
3170: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
3180: 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 test-records....
3190: 09 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 65 . hed (vector he
31a0: 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 d ;; 0......
31b0: 20 20 20 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 config ;;
31c0: 31 0a 09 09 09 09 09 20 20 20 20 20 77 61 69 74 1...... wait
31d0: 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 ons ;; 2......
31e0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
31f0: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
3200: 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 ements" "priorit
3210: 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 y") ;; prior
3220: 69 74 79 20 33 0a 09 09 09 09 09 20 20 20 20 20 ity 3......
3230: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
3240: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
3250: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
3260: 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b 3b "items" #f)) ;;
3270: 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 20 items 4.......
3280: 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 (itemstable (h
3290: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
32a0: 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 fault config "it
32b0: 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 emstable" #f)))
32c0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
32d0: 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 20 if either items
32e0: 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 69 or items table i
32f0: 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e 20 s a proc return
3300: 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 it so test runni
3310: 6e 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b ng...... ;
3320: 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e ; process can kn
3330: 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 ow to call items
3340: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
3350: 63 6f 6e 66 69 67 0a 09 09 09 09 09 20 20 20 20 config......
3360: 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 ;; if either
3370: 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f is a list and no
3380: 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f 20 ne is a proc go
3390: 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 ahead and call g
33a0: 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 20 20 et-items......
33b0: 20 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 ;; otherwis
33c0: 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 e return #f - th
33d0: 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 is is not an ite
33e0: 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 09 rated test......
33f0: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 (cond....
3400: 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ...((procedure?
3410: 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 09 items) ....
3420: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
3430: 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 69 -info 4 "items i
3440: 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 s a procedure, w
3450: 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 ill calc later")
3460: 0a 09 09 09 09 09 09 20 69 74 65 6d 73 29 20 20 ....... items)
3470: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 6c ;; cal
3480: 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 c later.......((
3490: 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d 73 procedure? items
34a0: 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 64 table)....... (d
34b0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
34c0: 34 20 22 69 74 65 6d 73 74 61 62 6c 65 20 69 73 4 "itemstable is
34d0: 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 69 a procedure, wi
34e0: 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 0a ll calc later").
34f0: 09 09 09 09 09 09 20 69 74 65 6d 73 74 61 62 6c ...... itemstabl
3500: 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c 63 e) ;; calc
3510: 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 66 later.......((f
3520: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
3530: 29 0a 09 09 09 09 09 09 09 20 20 20 28 6c 65 74 )........ (let
3540: 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 29 ((val (car x)))
3550: 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 69 66 ........ (if
3560: 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 6c (procedure? val
3570: 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 09 ) val #f))).....
3580: 09 09 09 20 28 61 70 70 65 6e 64 20 28 69 66 20 ... (append (if
3590: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 74 (list? items) it
35a0: 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 09 ems '())........
35b0: 09 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 65 . (if (list? ite
35c0: 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 61 mstable) itemsta
35d0: 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 09 ble '())))......
35e0: 09 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 . 'have-procedur
35f0: 65 29 0a 09 09 09 09 09 09 28 28 6f 72 20 28 6c e).......((or (l
3600: 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 74 ist? items)(list
3610: 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 3b ? itemstable)) ;
3620: 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 09 ; calc now......
3630: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 . (debug:print-i
3640: 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 61 6e 64 nfo 4 "items and
3650: 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 20 itemstable are
3660: 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 5c lists, calc now\
3670: 6e 22 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 n"........
3680: 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 74 " items: " it
3690: 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c 65 ems " itemstable
36a0: 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 0a : " itemstable).
36b0: 09 09 09 09 09 09 20 28 69 74 65 6d 73 3a 67 65 ...... (items:ge
36c0: 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e t-items-from-con
36d0: 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 09 fig config))....
36e0: 09 09 09 28 65 6c 73 65 20 23 66 29 29 29 20 20 ...(else #f)))
36f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3700: 20 20 20 20 20 20 20 20 20 3b 3b 20 6e 6f 74 20 ;; not
3710: 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 20 20 iterated......
3720: 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 69 74 #f ;; it
3730: 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 20 20 emsdat 5......
3740: 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 73 70 #f ;; sp
3750: 61 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 69 are - used for i
3760: 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 20 20 tem-path......
3770: 20 20 20 29 29 29 0a 09 20 20 20 20 28 66 6f 72 ))).. (for
3780: 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 6c 61 -each .. (la
3790: 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 20 mbda (waiton)..
37a0: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 77 (if (and w
37b0: 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d 62 aiton (not (memb
37c0: 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d 6e er waiton test-n
37d0: 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 62 65 ames)))... (be
37e0: 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 21 gin... (set!
37f0: 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 required-tests
3800: 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 71 (cons waiton req
3810: 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 09 uired-tests))...
3820: 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 2d (set! test-
3830: 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 74 names (cons wait
3840: 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 on test-names)))
3850: 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 70 )) ;; was an app
3860: 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 0a end, now a cons.
3870: 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 0a 09 . waitons)..
3880: 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 65 (let ((remte
3890: 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c sts (delete-dupl
38a0: 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 77 icates (append w
38b0: 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a 09 aitons tal))))..
38c0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
38d0: 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 29 null? remtests))
38e0: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
38f0: 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 65 remtests)(cdr re
3900: 6d 74 65 73 74 73 29 29 29 29 29 29 29 0a 0a 20 mtests)))))))..
3910: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
3920: 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 l? required-test
3930: 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e s))..(debug:prin
3940: 74 2d 69 6e 66 6f 20 31 20 22 41 64 64 69 6e 67 t-info 1 "Adding
3950: 20 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 " required-test
3960: 73 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 71 s " to the run q
3970: 75 65 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 4e ueue")). ;; N
3980: 4f 54 45 3a 20 74 68 65 73 65 20 61 72 65 20 61 OTE: these are a
3990: 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 74 73 2c ll parent tests,
39a0: 20 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 65 items are not e
39b0: 78 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 20 xpanded yet..
39c0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
39d0: 66 6f 20 34 20 22 74 65 73 74 2d 72 65 63 6f 72 fo 4 "test-recor
39e0: 64 73 3d 22 20 28 68 61 73 68 2d 74 61 62 6c 65 ds=" (hash-table
39f0: 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 72 65 63 ->alist test-rec
3a00: 6f 72 64 73 29 29 0a 20 20 20 20 28 6c 65 74 20 ords)). (let
3a10: 28 28 72 65 67 6c 65 6e 20 28 61 6e 79 2d 3e 6e ((reglen (any->n
3a20: 75 6d 62 65 72 20 20 28 63 6f 6e 66 69 67 66 3a umber (configf:
3a30: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
3a40: 74 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e 71 t* "setup" "runq
3a50: 75 65 75 65 22 29 29 29 29 0a 20 20 20 20 20 20 ueue")))).
3a60: 28 69 66 20 72 65 67 6c 65 6e 0a 09 20 20 28 72 (if reglen.. (r
3a70: 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 75 uns:run-tests-qu
3a80: 65 75 65 2d 6e 65 77 20 72 75 6e 2d 69 64 20 72 eue-new run-id r
3a90: 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 6f unname test-reco
3aa0: 72 64 73 20 66 6c 61 67 73 20 74 65 73 74 2d 70 rds flags test-p
3ab0: 61 74 74 73 20 72 65 67 6c 65 6e 29 0a 09 20 20 atts reglen)..
3ac0: 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d (runs:run-tests-
3ad0: 71 75 65 75 65 2d 63 6c 61 73 73 69 63 20 72 75 queue-classic ru
3ae0: 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 n-id runname tes
3af0: 74 2d 72 65 63 6f 72 64 73 20 66 6c 61 67 73 20 t-records flags
3b00: 74 65 73 74 2d 70 61 74 74 73 29 29 29 0a 20 20 test-patts))).
3b10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
3b20: 6e 66 6f 20 34 20 22 41 6c 6c 20 64 6f 6e 65 20 nfo 4 "All done
3b30: 62 79 20 68 65 72 65 22 29 29 29 0a 0a 28 64 65 by here")))..(de
3b40: 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 2d fine (runs:calc-
3b50: 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e 6f fails prereqs-no
3b60: 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 72 t-met). (filter
3b70: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
3b80: 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 6f . (and (vecto
3b90: 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 20 r? test) ;; not
3ba0: 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 0a (string? test)).
3bb0: 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 .. (equal? (db:t
3bc0: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 est-get-state te
3bd0: 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 st) "COMPLETED")
3be0: 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 ... (not (member
3bf0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
3c00: 61 74 75 73 20 74 65 73 74 29 0a 09 09 09 20 20 atus test)....
3c10: 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 41 '("PASS" "WA
3c20: 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 RN" "CHECK" "WAI
3c30: 56 45 44 22 20 22 53 4b 49 50 22 29 29 29 29 29 VED" "SKIP")))))
3c40: 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 2d .. prereqs-not-
3c50: 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 met))..(define (
3c60: 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 6f runs:calc-not-co
3c70: 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 2d mpleted prereqs-
3c80: 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 not-met). (filt
3c90: 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 74 er. (lambda (t
3ca0: 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 ). (or (not
3cb0: 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 28 (vector? t)).. (
3cc0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 4f 4d not (equal? "COM
3cd0: 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 73 74 PLETED" (db:test
3ce0: 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 29 29 -get-state t))))
3cf0: 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 ). prereqs-not
3d00: 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -met))..(define
3d10: 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 72 (runs:pretty-str
3d20: 69 6e 67 20 6c 73 74 29 0a 20 20 28 6d 61 70 20 ing lst). (map
3d30: 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 28 69 (lambda (t).. (i
3d40: 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f 20 f (not (vector?
3d50: 74 29 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 t)).. (conc
3d60: 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 28 t).. (conc (
3d70: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
3d80: 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 3a name t) ":" (db:
3d90: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
3da0: 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d 67 ) "/" (db:test-g
3db0: 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 0a et-status t)))).
3dc0: 20 20 20 20 20 20 20 6c 73 74 29 29 0a 0a 28 64 lst))..(d
3dd0: 65 66 69 6e 65 20 28 72 75 6e 73 3a 6d 61 6b 65 efine (runs:make
3de0: 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 20 -full-test-name
3df0: 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 testname itempat
3e00: 68 29 0a 20 20 28 69 66 20 28 65 71 75 61 6c 3f h). (if (equal?
3e10: 20 69 74 65 6d 70 61 74 68 20 22 22 29 20 74 65 itempath "") te
3e20: 73 74 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 stname (conc tes
3e30: 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 tname "/" itempa
3e40: 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 th)))..(define (
3e50: 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d runs:queue-next-
3e60: 68 65 64 20 74 61 6c 20 72 65 67 20 6e 20 72 65 hed tal reg n re
3e70: 67 66 75 6c 29 0a 20 20 28 69 66 20 72 65 67 66 gful). (if regf
3e80: 75 6c 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 ul. (if (nu
3e90: 6c 6c 3f 20 72 65 67 29 20 3b 3b 20 64 6f 65 73 ll? reg) ;; does
3ea0: 6e 27 74 20 6d 61 6b 65 20 73 65 6e 73 65 2c 20 n't make sense,
3eb0: 74 68 69 73 20 69 73 20 70 72 6f 62 61 62 6c 79 this is probably
3ec0: 20 4e 4f 54 20 74 68 65 20 70 72 6f 62 6c 65 6d NOT the problem
3ed0: 20 6f 66 20 74 68 65 20 63 61 72 0a 09 20 20 28 of the car.. (
3ee0: 63 61 72 20 74 61 6c 29 0a 09 20 20 28 63 61 72 car tal).. (car
3ef0: 20 72 65 67 29 29 0a 20 20 20 20 20 20 28 63 61 reg)). (ca
3f00: 72 20 74 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e r tal)))..(defin
3f10: 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 e (runs:queue-ne
3f20: 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 6e xt-tal tal reg n
3f30: 20 72 65 67 66 75 6c 29 0a 20 20 28 69 66 20 72 regful). (if r
3f40: 65 67 66 75 6c 0a 20 20 20 20 20 20 74 61 6c 0a egful. tal.
3f50: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 (let ((new
3f60: 74 61 6c 20 28 63 64 72 20 74 61 6c 29 29 29 0a tal (cdr tal))).
3f70: 09 28 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 74 .(if (null? newt
3f80: 61 6c 29 0a 09 20 20 20 20 72 65 67 0a 09 20 20 al).. reg..
3f90: 20 20 6e 65 77 74 61 6c 0a 09 20 20 20 20 29 29 newtal.. ))
3fa0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e ))..(define (run
3fb0: 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 67 s:queue-next-reg
3fc0: 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 75 tal reg n regfu
3fd0: 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c 0a l). (if regful.
3fe0: 20 20 20 20 20 20 28 63 64 72 20 72 65 67 29 0a (cdr reg).
3ff0: 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 28 (if (eq? (
4000: 6c 65 6e 67 74 68 20 74 61 6c 29 20 31 29 0a 09 length tal) 1)..
4010: 20 20 27 28 29 0a 09 20 20 72 65 67 29 29 29 0a '().. reg))).
4020: 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 6e 2d 74 .(include "run-t
4030: 65 73 74 73 2d 71 75 65 75 65 2d 63 6c 61 73 73 ests-queue-class
4040: 69 63 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ic.scm").(includ
4050: 65 20 22 72 75 6e 2d 74 65 73 74 73 2d 71 75 65 e "run-tests-que
4060: 75 65 2d 6e 65 77 2e 73 63 6d 22 29 0a 0a 3b 3b ue-new.scm")..;;
4070: 20 70 61 72 65 6e 74 2d 74 65 73 74 20 69 73 20 parent-test is
4080: 74 68 65 72 65 20 61 73 20 61 20 70 6c 61 63 65 there as a place
4090: 68 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 6e 20 holder for when
40a0: 70 61 72 65 6e 74 2d 74 65 73 74 73 20 63 61 6e parent-tests can
40b0: 20 62 65 20 72 75 6e 20 61 73 20 61 20 73 65 74 be run as a set
40c0: 75 70 20 73 74 65 70 0a 28 64 65 66 69 6e 65 20 up step.(define
40d0: 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 64 (run:test run-id
40e0: 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 2d 76 61 run-info key-va
40f0: 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d ls runname test-
4100: 72 65 63 6f 72 64 20 66 6c 61 67 73 20 70 61 72 record flags par
4110: 65 6e 74 2d 74 65 73 74 29 0a 20 20 3b 3b 20 41 ent-test). ;; A
4120: 6c 6c 20 74 68 65 73 65 20 76 61 72 73 20 6d 69 ll these vars mi
4130: 67 68 74 20 62 65 20 72 65 66 65 72 65 6e 63 65 ght be reference
4140: 64 20 62 79 20 74 68 65 20 74 65 73 74 63 6f 6e d by the testcon
4150: 66 69 67 20 66 69 6c 65 20 72 65 61 64 65 72 0a fig file reader.
4160: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 6e (let* ((test-n
4170: 61 6d 65 20 20 20 20 28 74 65 73 74 73 3a 74 65 ame (tests:te
4180: 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 stqueue-get-test
4190: 6e 61 6d 65 20 20 20 74 65 73 74 2d 72 65 63 6f name test-reco
41a0: 72 64 29 29 0a 09 20 28 74 65 73 74 2d 77 61 69 rd)).. (test-wai
41b0: 74 6f 6e 73 20 28 74 65 73 74 73 3a 74 65 73 74 tons (tests:test
41c0: 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f 6e queue-get-waiton
41d0: 73 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 s test-record
41e0: 29 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 20 )).. (test-conf
41f0: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 (tests:testqu
4200: 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e 66 eue-get-testconf
4210: 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 ig test-record))
4220: 0a 09 20 28 69 74 65 6d 64 61 74 20 20 20 20 20 .. (itemdat
4230: 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 (tests:testqueu
4240: 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 20 e-get-itemdat
4250: 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 test-record))..
4260: 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 (test-path (
4270: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
4280: 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 /tests/" test-na
4290: 6d 65 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 73 me)) ;; could us
42a0: 65 20 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 e tests:get-test
42b0: 63 6f 6e 66 69 67 20 68 65 72 65 20 2e 2e 2e 0a config here ....
42c0: 09 20 28 66 6f 72 63 65 20 20 20 20 20 20 20 20 . (force
42d0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
42e0: 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d default flags "-
42f0: 66 6f 72 63 65 22 20 23 66 29 29 0a 09 20 28 72 force" #f)).. (r
4300: 65 72 75 6e 20 20 20 20 20 20 20 20 28 68 61 73 erun (has
4310: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4320: 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 65 72 75 ult flags "-reru
4330: 6e 22 20 23 66 29 29 0a 09 20 28 6b 65 65 70 67 n" #f)).. (keepg
4340: 6f 69 6e 67 20 20 20 20 28 68 61 73 68 2d 74 61 oing (hash-ta
4350: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4360: 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e flags "-keepgoin
4370: 67 22 20 23 66 29 29 0a 09 20 28 69 74 65 6d 2d g" #f)).. (item-
4380: 70 61 74 68 20 20 20 20 20 22 22 29 0a 09 20 28 path "").. (
4390: 64 62 20 20 20 20 20 20 20 20 20 20 20 23 66 29 db #f)
43a0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
43b0: 6e 74 20 34 0a 09 09 20 22 74 65 73 74 2d 63 6f nt 4... "test-co
43c0: 6e 66 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 nfig: " (hash-ta
43d0: 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d ble->alist test-
43e0: 63 6f 6e 66 29 0a 09 09 20 22 5c 6e 20 20 20 69 conf)... "\n i
43f0: 74 65 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 61 temdat: " itemda
4400: 74 0a 09 09 20 29 0a 20 20 20 20 3b 3b 20 73 65 t... ). ;; se
4410: 74 74 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f tting itemdat to
4420: 20 61 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 a list if it is
4430: 20 23 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 #f. (if (not
4440: 20 69 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 itemdat)(set! i
4450: 74 65 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 temdat '())).
4460: 20 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 (set! item-path
4470: 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 (item-list->pat
4480: 68 20 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 h itemdat)).
4490: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
44a0: 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c 61 Attempting to la
44b0: 75 6e 63 68 20 74 65 73 74 20 22 20 74 65 73 74 unch test " test
44c0: 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 6c -name (if (equal
44d0: 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 2f 22 29 ? item-path "/")
44e0: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
44f0: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT
4500: 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 _TEST_NAME" test
4510: 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 20 28 -name) ;; . (
4520: 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 setenv "MT_RUNNA
4530: 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 20 ME" runname).
4540: 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 (set-megatest
4550: 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 -env-vars run-id
4560: 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e 6e inrunname: runn
4570: 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 ame) ;; these ma
4580: 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 y be needed by t
4590: 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f he launching pro
45a0: 63 65 73 73 0a 20 20 20 20 28 63 68 61 6e 67 65 cess. (change
45b0: 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 -directory *topp
45c0: 61 74 68 2a 29 0a 0a 20 20 20 20 3b 3b 20 48 65 ath*).. ;; He
45d0: 72 65 20 69 73 20 77 68 65 72 65 20 74 68 65 20 re is where the
45e0: 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 20 test_meta table
45f0: 69 73 20 62 65 73 74 20 75 70 64 61 74 65 64 0a is best updated.
4600: 20 20 20 20 3b 3b 20 59 65 73 2c 20 61 6e 6f 74 ;; Yes, anot
4610: 68 65 72 20 75 73 65 20 6f 66 20 61 20 67 6c 6f her use of a glo
4620: 62 61 6c 20 66 6f 72 20 63 61 63 68 69 6e 67 2e bal for caching.
4630: 20 4e 65 65 64 20 61 20 62 65 74 74 65 72 20 77 Need a better w
4640: 61 79 3f 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ay?. (if (not
4650: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
4660: 2f 64 65 66 61 75 6c 74 20 2a 74 65 73 74 2d 6d /default *test-m
4670: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 73 eta-updated* tes
4680: 74 2d 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 20 t-name #f)).
4690: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 28 (begin.. (
46a0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
46b0: 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 *test-meta-updat
46c0: 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 74 ed* test-name #t
46d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 75 ). (ru
46e0: 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f 6d ns:update-test_m
46f0: 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 eta test-name te
4700: 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 0a st-conf))). .
4710: 20 20 20 20 3b 3b 20 28 6c 61 6d 62 64 61 20 28 ;; (lambda (
4720: 69 74 65 6d 64 61 74 29 20 3b 3b 3b 20 28 28 72 itemdat) ;;; ((r
4730: 69 70 65 6e 65 73 73 20 22 6f 76 65 72 72 69 70 ipeness "overrip
4740: 65 22 29 20 28 74 65 6d 70 65 72 61 74 75 72 65 e") (temperature
4750: 20 22 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f 6e "cool") (season
4760: 20 22 73 75 6d 6d 65 72 22 29 29 0a 20 20 20 20 "summer")).
4770: 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 74 (let* ((new-test
4780: 2d 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 6e -path (string-in
4790: 74 65 72 73 70 65 72 73 65 20 28 63 6f 6e 73 20 tersperse (cons
47a0: 74 65 73 74 2d 70 61 74 68 20 28 6d 61 70 20 63 test-path (map c
47b0: 61 64 72 20 69 74 65 6d 64 61 74 29 29 20 22 2f adr itemdat)) "/
47c0: 22 29 29 0a 09 20 20 20 28 6e 65 77 2d 74 65 73 ")).. (new-tes
47d0: 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 t-name (if (equa
47e0: 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 29 l? item-path "")
47f0: 20 74 65 73 74 2d 6e 61 6d 65 20 28 63 6f 6e 63 test-name (conc
4800: 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 test-name "/" i
4810: 74 65 6d 2d 70 61 74 68 29 29 29 20 3b 3b 20 6a tem-path))) ;; j
4820: 75 73 74 20 6e 65 65 64 20 69 74 20 74 6f 20 62 ust need it to b
4830: 65 20 75 6e 69 71 75 65 0a 09 20 20 20 28 74 65 e unique.. (te
4840: 73 74 2d 69 64 20 20 20 20 20 20 20 28 63 64 62 st-id (cdb
4850: 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 :remote-run db:g
4860: 65 74 2d 74 65 73 74 2d 69 64 20 23 66 20 20 72 et-test-id #f r
4870: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
4880: 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 item-path))..
4890: 28 74 65 73 74 64 61 74 20 20 20 20 20 20 20 28 (testdat (
48a0: 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 cdb:get-test-inf
48b0: 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d 6f o-by-id *runremo
48c0: 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 0a 20 te* test-id))).
48d0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 65 (if (not te
48e0: 73 74 64 61 74 29 0a 09 20 20 28 62 65 67 69 6e stdat).. (begin
48f0: 0a 09 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 20 .. ;; ensure
4900: 74 68 61 74 20 74 68 65 20 70 61 74 68 20 65 78 that the path ex
4910: 69 73 74 73 20 62 65 66 6f 72 65 20 72 65 67 69 ists before regi
4920: 73 74 65 72 69 6e 67 20 74 68 65 20 74 65 73 74 stering the test
4930: 0a 09 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 43 .. ;; NOPE: C
4940: 61 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 6b 6e 6f annot! Don't kno
4950: 77 20 79 65 74 20 77 68 69 63 68 20 64 69 73 6b w yet which disk
4960: 20 61 72 65 61 20 77 69 6c 6c 20 62 65 20 61 73 area will be as
4970: 73 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 20 signed......
4980: 3b 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 ;; (system (conc
4990: 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6e 65 77 "mkdir -p " new
49a0: 2d 74 65 73 74 2d 70 61 74 68 29 29 0a 09 20 20 -test-path))..
49b0: 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 28 6f 70 ;;.. ;; (op
49c0: 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 en-run-close tes
49d0: 74 73 3a 72 65 67 69 73 74 65 72 2d 74 65 73 74 ts:register-test
49e0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test-
49f0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 0a name item-path).
4a00: 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 . ;;.. ;;
4a10: 4e 42 2f 2f 20 66 6f 72 20 74 68 65 20 61 62 6f NB// for the abo
4a20: 76 65 20 6c 69 6e 65 2e 20 49 20 77 61 6e 74 20 ve line. I want
4a30: 74 68 65 20 74 65 73 74 20 74 6f 20 62 65 20 72 the test to be r
4a40: 65 67 69 73 74 65 72 65 64 20 6c 6f 6e 67 20 62 egistered long b
4a50: 65 66 6f 72 65 20 74 68 69 73 20 72 6f 75 74 69 efore this routi
4a60: 6e 65 20 67 65 74 73 20 63 61 6c 6c 65 64 21 0a ne gets called!.
4a70: 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 73 65 . ;;.. (se
4a80: 74 21 20 74 65 73 74 2d 69 64 20 28 6f 70 65 6e t! test-id (open
4a90: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 -run-close db:ge
4aa0: 74 2d 74 65 73 74 2d 69 64 20 64 62 20 72 75 6e t-test-id db run
4ab0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
4ac0: 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 28 em-path)).. (
4ad0: 69 66 20 28 6e 6f 74 20 74 65 73 74 2d 69 64 29 if (not test-id)
4ae0: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 ...(begin... (d
4af0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 57 41 ebug:print 2 "WA
4b00: 52 4e 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 65 RN: Test not pre
4b10: 2d 63 72 65 61 74 65 64 3f 20 74 65 73 74 2d 6e -created? test-n
4b20: 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 ame=" test-name
4b30: 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 22 20 69 ", item-path=" i
4b40: 74 65 6d 2d 70 61 74 68 20 22 2c 20 72 75 6e 2d tem-path ", run-
4b50: 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a 09 09 20 id=" run-id)...
4b60: 20 28 63 64 62 3a 74 65 73 74 73 2d 72 65 67 69 (cdb:tests-regi
4b70: 73 74 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 65 ster-test *runre
4b80: 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 73 mote* run-id tes
4b90: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
4ba0: 29 0a 09 09 20 20 28 73 65 74 21 20 74 65 73 74 )... (set! test
4bb0: 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c -id (open-run-cl
4bc0: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 2d ose db:get-test-
4bd0: 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 id db run-id tes
4be0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
4bf0: 29 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 )))).. (debug
4c00: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 74 :print-info 4 "t
4c10: 65 73 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 64 est-id=" test-id
4c20: 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 6e ", run-id=" run
4c30: 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d 65 -id ", test-name
4c40: 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 =" test-name ",
4c50: 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 20 69 74 item-path=\"" it
4c60: 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 0a 09 20 em-path "\"")..
4c70: 20 20 20 28 73 65 74 21 20 74 65 73 74 64 61 74 (set! testdat
4c80: 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 (cdb:get-test-i
4c90: 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 nfo-by-id *runre
4ca0: 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 mote* test-id)))
4cb0: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 74 65 ). (set! te
4cc0: 73 74 2d 69 64 20 28 64 62 3a 74 65 73 74 2d 67 st-id (db:test-g
4cd0: 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a et-id testdat)).
4ce0: 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 (change-di
4cf0: 72 65 63 74 6f 72 79 20 74 65 73 74 2d 70 61 74 rectory test-pat
4d00: 68 29 0a 20 20 20 20 20 20 28 63 61 73 65 20 28 h). (case (
4d10: 69 66 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 67 if force ;; (arg
4d20: 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 63 s:get-arg "-forc
4d30: 65 22 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 54 e")...'NOT_START
4d40: 45 44 0a 09 09 28 69 66 20 74 65 73 74 64 61 74 ED...(if testdat
4d50: 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 3e ... (string->
4d60: 73 79 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 74 symbol (test:get
4d70: 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 -state testdat))
4d80: 0a 09 09 20 20 20 20 27 66 61 69 6c 65 64 2d 74 ... 'failed-t
4d90: 6f 2d 69 6e 73 65 72 74 29 29 0a 09 28 28 66 61 o-insert))..((fa
4da0: 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 0a iled-to-insert).
4db0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 . (debug:print 0
4dc0: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
4dd0: 74 6f 20 69 6e 73 65 72 74 20 74 68 65 20 72 65 to insert the re
4de0: 63 6f 72 64 20 69 6e 74 6f 20 74 68 65 20 64 62 cord into the db
4df0: 22 29 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 54 "))..((NOT_START
4e00: 45 44 20 43 4f 4d 50 4c 45 54 45 44 20 44 45 4c ED COMPLETED DEL
4e10: 45 54 45 44 29 0a 09 20 28 6c 65 74 20 28 28 72 ETED).. (let ((r
4e20: 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 20 unflag #f))..
4e30: 28 63 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 2d 66 (cond.. ;; -f
4e40: 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 74 orce, run no mat
4e50: 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 66 ter what.. (f
4e60: 6f 72 63 65 20 28 73 65 74 21 20 72 75 6e 66 6c orce (set! runfl
4e70: 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 ag #t)).. ;;
4e80: 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 6e NOT_STARTED, run
4e90: 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 0a no matter what.
4ea0: 09 20 20 20 20 28 28 6d 65 6d 62 65 72 20 28 74 . ((member (t
4eb0: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
4ec0: 73 74 64 61 74 29 20 27 28 22 44 45 4c 45 54 45 stdat) '("DELETE
4ed0: 44 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 D" "NOT_STARTED"
4ee0: 29 29 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 ))(set! runflag
4ef0: 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 #t)).. ;; not
4f00: 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 53 53 -rerun and PASS
4f10: 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c , WARN or CHECK,
4f20: 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 do no run..
4f30: 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 ((and (or (not r
4f40: 65 72 75 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 erun)... ke
4f50: 65 70 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 epgoing)... ;;
4f60: 52 65 71 75 69 72 65 20 74 6f 20 66 6f 72 63 65 Require to force
4f70: 20 72 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 re-run for COMP
4f80: 4c 45 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 LETED or *anythi
4f90: 6e 67 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 ng* + PASS,WARN
4fa0: 6f 72 20 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 or CHECK... (or
4fb0: 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 (member (test:g
4fc0: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
4fd0: 74 29 20 27 28 22 50 41 53 53 22 20 22 57 41 52 t) '("PASS" "WAR
4fe0: 4e 22 20 22 43 48 45 43 4b 22 20 22 53 4b 49 50 N" "CHECK" "SKIP
4ff0: 22 29 29 0a 09 09 20 20 20 20 20 20 28 6d 65 6d "))... (mem
5000: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
5010: 61 74 65 20 20 74 65 73 74 64 61 74 29 20 27 28 ate testdat) '(
5020: 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 20 "COMPLETED"))))
5030: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
5040: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 72 75 6e 6e int-info 2 "runn
5050: 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 2d ing test " test-
5060: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
5070: 74 68 20 22 20 73 75 70 70 72 65 73 73 65 64 20 th " suppressed
5080: 61 73 20 69 74 20 69 73 20 22 20 28 74 65 73 74 as it is " (test
5090: 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 :get-state testd
50a0: 61 74 29 20 22 20 61 6e 64 20 22 20 28 74 65 73 at) " and " (tes
50b0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
50c0: 74 64 61 74 29 29 0a 09 20 20 20 20 20 28 73 65 tdat)).. (se
50d0: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a t! runflag #f)).
50e0: 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 6e 20 61 . ;; -rerun a
50f0: 6e 64 20 73 74 61 74 75 73 20 69 73 20 6f 6e 65 nd status is one
5100: 20 6f 66 20 74 68 65 20 73 70 65 63 69 66 65 64 of the specifed
5110: 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 20 28 28 , run it.. ((
5120: 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 20 28 6c and rerun... (l
5130: 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 74 20 20 et* ((rerunlst
5140: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 72 (string-split r
5150: 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 09 20 28 erun ",")).... (
5160: 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d 65 6d 62 must-rerun (memb
5170: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
5180: 74 75 73 20 74 65 73 74 64 61 74 29 20 72 65 72 tus testdat) rer
5190: 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 20 20 28 unlst)))... (
51a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
51b0: 20 33 20 22 2d 72 65 72 75 6e 20 6c 69 73 74 3a 3 "-rerun list:
51c0: 20 22 20 72 65 72 75 6e 20 22 2c 20 74 65 73 74 " rerun ", test
51d0: 2d 73 74 61 74 75 73 3a 20 22 20 28 74 65 73 74 -status: " (test
51e0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
51f0: 64 61 74 29 22 2c 20 6d 75 73 74 2d 72 65 72 75 dat)", must-reru
5200: 6e 3a 20 22 20 6d 75 73 74 2d 72 65 72 75 6e 29 n: " must-rerun)
5210: 0a 09 09 20 20 20 20 6d 75 73 74 2d 72 65 72 75 ... must-reru
5220: 6e 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 n)).. (debug
5230: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 52 :print-info 2 "R
5240: 65 72 75 6e 20 66 6f 72 63 65 64 20 66 6f 72 20 erun forced for
5250: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
5260: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 0a "/" item-path).
5270: 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 . (set! runf
5280: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
5290: 20 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 64 6f 20 -keepgoing, do
52a0: 6e 6f 74 20 72 65 72 75 6e 20 46 41 49 4c 0a 09 not rerun FAIL..
52b0: 20 20 20 20 28 28 61 6e 64 20 6b 65 65 70 67 6f ((and keepgo
52c0: 69 6e 67 0a 09 09 20 20 28 6d 65 6d 62 65 72 20 ing... (member
52d0: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 (test:get-status
52e0: 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 49 testdat) '("FAI
52f0: 4c 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 74 L"))).. (set
5300: 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 ! runflag #f))..
5310: 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 72 ((and (not r
5320: 65 72 75 6e 29 0a 09 09 20 20 28 6d 65 6d 62 65 erun)... (membe
5330: 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 r (test:get-stat
5340: 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 46 us testdat) '("F
5350: 41 49 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 20 AIL" "n/a")))..
5360: 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c 61 (set! runfla
5370: 67 20 23 74 29 29 0a 09 20 20 20 20 28 65 6c 73 g #t)).. (els
5380: 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 e (set! runflag
5390: 23 66 29 29 29 0a 09 20 20 20 28 64 65 62 75 67 #f))).. (debug
53a0: 3a 70 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 4e :print 6 "RUNNIN
53b0: 47 20 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 20 G => runflag: "
53c0: 72 75 6e 66 6c 61 67 20 22 20 53 54 41 54 45 3a runflag " STATE:
53d0: 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 " (test:get-sta
53e0: 74 65 20 74 65 73 74 64 61 74 29 20 22 20 53 54 te testdat) " ST
53f0: 41 54 55 53 3a 20 22 20 28 74 65 73 74 3a 67 65 ATUS: " (test:ge
5400: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
5410: 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 )).. (if (not
5420: 72 75 6e 66 6c 61 67 29 0a 09 20 20 20 20 20 20 runflag)..
5430: 20 28 69 66 20 28 6e 6f 74 20 70 61 72 65 6e 74 (if (not parent
5440: 2d 74 65 73 74 29 0a 09 09 20 20 20 28 64 65 62 -test)... (deb
5450: 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 ug:print 1 "NOTE
5460: 3a 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 74 : Not starting t
5470: 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e est " new-test-n
5480: 61 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 73 ame " as it is s
5490: 74 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a 67 tate \"" (test:g
54a0: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
54b0: 29 20 0a 09 09 09 09 22 5c 22 20 61 6e 64 20 73 ) ....."\" and s
54c0: 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 3a tatus \"" (test:
54d0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
54e0: 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 72 65 at) "\", use -re
54f0: 72 75 6e 20 5c 22 22 20 28 74 65 73 74 3a 67 65 run \"" (test:ge
5500: 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 t-status testdat
5510: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
5520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5530: 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 20 "\" or -force
5540: 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 0a 09 to override"))..
5550: 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 ;; NOTE:
5560: 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 68 65 No longer be che
5570: 63 6b 69 6e 67 20 70 72 65 72 65 71 75 69 73 69 cking prerequisi
5580: 74 65 73 20 68 65 72 65 21 20 57 69 6c 6c 20 6e tes here! Will n
5590: 65 76 65 72 20 67 65 74 20 68 65 72 65 20 75 6e ever get here un
55a0: 6c 65 73 73 20 70 72 65 72 65 71 73 20 61 72 65 less prereqs are
55b0: 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 .. ;;
55c0: 20 20 61 6c 72 65 61 64 79 20 6d 65 74 2e 0a 09 already met...
55d0: 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 77 ;; This w
55e0: 6f 75 6c 64 20 62 65 20 61 20 67 72 65 61 74 20 ould be a great
55f0: 70 6c 61 63 65 20 74 6f 20 64 6f 20 74 68 65 20 place to do the
5600: 70 72 6f 63 65 73 73 2d 66 6f 72 6b 0a 09 20 20 process-fork..
5610: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6c (if (not (l
5620: 61 75 6e 63 68 2d 74 65 73 74 20 74 65 73 74 2d aunch-test test-
5630: 69 64 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e id run-id run-in
5640: 66 6f 20 6b 65 79 2d 76 61 6c 73 20 72 75 6e 6e fo key-vals runn
5650: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 74 65 ame test-conf te
5660: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 st-name test-pat
5670: 68 20 69 74 65 6d 64 61 74 20 66 6c 61 67 73 29 h itemdat flags)
5680: 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 )... (begin...
5690: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 (print "ERR
56a0: 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 OR: Failed to la
56b0: 75 6e 63 68 20 74 68 65 20 74 65 73 74 2e 20 45 unch the test. E
56c0: 78 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 61 xiting as soon a
56d0: 73 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 20 s possible")...
56e0: 20 20 20 20 28 73 65 74 21 20 2a 67 6c 6f 62 61 (set! *globa
56f0: 6c 65 78 69 74 73 74 61 74 75 73 2a 20 31 29 20 lexitstatus* 1)
5700: 3b 3b 20 0a 09 09 20 20 20 20 20 28 70 72 6f 63 ;; ... (proc
5710: 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 ess-signal (curr
5720: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 ent-process-id)
5730: 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 29 29 signal/kill)))))
5740: 29 0a 09 28 28 4b 49 4c 4c 45 44 29 20 0a 09 20 )..((KILLED) ..
5750: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
5760: 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 74 65 73 74 NOTE: " new-test
5770: 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 -name " is alrea
5780: 64 79 20 72 75 6e 6e 69 6e 67 20 6f 72 20 77 61 dy running or wa
5790: 73 20 65 78 70 6c 69 63 74 6c 79 20 6b 69 6c 6c s explictly kill
57a0: 65 64 2c 20 75 73 65 20 2d 66 6f 72 63 65 20 74 ed, use -force t
57b0: 6f 20 6c 61 75 6e 63 68 20 69 74 2e 22 29 29 0a o launch it.")).
57c0: 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d 4f .((LAUNCHED REMO
57d0: 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e 4e TEHOSTSTART RUNN
57e0: 49 4e 47 29 20 20 0a 09 20 28 69 66 20 28 3e 20 ING) .. (if (>
57f0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
5800: 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 73 74 2d nds)(+ (db:test-
5810: 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 74 get-event_time t
5820: 65 73 74 64 61 74 29 0a 09 09 09 09 20 20 20 20 estdat).....
5830: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
5840: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 run_duration tes
5850: 74 64 61 74 29 29 29 0a 09 09 36 30 30 29 20 3b tdat)))...600) ;
5860: 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 64 61 74 65 ; i.e. no update
5870: 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 36 for more than 6
5880: 30 30 20 73 65 63 6f 6e 64 73 0a 09 20 20 20 20 00 seconds..
5890: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
58a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
58b0: 57 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 20 WARNING: Test "
58c0: 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 65 test-name " appe
58d0: 61 72 73 20 74 6f 20 62 65 20 64 65 61 64 2e 20 ars to be dead.
58e0: 46 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 73 74 Forcing it to st
58f0: 61 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 61 ate INCOMPLETE a
5900: 6e 64 20 73 74 61 74 75 73 20 53 54 55 43 4b 2f nd status STUCK/
5910: 44 45 41 44 22 29 0a 09 20 20 20 20 20 20 20 28 DEAD").. (
5920: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 tests:test-set-s
5930: 74 61 74 75 73 21 20 74 65 73 74 2d 69 64 20 22 tatus! test-id "
5940: 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 55 INCOMPLETE" "STU
5950: 43 4b 2f 44 45 41 44 22 20 22 54 65 73 74 20 69 CK/DEAD" "Test i
5960: 73 20 73 74 75 63 6b 20 6f 72 20 64 65 61 64 22 s stuck or dead"
5970: 20 23 66 29 29 0a 09 20 20 20 20 20 28 64 65 62 #f)).. (deb
5980: 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 ug:print 2 "NOTE
5990: 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 : " test-name "
59a0: 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e 69 is already runni
59b0: 6e 67 22 29 29 29 0a 09 28 65 6c 73 65 20 20 20 ng")))..(else
59c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
59d0: 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 0 "ERROR: Faile
59e0: 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 74 d to launch test
59f0: 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 " new-test-name
5a00: 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 64 ". Unrecognised
5a10: 20 73 74 61 74 65 20 22 20 28 74 65 73 74 3a 67 state " (test:g
5a20: 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 et-state testdat
5a30: 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))))..;;=====
5a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5a80: 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 20 =.;; END OF NEW
5a90: 53 54 55 46 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d STUFF.;;========
5aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
5ae0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 69 72 (define (get-dir
5af0: 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 61 -up-n dir . para
5b00: 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 64 70 ms) . (let ((dp
5b10: 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 70 arts (string-sp
5b20: 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a 09 28 lit dir "/"))..(
5b30: 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e 75 6c count (if (nul
5b40: 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 63 61 l? params) 1 (ca
5b50: 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 r params)))).
5b60: 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
5b70: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
5b80: 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 64 70 . (take dp
5b90: 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 arts (- (length
5ba0: 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 29 0a dparts) count)).
5bb0: 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 29 0a . "/")))).
5bc0: 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a 3b ;; Remove runs.;
5bd0: 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 73 ; fields are pas
5be0: 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 20 sing in through
5bf0: 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 20 .;; action:.;;
5c00: 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 3b 'remove-runs.;
5c10: 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 65 2d ; 'set-state-
5c20: 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 2f status.;;.;; NB/
5c30: 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 69 6e / should pass in
5c40: 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e keys?.;;.(defin
5c50: 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d e (runs:operate-
5c60: 6f 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 65 74 on action target
5c70: 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 73 runnamepatt tes
5c80: 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 61 tpatt #!key (sta
5c90: 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 66 te #f)(status #f
5ca0: 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 74 )(new-state-stat
5cb0: 75 73 20 23 66 29 29 0a 20 20 28 63 6f 6d 6d 6f us #f)). (commo
5cc0: 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 20 n:clear-caches)
5cd0: 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 63 ;; clear all cac
5ce0: 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 hes. (let* ((db
5cf0: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 09 #f)..
5d00: 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 (keys (
5d10: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
5d20: 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a b:get-keys db)).
5d30: 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 20 . (rundat
5d40: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
5d50: 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 runs:get-runs-by
5d60: 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 -patt db keys ru
5d70: 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 65 74 nnamepatt target
5d80: 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 20 )).. (header
5d90: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
5da0: 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 6e undat 0)).. (run
5db0: 73 20 20 20 20 20 20 20 20 20 28 76 65 63 74 6f s (vecto
5dc0: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 r-ref rundat 1))
5dd0: 0a 09 20 28 73 74 61 74 65 73 20 20 20 20 20 20 .. (states
5de0: 20 28 69 66 20 73 74 61 74 65 20 20 28 73 74 72 (if state (str
5df0: 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 65 20 ing-split state
5e00: 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 73 ",") '())).. (s
5e10: 74 61 74 75 73 65 73 20 20 20 20 20 28 69 66 20 tatuses (if
5e20: 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d 73 status (string-s
5e30: 70 6c 69 74 20 73 74 61 74 75 73 20 22 2c 22 29 plit status ",")
5e40: 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 65 2d '())).. (state-
5e50: 73 74 61 74 75 73 20 28 69 66 20 28 73 74 72 69 status (if (stri
5e60: 6e 67 3f 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 ng? new-state-st
5e70: 61 74 75 73 29 20 28 73 74 72 69 6e 67 2d 73 70 atus) (string-sp
5e80: 6c 69 74 20 6e 65 77 2d 73 74 61 74 65 2d 73 74 lit new-state-st
5e90: 61 74 75 73 20 22 2c 22 29 20 27 28 23 66 20 23 atus ",") '(#f #
5ea0: 66 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 f)))). (debug
5eb0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 72 :print-info 4 "r
5ec0: 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 3d uns:operate-on =
5ed0: 3e 20 48 65 61 64 65 72 3a 20 22 20 68 65 61 64 > Header: " head
5ee0: 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 61 er " action: " a
5ef0: 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 74 ction " new-stat
5f00: 65 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 77 2d e-status: " new-
5f10: 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 20 20 state-status).
5f20: 20 20 28 69 66 20 28 3e 20 32 20 28 6c 65 6e 67 (if (> 2 (leng
5f30: 74 68 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 th state-status)
5f40: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
5f50: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
5f60: 4f 52 3a 20 74 68 65 20 70 61 72 61 6d 65 74 65 OR: the paramete
5f70: 72 20 74 6f 20 2d 73 65 74 2d 73 74 61 74 65 2d r to -set-state-
5f80: 73 74 61 74 75 73 20 69 73 20 61 20 63 6f 6d 6d status is a comm
5f90: 61 20 64 65 6c 69 6d 69 74 65 64 20 73 74 72 69 a delimited stri
5fa0: 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d 50 4c 45 54 ng. E.g. COMPLET
5fb0: 45 44 2c 46 41 49 4c 22 29 0a 09 20 20 28 65 78 ED,FAIL").. (ex
5fc0: 69 74 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 it))). (for-e
5fd0: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
5fe0: 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 28 6c (run). (l
5ff0: 65 74 20 28 28 72 75 6e 6b 65 79 20 28 73 74 72 et ((runkey (str
6000: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
6010: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b 29 (map (lambda (k)
6020: 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 2d 76 .......(db:get-v
6030: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 alue-by-header r
6040: 75 6e 20 68 65 61 64 65 72 20 6b 29 29 20 6b 65 un header k)) ke
6050: 79 73 29 20 22 2f 22 29 29 0a 09 20 20 20 20 20 ys) "/"))..
6060: 28 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 (dirs-to-remove
6070: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
6080: 29 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 75 ))).. (let* ((ru
6090: 6e 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 2d n-id (db:get-
60a0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
60b0: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
60c0: 29 0a 09 09 28 72 75 6e 2d 73 74 61 74 65 20 28 )...(run-state (
60d0: 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db:get-value-by-
60e0: 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 header run heade
60f0: 72 20 22 73 74 61 74 65 22 29 29 0a 09 09 28 74 r "state"))...(t
6100: 65 73 74 73 20 20 20 20 20 28 69 66 20 28 6e 6f ests (if (no
6110: 74 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 73 74 t (equal? run-st
6120: 61 74 65 20 22 6c 6f 63 6b 65 64 22 29 29 0a 09 ate "locked"))..
6130: 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
6140: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 2d un-close db:get-
6150: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 62 tests-for-run db
6160: 20 72 75 6e 2d 69 64 0a 09 09 09 09 09 09 20 20 run-id.......
6170: 20 20 20 20 74 65 73 74 70 61 74 74 20 73 74 61 testpatt sta
6180: 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 09 tes statuses....
6190: 09 09 09 20 20 20 20 20 20 6e 6f 74 2d 69 6e 3a ... not-in:
61a0: 20 20 23 66 0a 09 09 09 09 09 09 20 20 20 20 20 #f.......
61b0: 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 65 20 sort-by: (case
61c0: 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 09 20 action.........
61d0: 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 27 ((remove-runs) '
61e0: 72 75 6e 64 69 72 29 0a 09 09 09 09 09 09 09 09 rundir).........
61f0: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 (else
6200: 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 0a 09 'event_time)))..
6210: 09 09 20 20 20 20 20 20 20 27 28 29 29 29 0a 09 .. '()))..
6220: 09 28 6c 61 73 74 74 70 61 74 68 20 22 2f 64 6f .(lasttpath "/do
6230: 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 es/not/exist/I/h
6240: 6f 70 65 22 29 29 0a 09 20 20 20 28 64 65 62 75 ope")).. (debu
6250: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
6260: 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 runs:operate-on
6270: 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 68 65 61 run=" run ", hea
6280: 64 65 72 3d 22 20 68 65 61 64 65 72 29 0a 09 20 der=" header)..
6290: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
62a0: 3f 20 74 65 73 74 73 29 29 0a 09 20 20 20 20 20 ? tests))..
62b0: 20 20 28 62 65 67 69 6e 0a 09 09 20 28 63 61 73 (begin... (cas
62c0: 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 28 28 e action... ((
62d0: 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 20 remove-runs)...
62e0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
62f0: 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 74 1 "Removing test
6300: 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 6e s for run: " run
6310: 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 2d key " " (db:get-
6320: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
6330: 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e 6e run header "runn
6340: 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 73 ame")))... ((s
6350: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 et-state-status)
6360: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
6370: 69 6e 74 20 31 20 22 4d 6f 64 69 66 79 69 6e 67 int 1 "Modifying
6380: 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 75 73 state and staus
6390: 20 66 6f 72 20 74 65 73 74 73 20 66 6f 72 20 72 for tests for r
63a0: 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 22 un: " runkey " "
63b0: 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 (db:get-value-b
63c0: 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 y-header run hea
63d0: 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 29 der "runname")))
63e0: 0a 09 09 20 20 20 28 28 70 72 69 6e 74 2d 72 75 ... ((print-ru
63f0: 6e 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a n)... (debug:
6400: 70 72 69 6e 74 20 31 20 22 50 72 69 6e 74 69 6e print 1 "Printin
6410: 67 20 69 6e 66 6f 20 66 6f 72 20 72 75 6e 20 22 g info for run "
6420: 20 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d 22 runkey ", run="
6430: 20 72 75 6e 20 22 2c 20 74 65 73 74 73 3d 22 20 run ", tests="
6440: 74 65 73 74 73 20 22 2c 20 68 65 61 64 65 72 3d tests ", header=
6450: 22 20 68 65 61 64 65 72 29 0a 09 09 20 20 20 20 " header)...
6460: 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 28 65 6c action)... (el
6470: 73 65 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a se... (debug:
6480: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 63 print-info 0 "ac
6490: 74 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e 69 tion not recogni
64a0: 73 65 64 20 22 20 61 63 74 69 6f 6e 29 29 29 0a sed " action))).
64b0: 09 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 .. (for-each...
64c0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 0a (lambda (test).
64d0: 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 .. (let* ((it
64e0: 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 em-path (db:test
64f0: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 -get-item-path t
6500: 65 73 74 29 29 0a 09 09 09 20 20 20 28 74 65 73 est)).... (tes
6510: 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d t-name (db:test-
6520: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
6530: 74 29 29 0a 09 09 09 20 20 20 28 72 75 6e 2d 64 t)).... (run-d
6540: 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ir (db:test-ge
6550: 74 2d 72 75 6e 64 69 72 20 74 65 73 74 29 29 20 t-rundir test))
6560: 20 20 20 3b 3b 20 72 75 6e 20 64 69 72 20 69 73 ;; run dir is
6570: 20 66 72 6f 6d 20 74 68 65 20 6c 69 6e 6b 20 74 from the link t
6580: 72 65 65 0a 09 09 09 20 20 20 28 72 65 61 6c 2d ree.... (real-
6590: 64 69 72 20 20 28 69 66 20 28 66 69 6c 65 2d 65 dir (if (file-e
65a0: 78 69 73 74 73 3f 20 72 75 6e 2d 64 69 72 29 0a xists? run-dir).
65b0: 09 09 09 09 09 20 20 28 72 65 73 6f 6c 76 65 2d ..... (resolve-
65c0: 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 72 pathname run-dir
65d0: 29 0a 09 09 09 09 09 20 20 23 66 29 29 0a 09 09 )...... #f))...
65e0: 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 28 . (test-id (
65f0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 db:test-get-id t
6600: 65 73 74 29 29 29 0a 09 09 20 20 20 20 20 20 3b est)))... ;
6610: 3b 20 20 20 28 74 64 62 20 20 20 20 20 20 20 28 ; (tdb (
6620: 64 62 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 20 db:open-test-db
6630: 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 20 20 20 run-dir)))...
6640: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
6650: 69 6e 66 6f 20 34 20 22 74 65 73 74 3d 22 20 74 info 4 "test=" t
6660: 65 73 74 29 20 3b 3b 20 20 20 22 20 28 64 62 3a est) ;; " (db:
6670: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
6680: 65 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 20 e test) " id: "
6690: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
66a0: 74 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d 70 test) " " item-p
66b0: 61 74 68 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 ath " action: "
66c0: 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 20 action)...
66d0: 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 09 (case action....
66e0: 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 3b ((remove-runs) ;
66f0: 3b 20 74 68 65 20 74 64 62 20 69 73 20 66 6f 72 ; the tdb is for
6700: 20 66 75 74 75 72 65 20 70 6f 73 73 69 62 6c 65 future possible
6710: 2e 20 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 6e . .... (open-run
6720: 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 65 -close db:delete
6730: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 -test-records db
6740: 20 23 66 20 28 64 62 3a 74 65 73 74 2d 67 65 74 #f (db:test-get
6750: 2d 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 28 -id test)).... (
6760: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6770: 20 31 20 22 41 74 74 65 6d 70 74 69 6e 67 20 74 1 "Attempting t
6780: 6f 20 72 65 6d 6f 76 65 20 22 20 28 69 66 20 72 o remove " (if r
6790: 65 61 6c 2d 64 69 72 20 28 63 6f 6e 63 20 22 20 eal-dir (conc "
67a0: 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 22 dir " real-dir "
67b0: 20 61 6e 64 20 22 29 20 22 22 29 20 22 20 6c 69 and ") "") " li
67c0: 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 nk " run-dir)...
67d0: 09 20 28 69 66 20 28 61 6e 64 20 72 65 61 6c 2d . (if (and real-
67e0: 64 69 72 20 0a 09 09 09 09 20 20 28 3e 20 28 73 dir ..... (> (s
67f0: 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 65 61 tring-length rea
6800: 6c 2d 64 69 72 29 20 35 29 0a 09 09 09 09 20 20 l-dir) 5).....
6810: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 (file-exists? re
6820: 61 6c 2d 64 69 72 29 29 20 3b 3b 20 62 61 64 20 al-dir)) ;; bad
6830: 68 65 75 72 69 73 74 69 63 20 62 75 74 20 73 68 heuristic but sh
6840: 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 6d ould prevent /tm
6850: 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 09 09 p /home etc.....
6860: 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c (begin ;; l
6870: 65 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 28 et* ((realpath (
6880: 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d 65 resolve-pathname
6890: 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 run-dir)))....
68a0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
68b0: 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 63 75 72 nt-info 1 "Recur
68c0: 73 69 76 65 6c 79 20 72 65 6d 6f 76 69 6e 67 20 sively removing
68d0: 22 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 20 " real-dir)....
68e0: 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d (if (file-
68f0: 65 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 72 exists? real-dir
6900: 29 0a 09 09 09 09 20 20 20 28 69 66 20 28 3e 20 )..... (if (>
6910: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 72 (system (conc "r
6920: 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 69 72 m -rf " real-dir
6930: 29 29 20 30 29 0a 09 09 09 09 20 20 20 20 20 20 )) 0).....
6940: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
6950: 22 45 52 52 4f 52 3a 20 54 68 65 72 65 20 77 61 "ERROR: There wa
6960: 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 6d 6f s a problem remo
6970: 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 20 ving " real-dir
6980: 22 20 77 69 74 68 20 72 6d 20 2d 66 22 29 29 0a " with rm -f")).
6990: 09 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 .... (debug:pr
69a0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
69b0: 74 65 73 74 20 64 69 72 20 22 20 72 65 61 6c 2d test dir " real-
69c0: 64 69 72 20 22 20 61 70 70 65 61 72 73 20 74 6f dir " appears to
69d0: 20 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 69 73 not exist or is
69e0: 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 29 29 not readable"))
69f0: 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 72 65 ).... (if re
6a00: 61 6c 2d 64 69 72 20 0a 09 09 09 09 20 28 64 65 al-dir ..... (de
6a10: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
6a20: 4e 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 20 NING: directory
6a30: 22 20 72 65 61 6c 2d 64 69 72 20 22 20 64 6f 65 " real-dir " doe
6a40: 73 20 6e 6f 74 20 65 78 69 73 74 22 29 0a 09 09 s not exist")...
6a50: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
6a60: 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 72 0 "WARNING: no r
6a70: 65 61 6c 20 64 69 72 65 63 74 6f 72 79 20 63 6f eal directory co
6a80: 72 72 6f 73 70 6f 6e 64 69 6e 67 20 74 6f 20 6c rrosponding to l
6a90: 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 22 2c ink " run-dir ",
6aa0: 20 6e 6f 74 68 69 6e 67 20 64 6f 6e 65 22 29 29 nothing done"))
6ab0: 29 0a 09 09 09 20 28 69 66 20 28 73 79 6d 62 6f ).... (if (symbo
6ac0: 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 69 lic-link? run-di
6ad0: 72 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 69 r).... (begi
6ae0: 6e 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 n.... (deb
6af0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
6b00: 22 52 65 6d 6f 76 69 6e 67 20 73 79 6d 6c 69 6e "Removing symlin
6b10: 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 k " run-dir)....
6b20: 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 (handle-e
6b30: 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 78 xceptions.....ex
6b40: 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 n.....(debug:pri
6b50: 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 61 nt 0 "ERROR: Fa
6b60: 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 73 iled to remove s
6b70: 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 ymlink " run-dir
6b80: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
6b90: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
6ba0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
6bb0: 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 69 6e 67 n) ", attempting
6bc0: 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a 09 to continue")..
6bd0: 09 09 09 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 ...(delete-file
6be0: 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 20 run-dir)))....
6bf0: 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 (if (director
6c00: 79 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 09 y? run-dir).....
6c10: 20 28 69 66 20 28 3e 20 28 64 69 72 65 63 74 6f (if (> (directo
6c20: 72 79 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 ry-fold (lambda
6c30: 28 66 20 78 29 28 2b 20 31 20 78 29 29 20 30 20 (f x)(+ 1 x)) 0
6c40: 72 75 6e 2d 64 69 72 29 20 30 29 0a 09 09 09 09 run-dir) 0).....
6c50: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6c60: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 72 65 t 0 "WARNING: re
6c70: 66 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 65 fusing to remove
6c80: 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 20 " run-dir " as
6c90: 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 74 79 22 it is not empty"
6ca0: 29 0a 09 09 09 09 20 20 20 20 20 20 28 68 61 6e )..... (han
6cb0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
6cc0: 09 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 09 ... exn...
6cd0: 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 3a .. (debug:
6ce0: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
6cf0: 20 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 Failed to remov
6d00: 65 20 64 69 72 65 63 74 6f 72 79 20 22 20 72 75 e directory " ru
6d10: 6e 2d 64 69 72 20 28 28 63 6f 6e 64 69 74 69 6f n-dir ((conditio
6d20: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
6d30: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
6d40: 65 29 20 65 78 6e 29 20 22 2c 20 61 74 74 65 6d e) exn) ", attem
6d50: 70 74 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e 75 pting to continu
6d60: 65 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 e")..... (
6d70: 64 65 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 79 delete-directory
6d80: 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 09 run-dir))).....
6d90: 20 28 69 66 20 72 75 6e 2d 64 69 72 0a 09 09 09 (if run-dir....
6da0: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
6db0: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e nt 0 "WARNING: n
6dc0: 6f 74 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 75 ot removing " ru
6dd0: 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 65 69 n-dir " as it ei
6de0: 74 68 65 72 20 64 6f 65 73 6e 27 74 20 65 78 69 ther doesn't exi
6df0: 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 73 st or is not a s
6e00: 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 09 20 20 20 ymlink").....
6e10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
6e20: 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 20 "NOTE: the run
6e30: 64 69 72 20 66 6f 72 20 74 68 69 73 20 74 65 73 dir for this tes
6e40: 74 20 69 73 20 75 6e 64 65 66 69 6e 65 64 2e 20 t is undefined.
6e50: 54 65 73 74 20 6d 61 79 20 68 61 76 65 20 61 6c Test may have al
6e60: 72 65 61 64 79 20 62 65 65 6e 20 64 65 6c 65 74 ready been delet
6e70: 65 64 2e 22 29 29 0a 09 09 09 09 20 29 29 29 0a ed."))..... ))).
6e80: 09 09 09 28 28 73 65 74 2d 73 74 61 74 65 2d 73 ...((set-state-s
6e90: 74 61 74 75 73 29 0a 09 09 09 20 28 64 65 62 75 tatus).... (debu
6ea0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
6eb0: 6e 65 77 20 73 74 61 74 65 20 22 20 28 63 61 72 new state " (car
6ec0: 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 22 state-status) "
6ed0: 2c 20 6e 65 77 20 73 74 61 74 75 73 20 22 20 28 , new status " (
6ee0: 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 75 cadr state-statu
6ef0: 73 29 29 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 s)).... (open-ru
6f00: 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 2d n-close db:test-
6f10: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
6f20: 2d 62 79 2d 69 64 20 64 62 20 28 64 62 3a 74 65 -by-id db (db:te
6f30: 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 20 st-get-id test)
6f40: 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 75 (car state-statu
6f50: 73 29 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 s)(cadr state-st
6f60: 61 74 75 73 29 20 23 66 29 29 29 29 29 0a 09 09 atus) #f)))))...
6f70: 20 20 28 73 6f 72 74 20 74 65 73 74 73 20 28 6c (sort tests (l
6f80: 61 6d 62 64 61 20 28 61 20 62 29 28 6c 65 74 20 ambda (a b)(let
6f90: 28 28 64 69 72 61 20 28 64 62 3a 74 65 73 74 2d ((dira (db:test-
6fa0: 67 65 74 2d 72 75 6e 64 69 72 20 61 29 29 0a 09 get-rundir a))..
6fb0: 09 09 09 09 09 20 28 64 69 72 62 20 28 64 62 3a ..... (dirb (db:
6fc0: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
6fd0: 62 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 b)))...... (
6fe0: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
6ff0: 20 64 69 72 61 29 28 73 74 72 69 6e 67 3f 20 64 dira)(string? d
7000: 69 72 62 29 29 0a 09 09 09 09 09 09 20 28 3e 20 irb))....... (>
7010: 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 64 (string-length d
7020: 69 72 61 29 28 73 74 72 69 6e 67 2d 6c 65 6e 67 ira)(string-leng
7030: 74 68 20 64 69 72 62 29 29 0a 09 09 09 09 09 09 th dirb)).......
7040: 20 23 66 29 29 29 29 29 29 29 0a 09 20 20 20 3b #f))))))).. ;
7050: 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 72 75 6e ; remove the run
7060: 20 69 66 20 7a 65 72 6f 20 74 65 73 74 73 20 72 if zero tests r
7070: 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 28 65 emain.. (if (e
7080: 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f 76 q? action 'remov
7090: 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 20 20 e-runs)..
70a0: 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 20 (let ((remtests
70b0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
70c0: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
70d0: 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 2d -run db (db:get-
70e0: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
70f0: 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 29 run header "id")
7100: 20 23 66 20 27 28 22 44 45 4c 45 54 45 44 22 29 #f '("DELETED")
7110: 20 27 28 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 6e '("n/a") not-in
7120: 3a 20 23 74 29 29 29 0a 09 09 20 28 69 66 20 28 : #t)))... (if (
7130: 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 null? remtests)
7140: 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 ;; no more tests
7150: 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 20 remaining...
7160: 20 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 73 (let* ((dparts
7170: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
7180: 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 0a lasttpath "/")).
7190: 09 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 20 ... (runpath
71a0: 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 6e (conc "/" (strin
71b0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 09 g-intersperse ..
71c0: 09 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 74 .....(take dpart
71d0: 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 61 s (- (length dpa
71e0: 72 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 22 rts) 1))......."
71f0: 2f 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 /"))))...
7200: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 (debug:print 1 "
7210: 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 20 Removing run: "
7220: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
7230: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
7240: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
7250: 75 6e 6e 61 6d 65 22 29 20 22 20 61 6e 64 20 72 unname") " and r
7260: 65 6c 61 74 65 64 20 72 65 63 6f 72 64 22 29 0a elated record").
7270: 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 .. (open-r
7280: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 un-close db:dele
7290: 74 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 te-run db run-id
72a0: 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 54 68 )... ;; Th
72b0: 69 73 20 69 73 20 61 20 70 72 65 74 74 79 20 67 is is a pretty g
72c0: 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 70 75 72 ood place to pur
72d0: 67 65 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 74 ge old DELETED t
72e0: 65 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 6f ests... (o
72f0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
7300: 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 6f :delete-tests-fo
7310: 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 29 r-run db run-id)
7320: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
7330: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c run-close db:del
7340: 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 2d ete-old-deleted-
7350: 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 29 test-records db)
7360: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
7370: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 73 65 74 run-close db:set
7380: 2d 76 61 72 20 64 62 20 22 44 45 4c 45 54 45 44 -var db "DELETED
7390: 5f 54 45 53 54 53 22 20 28 63 75 72 72 65 6e 74 _TESTS" (current
73a0: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 -seconds))...
73b0: 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 66 ;; need to f
73c0: 69 67 75 72 65 20 6f 75 74 20 74 68 65 20 70 61 igure out the pa
73d0: 74 68 20 74 6f 20 74 68 65 20 72 75 6e 20 64 69 th to the run di
73e0: 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 20 r and remove it
73f0: 69 66 20 65 6d 70 74 79 0a 09 09 20 20 20 20 20 if empty...
7400: 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 6c ;; (if (nul
7410: 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 l? (glob (conc r
7420: 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 unpath "/*")))..
7430: 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 . ;;
7440: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
7450: 20 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 72 ;; . (debug:pr
7460: 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 int 1 "Removing
7470: 72 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 74 run dir " runpat
7480: 68 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 09 h)... ;; .
7490: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
74a0: 72 6d 64 69 72 20 2d 70 20 22 20 72 75 6e 70 61 rmdir -p " runpa
74b0: 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 th))))...
74c0: 29 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 ))))).. )).
74d0: 72 75 6e 73 29 29 0a 20 20 23 74 29 0a 0a 3b 3b runs)). #t)..;;
74e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7520: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f 75 74 69 6e ======.;; Routin
7530: 65 73 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 74 es for manipulat
7540: 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d 3d ing runs.;;=====
7550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7590: 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e 79 =..;; Since many
75a0: 20 63 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e 20 calls to a run
75b0: 72 65 71 75 69 72 65 20 70 72 65 74 74 79 20 6d require pretty m
75c0: 75 63 68 20 74 68 65 20 73 61 6d 65 20 73 65 74 uch the same set
75d0: 75 70 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 70 up .;; this wrap
75e0: 70 65 72 20 69 73 20 75 73 65 64 20 74 6f 20 72 per is used to r
75f0: 65 64 75 63 65 20 74 68 65 20 72 65 70 6c 69 63 educe the replic
7600: 61 74 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 64 ation of code.(d
7610: 65 66 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d 72 efine (general-r
7620: 75 6e 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e 61 un-call switchna
7630: 6d 65 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 70 me action-desc p
7640: 72 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 72 75 roc). (let ((ru
7650: 6e 6e 61 6d 65 20 28 61 72 67 73 3a 67 65 74 2d nname (args:get-
7660: 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 arg ":runname"))
7670: 0a 09 28 74 61 72 67 65 74 20 20 28 69 66 20 28 ..(target (if (
7680: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
7690: 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 arget")... (
76a0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
76b0: 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 28 arget")... (
76c0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
76d0: 65 71 74 61 72 67 22 29 29 29 29 0a 09 3b 3b 20 eqtarg"))))..;;
76e0: 28 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 20 (th1 #f)).
76f0: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e (cond. ((n
7700: 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 20 ot target).
7710: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
7720: 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 20 "ERROR: Missing
7730: 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 74 required paramet
7740: 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 6e er for " switchn
7750: 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 20 ame ", you must
7760: 73 70 65 63 69 66 79 20 74 68 65 20 74 61 72 67 specify the targ
7770: 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 22 et with -target"
7780: 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 29 ). (exit 3)
7790: 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 6e ). ((not run
77a0: 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 62 name). (deb
77b0: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
77c0: 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 69 R: Missing requi
77d0: 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 6f red parameter fo
77e0: 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 22 r " switchname "
77f0: 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 69 , you must speci
7800: 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 20 fy the run name
7810: 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 75 with :runname ru
7820: 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 65 nname"). (e
7830: 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 6c xit 3)). (el
7840: 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 se. (let ((
7850: 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 6b db #f).. (k
7860: 65 79 73 20 23 66 29 0a 09 20 20 20 20 28 74 61 eys #f).. (ta
7870: 72 67 65 74 20 28 6f 72 20 28 61 72 67 73 3a 67 rget (or (args:g
7880: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
7890: 22 29 0a 09 09 09 28 61 72 67 73 3a 67 65 74 2d ")....(args:get-
78a0: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 29 29 arg "-target")))
78b0: 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 )..(if (not (set
78c0: 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 up-for-run))..
78d0: 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 (begin ..
78e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
78f0: 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 "Failed to setup
7900: 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 , exiting")..
7910: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 (exit 1)))..(
7920: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
7930: 20 22 2d 73 65 72 76 65 72 22 29 0a 09 20 20 20 "-server")..
7940: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
7950: 20 73 65 72 76 65 72 3a 73 74 61 72 74 20 64 62 server:start db
7960: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7970: 2d 73 65 72 76 65 72 22 29 29 29 0a 09 28 73 65 -server")))..(se
7980: 74 21 20 6b 65 79 73 20 28 6b 65 79 73 3a 63 6f t! keys (keys:co
7990: 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 nfig-get-fields
79a0: 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 0a 09 3b *configdat*))..;
79b0: 3b 20 68 61 76 65 20 65 6e 6f 75 67 68 20 74 6f ; have enough to
79c0: 20 70 72 6f 63 65 73 73 20 2d 74 61 72 67 65 74 process -target
79d0: 20 6f 72 20 2d 72 65 71 74 61 72 67 20 68 65 72 or -reqtarg her
79e0: 65 0a 09 28 69 66 20 28 61 72 67 73 3a 67 65 74 e..(if (args:get
79f0: 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 -arg "-reqtarg")
7a00: 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 75 .. (let* ((ru
7a10: 6e 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 20 nconfigf (conc
7a20: 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 *toppath* "/runc
7a30: 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 onfigs.config"))
7a40: 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 41 4c 55 ;; DO NOT EVALU
7a50: 41 54 45 20 41 4c 4c 20 0a 09 09 20 20 20 28 72 ATE ALL ... (r
7a60: 75 6e 63 6f 6e 66 69 67 20 20 28 72 65 61 64 2d unconfig (read-
7a70: 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 config runconfig
7a80: 66 20 23 66 20 23 74 20 65 6e 76 69 72 6f 6e 2d f #f #t environ-
7a90: 70 61 74 74 3a 20 23 66 29 29 29 20 0a 09 20 20 patt: #f))) ..
7aa0: 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 (if (hash-ta
7ab0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
7ac0: 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 3a runconfig (args:
7ad0: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
7ae0: 67 22 29 20 23 66 29 0a 09 09 20 20 28 6b 65 79 g") #f)... (key
7af0: 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 67 s:target-set-arg
7b00: 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 74 s keys (args:get
7b10: 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 -arg "-reqtarg")
7b20: 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 0a args:arg-hash).
7b30: 09 09 20 20 20 20 0a 09 09 20 20 28 62 65 67 69 .. ... (begi
7b40: 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 n... (debug:p
7b50: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 5b rint 0 "ERROR: [
7b60: 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 " (args:get-arg
7b70: 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 6e "-reqtarg") "] n
7b80: 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 75 ot found in " ru
7b90: 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 20 nconfigf)...
7ba0: 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
7bb0: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
7bc0: 09 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 . (exit 1))))
7bd0: 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 73 3a .. (if (args:
7be0: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
7bf0: 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 65 ")...(keys:targe
7c00: 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 t-set-args keys
7c10: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7c20: 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 72 67 target" args:arg
7c30: 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 67 2d -hash) args:arg-
7c40: 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 6e 6f hash)))..(if (no
7c50: 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e t (car *configin
7c60: 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 67 69 fo*)).. (begi
7c70: 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a n.. (debug:
7c80: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
7c90: 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 61 Attempted to " a
7ca0: 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 74 ction-desc " but
7cb0: 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 67 run area config
7cc0: 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 22 file not found"
7cd0: 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 31 ).. (exit 1
7ce0: 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 61 )).. ;; Extra
7cf0: 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 65 ct out stuff nee
7d00: 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 6d ded in most or m
7d10: 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 3b any calls.. ;
7d20: 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c 6c ; here then call
7d30: 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 2a proc.. (let*
7d40: 20 28 28 6b 65 79 76 61 6c 73 20 20 20 20 28 6b ((keyvals (k
7d50: 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 eys:target->keyv
7d60: 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 al keys target))
7d70: 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 74 ).. (proc t
7d80: 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b 65 arget runname ke
7d90: 79 73 20 6b 65 79 76 61 6c 73 29 29 29 0a 09 28 ys keyvals)))..(
7da0: 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a 66 if db (sqlite3:f
7db0: 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 28 inalize! db))..(
7dc0: 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 69 set! *didsomethi
7dd0: 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b 3b ng* #t))))))..;;
7de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e20: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 6f 63 6b 2f 75 ======.;; Lock/u
7e30: 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d 3d nlock runs.;;===
7e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e80: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 ===..(define (ru
7e90: 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 6e ns:handle-lockin
7ea0: 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 75 g target keys ru
7eb0: 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f 63 nname lock unloc
7ec0: 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a 20 k user). (let*
7ed0: 28 28 64 62 20 20 20 20 20 20 20 23 66 29 0a 09 ((db #f)..
7ee0: 20 28 72 75 6e 64 61 74 20 20 20 28 6f 70 65 6e (rundat (open
7ef0: 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 3a -run-close runs:
7f00: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
7f10: 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 db keys runname
7f20: 20 74 61 72 67 65 74 29 29 0a 09 20 28 68 65 61 target)).. (hea
7f30: 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d 72 65 der (vector-re
7f40: 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 f rundat 0)).. (
7f50: 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 6f 72 runs (vector
7f60: 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 29 -ref rundat 1)))
7f70: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
7f80: 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 28 lambda (run)...(
7f90: 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 64 62 let ((run-id (db
7fa0: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he
7fb0: 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 ader run header
7fc0: 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 66 20 "id")))... (if
7fd0: 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 61 (or lock.... (a
7fe0: 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 20 nd unlock....
7ff0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 (begin.....
8000: 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 72 (print "Do you r
8010: 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 6e eally wish to un
8020: 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d 69 lock run " run-i
8030: 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 29 d "?\n y/n: ")
8040: 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 22 79 ..... (equal? "y
8050: 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 " (read-line))))
8060: 29 0a 09 09 20 20 20 20 20 20 28 6f 70 65 6e 2d )... (open-
8070: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c 6f 63 run-close db:loc
8080: 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 20 k/unlock-run db
8090: 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c 6f run-id lock unlo
80a0: 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 20 20 ck user)...
80b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
80c0: 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 20 6c fo 0 "Skipping l
80d0: 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 20 ock/unlock on "
80e0: 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 20 run-id))))..
80f0: 20 20 72 75 6e 73 29 29 29 0a 3b 3b 3d 3d 3d 3d runs))).;;====
8100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8140: 3d 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 6e ==.;; Rollup run
8150: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
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 0a 0a 3b 3b 20 55 ==========..;; U
81a0: 70 64 61 74 65 20 74 68 65 20 74 65 73 74 5f 6d pdate the test_m
81b0: 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 74 68 eta table for th
81c0: 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e 65 20 is test.(define
81d0: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
81e0: 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 t_meta test-name
81f0: 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 6c test-conf). (l
8200: 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 20 et ((currrecord
8210: 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 (cdb:remote-run
8220: 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 2d db:testmeta-get-
8230: 72 65 63 6f 72 64 20 23 66 20 74 65 73 74 2d 6e record #f test-n
8240: 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 28 ame))). (if (
8250: 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 0a not currrecord).
8260: 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 21 .(begin.. (set!
8270: 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 6b currrecord (mak
8280: 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 29 29 e-vector 10 #f))
8290: 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d .. (cdb:remote-
82a0: 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d run db:testmeta-
82b0: 61 64 64 2d 72 65 63 6f 72 64 20 23 66 20 74 65 add-record #f te
82c0: 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 st-name))). (
82d0: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
82e0: 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 20 lambda (key).
82f0: 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 78 20 (let* ((idx
8300: 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 20 20 (cadr key))..
8310: 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 6b 65 (fld (car ke
8320: 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 6c 20 y)).. (val
8330: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t
8340: 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 5f 6d est-conf "test_m
8350: 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 3b 3b eta" fld))).. ;;
8360: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 20 (debug:print 5
8370: 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 66 6c "idx: " idx " fl
8380: 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c 3a 20 d: " fld " val:
8390: 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 61 6e " val).. (if (an
83a0: 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 61 d val (not (equa
83b0: 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 63 l? (vector-ref c
83c0: 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 20 76 urrrecord idx) v
83d0: 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 al))).. (beg
83e0: 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 6e in.. (prin
83f0: 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 74 65 t "Updating " te
8400: 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 20 st-name " " fld
8410: 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 20 " to " val)..
8420: 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d (cdb:remote-
8430: 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 2d run db:testmeta-
8440: 75 70 64 61 74 65 2d 66 69 65 6c 64 20 23 66 20 update-field #f
8450: 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 test-name fld va
8460: 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 28 22 l))))). '(("
8470: 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 6e 65 author" 2)("owne
8480: 72 22 20 33 29 28 22 64 65 73 63 72 69 70 74 69 r" 3)("descripti
8490: 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 65 64 on" 4)("reviewed
84a0: 22 20 35 29 28 22 74 61 67 73 22 20 39 29 29 29 " 5)("tags" 9)))
84b0: 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 65 ))..;; Update te
84c0: 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c 20 st_meta for all
84d0: 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 28 72 tests.(define (r
84e0: 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 uns:update-all-t
84f0: 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 28 est_meta db). (
8500: 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 73 let ((test-names
8510: 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d (get-all-legal-
8520: 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 6f tests))). (fo
8530: 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 r-each . (la
8540: 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 mbda (test-name)
8550: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
8560: 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f test-path (co
8570: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 nc *toppath* "/t
8580: 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 ests/" test-name
8590: 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d )).. (test-
85a0: 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 configf (conc te
85b0: 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f st-path "/testco
85c0: 6e 66 69 67 22 29 29 0a 09 20 20 20 20 20 20 28 nfig")).. (
85d0: 74 65 73 74 65 78 69 73 74 73 20 20 20 28 61 6e testexists (an
85e0: 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 d (file-exists?
85f0: 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 test-configf)(fi
8600: 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 le-read-access?
8610: 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a test-configf))).
8620: 09 20 20 20 20 20 20 3b 3b 20 72 65 61 64 20 63 . ;; read c
8630: 6f 6e 66 69 67 73 20 77 69 74 68 20 74 72 69 63 onfigs with tric
8640: 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 20 28 69 ks turned off (i
8650: 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d 29 0a 09 .e. no system)..
8660: 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 (test-conf
8670: 20 20 20 20 28 69 66 20 74 65 73 74 65 78 69 73 (if testexis
8680: 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 ts (read-config
8690: 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 test-configf #f
86a0: 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 #f)(make-hash-ta
86b0: 62 6c 65 29 29 29 29 0a 09 20 3b 3b 20 75 73 65 ble)))).. ;; use
86c0: 20 74 68 65 20 6f 70 65 6e 2d 72 75 6e 2d 63 6c the open-run-cl
86d0: 6f 73 65 20 69 6e 73 74 65 61 64 20 6f 66 20 70 ose instead of p
86e0: 61 73 73 69 6e 67 20 69 6e 20 64 62 0a 09 20 28 assing in db.. (
86f0: 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 runs:update-test
8700: 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 20 _meta test-name
8710: 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 test-conf))).
8720: 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 0a test-names))).
8730: 0a 3b 3b 20 54 68 69 73 20 63 6f 75 6c 64 20 70 .;; This could p
8740: 72 6f 62 61 62 6c 79 20 62 65 20 72 65 66 61 63 robably be refac
8750: 74 6f 72 65 64 20 69 6e 74 6f 20 6f 6e 65 20 63 tored into one c
8760: 6f 6d 70 6c 65 78 20 71 75 65 72 79 20 2e 2e 2e omplex query ...
8770: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 .(define (runs:r
8780: 6f 6c 6c 75 70 2d 72 75 6e 20 6b 65 79 73 20 72 ollup-run keys r
8790: 75 6e 6e 61 6d 65 20 75 73 65 72 20 6b 65 79 76 unname user keyv
87a0: 61 6c 73 29 0a 20 20 28 64 65 62 75 67 3a 70 72 als). (debug:pr
87b0: 69 6e 74 20 34 20 22 72 75 6e 73 3a 72 6f 6c 6c int 4 "runs:roll
87c0: 75 70 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 up-run, keys: "
87d0: 6b 65 79 73 20 22 20 3a 72 75 6e 6e 61 6d 65 20 keys " :runname
87e0: 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 73 65 72 " runname " user
87f0: 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c 65 74 : " user). (let
8800: 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 20 * ((db
8810: 20 20 20 20 23 66 29 0a 09 20 28 6e 65 77 2d 72 #f).. (new-r
8820: 75 6e 2d 69 64 20 20 20 20 20 20 28 63 64 62 3a un-id (cdb:
8830: 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 72 65 remote-run db:re
8840: 67 69 73 74 65 72 2d 72 75 6e 20 23 66 20 6b 65 gister-run #f ke
8850: 79 73 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 ys keyvals runna
8860: 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 me "new" "n/a" u
8870: 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d 74 65 ser)).. (prev-te
8880: 73 74 73 20 20 20 20 20 20 28 6f 70 65 6e 2d 72 sts (open-r
8890: 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 3a 67 65 un-close test:ge
88a0: 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 t-matching-previ
88b0: 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 ous-test-run-rec
88c0: 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d ords db new-run-
88d0: 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 20 28 id "%" "%")).. (
88e0: 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 20 20 curr-tests
88f0: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
8900: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
8910: 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d -run db new-run-
8920: 69 64 20 22 25 2f 25 22 20 27 28 29 20 27 28 29 id "%/%" '() '()
8930: 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 73 )).. (curr-tests
8940: 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 -hash (make-hash
8950: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 6f -table))). (o
8960: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 pen-run-close db
8970: 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 6e :update-run-even
8980: 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 2d 72 75 t_time db new-ru
8990: 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 69 6e 64 n-id). ;; ind
89a0: 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 20 73 ex the already s
89b0: 61 76 65 64 20 74 65 73 74 73 20 62 79 20 74 65 aved tests by te
89c0: 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 6d 64 stname and itemd
89d0: 61 74 20 69 6e 20 63 75 72 72 2d 74 65 73 74 73 at in curr-tests
89e0: 2d 68 61 73 68 0a 20 20 20 20 28 66 6f 72 2d 65 -hash. (for-e
89f0: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
8a00: 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 20 (testdat).
8a10: 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e 61 (let* ((testna
8a20: 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 me (db:test-get
8a30: 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 61 -testname testda
8a40: 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 6d t)).. (item
8a50: 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d 67 -path (db:test-g
8a60: 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 73 et-item-path tes
8a70: 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 66 tdat)).. (f
8a80: 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 74 ull-name (conc t
8a90: 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d estname "/" item
8aa0: 2d 70 61 74 68 29 29 29 0a 09 20 28 68 61 73 68 -path))).. (hash
8ab0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 72 72 -table-set! curr
8ac0: 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c 6c -tests-hash full
8ad0: 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 29 -name testdat)))
8ae0: 0a 20 20 20 20 20 63 75 72 72 2d 74 65 73 74 73 . curr-tests
8af0: 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 4e ). ;; NOPE: N
8b00: 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 70 72 6f on-optimal appro
8b10: 61 63 68 2e 20 54 72 79 20 74 68 69 73 20 69 6e ach. Try this in
8b20: 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b 20 20 20 stead.. ;;
8b30: 31 2e 20 74 65 73 74 73 20 61 72 65 20 72 65 63 1. tests are rec
8b40: 65 69 76 65 64 20 69 6e 20 61 20 6c 69 73 74 2c eived in a list,
8b50: 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 66 69 72 most recent fir
8b60: 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 2e 20 72 st. ;; 2. r
8b70: 65 70 6c 61 63 65 20 74 68 65 20 72 6f 6c 6c 75 eplace the rollu
8b80: 70 20 74 65 73 74 20 77 69 74 68 20 74 68 65 20 p test with the
8b90: 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a 20 20 20 new *always*.
8ba0: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
8bb0: 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 61 (lambda (testda
8bc0: 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 t). (let*
8bd0: 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 3a ((testname (db:
8be0: 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 6d test-get-testnam
8bf0: 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 e testdat))..
8c00: 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 64 (item-path (d
8c10: 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d 2d b:test-get-item-
8c20: 70 61 74 68 20 74 65 73 74 64 61 74 29 29 0a 09 path testdat))..
8c30: 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d 65 (full-name
8c40: 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 20 (conc testname
8c50: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 0a "/" item-path)).
8c60: 09 20 20 20 20 20 20 28 70 72 65 76 2d 74 65 73 . (prev-tes
8c70: 74 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 6c t-dat (hash-tabl
8c80: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 75 e-ref/default cu
8c90: 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 rr-tests-hash fu
8ca0: 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 ll-name #f))..
8cb0: 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 73 20 (test-steps
8cc0: 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f (open-run-clo
8cd0: 73 65 20 64 62 3a 67 65 74 2d 73 74 65 70 73 2d se db:get-steps-
8ce0: 66 6f 72 2d 74 65 73 74 20 64 62 20 28 64 62 3a for-test db (db:
8cf0: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
8d00: 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 6e dat))).. (n
8d10: 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 23 ew-test-record #
8d20: 66 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 65 f)).. ;; replace
8d30: 20 74 68 65 73 65 20 77 69 74 68 20 69 6e 73 65 these with inse
8d40: 72 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 20 rt ... select..
8d50: 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a 65 (apply sqlite3:e
8d60: 78 65 63 75 74 65 20 0a 09 09 64 62 20 0a 09 09 xecute ...db ...
8d70: 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 (conc "INSERT OR
8d80: 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 REPLACE INTO te
8d90: 73 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 74 sts (run_id,test
8da0: 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 name,state,statu
8db0: 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f 73 s,event_time,hos
8dc0: 74 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 72 t,cpuload,diskfr
8dd0: 65 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 2c ee,uname,rundir,
8de0: 69 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 75 item_path,run_du
8df0: 72 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f 67 ration,final_log
8e00: 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 20 f,comment) "...
8e10: 20 20 20 20 20 22 56 41 4c 55 45 53 20 28 3f 2c "VALUES (?,
8e20: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ?,?,?,?,?,?,?,?,
8e30: 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 09 ?,?,?,?,?);")...
8e40: 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 72 new-run-id (cddr
8e50: 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 74 (vector->list t
8e60: 65 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 74 estdat))).. (set
8e70: 21 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 63 ! new-testdat (c
8e80: 61 72 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f ar (open-run-clo
8e90: 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d se db:get-tests-
8ea0: 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 for-run db new-r
8eb0: 75 6e 2d 69 64 20 28 63 6f 6e 63 20 74 65 73 74 un-id (conc test
8ec0: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
8ed0: 74 68 29 20 27 28 29 20 27 28 29 29 29 29 0a 09 th) '() '())))..
8ee0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
8ef0: 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 ! curr-tests-has
8f00: 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d h full-name new-
8f10: 74 65 73 74 64 61 74 29 20 3b 3b 20 74 68 69 73 testdat) ;; this
8f20: 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 could be confus
8f30: 69 6e 67 2c 20 77 68 69 63 68 20 72 65 63 6f 72 ing, which recor
8f40: 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f d should go into
8f50: 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c the lookup tabl
8f60: 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c e?.. ;; Now dupl
8f70: 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 73 icate the test s
8f80: 74 65 70 73 0a 09 20 28 64 65 62 75 67 3a 70 72 teps.. (debug:pr
8f90: 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 72 int 4 "Copying r
8fa0: 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f 73 ecords in test_s
8fb0: 74 65 70 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 teps from test_i
8fc0: 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 d=" (db:test-get
8fd0: 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 20 74 -id testdat) " t
8fe0: 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 o " (db:test-get
8ff0: 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 -id new-testdat)
9000: 29 0a 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c ).. (open-run-cl
9010: 6f 73 65 20 0a 09 20 20 28 6c 61 6d 62 64 61 20 ose .. (lambda
9020: 28 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 ().. (sqlite3
9030: 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 20 :execute ..
9040: 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 db .. (conc
9050: 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 "INSERT OR REPLA
9060: 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 65 CE INTO test_ste
9070: 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 70 ps (test_id,step
9080: 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 75 name,state,statu
9090: 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f 6d s,event_time,com
90a0: 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 45 ment) "... "SE
90b0: 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d LECT " (db:test-
90c0: 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
90d0: 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 at) ",stepname,s
90e0: 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e tate,status,even
90f0: 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 t_time,comment F
9100: 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 ROM test_steps W
9110: 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 HERE test_id=?;"
9120: 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 74 ).. (db:test
9130: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
9140: 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 75 ).. ;; Now du
9150: 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 plicate the test
9160: 20 64 61 74 61 0a 09 20 20 20 20 28 64 65 62 75 data.. (debu
9170: 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 69 g:print 4 "Copyi
9180: 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 65 ng records in te
9190: 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 73 st_data from tes
91a0: 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d t_id=" (db:test-
91b0: 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 get-id testdat)
91c0: 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d " to " (db:test-
91d0: 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
91e0: 61 74 29 29 0a 09 20 20 20 20 28 73 71 6c 69 74 at)).. (sqlit
91f0: 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 e3:execute ..
9200: 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e db .. (con
9210: 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 c "INSERT OR REP
9220: 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 LACE INTO test_d
9230: 61 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 ata (test_id,cat
9240: 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 egory,variable,v
9250: 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f alue,expected,to
9260: 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 l,units,comment)
9270: 20 22 0a 09 09 20 20 20 22 53 45 4c 45 43 54 20 "... "SELECT
9280: 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 " (db:test-get-i
9290: 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 22 d new-testdat) "
92a0: 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 62 ,category,variab
92b0: 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 65 le,value,expecte
92c0: 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d d,tol,units,comm
92d0: 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 61 ent FROM test_da
92e0: 74 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 64 ta WHERE test_id
92f0: 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 3a =?;").. (db:
9300: 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 test-get-id test
9310: 64 61 74 29 29 29 29 0a 09 20 29 29 0a 20 20 20 dat)))).. )).
9320: 20 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 0a prev-tests))).
9330: 09 20 0a 20 20 20 20 20 0a . . .