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 20 0a 09 09 *configdat* ...
0a20: 20 20 20 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 *conf
0a30: 69 67 64 61 74 2a 0a 09 09 20 20 20 20 20 20 20 igdat*...
0a40: 20 20 20 20 28 69 66 20 28 73 65 74 75 70 2d 66 (if (setup-f
0a50: 6f 72 2d 72 75 6e 29 0a 09 09 20 20 20 20 20 20 or-run)...
0a60: 20 20 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 *config
0a70: 64 61 74 2a 0a 09 09 20 20 20 20 20 20 20 20 20 dat*...
0a80: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 (begin...
0a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0aa0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
0ab0: 45 52 52 4f 52 3a 20 43 61 6c 6c 65 64 20 73 65 ERROR: Called se
0ac0: 74 75 70 20 69 6e 20 61 20 6e 6f 6e 2d 6d 65 67 tup in a non-meg
0ad0: 61 74 65 73 74 20 61 72 65 61 2c 20 65 78 69 74 atest area, exit
0ae0: 69 6e 67 22 29 0a 09 09 20 20 20 20 20 20 20 20 ing")...
0af0: 20 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 (exit 1
0b00: 29 29 29 29 29 0a 09 20 20 28 72 75 6e 72 65 63 ))))).. (runrec
0b10: 20 20 20 20 20 20 28 72 75 6e 73 3a 72 75 6e 72 (runs:runr
0b20: 65 63 2d 6d 61 6b 65 2d 72 65 63 6f 72 64 29 29 ec-make-record))
0b30: 0a 09 20 20 28 74 61 72 67 65 74 20 20 20 20 20 .. (target
0b40: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
0b50: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 rg "-reqtarg")..
0b60: 09 20 20 20 20 20 20 20 20 20 20 20 28 61 72 67 . (arg
0b70: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
0b80: 65 74 22 29 29 29 0a 09 20 20 28 72 75 6e 6e 61 et"))).. (runna
0b90: 6d 65 20 20 20 20 20 28 6f 72 20 28 61 72 67 73 me (or (args
0ba0: 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 :get-arg ":runna
0bb0: 6d 65 22 29 0a 09 09 20 20 20 20 20 20 20 20 20 me")...
0bc0: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
0bd0: 22 2d 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 20 "-runname")))..
0be0: 20 28 74 65 73 74 70 61 74 74 20 20 20 20 28 6f (testpatt (o
0bf0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
0c00: 22 2d 74 65 73 74 70 61 74 74 22 29 0a 09 09 20 "-testpatt")...
0c10: 20 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a (args:
0c20: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 get-arg "-runtes
0c30: 74 73 22 29 29 29 0a 09 20 20 28 6b 65 79 73 20 ts"))).. (keys
0c40: 20 20 20 20 20 20 20 28 6b 65 79 73 3a 63 6f 6e (keys:con
0c50: 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 6d fig-get-fields m
0c60: 63 6f 6e 66 69 67 29 29 0a 09 20 20 28 6b 65 79 config)).. (key
0c70: 76 61 6c 73 20 20 20 20 20 28 6b 65 79 73 3a 74 vals (keys:t
0c80: 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 arget->keyval ke
0c90: 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 20 28 ys target)).. (
0ca0: 74 6f 70 70 61 74 68 20 20 20 20 20 2a 74 6f 70 toppath *top
0cb0: 70 61 74 68 2a 29 0a 09 20 20 28 65 6e 76 64 61 path*).. (envda
0cc0: 74 20 20 20 20 20 20 6b 65 79 76 61 6c 73 29 20 t keyvals)
0cd0: 3b 3b 20 69 6e 69 74 69 61 6c 20 76 61 6c 75 65 ;; initial value
0ce0: 73 20 73 74 61 72 74 20 77 69 74 68 20 6b 65 79 s start with key
0cf0: 76 61 6c 73 0a 09 20 20 28 72 75 6e 63 6f 6e 66 vals.. (runconf
0d00: 69 67 20 20 20 23 66 29 0a 09 20 20 28 73 65 72 ig #f).. (ser
0d10: 76 65 72 64 61 74 20 20 20 28 69 66 20 28 61 72 verdat (if (ar
0d20: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 gs:get-arg "-ser
0d30: 76 65 72 22 29 0a 09 09 09 20 20 20 2a 72 75 6e ver").... *run
0d40: 72 65 6d 6f 74 65 2a 0a 09 09 09 20 20 20 23 66 remote*.... #f
0d50: 29 29 20 3b 3b 20 74 6f 20 62 65 20 75 73 65 64 )) ;; to be used
0d60: 20 6c 61 74 65 72 0a 09 20 20 28 74 72 61 6e 73 later.. (trans
0d70: 70 6f 72 74 20 20 20 28 6f 72 20 28 61 72 67 73 port (or (args
0d80: 3a 67 65 74 2d 61 72 67 20 22 2d 74 72 61 6e 73 :get-arg "-trans
0d90: 70 6f 72 74 22 29 20 27 68 74 74 70 29 29 0a 09 port") 'http))..
0da0: 20 20 28 64 62 20 20 20 20 20 20 20 20 20 20 28 (db (
0db0: 69 66 20 28 61 6e 64 20 6d 63 6f 6e 66 69 67 0a if (and mconfig.
0dc0: 09 09 09 09 28 6f 72 20 28 61 72 67 73 3a 67 65 ....(or (args:ge
0dd0: 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 t-arg "-server")
0de0: 0a 09 09 09 09 20 20 20 20 28 65 71 3f 20 74 72 ..... (eq? tr
0df0: 61 6e 73 70 6f 72 74 20 27 66 73 29 29 29 0a 09 ansport 'fs)))..
0e00: 09 09 20 20 20 28 6f 70 65 6e 2d 64 62 29 0a 09 .. (open-db)..
0e10: 09 09 20 20 20 23 66 29 29 0a 09 20 20 28 72 75 .. #f)).. (ru
0e20: 6e 2d 69 64 20 20 20 20 20 20 23 66 29 29 0a 20 n-id #f)).
0e30: 20 20 20 3b 3b 20 53 65 74 20 61 6c 6c 20 74 68 ;; Set all th
0e40: 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 e environment va
0e50: 72 73 20 77 65 20 6b 6e 6f 77 20 73 6f 20 66 61 rs we know so fa
0e60: 72 2c 20 73 74 61 72 74 20 77 69 74 68 20 6b 65 r, start with ke
0e70: 79 73 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ys. (for-each
0e80: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c (lambda (keyval
0e90: 29 0a 09 09 28 73 65 74 65 6e 76 20 28 63 61 72 )...(setenv (car
0ea0: 20 6b 65 79 76 61 6c 29 28 63 61 64 72 20 6b 65 keyval)(cadr ke
0eb0: 79 76 61 6c 29 29 29 0a 09 20 20 20 20 20 20 6b yval))).. k
0ec0: 65 79 76 61 6c 73 29 0a 20 20 20 20 3b 3b 20 53 eyvals). ;; S
0ed0: 65 74 20 75 70 20 76 61 72 69 6f 75 73 20 61 6e et up various an
0ee0: 64 20 73 75 6e 64 72 79 20 6b 6e 6f 77 6e 20 76 d sundry known v
0ef0: 61 72 73 20 68 65 72 65 0a 20 20 20 20 28 73 65 ars here. (se
0f00: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 tenv "MT_RUN_ARE
0f10: 41 5f 48 4f 4d 45 22 20 74 6f 70 70 61 74 68 29 A_HOME" toppath)
0f20: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT
0f30: 5f 52 55 4e 4e 41 4d 45 22 20 72 75 6e 6e 61 6d _RUNNAME" runnam
0f40: 65 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 e). (setenv "
0f50: 4d 54 5f 54 41 52 47 45 54 22 20 20 74 61 72 67 MT_TARGET" targ
0f60: 65 74 29 0a 20 20 20 20 28 73 65 74 21 20 65 6e et). (set! en
0f70: 76 64 61 74 20 28 61 70 70 65 6e 64 20 0a 09 09 vdat (append ...
0f80: 20 20 65 6e 76 64 61 74 0a 09 09 20 20 28 6c 69 envdat... (li
0f90: 73 74 20 28 6c 69 73 74 20 22 4d 54 5f 52 55 4e st (list "MT_RUN
0fa0: 5f 41 52 45 41 5f 48 4f 4d 45 22 20 74 6f 70 70 _AREA_HOME" topp
0fb0: 61 74 68 29 0a 09 09 09 28 6c 69 73 74 20 22 4d ath)....(list "M
0fc0: 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 20 20 20 T_RUNNAME"
0fd0: 20 72 75 6e 6e 61 6d 65 29 0a 09 09 09 28 6c 69 runname)....(li
0fe0: 73 74 20 22 4d 54 5f 54 41 52 47 45 54 22 20 20 st "MT_TARGET"
0ff0: 20 20 20 20 20 20 74 61 72 67 65 74 29 29 29 29 target))))
1000: 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 63 61 6e 20 . ;; Now can
1010: 72 65 61 64 20 74 68 65 20 72 75 6e 63 6f 6e 66 read the runconf
1020: 69 67 73 20 66 69 6c 65 0a 20 20 20 20 3b 3b 20 igs file. ;;
1030: 0a 20 20 20 20 28 73 65 74 21 20 72 75 6e 63 6f . (set! runco
1040: 6e 66 69 67 20 28 72 65 61 64 2d 63 6f 6e 66 69 nfig (read-confi
1050: 67 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 g (conc *toppat
1060: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
1070: 63 6f 6e 66 69 67 22 29 20 23 66 20 23 74 20 73 config") #f #t s
1080: 65 63 74 69 6f 6e 73 3a 20 28 6c 69 73 74 20 22 ections: (list "
1090: 64 65 66 61 75 6c 74 22 20 74 61 72 67 65 74 29 default" target)
10a0: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
10b0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
10c0: 64 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 default runconfi
10d0: 67 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 g (args:get-arg
10e0: 22 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 29 "-reqtarg") #f))
10f0: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
1100: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
1110: 52 3a 20 5b 22 20 28 61 72 67 73 3a 67 65 74 2d R: [" (args:get-
1120: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 20 arg "-reqtarg")
1130: 22 5d 20 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 "] not found in
1140: 22 20 72 75 6e 63 6f 6e 66 69 67 66 29 0a 09 20 " runconfigf)..
1150: 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 (if db (sqlite3
1160: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a :finalize! db)).
1170: 09 20 20 28 65 78 69 74 20 31 29 29 29 0a 20 20 . (exit 1))).
1180: 20 20 3b 3b 20 4e 6f 77 20 68 61 76 65 20 72 75 ;; Now have ru
1190: 6e 63 6f 6e 66 69 67 73 20 64 61 74 61 20 6c 6f nconfigs data lo
11a0: 61 64 65 64 2c 20 73 65 74 20 65 6e 76 69 72 6f aded, set enviro
11b0: 6e 6d 65 6e 74 20 76 61 72 73 0a 20 20 20 20 28 nment vars. (
11c0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
11d0: 20 28 73 65 63 74 69 6f 6e 29 0a 09 09 28 66 6f (section)...(fo
11e0: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
11f0: 76 61 72 76 61 6c 29 0a 09 09 09 20 20 20 20 28 varval).... (
1200: 73 65 74 21 20 65 6e 76 64 61 74 20 28 61 70 70 set! envdat (app
1210: 65 6e 64 20 65 6e 76 64 61 74 20 28 6c 69 73 74 end envdat (list
1220: 20 76 61 72 76 61 6c 29 29 29 0a 09 09 09 20 20 varval)))....
1230: 20 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 76 (setenv (car v
1240: 61 72 76 61 6c 29 28 63 61 64 72 20 76 61 72 76 arval)(cadr varv
1250: 61 6c 29 29 29 0a 09 09 09 20 20 28 63 6f 6e 66 al))).... (conf
1260: 69 67 66 3a 67 65 74 2d 73 65 63 74 69 6f 6e 20 igf:get-section
1270: 72 75 6e 63 6f 6e 66 69 67 20 73 65 63 74 69 6f runconfig sectio
1280: 6e 29 29 29 0a 09 20 20 20 20 20 20 28 6c 69 73 n))).. (lis
1290: 74 20 22 64 65 66 61 75 6c 74 22 20 74 61 72 67 t "default" targ
12a0: 65 74 29 29 0a 20 20 20 20 28 76 65 63 74 6f 72 et)). (vector
12b0: 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 target runname
12c0: 74 65 73 74 70 61 74 74 20 6b 65 79 73 20 6b 65 testpatt keys ke
12d0: 79 76 61 6c 73 20 65 6e 76 64 61 74 20 6d 63 6f yvals envdat mco
12e0: 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 67 20 73 nfig runconfig s
12f0: 65 72 76 65 72 64 61 74 20 74 72 61 6e 73 70 6f erverdat transpo
1300: 72 74 20 64 62 20 74 6f 70 70 61 74 68 20 72 75 rt db toppath ru
1310: 6e 2d 69 64 29 29 29 0a 0a 09 20 0a 28 64 65 66 n-id)))... .(def
1320: 69 6e 65 20 28 73 65 74 2d 6d 65 67 61 74 65 73 ine (set-megates
1330: 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 t-env-vars run-i
1340: 64 20 23 21 6b 65 79 20 28 69 6e 6b 65 79 73 20 d #!key (inkeys
1350: 23 66 29 28 69 6e 72 75 6e 6e 61 6d 65 20 23 66 #f)(inrunname #f
1360: 29 29 0a 20 20 28 6c 65 74 20 28 28 6b 65 79 73 )). (let ((keys
1370: 20 28 69 66 20 69 6e 6b 65 79 73 20 69 6e 6b 65 (if inkeys inke
1380: 79 73 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 ys (cdb:remote-r
1390: 75 6e 20 64 62 3a 67 65 74 2d 6b 65 79 73 20 23 un db:get-keys #
13a0: 66 29 29 29 0a 09 28 76 61 6c 73 20 28 68 61 73 f)))..(vals (has
13b0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
13c0: 75 6c 74 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 ult *env-vars-by
13d0: 2d 72 75 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 -run-id* run-id
13e0: 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 67 65 74 #f))). ;; get
13f0: 20 74 68 65 20 69 6e 66 6f 20 66 72 6f 6d 20 74 the info from t
1400: 68 65 20 64 62 20 61 6e 64 20 70 75 74 20 69 74 he db and put it
1410: 20 69 6e 20 74 68 65 20 63 61 63 68 65 0a 20 20 in the cache.
1420: 20 20 28 69 66 20 28 6e 6f 74 20 76 61 6c 73 29 (if (not vals)
1430: 0a 09 28 6c 65 74 20 28 28 68 74 20 28 6d 61 6b ..(let ((ht (mak
1440: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
1450: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
1460: 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 et! *env-vars-by
1470: 2d 72 75 6e 2d 69 64 2a 20 72 75 6e 2d 69 64 20 -run-id* run-id
1480: 68 74 29 0a 09 20 20 28 73 65 74 21 20 76 61 6c ht).. (set! val
1490: 73 20 68 74 29 0a 09 20 20 28 66 6f 72 2d 65 61 s ht).. (for-ea
14a0: 63 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 ch.. (lambda (
14b0: 6b 65 79 29 0a 09 20 20 20 20 20 28 68 61 73 68 key).. (hash
14c0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 76 61 6c 73 -table-set! vals
14d0: 20 6b 65 79 20 28 63 64 62 3a 72 65 6d 6f 74 65 key (cdb:remote
14e0: 2d 72 75 6e 20 64 62 3a 67 65 74 2d 72 75 6e 2d -run db:get-run-
14f0: 6b 65 79 2d 76 61 6c 20 23 66 20 72 75 6e 2d 69 key-val #f run-i
1500: 64 20 6b 65 79 29 29 29 0a 09 20 20 20 6b 65 79 d key))).. key
1510: 73 29 29 29 0a 20 20 20 20 3b 3b 20 66 72 6f 6d s))). ;; from
1520: 20 74 68 65 20 63 61 63 68 65 64 20 64 61 74 61 the cached data
1530: 20 73 65 74 20 74 68 65 20 76 61 72 73 0a 20 20 set the vars.
1540: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f (hash-table-fo
1550: 72 2d 65 61 63 68 0a 20 20 20 20 20 76 61 6c 73 r-each. vals
1560: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6b . (lambda (k
1570: 65 79 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 ey val). (
1580: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 debug:print 2 "s
1590: 65 74 65 6e 76 20 22 20 6b 65 79 20 22 20 22 20 etenv " key " "
15a0: 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 val). (set
15b0: 65 6e 76 20 6b 65 79 20 76 61 6c 29 29 29 0a 20 env key val))).
15c0: 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 (alist->env-v
15d0: 61 72 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ars (hash-table-
15e0: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e ref/default *con
15f0: 66 69 67 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 figdat* "env-ove
1600: 72 72 69 64 65 22 20 27 28 29 29 29 0a 20 20 20 rride" '())).
1610: 20 3b 3b 20 4c 65 74 73 20 75 73 65 20 74 68 69 ;; Lets use thi
1620: 73 20 61 73 20 61 6e 20 6f 70 70 6f 72 74 75 6e s as an opportun
1630: 69 74 79 20 74 6f 20 70 75 74 20 4d 54 5f 52 55 ity to put MT_RU
1640: 4e 4e 41 4d 45 20 69 6e 20 74 68 65 20 65 6e 76 NNAME in the env
1650: 69 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 28 73 65 ironment. (se
1660: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 tenv "MT_RUNNAME
1670: 22 20 28 69 66 20 69 6e 72 75 6e 6e 61 6d 65 20 " (if inrunname
1680: 69 6e 72 75 6e 6e 61 6d 65 20 28 63 64 62 3a 72 inrunname (cdb:r
1690: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 emote-run db:get
16a0: 2d 72 75 6e 2d 6e 61 6d 65 2d 66 72 6f 6d 2d 69 -run-name-from-i
16b0: 64 20 23 66 20 72 75 6e 2d 69 64 29 29 29 0a 20 d #f run-id))).
16c0: 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 (setenv "MT_R
16d0: 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 UN_AREA_HOME" *t
16e0: 6f 70 70 61 74 68 2a 29 29 29 0a 0a 28 64 65 66 oppath*)))..(def
16f0: 69 6e 65 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e ine (set-item-en
1700: 76 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a v-vars itemdat).
1710: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
1720: 62 64 61 20 28 69 74 65 6d 29 0a 09 20 20 20 20 bda (item)..
1730: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
1740: 20 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 "setenv " (car
1750: 69 74 65 6d 29 20 22 20 22 20 28 63 61 64 72 20 item) " " (cadr
1760: 69 74 65 6d 29 29 0a 09 20 20 20 20 20 20 28 73 item)).. (s
1770: 65 74 65 6e 76 20 28 63 61 72 20 69 74 65 6d 29 etenv (car item)
1780: 20 28 63 61 64 72 20 69 74 65 6d 29 29 29 0a 09 (cadr item)))..
1790: 20 20 20 20 69 74 65 6d 64 61 74 29 29 0a 0a 28 itemdat))..(
17a0: 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6e 75 6d define *last-num
17b0: 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 2a 20 -running-tests*
17c0: 30 29 0a 0a 3b 3b 20 45 76 65 72 79 20 74 69 6d 0)..;; Every tim
17d0: 65 20 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 e can-run-more-t
17e0: 65 73 74 73 20 69 73 20 63 61 6c 6c 65 64 20 69 ests is called i
17f0: 6e 63 72 65 6d 65 6e 74 20 74 68 65 20 64 65 6c ncrement the del
1800: 61 79 0a 3b 3b 20 69 66 20 74 68 65 20 63 6f 75 ay.;; if the cou
1810: 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 73 3a 63 .(define *runs:c
1820: 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 73 74 an-run-more-test
1830: 73 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 64 65 66 s-count* 0).(def
1840: 69 6e 65 20 28 72 75 6e 73 3a 73 68 72 69 6e 6b ine (runs:shrink
1850: 2d 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 -can-run-more-te
1860: 73 74 73 2d 63 6f 75 6e 74 29 0a 20 20 28 73 65 sts-count). (se
1870: 74 21 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e t! *runs:can-run
1880: 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e -more-tests-coun
1890: 74 2a 20 30 29 29 20 3b 3b 20 28 2f 20 2a 72 75 t* 0)) ;; (/ *ru
18a0: 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d ns:can-run-more-
18b0: 74 65 73 74 73 2d 63 6f 75 6e 74 2a 20 32 29 29 tests-count* 2))
18c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 )..(define (runs
18d0: 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 2d 74 65 :can-run-more-te
18e0: 73 74 73 20 74 65 73 74 2d 72 65 63 6f 72 64 20 sts test-record
18f0: 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a max-concurrent-j
1900: 6f 62 73 29 0a 20 20 28 74 68 72 65 61 64 2d 73 obs). (thread-s
1910: 6c 65 65 70 21 20 28 63 6f 6e 64 0a 09 09 20 20 leep! (cond...
1920: 28 28 3e 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 ((> *runs:can-ru
1930: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 n-more-tests-cou
1940: 6e 74 2a 20 32 30 29 20 32 29 3b 3b 20 6f 62 76 nt* 20) 2);; obv
1950: 69 6f 75 73 6c 79 20 68 61 76 65 6e 27 74 20 68 iously haven't h
1960: 61 64 20 61 6e 79 20 77 6f 72 6b 20 74 6f 20 64 ad any work to d
1970: 6f 20 66 6f 72 20 61 20 77 68 69 6c 65 0a 09 09 o for a while...
1980: 20 20 28 65 6c 73 65 20 30 29 29 29 0a 20 20 28 (else 0))). (
1990: 6c 65 74 2a 20 28 28 74 63 6f 6e 66 69 67 20 20 let* ((tconfig
19a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
19b0: 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d tests:testqueue-
19c0: 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 get-testconfig t
19d0: 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 est-record)).. (
19e0: 6a 6f 62 67 72 6f 75 70 20 20 20 20 20 20 20 20 jobgroup
19f0: 20 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d (config-
1a00: 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 lookup tconfig "
1a10: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6a requirements" "j
1a20: 6f 62 67 72 6f 75 70 22 29 29 0a 09 20 28 6e 75 obgroup")).. (nu
1a30: 6d 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 m-running
1a40: 20 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 (cdb:remot
1a50: 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 63 6f 75 e-run db:get-cou
1a60: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
1a70: 20 23 66 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e #f)).. (num-run
1a80: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
1a90: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
1aa0: 20 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 65 db:get-count-te
1ab0: 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a sts-running-in-j
1ac0: 6f 62 67 72 6f 75 70 20 23 66 20 6a 6f 62 67 72 obgroup #f jobgr
1ad0: 6f 75 70 29 29 0a 09 20 28 6a 6f 62 2d 67 72 6f oup)).. (job-gro
1ae0: 75 70 2d 6c 69 6d 69 74 20 20 20 20 20 20 20 20 up-limit
1af0: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
1b00: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 *configdat* "job
1b10: 67 72 6f 75 70 73 22 20 6a 6f 62 67 72 6f 75 70 groups" jobgroup
1b20: 29 29 29 0a 20 20 20 20 28 69 66 20 28 3e 20 28 ))). (if (> (
1b30: 2b 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 6e 75 + num-running nu
1b40: 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 m-running-in-job
1b50: 67 72 6f 75 70 29 20 30 29 0a 09 28 73 65 74 21 group) 0)..(set!
1b60: 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d *runs:can-run-m
1b70: 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 6e 74 2a ore-tests-count*
1b80: 20 28 2b 20 2a 72 75 6e 73 3a 63 61 6e 2d 72 75 (+ *runs:can-ru
1b90: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 2d 63 6f 75 n-more-tests-cou
1ba0: 6e 74 2a 20 31 29 29 29 0a 20 20 20 20 28 69 66 nt* 1))). (if
1bb0: 20 28 6e 6f 74 20 28 65 71 3f 20 2a 6c 61 73 74 (not (eq? *last
1bc0: 2d 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 -num-running-tes
1bd0: 74 73 2a 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 ts* num-running)
1be0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
1bf0: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 6d 61 78 bug:print 2 "max
1c00: 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 -concurrent-jobs
1c10: 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 : " max-concurre
1c20: 6e 74 2d 6a 6f 62 73 20 22 2c 20 6e 75 6d 2d 72 nt-jobs ", num-r
1c30: 75 6e 6e 69 6e 67 3a 20 22 20 6e 75 6d 2d 72 75 unning: " num-ru
1c40: 6e 6e 69 6e 67 29 0a 09 20 20 28 73 65 74 21 20 nning).. (set!
1c50: 2a 6c 61 73 74 2d 6e 75 6d 2d 72 75 6e 6e 69 6e *last-num-runnin
1c60: 67 2d 74 65 73 74 73 2a 20 6e 75 6d 2d 72 75 6e g-tests* num-run
1c70: 6e 69 6e 67 29 29 29 0a 20 20 20 20 28 69 66 20 ning))). (if
1c80: 28 6e 6f 74 20 28 65 71 3f 20 30 20 2a 67 6c 6f (not (eq? 0 *glo
1c90: 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a 29 29 balexitstatus*))
1ca0: 0a 09 28 6c 69 73 74 20 23 66 20 6e 75 6d 2d 72 ..(list #f num-r
1cb0: 75 6e 6e 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 unning num-runni
1cc0: 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d ng-in-jobgroup m
1cd0: 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f ax-concurrent-jo
1ce0: 62 73 20 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d bs job-group-lim
1cf0: 69 74 29 0a 09 28 6c 65 74 20 28 28 63 61 6e 2d it)..(let ((can-
1d00: 6e 6f 74 2d 72 75 6e 2d 6d 6f 72 65 20 28 63 6f not-run-more (co
1d10: 6e 64 0a 09 09 09 09 20 3b 3b 20 69 66 20 6d 61 nd..... ;; if ma
1d20: 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 x-concurrent-job
1d30: 73 20 69 73 20 73 65 74 20 61 6e 64 20 74 68 65 s is set and the
1d40: 20 6e 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 20 number running
1d50: 69 73 20 67 72 65 61 74 65 72 20 0a 09 09 09 09 is greater .....
1d60: 20 3b 3b 20 74 68 61 6e 20 69 74 20 74 68 61 6e ;; than it than
1d70: 20 63 61 6e 6e 6f 74 20 72 75 6e 20 6d 6f 72 65 cannot run more
1d80: 20 6a 6f 62 73 0a 09 09 09 09 20 28 28 61 6e 64 jobs..... ((and
1d90: 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 2d max-concurrent-
1da0: 6a 6f 62 73 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e jobs (>= num-run
1db0: 6e 69 6e 67 20 6d 61 78 2d 63 6f 6e 63 75 72 72 ning max-concurr
1dc0: 65 6e 74 2d 6a 6f 62 73 29 29 0a 09 09 09 09 20 ent-jobs)).....
1dd0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
1de0: 22 57 41 52 4e 49 4e 47 3a 20 4d 61 78 20 72 75 "WARNING: Max ru
1df0: 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 78 63 65 65 nning jobs excee
1e00: 64 65 64 2c 20 63 75 72 72 65 6e 74 20 6e 75 6d ded, current num
1e10: 62 65 72 20 72 75 6e 6e 69 6e 67 3a 20 22 20 6e ber running: " n
1e20: 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 09 09 09 um-running .....
1e30: 09 20 20 20 20 20 20 20 22 2c 20 6d 61 78 5f 63 . ", max_c
1e40: 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 3a 20 oncurrent_jobs:
1e50: 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 74 " max-concurrent
1e60: 2d 6a 6f 62 73 29 0a 09 09 09 09 20 20 23 74 29 -jobs)..... #t)
1e70: 0a 09 09 09 09 20 3b 3b 20 69 66 20 6a 6f 62 2d ..... ;; if job-
1e80: 67 72 6f 75 70 2d 6c 69 6d 69 74 20 69 73 20 73 group-limit is s
1e90: 65 74 20 61 6e 64 20 6e 75 6d 62 65 72 20 6f 66 et and number of
1ea0: 20 6a 6f 62 73 20 69 6e 20 74 68 65 20 67 72 6f jobs in the gro
1eb0: 75 70 20 69 73 20 67 72 65 61 74 65 72 0a 09 09 up is greater...
1ec0: 09 09 20 3b 3b 20 74 68 61 6e 20 74 68 65 20 6c .. ;; than the l
1ed0: 69 6d 69 74 20 74 68 65 6e 20 63 61 6e 6e 6f 74 imit then cannot
1ee0: 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 20 6f run more jobs o
1ef0: 66 20 74 68 69 73 20 6b 69 6e 64 0a 09 09 09 09 f this kind.....
1f00: 20 28 28 61 6e 64 20 6a 6f 62 2d 67 72 6f 75 70 ((and job-group
1f10: 2d 6c 69 6d 69 74 0a 09 09 09 09 20 20 20 20 20 -limit.....
1f20: 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e 69 6e (>= num-runnin
1f30: 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6a 6f g-in-jobgroup jo
1f40: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 29 0a b-group-limit)).
1f50: 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
1f60: 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 3a 20 6e nt 1 "WARNING: n
1f70: 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 22 20 umber of jobs "
1f80: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d 6a num-running-in-j
1f90: 6f 62 67 72 6f 75 70 20 0a 09 09 09 09 09 20 20 obgroup ......
1fa0: 20 20 20 20 20 22 20 69 6e 20 22 20 6a 6f 62 67 " in " jobg
1fb0: 72 6f 75 70 20 22 20 65 78 63 65 65 64 65 64 2c roup " exceeded,
1fc0: 20 77 69 6c 6c 20 6e 6f 74 20 72 75 6e 20 22 20 will not run "
1fd0: 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 (tests:testqueue
1fe0: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
1ff0: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 09 09 st-record)).....
2000: 20 20 23 74 29 0a 09 09 09 09 20 28 65 6c 73 65 #t)..... (else
2010: 20 23 66 29 29 29 29 0a 09 20 20 28 6c 69 73 74 #f)))).. (list
2020: 20 28 6e 6f 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 (not can-not-ru
2030: 6e 2d 6d 6f 72 65 29 20 6e 75 6d 2d 72 75 6e 6e n-more) num-runn
2040: 69 6e 67 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d ing num-running-
2050: 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 6d 61 78 2d in-jobgroup max-
2060: 63 6f 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 concurrent-jobs
2070: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 job-group-limit)
2080: 29 29 29 29 0a 0a 3b 3b 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 3d 0a 3b ==============.;
20d0: 3b 20 4e 65 77 20 6d 65 74 68 6f 64 6f 6c 6f 67 ; New methodolog
20e0: 79 2e 20 54 68 65 73 65 20 72 6f 75 74 69 6e 65 y. These routine
20f0: 73 20 77 69 6c 6c 20 72 65 70 6c 61 63 65 20 74 s will replace t
2100: 68 65 20 61 62 6f 76 65 20 69 6e 20 74 69 6d 65 he above in time
2110: 2e 20 46 6f 72 0a 3b 3b 20 6e 6f 77 20 74 68 65 . For.;; now the
2120: 20 63 6f 64 65 20 69 73 20 64 75 70 6c 69 63 61 code is duplica
2130: 74 65 64 2e 20 54 68 69 73 20 73 74 75 66 66 20 ted. This stuff
2140: 69 73 20 69 6e 69 74 69 61 6c 6c 79 20 75 73 65 is initially use
2150: 64 20 69 6e 20 74 68 65 20 6d 6f 6e 69 74 6f 72 d in the monitor
2160: 0a 3b 3b 20 62 61 73 65 64 20 63 6f 64 65 2e 0a .;; based code..
2170: 3b 3b 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 3d 0a 0a 0a 3b 3b 20 54 68 ========...;; Th
21c0: 69 73 20 69 73 20 61 20 64 75 70 6c 69 63 61 74 is is a duplicat
21d0: 65 20 6f 66 20 72 75 6e 2d 74 65 73 74 73 20 28 e of run-tests (
21e0: 77 68 69 63 68 20 68 61 73 20 62 65 65 6e 20 64 which has been d
21f0: 65 70 72 65 63 61 74 65 64 29 2e 20 55 73 65 20 eprecated). Use
2200: 74 68 69 73 20 6f 6e 65 20 69 6e 73 74 65 61 64 this one instead
2210: 20 6f 66 20 72 75 6e 20 74 65 73 74 73 2e 0a 3b of run tests..;
2220: 3b 20 6b 65 79 76 61 6c 73 2e 0a 3b 3b 0a 3b 3b ; keyvals..;;.;;
2230: 20 20 74 65 73 74 2d 6e 61 6d 65 73 3a 20 43 6f test-names: Co
2240: 6d 6d 61 20 73 65 70 61 72 61 74 65 64 20 70 61 mma separated pa
2250: 74 74 65 72 6e 73 20 73 61 6d 65 20 61 73 20 74 tterns same as t
2260: 65 73 74 2d 70 61 74 74 73 20 62 75 74 20 75 73 est-patts but us
2270: 65 64 20 69 6e 20 73 65 6c 65 63 74 69 6f 6e 20 ed in selection
2280: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
2290: 20 6f 66 20 74 65 73 74 73 20 74 6f 20 72 75 6e of tests to run
22a0: 2e 20 54 68 65 20 69 74 65 6d 20 70 6f 72 74 69 . The item porti
22b0: 6f 6e 73 20 61 72 65 20 6e 6f 74 20 72 65 73 70 ons are not resp
22c0: 65 63 74 65 64 2e 0a 3b 3b 20 20 20 20 20 20 20 ected..;;
22d0: 20 20 20 20 20 20 20 46 49 58 4d 45 3a 20 65 72 FIXME: er
22e0: 72 6f 72 20 6f 75 74 20 69 66 20 2f 70 61 74 74 ror out if /patt
22f0: 20 73 70 65 63 69 66 69 65 64 0a 3b 3b 20 20 20 specified.;;
2300: 20 20 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e .(defin
2310: 65 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 e (runs:run-test
2320: 73 20 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 s target runname
2330: 20 74 65 73 74 2d 70 61 74 74 73 20 75 73 65 72 test-patts user
2340: 20 66 6c 61 67 73 29 20 3b 3b 20 74 65 73 74 2d flags) ;; test-
2350: 6e 61 6d 65 73 0a 20 20 28 63 6f 6d 6d 6f 6e 3a names. (common:
2360: 63 6c 65 61 72 2d 63 61 63 68 65 73 29 20 3b 3b clear-caches) ;;
2370: 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 63 68 65 clear all cache
2380: 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 s. (let* ((db
2390: 20 20 20 20 20 20 20 20 23 66 29 0a 09 20 28 6b #f).. (k
23a0: 65 79 73 20 20 20 20 20 20 20 20 28 6b 65 79 73 eys (keys
23b0: 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c :config-get-fiel
23c0: 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 ds *configdat*))
23d0: 0a 09 20 28 6b 65 79 76 61 6c 73 20 20 20 20 20 .. (keyvals
23e0: 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 (keys:target->ke
23f0: 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 yval keys target
2400: 29 29 0a 09 20 28 72 75 6e 2d 69 64 20 20 20 20 )).. (run-id
2410: 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 (cdb:remote-ru
2420: 6e 20 64 62 3a 72 65 67 69 73 74 65 72 2d 72 75 n db:register-ru
2430: 6e 20 23 66 20 6b 65 79 73 20 6b 65 79 76 61 6c n #f keys keyval
2440: 73 20 72 75 6e 6e 61 6d 65 20 22 6e 65 77 22 20 s runname "new"
2450: 22 6e 2f 61 22 20 75 73 65 72 29 29 20 20 3b 3b "n/a" user)) ;;
2460: 20 20 74 65 73 74 2d 6e 61 6d 65 29 29 29 0a 09 test-name)))..
2470: 20 28 64 65 66 65 72 72 65 64 20 20 20 20 27 28 (deferred '(
2480: 29 29 20 3b 3b 20 64 65 6c 61 79 20 72 75 6e 6e )) ;; delay runn
2490: 69 6e 67 20 74 68 65 73 65 20 73 69 6e 63 65 20 ing these since
24a0: 74 68 65 79 20 68 61 76 65 20 61 20 77 61 69 74 they have a wait
24b0: 6f 6e 20 63 6c 61 75 73 65 0a 09 20 3b 3b 20 6b on clause.. ;; k
24c0: 65 65 70 67 6f 69 6e 67 20 69 73 20 74 68 65 20 eepgoing is the
24d0: 64 65 66 61 63 74 6f 20 6d 6f 64 61 6c 69 74 79 defacto modality
24e0: 20 6e 6f 77 2c 20 77 69 6c 6c 20 61 64 64 20 68 now, will add h
24f0: 69 74 2d 6e 2d 72 75 6e 20 61 20 62 69 74 20 6c it-n-run a bit l
2500: 61 74 65 72 0a 09 20 3b 3b 20 28 6b 65 65 70 67 ater.. ;; (keepg
2510: 6f 69 6e 67 20 20 20 28 68 61 73 68 2d 74 61 62 oing (hash-tab
2520: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 le-ref/default f
2530: 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 6e 67 lags "-keepgoing
2540: 22 20 23 66 29 29 0a 09 20 28 72 75 6e 63 6f 6e " #f)).. (runcon
2550: 66 69 67 66 20 20 20 28 63 6f 6e 63 20 20 2a 74 figf (conc *t
2560: 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e oppath* "/runcon
2570: 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 figs.config"))..
2580: 20 28 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 (required-tests
2590: 20 27 28 29 29 0a 09 20 28 74 65 73 74 2d 72 65 '()).. (test-re
25a0: 63 6f 72 64 73 20 28 6d 61 6b 65 2d 68 61 73 68 cords (make-hash
25b0: 2d 74 61 62 6c 65 29 29 0a 09 20 28 74 65 73 74 -table)).. (test
25c0: 2d 6e 61 6d 65 73 20 27 28 29 29 29 0a 0a 20 20 -names '()))..
25d0: 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d (set-megatest-
25e0: 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 env-vars run-id
25f0: 69 6e 6b 65 79 73 3a 20 6b 65 79 73 29 20 3b 3b inkeys: keys) ;;
2600: 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 these may be ne
2610: 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e eded by the laun
2620: 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 0a 20 ching process..
2630: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
2640: 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 29 sts? runconfigf)
2650: 0a 09 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 ..(setup-env-def
2660: 61 75 6c 74 73 20 72 75 6e 63 6f 6e 66 69 67 66 aults runconfigf
2670: 20 72 75 6e 2d 69 64 20 2a 61 6c 72 65 61 64 79 run-id *already
2680: 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d -seen-runconfig-
2690: 69 6e 66 6f 2a 20 6b 65 79 73 20 6b 65 79 76 61 info* keys keyva
26a0: 6c 73 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 ls "pre-launch-e
26b0: 6e 76 2d 76 61 72 73 22 29 0a 09 28 64 65 62 75 nv-vars")..(debu
26c0: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
26d0: 4e 47 3a 20 59 6f 75 20 64 6f 20 6e 6f 74 20 68 NG: You do not h
26e0: 61 76 65 20 61 20 72 75 6e 20 63 6f 6e 66 69 67 ave a run config
26f0: 20 66 69 6c 65 3a 20 22 20 72 75 6e 63 6f 6e 66 file: " runconf
2700: 69 67 66 29 29 0a 20 20 20 20 0a 20 20 20 20 3b igf)). . ;
2710: 3b 20 6c 6f 6f 6b 20 75 70 20 61 6c 6c 20 74 65 ; look up all te
2720: 73 74 73 20 6d 61 74 63 68 69 6e 67 20 74 68 65 sts matching the
2730: 20 63 6f 6d 6d 61 20 73 65 70 61 72 61 74 65 64 comma separated
2740: 20 6c 69 73 74 20 6f 66 20 67 6c 6f 62 73 20 69 list of globs i
2750: 6e 0a 20 20 20 20 3b 3b 20 74 65 73 74 2d 70 61 n. ;; test-pa
2760: 74 74 73 20 28 75 73 69 6e 67 20 25 20 61 73 20 tts (using % as
2770: 77 69 6c 64 63 61 72 64 29 0a 0a 20 20 20 20 28 wildcard).. (
2780: 73 65 74 21 20 74 65 73 74 2d 6e 61 6d 65 73 20 set! test-names
2790: 28 74 65 73 74 73 3a 67 65 74 2d 76 61 6c 69 64 (tests:get-valid
27a0: 2d 74 65 73 74 73 20 2a 74 6f 70 70 61 74 68 2a -tests *toppath*
27b0: 20 74 65 73 74 2d 70 61 74 74 73 29 29 0a 20 20 test-patts)).
27c0: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
27d0: 65 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 es (delete-dupli
27e0: 63 61 74 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 cates test-names
27f0: 29 29 0a 0a 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
2800: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 74 65 73 rint-info 0 "tes
2810: 74 20 6e 61 6d 65 73 20 22 20 74 65 73 74 2d 6e t names " test-n
2820: 61 6d 65 73 29 0a 0a 20 20 20 20 3b 3b 20 6f 6e ames).. ;; on
2830: 20 74 68 65 20 66 69 72 73 74 20 70 61 73 73 20 the first pass
2840: 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d 74 or call to run-t
2850: 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 20 74 ests set FAILS t
2860: 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 66 o NOT_STARTED if
2870: 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 . ;; -keepgoi
2880: 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 64 0a ng is specified.
2890: 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a 70 61 (if (eq? *pa
28a0: 73 73 6e 75 6d 2a 20 30 29 0a 09 28 62 65 67 69 ssnum* 0)..(begi
28b0: 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 6f 20 n.. ;; have to
28c0: 64 65 6c 65 74 65 20 74 65 73 74 20 72 65 63 6f delete test reco
28d0: 72 64 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 54 rds where NOT_ST
28e0: 41 52 54 45 44 20 73 69 6e 63 65 20 74 68 65 79 ARTED since they
28f0: 20 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 70 can cause -keep
2900: 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b 20 going to .. ;;
2910: 67 65 74 20 73 74 75 63 6b 20 64 75 65 20 74 6f get stuck due to
2920: 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 65 becoming inacce
2930: 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 61 ssible from a fa
2940: 69 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 2e 20 iled test. I.e.
2950: 69 66 20 74 65 73 74 20 42 20 64 65 70 65 6e 64 if test B depend
2960: 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 74 s .. ;; on test
2970: 20 41 20 62 75 74 20 74 65 73 74 20 42 20 72 65 A but test B re
2980: 61 63 68 65 64 20 74 68 65 20 70 6f 69 6e 74 20 ached the point
2990: 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 73 74 65 on being registe
29a0: 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 54 red as NOT_START
29b0: 45 44 20 61 6e 64 20 74 65 73 74 0a 09 20 20 3b ED and test.. ;
29c0: 3b 20 41 20 66 61 69 6c 65 64 20 66 6f 72 20 73 ; A failed for s
29d0: 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 6e 20 ome reason then
29e0: 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 20 on re-run using
29f0: 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 20 72 -keepgoing the r
2a00: 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 6f 6d un can never com
2a10: 70 6c 65 74 65 2e 0a 09 20 20 28 63 64 62 3a 64 plete... (cdb:d
2a20: 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 elete-tests-in-s
2a30: 74 61 74 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a tate *runremote*
2a40: 20 72 75 6e 2d 69 64 20 22 4e 4f 54 5f 53 54 41 run-id "NOT_STA
2a50: 52 54 45 44 22 29 0a 09 20 20 28 63 64 62 3a 72 RTED").. (cdb:r
2a60: 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 73 65 74 emote-run db:set
2a70: 2d 74 65 73 74 73 2d 73 74 61 74 65 2d 73 74 61 -tests-state-sta
2a80: 74 75 73 20 23 66 20 72 75 6e 2d 69 64 20 74 65 tus #f run-id te
2a90: 73 74 2d 6e 61 6d 65 73 20 23 66 20 22 46 41 49 st-names #f "FAI
2aa0: 4c 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 L" "NOT_STARTED"
2ab0: 20 22 46 41 49 4c 22 29 29 29 0a 0a 20 20 20 20 "FAIL")))..
2ac0: 3b 3b 20 66 72 6f 6d 20 68 65 72 65 20 6f 6e 20 ;; from here on
2ad0: 6f 75 74 20 74 68 65 20 64 62 20 77 69 6c 6c 20 out the db will
2ae0: 62 65 20 6f 70 65 6e 65 64 20 61 6e 64 20 63 6c be opened and cl
2af0: 6f 73 65 64 20 6f 6e 20 65 76 65 72 79 20 63 61 osed on every ca
2b00: 6c 6c 20 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 ll runs:run-test
2b10: 73 2d 71 75 65 75 65 0a 20 20 20 20 3b 3b 20 28 s-queue. ;; (
2b20: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
2b30: 21 20 64 62 29 20 0a 20 20 20 20 3b 3b 20 6e 6f ! db) . ;; no
2b40: 77 20 61 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 w add non-direct
2b50: 6c 79 20 72 65 66 65 72 65 6e 63 65 64 20 64 65 ly referenced de
2b60: 70 65 6e 64 65 6e 63 69 65 73 20 28 69 2e 65 2e pendencies (i.e.
2b70: 20 77 61 69 74 6f 6e 29 0a 20 20 20 20 28 69 66 waiton). (if
2b80: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 (not (null? tes
2b90: 74 2d 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 t-names))..(let
2ba0: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
2bb0: 74 65 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 test-names))...
2bc0: 20 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 (tal (cdr test
2bd0: 2d 6e 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 -names)))
2be0: 20 20 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f ;; 'return-pro
2bf0: 63 73 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e cs tells the con
2c00: 66 69 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 fig reader to pr
2c10: 65 70 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 ep running syste
2c20: 6d 20 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 m but return a p
2c30: 72 6f 63 0a 09 20 20 28 64 65 62 75 67 3a 70 72 roc.. (debug:pr
2c40: 69 6e 74 2d 69 6e 66 6f 20 34 20 22 68 65 64 3d int-info 4 "hed=
2c50: 22 20 68 65 64 20 22 20 61 74 20 74 6f 70 20 6f " hed " at top o
2c60: 66 20 6c 6f 6f 70 22 29 0a 09 20 20 28 6c 65 74 f loop").. (let
2c70: 2a 20 28 28 63 6f 6e 66 69 67 20 20 28 74 65 73 * ((config (tes
2c80: 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ts:get-testconfi
2c90: 67 20 68 65 64 20 27 72 65 74 75 72 6e 2d 70 72 g hed 'return-pr
2ca0: 6f 63 73 29 29 0a 09 09 20 28 77 61 69 74 6f 6e ocs))... (waiton
2cb0: 73 20 28 6c 65 74 20 28 28 69 6e 73 74 72 20 28 s (let ((instr (
2cc0: 69 66 20 63 6f 6e 66 69 67 20 0a 09 09 09 09 09 if config ......
2cd0: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
2ce0: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
2cf0: 65 6d 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 ements" "waiton"
2d00: 29 0a 09 09 09 09 09 20 20 20 28 62 65 67 69 6e )...... (begin
2d10: 20 3b 3b 20 4e 6f 20 63 6f 6e 66 69 67 20 6d 65 ;; No config me
2d20: 61 6e 73 20 74 68 69 73 20 69 73 20 61 20 6e 6f ans this is a no
2d30: 6e 2d 65 78 69 73 74 61 6e 74 20 74 65 73 74 0a n-existant test.
2d40: 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
2d50: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
2d60: 20 6e 6f 6e 2d 65 78 69 73 74 65 6e 74 20 72 65 non-existent re
2d70: 71 75 69 72 65 64 20 74 65 73 74 20 5c 22 22 20 quired test \""
2d80: 68 65 64 20 22 5c 22 22 29 0a 09 09 09 09 09 20 hed "\"")......
2d90: 20 20 20 20 28 69 66 20 64 62 20 28 73 71 6c 69 (if db (sqli
2da0: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
2db0: 29 29 0a 09 09 09 09 09 20 20 20 20 20 28 65 78 ))...... (ex
2dc0: 69 74 20 31 29 29 29 29 29 0a 09 09 09 20 20 20 it 1)))))....
2dd0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2de0: 66 6f 20 38 20 22 77 61 69 74 6f 6e 73 20 73 74 fo 8 "waitons st
2df0: 72 69 6e 67 20 69 73 20 22 20 69 6e 73 74 72 29 ring is " instr)
2e00: 0a 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d .... (string-
2e10: 73 70 6c 69 74 20 28 63 6f 6e 64 0a 09 09 09 09 split (cond.....
2e20: 09 20 20 20 28 28 70 72 6f 63 65 64 75 72 65 3f . ((procedure?
2e30: 20 69 6e 73 74 72 29 0a 09 09 09 09 09 20 20 20 instr)......
2e40: 20 28 6c 65 74 20 28 28 72 65 73 20 28 69 6e 73 (let ((res (ins
2e50: 74 72 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 tr)))......
2e60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2e70: 66 6f 20 38 20 22 77 61 69 74 6f 6e 20 70 72 6f fo 8 "waiton pro
2e80: 63 65 64 75 72 65 20 72 65 73 75 6c 74 73 20 69 cedure results i
2e90: 6e 20 73 74 72 69 6e 67 20 22 20 72 65 73 20 22 n string " res "
2ea0: 20 66 6f 72 20 74 65 73 74 20 22 20 68 65 64 29 for test " hed)
2eb0: 0a 09 09 09 09 09 20 20 20 20 20 20 72 65 73 29 ...... res)
2ec0: 29 0a 09 09 09 09 09 20 20 20 28 28 73 74 72 69 )...... ((stri
2ed0: 6e 67 3f 20 69 6e 73 74 72 29 20 20 20 20 20 69 ng? instr) i
2ee0: 6e 73 74 72 29 0a 09 09 09 09 09 20 20 20 28 65 nstr)...... (e
2ef0: 6c 73 65 20 0a 09 09 09 09 09 20 20 20 20 3b 3b lse ...... ;;
2f00: 20 4e 4f 54 45 3a 20 54 68 69 73 20 69 73 20 61 NOTE: This is a
2f10: 63 74 75 61 6c 6c 79 20 74 68 65 20 63 61 73 65 ctually the case
2f20: 20 6f 66 20 2a 6e 6f 2a 20 77 61 69 74 6f 6e 73 of *no* waitons
2f30: 21 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ! ;; (debug:prin
2f40: 74 20 30 20 22 45 52 52 4f 52 3a 20 73 6f 6d 65 t 0 "ERROR: some
2f50: 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 thing went wrong
2f60: 20 69 6e 20 70 72 6f 63 65 73 73 69 6e 67 20 77 in processing w
2f70: 61 69 74 6f 6e 73 20 66 6f 72 20 74 65 73 74 20 aitons for test
2f80: 22 20 68 65 64 29 0a 09 09 09 09 09 20 20 20 20 " hed)......
2f90: 22 22 29 29 29 29 29 29 0a 09 20 20 20 20 28 64 "")))))).. (d
2fa0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2fb0: 38 20 22 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 8 "waitons: " wa
2fc0: 69 74 6f 6e 73 29 0a 09 20 20 20 20 3b 3b 20 63 itons).. ;; c
2fd0: 68 65 63 6b 20 66 6f 72 20 68 65 64 20 69 6e 20 heck for hed in
2fe0: 77 61 69 74 6f 6e 73 20 3d 3e 20 74 68 69 73 20 waitons => this
2ff0: 77 6f 75 6c 64 20 62 65 20 63 69 72 63 75 6c 61 would be circula
3000: 72 2c 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 r, remove it and
3010: 20 69 73 73 75 65 20 61 6e 0a 09 20 20 20 20 3b issue an.. ;
3020: 3b 20 65 72 72 6f 72 0a 09 20 20 20 20 28 69 66 ; error.. (if
3030: 20 28 6d 65 6d 62 65 72 20 68 65 64 20 77 61 69 (member hed wai
3040: 74 6f 6e 73 29 0a 09 09 28 62 65 67 69 6e 0a 09 tons)...(begin..
3050: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
3060: 30 20 22 45 52 52 4f 52 3a 20 74 65 73 74 20 22 0 "ERROR: test "
3070: 20 68 65 64 20 22 20 68 61 73 20 6c 69 73 74 65 hed " has liste
3080: 64 20 69 74 73 65 6c 66 20 61 73 20 61 20 77 61 d itself as a wa
3090: 69 74 6f 6e 2c 20 70 6c 65 61 73 65 20 63 6f 72 iton, please cor
30a0: 72 65 63 74 20 74 68 69 73 21 22 29 0a 09 09 20 rect this!")...
30b0: 20 28 73 65 74 21 20 77 61 69 74 6f 6e 73 20 28 (set! waitons (
30c0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
30d0: 78 29 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 78 x)(not (equal? x
30e0: 20 68 65 64 29 29 29 20 77 61 69 74 6f 6e 73 29 hed))) waitons)
30f0: 29 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b ))).. .. ;
3100: 3b 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d ; (items (item
3110: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
3120: 2d 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 -config config))
3130: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
3140: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
3150: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 default test-rec
3160: 6f 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 ords hed #f))...
3170: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
3180: 20 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 test-records...
3190: 09 09 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 .. hed (vector h
31a0: 65 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 ed ;; 0.....
31b0: 09 20 20 20 20 20 63 6f 6e 66 69 67 20 20 3b 3b . config ;;
31c0: 20 31 0a 09 09 09 09 09 20 20 20 20 20 77 61 69 1...... wai
31d0: 74 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 20 tons ;; 2......
31e0: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
31f0: 75 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 up config "requi
3200: 72 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 rements" "priori
3210: 74 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f ty") ;; prio
3220: 72 69 74 79 20 33 0a 09 09 09 09 09 20 20 20 20 rity 3......
3230: 20 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 (let ((items
3240: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
3250: 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 ef/default confi
3260: 67 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b g "items" #f)) ;
3270: 3b 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 ; items 4.......
3280: 20 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 (itemstable (
3290: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
32a0: 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 efault config "i
32b0: 74 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 temstable" #f)))
32c0: 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b ...... ;;
32d0: 20 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 if either items
32e0: 20 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 or items table
32f0: 69 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e is a proc return
3300: 20 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e it so test runn
3310: 69 6e 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 ing......
3320: 3b 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b ;; process can k
3330: 6e 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d now to call item
3340: 73 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d s:get-items-from
3350: 2d 63 6f 6e 66 69 67 0a 09 09 09 09 09 20 20 20 -config......
3360: 20 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 ;; if either
3370: 20 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e is a list and n
3380: 6f 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f one is a proc go
3390: 20 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 ahead and call
33a0: 67 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 20 get-items......
33b0: 20 20 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 ;; otherwi
33c0: 73 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 se return #f - t
33d0: 68 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 his is not an it
33e0: 65 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 erated test.....
33f0: 09 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 . (cond...
3400: 09 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f ....((procedure?
3410: 20 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 items) ...
3420: 09 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e .... (debug:prin
3430: 74 2d 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 t-info 4 "items
3440: 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
3450: 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
3460: 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 29 20 )....... items)
3470: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 ;; ca
3480: 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 lc later.......(
3490: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
34a0: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 stable)....... (
34b0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
34c0: 20 34 20 22 69 74 65 6d 73 74 61 62 6c 65 20 69 4 "itemstable i
34d0: 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 77 s a procedure, w
34e0: 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 29 ill calc later")
34f0: 0a 09 09 09 09 09 09 20 69 74 65 6d 73 74 61 62 ....... itemstab
3500: 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 6c le) ;; cal
3510: 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 28 c later.......((
3520: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
3530: 78 29 0a 09 09 09 09 09 09 09 20 20 20 28 6c 65 x)........ (le
3540: 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 29 t ((val (car x))
3550: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 69 )........ (i
3560: 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 61 f (procedure? va
3570: 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 09 l) val #f)))....
3580: 09 09 09 09 20 28 61 70 70 65 6e 64 20 28 69 66 .... (append (if
3590: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 69 (list? items) i
35a0: 74 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 09 tems '()).......
35b0: 09 09 20 28 69 66 20 28 6c 69 73 74 3f 20 69 74 .. (if (list? it
35c0: 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 74 emstable) itemst
35d0: 61 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 09 able '()))).....
35e0: 09 09 20 27 68 61 76 65 2d 70 72 6f 63 65 64 75 .. 'have-procedu
35f0: 72 65 29 0a 09 09 09 09 09 09 28 28 6f 72 20 28 re).......((or (
3600: 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 73 list? items)(lis
3610: 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 20 t? itemstable))
3620: 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 09 ;; calc now.....
3630: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
3640: 69 6e 66 6f 20 34 20 22 69 74 65 6d 73 20 61 6e info 4 "items an
3650: 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 72 65 d itemstable are
3660: 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e 6f 77 lists, calc now
3670: 5c 6e 22 0a 09 09 09 09 09 09 09 20 20 20 20 20 \n"........
3680: 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 20 69 " items: " i
3690: 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 62 6c tems " itemstabl
36a0: 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c 65 29 e: " itemstable)
36b0: 0a 09 09 09 09 09 09 20 28 69 74 65 6d 73 3a 67 ....... (items:g
36c0: 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f et-items-from-co
36d0: 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a 09 09 nfig config))...
36e0: 09 09 09 09 28 65 6c 73 65 20 23 66 29 29 29 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 20 3b 3b 20 6e 6f 74 ;; not
3710: 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 09 20 iterated......
3720: 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 69 #f ;; i
3730: 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 09 20 temsdat 5......
3740: 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b 20 73 #f ;; s
3750: 70 61 72 65 20 2d 20 75 73 65 64 20 66 6f 72 20 pare - used for
3760: 69 74 65 6d 2d 70 61 74 68 0a 09 09 09 09 09 20 item-path......
3770: 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 66 6f ))).. (fo
3780: 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 6c r-each .. (l
3790: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
37a0: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
37b0: 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d waiton (not (mem
37c0: 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ber waiton test-
37d0: 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 62 names)))... (b
37e0: 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 egin... (set
37f0: 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 ! required-tests
3800: 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 (cons waiton re
3810: 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 quired-tests))..
3820: 09 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 . (set! test
3830: 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 -names (cons wai
3840: 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ton test-names))
3850: 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 ))) ;; was an ap
3860: 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 pend, now a cons
3870: 0a 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 0a .. waitons).
3880: 09 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 . (let ((remt
3890: 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 ests (delete-dup
38a0: 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 licates (append
38b0: 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a waitons tal)))).
38c0: 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
38d0: 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 (null? remtests)
38e0: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 )... (loop (car
38f0: 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 remtests)(cdr r
3900: 65 6d 74 65 73 74 73 29 29 29 29 29 29 29 0a 0a emtests)))))))..
3910: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
3920: 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 65 73 ll? required-tes
3930: 74 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 ts))..(debug:pri
3940: 6e 74 2d 69 6e 66 6f 20 31 20 22 41 64 64 69 6e nt-info 1 "Addin
3950: 67 20 22 20 72 65 71 75 69 72 65 64 2d 74 65 73 g " required-tes
3960: 74 73 20 22 20 74 6f 20 74 68 65 20 72 75 6e 20 ts " to the run
3970: 71 75 65 75 65 22 29 29 0a 20 20 20 20 3b 3b 20 queue")). ;;
3980: 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 72 65 20 NOTE: these are
3990: 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 74 73 all parent tests
39a0: 2c 20 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 20 , items are not
39b0: 65 78 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 20 expanded yet..
39c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
39d0: 6e 66 6f 20 34 20 22 74 65 73 74 2d 72 65 63 6f nfo 4 "test-reco
39e0: 72 64 73 3d 22 20 28 68 61 73 68 2d 74 61 62 6c rds=" (hash-tabl
39f0: 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 72 65 e->alist test-re
3a00: 63 6f 72 64 73 29 29 0a 20 20 20 20 28 6c 65 74 cords)). (let
3a10: 20 28 28 72 65 67 6c 65 6e 20 28 61 6e 79 2d 3e ((reglen (any->
3a20: 6e 75 6d 62 65 72 20 20 28 63 6f 6e 66 69 67 66 number (configf
3a30: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
3a40: 61 74 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e at* "setup" "run
3a50: 71 75 65 75 65 22 29 29 29 29 0a 20 20 20 20 20 queue")))).
3a60: 20 28 69 66 20 72 65 67 6c 65 6e 0a 09 20 20 28 (if reglen.. (
3a70: 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 2d 71 runs:run-tests-q
3a80: 75 65 75 65 2d 6e 65 77 20 72 75 6e 2d 69 64 20 ueue-new run-id
3a90: 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 63 runname test-rec
3aa0: 6f 72 64 73 20 66 6c 61 67 73 20 74 65 73 74 2d ords flags test-
3ab0: 70 61 74 74 73 20 72 65 67 6c 65 6e 29 0a 09 20 patts reglen)..
3ac0: 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 (runs:run-tests
3ad0: 2d 71 75 65 75 65 2d 63 6c 61 73 73 69 63 20 72 -queue-classic r
3ae0: 75 6e 2d 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 un-id runname te
3af0: 73 74 2d 72 65 63 6f 72 64 73 20 66 6c 61 67 73 st-records flags
3b00: 20 74 65 73 74 2d 70 61 74 74 73 29 29 29 0a 20 test-patts))).
3b10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3b20: 69 6e 66 6f 20 34 20 22 41 6c 6c 20 64 6f 6e 65 info 4 "All done
3b30: 20 62 79 20 68 65 72 65 22 29 29 29 0a 0a 28 64 by here")))..(d
3b40: 65 66 69 6e 65 20 28 72 75 6e 73 3a 63 61 6c 63 efine (runs:calc
3b50: 2d 66 61 69 6c 73 20 70 72 65 72 65 71 73 2d 6e -fails prereqs-n
3b60: 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c 74 65 ot-met). (filte
3b70: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 r (lambda (test)
3b80: 0a 09 20 20 20 20 28 61 6e 64 20 28 76 65 63 74 .. (and (vect
3b90: 6f 72 3f 20 74 65 73 74 29 20 3b 3b 20 6e 6f 74 or? test) ;; not
3ba0: 20 28 73 74 72 69 6e 67 3f 20 74 65 73 74 29 29 (string? test))
3bb0: 0a 09 09 20 28 65 71 75 61 6c 3f 20 28 64 62 3a ... (equal? (db:
3bc0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
3bd0: 65 73 74 29 20 22 43 4f 4d 50 4c 45 54 45 44 22 est) "COMPLETED"
3be0: 29 0a 09 09 20 28 6e 6f 74 20 28 6d 65 6d 62 65 )... (not (membe
3bf0: 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 r (db:test-get-s
3c00: 74 61 74 75 73 20 74 65 73 74 29 0a 09 09 09 20 tatus test)....
3c10: 20 20 20 20 20 27 28 22 50 41 53 53 22 20 22 57 '("PASS" "W
3c20: 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 ARN" "CHECK" "WA
3c30: 49 56 45 44 22 20 22 53 4b 49 50 22 29 29 29 29 IVED" "SKIP"))))
3c40: 29 0a 09 20 20 70 72 65 72 65 71 73 2d 6e 6f 74 ).. prereqs-not
3c50: 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 -met))..(define
3c60: 28 72 75 6e 73 3a 63 61 6c 63 2d 6e 6f 74 2d 63 (runs:calc-not-c
3c70: 6f 6d 70 6c 65 74 65 64 20 70 72 65 72 65 71 73 ompleted prereqs
3c80: 2d 6e 6f 74 2d 6d 65 74 29 0a 20 20 28 66 69 6c -not-met). (fil
3c90: 74 65 72 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 ter. (lambda (
3ca0: 74 29 0a 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 t). (or (not
3cb0: 20 28 76 65 63 74 6f 72 3f 20 74 29 29 0a 09 20 (vector? t))..
3cc0: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 22 43 4f (not (equal? "CO
3cd0: 4d 50 4c 45 54 45 44 22 20 28 64 62 3a 74 65 73 MPLETED" (db:tes
3ce0: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 29 29 29 t-get-state t)))
3cf0: 29 29 0a 20 20 20 70 72 65 72 65 71 73 2d 6e 6f )). prereqs-no
3d00: 74 2d 6d 65 74 29 29 0a 0a 28 64 65 66 69 6e 65 t-met))..(define
3d10: 20 28 72 75 6e 73 3a 70 72 65 74 74 79 2d 73 74 (runs:pretty-st
3d20: 72 69 6e 67 20 6c 73 74 29 0a 20 20 28 6d 61 70 ring lst). (map
3d30: 20 28 6c 61 6d 62 64 61 20 28 74 29 0a 09 20 28 (lambda (t).. (
3d40: 69 66 20 28 6e 6f 74 20 28 76 65 63 74 6f 72 3f if (not (vector?
3d50: 20 74 29 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 t)).. (conc
3d60: 20 74 29 0a 09 20 20 20 20 20 28 63 6f 6e 63 20 t).. (conc
3d70: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
3d80: 74 6e 61 6d 65 20 74 29 20 22 3a 22 20 28 64 62 tname t) ":" (db
3d90: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
3da0: 74 29 20 22 2f 22 20 28 64 62 3a 74 65 73 74 2d t) "/" (db:test-
3db0: 67 65 74 2d 73 74 61 74 75 73 20 74 29 29 29 29 get-status t))))
3dc0: 0a 20 20 20 20 20 20 20 6c 73 74 29 29 0a 0a 28 . lst))..(
3dd0: 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 6d 61 6b define (runs:mak
3de0: 65 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 6d 65 e-full-test-name
3df0: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 testname itempa
3e00: 74 68 29 0a 20 20 28 69 66 20 28 65 71 75 61 6c th). (if (equal
3e10: 3f 20 69 74 65 6d 70 61 74 68 20 22 22 29 20 74 ? itempath "") t
3e20: 65 73 74 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 estname (conc te
3e30: 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 stname "/" itemp
3e40: 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ath)))..(define
3e50: 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 (runs:queue-next
3e60: 2d 68 65 64 20 74 61 6c 20 72 65 67 20 6e 20 72 -hed tal reg n r
3e70: 65 67 66 75 6c 29 0a 20 20 28 69 66 20 72 65 67 egful). (if reg
3e80: 66 75 6c 0a 20 20 20 20 20 20 28 69 66 20 28 6e ful. (if (n
3e90: 75 6c 6c 3f 20 72 65 67 29 20 3b 3b 20 64 6f 65 ull? reg) ;; doe
3ea0: 73 6e 27 74 20 6d 61 6b 65 20 73 65 6e 73 65 2c sn't make sense,
3eb0: 20 74 68 69 73 20 69 73 20 70 72 6f 62 61 62 6c this is probabl
3ec0: 79 20 4e 4f 54 20 74 68 65 20 70 72 6f 62 6c 65 y NOT the proble
3ed0: 6d 20 6f 66 20 74 68 65 20 63 61 72 0a 09 20 20 m of the car..
3ee0: 28 63 61 72 20 74 61 6c 29 0a 09 20 20 28 63 61 (car tal).. (ca
3ef0: 72 20 72 65 67 29 29 0a 20 20 20 20 20 20 28 63 r reg)). (c
3f00: 61 72 20 74 61 6c 29 29 29 0a 0a 28 64 65 66 69 ar tal)))..(defi
3f10: 6e 65 20 28 72 75 6e 73 3a 71 75 65 75 65 2d 6e ne (runs:queue-n
3f20: 65 78 74 2d 74 61 6c 20 74 61 6c 20 72 65 67 20 ext-tal tal reg
3f30: 6e 20 72 65 67 66 75 6c 29 0a 20 20 28 69 66 20 n regful). (if
3f40: 72 65 67 66 75 6c 0a 20 20 20 20 20 20 74 61 6c regful. tal
3f50: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 . (let ((ne
3f60: 77 74 61 6c 20 28 63 64 72 20 74 61 6c 29 29 29 wtal (cdr tal)))
3f70: 0a 09 28 69 66 20 28 6e 75 6c 6c 3f 20 6e 65 77 ..(if (null? new
3f80: 74 61 6c 29 0a 09 20 20 20 20 72 65 67 0a 09 20 tal).. reg..
3f90: 20 20 20 6e 65 77 74 61 6c 0a 09 20 20 20 20 29 newtal.. )
3fa0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 72 75 )))..(define (ru
3fb0: 6e 73 3a 71 75 65 75 65 2d 6e 65 78 74 2d 72 65 ns:queue-next-re
3fc0: 67 20 74 61 6c 20 72 65 67 20 6e 20 72 65 67 66 g tal reg n regf
3fd0: 75 6c 29 0a 20 20 28 69 66 20 72 65 67 66 75 6c ul). (if regful
3fe0: 0a 20 20 20 20 20 20 28 63 64 72 20 72 65 67 29 . (cdr reg)
3ff0: 0a 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 . (if (eq?
4000: 28 6c 65 6e 67 74 68 20 74 61 6c 29 20 31 29 0a (length tal) 1).
4010: 09 20 20 27 28 29 0a 09 20 20 72 65 67 29 29 29 . '().. reg)))
4020: 0a 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 6e 2d ..(include "run-
4030: 74 65 73 74 73 2d 71 75 65 75 65 2d 63 6c 61 73 tests-queue-clas
4040: 73 69 63 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 sic.scm").(inclu
4050: 64 65 20 22 72 75 6e 2d 74 65 73 74 73 2d 71 75 de "run-tests-qu
4060: 65 75 65 2d 6e 65 77 2e 73 63 6d 22 29 0a 0a 3b eue-new.scm")..;
4070: 3b 20 70 61 72 65 6e 74 2d 74 65 73 74 20 69 73 ; parent-test is
4080: 20 74 68 65 72 65 20 61 73 20 61 20 70 6c 61 63 there as a plac
4090: 65 68 6f 6c 64 65 72 20 66 6f 72 20 77 68 65 6e eholder for when
40a0: 20 70 61 72 65 6e 74 2d 74 65 73 74 73 20 63 61 parent-tests ca
40b0: 6e 20 62 65 20 72 75 6e 20 61 73 20 61 20 73 65 n be run as a se
40c0: 74 75 70 20 73 74 65 70 0a 28 64 65 66 69 6e 65 tup step.(define
40d0: 20 28 72 75 6e 3a 74 65 73 74 20 72 75 6e 2d 69 (run:test run-i
40e0: 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 2d 76 d run-info key-v
40f0: 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 als runname test
4100: 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 20 70 61 -record flags pa
4110: 72 65 6e 74 2d 74 65 73 74 29 0a 20 20 3b 3b 20 rent-test). ;;
4120: 41 6c 6c 20 74 68 65 73 65 20 76 61 72 73 20 6d All these vars m
4130: 69 67 68 74 20 62 65 20 72 65 66 65 72 65 6e 63 ight be referenc
4140: 65 64 20 62 79 20 74 68 65 20 74 65 73 74 63 6f ed by the testco
4150: 6e 66 69 67 20 66 69 6c 65 20 72 65 61 64 65 72 nfig file reader
4160: 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 2d . (let* ((test-
4170: 6e 61 6d 65 20 20 20 20 28 74 65 73 74 73 3a 74 name (tests:t
4180: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
4190: 74 6e 61 6d 65 20 20 20 74 65 73 74 2d 72 65 63 tname test-rec
41a0: 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 77 61 ord)).. (test-wa
41b0: 69 74 6f 6e 73 20 28 74 65 73 74 73 3a 74 65 73 itons (tests:tes
41c0: 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 74 6f tqueue-get-waito
41d0: 6e 73 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 ns test-recor
41e0: 64 29 29 0a 09 20 28 74 65 73 74 2d 63 6f 6e 66 d)).. (test-conf
41f0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
4200: 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 6f 6e ueue-get-testcon
4210: 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 64 29 fig test-record)
4220: 29 0a 09 20 28 69 74 65 6d 64 61 74 20 20 20 20 ).. (itemdat
4230: 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 (tests:testque
4240: 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 20 20 ue-get-itemdat
4250: 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a test-record)).
4260: 09 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 . (test-path
4270: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
4280: 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e "/tests/" test-n
4290: 61 6d 65 29 29 20 3b 3b 20 63 6f 75 6c 64 20 75 ame)) ;; could u
42a0: 73 65 20 74 65 73 74 73 3a 67 65 74 2d 74 65 73 se tests:get-tes
42b0: 74 63 6f 6e 66 69 67 20 68 65 72 65 20 2e 2e 2e tconfig here ...
42c0: 0a 09 20 28 66 6f 72 63 65 20 20 20 20 20 20 20 .. (force
42d0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
42e0: 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 /default flags "
42f0: 2d 66 6f 72 63 65 22 20 23 66 29 29 0a 09 20 28 -force" #f)).. (
4300: 72 65 72 75 6e 20 20 20 20 20 20 20 20 28 68 61 rerun (ha
4310: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4320: 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 65 72 ault flags "-rer
4330: 75 6e 22 20 23 66 29 29 0a 09 20 28 6b 65 65 70 un" #f)).. (keep
4340: 67 6f 69 6e 67 20 20 20 20 28 68 61 73 68 2d 74 going (hash-t
4350: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4360: 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f 69 flags "-keepgoi
4370: 6e 67 22 20 23 66 29 29 0a 09 20 28 69 74 65 6d ng" #f)).. (item
4380: 2d 70 61 74 68 20 20 20 20 20 22 22 29 0a 09 20 -path "")..
4390: 28 64 62 20 20 20 20 20 20 20 20 20 20 20 23 66 (db #f
43a0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
43b0: 69 6e 74 20 34 0a 09 09 20 22 74 65 73 74 2d 63 int 4... "test-c
43c0: 6f 6e 66 69 67 3a 20 22 20 28 68 61 73 68 2d 74 onfig: " (hash-t
43d0: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 able->alist test
43e0: 2d 63 6f 6e 66 29 0a 09 09 20 22 5c 6e 20 20 20 -conf)... "\n
43f0: 69 74 65 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 itemdat: " itemd
4400: 61 74 0a 09 09 20 29 0a 20 20 20 20 3b 3b 20 73 at... ). ;; s
4410: 65 74 74 69 6e 67 20 69 74 65 6d 64 61 74 20 74 etting itemdat t
4420: 6f 20 61 20 6c 69 73 74 20 69 66 20 69 74 20 69 o a list if it i
4430: 73 20 23 66 0a 20 20 20 20 28 69 66 20 28 6e 6f s #f. (if (no
4440: 74 20 69 74 65 6d 64 61 74 29 28 73 65 74 21 20 t itemdat)(set!
4450: 69 74 65 6d 64 61 74 20 27 28 29 29 29 0a 20 20 itemdat '())).
4460: 20 20 28 73 65 74 21 20 69 74 65 6d 2d 70 61 74 (set! item-pat
4470: 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 h (item-list->pa
4480: 74 68 20 69 74 65 6d 64 61 74 29 29 0a 20 20 20 th itemdat)).
4490: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
44a0: 22 41 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c "Attempting to l
44b0: 61 75 6e 63 68 20 74 65 73 74 20 22 20 74 65 73 aunch test " tes
44c0: 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 61 t-name (if (equa
44d0: 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 2f 22 l? item-path "/"
44e0: 29 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 ) "/" item-path)
44f0: 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d ). (setenv "M
4500: 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 T_TEST_NAME" tes
4510: 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 20 t-name) ;; .
4520: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
4530: 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a AME" runname).
4540: 20 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 73 (set-megates
4550: 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 t-env-vars run-i
4560: 64 20 69 6e 72 75 6e 6e 61 6d 65 3a 20 72 75 6e d inrunname: run
4570: 6e 61 6d 65 29 20 3b 3b 20 74 68 65 73 65 20 6d name) ;; these m
4580: 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 ay be needed by
4590: 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 the launching pr
45a0: 6f 63 65 73 73 0a 20 20 20 20 28 63 68 61 6e 67 ocess. (chang
45b0: 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 e-directory *top
45c0: 70 61 74 68 2a 29 0a 0a 20 20 20 20 3b 3b 20 48 path*).. ;; H
45d0: 65 72 65 20 69 73 20 77 68 65 72 65 20 74 68 65 ere is where the
45e0: 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c 65 test_meta table
45f0: 20 69 73 20 62 65 73 74 20 75 70 64 61 74 65 64 is best updated
4600: 0a 20 20 20 20 3b 3b 20 59 65 73 2c 20 61 6e 6f . ;; Yes, ano
4610: 74 68 65 72 20 75 73 65 20 6f 66 20 61 20 67 6c ther use of a gl
4620: 6f 62 61 6c 20 66 6f 72 20 63 61 63 68 69 6e 67 obal for caching
4630: 2e 20 4e 65 65 64 20 61 20 62 65 74 74 65 72 20 . Need a better
4640: 77 61 79 3f 0a 20 20 20 20 28 69 66 20 28 6e 6f way?. (if (no
4650: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 t (hash-table-re
4660: 66 2f 64 65 66 61 75 6c 74 20 2a 74 65 73 74 2d f/default *test-
4670: 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 74 65 meta-updated* te
4680: 73 74 2d 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 st-name #f)).
4690: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 (begin..
46a0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
46b0: 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 *test-meta-upda
46c0: 74 65 64 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 ted* test-name #
46d0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 t). (r
46e0: 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 74 5f uns:update-test_
46f0: 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 20 74 meta test-name t
4700: 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 est-conf))).
4710: 0a 20 20 20 20 3b 3b 20 28 6c 61 6d 62 64 61 20 . ;; (lambda
4720: 28 69 74 65 6d 64 61 74 29 20 3b 3b 3b 20 28 28 (itemdat) ;;; ((
4730: 72 69 70 65 6e 65 73 73 20 22 6f 76 65 72 72 69 ripeness "overri
4740: 70 65 22 29 20 28 74 65 6d 70 65 72 61 74 75 72 pe") (temperatur
4750: 65 20 22 63 6f 6f 6c 22 29 20 28 73 65 61 73 6f e "cool") (seaso
4760: 6e 20 22 73 75 6d 6d 65 72 22 29 29 0a 20 20 20 n "summer")).
4770: 20 28 6c 65 74 2a 20 28 28 6e 65 77 2d 74 65 73 (let* ((new-tes
4780: 74 2d 70 61 74 68 20 28 73 74 72 69 6e 67 2d 69 t-path (string-i
4790: 6e 74 65 72 73 70 65 72 73 65 20 28 63 6f 6e 73 ntersperse (cons
47a0: 20 74 65 73 74 2d 70 61 74 68 20 28 6d 61 70 20 test-path (map
47b0: 63 61 64 72 20 69 74 65 6d 64 61 74 29 29 20 22 cadr itemdat)) "
47c0: 2f 22 29 29 0a 09 20 20 20 28 6e 65 77 2d 74 65 /")).. (new-te
47d0: 73 74 2d 6e 61 6d 65 20 28 69 66 20 28 65 71 75 st-name (if (equ
47e0: 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 20 22 22 al? item-path ""
47f0: 29 20 74 65 73 74 2d 6e 61 6d 65 20 28 63 6f 6e ) test-name (con
4800: 63 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 c test-name "/"
4810: 69 74 65 6d 2d 70 61 74 68 29 29 29 20 3b 3b 20 item-path))) ;;
4820: 6a 75 73 74 20 6e 65 65 64 20 69 74 20 74 6f 20 just need it to
4830: 62 65 20 75 6e 69 71 75 65 0a 09 20 20 20 28 74 be unique.. (t
4840: 65 73 74 2d 69 64 20 20 20 20 20 20 20 28 63 64 est-id (cd
4850: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
4860: 67 65 74 2d 74 65 73 74 2d 69 64 20 23 66 20 20 get-test-id #f
4870: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
4880: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 item-path))..
4890: 20 28 74 65 73 74 64 61 74 20 20 20 20 20 20 20 (testdat
48a0: 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e (cdb:get-test-in
48b0: 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 65 6d fo-by-id *runrem
48c0: 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 29 0a ote* test-id))).
48d0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 74 (if (not t
48e0: 65 73 74 64 61 74 29 0a 09 20 20 28 62 65 67 69 estdat).. (begi
48f0: 6e 0a 09 20 20 20 20 3b 3b 20 65 6e 73 75 72 65 n.. ;; ensure
4900: 20 74 68 61 74 20 74 68 65 20 70 61 74 68 20 65 that the path e
4910: 78 69 73 74 73 20 62 65 66 6f 72 65 20 72 65 67 xists before reg
4920: 69 73 74 65 72 69 6e 67 20 74 68 65 20 74 65 73 istering the tes
4930: 74 0a 09 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 t.. ;; NOPE:
4940: 43 61 6e 6e 6f 74 21 20 44 6f 6e 27 74 20 6b 6e Cannot! Don't kn
4950: 6f 77 20 79 65 74 20 77 68 69 63 68 20 64 69 73 ow yet which dis
4960: 6b 20 61 72 65 61 20 77 69 6c 6c 20 62 65 20 61 k area will be a
4970: 73 73 69 67 6e 65 64 2e 2e 2e 2e 0a 09 20 20 20 ssigned......
4980: 20 3b 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e ;; (system (con
4990: 63 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6e 65 c "mkdir -p " ne
49a0: 77 2d 74 65 73 74 2d 70 61 74 68 29 29 0a 09 20 w-test-path))..
49b0: 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b 20 28 6f ;;.. ;; (o
49c0: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 74 65 pen-run-close te
49d0: 73 74 73 3a 72 65 67 69 73 74 65 72 2d 74 65 73 sts:register-tes
49e0: 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 t db run-id test
49f0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
4a00: 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 3b 3b .. ;;.. ;;
4a10: 20 4e 42 2f 2f 20 66 6f 72 20 74 68 65 20 61 62 NB// for the ab
4a20: 6f 76 65 20 6c 69 6e 65 2e 20 49 20 77 61 6e 74 ove line. I want
4a30: 20 74 68 65 20 74 65 73 74 20 74 6f 20 62 65 20 the test to be
4a40: 72 65 67 69 73 74 65 72 65 64 20 6c 6f 6e 67 20 registered long
4a50: 62 65 66 6f 72 65 20 74 68 69 73 20 72 6f 75 74 before this rout
4a60: 69 6e 65 20 67 65 74 73 20 63 61 6c 6c 65 64 21 ine gets called!
4a70: 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 73 .. ;;.. (s
4a80: 65 74 21 20 74 65 73 74 2d 69 64 20 28 6f 70 65 et! test-id (ope
4a90: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 n-run-close db:g
4aa0: 65 74 2d 74 65 73 74 2d 69 64 20 64 62 20 72 75 et-test-id db ru
4ab0: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i
4ac0: 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 tem-path))..
4ad0: 28 69 66 20 28 6e 6f 74 20 74 65 73 74 2d 69 64 (if (not test-id
4ae0: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
4af0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 57 debug:print 2 "W
4b00: 41 52 4e 3a 20 54 65 73 74 20 6e 6f 74 20 70 72 ARN: Test not pr
4b10: 65 2d 63 72 65 61 74 65 64 3f 20 74 65 73 74 2d e-created? test-
4b20: 6e 61 6d 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 name=" test-name
4b30: 20 22 2c 20 69 74 65 6d 2d 70 61 74 68 3d 22 20 ", item-path="
4b40: 69 74 65 6d 2d 70 61 74 68 20 22 2c 20 72 75 6e item-path ", run
4b50: 2d 69 64 3d 22 20 72 75 6e 2d 69 64 29 0a 09 09 -id=" run-id)...
4b60: 20 20 28 63 64 62 3a 74 65 73 74 73 2d 72 65 67 (cdb:tests-reg
4b70: 69 73 74 65 72 2d 74 65 73 74 20 2a 72 75 6e 72 ister-test *runr
4b80: 65 6d 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 emote* run-id te
4b90: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
4ba0: 68 29 0a 09 09 20 20 28 73 65 74 21 20 74 65 73 h)... (set! tes
4bb0: 74 2d 69 64 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 t-id (open-run-c
4bc0: 6c 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 lose db:get-test
4bd0: 2d 69 64 20 64 62 20 72 75 6e 2d 69 64 20 74 65 -id db run-id te
4be0: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
4bf0: 68 29 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 h)))).. (debu
4c00: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
4c10: 74 65 73 74 2d 69 64 3d 22 20 74 65 73 74 2d 69 test-id=" test-i
4c20: 64 20 22 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 d ", run-id=" ru
4c30: 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 6e 61 6d n-id ", test-nam
4c40: 65 3d 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c e=" test-name ",
4c50: 20 69 74 65 6d 2d 70 61 74 68 3d 5c 22 22 20 69 item-path=\"" i
4c60: 74 65 6d 2d 70 61 74 68 20 22 5c 22 22 29 0a 09 tem-path "\"")..
4c70: 20 20 20 20 28 73 65 74 21 20 74 65 73 74 64 61 (set! testda
4c80: 74 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 2d t (cdb:get-test-
4c90: 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e 72 info-by-id *runr
4ca0: 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 29 emote* test-id))
4cb0: 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 74 )). (set! t
4cc0: 65 73 74 2d 69 64 20 28 64 62 3a 74 65 73 74 2d est-id (db:test-
4cd0: 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 get-id testdat))
4ce0: 0a 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 . (change-d
4cf0: 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d 70 61 irectory test-pa
4d00: 74 68 29 0a 20 20 20 20 20 20 28 63 61 73 65 20 th). (case
4d10: 28 69 66 20 66 6f 72 63 65 20 3b 3b 20 28 61 72 (if force ;; (ar
4d20: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 66 6f 72 gs:get-arg "-for
4d30: 63 65 22 29 0a 09 09 27 4e 4f 54 5f 53 54 41 52 ce")...'NOT_STAR
4d40: 54 45 44 0a 09 09 28 69 66 20 74 65 73 74 64 61 TED...(if testda
4d50: 74 0a 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d t... (string-
4d60: 3e 73 79 6d 62 6f 6c 20 28 74 65 73 74 3a 67 65 >symbol (test:ge
4d70: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
4d80: 29 0a 09 09 20 20 20 20 27 66 61 69 6c 65 64 2d )... 'failed-
4d90: 74 6f 2d 69 6e 73 65 72 74 29 29 0a 09 28 28 66 to-insert))..((f
4da0: 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 72 74 29 ailed-to-insert)
4db0: 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
4dc0: 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 0 "ERROR: Failed
4dd0: 20 74 6f 20 69 6e 73 65 72 74 20 74 68 65 20 72 to insert the r
4de0: 65 63 6f 72 64 20 69 6e 74 6f 20 74 68 65 20 64 ecord into the d
4df0: 62 22 29 29 0a 09 28 28 4e 4f 54 5f 53 54 41 52 b"))..((NOT_STAR
4e00: 54 45 44 20 43 4f 4d 50 4c 45 54 45 44 20 44 45 TED COMPLETED DE
4e10: 4c 45 54 45 44 29 0a 09 20 28 6c 65 74 20 28 28 LETED).. (let ((
4e20: 72 75 6e 66 6c 61 67 20 23 66 29 29 0a 09 20 20 runflag #f))..
4e30: 20 28 63 6f 6e 64 0a 09 20 20 20 20 3b 3b 20 2d (cond.. ;; -
4e40: 66 6f 72 63 65 2c 20 72 75 6e 20 6e 6f 20 6d 61 force, run no ma
4e50: 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 tter what.. (
4e60: 66 6f 72 63 65 20 28 73 65 74 21 20 72 75 6e 66 force (set! runf
4e70: 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b 3b lag #t)).. ;;
4e80: 20 4e 4f 54 5f 53 54 41 52 54 45 44 2c 20 72 75 NOT_STARTED, ru
4e90: 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 n no matter what
4ea0: 0a 09 20 20 20 20 28 28 6d 65 6d 62 65 72 20 28 .. ((member (
4eb0: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 test:get-state t
4ec0: 65 73 74 64 61 74 29 20 27 28 22 44 45 4c 45 54 estdat) '("DELET
4ed0: 45 44 22 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 ED" "NOT_STARTED
4ee0: 22 29 29 28 73 65 74 21 20 72 75 6e 66 6c 61 67 "))(set! runflag
4ef0: 20 23 74 29 29 0a 09 20 20 20 20 3b 3b 20 6e 6f #t)).. ;; no
4f00: 74 20 2d 72 65 72 75 6e 20 61 6e 64 20 50 41 53 t -rerun and PAS
4f10: 53 2c 20 57 41 52 4e 20 6f 72 20 43 48 45 43 4b S, WARN or CHECK
4f20: 2c 20 64 6f 20 6e 6f 20 72 75 6e 0a 09 20 20 20 , do no run..
4f30: 20 28 28 61 6e 64 20 28 6f 72 20 28 6e 6f 74 20 ((and (or (not
4f40: 72 65 72 75 6e 29 0a 09 09 20 20 20 20 20 20 6b rerun)... k
4f50: 65 65 70 67 6f 69 6e 67 29 0a 09 09 20 20 3b 3b eepgoing)... ;;
4f60: 20 52 65 71 75 69 72 65 20 74 6f 20 66 6f 72 63 Require to forc
4f70: 65 20 72 65 2d 72 75 6e 20 66 6f 72 20 43 4f 4d e re-run for COM
4f80: 50 4c 45 54 45 44 20 6f 72 20 2a 61 6e 79 74 68 PLETED or *anyth
4f90: 69 6e 67 2a 20 2b 20 50 41 53 53 2c 57 41 52 4e ing* + PASS,WARN
4fa0: 20 6f 72 20 43 48 45 43 4b 0a 09 09 20 20 28 6f or CHECK... (o
4fb0: 72 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a r (member (test:
4fc0: 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 get-status testd
4fd0: 61 74 29 20 27 28 22 50 41 53 53 22 20 22 57 41 at) '("PASS" "WA
4fe0: 52 4e 22 20 22 43 48 45 43 4b 22 20 22 53 4b 49 RN" "CHECK" "SKI
4ff0: 50 22 29 29 0a 09 09 20 20 20 20 20 20 28 6d 65 P"))... (me
5000: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
5010: 74 61 74 65 20 20 74 65 73 74 64 61 74 29 20 27 tate testdat) '
5020: 28 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 29 29 ("COMPLETED"))))
5030: 20 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
5040: 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 72 75 6e rint-info 2 "run
5050: 6e 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 ning test " test
5060: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
5070: 61 74 68 20 22 20 73 75 70 70 72 65 73 73 65 64 ath " suppressed
5080: 20 61 73 20 69 74 20 69 73 20 22 20 28 74 65 73 as it is " (tes
5090: 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t:get-state test
50a0: 64 61 74 29 20 22 20 61 6e 64 20 22 20 28 74 65 dat) " and " (te
50b0: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
50c0: 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 28 73 stdat)).. (s
50d0: 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 et! runflag #f))
50e0: 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 6e 20 .. ;; -rerun
50f0: 61 6e 64 20 73 74 61 74 75 73 20 69 73 20 6f 6e and status is on
5100: 65 20 6f 66 20 74 68 65 20 73 70 65 63 69 66 65 e of the specife
5110: 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 20 28 d, run it.. (
5120: 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 20 28 (and rerun... (
5130: 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 74 20 let* ((rerunlst
5140: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
5150: 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 09 20 rerun ","))....
5160: 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d 65 6d (must-rerun (mem
5170: 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 ber (test:get-st
5180: 61 74 75 73 20 74 65 73 74 64 61 74 29 20 72 65 atus testdat) re
5190: 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 20 20 runlst)))...
51a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
51b0: 6f 20 33 20 22 2d 72 65 72 75 6e 20 6c 69 73 74 o 3 "-rerun list
51c0: 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 74 65 73 : " rerun ", tes
51d0: 74 2d 73 74 61 74 75 73 3a 20 22 20 28 74 65 73 t-status: " (tes
51e0: 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t:get-status tes
51f0: 74 64 61 74 29 22 2c 20 6d 75 73 74 2d 72 65 72 tdat)", must-rer
5200: 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 72 75 6e un: " must-rerun
5210: 29 0a 09 09 20 20 20 20 6d 75 73 74 2d 72 65 72 )... must-rer
5220: 75 6e 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 un)).. (debu
5230: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 22 g:print-info 2 "
5240: 52 65 72 75 6e 20 66 6f 72 63 65 64 20 66 6f 72 Rerun forced for
5250: 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d test " test-nam
5260: 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 e "/" item-path)
5270: 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 75 6e .. (set! run
5280: 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 20 3b flag #t)).. ;
5290: 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 2c 20 64 6f ; -keepgoing, do
52a0: 20 6e 6f 74 20 72 65 72 75 6e 20 46 41 49 4c 0a not rerun FAIL.
52b0: 09 20 20 20 20 28 28 61 6e 64 20 6b 65 65 70 67 . ((and keepg
52c0: 6f 69 6e 67 0a 09 09 20 20 28 6d 65 6d 62 65 72 oing... (member
52d0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 (test:get-statu
52e0: 73 20 74 65 73 74 64 61 74 29 20 27 28 22 46 41 s testdat) '("FA
52f0: 49 4c 22 29 29 29 0a 09 20 20 20 20 20 28 73 65 IL"))).. (se
5300: 74 21 20 72 75 6e 66 6c 61 67 20 23 66 29 29 0a t! runflag #f)).
5310: 09 20 20 20 20 28 28 61 6e 64 20 28 6e 6f 74 20 . ((and (not
5320: 72 65 72 75 6e 29 0a 09 09 20 20 28 6d 65 6d 62 rerun)... (memb
5330: 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 er (test:get-sta
5340: 74 75 73 20 74 65 73 74 64 61 74 29 20 27 28 22 tus testdat) '("
5350: 46 41 49 4c 22 20 22 6e 2f 61 22 29 29 29 0a 09 FAIL" "n/a")))..
5360: 20 20 20 20 20 28 73 65 74 21 20 72 75 6e 66 6c (set! runfl
5370: 61 67 20 23 74 29 29 0a 09 20 20 20 20 28 65 6c ag #t)).. (el
5380: 73 65 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 se (set! runflag
5390: 20 23 66 29 29 29 0a 09 20 20 20 28 64 65 62 75 #f))).. (debu
53a0: 67 3a 70 72 69 6e 74 20 36 20 22 52 55 4e 4e 49 g:print 6 "RUNNI
53b0: 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 67 3a 20 22 NG => runflag: "
53c0: 20 72 75 6e 66 6c 61 67 20 22 20 53 54 41 54 45 runflag " STATE
53d0: 3a 20 22 20 28 74 65 73 74 3a 67 65 74 2d 73 74 : " (test:get-st
53e0: 61 74 65 20 74 65 73 74 64 61 74 29 20 22 20 53 ate testdat) " S
53f0: 54 41 54 55 53 3a 20 22 20 28 74 65 73 74 3a 67 TATUS: " (test:g
5400: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
5410: 74 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 t)).. (if (not
5420: 20 72 75 6e 66 6c 61 67 29 0a 09 20 20 20 20 20 runflag)..
5430: 20 20 28 69 66 20 28 6e 6f 74 20 70 61 72 65 6e (if (not paren
5440: 74 2d 74 65 73 74 29 0a 09 09 20 20 20 28 64 65 t-test)... (de
5450: 62 75 67 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 bug:print 1 "NOT
5460: 45 3a 20 4e 6f 74 20 73 74 61 72 74 69 6e 67 20 E: Not starting
5470: 74 65 73 74 20 22 20 6e 65 77 2d 74 65 73 74 2d test " new-test-
5480: 6e 61 6d 65 20 22 20 61 73 20 69 74 20 69 73 20 name " as it is
5490: 73 74 61 74 65 20 5c 22 22 20 28 74 65 73 74 3a state \"" (test:
54a0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
54b0: 74 29 20 0a 09 09 09 09 22 5c 22 20 61 6e 64 20 t) ....."\" and
54c0: 73 74 61 74 75 73 20 5c 22 22 20 28 74 65 73 74 status \"" (test
54d0: 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 :get-status test
54e0: 64 61 74 29 20 22 5c 22 2c 20 75 73 65 20 2d 72 dat) "\", use -r
54f0: 65 72 75 6e 20 5c 22 22 20 28 74 65 73 74 3a 67 erun \"" (test:g
5500: 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 et-status testda
5510: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
5520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5530: 20 20 20 22 5c 22 20 6f 72 20 2d 66 6f 72 63 65 "\" or -force
5540: 20 74 6f 20 6f 76 65 72 72 69 64 65 22 29 29 0a to override")).
5550: 09 20 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a . ;; NOTE:
5560: 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 65 20 63 68 No longer be ch
5570: 65 63 6b 69 6e 67 20 70 72 65 72 65 71 75 69 73 ecking prerequis
5580: 69 74 65 73 20 68 65 72 65 21 20 57 69 6c 6c 20 ites here! Will
5590: 6e 65 76 65 72 20 67 65 74 20 68 65 72 65 20 75 never get here u
55a0: 6e 6c 65 73 73 20 70 72 65 72 65 71 73 20 61 72 nless prereqs ar
55b0: 65 0a 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 e.. ;;
55c0: 20 20 20 61 6c 72 65 61 64 79 20 6d 65 74 2e 0a already met..
55d0: 09 20 20 20 20 20 20 20 3b 3b 20 54 68 69 73 20 . ;; This
55e0: 77 6f 75 6c 64 20 62 65 20 61 20 67 72 65 61 74 would be a great
55f0: 20 70 6c 61 63 65 20 74 6f 20 64 6f 20 74 68 65 place to do the
5600: 20 70 72 6f 63 65 73 73 2d 66 6f 72 6b 0a 09 20 process-fork..
5610: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
5620: 6c 61 75 6e 63 68 2d 74 65 73 74 20 74 65 73 74 launch-test test
5630: 2d 69 64 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 -id run-id run-i
5640: 6e 66 6f 20 6b 65 79 2d 76 61 6c 73 20 72 75 6e nfo key-vals run
5650: 6e 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 74 name test-conf t
5660: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 est-name test-pa
5670: 74 68 20 69 74 65 6d 64 61 74 20 66 6c 61 67 73 th itemdat flags
5680: 29 29 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 ))... (begin..
5690: 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 . (print "ER
56a0: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c ROR: Failed to l
56b0: 61 75 6e 63 68 20 74 68 65 20 74 65 73 74 2e 20 aunch the test.
56c0: 45 78 69 74 69 6e 67 20 61 73 20 73 6f 6f 6e 20 Exiting as soon
56d0: 61 73 20 70 6f 73 73 69 62 6c 65 22 29 0a 09 09 as possible")...
56e0: 20 20 20 20 20 28 73 65 74 21 20 2a 67 6c 6f 62 (set! *glob
56f0: 61 6c 65 78 69 74 73 74 61 74 75 73 2a 20 31 29 alexitstatus* 1)
5700: 20 3b 3b 20 0a 09 09 20 20 20 20 20 28 70 72 6f ;; ... (pro
5710: 63 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 cess-signal (cur
5720: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
5730: 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 29 signal/kill))))
5740: 29 29 0a 09 28 28 4b 49 4c 4c 45 44 29 20 0a 09 ))..((KILLED) ..
5750: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
5760: 22 4e 4f 54 45 3a 20 22 20 6e 65 77 2d 74 65 73 "NOTE: " new-tes
5770: 74 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 t-name " is alre
5780: 61 64 79 20 72 75 6e 6e 69 6e 67 20 6f 72 20 77 ady running or w
5790: 61 73 20 65 78 70 6c 69 63 74 6c 79 20 6b 69 6c as explictly kil
57a0: 6c 65 64 2c 20 75 73 65 20 2d 66 6f 72 63 65 20 led, use -force
57b0: 74 6f 20 6c 61 75 6e 63 68 20 69 74 2e 22 29 29 to launch it."))
57c0: 0a 09 28 28 4c 41 55 4e 43 48 45 44 20 52 45 4d ..((LAUNCHED REM
57d0: 4f 54 45 48 4f 53 54 53 54 41 52 54 20 52 55 4e OTEHOSTSTART RUN
57e0: 4e 49 4e 47 29 20 20 0a 09 20 28 69 66 20 28 3e NING) .. (if (>
57f0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
5800: 6f 6e 64 73 29 28 2b 20 28 64 62 3a 74 65 73 74 onds)(+ (db:test
5810: 2d 67 65 74 2d 65 76 65 6e 74 5f 74 69 6d 65 20 -get-event_time
5820: 74 65 73 74 64 61 74 29 0a 09 09 09 09 20 20 20 testdat).....
5830: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
5840: 2d 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 -run_duration te
5850: 73 74 64 61 74 29 29 29 0a 09 09 36 30 30 29 20 stdat)))...600)
5860: 3b 3b 20 69 2e 65 2e 20 6e 6f 20 75 70 64 61 74 ;; i.e. no updat
5870: 65 20 66 6f 72 20 6d 6f 72 65 20 74 68 61 6e 20 e for more than
5880: 36 30 30 20 73 65 63 6f 6e 64 73 0a 09 20 20 20 600 seconds..
5890: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
58a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
58b0: 22 57 41 52 4e 49 4e 47 3a 20 54 65 73 74 20 22 "WARNING: Test "
58c0: 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 61 70 70 test-name " app
58d0: 65 61 72 73 20 74 6f 20 62 65 20 64 65 61 64 2e ears to be dead.
58e0: 20 46 6f 72 63 69 6e 67 20 69 74 20 74 6f 20 73 Forcing it to s
58f0: 74 61 74 65 20 49 4e 43 4f 4d 50 4c 45 54 45 20 tate INCOMPLETE
5900: 61 6e 64 20 73 74 61 74 75 73 20 53 54 55 43 4b and status STUCK
5910: 2f 44 45 41 44 22 29 0a 09 20 20 20 20 20 20 20 /DEAD")..
5920: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
5930: 73 74 61 74 75 73 21 20 74 65 73 74 2d 69 64 20 status! test-id
5940: 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 "INCOMPLETE" "ST
5950: 55 43 4b 2f 44 45 41 44 22 20 22 54 65 73 74 20 UCK/DEAD" "Test
5960: 69 73 20 73 74 75 63 6b 20 6f 72 20 64 65 61 64 is stuck or dead
5970: 22 20 23 66 29 29 0a 09 20 20 20 20 20 28 64 65 " #f)).. (de
5980: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 bug:print 2 "NOT
5990: 45 3a 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 E: " test-name "
59a0: 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e 6e is already runn
59b0: 69 6e 67 22 29 29 29 0a 09 28 65 6c 73 65 20 20 ing")))..(else
59c0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
59d0: 74 20 30 20 22 45 52 52 4f 52 3a 20 46 61 69 6c t 0 "ERROR: Fail
59e0: 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 65 73 ed to launch tes
59f0: 74 20 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d t " new-test-nam
5a00: 65 20 22 2e 20 55 6e 72 65 63 6f 67 6e 69 73 65 e ". Unrecognise
5a10: 64 20 73 74 61 74 65 20 22 20 28 74 65 73 74 3a d state " (test:
5a20: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 get-state testda
5a30: 74 29 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d t)))))))..;;====
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 3d 0a 3b 3b 20 45 4e 44 20 4f 46 20 4e 45 57 ==.;; END OF NEW
5a90: 20 53 54 55 46 46 0a 3b 3b 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 3d 0a ===============.
5ae0: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 69 .(define (get-di
5af0: 72 2d 75 70 2d 6e 20 64 69 72 20 2e 20 70 61 72 r-up-n dir . par
5b00: 61 6d 73 29 20 0a 20 20 28 6c 65 74 20 28 28 64 ams) . (let ((d
5b10: 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d 73 parts (string-s
5b20: 70 6c 69 74 20 64 69 72 20 22 2f 22 29 29 0a 09 plit dir "/"))..
5b30: 28 63 6f 75 6e 74 20 20 20 28 69 66 20 28 6e 75 (count (if (nu
5b40: 6c 6c 3f 20 70 61 72 61 6d 73 29 20 31 20 28 63 ll? params) 1 (c
5b50: 61 72 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 ar params)))).
5b60: 20 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 (conc "/" (str
5b70: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
5b80: 0a 09 20 20 20 20 20 20 20 28 74 61 6b 65 20 64 .. (take d
5b90: 70 61 72 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 parts (- (length
5ba0: 20 64 70 61 72 74 73 29 20 63 6f 75 6e 74 29 29 dparts) count))
5bb0: 0a 09 20 20 20 20 20 20 20 22 2f 22 29 29 29 29 .. "/"))))
5bc0: 0a 3b 3b 20 52 65 6d 6f 76 65 20 72 75 6e 73 0a .;; Remove runs.
5bd0: 3b 3b 20 66 69 65 6c 64 73 20 61 72 65 20 70 61 ;; fields are pa
5be0: 73 73 69 6e 67 20 69 6e 20 74 68 72 6f 75 67 68 ssing in through
5bf0: 20 0a 3b 3b 20 61 63 74 69 6f 6e 3a 0a 3b 3b 20 .;; action:.;;
5c00: 20 20 20 27 72 65 6d 6f 76 65 2d 72 75 6e 73 0a 'remove-runs.
5c10: 3b 3b 20 20 20 20 27 73 65 74 2d 73 74 61 74 65 ;; 'set-state
5c20: 2d 73 74 61 74 75 73 0a 3b 3b 0a 3b 3b 20 4e 42 -status.;;.;; NB
5c30: 2f 2f 20 73 68 6f 75 6c 64 20 70 61 73 73 20 69 // should pass i
5c40: 6e 20 6b 65 79 73 3f 0a 3b 3b 0a 28 64 65 66 69 n keys?.;;.(defi
5c50: 6e 65 20 28 72 75 6e 73 3a 6f 70 65 72 61 74 65 ne (runs:operate
5c60: 2d 6f 6e 20 61 63 74 69 6f 6e 20 74 61 72 67 65 -on action targe
5c70: 74 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 65 t runnamepatt te
5c80: 73 74 70 61 74 74 20 23 21 6b 65 79 20 28 73 74 stpatt #!key (st
5c90: 61 74 65 20 23 66 29 28 73 74 61 74 75 73 20 23 ate #f)(status #
5ca0: 66 29 28 6e 65 77 2d 73 74 61 74 65 2d 73 74 61 f)(new-state-sta
5cb0: 74 75 73 20 23 66 29 29 0a 20 20 28 63 6f 6d 6d tus #f)). (comm
5cc0: 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 on:clear-caches)
5cd0: 20 3b 3b 20 63 6c 65 61 72 20 61 6c 6c 20 63 61 ;; clear all ca
5ce0: 63 68 65 73 0a 20 20 28 6c 65 74 2a 20 28 28 64 ches. (let* ((d
5cf0: 62 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a b #f).
5d00: 09 20 28 6b 65 79 73 20 20 20 20 20 20 20 20 20 . (keys
5d10: 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 (open-run-close
5d20: 64 62 3a 67 65 74 2d 6b 65 79 73 20 64 62 29 29 db:get-keys db))
5d30: 0a 09 20 28 72 75 6e 64 61 74 20 20 20 20 20 20 .. (rundat
5d40: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
5d50: 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 runs:get-runs-b
5d60: 79 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 y-patt db keys r
5d70: 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 72 67 65 unnamepatt targe
5d80: 74 29 29 0a 09 20 28 68 65 61 64 65 72 20 20 20 t)).. (header
5d90: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
5da0: 72 75 6e 64 61 74 20 30 29 29 0a 09 20 28 72 75 rundat 0)).. (ru
5db0: 6e 73 20 20 20 20 20 20 20 20 20 28 76 65 63 74 ns (vect
5dc0: 6f 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 or-ref rundat 1)
5dd0: 29 0a 09 20 28 73 74 61 74 65 73 20 20 20 20 20 ).. (states
5de0: 20 20 28 69 66 20 73 74 61 74 65 20 20 28 73 74 (if state (st
5df0: 72 69 6e 67 2d 73 70 6c 69 74 20 73 74 61 74 65 ring-split state
5e00: 20 20 22 2c 22 29 20 27 28 29 29 29 0a 09 20 28 ",") '())).. (
5e10: 73 74 61 74 75 73 65 73 20 20 20 20 20 28 69 66 statuses (if
5e20: 20 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d status (string-
5e30: 73 70 6c 69 74 20 73 74 61 74 75 73 20 22 2c 22 split status ","
5e40: 29 20 27 28 29 29 29 0a 09 20 28 73 74 61 74 65 ) '())).. (state
5e50: 2d 73 74 61 74 75 73 20 28 69 66 20 28 73 74 72 -status (if (str
5e60: 69 6e 67 3f 20 6e 65 77 2d 73 74 61 74 65 2d 73 ing? new-state-s
5e70: 74 61 74 75 73 29 20 28 73 74 72 69 6e 67 2d 73 tatus) (string-s
5e80: 70 6c 69 74 20 6e 65 77 2d 73 74 61 74 65 2d 73 plit new-state-s
5e90: 74 61 74 75 73 20 22 2c 22 29 20 27 28 23 66 20 tatus ",") '(#f
5ea0: 23 66 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 #f)))). (debu
5eb0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 22 g:print-info 4 "
5ec0: 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e 20 runs:operate-on
5ed0: 3d 3e 20 48 65 61 64 65 72 3a 20 22 20 68 65 61 => Header: " hea
5ee0: 64 65 72 20 22 20 61 63 74 69 6f 6e 3a 20 22 20 der " action: "
5ef0: 61 63 74 69 6f 6e 20 22 20 6e 65 77 2d 73 74 61 action " new-sta
5f00: 74 65 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 77 te-status: " new
5f10: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 29 0a 20 -state-status).
5f20: 20 20 20 28 69 66 20 28 3e 20 32 20 28 6c 65 6e (if (> 2 (len
5f30: 67 74 68 20 73 74 61 74 65 2d 73 74 61 74 75 73 gth state-status
5f40: 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 ))..(begin.. (d
5f50: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 ebug:print 0 "ER
5f60: 52 4f 52 3a 20 74 68 65 20 70 61 72 61 6d 65 74 ROR: the paramet
5f70: 65 72 20 74 6f 20 2d 73 65 74 2d 73 74 61 74 65 er to -set-state
5f80: 2d 73 74 61 74 75 73 20 69 73 20 61 20 63 6f 6d -status is a com
5f90: 6d 61 20 64 65 6c 69 6d 69 74 65 64 20 73 74 72 ma delimited str
5fa0: 69 6e 67 2e 20 45 2e 67 2e 20 43 4f 4d 50 4c 45 ing. E.g. COMPLE
5fb0: 54 45 44 2c 46 41 49 4c 22 29 0a 09 20 20 28 65 TED,FAIL").. (e
5fc0: 78 69 74 29 29 29 0a 20 20 20 20 28 66 6f 72 2d xit))). (for-
5fd0: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
5fe0: 61 20 28 72 75 6e 29 0a 20 20 20 20 20 20 20 28 a (run). (
5ff0: 6c 65 74 20 28 28 72 75 6e 6b 65 79 20 28 73 74 let ((runkey (st
6000: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
6010: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 6b (map (lambda (k
6020: 29 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 2d ).......(db:get-
6030: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
6040: 72 75 6e 20 68 65 61 64 65 72 20 6b 29 29 20 6b run header k)) k
6050: 65 79 73 29 20 22 2f 22 29 29 0a 09 20 20 20 20 eys) "/"))..
6060: 20 28 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 (dirs-to-remove
6070: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
6080: 65 29 29 29 0a 09 20 28 6c 65 74 2a 20 28 28 72 e))).. (let* ((r
6090: 75 6e 2d 69 64 20 20 20 20 28 64 62 3a 67 65 74 un-id (db:get
60a0: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
60b0: 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
60c0: 29 29 0a 09 09 28 72 75 6e 2d 73 74 61 74 65 20 ))...(run-state
60d0: 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 (db:get-value-by
60e0: 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 -header run head
60f0: 65 72 20 22 73 74 61 74 65 22 29 29 0a 09 09 28 er "state"))...(
6100: 74 65 73 74 73 20 20 20 20 20 28 69 66 20 28 6e tests (if (n
6110: 6f 74 20 28 65 71 75 61 6c 3f 20 72 75 6e 2d 73 ot (equal? run-s
6120: 74 61 74 65 20 22 6c 6f 63 6b 65 64 22 29 29 0a tate "locked")).
6130: 09 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
6140: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 67 65 74 run-close db:get
6150: 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 64 -tests-for-run d
6160: 62 20 72 75 6e 2d 69 64 0a 09 09 09 09 09 09 20 b run-id.......
6170: 20 20 20 20 20 74 65 73 74 70 61 74 74 20 73 74 testpatt st
6180: 61 74 65 73 20 73 74 61 74 75 73 65 73 0a 09 09 ates statuses...
6190: 09 09 09 09 20 20 20 20 20 20 6e 6f 74 2d 69 6e .... not-in
61a0: 3a 20 20 23 66 0a 09 09 09 09 09 09 20 20 20 20 : #f.......
61b0: 20 20 73 6f 72 74 2d 62 79 3a 20 28 63 61 73 65 sort-by: (case
61c0: 20 61 63 74 69 6f 6e 0a 09 09 09 09 09 09 09 09 action.........
61d0: 20 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 ((remove-runs)
61e0: 27 72 75 6e 64 69 72 29 0a 09 09 09 09 09 09 09 'rundir)........
61f0: 09 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 . (else
6200: 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 29 29 0a 'event_time))).
6210: 09 09 09 20 20 20 20 20 20 20 27 28 29 29 29 0a ... '())).
6220: 09 09 28 6c 61 73 74 74 70 61 74 68 20 22 2f 64 ..(lasttpath "/d
6230: 6f 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f oes/not/exist/I/
6240: 68 6f 70 65 22 29 29 0a 09 20 20 20 28 64 65 62 hope")).. (deb
6250: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
6260: 22 72 75 6e 73 3a 6f 70 65 72 61 74 65 2d 6f 6e "runs:operate-on
6270: 20 72 75 6e 3d 22 20 72 75 6e 20 22 2c 20 68 65 run=" run ", he
6280: 61 64 65 72 3d 22 20 68 65 61 64 65 72 29 0a 09 ader=" header)..
6290: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
62a0: 6c 3f 20 74 65 73 74 73 29 29 0a 09 20 20 20 20 l? tests))..
62b0: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 63 61 (begin... (ca
62c0: 73 65 20 61 63 74 69 6f 6e 0a 09 09 20 20 20 28 se action... (
62d0: 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 0a 09 09 (remove-runs)...
62e0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
62f0: 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 65 73 1 "Removing tes
6300: 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 72 75 ts for run: " ru
6310: 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 65 74 nkey " " (db:get
6320: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
6330: 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 75 6e run header "run
6340: 6e 61 6d 65 22 29 29 29 0a 09 09 20 20 20 28 28 name")))... ((
6350: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
6360: 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 )... (debug:p
6370: 72 69 6e 74 20 31 20 22 4d 6f 64 69 66 79 69 6e rint 1 "Modifyin
6380: 67 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 75 g state and stau
6390: 73 20 66 6f 72 20 74 65 73 74 73 20 66 6f 72 20 s for tests for
63a0: 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 20 22 20 run: " runkey "
63b0: 22 20 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 2d " (db:get-value-
63c0: 62 79 2d 68 65 61 64 65 72 20 72 75 6e 20 68 65 by-header run he
63d0: 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 22 29 29 ader "runname"))
63e0: 29 0a 09 09 20 20 20 28 28 70 72 69 6e 74 2d 72 )... ((print-r
63f0: 75 6e 29 0a 09 09 20 20 20 20 28 64 65 62 75 67 un)... (debug
6400: 3a 70 72 69 6e 74 20 31 20 22 50 72 69 6e 74 69 :print 1 "Printi
6410: 6e 67 20 69 6e 66 6f 20 66 6f 72 20 72 75 6e 20 ng info for run
6420: 22 20 72 75 6e 6b 65 79 20 22 2c 20 72 75 6e 3d " runkey ", run=
6430: 22 20 72 75 6e 20 22 2c 20 74 65 73 74 73 3d 22 " run ", tests="
6440: 20 74 65 73 74 73 20 22 2c 20 68 65 61 64 65 72 tests ", header
6450: 3d 22 20 68 65 61 64 65 72 29 0a 09 09 20 20 20 =" header)...
6460: 20 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 28 65 action)... (e
6470: 6c 73 65 0a 09 09 20 20 20 20 28 64 65 62 75 67 lse... (debug
6480: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 22 61 :print-info 0 "a
6490: 63 74 69 6f 6e 20 6e 6f 74 20 72 65 63 6f 67 6e ction not recogn
64a0: 69 73 65 64 20 22 20 61 63 74 69 6f 6e 29 29 29 ised " action)))
64b0: 0a 09 09 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 ... (for-each...
64c0: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 (lambda (test)
64d0: 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 ... (let* ((i
64e0: 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 tem-path (db:tes
64f0: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
6500: 74 65 73 74 29 29 0a 09 09 09 20 20 20 28 74 65 test)).... (te
6510: 73 74 2d 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 st-name (db:test
6520: 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 -get-testname te
6530: 73 74 29 29 0a 09 09 09 20 20 20 28 72 75 6e 2d st)).... (run-
6540: 64 69 72 20 20 20 28 64 62 3a 74 65 73 74 2d 67 dir (db:test-g
6550: 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 29 29 et-rundir test))
6560: 20 20 20 20 3b 3b 20 72 75 6e 20 64 69 72 20 69 ;; run dir i
6570: 73 20 66 72 6f 6d 20 74 68 65 20 6c 69 6e 6b 20 s from the link
6580: 74 72 65 65 0a 09 09 09 20 20 20 28 72 65 61 6c tree.... (real
6590: 2d 64 69 72 20 20 28 69 66 20 28 66 69 6c 65 2d -dir (if (file-
65a0: 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 69 72 29 exists? run-dir)
65b0: 0a 09 09 09 09 09 20 20 28 72 65 73 6f 6c 76 65 ...... (resolve
65c0: 2d 70 61 74 68 6e 61 6d 65 20 72 75 6e 2d 64 69 -pathname run-di
65d0: 72 29 0a 09 09 09 09 09 20 20 23 66 29 29 0a 09 r)...... #f))..
65e0: 09 09 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 .. (test-id
65f0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 (db:test-get-id
6600: 74 65 73 74 29 29 29 0a 09 09 20 20 20 20 20 20 test)))...
6610: 3b 3b 20 20 20 28 74 64 62 20 20 20 20 20 20 20 ;; (tdb
6620: 28 64 62 3a 6f 70 65 6e 2d 74 65 73 74 2d 64 62 (db:open-test-db
6630: 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 20 20 run-dir)))...
6640: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6650: 2d 69 6e 66 6f 20 34 20 22 74 65 73 74 3d 22 20 -info 4 "test="
6660: 74 65 73 74 29 20 3b 3b 20 20 20 22 20 28 64 62 test) ;; " (db
6670: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
6680: 6d 65 20 74 65 73 74 29 20 22 20 69 64 3a 20 22 me test) " id: "
6690: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
66a0: 20 74 65 73 74 29 20 22 20 22 20 69 74 65 6d 2d test) " " item-
66b0: 70 61 74 68 20 22 20 61 63 74 69 6f 6e 3a 20 22 path " action: "
66c0: 20 61 63 74 69 6f 6e 29 0a 09 09 20 20 20 20 20 action)...
66d0: 20 28 63 61 73 65 20 61 63 74 69 6f 6e 0a 09 09 (case action...
66e0: 09 28 28 72 65 6d 6f 76 65 2d 72 75 6e 73 29 20 .((remove-runs)
66f0: 3b 3b 20 74 68 65 20 74 64 62 20 69 73 20 66 6f ;; the tdb is fo
6700: 72 20 66 75 74 75 72 65 20 70 6f 73 73 69 62 6c r future possibl
6710: 65 2e 20 0a 09 09 09 20 28 6f 70 65 6e 2d 72 75 e. .... (open-ru
6720: 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 74 n-close db:delet
6730: 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 e-test-records d
6740: 62 20 23 66 20 28 64 62 3a 74 65 73 74 2d 67 65 b #f (db:test-ge
6750: 74 2d 69 64 20 74 65 73 74 29 29 0a 09 09 09 20 t-id test))....
6760: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6770: 6f 20 31 20 22 41 74 74 65 6d 70 74 69 6e 67 20 o 1 "Attempting
6780: 74 6f 20 72 65 6d 6f 76 65 20 22 20 28 69 66 20 to remove " (if
6790: 72 65 61 6c 2d 64 69 72 20 28 63 6f 6e 63 20 22 real-dir (conc "
67a0: 20 64 69 72 20 22 20 72 65 61 6c 2d 64 69 72 20 dir " real-dir
67b0: 22 20 61 6e 64 20 22 29 20 22 22 29 20 22 20 6c " and ") "") " l
67c0: 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 ink " run-dir)..
67d0: 09 09 20 28 69 66 20 28 61 6e 64 20 72 65 61 6c .. (if (and real
67e0: 2d 64 69 72 20 0a 09 09 09 09 20 20 28 3e 20 28 -dir ..... (> (
67f0: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 72 65 string-length re
6800: 61 6c 2d 64 69 72 29 20 35 29 0a 09 09 09 09 20 al-dir) 5).....
6810: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 (file-exists? r
6820: 65 61 6c 2d 64 69 72 29 29 20 3b 3b 20 62 61 64 eal-dir)) ;; bad
6830: 20 68 65 75 72 69 73 74 69 63 20 62 75 74 20 73 heuristic but s
6840: 68 6f 75 6c 64 20 70 72 65 76 65 6e 74 20 2f 74 hould prevent /t
6850: 6d 70 20 2f 68 6f 6d 65 20 65 74 63 2e 0a 09 09 mp /home etc....
6860: 09 20 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 . (begin ;;
6870: 6c 65 74 2a 20 28 28 72 65 61 6c 70 61 74 68 20 let* ((realpath
6880: 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d (resolve-pathnam
6890: 65 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 e run-dir)))....
68a0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
68b0: 69 6e 74 2d 69 6e 66 6f 20 31 20 22 52 65 63 75 int-info 1 "Recu
68c0: 72 73 69 76 65 6c 79 20 72 65 6d 6f 76 69 6e 67 rsively removing
68d0: 20 22 20 72 65 61 6c 2d 64 69 72 29 0a 09 09 09 " real-dir)....
68e0: 20 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 (if (file
68f0: 2d 65 78 69 73 74 73 3f 20 72 65 61 6c 2d 64 69 -exists? real-di
6900: 72 29 0a 09 09 09 09 20 20 20 28 69 66 20 28 3e r)..... (if (>
6910: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
6920: 72 6d 20 2d 72 66 20 22 20 72 65 61 6c 2d 64 69 rm -rf " real-di
6930: 72 29 29 20 30 29 0a 09 09 09 09 20 20 20 20 20 r)) 0).....
6940: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
6950: 20 22 45 52 52 4f 52 3a 20 54 68 65 72 65 20 77 "ERROR: There w
6960: 61 73 20 61 20 70 72 6f 62 6c 65 6d 20 72 65 6d as a problem rem
6970: 6f 76 69 6e 67 20 22 20 72 65 61 6c 2d 64 69 72 oving " real-dir
6980: 20 22 20 77 69 74 68 20 72 6d 20 2d 66 22 29 29 " with rm -f"))
6990: 0a 09 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 ..... (debug:p
69a0: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING:
69b0: 20 74 65 73 74 20 64 69 72 20 22 20 72 65 61 6c test dir " real
69c0: 2d 64 69 72 20 22 20 61 70 70 65 61 72 73 20 74 -dir " appears t
69d0: 6f 20 6e 6f 74 20 65 78 69 73 74 20 6f 72 20 69 o not exist or i
69e0: 73 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 22 29 s not readable")
69f0: 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 72 )).... (if r
6a00: 65 61 6c 2d 64 69 72 20 0a 09 09 09 09 20 28 64 eal-dir ..... (d
6a10: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 ebug:print 0 "WA
6a20: 52 4e 49 4e 47 3a 20 64 69 72 65 63 74 6f 72 79 RNING: directory
6a30: 20 22 20 72 65 61 6c 2d 64 69 72 20 22 20 64 6f " real-dir " do
6a40: 65 73 20 6e 6f 74 20 65 78 69 73 74 22 29 0a 09 es not exist")..
6a50: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
6a60: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 0 "WARNING: no
6a70: 72 65 61 6c 20 64 69 72 65 63 74 6f 72 79 20 63 real directory c
6a80: 6f 72 72 6f 73 70 6f 6e 64 69 6e 67 20 74 6f 20 orrosponding to
6a90: 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 72 20 22 link " run-dir "
6aa0: 2c 20 6e 6f 74 68 69 6e 67 20 64 6f 6e 65 22 29 , nothing done")
6ab0: 29 29 0a 09 09 09 20 28 69 66 20 28 73 79 6d 62 )).... (if (symb
6ac0: 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 72 75 6e 2d 64 olic-link? run-d
6ad0: 69 72 29 0a 09 09 09 20 20 20 20 20 28 62 65 67 ir).... (beg
6ae0: 69 6e 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 in.... (de
6af0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
6b00: 20 22 52 65 6d 6f 76 69 6e 67 20 73 79 6d 6c 69 "Removing symli
6b10: 6e 6b 20 22 20 72 75 6e 2d 64 69 72 29 0a 09 09 nk " run-dir)...
6b20: 09 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d . (handle-
6b30: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 65 exceptions.....e
6b40: 78 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 xn.....(debug:pr
6b50: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 int 0 "ERROR: F
6b60: 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 ailed to remove
6b70: 73 79 6d 6c 69 6e 6b 20 22 20 72 75 6e 2d 64 69 symlink " run-di
6b80: 72 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 r ((condition-pr
6b90: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
6ba0: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
6bb0: 78 6e 29 20 22 2c 20 61 74 74 65 6d 70 74 69 6e xn) ", attemptin
6bc0: 67 20 74 6f 20 63 6f 6e 74 69 6e 75 65 22 29 0a g to continue").
6bd0: 09 09 09 09 28 64 65 6c 65 74 65 2d 66 69 6c 65 ....(delete-file
6be0: 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 20 run-dir)))....
6bf0: 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f (if (directo
6c00: 72 79 3f 20 72 75 6e 2d 64 69 72 29 0a 09 09 09 ry? run-dir)....
6c10: 09 20 28 69 66 20 28 3e 20 28 64 69 72 65 63 74 . (if (> (direct
6c20: 6f 72 79 2d 66 6f 6c 64 20 28 6c 61 6d 62 64 61 ory-fold (lambda
6c30: 20 28 66 20 78 29 28 2b 20 31 20 78 29 29 20 30 (f x)(+ 1 x)) 0
6c40: 20 72 75 6e 2d 64 69 72 29 20 30 29 0a 09 09 09 run-dir) 0)....
6c50: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
6c60: 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 72 nt 0 "WARNING: r
6c70: 65 66 75 73 69 6e 67 20 74 6f 20 72 65 6d 6f 76 efusing to remov
6c80: 65 20 22 20 72 75 6e 2d 64 69 72 20 22 20 61 73 e " run-dir " as
6c90: 20 69 74 20 69 73 20 6e 6f 74 20 65 6d 70 74 79 it is not empty
6ca0: 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 68 61 ")..... (ha
6cb0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
6cc0: 09 09 09 09 20 20 20 20 20 20 20 65 78 6e 0a 09 .... exn..
6cd0: 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
6ce0: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
6cf0: 20 20 46 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f Failed to remo
6d00: 76 65 20 64 69 72 65 63 74 6f 72 79 20 22 20 72 ve directory " r
6d10: 75 6e 2d 64 69 72 20 28 28 63 6f 6e 64 69 74 69 un-dir ((conditi
6d20: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
6d30: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
6d40: 67 65 29 20 65 78 6e 29 20 22 2c 20 61 74 74 65 ge) exn) ", atte
6d50: 6d 70 74 69 6e 67 20 74 6f 20 63 6f 6e 74 69 6e mpting to contin
6d60: 75 65 22 29 0a 09 09 09 09 20 20 20 20 20 20 20 ue").....
6d70: 28 64 65 6c 65 74 65 2d 64 69 72 65 63 74 6f 72 (delete-director
6d80: 79 20 72 75 6e 2d 64 69 72 29 29 29 0a 09 09 09 y run-dir)))....
6d90: 09 20 28 69 66 20 72 75 6e 2d 64 69 72 0a 09 09 . (if run-dir...
6da0: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
6db0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING:
6dc0: 6e 6f 74 20 72 65 6d 6f 76 69 6e 67 20 22 20 72 not removing " r
6dd0: 75 6e 2d 64 69 72 20 22 20 61 73 20 69 74 20 65 un-dir " as it e
6de0: 69 74 68 65 72 20 64 6f 65 73 6e 27 74 20 65 78 ither doesn't ex
6df0: 69 73 74 20 6f 72 20 69 73 20 6e 6f 74 20 61 20 ist or is not a
6e00: 73 79 6d 6c 69 6e 6b 22 29 0a 09 09 09 09 20 20 symlink").....
6e10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6e20: 30 20 22 4e 4f 54 45 3a 20 74 68 65 20 72 75 6e 0 "NOTE: the run
6e30: 20 64 69 72 20 66 6f 72 20 74 68 69 73 20 74 65 dir for this te
6e40: 73 74 20 69 73 20 75 6e 64 65 66 69 6e 65 64 2e st is undefined.
6e50: 20 54 65 73 74 20 6d 61 79 20 68 61 76 65 20 61 Test may have a
6e60: 6c 72 65 61 64 79 20 62 65 65 6e 20 64 65 6c 65 lready been dele
6e70: 74 65 64 2e 22 29 29 0a 09 09 09 09 20 29 29 29 ted."))..... )))
6e80: 0a 09 09 09 28 28 73 65 74 2d 73 74 61 74 65 2d ....((set-state-
6e90: 73 74 61 74 75 73 29 0a 09 09 09 20 28 64 65 62 status).... (deb
6ea0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2
6eb0: 22 6e 65 77 20 73 74 61 74 65 20 22 20 28 63 61 "new state " (ca
6ec0: 72 20 73 74 61 74 65 2d 73 74 61 74 75 73 29 20 r state-status)
6ed0: 22 2c 20 6e 65 77 20 73 74 61 74 75 73 20 22 20 ", new status "
6ee0: 28 63 61 64 72 20 73 74 61 74 65 2d 73 74 61 74 (cadr state-stat
6ef0: 75 73 29 29 0a 09 09 09 20 28 6f 70 65 6e 2d 72 us)).... (open-r
6f00: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 74 65 73 74 un-close db:test
6f10: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
6f20: 73 2d 62 79 2d 69 64 20 64 62 20 28 64 62 3a 74 s-by-id db (db:t
6f30: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
6f40: 20 28 63 61 72 20 73 74 61 74 65 2d 73 74 61 74 (car state-stat
6f50: 75 73 29 28 63 61 64 72 20 73 74 61 74 65 2d 73 us)(cadr state-s
6f60: 74 61 74 75 73 29 20 23 66 29 29 29 29 29 0a 09 tatus) #f)))))..
6f70: 09 20 20 28 73 6f 72 74 20 74 65 73 74 73 20 28 . (sort tests (
6f80: 6c 61 6d 62 64 61 20 28 61 20 62 29 28 6c 65 74 lambda (a b)(let
6f90: 20 28 28 64 69 72 61 20 28 64 62 3a 74 65 73 74 ((dira (db:test
6fa0: 2d 67 65 74 2d 72 75 6e 64 69 72 20 61 29 29 0a -get-rundir a)).
6fb0: 09 09 09 09 09 09 20 28 64 69 72 62 20 28 64 62 ...... (dirb (db
6fc0: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
6fd0: 20 62 29 29 29 0a 09 09 09 09 09 20 20 20 20 20 b)))......
6fe0: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
6ff0: 3f 20 64 69 72 61 29 28 73 74 72 69 6e 67 3f 20 ? dira)(string?
7000: 64 69 72 62 29 29 0a 09 09 09 09 09 09 20 28 3e dirb))....... (>
7010: 20 28 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 (string-length
7020: 64 69 72 61 29 28 73 74 72 69 6e 67 2d 6c 65 6e dira)(string-len
7030: 67 74 68 20 64 69 72 62 29 29 0a 09 09 09 09 09 gth dirb))......
7040: 09 20 23 66 29 29 29 29 29 29 29 0a 09 20 20 20 . #f)))))))..
7050: 3b 3b 20 72 65 6d 6f 76 65 20 74 68 65 20 72 75 ;; remove the ru
7060: 6e 20 69 66 20 7a 65 72 6f 20 74 65 73 74 73 20 n if zero tests
7070: 72 65 6d 61 69 6e 0a 09 20 20 20 28 69 66 20 28 remain.. (if (
7080: 65 71 3f 20 61 63 74 69 6f 6e 20 27 72 65 6d 6f eq? action 'remo
7090: 76 65 2d 72 75 6e 73 29 0a 09 20 20 20 20 20 20 ve-runs)..
70a0: 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 (let ((remtests
70b0: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
70c0: 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f db:get-tests-fo
70d0: 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 74 r-run db (db:get
70e0: 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 -value-by-header
70f0: 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 22 run header "id"
7100: 29 20 23 66 20 27 28 22 44 45 4c 45 54 45 44 22 ) #f '("DELETED"
7110: 29 20 27 28 22 6e 2f 61 22 29 20 6e 6f 74 2d 69 ) '("n/a") not-i
7120: 6e 3a 20 23 74 29 29 29 0a 09 09 20 28 69 66 20 n: #t)))... (if
7130: 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 (null? remtests)
7140: 20 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 ;; no more test
7150: 73 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 20 s remaining...
7160: 20 20 20 28 6c 65 74 2a 20 28 28 64 70 61 72 74 (let* ((dpart
7170: 73 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 s (string-split
7180: 20 6c 61 73 74 74 70 61 74 68 20 22 2f 22 29 29 lasttpath "/"))
7190: 0a 09 09 09 20 20 20 20 28 72 75 6e 70 61 74 68 .... (runpath
71a0: 20 28 63 6f 6e 63 20 22 2f 22 20 28 73 74 72 69 (conc "/" (stri
71b0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
71c0: 09 09 09 09 09 09 28 74 61 6b 65 20 64 70 61 72 ......(take dpar
71d0: 74 73 20 28 2d 20 28 6c 65 6e 67 74 68 20 64 70 ts (- (length dp
71e0: 61 72 74 73 29 20 31 29 29 0a 09 09 09 09 09 09 arts) 1)).......
71f0: 22 2f 22 29 29 29 29 0a 09 09 20 20 20 20 20 20 "/"))))...
7200: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
7210: 22 52 65 6d 6f 76 69 6e 67 20 72 75 6e 3a 20 22 "Removing run: "
7220: 20 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a runkey " " (db:
7230: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea
7240: 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 der run header "
7250: 72 75 6e 6e 61 6d 65 22 29 20 22 20 61 6e 64 20 runname") " and
7260: 72 65 6c 61 74 65 64 20 72 65 63 6f 72 64 22 29 related record")
7270: 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e 2d ... (open-
7280: 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c run-close db:del
7290: 65 74 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 ete-run db run-i
72a0: 64 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 54 d)... ;; T
72b0: 68 69 73 20 69 73 20 61 20 70 72 65 74 74 79 20 his is a pretty
72c0: 67 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 70 75 good place to pu
72d0: 72 67 65 20 6f 6c 64 20 44 45 4c 45 54 45 44 20 rge old DELETED
72e0: 74 65 73 74 73 0a 09 09 20 20 20 20 20 20 20 28 tests... (
72f0: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
7300: 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 73 2d 66 b:delete-tests-f
7310: 6f 72 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 64 or-run db run-id
7320: 29 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e )... (open
7330: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 -run-close db:de
7340: 6c 65 74 65 2d 6f 6c 64 2d 64 65 6c 65 74 65 64 lete-old-deleted
7350: 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 20 64 62 -test-records db
7360: 29 0a 09 09 20 20 20 20 20 20 20 28 6f 70 65 6e )... (open
7370: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 73 65 -run-close db:se
7380: 74 2d 76 61 72 20 64 62 20 22 44 45 4c 45 54 45 t-var db "DELETE
7390: 44 5f 54 45 53 54 53 22 20 28 63 75 72 72 65 6e D_TESTS" (curren
73a0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 t-seconds))...
73b0: 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 ;; need to
73c0: 66 69 67 75 72 65 20 6f 75 74 20 74 68 65 20 70 figure out the p
73d0: 61 74 68 20 74 6f 20 74 68 65 20 72 75 6e 20 64 ath to the run d
73e0: 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 20 69 74 ir and remove it
73f0: 20 69 66 20 65 6d 70 74 79 0a 09 09 20 20 20 20 if empty...
7400: 20 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 ;; (if (nu
7410: 6c 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 ll? (glob (conc
7420: 72 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a runpath "/*"))).
7430: 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 .. ;;
7440: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
7450: 20 20 20 3b 3b 20 09 20 28 64 65 62 75 67 3a 70 ;; . (debug:p
7460: 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 rint 1 "Removing
7470: 20 72 75 6e 20 64 69 72 20 22 20 72 75 6e 70 61 run dir " runpa
7480: 74 68 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 th)... ;;
7490: 09 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 . (system (conc
74a0: 22 72 6d 64 69 72 20 2d 70 20 22 20 72 75 6e 70 "rmdir -p " runp
74b0: 61 74 68 29 29 29 29 0a 09 09 20 20 20 20 20 20 ath))))...
74c0: 20 29 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 ))))).. )).
74d0: 20 72 75 6e 73 29 29 0a 20 20 23 74 29 0a 0a 3b runs)). #t)..;
74e0: 3b 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 3d 0a 3b 3b 20 52 6f 75 74 69 =======.;; Routi
7530: 6e 65 73 20 66 6f 72 20 6d 61 6e 69 70 75 6c 61 nes for manipula
7540: 74 69 6e 67 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d ting 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 3d 0a 0a 3b 3b 20 53 69 6e 63 65 20 6d 61 6e ==..;; Since man
75a0: 79 20 63 61 6c 6c 73 20 74 6f 20 61 20 72 75 6e y calls to a run
75b0: 20 72 65 71 75 69 72 65 20 70 72 65 74 74 79 20 require pretty
75c0: 6d 75 63 68 20 74 68 65 20 73 61 6d 65 20 73 65 much the same se
75d0: 74 75 70 20 0a 3b 3b 20 74 68 69 73 20 77 72 61 tup .;; this wra
75e0: 70 70 65 72 20 69 73 20 75 73 65 64 20 74 6f 20 pper is used to
75f0: 72 65 64 75 63 65 20 74 68 65 20 72 65 70 6c 69 reduce the repli
7600: 63 61 74 69 6f 6e 20 6f 66 20 63 6f 64 65 0a 28 cation of code.(
7610: 64 65 66 69 6e 65 20 28 67 65 6e 65 72 61 6c 2d define (general-
7620: 72 75 6e 2d 63 61 6c 6c 20 73 77 69 74 63 68 6e run-call switchn
7630: 61 6d 65 20 61 63 74 69 6f 6e 2d 64 65 73 63 20 ame action-desc
7640: 70 72 6f 63 29 0a 20 20 28 6c 65 74 20 28 28 72 proc). (let ((r
7650: 75 6e 6e 61 6d 65 20 28 61 72 67 73 3a 67 65 74 unname (args:get
7660: 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 -arg ":runname")
7670: 29 0a 09 28 74 61 72 67 65 74 20 20 28 69 66 20 )..(target (if
7680: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7690: 74 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 target")...
76a0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
76b0: 74 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 target")...
76c0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
76d0: 72 65 71 74 61 72 67 22 29 29 29 29 0a 09 3b 3b reqtarg"))))..;;
76e0: 20 28 74 68 31 20 20 20 20 20 23 66 29 29 0a 20 (th1 #f)).
76f0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
7700: 6e 6f 74 20 74 61 72 67 65 74 29 0a 20 20 20 20 not target).
7710: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
7720: 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 6e 67 "ERROR: Missing
7730: 20 72 65 71 75 69 72 65 64 20 70 61 72 61 6d 65 required parame
7740: 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 63 68 ter for " switch
7750: 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 73 74 name ", you must
7760: 20 73 70 65 63 69 66 79 20 74 68 65 20 74 61 72 specify the tar
7770: 67 65 74 20 77 69 74 68 20 2d 74 61 72 67 65 74 get with -target
7780: 22 29 0a 20 20 20 20 20 20 28 65 78 69 74 20 33 "). (exit 3
7790: 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 72 75 )). ((not ru
77a0: 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 64 65 nname). (de
77b0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 bug:print 0 "ERR
77c0: 4f 52 3a 20 4d 69 73 73 69 6e 67 20 72 65 71 75 OR: Missing requ
77d0: 69 72 65 64 20 70 61 72 61 6d 65 74 65 72 20 66 ired parameter f
77e0: 6f 72 20 22 20 73 77 69 74 63 68 6e 61 6d 65 20 or " switchname
77f0: 22 2c 20 79 6f 75 20 6d 75 73 74 20 73 70 65 63 ", you must spec
7800: 69 66 79 20 74 68 65 20 72 75 6e 20 6e 61 6d 65 ify the run name
7810: 20 77 69 74 68 20 3a 72 75 6e 6e 61 6d 65 20 72 with :runname r
7820: 75 6e 6e 61 6d 65 22 29 0a 20 20 20 20 20 20 28 unname"). (
7830: 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 65 exit 3)). (e
7840: 6c 73 65 0a 20 20 20 20 20 20 28 6c 65 74 20 28 lse. (let (
7850: 28 64 62 20 20 20 23 66 29 0a 09 20 20 20 20 28 (db #f).. (
7860: 6b 65 79 73 20 23 66 29 0a 09 20 20 20 20 28 74 keys #f).. (t
7870: 61 72 67 65 74 20 28 6f 72 20 28 61 72 67 73 3a arget (or (args:
7880: 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 get-arg "-reqtar
7890: 67 22 29 0a 09 09 09 28 61 72 67 73 3a 67 65 74 g")....(args:get
78a0: 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 29 -arg "-target"))
78b0: 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 ))..(if (not (se
78c0: 74 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 tup-for-run))..
78d0: 20 20 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 (begin ..
78e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
78f0: 20 22 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 "Failed to setu
7900: 70 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 p, exiting")..
7910: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 (exit 1)))..
7920: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar
7930: 67 20 22 2d 73 65 72 76 65 72 22 29 0a 09 20 20 g "-server")..
7940: 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 (open-run-clos
7950: 65 20 73 65 72 76 65 72 3a 73 74 61 72 74 20 64 e server:start d
7960: 62 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 b (args:get-arg
7970: 22 2d 73 65 72 76 65 72 22 29 29 29 0a 09 28 73 "-server")))..(s
7980: 65 74 21 20 6b 65 79 73 20 28 6b 65 79 73 3a 63 et! keys (keys:c
7990: 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 onfig-get-fields
79a0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 29 0a 09 *configdat*))..
79b0: 3b 3b 20 68 61 76 65 20 65 6e 6f 75 67 68 20 74 ;; have enough t
79c0: 6f 20 70 72 6f 63 65 73 73 20 2d 74 61 72 67 65 o process -targe
79d0: 74 20 6f 72 20 2d 72 65 71 74 61 72 67 20 68 65 t or -reqtarg he
79e0: 72 65 0a 09 28 69 66 20 28 61 72 67 73 3a 67 65 re..(if (args:ge
79f0: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
7a00: 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 72 ).. (let* ((r
7a10: 75 6e 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 unconfigf (conc
7a20: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
7a30: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
7a40: 29 20 3b 3b 20 44 4f 20 4e 4f 54 20 45 56 41 4c ) ;; DO NOT EVAL
7a50: 55 41 54 45 20 41 4c 4c 20 0a 09 09 20 20 20 28 UATE ALL ... (
7a60: 72 75 6e 63 6f 6e 66 69 67 20 20 28 72 65 61 64 runconfig (read
7a70: 2d 63 6f 6e 66 69 67 20 72 75 6e 63 6f 6e 66 69 -config runconfi
7a80: 67 66 20 23 66 20 23 74 20 65 6e 76 69 72 6f 6e gf #f #t environ
7a90: 2d 70 61 74 74 3a 20 23 66 29 29 29 20 0a 09 20 -patt: #f))) ..
7aa0: 20 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 (if (hash-t
7ab0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7ac0: 20 72 75 6e 63 6f 6e 66 69 67 20 28 61 72 67 73 runconfig (args
7ad0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
7ae0: 72 67 22 29 20 23 66 29 0a 09 09 20 20 28 6b 65 rg") #f)... (ke
7af0: 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 72 ys:target-set-ar
7b00: 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 65 gs keys (args:ge
7b10: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
7b20: 29 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 ) args:arg-hash)
7b30: 0a 09 09 20 20 20 20 0a 09 09 20 20 28 62 65 67 ... ... (beg
7b40: 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a in... (debug:
7b50: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
7b60: 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 [" (args:get-arg
7b70: 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 "-reqtarg") "]
7b80: 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 not found in " r
7b90: 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 unconfigf)...
7ba0: 20 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 (if db (sqlite3
7bb0: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a :finalize! db)).
7bc0: 09 09 20 20 20 20 28 65 78 69 74 20 31 29 29 29 .. (exit 1)))
7bd0: 29 0a 09 20 20 20 20 28 69 66 20 28 61 72 67 73 ).. (if (args
7be0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
7bf0: 74 22 29 0a 09 09 28 6b 65 79 73 3a 74 61 72 67 t")...(keys:targ
7c00: 65 74 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 et-set-args keys
7c10: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7c20: 2d 74 61 72 67 65 74 22 20 61 72 67 73 3a 61 72 -target" args:ar
7c30: 67 2d 68 61 73 68 29 20 61 72 67 73 3a 61 72 67 g-hash) args:arg
7c40: 2d 68 61 73 68 29 29 29 0a 09 28 69 66 20 28 6e -hash)))..(if (n
7c50: 6f 74 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 ot (car *configi
7c60: 6e 66 6f 2a 29 29 0a 09 20 20 20 20 28 62 65 67 nfo*)).. (beg
7c70: 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 in.. (debug
7c80: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR:
7c90: 20 41 74 74 65 6d 70 74 65 64 20 74 6f 20 22 20 Attempted to "
7ca0: 61 63 74 69 6f 6e 2d 64 65 73 63 20 22 20 62 75 action-desc " bu
7cb0: 74 20 72 75 6e 20 61 72 65 61 20 63 6f 6e 66 69 t run area confi
7cc0: 67 20 66 69 6c 65 20 6e 6f 74 20 66 6f 75 6e 64 g file not found
7cd0: 22 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 ").. (exit
7ce0: 31 29 29 0a 09 20 20 20 20 3b 3b 20 45 78 74 72 1)).. ;; Extr
7cf0: 61 63 74 20 6f 75 74 20 73 74 75 66 66 20 6e 65 act out stuff ne
7d00: 65 64 65 64 20 69 6e 20 6d 6f 73 74 20 6f 72 20 eded in most or
7d10: 6d 61 6e 79 20 63 61 6c 6c 73 0a 09 20 20 20 20 many calls..
7d20: 3b 3b 20 68 65 72 65 20 74 68 65 6e 20 63 61 6c ;; here then cal
7d30: 6c 20 70 72 6f 63 0a 09 20 20 20 20 28 6c 65 74 l proc.. (let
7d40: 2a 20 28 28 6b 65 79 76 61 6c 73 20 20 20 20 28 * ((keyvals (
7d50: 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 keys:target->key
7d60: 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 val keys target)
7d70: 29 29 0a 09 20 20 20 20 20 20 28 70 72 6f 63 20 )).. (proc
7d80: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b target runname k
7d90: 65 79 73 20 6b 65 79 76 61 6c 73 29 29 29 0a 09 eys keyvals)))..
7da0: 28 69 66 20 64 62 20 28 73 71 6c 69 74 65 33 3a (if db (sqlite3:
7db0: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 29 0a 09 finalize! db))..
7dc0: 28 73 65 74 21 20 2a 64 69 64 73 6f 6d 65 74 68 (set! *didsometh
7dd0: 69 6e 67 2a 20 23 74 29 29 29 29 29 29 0a 0a 3b ing* #t))))))..;
7de0: 3b 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 3d 0a 3b 3b 20 4c 6f 63 6b 2f =======.;; Lock/
7e30: 75 6e 6c 6f 63 6b 20 72 75 6e 73 0a 3b 3b 3d 3d unlock 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 3d 0a 0a 28 64 65 66 69 6e 65 20 28 72 ====..(define (r
7e90: 75 6e 73 3a 68 61 6e 64 6c 65 2d 6c 6f 63 6b 69 uns:handle-locki
7ea0: 6e 67 20 74 61 72 67 65 74 20 6b 65 79 73 20 72 ng target keys r
7eb0: 75 6e 6e 61 6d 65 20 6c 6f 63 6b 20 75 6e 6c 6f unname lock unlo
7ec0: 63 6b 20 75 73 65 72 29 0a 20 20 28 6c 65 74 2a ck user). (let*
7ed0: 20 28 28 64 62 20 20 20 20 20 20 20 23 66 29 0a ((db #f).
7ee0: 09 20 28 72 75 6e 64 61 74 20 20 20 28 6f 70 65 . (rundat (ope
7ef0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 72 75 6e 73 n-run-close runs
7f00: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
7f10: 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e 61 6d t db keys runnam
7f20: 65 20 74 61 72 67 65 74 29 29 0a 09 20 28 68 65 e target)).. (he
7f30: 61 64 65 72 20 20 20 28 76 65 63 74 6f 72 2d 72 ader (vector-r
7f40: 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a 09 20 ef rundat 0))..
7f50: 28 72 75 6e 73 20 20 20 20 20 28 76 65 63 74 6f (runs (vecto
7f60: 72 2d 72 65 66 20 72 75 6e 64 61 74 20 31 29 29 r-ref rundat 1))
7f70: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
7f80: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 09 09 (lambda (run)...
7f90: 28 6c 65 74 20 28 28 72 75 6e 2d 69 64 20 28 64 (let ((run-id (d
7fa0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
7fb0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
7fc0: 20 22 69 64 22 29 29 29 0a 09 09 20 20 28 69 66 "id")))... (if
7fd0: 20 28 6f 72 20 6c 6f 63 6b 0a 09 09 09 20 20 28 (or lock.... (
7fe0: 61 6e 64 20 75 6e 6c 6f 63 6b 0a 09 09 09 20 20 and unlock....
7ff0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
8000: 20 28 70 72 69 6e 74 20 22 44 6f 20 79 6f 75 20 (print "Do you
8010: 72 65 61 6c 6c 79 20 77 69 73 68 20 74 6f 20 75 really wish to u
8020: 6e 6c 6f 63 6b 20 72 75 6e 20 22 20 72 75 6e 2d nlock run " run-
8030: 69 64 20 22 3f 5c 6e 20 20 20 79 2f 6e 3a 20 22 id "?\n y/n: "
8040: 29 0a 09 09 09 09 20 28 65 71 75 61 6c 3f 20 22 )..... (equal? "
8050: 79 22 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 y" (read-line)))
8060: 29 29 0a 09 09 20 20 20 20 20 20 28 6f 70 65 6e ))... (open
8070: 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 6c 6f -run-close db:lo
8080: 63 6b 2f 75 6e 6c 6f 63 6b 2d 72 75 6e 20 64 62 ck/unlock-run db
8090: 20 72 75 6e 2d 69 64 20 6c 6f 63 6b 20 75 6e 6c run-id lock unl
80a0: 6f 63 6b 20 75 73 65 72 29 0a 09 09 20 20 20 20 ock user)...
80b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
80c0: 6e 66 6f 20 30 20 22 53 6b 69 70 70 69 6e 67 20 nfo 0 "Skipping
80d0: 6c 6f 63 6b 2f 75 6e 6c 6f 63 6b 20 6f 6e 20 22 lock/unlock on "
80e0: 20 72 75 6e 2d 69 64 29 29 29 29 0a 09 20 20 20 run-id))))..
80f0: 20 20 20 72 75 6e 73 29 29 29 0a 3b 3b 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 3d 0a 3b 3b 20 52 6f 6c 6c 75 70 20 72 75 ===.;; Rollup ru
8150: 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ns.;;===========
8160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
81a0: 55 70 64 61 74 65 20 74 68 65 20 74 65 73 74 5f Update the test_
81b0: 6d 65 74 61 20 74 61 62 6c 65 20 66 6f 72 20 74 meta table for t
81c0: 68 69 73 20 74 65 73 74 0a 28 64 65 66 69 6e 65 his test.(define
81d0: 20 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 (runs:update-te
81e0: 73 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d st_meta test-nam
81f0: 65 20 74 65 73 74 2d 63 6f 6e 66 29 0a 20 20 28 e test-conf). (
8200: 6c 65 74 20 28 28 63 75 72 72 72 65 63 6f 72 64 let ((currrecord
8210: 20 28 63 64 62 3a 72 65 6d 6f 74 65 2d 72 75 6e (cdb:remote-run
8220: 20 64 62 3a 74 65 73 74 6d 65 74 61 2d 67 65 74 db:testmeta-get
8230: 2d 72 65 63 6f 72 64 20 23 66 20 74 65 73 74 2d -record #f test-
8240: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 69 66 20 name))). (if
8250: 28 6e 6f 74 20 63 75 72 72 72 65 63 6f 72 64 29 (not currrecord)
8260: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 ..(begin.. (set
8270: 21 20 63 75 72 72 72 65 63 6f 72 64 20 28 6d 61 ! currrecord (ma
8280: 6b 65 2d 76 65 63 74 6f 72 20 31 30 20 23 66 29 ke-vector 10 #f)
8290: 29 0a 09 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 ).. (cdb:remote
82a0: 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 -run db:testmeta
82b0: 2d 61 64 64 2d 72 65 63 6f 72 64 20 23 66 20 74 -add-record #f t
82c0: 65 73 74 2d 6e 61 6d 65 29 29 29 0a 20 20 20 20 est-name))).
82d0: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
82e0: 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 (lambda (key).
82f0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 64 78 (let* ((idx
8300: 20 28 63 61 64 72 20 6b 65 79 29 29 0a 09 20 20 (cadr key))..
8310: 20 20 20 20 28 66 6c 64 20 28 63 61 72 20 20 6b (fld (car k
8320: 65 79 29 29 0a 09 20 20 20 20 20 20 28 76 61 6c ey)).. (val
8330: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
8340: 74 65 73 74 2d 63 6f 6e 66 20 22 74 65 73 74 5f test-conf "test_
8350: 6d 65 74 61 22 20 66 6c 64 29 29 29 0a 09 20 3b meta" fld))).. ;
8360: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 35 ; (debug:print 5
8370: 20 22 69 64 78 3a 20 22 20 69 64 78 20 22 20 66 "idx: " idx " f
8380: 6c 64 3a 20 22 20 66 6c 64 20 22 20 76 61 6c 3a ld: " fld " val:
8390: 20 22 20 76 61 6c 29 0a 09 20 28 69 66 20 28 61 " val).. (if (a
83a0: 6e 64 20 76 61 6c 20 28 6e 6f 74 20 28 65 71 75 nd val (not (equ
83b0: 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 al? (vector-ref
83c0: 63 75 72 72 72 65 63 6f 72 64 20 69 64 78 29 20 currrecord idx)
83d0: 76 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 val))).. (be
83e0: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 70 72 69 gin.. (pri
83f0: 6e 74 20 22 55 70 64 61 74 69 6e 67 20 22 20 74 nt "Updating " t
8400: 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 66 6c 64 est-name " " fld
8410: 20 22 20 74 6f 20 22 20 76 61 6c 29 0a 09 20 20 " to " val)..
8420: 20 20 20 20 20 28 63 64 62 3a 72 65 6d 6f 74 65 (cdb:remote
8430: 2d 72 75 6e 20 64 62 3a 74 65 73 74 6d 65 74 61 -run db:testmeta
8440: 2d 75 70 64 61 74 65 2d 66 69 65 6c 64 20 23 66 -update-field #f
8450: 20 74 65 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 test-name fld v
8460: 61 6c 29 29 29 29 29 0a 20 20 20 20 20 27 28 28 al))))). '((
8470: 22 61 75 74 68 6f 72 22 20 32 29 28 22 6f 77 6e "author" 2)("own
8480: 65 72 22 20 33 29 28 22 64 65 73 63 72 69 70 74 er" 3)("descript
8490: 69 6f 6e 22 20 34 29 28 22 72 65 76 69 65 77 65 ion" 4)("reviewe
84a0: 64 22 20 35 29 28 22 74 61 67 73 22 20 39 29 29 d" 5)("tags" 9))
84b0: 29 29 29 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 )))..;; Update t
84c0: 65 73 74 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c est_meta for all
84d0: 20 74 65 73 74 73 0a 28 64 65 66 69 6e 65 20 28 tests.(define (
84e0: 72 75 6e 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d runs:update-all-
84f0: 74 65 73 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 test_meta db).
8500: 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 (let ((test-name
8510: 73 20 28 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c s (get-all-legal
8520: 2d 74 65 73 74 73 29 29 29 0a 20 20 20 20 28 66 -tests))). (f
8530: 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c or-each . (l
8540: 61 6d 62 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 ambda (test-name
8550: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
8560: 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 28 63 (test-path (c
8570: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
8580: 74 65 73 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d tests/" test-nam
8590: 65 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 e)).. (test
85a0: 2d 63 6f 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 -configf (conc t
85b0: 65 73 74 2d 70 61 74 68 20 22 2f 74 65 73 74 63 est-path "/testc
85c0: 6f 6e 66 69 67 22 29 29 0a 09 20 20 20 20 20 20 onfig"))..
85d0: 28 74 65 73 74 65 78 69 73 74 73 20 20 20 28 61 (testexists (a
85e0: 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f nd (file-exists?
85f0: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 test-configf)(f
8600: 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f ile-read-access?
8610: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 test-configf)))
8620: 0a 09 20 20 20 20 20 20 3b 3b 20 72 65 61 64 20 .. ;; read
8630: 63 6f 6e 66 69 67 73 20 77 69 74 68 20 74 72 69 configs with tri
8640: 63 6b 73 20 74 75 72 6e 65 64 20 6f 66 66 20 28 cks turned off (
8650: 69 2e 65 2e 20 6e 6f 20 73 79 73 74 65 6d 29 0a i.e. no system).
8660: 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f 6e . (test-con
8670: 66 20 20 20 20 28 69 66 20 74 65 73 74 65 78 69 f (if testexi
8680: 73 74 73 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 sts (read-config
8690: 20 74 65 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 test-configf #f
86a0: 20 23 66 29 28 6d 61 6b 65 2d 68 61 73 68 2d 74 #f)(make-hash-t
86b0: 61 62 6c 65 29 29 29 29 0a 09 20 3b 3b 20 75 73 able)))).. ;; us
86c0: 65 20 74 68 65 20 6f 70 65 6e 2d 72 75 6e 2d 63 e the open-run-c
86d0: 6c 6f 73 65 20 69 6e 73 74 65 61 64 20 6f 66 20 lose instead of
86e0: 70 61 73 73 69 6e 67 20 69 6e 20 64 62 0a 09 20 passing in db..
86f0: 28 72 75 6e 73 3a 75 70 64 61 74 65 2d 74 65 73 (runs:update-tes
8700: 74 5f 6d 65 74 61 20 74 65 73 74 2d 6e 61 6d 65 t_meta test-name
8710: 20 74 65 73 74 2d 63 6f 6e 66 29 29 29 0a 20 20 test-conf))).
8720: 20 20 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 29 test-names)))
8730: 0a 0a 3b 3b 20 54 68 69 73 20 63 6f 75 6c 64 20 ..;; This could
8740: 70 72 6f 62 61 62 6c 79 20 62 65 20 72 65 66 61 probably be refa
8750: 63 74 6f 72 65 64 20 69 6e 74 6f 20 6f 6e 65 20 ctored into one
8760: 63 6f 6d 70 6c 65 78 20 71 75 65 72 79 20 2e 2e complex query ..
8770: 2e 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a ..(define (runs:
8780: 72 6f 6c 6c 75 70 2d 72 75 6e 20 6b 65 79 73 20 rollup-run keys
8790: 72 75 6e 6e 61 6d 65 20 75 73 65 72 20 6b 65 79 runname user key
87a0: 76 61 6c 73 29 0a 20 20 28 64 65 62 75 67 3a 70 vals). (debug:p
87b0: 72 69 6e 74 20 34 20 22 72 75 6e 73 3a 72 6f 6c rint 4 "runs:rol
87c0: 6c 75 70 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 lup-run, keys: "
87d0: 20 6b 65 79 73 20 22 20 3a 72 75 6e 6e 61 6d 65 keys " :runname
87e0: 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 75 73 65 " runname " use
87f0: 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c 65 r: " user). (le
8800: 74 2a 20 28 28 64 62 20 20 20 20 20 20 20 20 20 t* ((db
8810: 20 20 20 20 20 23 66 29 0a 09 20 28 6e 65 77 2d #f).. (new-
8820: 72 75 6e 2d 69 64 20 20 20 20 20 20 28 63 64 62 run-id (cdb
8830: 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a 72 :remote-run db:r
8840: 65 67 69 73 74 65 72 2d 72 75 6e 20 23 66 20 6b egister-run #f k
8850: 65 79 73 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e eys keyvals runn
8860: 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 ame "new" "n/a"
8870: 75 73 65 72 29 29 0a 09 20 28 70 72 65 76 2d 74 user)).. (prev-t
8880: 65 73 74 73 20 20 20 20 20 20 28 6f 70 65 6e 2d ests (open-
8890: 72 75 6e 2d 63 6c 6f 73 65 20 74 65 73 74 3a 67 run-close test:g
88a0: 65 74 2d 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 et-matching-prev
88b0: 69 6f 75 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 ious-test-run-re
88c0: 63 6f 72 64 73 20 64 62 20 6e 65 77 2d 72 75 6e cords db new-run
88d0: 2d 69 64 20 22 25 22 20 22 25 22 29 29 0a 09 20 -id "%" "%"))..
88e0: 28 63 75 72 72 2d 74 65 73 74 73 20 20 20 20 20 (curr-tests
88f0: 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 (open-run-close
8900: 20 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f db:get-tests-fo
8910: 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e r-run db new-run
8920: 2d 69 64 20 22 25 2f 25 22 20 27 28 29 20 27 28 -id "%/%" '() '(
8930: 29 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 74 ))).. (curr-test
8940: 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 73 s-hash (make-has
8950: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 h-table))). (
8960: 6f 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 64 open-run-close d
8970: 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 76 65 b:update-run-eve
8980: 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 2d 72 nt_time db new-r
8990: 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 69 6e un-id). ;; in
89a0: 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 79 20 dex the already
89b0: 73 61 76 65 64 20 74 65 73 74 73 20 62 79 20 74 saved tests by t
89c0: 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 65 6d estname and item
89d0: 64 61 74 20 69 6e 20 63 75 72 72 2d 74 65 73 74 dat in curr-test
89e0: 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f 72 2d s-hash. (for-
89f0: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
8a00: 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 20 20 a (testdat).
8a10: 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 6e (let* ((testn
8a20: 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ame (db:test-ge
8a30: 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 74 64 t-testname testd
8a40: 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 74 65 at)).. (ite
8a50: 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 74 2d m-path (db:test-
8a60: 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 74 65 get-item-path te
8a70: 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 stdat)).. (
8a80: 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e 63 20 full-name (conc
8a90: 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 testname "/" ite
8aa0: 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 61 73 m-path))).. (has
8ab0: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 75 72 h-table-set! cur
8ac0: 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 75 6c r-tests-hash ful
8ad0: 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 l-name testdat))
8ae0: 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 73 74 ). curr-test
8af0: 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 3a 20 s). ;; NOPE:
8b00: 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 70 72 Non-optimal appr
8b10: 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 20 69 oach. Try this i
8b20: 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b 20 20 nstead.. ;;
8b30: 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 72 65 1. tests are re
8b40: 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 73 74 ceived in a list
8b50: 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 66 69 , most recent fi
8b60: 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 2e 20 rst. ;; 2.
8b70: 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f 6c 6c replace the roll
8b80: 75 70 20 74 65 73 74 20 77 69 74 68 20 74 68 65 up test with the
8b90: 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a 20 20 new *always*.
8ba0: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
8bb0: 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 64 (lambda (testd
8bc0: 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a at). (let*
8bd0: 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 64 62 ((testname (db
8be0: 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 6e 61 :test-get-testna
8bf0: 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 20 20 me testdat))..
8c00: 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 20 28 (item-path (
8c10: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
8c20: 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 29 0a -path testdat)).
8c30: 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e 61 6d . (full-nam
8c40: 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d 65 e (conc testname
8c50: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
8c60: 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d 74 65 .. (prev-te
8c70: 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 61 62 st-dat (hash-tab
8c80: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 le-ref/default c
8c90: 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
8ca0: 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a 09 20 ull-name #f))..
8cb0: 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 70 73 (test-steps
8cc0: 20 20 20 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c (open-run-cl
8cd0: 6f 73 65 20 64 62 3a 67 65 74 2d 73 74 65 70 73 ose db:get-steps
8ce0: 2d 66 6f 72 2d 74 65 73 74 20 64 62 20 28 64 62 -for-test db (db
8cf0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
8d00: 74 64 61 74 29 29 29 0a 09 20 20 20 20 20 20 28 tdat))).. (
8d10: 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 20 new-test-record
8d20: 23 66 29 29 0a 09 20 3b 3b 20 72 65 70 6c 61 63 #f)).. ;; replac
8d30: 65 20 74 68 65 73 65 20 77 69 74 68 20 69 6e 73 e these with ins
8d40: 65 72 74 20 2e 2e 2e 20 73 65 6c 65 63 74 0a 09 ert ... select..
8d50: 20 28 61 70 70 6c 79 20 73 71 6c 69 74 65 33 3a (apply sqlite3:
8d60: 65 78 65 63 75 74 65 20 0a 09 09 64 62 20 0a 09 execute ...db ..
8d70: 09 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f .(conc "INSERT O
8d80: 52 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 74 R REPLACE INTO t
8d90: 65 73 74 73 20 28 72 75 6e 5f 69 64 2c 74 65 73 ests (run_id,tes
8da0: 74 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 tname,state,stat
8db0: 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 68 6f us,event_time,ho
8dc0: 73 74 2c 63 70 75 6c 6f 61 64 2c 64 69 73 6b 66 st,cpuload,diskf
8dd0: 72 65 65 2c 75 6e 61 6d 65 2c 72 75 6e 64 69 72 ree,uname,rundir
8de0: 2c 69 74 65 6d 5f 70 61 74 68 2c 72 75 6e 5f 64 ,item_path,run_d
8df0: 75 72 61 74 69 6f 6e 2c 66 69 6e 61 6c 5f 6c 6f uration,final_lo
8e00: 67 66 2c 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 gf,comment) "...
8e10: 20 20 20 20 20 20 22 56 41 4c 55 45 53 20 28 3f "VALUES (?
8e20: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f ,?,?,?,?,?,?,?,?
8e30: 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 ,?,?,?,?,?);")..
8e40: 09 6e 65 77 2d 72 75 6e 2d 69 64 20 28 63 64 64 .new-run-id (cdd
8e50: 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 r (vector->list
8e60: 74 65 73 74 64 61 74 29 29 29 0a 09 20 28 73 65 testdat))).. (se
8e70: 74 21 20 6e 65 77 2d 74 65 73 74 64 61 74 20 28 t! new-testdat (
8e80: 63 61 72 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 6c car (open-run-cl
8e90: 6f 73 65 20 64 62 3a 67 65 74 2d 74 65 73 74 73 ose db:get-tests
8ea0: 2d 66 6f 72 2d 72 75 6e 20 64 62 20 6e 65 77 2d -for-run db new-
8eb0: 72 75 6e 2d 69 64 20 28 63 6f 6e 63 20 74 65 73 run-id (conc tes
8ec0: 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 tname "/" item-p
8ed0: 61 74 68 29 20 27 28 29 20 27 28 29 29 29 29 0a ath) '() '()))).
8ee0: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
8ef0: 74 21 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 t! curr-tests-ha
8f00: 73 68 20 66 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 sh full-name new
8f10: 2d 74 65 73 74 64 61 74 29 20 3b 3b 20 74 68 69 -testdat) ;; thi
8f20: 73 20 63 6f 75 6c 64 20 62 65 20 63 6f 6e 66 75 s could be confu
8f30: 73 69 6e 67 2c 20 77 68 69 63 68 20 72 65 63 6f sing, which reco
8f40: 72 64 20 73 68 6f 75 6c 64 20 67 6f 20 69 6e 74 rd should go int
8f50: 6f 20 74 68 65 20 6c 6f 6f 6b 75 70 20 74 61 62 o the lookup tab
8f60: 6c 65 3f 0a 09 20 3b 3b 20 4e 6f 77 20 64 75 70 le?.. ;; Now dup
8f70: 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 74 20 licate the test
8f80: 73 74 65 70 73 0a 09 20 28 64 65 62 75 67 3a 70 steps.. (debug:p
8f90: 72 69 6e 74 20 34 20 22 43 6f 70 79 69 6e 67 20 rint 4 "Copying
8fa0: 72 65 63 6f 72 64 73 20 69 6e 20 74 65 73 74 5f records in test_
8fb0: 73 74 65 70 73 20 66 72 6f 6d 20 74 65 73 74 5f steps from test_
8fc0: 69 64 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 id=" (db:test-ge
8fd0: 74 2d 69 64 20 74 65 73 74 64 61 74 29 20 22 20 t-id testdat) "
8fe0: 74 6f 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 to " (db:test-ge
8ff0: 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 t-id new-testdat
9000: 29 29 0a 09 20 28 6f 70 65 6e 2d 72 75 6e 2d 63 )).. (open-run-c
9010: 6c 6f 73 65 20 0a 09 20 20 28 6c 61 6d 62 64 61 lose .. (lambda
9020: 20 28 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 ().. (sqlite
9030: 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 20 20 3:execute ..
9040: 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f 6e 63 db .. (conc
9050: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
9060: 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 73 74 ACE INTO test_st
9070: 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 74 65 eps (test_id,ste
9080: 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 61 74 pname,state,stat
9090: 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c 63 6f us,event_time,co
90a0: 6d 6d 65 6e 74 29 20 22 0a 09 09 20 20 20 22 53 mment) "... "S
90b0: 45 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 ELECT " (db:test
90c0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
90d0: 64 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c dat) ",stepname,
90e0: 73 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 state,status,eve
90f0: 6e 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 nt_time,comment
9100: 46 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 FROM test_steps
9110: 57 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b WHERE test_id=?;
9120: 22 29 0a 09 20 20 20 20 20 28 64 62 3a 74 65 73 ").. (db:tes
9130: 74 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 t-get-id testdat
9140: 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 64 )).. ;; Now d
9150: 75 70 6c 69 63 61 74 65 20 74 68 65 20 74 65 73 uplicate the tes
9160: 74 20 64 61 74 61 0a 09 20 20 20 20 28 64 65 62 t data.. (deb
9170: 75 67 3a 70 72 69 6e 74 20 34 20 22 43 6f 70 79 ug:print 4 "Copy
9180: 69 6e 67 20 72 65 63 6f 72 64 73 20 69 6e 20 74 ing records in t
9190: 65 73 74 5f 64 61 74 61 20 66 72 6f 6d 20 74 65 est_data from te
91a0: 73 74 5f 69 64 3d 22 20 28 64 62 3a 74 65 73 74 st_id=" (db:test
91b0: 2d 67 65 74 2d 69 64 20 74 65 73 74 64 61 74 29 -get-id testdat)
91c0: 20 22 20 74 6f 20 22 20 28 64 62 3a 74 65 73 74 " to " (db:test
91d0: 2d 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 -get-id new-test
91e0: 64 61 74 29 29 0a 09 20 20 20 20 28 73 71 6c 69 dat)).. (sqli
91f0: 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 20 20 te3:execute ..
9200: 20 20 20 64 62 20 0a 09 20 20 20 20 20 28 63 6f db .. (co
9210: 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 nc "INSERT OR RE
9220: 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f PLACE INTO test_
9230: 64 61 74 61 20 28 74 65 73 74 5f 69 64 2c 63 61 data (test_id,ca
9240: 74 65 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c tegory,variable,
9250: 76 61 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 value,expected,t
9260: 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 ol,units,comment
9270: 29 20 22 0a 09 09 20 20 20 22 53 45 4c 45 43 54 ) "... "SELECT
9280: 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d " (db:test-get-
9290: 69 64 20 6e 65 77 2d 74 65 73 74 64 61 74 29 20 id new-testdat)
92a0: 22 2c 63 61 74 65 67 6f 72 79 2c 76 61 72 69 61 ",category,varia
92b0: 62 6c 65 2c 76 61 6c 75 65 2c 65 78 70 65 63 74 ble,value,expect
92c0: 65 64 2c 74 6f 6c 2c 75 6e 69 74 73 2c 63 6f 6d ed,tol,units,com
92d0: 6d 65 6e 74 20 46 52 4f 4d 20 74 65 73 74 5f 64 ment FROM test_d
92e0: 61 74 61 20 57 48 45 52 45 20 74 65 73 74 5f 69 ata WHERE test_i
92f0: 64 3d 3f 3b 22 29 0a 09 20 20 20 20 20 28 64 62 d=?;").. (db
9300: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 :test-get-id tes
9310: 74 64 61 74 29 29 29 29 0a 09 20 29 29 0a 20 20 tdat)))).. )).
9320: 20 20 20 70 72 65 76 2d 74 65 73 74 73 29 29 29 prev-tests)))
9330: 0a 09 20 0a 20 20 20 20 20 0a .. . .