0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 31 2c 20 4d 61 74 74 68 65 77 06-2011, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 20 20 73 PURPOSE...;; s
0150: 74 72 66 74 69 6d 65 28 27 25 6d 2f 25 64 2f 25 trftime('%m/%d/%
0160: 59 20 25 48 3a 25 4d 3a 25 53 27 2c 27 6e 6f 77 Y %H:%M:%S','now
0170: 27 2c 27 6c 6f 63 61 6c 74 69 6d 65 27 29 0a 0a ','localtime')..
0180: 28 75 73 65 20 73 71 6c 69 74 65 33 20 73 72 66 (use sqlite3 srf
0190: 69 2d 31 20 70 6f 73 69 78 20 72 65 67 65 78 20 i-1 posix regex
01a0: 72 65 67 65 78 2d 63 61 73 65 20 73 72 66 69 2d regex-case srfi-
01b0: 36 39 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 29 0a 69 dot-locking).
01c0: 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 (import (prefix
01d0: 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a sqlite3 sqlite3:
01e0: 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e ))..(declare (un
01f0: 69 74 20 72 75 6e 73 29 29 0a 28 64 65 63 6c 61 it runs)).(decla
0200: 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 64 re (uses db)).(d
0210: 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d eclare (uses com
0220: 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 mon)).(declare (
0230: 75 73 65 73 20 69 74 65 6d 73 29 29 0a 28 64 65 uses items)).(de
0240: 63 6c 61 72 65 20 28 75 73 65 73 20 72 75 6e 63 clare (uses runc
0250: 6f 6e 66 69 67 29 29 0a 28 64 65 63 6c 61 72 65 onfig)).(declare
0260: 20 28 75 73 65 73 20 74 65 73 74 73 29 29 0a 28 (uses tests)).(
0270: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 65 declare (uses se
0280: 72 76 65 72 29 29 0a 0a 28 69 6e 63 6c 75 64 65 rver))..(include
0290: 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 "common_records
02a0: 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 .scm").(include
02b0: 22 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d "key_records.scm
02c0: 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f ").(include "db_
02d0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
02e0: 6e 63 6c 75 64 65 20 22 72 75 6e 5f 72 65 63 6f nclude "run_reco
02f0: 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 rds.scm").(inclu
0300: 64 65 20 22 74 65 73 74 5f 72 65 63 6f 72 64 73 de "test_records
0310: 2e 73 63 6d 22 29 0a 0a 3b 3b 20 72 75 6e 73 3a .scm")..;; runs:
0320: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
0330: 0a 3b 3b 20 67 65 74 20 72 75 6e 73 20 62 79 20 .;; get runs by
0340: 6c 69 73 74 20 6f 66 20 63 72 69 74 65 72 69 61 list of criteria
0350: 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 74 .;; register a t
0360: 65 73 74 20 72 75 6e 20 77 69 74 68 20 74 68 65 est run with the
0370: 20 64 62 0a 3b 3b 0a 3b 3b 20 55 73 65 3a 20 28 db.;;.;; Use: (
0380: 64 62 2d 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d db-get-value-by-
0390: 68 65 61 64 65 72 20 28 64 62 3a 67 65 74 2d 68 header (db:get-h
03a0: 65 61 64 65 72 20 72 75 6e 69 6e 66 6f 29 28 64 eader runinfo)(d
03b0: 62 3a 67 65 74 2d 72 6f 77 20 72 75 6e 69 6e 66 b:get-row runinf
03c0: 6f 29 29 0a 3b 3b 20 20 74 6f 20 65 78 74 72 61 o)).;; to extra
03d0: 63 74 20 69 6e 66 6f 20 66 72 6f 6d 20 74 68 65 ct info from the
03e0: 20 73 74 72 75 63 74 75 72 65 20 72 65 74 75 72 structure retur
03f0: 6e 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ned.;;.(define (
0400: 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 runs:get-runs-by
0410: 2d 70 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 -patt db keys ru
0420: 6e 6e 61 6d 65 70 61 74 74 20 2e 20 70 61 72 61 nnamepatt . para
0430: 6d 73 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 ms) ;; test-name
0440: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 76 ). (let* ((keyv
0450: 61 6c 6c 73 74 20 28 6b 65 79 73 2d 3e 76 61 6c allst (keys->val
0460: 6c 69 73 74 20 6b 65 79 73 29 29 0a 09 20 28 74 list keys)).. (t
0470: 6d 70 20 20 20 20 20 20 28 72 75 6e 73 3a 67 65 mp (runs:ge
0480: 74 2d 73 74 64 2d 72 75 6e 2d 66 69 65 6c 64 73 t-std-run-fields
0490: 20 6b 65 79 73 20 27 28 22 69 64 22 20 22 72 75 keys '("id" "ru
04a0: 6e 6e 61 6d 65 22 20 22 73 74 61 74 65 22 20 22 nname" "state" "
04b0: 73 74 61 74 75 73 22 20 22 6f 77 6e 65 72 22 20 status" "owner"
04c0: 22 65 76 65 6e 74 5f 74 69 6d 65 22 29 29 29 0a "event_time"))).
04d0: 09 20 28 6b 65 79 73 74 72 20 20 20 28 63 61 72 . (keystr (car
04e0: 20 74 6d 70 29 29 0a 09 20 28 68 65 61 64 65 72 tmp)).. (header
04f0: 20 20 20 28 63 61 64 72 20 74 6d 70 29 29 0a 09 (cadr tmp))..
0500: 20 28 72 65 73 20 20 20 20 20 27 28 29 29 0a 09 (res '())..
0510: 20 28 6b 65 79 2d 70 61 74 74 20 22 22 29 29 0a (key-patt "")).
0520: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
0530: 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 ambda (keyval)..
0540: 09 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 .(let* ((key
0550: 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 65 79 76 (vector-ref keyv
0560: 61 6c 20 30 29 29 0a 09 09 20 20 20 20 20 20 20 al 0))...
0570: 28 66 75 6c 6b 65 79 20 28 63 6f 6e 63 20 22 3a (fulkey (conc ":
0580: 22 20 6b 65 79 29 29 0a 09 09 20 20 20 20 20 20 " key))...
0590: 20 28 70 61 74 74 20 20 20 28 61 72 67 73 3a 67 (patt (args:g
05a0: 65 74 2d 61 72 67 20 66 75 6c 6b 65 79 29 29 29 et-arg fulkey)))
05b0: 0a 09 09 20 20 28 69 66 20 70 61 74 74 0a 09 09 ... (if patt...
05c0: 20 20 20 20 20 20 28 73 65 74 21 20 6b 65 79 2d (set! key-
05d0: 70 61 74 74 20 28 63 6f 6e 63 20 6b 65 79 2d 70 patt (conc key-p
05e0: 61 74 74 20 22 20 41 4e 44 20 22 20 6b 65 79 20 att " AND " key
05f0: 22 20 6c 69 6b 65 20 27 22 20 70 61 74 74 20 22 " like '" patt "
0600: 27 22 29 29 0a 09 09 20 20 20 20 20 20 28 62 65 '"))... (be
0610: 67 69 6e 0a 09 09 09 28 64 65 62 75 67 3a 70 72 gin....(debug:pr
0620: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 73 65 int 0 "ERROR: se
0630: 61 72 63 68 69 6e 67 20 66 6f 72 20 72 75 6e 73 arching for runs
0640: 20 77 69 74 68 20 6e 6f 20 70 61 74 74 65 72 6e with no pattern
0650: 20 73 65 74 20 66 6f 72 20 22 20 66 75 6c 6b 65 set for " fulke
0660: 79 29 0a 09 09 09 28 65 78 69 74 20 36 29 29 29 y)....(exit 6)))
0670: 29 29 0a 09 20 20 20 20 20 20 6b 65 79 73 29 0a )).. keys).
0680: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 6f 72 (sqlite3:for
0690: 2d 65 61 63 68 2d 72 6f 77 20 0a 20 20 20 20 20 -each-row .
06a0: 28 6c 61 6d 62 64 61 20 28 61 20 2e 20 72 29 0a (lambda (a . r).
06b0: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 (set! res
06c0: 20 28 63 6f 6e 73 20 28 6c 69 73 74 2d 3e 76 65 (cons (list->ve
06d0: 63 74 6f 72 20 28 63 6f 6e 73 20 61 20 72 29 29 ctor (cons a r))
06e0: 20 72 65 73 29 29 29 0a 20 20 20 20 20 64 62 20 res))). db
06f0: 0a 20 20 20 20 20 28 63 6f 6e 63 20 22 53 45 4c . (conc "SEL
0700: 45 43 54 20 22 20 6b 65 79 73 74 72 20 22 20 46 ECT " keystr " F
0710: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 72 ROM runs WHERE r
0720: 75 6e 6e 61 6d 65 20 6c 69 6b 65 20 3f 20 22 20 unname like ? "
0730: 6b 65 79 2d 70 61 74 74 20 22 3b 22 29 0a 20 20 key-patt ";").
0740: 20 20 20 72 75 6e 6e 61 6d 65 70 61 74 74 29 0a runnamepatt).
0750: 20 20 20 20 28 76 65 63 74 6f 72 20 68 65 61 64 (vector head
0760: 65 72 20 72 65 73 29 29 29 0a 0a 28 64 65 66 69 er res)))..(defi
0770: 6e 65 20 28 72 75 6e 73 3a 74 65 73 74 2d 67 65 ne (runs:test-ge
0780: 74 2d 66 75 6c 6c 2d 70 61 74 68 20 74 65 73 74 t-full-path test
0790: 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 ). (let* ((test
07a0: 6e 61 6d 65 20 28 64 62 3a 74 65 73 74 2d 67 65 name (db:test-ge
07b0: 74 2d 74 65 73 74 6e 61 6d 65 20 20 20 74 65 73 t-testname tes
07c0: 74 29 29 0a 09 20 28 69 74 65 6d 70 61 74 68 20 t)).. (itempath
07d0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 (db:test-get-ite
07e0: 6d 2d 70 61 74 68 20 74 65 73 74 29 29 29 0a 20 m-path test))).
07f0: 20 20 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 6d (conc testnam
0800: 65 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 e (if (equal? it
0810: 65 6d 70 61 74 68 20 22 22 29 20 22 22 20 28 63 empath "") "" (c
0820: 6f 6e 63 20 22 28 22 20 69 74 65 6d 70 61 74 68 onc "(" itempath
0830: 20 22 29 22 29 29 29 29 29 0a 0a 0a 28 64 65 66 ")")))))...(def
0840: 69 6e 65 20 28 73 65 74 2d 6d 65 67 61 74 65 73 ine (set-megates
0850: 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 75 t-env-vars db ru
0860: 6e 2d 69 64 29 0a 20 20 28 6c 65 74 20 28 28 6b n-id). (let ((k
0870: 65 79 73 20 28 72 64 62 3a 67 65 74 2d 6b 65 79 eys (rdb:get-key
0880: 73 20 64 62 29 29 29 0a 20 20 20 20 28 66 6f 72 s db))). (for
0890: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b -each (lambda (k
08a0: 65 79 29 0a 09 09 28 73 71 6c 69 74 65 33 3a 66 ey)...(sqlite3:f
08b0: 6f 72 2d 65 61 63 68 2d 72 6f 77 0a 09 09 20 28 or-each-row... (
08c0: 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 09 09 20 lambda (val)...
08d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
08e0: 20 22 73 65 74 65 6e 76 20 22 20 28 6b 65 79 3a "setenv " (key:
08f0: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
0900: 79 29 20 22 20 22 20 76 61 6c 29 0a 09 09 20 20 y) " " val)...
0910: 20 28 73 65 74 65 6e 76 20 28 6b 65 79 3a 67 65 (setenv (key:ge
0920: 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 79 29 t-fieldname key)
0930: 20 76 61 6c 29 29 0a 09 09 20 64 62 20 0a 09 09 val))... db ...
0940: 20 28 63 6f 6e 63 20 22 53 45 4c 45 43 54 20 22 (conc "SELECT "
0950: 20 28 6b 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e (key:get-fieldn
0960: 61 6d 65 20 6b 65 79 29 20 22 20 46 52 4f 4d 20 ame key) " FROM
0970: 72 75 6e 73 20 57 48 45 52 45 20 69 64 3d 3f 3b runs WHERE id=?;
0980: 22 29 0a 09 09 20 72 75 6e 2d 69 64 29 29 0a 09 ")... run-id))..
0990: 20 20 20 20 20 20 6b 65 79 73 29 0a 20 20 20 20 keys).
09a0: 3b 3b 20 4c 65 74 73 20 75 73 65 20 74 68 69 73 ;; Lets use this
09b0: 20 61 73 20 61 6e 20 6f 70 70 6f 72 74 75 6e 69 as an opportuni
09c0: 74 79 20 74 6f 20 70 75 74 20 4d 54 5f 52 55 4e ty to put MT_RUN
09d0: 4e 41 4d 45 20 69 6e 20 74 68 65 20 65 6e 76 69 NAME in the envi
09e0: 72 6f 6e 6d 65 6e 74 0a 20 20 20 20 28 73 71 6c ronment. (sql
09f0: 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f ite3:for-each-ro
0a00: 77 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 w. (lambda (
0a10: 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 runname).
0a20: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (setenv "MT_RUNN
0a30: 41 4d 45 22 20 72 75 6e 6e 61 6d 65 29 29 0a 20 AME" runname)).
0a40: 20 20 20 20 64 62 0a 20 20 20 20 20 22 53 45 4c db. "SEL
0a50: 45 43 54 20 72 75 6e 6e 61 6d 65 20 46 52 4f 4d ECT runname FROM
0a60: 20 72 75 6e 73 20 57 48 45 52 45 20 69 64 3d 3f runs WHERE id=?
0a70: 3b 22 0a 20 20 20 20 20 72 75 6e 2d 69 64 29 0a ;". run-id).
0a80: 20 20 20 20 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))..(define
0a90: 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 61 (set-item-env-va
0aa0: 72 73 20 69 74 65 6d 64 61 74 29 0a 20 20 28 66 rs itemdat). (f
0ab0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
0ac0: 28 69 74 65 6d 29 0a 09 20 20 20 20 20 20 28 64 (item).. (d
0ad0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 73 65 ebug:print 2 "se
0ae0: 74 65 6e 76 20 22 20 28 63 61 72 20 69 74 65 6d tenv " (car item
0af0: 29 20 22 20 22 20 28 63 61 64 72 20 69 74 65 6d ) " " (cadr item
0b00: 29 29 0a 09 20 20 20 20 20 20 28 73 65 74 65 6e )).. (seten
0b10: 76 20 28 63 61 72 20 69 74 65 6d 29 20 28 63 61 v (car item) (ca
0b20: 64 72 20 69 74 65 6d 29 29 29 0a 09 20 20 20 20 dr item)))..
0b30: 69 74 65 6d 64 61 74 29 29 0a 0a 28 64 65 66 69 itemdat))..(defi
0b40: 6e 65 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 6e ne (runs:can-run
0b50: 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 20 74 -more-tests db t
0b60: 65 73 74 2d 72 65 63 6f 72 64 29 0a 20 20 28 6c est-record). (l
0b70: 65 74 2a 20 28 28 74 63 6f 6e 66 69 67 20 20 20 et* ((tconfig
0b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
0b90: 65 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 ests:testqueue-g
0ba0: 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 74 65 et-testconfig te
0bb0: 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 20 28 6a st-record)).. (j
0bc0: 6f 62 67 72 6f 75 70 20 20 20 20 20 20 20 20 20 obgroup
0bd0: 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c (config-l
0be0: 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 22 72 ookup tconfig "r
0bf0: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6a 6f equirements" "jo
0c00: 62 67 72 6f 75 70 22 29 29 0a 09 20 28 6e 75 6d bgroup")).. (num
0c10: 2d 72 75 6e 6e 69 6e 67 20 20 20 20 20 20 20 20 -running
0c20: 20 20 20 20 20 28 64 62 3a 67 65 74 2d 63 6f 75 (db:get-cou
0c30: 6e 74 2d 74 65 73 74 73 2d 72 75 6e 6e 69 6e 67 nt-tests-running
0c40: 20 64 62 29 29 0a 09 20 28 6e 75 6d 2d 72 75 6e db)).. (num-run
0c50: 6e 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 ning-in-jobgroup
0c60: 20 28 64 62 3a 67 65 74 2d 63 6f 75 6e 74 2d 74 (db:get-count-t
0c70: 65 73 74 73 2d 72 75 6e 6e 69 6e 67 2d 69 6e 2d ests-running-in-
0c80: 6a 6f 62 67 72 6f 75 70 20 64 62 20 6a 6f 62 67 jobgroup db jobg
0c90: 72 6f 75 70 29 29 0a 09 20 28 6d 61 78 2d 63 6f roup)).. (max-co
0ca0: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 20 20 ncurrent-jobs
0cb0: 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 (config-lookup
0cc0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
0cd0: 74 75 70 22 20 20 20 20 20 22 6d 61 78 5f 63 6f tup" "max_co
0ce0: 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 22 29 29 ncurrent_jobs"))
0cf0: 0a 09 20 28 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 .. (job-group-li
0d00: 6d 69 74 20 20 20 20 20 20 20 20 20 28 63 6f 6e mit (con
0d10: 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 fig-lookup *conf
0d20: 69 67 64 61 74 2a 20 22 6a 6f 62 67 72 6f 75 70 igdat* "jobgroup
0d30: 73 22 20 6a 6f 62 67 72 6f 75 70 29 29 29 0a 20 s" jobgroup))).
0d40: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
0d50: 32 20 22 6d 61 78 2d 63 6f 6e 63 75 72 72 65 6e 2 "max-concurren
0d60: 74 2d 6a 6f 62 73 3a 20 22 20 6d 61 78 2d 63 6f t-jobs: " max-co
0d70: 6e 63 75 72 72 65 6e 74 2d 6a 6f 62 73 20 22 2c ncurrent-jobs ",
0d80: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 3a 20 22 20 num-running: "
0d90: 6e 75 6d 2d 72 75 6e 6e 69 6e 67 29 0a 20 20 20 num-running).
0da0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 30 (if (not (eq? 0
0db0: 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 *globalexitstat
0dc0: 75 73 2a 29 29 0a 09 23 66 0a 09 28 6c 65 74 20 us*))..#f..(let
0dd0: 28 28 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f ((can-not-run-mo
0de0: 72 65 20 28 63 6f 6e 64 0a 09 09 09 09 20 3b 3b re (cond..... ;;
0df0: 20 69 66 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 if max-concurre
0e00: 6e 74 2d 6a 6f 62 73 20 69 73 20 73 65 74 20 61 nt-jobs is set a
0e10: 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 20 72 75 nd the number ru
0e20: 6e 6e 69 6e 67 20 69 73 20 67 72 65 61 74 65 72 nning is greater
0e30: 20 0a 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 69 ..... ;; than i
0e40: 74 20 74 68 61 6e 20 63 61 6e 6e 6f 74 20 72 75 t than cannot ru
0e50: 6e 20 6d 6f 72 65 20 6a 6f 62 73 0a 09 09 09 09 n more jobs.....
0e60: 20 28 28 61 6e 64 20 6d 61 78 2d 63 6f 6e 63 75 ((and max-concu
0e70: 72 72 65 6e 74 2d 6a 6f 62 73 0a 09 09 09 09 20 rrent-jobs.....
0e80: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e (string->n
0e90: 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e 63 75 72 umber max-concur
0ea0: 72 65 6e 74 2d 6a 6f 62 73 29 0a 09 09 09 09 20 rent-jobs).....
0eb0: 20 20 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 (>= num-ru
0ec0: 6e 6e 69 6e 67 20 28 73 74 72 69 6e 67 2d 3e 6e nning (string->n
0ed0: 75 6d 62 65 72 20 6d 61 78 2d 63 6f 6e 63 75 72 umber max-concur
0ee0: 72 65 6e 74 2d 6a 6f 62 73 29 29 29 0a 09 09 09 rent-jobs)))....
0ef0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
0f00: 30 20 22 57 41 52 4e 49 4e 47 3a 20 4d 61 78 20 0 "WARNING: Max
0f10: 72 75 6e 6e 69 6e 67 20 6a 6f 62 73 20 65 78 63 running jobs exc
0f20: 65 65 64 65 64 2c 20 63 75 72 72 65 6e 74 20 6e eeded, current n
0f30: 75 6d 62 65 72 20 72 75 6e 6e 69 6e 67 3a 20 22 umber running: "
0f40: 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 20 0a 09 09 num-running ...
0f50: 09 09 09 20 20 20 20 20 20 20 22 2c 20 6d 61 78 ... ", max
0f60: 5f 63 6f 6e 63 75 72 72 65 6e 74 5f 6a 6f 62 73 _concurrent_jobs
0f70: 3a 20 22 20 6d 61 78 2d 63 6f 6e 63 75 72 72 65 : " max-concurre
0f80: 6e 74 2d 6a 6f 62 73 29 0a 09 09 09 09 20 20 23 nt-jobs)..... #
0f90: 74 29 0a 09 09 09 09 20 3b 3b 20 69 66 20 6a 6f t)..... ;; if jo
0fa0: 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 20 69 73 b-group-limit is
0fb0: 20 73 65 74 20 61 6e 64 20 6e 75 6d 62 65 72 20 set and number
0fc0: 6f 66 20 6a 6f 62 73 20 69 6e 20 74 68 65 20 67 of jobs in the g
0fd0: 72 6f 75 70 20 69 73 20 67 72 65 61 74 65 72 0a roup is greater.
0fe0: 09 09 09 09 20 3b 3b 20 74 68 61 6e 20 74 68 65 .... ;; than the
0ff0: 20 6c 69 6d 69 74 20 74 68 65 6e 20 63 61 6e 6e limit then cann
1000: 6f 74 20 72 75 6e 20 6d 6f 72 65 20 6a 6f 62 73 ot run more jobs
1010: 20 6f 66 20 74 68 69 73 20 6b 69 6e 64 0a 09 09 of this kind...
1020: 09 09 20 28 28 61 6e 64 20 6a 6f 62 2d 67 72 6f .. ((and job-gro
1030: 75 70 2d 6c 69 6d 69 74 0a 09 09 09 09 20 20 20 up-limit.....
1040: 20 20 20 20 28 3e 3d 20 6e 75 6d 2d 72 75 6e 6e (>= num-runn
1050: 69 6e 67 2d 69 6e 2d 6a 6f 62 67 72 6f 75 70 20 ing-in-jobgroup
1060: 6a 6f 62 2d 67 72 6f 75 70 2d 6c 69 6d 69 74 29 job-group-limit)
1070: 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a 70 )..... (debug:p
1080: 72 69 6e 74 20 31 20 22 57 41 52 4e 49 4e 47 3a rint 1 "WARNING:
1090: 20 6e 75 6d 62 65 72 20 6f 66 20 6a 6f 62 73 20 number of jobs
10a0: 22 20 6e 75 6d 2d 72 75 6e 6e 69 6e 67 2d 69 6e " num-running-in
10b0: 2d 6a 6f 62 67 72 6f 75 70 20 0a 09 09 09 09 09 -jobgroup ......
10c0: 20 20 20 20 20 20 20 22 20 69 6e 20 22 20 6a 6f " in " jo
10d0: 62 67 72 6f 75 70 20 22 20 65 78 63 65 65 64 65 bgroup " exceede
10e0: 64 2c 20 77 69 6c 6c 20 6e 6f 74 20 72 75 6e 20 d, will not run
10f0: 22 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 " (tests:testque
1100: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
1110: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 0a 09 09 test-record))...
1120: 09 09 20 20 23 74 29 0a 09 09 09 09 20 28 65 6c .. #t)..... (el
1130: 73 65 20 23 66 29 29 29 29 0a 09 20 20 28 6e 6f se #f)))).. (no
1140: 74 20 63 61 6e 2d 6e 6f 74 2d 72 75 6e 2d 6d 6f t can-not-run-mo
1150: 72 65 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d re)))))..;;=====
1160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11a0: 3d 0a 3b 3b 20 4e 65 77 20 6d 65 74 68 6f 64 6f =.;; New methodo
11b0: 6c 6f 67 79 2e 20 54 68 65 73 65 20 72 6f 75 74 logy. These rout
11c0: 69 6e 65 73 20 77 69 6c 6c 20 72 65 70 6c 61 63 ines will replac
11d0: 65 20 74 68 65 20 61 62 6f 76 65 20 69 6e 20 74 e the above in t
11e0: 69 6d 65 2e 20 46 6f 72 0a 3b 3b 20 6e 6f 77 20 ime. For.;; now
11f0: 74 68 65 20 63 6f 64 65 20 69 73 20 64 75 70 6c the code is dupl
1200: 69 63 61 74 65 64 2e 20 54 68 69 73 20 73 74 75 icated. This stu
1210: 66 66 20 69 73 20 69 6e 69 74 69 61 6c 6c 79 20 ff is initially
1220: 75 73 65 64 20 69 6e 20 74 68 65 20 6d 6f 6e 69 used in the moni
1230: 74 6f 72 0a 3b 3b 20 62 61 73 65 64 20 63 6f 64 tor.;; based cod
1240: 65 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d e..;;===========
1250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
1290: 72 65 67 69 73 74 65 72 20 61 20 74 65 73 74 20 register a test
12a0: 72 75 6e 20 77 69 74 68 20 74 68 65 20 64 62 0a run with the db.
12b0: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 65 (define (runs:re
12c0: 67 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 gister-run db ke
12d0: 79 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e ys keyvallst run
12e0: 6e 61 6d 65 20 73 74 61 74 65 20 73 74 61 74 75 name state statu
12f0: 73 20 75 73 65 72 29 0a 20 20 28 64 65 62 75 67 s user). (debug
1300: 3a 70 72 69 6e 74 20 33 20 22 72 75 6e 73 3a 72 :print 3 "runs:r
1310: 65 67 69 73 74 65 72 2d 72 75 6e 2c 20 6b 65 79 egister-run, key
1320: 73 3a 20 22 20 6b 65 79 73 20 22 20 6b 65 79 76 s: " keys " keyv
1330: 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c 6c allst: " keyvall
1340: 73 74 20 22 20 72 75 6e 6e 61 6d 65 3a 20 22 20 st " runname: "
1350: 72 75 6e 6e 61 6d 65 20 22 20 73 74 61 74 65 3a runname " state:
1360: 20 22 20 73 74 61 74 65 20 22 20 73 74 61 74 75 " state " statu
1370: 73 3a 20 22 20 73 74 61 74 75 73 20 22 20 75 73 s: " status " us
1380: 65 72 3a 20 22 20 75 73 65 72 29 0a 20 20 28 6c er: " user). (l
1390: 65 74 2a 20 28 28 6b 65 79 73 74 72 20 20 20 20 et* ((keystr
13a0: 28 6b 65 79 73 2d 3e 6b 65 79 73 74 72 20 6b 65 (keys->keystr ke
13b0: 79 73 29 29 0a 09 20 28 63 6f 6d 6d 61 20 20 20 ys)).. (comma
13c0: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
13d0: 20 6b 65 79 73 29 20 30 29 20 22 2c 22 20 22 22 keys) 0) "," ""
13e0: 29 29 0a 09 20 28 61 6e 64 73 74 72 20 20 20 20 )).. (andstr
13f0: 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 6b (if (> (length k
1400: 65 79 73 29 20 30 29 20 22 20 41 4e 44 20 22 20 eys) 0) " AND "
1410: 22 22 29 29 0a 09 20 28 76 61 6c 73 6c 6f 74 73 "")).. (valslots
1420: 20 20 28 6b 65 79 73 2d 3e 76 61 6c 73 6c 6f 74 (keys->valslot
1430: 73 20 6b 65 79 73 29 29 20 3b 3b 20 3f 2c 3f 2c s keys)) ;; ?,?,
1440: 3f 20 2e 2e 2e 0a 09 20 28 6b 65 79 76 61 6c 73 ? ..... (keyvals
1450: 20 20 20 28 6d 61 70 20 63 61 64 72 20 6b 65 79 (map cadr key
1460: 76 61 6c 6c 73 74 29 29 0a 09 20 28 61 6c 6c 76 vallst)).. (allv
1470: 61 6c 73 20 20 20 28 61 70 70 65 6e 64 20 28 6c als (append (l
1480: 69 73 74 20 72 75 6e 6e 61 6d 65 20 73 74 61 74 ist runname stat
1490: 65 20 73 74 61 74 75 73 20 75 73 65 72 29 20 6b e status user) k
14a0: 65 79 76 61 6c 73 29 29 0a 09 20 28 71 72 79 76 eyvals)).. (qryv
14b0: 61 6c 73 20 20 20 28 61 70 70 65 6e 64 20 28 6c als (append (l
14c0: 69 73 74 20 72 75 6e 6e 61 6d 65 29 20 6b 65 79 ist runname) key
14d0: 76 61 6c 73 29 29 0a 09 20 28 6b 65 79 3d 3f 73 vals)).. (key=?s
14e0: 74 72 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 tr (string-inte
14f0: 72 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 rsperse (map (la
1500: 6d 62 64 61 20 28 6b 29 28 63 6f 6e 63 20 28 6b mbda (k)(conc (k
1510: 65 79 3a 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 ey:get-fieldname
1520: 20 6b 29 20 22 3d 3f 22 29 29 20 6b 65 79 73 29 k) "=?")) keys)
1530: 20 22 20 41 4e 44 20 22 29 29 29 0a 20 20 20 20 " AND "))).
1540: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 20 22 (debug:print 3 "
1550: 6b 65 79 73 3a 20 22 20 6b 65 79 73 20 22 20 61 keys: " keys " a
1560: 6c 6c 76 61 6c 73 3a 20 22 20 61 6c 6c 76 61 6c llvals: " allval
1570: 73 20 22 20 6b 65 79 76 61 6c 73 3a 20 22 20 6b s " keyvals: " k
1580: 65 79 76 61 6c 73 29 0a 20 20 20 20 28 64 65 62 eyvals). (deb
1590: 75 67 3a 70 72 69 6e 74 20 32 20 22 4e 4f 54 45 ug:print 2 "NOTE
15a0: 3a 20 75 73 69 6e 67 20 74 61 72 67 65 74 20 22 : using target "
15b0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
15c0: 65 72 73 65 20 6b 65 79 76 61 6c 73 20 22 2f 22 erse keyvals "/"
15d0: 29 20 22 20 66 6f 72 20 74 68 69 73 20 72 75 6e ) " for this run
15e0: 22 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 "). (if (and
15f0: 72 75 6e 6e 61 6d 65 20 28 6e 75 6c 6c 3f 20 28 runname (null? (
1600: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
1610: 78 29 28 6e 6f 74 20 78 29 29 20 6b 65 79 76 61 x)(not x)) keyva
1620: 6c 73 29 29 29 20 3b 3b 20 74 68 65 72 65 20 6d ls))) ;; there m
1630: 75 73 74 20 62 65 20 61 20 62 65 74 74 65 72 20 ust be a better
1640: 77 61 79 20 74 6f 20 22 61 70 70 6c 79 20 61 6e way to "apply an
1650: 64 22 0a 09 28 6c 65 74 20 28 28 72 65 73 20 23 d"..(let ((res #
1660: 66 29 29 0a 09 20 20 28 61 70 70 6c 79 20 73 71 f)).. (apply sq
1670: 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 64 62 lite3:execute db
1680: 20 28 63 6f 6e 63 20 22 49 4e 53 45 52 54 20 4f (conc "INSERT O
1690: 52 20 49 47 4e 4f 52 45 20 49 4e 54 4f 20 72 75 R IGNORE INTO ru
16a0: 6e 73 20 28 72 75 6e 6e 61 6d 65 2c 73 74 61 74 ns (runname,stat
16b0: 65 2c 73 74 61 74 75 73 2c 6f 77 6e 65 72 2c 65 e,status,owner,e
16c0: 76 65 6e 74 5f 74 69 6d 65 22 20 63 6f 6d 6d 61 vent_time" comma
16d0: 20 6b 65 79 73 74 72 20 22 29 20 56 41 4c 55 45 keystr ") VALUE
16e0: 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 73 74 72 66 74 S (?,?,?,?,strft
16f0: 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 22 ime('%s','now')"
1700: 20 63 6f 6d 6d 61 20 76 61 6c 73 6c 6f 74 73 20 comma valslots
1710: 22 29 3b 22 29 0a 09 09 20 61 6c 6c 76 61 6c 73 ");")... allvals
1720: 29 0a 09 20 20 28 61 70 70 6c 79 20 73 71 6c 69 ).. (apply sqli
1730: 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 6f 77 te3:for-each-row
1740: 20 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 69 .. (lambda (i
1750: 64 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 d).. (set! r
1760: 65 73 20 69 64 29 29 0a 09 20 20 20 64 62 0a 09 es id)).. db..
1770: 20 20 20 28 6c 65 74 20 28 28 71 72 79 20 28 63 (let ((qry (c
1780: 6f 6e 63 20 22 53 45 4c 45 43 54 20 69 64 20 46 onc "SELECT id F
1790: 52 4f 4d 20 72 75 6e 73 20 57 48 45 52 45 20 28 ROM runs WHERE (
17a0: 72 75 6e 6e 61 6d 65 3d 3f 20 22 20 61 6e 64 73 runname=? " ands
17b0: 74 72 20 6b 65 79 3d 3f 73 74 72 20 22 29 3b 22 tr key=?str ");"
17c0: 29 29 29 0a 09 20 20 20 20 20 3b 28 64 65 62 75 ))).. ;(debu
17d0: 67 3a 70 72 69 6e 74 20 34 20 22 71 72 79 3a 20 g:print 4 "qry:
17e0: 22 20 71 72 79 29 20 0a 09 20 20 20 20 20 71 72 " qry) .. qr
17f0: 79 29 0a 09 20 20 20 71 72 79 76 61 6c 73 29 0a y).. qryvals).
1800: 09 20 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 . (sqlite3:exec
1810: 75 74 65 20 64 62 20 22 55 50 44 41 54 45 20 72 ute db "UPDATE r
1820: 75 6e 73 20 53 45 54 20 73 74 61 74 65 3d 3f 2c uns SET state=?,
1830: 73 74 61 74 75 73 3d 3f 20 57 48 45 52 45 20 69 status=? WHERE i
1840: 64 3d 3f 3b 22 20 73 74 61 74 65 20 73 74 61 74 d=?;" state stat
1850: 75 73 20 72 65 73 29 0a 09 20 20 72 65 73 29 20 us res).. res)
1860: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
1870: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
1880: 52 3a 20 43 61 6c 6c 65 64 20 77 69 74 68 6f 75 R: Called withou
1890: 74 20 61 6c 6c 20 6e 65 63 65 73 73 61 72 79 20 t all necessary
18a0: 6b 65 79 73 22 29 0a 09 20 20 23 66 29 29 29 29 keys").. #f))))
18b0: 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 64 ..;; This is a d
18c0: 75 70 6c 69 63 61 74 65 20 6f 66 20 72 75 6e 2d uplicate of run-
18d0: 74 65 73 74 73 20 28 77 68 69 63 68 20 68 61 73 tests (which has
18e0: 20 62 65 65 6e 20 64 65 70 72 65 63 61 74 65 64 been deprecated
18f0: 29 2e 20 55 73 65 20 74 68 69 73 20 6f 6e 65 20 ). Use this one
1900: 69 6e 73 74 65 61 64 20 6f 66 20 72 75 6e 20 74 instead of run t
1910: 65 73 74 73 2e 0a 3b 3b 20 6b 65 79 76 61 6c 73 ests..;; keyvals
1920: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 72 .(define (runs:r
1930: 75 6e 2d 74 65 73 74 73 20 64 62 20 74 61 72 67 un-tests db targ
1940: 65 74 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d et runname test-
1950: 70 61 74 74 73 20 69 74 65 6d 2d 70 61 74 74 73 patts item-patts
1960: 20 75 73 65 72 20 66 6c 61 67 73 29 0a 20 20 28 user flags). (
1970: 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 20 let* ((keys
1980: 20 20 20 28 72 64 62 3a 67 65 74 2d 6b 65 79 73 (rdb:get-keys
1990: 20 64 62 29 29 0a 09 20 28 6b 65 79 76 61 6c 6c db)).. (keyvall
19a0: 73 74 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 st (keys:targe
19b0: 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 t->keyval keys t
19c0: 61 72 67 65 74 29 29 0a 09 20 28 72 75 6e 2d 69 arget)).. (run-i
19d0: 64 20 20 20 20 20 20 28 72 75 6e 73 3a 72 65 67 d (runs:reg
19e0: 69 73 74 65 72 2d 72 75 6e 20 64 62 20 6b 65 79 ister-run db key
19f0: 73 20 6b 65 79 76 61 6c 6c 73 74 20 72 75 6e 6e s keyvallst runn
1a00: 61 6d 65 20 22 6e 65 77 22 20 22 6e 2f 61 22 20 ame "new" "n/a"
1a10: 75 73 65 72 29 29 20 20 3b 3b 20 20 74 65 73 74 user)) ;; test
1a20: 2d 6e 61 6d 65 29 29 29 0a 09 20 28 64 65 66 65 -name))).. (defe
1a30: 72 72 65 64 20 20 20 20 27 28 29 29 20 3b 3b 20 rred '()) ;;
1a40: 64 65 6c 61 79 20 72 75 6e 6e 69 6e 67 20 74 68 delay running th
1a50: 65 73 65 20 73 69 6e 63 65 20 74 68 65 79 20 68 ese since they h
1a60: 61 76 65 20 61 20 77 61 69 74 6f 6e 20 63 6c 61 ave a waiton cla
1a70: 75 73 65 0a 09 20 3b 3b 20 6b 65 65 70 67 6f 69 use.. ;; keepgoi
1a80: 6e 67 20 69 73 20 74 68 65 20 64 65 66 61 63 74 ng is the defact
1a90: 6f 20 6d 6f 64 61 6c 69 74 79 20 6e 6f 77 2c 20 o modality now,
1aa0: 77 69 6c 6c 20 61 64 64 20 68 69 74 2d 6e 2d 72 will add hit-n-r
1ab0: 75 6e 20 61 20 62 69 74 20 6c 61 74 65 72 0a 09 un a bit later..
1ac0: 20 3b 3b 20 28 6b 65 65 70 67 6f 69 6e 67 20 20 ;; (keepgoing
1ad0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
1ae0: 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 22 /default flags "
1af0: 2d 6b 65 65 70 67 6f 69 6e 67 22 20 23 66 29 29 -keepgoing" #f))
1b00: 0a 09 20 28 74 65 73 74 2d 6e 61 6d 65 73 20 20 .. (test-names
1b10: 27 28 29 29 0a 09 20 28 72 75 6e 63 6f 6e 66 69 '()).. (runconfi
1b20: 67 66 20 20 20 28 63 6f 6e 63 20 20 2a 74 6f 70 gf (conc *top
1b30: 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 path* "/runconfi
1b40: 67 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 gs.config")).. (
1b50: 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 20 27 required-tests '
1b60: 28 29 29 0a 09 20 28 74 65 73 74 2d 72 65 63 6f ()).. (test-reco
1b70: 72 64 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 rds (make-hash-t
1b80: 61 62 6c 65 29 29 29 0a 0a 20 20 20 20 28 73 65 able))).. (se
1b90: 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 t-megatest-env-v
1ba0: 61 72 73 20 64 62 20 72 75 6e 2d 69 64 29 20 3b ars db run-id) ;
1bb0: 3b 20 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e ; these may be n
1bc0: 65 65 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 eeded by the lau
1bd0: 6e 63 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 0a nching process..
1be0: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
1bf0: 69 73 74 73 3f 20 72 75 6e 63 6f 6e 66 69 67 66 ists? runconfigf
1c00: 29 0a 09 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 )..(setup-env-de
1c10: 66 61 75 6c 74 73 20 64 62 20 72 75 6e 63 6f 6e faults db runcon
1c20: 66 69 67 66 20 72 75 6e 2d 69 64 20 2a 61 6c 72 figf run-id *alr
1c30: 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e eady-seen-runcon
1c40: 66 69 67 2d 69 6e 66 6f 2a 20 22 70 72 65 2d 6c fig-info* "pre-l
1c50: 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 22 29 aunch-env-vars")
1c60: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
1c70: 20 22 57 41 52 4e 49 4e 47 3a 20 59 6f 75 20 64 "WARNING: You d
1c80: 6f 20 6e 6f 74 20 68 61 76 65 20 61 20 72 75 6e o not have a run
1c90: 20 63 6f 6e 66 69 67 20 66 69 6c 65 3a 20 22 20 config file: "
1ca0: 72 75 6e 63 6f 6e 66 69 67 66 29 29 0a 20 20 20 runconfigf)).
1cb0: 20 0a 20 20 20 20 3b 3b 20 6c 6f 6f 6b 20 75 70 . ;; look up
1cc0: 20 61 6c 6c 20 74 65 73 74 73 20 6d 61 74 63 68 all tests match
1cd0: 69 6e 67 20 74 68 65 20 63 6f 6d 6d 61 20 73 65 ing the comma se
1ce0: 70 61 72 61 74 65 64 20 6c 69 73 74 20 6f 66 20 parated list of
1cf0: 67 6c 6f 62 73 20 69 6e 0a 20 20 20 20 3b 3b 20 globs in. ;;
1d00: 74 65 73 74 2d 70 61 74 74 73 20 28 75 73 69 6e test-patts (usin
1d10: 67 20 25 20 61 73 20 77 69 6c 64 63 61 72 64 29 g % as wildcard)
1d20: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
1d30: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 70 61 (lambda (pa
1d40: 74 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 tt). (let
1d50: 28 28 74 65 73 74 73 20 28 67 6c 6f 62 20 28 63 ((tests (glob (c
1d60: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
1d70: 74 65 73 74 73 2f 22 20 28 73 74 72 69 6e 67 2d tests/" (string-
1d80: 74 72 61 6e 73 6c 61 74 65 20 70 61 74 74 20 22 translate patt "
1d90: 25 22 20 22 2a 22 29 29 29 29 29 0a 09 20 28 73 %" "*"))))).. (s
1da0: 65 74 21 20 74 65 73 74 73 20 28 66 69 6c 74 65 et! tests (filte
1db0: 72 20 28 6c 61 6d 62 64 61 20 28 74 65 73 74 29 r (lambda (test)
1dc0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 (file-exists? (c
1dd0: 6f 6e 63 20 74 65 73 74 20 22 2f 74 65 73 74 63 onc test "/testc
1de0: 6f 6e 66 69 67 22 29 29 29 20 74 65 73 74 73 29 onfig"))) tests)
1df0: 29 0a 09 20 28 73 65 74 21 20 74 65 73 74 2d 6e ).. (set! test-n
1e00: 61 6d 65 73 20 28 61 70 70 65 6e 64 20 74 65 73 ames (append tes
1e10: 74 2d 6e 61 6d 65 73 20 0a 09 09 09 09 20 20 28 t-names ..... (
1e20: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 74 65 73 map (lambda (tes
1e30: 74 70 29 0a 09 09 09 09 09 20 28 6c 61 73 74 20 tp)...... (last
1e40: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 65 (string-split te
1e50: 73 74 70 20 22 2f 22 29 29 29 0a 09 09 09 09 20 stp "/"))).....
1e60: 20 20 20 20 20 20 74 65 73 74 73 29 29 29 29 29 tests)))))
1e70: 0a 20 20 20 20 20 28 69 66 20 74 65 73 74 2d 70 . (if test-p
1e80: 61 74 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c atts (string-spl
1e90: 69 74 20 74 65 73 74 2d 70 61 74 74 73 20 22 2c it test-patts ",
1ea0: 22 29 28 6c 69 73 74 20 22 25 22 29 29 29 0a 0a ")(list "%")))..
1eb0: 20 20 20 20 20 3b 3b 20 6e 6f 77 20 72 65 6d 6f ;; now remo
1ec0: 76 65 20 64 75 70 6c 69 63 61 74 65 73 0a 20 20 ve duplicates.
1ed0: 20 20 28 73 65 74 21 20 74 65 73 74 2d 6e 61 6d (set! test-nam
1ee0: 65 73 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 es (delete-dupli
1ef0: 63 61 74 65 73 20 74 65 73 74 2d 6e 61 6d 65 73 cates test-names
1f00: 29 29 0a 0a 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
1f10: 72 69 6e 74 20 30 20 22 49 4e 46 4f 3a 20 74 65 rint 0 "INFO: te
1f20: 73 74 20 6e 61 6d 65 73 20 22 20 74 65 73 74 2d st names " test-
1f30: 6e 61 6d 65 73 29 0a 0a 20 20 20 20 3b 3b 20 6f names).. ;; o
1f40: 6e 20 74 68 65 20 66 69 72 73 74 20 70 61 73 73 n the first pass
1f50: 20 6f 72 20 63 61 6c 6c 20 74 6f 20 72 75 6e 2d or call to run-
1f60: 74 65 73 74 73 20 73 65 74 20 46 41 49 4c 53 20 tests set FAILS
1f70: 74 6f 20 4e 4f 54 5f 53 54 41 52 54 45 44 20 69 to NOT_STARTED i
1f80: 66 0a 20 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f f. ;; -keepgo
1f90: 69 6e 67 20 69 73 20 73 70 65 63 69 66 69 65 64 ing is specified
1fa0: 0a 20 20 20 20 28 69 66 20 28 65 71 3f 20 2a 70 . (if (eq? *p
1fb0: 61 73 73 6e 75 6d 2a 20 30 29 0a 09 28 62 65 67 assnum* 0)..(beg
1fc0: 69 6e 0a 09 20 20 3b 3b 20 68 61 76 65 20 74 6f in.. ;; have to
1fd0: 20 64 65 6c 65 74 65 20 74 65 73 74 20 72 65 63 delete test rec
1fe0: 6f 72 64 73 20 77 68 65 72 65 20 4e 4f 54 5f 53 ords where NOT_S
1ff0: 54 41 52 54 45 44 20 73 69 6e 63 65 20 74 68 65 TARTED since the
2000: 79 20 63 61 6e 20 63 61 75 73 65 20 2d 6b 65 65 y can cause -kee
2010: 70 67 6f 69 6e 67 20 74 6f 20 0a 09 20 20 3b 3b pgoing to .. ;;
2020: 20 67 65 74 20 73 74 75 63 6b 20 64 75 65 20 74 get stuck due t
2030: 6f 20 62 65 63 6f 6d 69 6e 67 20 69 6e 61 63 63 o becoming inacc
2040: 65 73 73 69 62 6c 65 20 66 72 6f 6d 20 61 20 66 essible from a f
2050: 61 69 6c 65 64 20 74 65 73 74 2e 20 49 2e 65 2e ailed test. I.e.
2060: 20 69 66 20 74 65 73 74 20 42 20 64 65 70 65 6e if test B depen
2070: 64 73 20 0a 09 20 20 3b 3b 20 6f 6e 20 74 65 73 ds .. ;; on tes
2080: 74 20 41 20 62 75 74 20 74 65 73 74 20 42 20 72 t A but test B r
2090: 65 61 63 68 65 64 20 74 68 65 20 70 6f 69 6e 74 eached the point
20a0: 20 6f 6e 20 62 65 69 6e 67 20 72 65 67 69 73 74 on being regist
20b0: 65 72 65 64 20 61 73 20 4e 4f 54 5f 53 54 41 52 ered as NOT_STAR
20c0: 54 45 44 20 61 6e 64 20 74 65 73 74 0a 09 20 20 TED and test..
20d0: 3b 3b 20 41 20 66 61 69 6c 65 64 20 66 6f 72 20 ;; A failed for
20e0: 73 6f 6d 65 20 72 65 61 73 6f 6e 20 74 68 65 6e some reason then
20f0: 20 6f 6e 20 72 65 2d 72 75 6e 20 75 73 69 6e 67 on re-run using
2100: 20 2d 6b 65 65 70 67 6f 69 6e 67 20 74 68 65 20 -keepgoing the
2110: 72 75 6e 20 63 61 6e 20 6e 65 76 65 72 20 63 6f run can never co
2120: 6d 70 6c 65 74 65 2e 0a 09 20 20 28 64 62 3a 64 mplete... (db:d
2130: 65 6c 65 74 65 2d 74 65 73 74 73 2d 69 6e 2d 73 elete-tests-in-s
2140: 74 61 74 65 20 64 62 20 72 75 6e 2d 69 64 20 22 tate db run-id "
2150: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 09 20 NOT_STARTED")..
2160: 20 28 72 64 62 3a 73 65 74 2d 74 65 73 74 73 2d (rdb:set-tests-
2170: 73 74 61 74 65 2d 73 74 61 74 75 73 20 64 62 20 state-status db
2180: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name
2190: 73 20 23 66 20 22 46 41 49 4c 22 20 22 4e 4f 54 s #f "FAIL" "NOT
21a0: 5f 53 54 41 52 54 45 44 22 20 22 46 41 49 4c 22 _STARTED" "FAIL"
21b0: 29 29 29 0a 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 ))).. ;; now
21c0: 61 64 64 20 6e 6f 6e 2d 64 69 72 65 63 74 6c 79 add non-directly
21d0: 20 72 65 66 65 72 65 6e 63 65 64 20 64 65 70 65 referenced depe
21e0: 6e 64 65 6e 63 69 65 73 20 28 69 2e 65 2e 20 77 ndencies (i.e. w
21f0: 61 69 74 6f 6e 29 0a 20 20 20 20 28 69 66 20 28 aiton). (if (
2200: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 2d not (null? test-
2210: 6e 61 6d 65 73 29 29 0a 09 28 6c 65 74 20 6c 6f names))..(let lo
2220: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 65 op ((hed (car te
2230: 73 74 2d 6e 61 6d 65 73 29 29 0a 09 09 20 20 20 st-names))...
2240: 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 6e (tal (cdr test-n
2250: 61 6d 65 73 29 29 29 20 20 20 20 20 20 20 20 20 ames)))
2260: 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ;; 'return-procs
2270: 20 74 65 6c 6c 73 20 74 68 65 20 63 6f 6e 66 69 tells the confi
2280: 67 20 72 65 61 64 65 72 20 74 6f 20 70 72 65 70 g reader to prep
2290: 20 72 75 6e 6e 69 6e 67 20 73 79 73 74 65 6d 20 running system
22a0: 62 75 74 20 72 65 74 75 72 6e 20 61 20 70 72 6f but return a pro
22b0: 63 0a 09 20 20 28 6c 65 74 2a 20 28 28 63 6f 6e c.. (let* ((con
22c0: 66 69 67 20 20 28 74 65 73 74 3a 67 65 74 2d 74 fig (test:get-t
22d0: 65 73 74 63 6f 6e 66 69 67 20 68 65 64 20 27 72 estconfig hed 'r
22e0: 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 0a 09 09 eturn-procs))...
22f0: 20 28 77 61 69 74 6f 6e 73 20 28 73 74 72 69 6e (waitons (strin
2300: 67 2d 73 70 6c 69 74 20 28 6c 65 74 20 28 28 77 g-split (let ((w
2310: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup
2320: 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 65 6d config "requirem
2330: 65 6e 74 73 22 20 22 77 61 69 74 6f 6e 22 29 29 ents" "waiton"))
2340: 29 0a 09 09 09 09 09 20 20 28 69 66 20 77 20 77 )...... (if w w
2350: 20 22 22 29 29 29 29 29 0a 09 20 20 20 20 3b 3b ""))))).. ;;
2360: 20 28 69 74 65 6d 73 20 20 20 28 69 74 65 6d 73 (items (items
2370: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
2380: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 29 config config)))
2390: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 .. (if (not (
23a0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
23b0: 65 66 61 75 6c 74 20 74 65 73 74 2d 72 65 63 6f efault test-reco
23c0: 72 64 73 20 68 65 64 20 23 66 29 29 0a 09 09 28 rds hed #f))...(
23d0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
23e0: 74 65 73 74 2d 72 65 63 6f 72 64 73 0a 09 09 09 test-records....
23f0: 09 20 68 65 64 20 28 76 65 63 74 6f 72 20 68 65 . hed (vector he
2400: 64 20 20 20 20 20 3b 3b 20 30 0a 09 09 09 09 09 d ;; 0......
2410: 20 20 20 20 20 63 6f 6e 66 69 67 20 20 3b 3b 20 config ;;
2420: 31 0a 09 09 09 09 09 20 20 20 20 20 77 61 69 74 1...... wait
2430: 6f 6e 73 20 3b 3b 20 32 0a 09 09 09 09 09 20 20 ons ;; 2......
2440: 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 (config-looku
2450: 70 20 63 6f 6e 66 69 67 20 22 72 65 71 75 69 72 p config "requir
2460: 65 6d 65 6e 74 73 22 20 22 70 72 69 6f 72 69 74 ements" "priorit
2470: 79 22 29 20 20 20 20 20 3b 3b 20 70 72 69 6f 72 y") ;; prior
2480: 69 74 79 20 33 0a 09 09 09 09 09 20 20 20 20 20 ity 3......
2490: 28 6c 65 74 20 28 28 69 74 65 6d 73 20 20 20 20 (let ((items
24a0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
24b0: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
24c0: 20 22 69 74 65 6d 73 22 20 23 66 29 29 20 3b 3b "items" #f)) ;;
24d0: 20 69 74 65 6d 73 20 34 0a 09 09 09 09 09 09 20 items 4.......
24e0: 20 20 28 69 74 65 6d 73 74 61 62 6c 65 20 28 68 (itemstable (h
24f0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2500: 66 61 75 6c 74 20 63 6f 6e 66 69 67 20 22 69 74 fault config "it
2510: 65 6d 73 74 61 62 6c 65 22 20 23 66 29 29 29 20 emstable" #f)))
2520: 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
2530: 69 66 20 65 69 74 68 65 72 20 69 74 65 6d 73 20 if either items
2540: 6f 72 20 69 74 65 6d 73 20 74 61 62 6c 65 20 69 or items table i
2550: 73 20 61 20 70 72 6f 63 20 72 65 74 75 72 6e 20 s a proc return
2560: 69 74 20 73 6f 20 74 65 73 74 20 72 75 6e 6e 69 it so test runni
2570: 6e 67 0a 09 09 09 09 09 20 20 20 20 20 20 20 3b ng...... ;
2580: 3b 20 70 72 6f 63 65 73 73 20 63 61 6e 20 6b 6e ; process can kn
2590: 6f 77 20 74 6f 20 63 61 6c 6c 20 69 74 65 6d 73 ow to call items
25a0: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
25b0: 63 6f 6e 66 69 67 0a 09 09 09 09 09 20 20 20 20 config......
25c0: 20 20 20 3b 3b 20 69 66 20 65 69 74 68 65 72 20 ;; if either
25d0: 69 73 20 61 20 6c 69 73 74 20 61 6e 64 20 6e 6f is a list and no
25e0: 6e 65 20 69 73 20 61 20 70 72 6f 63 20 67 6f 20 ne is a proc go
25f0: 61 68 65 61 64 20 61 6e 64 20 63 61 6c 6c 20 67 ahead and call g
2600: 65 74 2d 69 74 65 6d 73 0a 09 09 09 09 09 20 20 et-items......
2610: 20 20 20 20 20 3b 3b 20 6f 74 68 65 72 77 69 73 ;; otherwis
2620: 65 20 72 65 74 75 72 6e 20 23 66 20 2d 20 74 68 e return #f - th
2630: 69 73 20 69 73 20 6e 6f 74 20 61 6e 20 69 74 65 is is not an ite
2640: 72 61 74 65 64 20 74 65 73 74 0a 09 09 09 09 09 rated test......
2650: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 (cond....
2660: 09 09 09 28 28 70 72 6f 63 65 64 75 72 65 3f 20 ...((procedure?
2670: 69 74 65 6d 73 29 20 20 20 20 20 20 0a 09 09 09 items) ....
2680: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
2690: 20 34 20 22 49 4e 46 4f 3a 20 69 74 65 6d 73 20 4 "INFO: items
26a0: 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
26b0: 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
26c0: 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 29 20 )....... items)
26d0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 63 61 ;; ca
26e0: 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 lc later.......(
26f0: 28 70 72 6f 63 65 64 75 72 65 3f 20 69 74 65 6d (procedure? item
2700: 73 74 61 62 6c 65 29 0a 09 09 09 09 09 09 20 28 stable)....... (
2710: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 debug:print 4 "I
2720: 4e 46 4f 3a 20 69 74 65 6d 73 74 61 62 6c 65 20 NFO: itemstable
2730: 69 73 20 61 20 70 72 6f 63 65 64 75 72 65 2c 20 is a procedure,
2740: 77 69 6c 6c 20 63 61 6c 63 20 6c 61 74 65 72 22 will calc later"
2750: 29 0a 09 09 09 09 09 09 20 69 74 65 6d 73 74 61 )....... itemsta
2760: 62 6c 65 29 20 20 20 20 20 20 20 3b 3b 20 63 61 ble) ;; ca
2770: 6c 63 20 6c 61 74 65 72 0a 09 09 09 09 09 09 28 lc later.......(
2780: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
2790: 28 78 29 0a 09 09 09 09 09 09 09 20 20 20 28 6c (x)........ (l
27a0: 65 74 20 28 28 76 61 6c 20 28 63 61 72 20 78 29 et ((val (car x)
27b0: 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 28 ))........ (
27c0: 69 66 20 28 70 72 6f 63 65 64 75 72 65 3f 20 76 if (procedure? v
27d0: 61 6c 29 20 76 61 6c 20 23 66 29 29 29 0a 09 09 al) val #f)))...
27e0: 09 09 09 09 09 20 28 61 70 70 65 6e 64 20 28 69 ..... (append (i
27f0: 66 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 20 f (list? items)
2800: 69 74 65 6d 73 20 27 28 29 29 0a 09 09 09 09 09 items '())......
2810: 09 09 09 20 28 69 66 20 28 6c 69 73 74 3f 20 69 ... (if (list? i
2820: 74 65 6d 73 74 61 62 6c 65 29 20 69 74 65 6d 73 temstable) items
2830: 74 61 62 6c 65 20 27 28 29 29 29 29 0a 09 09 09 table '())))....
2840: 09 09 09 20 27 68 61 76 65 2d 70 72 6f 63 65 64 ... 'have-proced
2850: 75 72 65 29 0a 09 09 09 09 09 09 28 28 6f 72 20 ure).......((or
2860: 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 28 6c 69 (list? items)(li
2870: 73 74 3f 20 69 74 65 6d 73 74 61 62 6c 65 29 29 st? itemstable))
2880: 20 3b 3b 20 63 61 6c 63 20 6e 6f 77 0a 09 09 09 ;; calc now....
2890: 09 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
28a0: 20 34 20 22 49 4e 46 4f 3a 20 69 74 65 6d 73 20 4 "INFO: items
28b0: 61 6e 64 20 69 74 65 6d 73 74 61 62 6c 65 20 61 and itemstable a
28c0: 72 65 20 6c 69 73 74 73 2c 20 63 61 6c 63 20 6e re lists, calc n
28d0: 6f 77 5c 6e 22 0a 09 09 09 09 09 09 09 20 20 20 ow\n"........
28e0: 20 20 20 22 20 20 20 20 69 74 65 6d 73 3a 20 22 " items: "
28f0: 20 69 74 65 6d 73 20 22 20 69 74 65 6d 73 74 61 items " itemsta
2900: 62 6c 65 3a 20 22 20 69 74 65 6d 73 74 61 62 6c ble: " itemstabl
2910: 65 29 0a 09 09 09 09 09 09 20 28 69 74 65 6d 73 e)....... (items
2920: 3a 67 65 74 2d 69 74 65 6d 73 2d 66 72 6f 6d 2d :get-items-from-
2930: 63 6f 6e 66 69 67 20 63 6f 6e 66 69 67 29 29 0a config config)).
2940: 09 09 09 09 09 09 28 65 6c 73 65 20 23 66 29 29 ......(else #f))
2950: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
2960: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6e ;; n
2970: 6f 74 20 69 74 65 72 61 74 65 64 0a 09 09 09 09 ot iterated.....
2980: 09 20 20 20 20 20 23 66 20 20 20 20 20 20 3b 3b . #f ;;
2990: 20 69 74 65 6d 73 64 61 74 20 35 0a 09 09 09 09 itemsdat 5.....
29a0: 09 20 20 20 20 20 3b 3b 20 23 66 20 20 20 20 20 . ;; #f
29b0: 20 3b 3b 20 73 70 61 72 65 0a 09 09 09 09 09 20 ;; spare......
29c0: 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 66 6f ))).. (fo
29d0: 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 28 6c r-each .. (l
29e0: 61 6d 62 64 61 20 28 77 61 69 74 6f 6e 29 0a 09 ambda (waiton)..
29f0: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
2a00: 77 61 69 74 6f 6e 20 28 6e 6f 74 20 28 6d 65 6d waiton (not (mem
2a10: 62 65 72 20 77 61 69 74 6f 6e 20 74 65 73 74 2d ber waiton test-
2a20: 6e 61 6d 65 73 29 29 29 0a 09 09 20 20 20 28 62 names)))... (b
2a30: 65 67 69 6e 0a 09 09 20 20 20 20 20 28 73 65 74 egin... (set
2a40: 21 20 72 65 71 75 69 72 65 64 2d 74 65 73 74 73 ! required-tests
2a50: 20 28 63 6f 6e 73 20 77 61 69 74 6f 6e 20 72 65 (cons waiton re
2a60: 71 75 69 72 65 64 2d 74 65 73 74 73 29 29 0a 09 quired-tests))..
2a70: 09 20 20 20 20 20 28 73 65 74 21 20 74 65 73 74 . (set! test
2a80: 2d 6e 61 6d 65 73 20 28 63 6f 6e 73 20 77 61 69 -names (cons wai
2a90: 74 6f 6e 20 74 65 73 74 2d 6e 61 6d 65 73 29 29 ton test-names))
2aa0: 29 29 29 20 3b 3b 20 77 61 73 20 61 6e 20 61 70 ))) ;; was an ap
2ab0: 70 65 6e 64 2c 20 6e 6f 77 20 61 20 63 6f 6e 73 pend, now a cons
2ac0: 0a 09 20 20 20 20 20 77 61 69 74 6f 6e 73 29 0a .. waitons).
2ad0: 09 20 20 20 20 28 6c 65 74 20 28 28 72 65 6d 74 . (let ((remt
2ae0: 65 73 74 73 20 28 64 65 6c 65 74 65 2d 64 75 70 ests (delete-dup
2af0: 6c 69 63 61 74 65 73 20 28 61 70 70 65 6e 64 20 licates (append
2b00: 77 61 69 74 6f 6e 73 20 74 61 6c 29 29 29 29 0a waitons tal)))).
2b10: 09 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 . (if (not
2b20: 28 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 (null? remtests)
2b30: 29 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 )... (loop (car
2b40: 20 72 65 6d 74 65 73 74 73 29 28 63 64 72 20 72 remtests)(cdr r
2b50: 65 6d 74 65 73 74 73 29 29 29 29 29 29 29 0a 0a emtests)))))))..
2b60: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
2b70: 6c 6c 3f 20 72 65 71 75 69 72 65 64 2d 74 65 73 ll? required-tes
2b80: 74 73 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 ts))..(debug:pri
2b90: 6e 74 20 31 20 22 49 4e 46 4f 3a 20 41 64 64 69 nt 1 "INFO: Addi
2ba0: 6e 67 20 22 20 72 65 71 75 69 72 65 64 2d 74 65 ng " required-te
2bb0: 73 74 73 20 22 20 74 6f 20 74 68 65 20 72 75 6e sts " to the run
2bc0: 20 71 75 65 75 65 22 29 29 0a 20 20 20 20 3b 3b queue")). ;;
2bd0: 20 4e 4f 54 45 3a 20 74 68 65 73 65 20 61 72 65 NOTE: these are
2be0: 20 61 6c 6c 20 70 61 72 65 6e 74 20 74 65 73 74 all parent test
2bf0: 73 2c 20 69 74 65 6d 73 20 61 72 65 20 6e 6f 74 s, items are not
2c00: 20 65 78 70 61 6e 64 65 64 20 79 65 74 2e 0a 20 expanded yet..
2c10: 20 20 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 (runs:run-tes
2c20: 74 73 2d 71 75 65 75 65 20 64 62 20 72 75 6e 2d ts-queue db run-
2c30: 69 64 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d id runname test-
2c40: 72 65 63 6f 72 64 73 20 6b 65 79 76 61 6c 6c 73 records keyvalls
2c50: 74 20 66 6c 61 67 73 29 0a 20 20 20 20 28 64 65 t flags). (de
2c60: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 49 4e 46 bug:print 4 "INF
2c70: 4f 3a 20 41 6c 6c 20 64 6f 6e 65 20 62 79 20 68 O: All done by h
2c80: 65 72 65 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 ere")))..(define
2c90: 20 28 72 75 6e 73 3a 72 75 6e 2d 74 65 73 74 73 (runs:run-tests
2ca0: 2d 71 75 65 75 65 20 64 62 20 72 75 6e 2d 69 64 -queue db run-id
2cb0: 20 72 75 6e 6e 61 6d 65 20 74 65 73 74 2d 72 65 runname test-re
2cc0: 63 6f 72 64 73 20 6b 65 79 76 61 6c 6c 73 74 20 cords keyvallst
2cd0: 66 6c 61 67 73 29 0a 20 20 20 20 3b 3b 20 41 74 flags). ;; At
2ce0: 20 74 68 69 73 20 70 6f 69 6e 74 20 74 68 65 20 this point the
2cf0: 6c 69 73 74 20 6f 66 20 70 61 72 65 6e 74 20 74 list of parent t
2d00: 65 73 74 73 20 69 73 20 65 78 70 61 6e 64 65 64 ests is expanded
2d10: 20 0a 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 53 68 . ;; NB// Sh
2d20: 6f 75 6c 64 20 65 78 70 61 6e 64 20 69 74 65 6d ould expand item
2d30: 73 20 68 65 72 65 20 61 6e 64 20 74 68 65 6e 20 s here and then
2d40: 69 6e 73 65 72 74 20 69 6e 74 6f 20 74 68 65 20 insert into the
2d50: 72 75 6e 20 71 75 65 75 65 2e 0a 20 20 28 64 65 run queue.. (de
2d60: 62 75 67 3a 70 72 69 6e 74 20 35 20 22 74 65 73 bug:print 5 "tes
2d70: 74 2d 72 65 63 6f 72 64 73 3a 20 22 20 74 65 73 t-records: " tes
2d80: 74 2d 72 65 63 6f 72 64 73 20 22 2c 20 6b 65 79 t-records ", key
2d90: 76 61 6c 6c 73 74 3a 20 22 20 6b 65 79 76 61 6c vallst: " keyval
2da0: 6c 73 74 29 0a 20 20 28 6c 65 74 20 28 28 73 6f lst). (let ((so
2db0: 72 74 65 64 2d 74 65 73 74 2d 6e 61 6d 65 73 20 rted-test-names
2dc0: 28 74 65 73 74 73 3a 73 6f 72 74 2d 62 79 2d 70 (tests:sort-by-p
2dd0: 72 69 6f 72 69 74 79 2d 61 6e 64 2d 77 61 69 74 riority-and-wait
2de0: 6f 6e 20 74 65 73 74 2d 72 65 63 6f 72 64 73 29 on test-records)
2df0: 29 0a 09 28 69 74 65 6d 2d 70 61 74 74 73 20 20 )..(item-patts
2e00: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
2e10: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 66 6c e-ref/default fl
2e20: 61 67 73 20 22 2d 69 74 65 6d 70 61 74 74 22 20 ags "-itempatt"
2e30: 23 66 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c #f))). (let l
2e40: 6f 6f 70 20 28 3b 20 28 6e 75 6d 74 69 6d 65 73 oop (; (numtimes
2e50: 20 30 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 0) ;; shouldn't
2e60: 20 6e 65 65 64 20 74 68 69 73 0a 09 20 20 20 20 need this..
2e70: 20 20 20 28 68 65 64 20 20 20 20 20 20 20 20 20 (hed
2e80: 28 63 61 72 20 73 6f 72 74 65 64 2d 74 65 73 74 (car sorted-test
2e90: 2d 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 20 20 -names))..
2ea0: 20 28 74 61 6c 20 20 20 20 20 20 20 20 20 28 63 (tal (c
2eb0: 64 72 20 73 6f 72 74 65 64 2d 74 65 73 74 2d 6e dr sorted-test-n
2ec0: 61 6d 65 73 29 29 29 0a 20 20 20 20 20 20 28 6c ames))). (l
2ed0: 65 74 2a 20 28 28 74 65 73 74 2d 72 65 63 6f 72 et* ((test-recor
2ee0: 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 d (hash-table-re
2ef0: 66 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 68 f test-records h
2f00: 65 64 29 29 0a 09 20 20 20 20 20 28 74 63 6f 6e ed)).. (tcon
2f10: 66 69 67 20 20 20 20 20 28 74 65 73 74 73 3a 74 fig (tests:t
2f20: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 estqueue-get-tes
2f30: 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 tconfig test-rec
2f40: 6f 72 64 29 29 0a 09 20 20 20 20 20 28 77 61 69 ord)).. (wai
2f50: 74 6f 6e 73 20 20 20 20 20 28 74 65 73 74 73 3a tons (tests:
2f60: 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 testqueue-get-wa
2f70: 69 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 itons test-re
2f80: 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 70 72 cord)).. (pr
2f90: 69 6f 72 69 74 79 20 20 20 20 28 74 65 73 74 73 iority (tests
2fa0: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 70 :testqueue-get-p
2fb0: 72 69 6f 72 69 74 79 20 20 20 74 65 73 74 2d 72 riority test-r
2fc0: 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 69 ecord)).. (i
2fd0: 74 65 6d 64 61 74 20 20 20 20 20 28 74 65 73 74 temdat (test
2fe0: 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d s:testqueue-get-
2ff0: 69 74 65 6d 64 61 74 20 20 20 20 74 65 73 74 2d itemdat test-
3000: 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 28 record)).. (
3010: 69 74 65 6d 73 20 20 20 20 20 20 20 28 74 65 73 items (tes
3020: 74 73 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 ts:testqueue-get
3030: 2d 69 74 65 6d 73 20 20 20 20 20 20 74 65 73 74 -items test
3040: 2d 72 65 63 6f 72 64 29 29 0a 09 20 20 20 20 20 -record))..
3050: 28 69 74 65 6d 2d 70 61 74 68 20 20 20 28 69 74 (item-path (it
3060: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it
3070: 65 6d 64 61 74 29 29 29 0a 09 28 64 65 62 75 67 emdat)))..(debug
3080: 3a 70 72 69 6e 74 20 36 0a 09 09 20 20 20 20 20 :print 6...
3090: 22 69 74 65 6d 64 61 74 3a 20 20 20 20 20 22 20 "itemdat: "
30a0: 69 74 65 6d 64 61 74 0a 09 09 20 20 20 20 20 22 itemdat... "
30b0: 5c 6e 20 20 69 74 65 6d 73 3a 20 20 20 20 20 22 \n items: "
30c0: 20 69 74 65 6d 73 0a 09 09 20 20 20 20 20 22 5c items... "\
30d0: 6e 20 20 69 74 65 6d 2d 70 61 74 68 3a 20 22 20 n item-path: "
30e0: 69 74 65 6d 2d 70 61 74 68 29 0a 09 28 63 6f 6e item-path)..(con
30f0: 64 0a 09 20 28 28 6e 6f 74 20 69 74 65 6d 73 29 d.. ((not items)
3100: 20 3b 3b 20 77 68 65 6e 20 66 61 6c 73 65 20 74 ;; when false t
3110: 68 65 20 74 65 73 74 20 69 73 20 6f 6b 20 74 6f he test is ok to
3120: 20 62 65 20 68 61 6e 64 65 64 20 6f 66 66 20 74 be handed off t
3130: 6f 20 6c 61 75 6e 63 68 20 28 62 75 74 20 6e 6f o launch (but no
3140: 74 20 62 65 66 6f 72 65 29 0a 09 20 20 28 6c 65 t before).. (le
3150: 74 20 28 28 68 61 76 65 2d 72 65 73 6f 75 72 63 t ((have-resourc
3160: 65 73 20 20 28 72 75 6e 73 3a 63 61 6e 2d 72 75 es (runs:can-ru
3170: 6e 2d 6d 6f 72 65 2d 74 65 73 74 73 20 64 62 20 n-more-tests db
3180: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 20 3b 3b test-record)) ;;
3190: 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 74 65 73 look at the tes
31a0: 74 20 6a 6f 62 67 72 6f 75 70 20 61 6e 64 20 74 t jobgroup and t
31b0: 6f 74 20 6a 6f 62 73 20 72 75 6e 6e 69 6e 67 0a ot jobs running.
31c0: 09 09 28 70 72 65 72 65 71 73 2d 6e 6f 74 2d 6d ..(prereqs-not-m
31d0: 65 74 20 28 64 62 3a 67 65 74 2d 70 72 65 72 65 et (db:get-prere
31e0: 71 73 2d 6e 6f 74 2d 6d 65 74 20 64 62 20 72 75 qs-not-met db ru
31f0: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite
3200: 6d 2d 70 61 74 68 29 29 29 0a 09 20 20 20 20 3b m-path))).. ;
3210: 3b 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 61 74 20 ; Don't know at
3220: 74 68 69 73 20 74 69 6d 65 20 69 66 20 74 68 65 this time if the
3230: 20 74 65 73 74 20 68 61 76 65 20 62 65 65 6e 20 test have been
3240: 6c 61 75 6e 63 68 65 64 20 61 74 20 73 6f 6d 65 launched at some
3250: 20 74 69 6d 65 20 69 6e 20 74 68 65 20 70 61 73 time in the pas
3260: 74 0a 09 20 20 20 20 3b 3b 20 69 2e 65 2e 20 69 t.. ;; i.e. i
3270: 73 20 74 68 69 73 20 61 20 72 65 2d 6c 61 75 6e s this a re-laun
3280: 63 68 3f 0a 09 20 20 20 20 28 69 66 20 28 61 6e ch?.. (if (an
3290: 64 20 68 61 76 65 2d 72 65 73 6f 75 72 63 65 73 d have-resources
32a0: 0a 09 09 20 20 20 20 20 28 6e 75 6c 6c 3f 20 70 ... (null? p
32b0: 72 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 29 29 rereqs-not-met))
32c0: 0a 09 09 3b 3b 20 6e 6f 20 6c 6f 6f 70 20 2d 20 ...;; no loop -
32d0: 64 72 6f 70 20 74 68 6f 75 67 68 20 61 6e 64 20 drop though and
32e0: 75 73 65 20 74 68 65 20 6c 6f 6f 70 20 61 74 20 use the loop at
32f0: 74 68 65 20 62 6f 74 74 6f 6d 20 0a 09 09 28 72 the bottom ...(r
3300: 75 6e 3a 74 65 73 74 20 64 62 20 72 75 6e 2d 69 un:test db run-i
3310: 64 20 72 75 6e 6e 61 6d 65 20 6b 65 79 76 61 6c d runname keyval
3320: 6c 73 74 20 74 65 73 74 2d 72 65 63 6f 72 64 20 lst test-record
3330: 66 6c 61 67 73 20 23 66 29 0a 09 09 3b 3b 20 65 flags #f)...;; e
3340: 6c 73 65 20 74 68 65 20 72 75 6e 20 69 73 20 73 lse the run is s
3350: 74 75 63 6b 2c 20 74 65 6d 70 6f 72 61 72 69 6c tuck, temporaril
3360: 79 20 6f 72 20 70 65 72 6d 61 6e 65 6e 74 6c 79 y or permanently
3370: 0a 09 09 28 6c 65 74 20 28 28 6e 65 77 74 61 6c ...(let ((newtal
3380: 20 28 61 70 70 65 6e 64 20 74 61 6c 20 28 6c 69 (append tal (li
3390: 73 74 20 68 65 64 29 29 29 29 0a 09 09 20 20 3b st hed))))... ;
33a0: 3b 20 63 6f 75 6c 64 6e 27 74 20 72 75 6e 2c 20 ; couldn't run,
33b0: 74 61 6b 65 20 61 20 62 72 65 61 74 68 65 72 0a take a breather.
33c0: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
33d0: 70 21 20 34 29 0a 09 09 20 20 28 6c 6f 6f 70 20 p! 4)... (loop
33e0: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
33f0: 20 6e 65 77 74 61 6c 29 29 29 29 29 29 0a 09 20 newtal))))))..
3400: 0a 09 20 3b 3b 20 63 61 73 65 20 77 68 65 72 65 .. ;; case where
3410: 20 61 6e 20 69 74 65 6d 73 20 63 61 6d 65 20 69 an items came i
3420: 6e 20 61 73 20 61 20 6c 69 73 74 20 62 65 65 6e n as a list been
3430: 20 70 72 6f 63 65 73 73 65 64 0a 09 20 28 28 61 processed.. ((a
3440: 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 29 nd (list? items)
3450: 20 20 20 20 20 3b 3b 20 74 68 75 73 20 77 65 20 ;; thus we
3460: 6b 6e 6f 77 20 6f 75 72 20 69 74 65 6d 73 20 61 know our items a
3470: 72 65 20 61 6c 72 65 61 64 79 20 63 61 6c 63 75 re already calcu
3480: 6c 61 74 65 64 0a 09 20 20 20 20 20 20 20 28 6e lated.. (n
3490: 6f 74 20 20 20 69 74 65 6d 64 61 74 29 29 20 3b ot itemdat)) ;
34a0: 3b 20 61 6e 64 20 6e 6f 74 20 79 65 74 20 65 78 ; and not yet ex
34b0: 70 61 6e 64 65 64 20 69 6e 74 6f 20 74 68 65 20 panded into the
34c0: 6c 69 73 74 20 6f 66 20 74 68 69 6e 67 73 20 74 list of things t
34d0: 6f 20 62 65 20 64 6f 6e 65 0a 09 20 20 28 69 66 o be done.. (if
34e0: 20 28 3e 3d 20 2a 76 65 72 62 6f 73 69 74 79 2a (>= *verbosity*
34f0: 20 31 29 28 70 70 20 69 74 65 6d 73 29 29 0a 09 1)(pp items))..
3500: 20 20 3b 3b 20 28 69 66 20 28 3e 3d 20 2a 76 65 ;; (if (>= *ve
3510: 72 62 6f 73 69 74 79 2a 20 35 29 0a 09 20 20 3b rbosity* 5).. ;
3520: 3b 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 ; (begin..
3530: 3b 3b 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 ;; (print
3540: 22 69 74 65 6d 73 3a 20 22 29 20 20 20 20 20 28 "items: ") (
3550: 70 70 20 28 69 74 65 6d 2d 61 73 73 6f 63 2d 3e pp (item-assoc->
3560: 69 74 65 6d 2d 6c 69 73 74 20 69 74 65 6d 73 29 item-list items)
3570: 29 0a 09 20 20 3b 3b 20 20 20 20 20 20 20 28 70 ).. ;; (p
3580: 72 69 6e 74 20 22 69 74 65 6d 73 74 61 62 6c 65 rint "itemstable
3590: 3a 20 22 29 28 70 70 20 28 69 74 65 6d 2d 74 61 : ")(pp (item-ta
35a0: 62 6c 65 2d 3e 69 74 65 6d 2d 6c 69 73 74 20 69 ble->item-list i
35b0: 74 65 6d 73 74 61 62 6c 65 29 29 29 29 0a 09 20 temstable))))..
35c0: 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 (for-each.. (
35d0: 6c 61 6d 62 64 61 20 28 6d 79 2d 69 74 65 6d 64 lambda (my-itemd
35e0: 61 74 29 0a 09 20 20 20 20 20 28 6c 65 74 2a 20 at).. (let*
35f0: 28 28 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 ((new-test-recor
3600: 64 20 28 6c 65 74 20 28 28 6e 65 77 72 65 63 20 d (let ((newrec
3610: 28 6d 61 6b 65 2d 74 65 73 74 73 3a 74 65 73 74 (make-tests:test
3620: 71 75 65 75 65 29 29 29 0a 09 09 09 09 20 20 20 queue))).....
3630: 20 20 20 20 28 76 65 63 74 6f 72 2d 63 6f 70 79 (vector-copy
3640: 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 6e 65 ! test-record ne
3650: 77 72 65 63 29 0a 09 09 09 09 20 20 20 20 20 20 wrec).....
3660: 20 6e 65 77 72 65 63 29 29 0a 09 09 20 20 20 20 newrec))...
3670: 28 6d 79 2d 69 74 65 6d 2d 70 61 74 68 20 28 69 (my-item-path (i
3680: 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 6d tem-list->path m
3690: 79 2d 69 74 65 6d 64 61 74 29 29 0a 09 09 20 20 y-itemdat))...
36a0: 20 20 28 69 74 65 6d 2d 6d 61 74 63 68 65 73 20 (item-matches
36b0: 28 69 66 20 69 74 65 6d 2d 70 61 74 74 73 20 20 (if item-patts
36c0: 20 20 20 20 20 3b 3b 20 68 65 72 65 20 77 65 20 ;; here we
36d0: 61 72 65 20 66 69 6c 74 65 72 69 6e 67 20 66 6f are filtering fo
36e0: 72 20 6d 61 74 63 68 65 73 20 77 69 74 68 20 2d r matches with -
36f0: 69 74 65 6d 70 61 74 74 0a 09 09 09 09 20 20 20 itempatt.....
3700: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 (let ((res #f
3710: 29 29 09 20 3b 3b 20 6c 6f 6f 6b 20 74 68 72 6f )). ;; look thro
3720: 75 67 68 20 61 6c 6c 20 74 68 65 20 69 74 65 6d ugh all the item
3730: 2d 70 61 74 74 73 20 69 66 20 64 65 66 69 6e 65 -patts if define
3740: 64 2c 20 66 6f 72 6d 61 74 20 69 73 20 70 61 74 d, format is pat
3750: 74 31 2c 70 61 74 74 32 2c 70 61 74 74 33 20 2e t1,patt2,patt3 .
3760: 2e 2e 20 77 69 6c 64 63 61 72 64 20 69 73 20 25 .. wildcard is %
3770: 0a 09 09 09 09 09 28 66 6f 72 2d 65 61 63 68 20 ......(for-each
3780: 0a 09 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 ...... (lambda (
3790: 70 61 74 74 29 0a 09 09 09 09 09 20 20 20 28 69 patt)...... (i
37a0: 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 f (string-search
37b0: 20 28 67 6c 6f 62 2d 3e 72 65 67 65 78 70 0a 09 (glob->regexp..
37c0: 09 09 09 09 09 09 20 20 20 20 20 20 20 28 73 74 ...... (st
37d0: 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 70 ring-translate p
37e0: 61 74 74 20 22 25 22 20 22 2a 22 29 29 0a 09 09 att "%" "*"))...
37f0: 09 09 09 09 09 20 20 20 20 20 20 69 74 65 6d 2d ..... item-
3800: 70 61 74 68 29 0a 09 09 09 09 09 20 20 20 20 20 path)......
3810: 20 20 28 73 65 74 21 20 72 65 73 20 23 74 29 29 (set! res #t))
3820: 29 0a 09 09 09 09 09 20 28 73 74 72 69 6e 67 2d )...... (string-
3830: 73 70 6c 69 74 20 69 74 65 6d 2d 70 61 74 74 73 split item-patts
3840: 20 22 2c 22 29 29 0a 09 09 09 09 09 72 65 73 29 ","))......res)
3850: 0a 09 09 09 09 20 20 20 20 20 20 23 74 29 29 29 ..... #t)))
3860: 0a 09 20 20 20 20 20 20 20 28 69 66 20 69 74 65 .. (if ite
3870: 6d 2d 6d 61 74 63 68 65 73 20 3b 3b 20 79 65 73 m-matches ;; yes
3880: 2c 20 77 65 20 77 61 6e 74 20 74 6f 20 70 72 6f , we want to pro
3890: 63 65 73 73 20 74 68 69 73 20 69 74 65 6d 0a 09 cess this item..
38a0: 09 20 20 20 28 6c 65 74 20 28 28 6e 65 77 74 65 . (let ((newte
38b0: 73 74 6e 61 6d 65 20 28 63 6f 6e 63 20 68 65 64 stname (conc hed
38c0: 20 22 2f 22 20 6d 79 2d 69 74 65 6d 2d 70 61 74 "/" my-item-pat
38d0: 68 29 29 29 20 0a 09 09 20 20 20 20 20 28 74 65 h))) ... (te
38e0: 73 74 73 3a 74 65 73 74 71 75 65 75 65 2d 73 65 sts:testqueue-se
38f0: 74 2d 69 74 65 6d 73 21 20 20 20 6e 65 77 2d 74 t-items! new-t
3900: 65 73 74 2d 72 65 63 6f 72 64 20 23 66 29 0a 09 est-record #f)..
3910: 09 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 . (tests:tes
3920: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 64 tqueue-set-itemd
3930: 61 74 21 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 at! new-test-rec
3940: 6f 72 64 20 6d 79 2d 69 74 65 6d 64 61 74 29 0a ord my-itemdat).
3950: 09 09 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 .. (hash-tab
3960: 6c 65 2d 73 65 74 21 20 74 65 73 74 2d 72 65 63 le-set! test-rec
3970: 6f 72 64 73 20 6e 65 77 74 65 73 74 6e 61 6d 65 ords newtestname
3980: 20 6e 65 77 2d 74 65 73 74 2d 72 65 63 6f 72 64 new-test-record
3990: 29 0a 09 09 20 20 20 20 20 28 73 65 74 21 20 74 )... (set! t
39a0: 61 6c 20 28 63 6f 6e 73 20 6e 65 77 74 65 73 74 al (cons newtest
39b0: 6e 61 6d 65 20 74 61 6c 29 29 29 29 29 29 20 3b name tal)))))) ;
39c0: 3b 20 73 69 6e 63 65 20 74 68 65 73 65 20 61 72 ; since these ar
39d0: 65 20 69 74 65 6d 69 7a 65 64 20 63 72 65 61 74 e itemized creat
39e0: 65 20 6e 65 77 20 74 65 73 74 20 6e 61 6d 65 73 e new test names
39f0: 20 74 65 73 74 6e 61 6d 65 2f 69 74 65 6d 70 61 testname/itempa
3a00: 74 68 0a 09 20 20 20 69 74 65 6d 73 29 0a 09 20 th.. items)..
3a10: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
3a20: 28 63 64 72 20 74 61 6c 29 29 29 0a 0a 09 20 3b (cdr tal)))... ;
3a30: 3b 20 69 66 20 69 74 65 6d 73 20 69 73 20 61 20 ; if items is a
3a40: 70 72 6f 63 20 74 68 65 6e 20 6e 65 65 64 20 74 proc then need t
3a50: 6f 20 72 75 6e 20 69 74 65 6d 73 3a 67 65 74 2d o run items:get-
3a60: 69 74 65 6d 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 items-from-confi
3a70: 67 2c 20 67 65 74 20 74 68 65 20 6c 69 73 74 20 g, get the list
3a80: 61 6e 64 20 6c 6f 6f 70 20 0a 09 20 3b 3b 20 20 and loop .. ;;
3a90: 20 20 2d 20 62 75 74 20 6f 6e 6c 79 20 64 6f 20 - but only do
3aa0: 74 68 61 74 20 69 66 20 72 65 73 6f 75 72 63 65 that if resource
3ab0: 73 20 65 78 69 73 74 20 74 6f 20 6b 69 63 6b 20 s exist to kick
3ac0: 6f 66 66 20 74 68 65 20 6a 6f 62 0a 09 20 28 28 off the job.. ((
3ad0: 6f 72 20 28 70 72 6f 63 65 64 75 72 65 3f 20 69 or (procedure? i
3ae0: 74 65 6d 73 29 28 65 71 3f 20 69 74 65 6d 73 20 tems)(eq? items
3af0: 27 68 61 76 65 2d 70 72 6f 63 65 64 75 72 65 29 'have-procedure)
3b00: 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 72 ).. (if (and (r
3b10: 75 6e 73 3a 63 61 6e 2d 72 75 6e 2d 6d 6f 72 65 uns:can-run-more
3b20: 2d 74 65 73 74 73 20 64 62 20 74 65 73 74 2d 72 -tests db test-r
3b30: 65 63 6f 72 64 29 0a 09 09 20 20 20 28 6e 75 6c ecord)... (nul
3b40: 6c 3f 20 28 64 62 3a 67 65 74 2d 70 72 65 72 65 l? (db:get-prere
3b50: 71 73 2d 6e 6f 74 2d 6d 65 74 20 64 62 20 72 75 qs-not-met db ru
3b60: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 69 74 65 n-id waitons ite
3b70: 6d 2d 70 61 74 68 29 29 29 0a 09 20 20 20 20 20 m-path)))..
3b80: 20 28 6c 65 74 20 28 28 74 65 73 74 2d 6e 61 6d (let ((test-nam
3b90: 65 20 28 74 65 73 74 73 3a 74 65 73 74 71 75 65 e (tests:testque
3ba0: 75 65 2d 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 ue-get-testname
3bb0: 74 65 73 74 2d 72 65 63 6f 72 64 29 29 29 0a 09 test-record)))..
3bc0: 09 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 .(setenv "MT_TES
3bd0: 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d T_NAME" test-nam
3be0: 65 29 20 3b 3b 20 0a 09 09 28 73 65 74 65 6e 76 e) ;; ...(setenv
3bf0: 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 "MT_RUNNAME"
3c00: 72 75 6e 6e 61 6d 65 29 0a 09 09 28 73 65 74 2d runname)...(set-
3c10: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
3c20: 73 20 64 62 20 72 75 6e 2d 69 64 29 20 3b 3b 20 s db run-id) ;;
3c30: 74 68 65 73 65 20 6d 61 79 20 62 65 20 6e 65 65 these may be nee
3c40: 64 65 64 20 62 79 20 74 68 65 20 6c 61 75 6e 63 ded by the launc
3c50: 68 69 6e 67 20 70 72 6f 63 65 73 73 0a 09 09 28 hing process...(
3c60: 6c 65 74 20 28 28 69 74 65 6d 73 2d 6c 69 73 74 let ((items-list
3c70: 20 28 69 74 65 6d 73 3a 67 65 74 2d 69 74 65 6d (items:get-item
3c80: 73 2d 66 72 6f 6d 2d 63 6f 6e 66 69 67 20 74 63 s-from-config tc
3c90: 6f 6e 66 69 67 29 29 29 0a 09 09 20 20 28 69 66 onfig)))... (if
3ca0: 20 28 6c 69 73 74 3f 20 69 74 65 6d 73 2d 6c 69 (list? items-li
3cb0: 73 74 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 st)... (beg
3cc0: 69 6e 0a 09 09 09 28 74 65 73 74 73 3a 74 65 73 in....(tests:tes
3cd0: 74 71 75 65 75 65 2d 73 65 74 2d 69 74 65 6d 73 tqueue-set-items
3ce0: 21 20 74 65 73 74 2d 72 65 63 6f 72 64 20 69 74 ! test-record it
3cf0: 65 6d 73 2d 6c 69 73 74 29 0a 09 09 09 28 6c 6f ems-list)....(lo
3d00: 6f 70 20 68 65 64 20 74 61 6c 29 29 0a 09 09 20 op hed tal))...
3d10: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 (begin....(
3d20: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
3d30: 52 52 4f 52 3a 20 54 68 65 20 70 72 6f 63 20 66 RROR: The proc f
3d40: 72 6f 6d 20 72 65 61 64 69 6e 67 20 74 68 65 20 rom reading the
3d50: 73 65 74 75 70 20 64 69 64 20 6e 6f 74 20 79 69 setup did not yi
3d60: 65 6c 64 20 61 20 6c 69 73 74 20 2d 20 70 6c 65 eld a list - ple
3d70: 61 73 65 20 72 65 70 6f 72 74 20 74 68 69 73 22 ase report this"
3d80: 29 0a 09 09 09 28 65 78 69 74 20 31 29 29 29 29 )....(exit 1))))
3d90: 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ).. (let ((
3da0: 6e 65 77 74 61 6c 20 28 61 70 70 65 6e 64 20 74 newtal (append t
3db0: 61 6c 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 al (list hed))))
3dc0: 0a 09 09 3b 3b 20 69 66 20 63 61 6e 27 74 20 72 ...;; if can't r
3dd0: 75 6e 20 6d 6f 72 65 20 74 65 73 74 73 2c 20 6c un more tests, l
3de0: 65 74 73 20 74 61 6b 65 20 61 20 62 72 65 61 74 ets take a breat
3df0: 68 65 72 0a 09 09 28 74 68 72 65 61 64 2d 73 6c her...(thread-sl
3e00: 65 65 70 21 20 31 29 0a 09 09 28 6c 6f 6f 70 20 eep! 1)...(loop
3e10: 28 63 61 72 20 6e 65 77 74 61 6c 29 28 63 64 72 (car newtal)(cdr
3e20: 20 6e 65 77 74 61 6c 29 29 29 29 29 0a 0a 09 20 newtal)))))...
3e30: 3b 3b 20 74 68 69 73 20 63 61 73 65 20 73 68 6f ;; this case sho
3e40: 75 6c 64 20 6e 6f 74 20 68 61 70 70 65 6e 2c 20 uld not happen,
3e50: 61 64 64 65 64 20 74 6f 20 68 65 6c 70 20 63 61 added to help ca
3e60: 74 63 68 20 61 6e 79 20 62 75 67 73 0a 09 20 28 tch any bugs.. (
3e70: 28 61 6e 64 20 28 6c 69 73 74 3f 20 69 74 65 6d (and (list? item
3e80: 73 29 20 69 74 65 6d 64 61 74 29 0a 09 20 20 28 s) itemdat).. (
3e90: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 45 debug:print 0 "E
3ea0: 52 52 4f 52 3a 20 53 68 6f 75 6c 64 20 6e 6f 74 RROR: Should not
3eb0: 20 68 61 76 65 20 61 20 6c 69 73 74 20 6f 66 20 have a list of
3ec0: 69 74 65 6d 73 20 69 6e 20 61 20 74 65 73 74 20 items in a test
3ed0: 61 6e 64 20 74 68 65 20 69 74 65 6d 73 70 61 74 and the itemspat
3ee0: 68 20 73 65 74 20 2d 20 70 6c 65 61 73 65 20 72 h set - please r
3ef0: 65 70 6f 72 74 20 74 68 69 73 22 29 0a 09 20 20 eport this")..
3f00: 28 65 78 69 74 20 31 29 29 29 29 0a 09 0a 20 20 (exit 1))))...
3f10: 20 20 20 20 3b 3b 20 77 65 20 67 65 74 20 68 65 ;; we get he
3f20: 72 65 20 6f 6e 20 22 64 72 6f 70 20 74 68 72 6f re on "drop thro
3f30: 75 67 68 22 20 2d 20 6c 6f 6f 70 20 66 6f 72 20 ugh" - loop for
3f40: 6e 65 78 74 20 74 65 73 74 20 69 6e 20 71 75 65 next test in que
3f50: 75 65 0a 20 20 20 20 20 20 28 69 66 20 28 6e 75 ue. (if (nu
3f60: 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 28 62 65 67 ll? tal).. (beg
3f70: 69 6e 0a 09 20 20 20 20 3b 3b 20 46 49 58 4d 45 in.. ;; FIXME
3f80: 21 21 21 21 20 54 48 49 53 20 53 48 4f 55 4c 44 !!!! THIS SHOULD
3f90: 20 4e 4f 54 20 52 45 51 55 49 52 45 20 41 4e 20 NOT REQUIRE AN
3fa0: 45 58 49 54 21 21 21 21 21 21 21 0a 09 20 20 20 EXIT!!!!!!!..
3fb0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
3fc0: 22 49 4e 46 4f 3a 20 41 6c 6c 20 74 65 73 74 73 "INFO: All tests
3fd0: 20 6c 61 75 6e 63 68 65 64 2c 20 65 78 69 74 69 launched, exiti
3fe0: 6e 67 22 29 0a 09 20 20 20 20 28 65 78 69 74 20 ng").. (exit
3ff0: 30 29 29 0a 09 20 20 28 6c 6f 6f 70 20 28 63 61 0)).. (loop (ca
4000: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
4010: 29 29 29 29 0a 0a 3b 3b 20 70 61 72 65 6e 74 2d ))))..;; parent-
4020: 74 65 73 74 20 69 73 20 74 68 65 72 65 20 61 73 test is there as
4030: 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 66 a placeholder f
4040: 6f 72 20 77 68 65 6e 20 70 61 72 65 6e 74 2d 74 or when parent-t
4050: 65 73 74 73 20 63 61 6e 20 62 65 20 72 75 6e 20 ests can be run
4060: 61 73 20 61 20 73 65 74 75 70 20 73 74 65 70 0a as a setup step.
4070: 28 64 65 66 69 6e 65 20 28 72 75 6e 3a 74 65 73 (define (run:tes
4080: 74 20 64 62 20 72 75 6e 2d 69 64 20 72 75 6e 6e t db run-id runn
4090: 61 6d 65 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 ame keyvallst te
40a0: 73 74 2d 72 65 63 6f 72 64 20 66 6c 61 67 73 20 st-record flags
40b0: 70 61 72 65 6e 74 2d 74 65 73 74 29 0a 20 20 3b parent-test). ;
40c0: 3b 20 41 6c 6c 20 74 68 65 73 65 20 76 61 72 73 ; All these vars
40d0: 20 6d 69 67 68 74 20 62 65 20 72 65 66 65 72 65 might be refere
40e0: 6e 63 65 64 20 62 79 20 74 68 65 20 74 65 73 74 nced by the test
40f0: 63 6f 6e 66 69 67 20 66 69 6c 65 20 72 65 61 64 config file read
4100: 65 72 0a 20 20 28 6c 65 74 2a 20 28 28 74 65 73 er. (let* ((tes
4110: 74 2d 6e 61 6d 65 20 20 20 20 28 74 65 73 74 73 t-name (tests
4120: 3a 74 65 73 74 71 75 65 75 65 2d 67 65 74 2d 74 :testqueue-get-t
4130: 65 73 74 6e 61 6d 65 20 20 20 74 65 73 74 2d 72 estname test-r
4140: 65 63 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d ecord)).. (test-
4150: 77 61 69 74 6f 6e 73 20 28 74 65 73 74 73 3a 74 waitons (tests:t
4160: 65 73 74 71 75 65 75 65 2d 67 65 74 2d 77 61 69 estqueue-get-wai
4170: 74 6f 6e 73 20 20 20 20 74 65 73 74 2d 72 65 63 tons test-rec
4180: 6f 72 64 29 29 0a 09 20 28 74 65 73 74 2d 63 6f ord)).. (test-co
4190: 6e 66 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 nf (tests:tes
41a0: 74 71 75 65 75 65 2d 67 65 74 2d 74 65 73 74 63 tqueue-get-testc
41b0: 6f 6e 66 69 67 20 74 65 73 74 2d 72 65 63 6f 72 onfig test-recor
41c0: 64 29 29 0a 09 20 28 69 74 65 6d 64 61 74 20 20 d)).. (itemdat
41d0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 71 (tests:testq
41e0: 75 65 75 65 2d 67 65 74 2d 69 74 65 6d 64 61 74 ueue-get-itemdat
41f0: 20 20 20 20 74 65 73 74 2d 72 65 63 6f 72 64 29 test-record)
4200: 29 0a 09 20 28 74 65 73 74 2d 70 61 74 68 20 20 ).. (test-path
4210: 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 (conc *toppath
4220: 2a 20 22 2f 74 65 73 74 73 2f 22 20 74 65 73 74 * "/tests/" test
4230: 2d 6e 61 6d 65 29 29 20 3b 3b 20 63 6f 75 6c 64 -name)) ;; could
4240: 20 75 73 65 20 74 65 73 74 3a 67 65 74 2d 74 65 use test:get-te
4250: 73 74 63 6f 6e 66 69 67 20 68 65 72 65 20 2e 2e stconfig here ..
4260: 2e 0a 09 20 28 66 6f 72 63 65 20 20 20 20 20 20 ... (force
4270: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
4280: 66 2f 64 65 66 61 75 6c 74 20 66 6c 61 67 73 20 f/default flags
4290: 22 2d 66 6f 72 63 65 22 20 23 66 29 29 0a 09 20 "-force" #f))..
42a0: 28 72 65 72 75 6e 20 20 20 20 20 20 20 20 28 68 (rerun (h
42b0: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
42c0: 66 61 75 6c 74 20 66 6c 61 67 73 20 22 2d 72 65 fault flags "-re
42d0: 72 75 6e 22 20 23 66 29 29 0a 09 20 28 6b 65 65 run" #f)).. (kee
42e0: 70 67 6f 69 6e 67 20 20 20 20 28 68 61 73 68 2d pgoing (hash-
42f0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
4300: 74 20 66 6c 61 67 73 20 22 2d 6b 65 65 70 67 6f t flags "-keepgo
4310: 69 6e 67 22 20 23 66 29 29 0a 09 20 28 69 74 65 ing" #f)).. (ite
4320: 6d 2d 70 61 74 68 20 20 20 20 20 22 22 29 29 0a m-path "")).
4330: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
4340: 20 35 0a 09 09 20 22 74 65 73 74 2d 63 6f 6e 66 5... "test-conf
4350: 69 67 3a 20 22 20 28 68 61 73 68 2d 74 61 62 6c ig: " (hash-tabl
4360: 65 2d 3e 61 6c 69 73 74 20 74 65 73 74 2d 63 6f e->alist test-co
4370: 6e 66 29 0a 09 09 20 22 5c 6e 20 20 20 69 74 65 nf)... "\n ite
4380: 6d 64 61 74 3a 20 22 20 69 74 65 6d 64 61 74 0a mdat: " itemdat.
4390: 09 09 20 29 0a 20 20 20 20 3b 3b 20 73 65 74 74 .. ). ;; sett
43a0: 69 6e 67 20 69 74 65 6d 64 61 74 20 74 6f 20 61 ing itemdat to a
43b0: 20 6c 69 73 74 20 69 66 20 69 74 20 69 73 20 23 list if it is #
43c0: 66 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 f. (if (not i
43d0: 74 65 6d 64 61 74 29 28 73 65 74 21 20 69 74 65 temdat)(set! ite
43e0: 6d 64 61 74 20 27 28 29 29 29 0a 20 20 20 20 28 mdat '())). (
43f0: 73 65 74 21 20 69 74 65 6d 2d 70 61 74 68 20 28 set! item-path (
4400: 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 item-list->path
4410: 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 28 64 itemdat)). (d
4420: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 41 74 ebug:print 2 "At
4430: 74 65 6d 70 74 69 6e 67 20 74 6f 20 6c 61 75 6e tempting to laun
4440: 63 68 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e ch test " test-n
4450: 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 ame "/" item-pat
4460: 68 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 h). (setenv "
4470: 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 MT_TEST_NAME" te
4480: 73 74 2d 6e 61 6d 65 29 20 3b 3b 20 0a 20 20 20 st-name) ;; .
4490: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (setenv "MT_RUN
44a0: 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 NAME" runname)
44b0: 0a 20 20 20 20 28 73 65 74 2d 6d 65 67 61 74 65 . (set-megate
44c0: 73 74 2d 65 6e 76 2d 76 61 72 73 20 64 62 20 72 st-env-vars db r
44d0: 75 6e 2d 69 64 29 20 3b 3b 20 74 68 65 73 65 20 un-id) ;; these
44e0: 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 may be needed by
44f0: 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 the launching p
4500: 72 6f 63 65 73 73 0a 20 20 20 20 28 63 68 61 6e rocess. (chan
4510: 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f ge-directory *to
4520: 70 70 61 74 68 2a 29 0a 0a 20 20 20 20 3b 3b 20 ppath*).. ;;
4530: 48 65 72 65 20 69 73 20 77 68 65 72 65 20 74 68 Here is where th
4540: 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c e test_meta tabl
4550: 65 20 69 73 20 62 65 73 74 20 75 70 64 61 74 65 e is best update
4560: 64 0a 20 20 20 20 28 72 75 6e 73 3a 75 70 64 61 d. (runs:upda
4570: 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 62 20 te-test_meta db
4580: 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 63 test-name test-c
4590: 6f 6e 66 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b onf). . ;;
45a0: 20 28 6c 61 6d 62 64 61 20 28 69 74 65 6d 64 61 (lambda (itemda
45b0: 74 29 20 3b 3b 3b 20 28 28 72 69 70 65 6e 65 73 t) ;;; ((ripenes
45c0: 73 20 22 6f 76 65 72 72 69 70 65 22 29 20 28 74 s "overripe") (t
45d0: 65 6d 70 65 72 61 74 75 72 65 20 22 63 6f 6f 6c emperature "cool
45e0: 22 29 20 28 73 65 61 73 6f 6e 20 22 73 75 6d 6d ") (season "summ
45f0: 65 72 22 29 29 0a 20 20 20 20 28 6c 65 74 2a 20 er")). (let*
4600: 28 28 6e 65 77 2d 74 65 73 74 2d 70 61 74 68 20 ((new-test-path
4610: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
4620: 72 73 65 20 28 63 6f 6e 73 20 74 65 73 74 2d 70 rse (cons test-p
4630: 61 74 68 20 28 6d 61 70 20 63 61 64 72 20 69 74 ath (map cadr it
4640: 65 6d 64 61 74 29 29 20 22 2f 22 29 29 0a 09 20 emdat)) "/"))..
4650: 20 20 28 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 (new-test-name
4660: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 69 74 65 (if (equal? ite
4670: 6d 2d 70 61 74 68 20 22 22 29 20 74 65 73 74 2d m-path "") test-
4680: 6e 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 2d name (conc test-
4690: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 name "/" item-pa
46a0: 74 68 29 29 29 20 3b 3b 20 6a 75 73 74 20 6e 65 th))) ;; just ne
46b0: 65 64 20 69 74 20 74 6f 20 62 65 20 75 6e 69 71 ed it to be uniq
46c0: 75 65 0a 09 20 20 20 28 74 65 73 74 64 61 74 20 ue.. (testdat
46d0: 20 20 20 20 20 20 28 72 64 62 3a 67 65 74 2d 74 (rdb:get-t
46e0: 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e 2d est-info db run-
46f0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
4700: 6d 2d 70 61 74 68 29 29 29 0a 20 20 20 20 20 20 m-path))).
4710: 28 69 66 20 28 6e 6f 74 20 74 65 73 74 64 61 74 (if (not testdat
4720: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
4730: 20 3b 3b 20 65 6e 73 75 72 65 20 74 68 61 74 20 ;; ensure that
4740: 74 68 65 20 70 61 74 68 20 65 78 69 73 74 73 20 the path exists
4750: 62 65 66 6f 72 65 20 72 65 67 69 73 74 65 72 69 before registeri
4760: 6e 67 20 74 68 65 20 74 65 73 74 0a 09 20 20 20 ng the test..
4770: 20 3b 3b 20 4e 4f 50 45 3a 20 43 61 6e 6e 6f 74 ;; NOPE: Cannot
4780: 21 20 44 6f 6e 27 74 20 6b 6e 6f 77 20 79 65 74 ! Don't know yet
4790: 20 77 68 69 63 68 20 64 69 73 6b 20 61 72 65 61 which disk area
47a0: 20 77 69 6c 6c 20 62 65 20 61 73 73 69 67 6e 65 will be assigne
47b0: 64 2e 2e 2e 2e 0a 09 20 20 20 20 3b 3b 20 28 73 d...... ;; (s
47c0: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 ystem (conc "mkd
47d0: 69 72 20 2d 70 20 22 20 6e 65 77 2d 74 65 73 74 ir -p " new-test
47e0: 2d 70 61 74 68 29 29 0a 09 20 20 20 20 28 72 74 -path)).. (rt
47f0: 65 73 74 73 3a 72 65 67 69 73 74 65 72 2d 74 65 ests:register-te
4800: 73 74 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 st db run-id tes
4810: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
4820: 29 0a 09 20 20 20 20 28 73 65 74 21 20 74 65 73 ).. (set! tes
4830: 74 64 61 74 20 28 72 64 62 3a 67 65 74 2d 74 65 tdat (rdb:get-te
4840: 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e 2d 69 st-info db run-i
4850: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
4860: 2d 70 61 74 68 29 29 29 29 0a 20 20 20 20 20 20 -path)))).
4870: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
4880: 79 20 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 y test-path).
4890: 20 20 20 28 63 61 73 65 20 28 69 66 20 66 6f 72 (case (if for
48a0: 63 65 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d ce ;; (args:get-
48b0: 61 72 67 20 22 2d 66 6f 72 63 65 22 29 0a 09 09 arg "-force")...
48c0: 27 4e 4f 54 5f 53 54 41 52 54 45 44 0a 09 09 28 'NOT_STARTED...(
48d0: 69 66 20 74 65 73 74 64 61 74 0a 09 09 20 20 20 if testdat...
48e0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
48f0: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
4900: 20 74 65 73 74 64 61 74 29 29 0a 09 09 20 20 20 testdat))...
4910: 20 27 66 61 69 6c 65 64 2d 74 6f 2d 69 6e 73 65 'failed-to-inse
4920: 72 74 29 29 0a 09 28 28 66 61 69 6c 65 64 2d 74 rt))..((failed-t
4930: 6f 2d 69 6e 73 65 72 74 29 0a 09 20 28 64 65 62 o-insert).. (deb
4940: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
4950: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 69 6e 73 R: Failed to ins
4960: 65 72 74 20 74 68 65 20 72 65 63 6f 72 64 20 69 ert the record i
4970: 6e 74 6f 20 74 68 65 20 64 62 22 29 29 0a 09 28 nto the db"))..(
4980: 28 4e 4f 54 5f 53 54 41 52 54 45 44 20 43 4f 4d (NOT_STARTED COM
4990: 50 4c 45 54 45 44 29 0a 09 20 28 64 65 62 75 67 PLETED).. (debug
49a0: 3a 70 72 69 6e 74 20 36 20 22 47 6f 74 20 68 65 :print 6 "Got he
49b0: 72 65 2c 20 22 20 28 74 65 73 74 3a 67 65 74 2d re, " (test:get-
49c0: 73 74 61 74 65 20 74 65 73 74 64 61 74 29 29 0a state testdat)).
49d0: 09 20 28 6c 65 74 20 28 28 72 75 6e 66 6c 61 67 . (let ((runflag
49e0: 20 23 66 29 29 0a 09 20 20 20 28 63 6f 6e 64 0a #f)).. (cond.
49f0: 09 20 20 20 20 3b 3b 20 2d 66 6f 72 63 65 2c 20 . ;; -force,
4a00: 72 75 6e 20 6e 6f 20 6d 61 74 74 65 72 20 77 68 run no matter wh
4a10: 61 74 0a 09 20 20 20 20 28 66 6f 72 63 65 20 28 at.. (force (
4a20: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 set! runflag #t)
4a30: 29 0a 09 20 20 20 20 3b 3b 20 4e 4f 54 5f 53 54 ).. ;; NOT_ST
4a40: 41 52 54 45 44 2c 20 72 75 6e 20 6e 6f 20 6d 61 ARTED, run no ma
4a50: 74 74 65 72 20 77 68 61 74 0a 09 20 20 20 20 28 tter what.. (
4a60: 28 65 71 75 61 6c 3f 20 28 74 65 73 74 3a 67 65 (equal? (test:ge
4a70: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
4a80: 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 28 "NOT_STARTED")(
4a90: 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 74 29 set! runflag #t)
4aa0: 29 0a 09 20 20 20 20 3b 3b 20 6e 6f 74 20 2d 72 ).. ;; not -r
4ab0: 65 72 75 6e 20 61 6e 64 20 50 41 53 53 2c 20 57 erun and PASS, W
4ac0: 41 52 4e 20 6f 72 20 43 48 45 43 4b 2c 20 64 6f ARN or CHECK, do
4ad0: 20 6e 6f 20 72 75 6e 0a 09 20 20 20 20 28 28 61 no run.. ((a
4ae0: 6e 64 20 28 6f 72 20 28 6e 6f 74 20 72 65 72 75 nd (or (not reru
4af0: 6e 29 0a 09 09 20 20 20 20 20 20 6b 65 65 70 67 n)... keepg
4b00: 6f 69 6e 67 29 0a 09 09 20 20 3b 3b 20 52 65 71 oing)... ;; Req
4b10: 75 69 72 65 20 74 6f 20 66 6f 72 63 65 20 72 65 uire to force re
4b20: 2d 72 75 6e 20 66 6f 72 20 43 4f 4d 50 4c 45 54 -run for COMPLET
4b30: 45 44 20 6f 72 20 2a 61 6e 79 74 68 69 6e 67 2a ED or *anything*
4b40: 20 2b 20 50 41 53 53 2c 57 41 52 4e 20 6f 72 20 + PASS,WARN or
4b50: 43 48 45 43 4b 0a 09 09 20 20 28 6f 72 20 28 6d CHECK... (or (m
4b60: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
4b70: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
4b80: 27 28 22 50 41 53 53 22 20 22 57 41 52 4e 22 20 '("PASS" "WARN"
4b90: 22 43 48 45 43 4b 22 29 29 0a 09 09 20 20 20 20 "CHECK"))...
4ba0: 20 20 28 6d 65 6d 62 65 72 20 28 74 65 73 74 3a (member (test:
4bb0: 67 65 74 2d 73 74 61 74 65 20 20 74 65 73 74 64 get-state testd
4bc0: 61 74 29 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 at) '("COMPLETED
4bd0: 22 29 29 29 29 20 0a 09 20 20 20 20 20 28 64 65 ")))) .. (de
4be0: 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 4e 46 bug:print 2 "INF
4bf0: 4f 3a 20 72 75 6e 6e 69 6e 67 20 74 65 73 74 20 O: running test
4c00: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 " test-name "/"
4c10: 69 74 65 6d 2d 70 61 74 68 20 22 20 73 75 70 70 item-path " supp
4c20: 72 65 73 73 65 64 20 61 73 20 69 74 20 69 73 20 ressed as it is
4c30: 43 4f 4d 50 4c 45 54 45 44 20 61 6e 64 20 22 20 COMPLETED and "
4c40: 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 (test:get-state
4c50: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
4c60: 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 66 (set! runflag #f
4c70: 29 29 0a 09 20 20 20 20 3b 3b 20 2d 72 65 72 75 )).. ;; -reru
4c80: 6e 20 61 6e 64 20 73 74 61 74 75 73 20 69 73 20 n and status is
4c90: 6f 6e 65 20 6f 66 20 74 68 65 20 73 70 65 63 69 one of the speci
4ca0: 66 65 64 2c 20 72 75 6e 20 69 74 0a 09 20 20 20 fed, run it..
4cb0: 20 28 28 61 6e 64 20 72 65 72 75 6e 0a 09 09 20 ((and rerun...
4cc0: 20 28 6c 65 74 2a 20 28 28 72 65 72 75 6e 6c 73 (let* ((rerunls
4cd0: 74 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 t (string-spli
4ce0: 74 20 72 65 72 75 6e 20 22 2c 22 29 29 0a 09 09 t rerun ","))...
4cf0: 09 20 28 6d 75 73 74 2d 72 65 72 75 6e 20 28 6d . (must-rerun (m
4d00: 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d ember (test:get-
4d10: 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 status testdat)
4d20: 72 65 72 75 6e 6c 73 74 29 29 29 0a 09 09 20 20 rerunlst)))...
4d30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 33 (debug:print 3
4d40: 20 22 49 4e 46 4f 3a 20 2d 72 65 72 75 6e 20 6c "INFO: -rerun l
4d50: 69 73 74 3a 20 22 20 72 65 72 75 6e 20 22 2c 20 ist: " rerun ",
4d60: 74 65 73 74 2d 73 74 61 74 75 73 3a 20 22 20 28 test-status: " (
4d70: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
4d80: 74 65 73 74 64 61 74 29 22 2c 20 6d 75 73 74 2d testdat)", must-
4d90: 72 65 72 75 6e 3a 20 22 20 6d 75 73 74 2d 72 65 rerun: " must-re
4da0: 72 75 6e 29 0a 09 09 20 20 20 20 6d 75 73 74 2d run)... must-
4db0: 72 65 72 75 6e 29 29 0a 09 20 20 20 20 20 28 64 rerun)).. (d
4dc0: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 49 4e ebug:print 2 "IN
4dd0: 46 4f 3a 20 52 65 72 75 6e 20 66 6f 72 63 65 64 FO: Rerun forced
4de0: 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 74 for test " test
4df0: 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 -name "/" item-p
4e00: 61 74 68 29 0a 09 20 20 20 20 20 28 73 65 74 21 ath).. (set!
4e10: 20 72 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 runflag #t))..
4e20: 20 20 20 3b 3b 20 2d 6b 65 65 70 67 6f 69 6e 67 ;; -keepgoing
4e30: 2c 20 64 6f 20 6e 6f 74 20 72 65 72 75 6e 20 46 , do not rerun F
4e40: 41 49 4c 0a 09 20 20 20 20 28 28 61 6e 64 20 6b AIL.. ((and k
4e50: 65 65 70 67 6f 69 6e 67 0a 09 09 20 20 28 6d 65 eepgoing... (me
4e60: 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 2d 73 mber (test:get-s
4e70: 74 61 74 75 73 20 74 65 73 74 64 61 74 29 20 27 tatus testdat) '
4e80: 28 22 46 41 49 4c 22 29 29 29 0a 09 20 20 20 20 ("FAIL")))..
4e90: 20 28 73 65 74 21 20 72 75 6e 66 6c 61 67 20 23 (set! runflag #
4ea0: 66 29 29 0a 09 20 20 20 20 28 28 61 6e 64 20 28 f)).. ((and (
4eb0: 6e 6f 74 20 72 65 72 75 6e 29 0a 09 09 20 20 28 not rerun)... (
4ec0: 6d 65 6d 62 65 72 20 28 74 65 73 74 3a 67 65 74 member (test:get
4ed0: 2d 73 74 61 74 75 73 20 74 65 73 74 64 61 74 29 -status testdat)
4ee0: 20 27 28 22 46 41 49 4c 22 20 22 6e 2f 61 22 29 '("FAIL" "n/a")
4ef0: 29 29 0a 09 20 20 20 20 20 28 73 65 74 21 20 72 )).. (set! r
4f00: 75 6e 66 6c 61 67 20 23 74 29 29 0a 09 20 20 20 unflag #t))..
4f10: 20 28 65 6c 73 65 20 28 73 65 74 21 20 72 75 6e (else (set! run
4f20: 66 6c 61 67 20 23 66 29 29 29 0a 09 20 20 20 28 flag #f))).. (
4f30: 64 65 62 75 67 3a 70 72 69 6e 74 20 36 20 22 52 debug:print 6 "R
4f40: 55 4e 4e 49 4e 47 20 3d 3e 20 72 75 6e 66 6c 61 UNNING => runfla
4f50: 67 3a 20 22 20 72 75 6e 66 6c 61 67 20 22 20 53 g: " runflag " S
4f60: 54 41 54 45 3a 20 22 20 28 74 65 73 74 3a 67 65 TATE: " (test:ge
4f70: 74 2d 73 74 61 74 65 20 74 65 73 74 64 61 74 29 t-state testdat)
4f80: 20 22 20 53 54 41 54 55 53 3a 20 22 20 28 74 65 " STATUS: " (te
4f90: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
4fa0: 73 74 64 61 74 29 29 0a 09 20 20 20 28 69 66 20 stdat)).. (if
4fb0: 28 6e 6f 74 20 72 75 6e 66 6c 61 67 29 0a 09 20 (not runflag)..
4fc0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 70 (if (not p
4fd0: 61 72 65 6e 74 2d 74 65 73 74 29 0a 09 09 20 20 arent-test)...
4fe0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
4ff0: 22 4e 4f 54 45 3a 20 4e 6f 74 20 73 74 61 72 74 "NOTE: Not start
5000: 69 6e 67 20 74 65 73 74 20 22 20 6e 65 77 2d 74 ing test " new-t
5010: 65 73 74 2d 6e 61 6d 65 20 22 20 61 73 20 69 74 est-name " as it
5020: 20 69 73 20 73 74 61 74 65 20 5c 22 22 20 28 74 is state \"" (t
5030: 65 73 74 3a 67 65 74 2d 73 74 61 74 65 20 74 65 est:get-state te
5040: 73 74 64 61 74 29 20 0a 09 09 09 09 22 5c 22 20 stdat) ....."\"
5050: 61 6e 64 20 73 74 61 74 75 73 20 5c 22 22 20 28 and status \"" (
5060: 74 65 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 test:get-status
5070: 74 65 73 74 64 61 74 29 20 22 5c 22 2c 20 75 73 testdat) "\", us
5080: 65 20 2d 72 65 72 75 6e 20 5c 22 22 20 28 74 65 e -rerun \"" (te
5090: 73 74 3a 67 65 74 2d 73 74 61 74 75 73 20 74 65 st:get-status te
50a0: 73 74 64 61 74 29 20 22 5c 22 20 6f 72 20 2d 66 stdat) "\" or -f
50b0: 6f 72 63 65 20 74 6f 20 6f 76 65 72 72 69 64 65 orce to override
50c0: 22 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 4e ")).. ;; N
50d0: 4f 54 45 3a 20 4e 6f 20 6c 6f 6e 67 65 72 20 62 OTE: No longer b
50e0: 65 20 63 68 65 63 6b 69 6e 67 20 70 72 65 72 65 e checking prere
50f0: 71 75 69 73 69 74 65 73 20 68 65 72 65 21 20 57 quisites here! W
5100: 69 6c 6c 20 6e 65 76 65 72 20 67 65 74 20 68 65 ill never get he
5110: 72 65 20 75 6e 6c 65 73 73 20 70 72 65 72 65 71 re unless prereq
5120: 73 20 61 72 65 0a 09 20 20 20 20 20 20 20 3b 3b s are.. ;;
5130: 20 20 20 20 20 20 20 61 6c 72 65 61 64 79 20 6d already m
5140: 65 74 2e 0a 09 20 20 20 20 20 20 20 28 69 66 20 et... (if
5150: 28 6e 6f 74 20 28 6c 61 75 6e 63 68 2d 74 65 73 (not (launch-tes
5160: 74 20 64 62 20 72 75 6e 2d 69 64 20 72 75 6e 6e t db run-id runn
5170: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 6b 65 ame test-conf ke
5180: 79 76 61 6c 6c 73 74 20 74 65 73 74 2d 6e 61 6d yvallst test-nam
5190: 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d e test-path item
51a0: 64 61 74 20 66 6c 61 67 73 29 29 0a 09 09 20 20 dat flags))...
51b0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 (begin... (
51c0: 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 print "ERROR: Fa
51d0: 69 6c 65 64 20 74 6f 20 6c 61 75 6e 63 68 20 74 iled to launch t
51e0: 68 65 20 74 65 73 74 2e 20 45 78 69 74 69 6e 67 he test. Exiting
51f0: 20 61 73 20 73 6f 6f 6e 20 61 73 20 70 6f 73 73 as soon as poss
5200: 69 62 6c 65 22 29 0a 09 09 20 20 20 20 20 28 73 ible")... (s
5210: 65 74 21 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 et! *globalexits
5220: 74 61 74 75 73 2a 20 31 29 20 3b 3b 20 0a 09 09 tatus* 1) ;; ...
5230: 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 (process-si
5240: 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 gnal (current-pr
5250: 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c ocess-id) signal
5260: 2f 6b 69 6c 6c 29 29 29 29 29 29 0a 09 28 28 4b /kill))))))..((K
5270: 49 4c 4c 45 44 29 20 0a 09 20 28 64 65 62 75 67 ILLED) .. (debug
5280: 3a 70 72 69 6e 74 20 31 20 22 4e 4f 54 45 3a 20 :print 1 "NOTE:
5290: 22 20 6e 65 77 2d 74 65 73 74 2d 6e 61 6d 65 20 " new-test-name
52a0: 22 20 69 73 20 61 6c 72 65 61 64 79 20 72 75 6e " is already run
52b0: 6e 69 6e 67 20 6f 72 20 77 61 73 20 65 78 70 6c ning or was expl
52c0: 69 63 74 6c 79 20 6b 69 6c 6c 65 64 2c 20 75 73 ictly killed, us
52d0: 65 20 2d 66 6f 72 63 65 20 74 6f 20 6c 61 75 6e e -force to laun
52e0: 63 68 20 69 74 2e 22 29 29 0a 09 28 28 4c 41 55 ch it."))..((LAU
52f0: 4e 43 48 45 44 20 52 45 4d 4f 54 45 48 4f 53 54 NCHED REMOTEHOST
5300: 53 54 41 52 54 20 52 55 4e 4e 49 4e 47 29 20 20 START RUNNING)
5310: 0a 09 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 .. (if (> (- (cu
5320: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 2b rrent-seconds)(+
5330: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 65 76 (db:test-get-ev
5340: 65 6e 74 5f 74 69 6d 65 20 74 65 73 74 64 61 74 ent_time testdat
5350: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 64 62 )..... (db
5360: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 5f 64 75 :test-get-run_du
5370: 72 61 74 69 6f 6e 20 74 65 73 74 64 61 74 29 29 ration testdat))
5380: 29 0a 09 09 36 30 30 29 20 3b 3b 20 69 2e 65 2e )...600) ;; i.e.
5390: 20 6e 6f 20 75 70 64 61 74 65 20 66 6f 72 20 6d no update for m
53a0: 6f 72 65 20 74 68 61 6e 20 36 30 30 20 73 65 63 ore than 600 sec
53b0: 6f 6e 64 73 0a 09 20 20 20 20 20 28 62 65 67 69 onds.. (begi
53c0: 6e 0a 09 20 20 20 20 20 20 20 28 64 65 62 75 67 n.. (debug
53d0: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
53e0: 47 3a 20 54 65 73 74 20 22 20 74 65 73 74 2d 6e G: Test " test-n
53f0: 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 6f ame " appears to
5400: 20 62 65 20 64 65 61 64 2e 20 46 6f 72 63 69 6e be dead. Forcin
5410: 67 20 69 74 20 74 6f 20 73 74 61 74 65 20 49 4e g it to state IN
5420: 43 4f 4d 50 4c 45 54 45 20 61 6e 64 20 73 74 61 COMPLETE and sta
5430: 74 75 73 20 53 54 55 43 4b 2f 44 45 41 44 22 29 tus STUCK/DEAD")
5440: 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d 73 .. (test-s
5450: 65 74 2d 73 74 61 74 75 73 21 20 64 62 20 72 75 et-status! db ru
5460: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 22 n-id test-name "
5470: 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 53 54 55 INCOMPLETE" "STU
5480: 43 4b 2f 44 45 41 44 22 20 69 74 65 6d 64 61 74 CK/DEAD" itemdat
5490: 20 22 54 65 73 74 20 69 73 20 73 74 75 63 6b 20 "Test is stuck
54a0: 6f 72 20 64 65 61 64 22 20 23 66 29 29 0a 09 20 or dead" #f))..
54b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
54c0: 20 32 20 22 4e 4f 54 45 3a 20 22 20 74 65 73 74 2 "NOTE: " test
54d0: 2d 6e 61 6d 65 20 22 20 69 73 20 61 6c 72 65 61 -name " is alrea
54e0: 64 79 20 72 75 6e 6e 69 6e 67 22 29 29 29 0a 09 dy running")))..
54f0: 28 65 6c 73 65 20 20 20 20 20 20 20 28 64 65 62 (else (deb
5500: 75 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f ug:print 0 "ERRO
5510: 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 6c 61 75 R: Failed to lau
5520: 6e 63 68 20 74 65 73 74 20 22 20 6e 65 77 2d 74 nch test " new-t
5530: 65 73 74 2d 6e 61 6d 65 20 22 2e 20 55 6e 72 65 est-name ". Unre
5540: 63 6f 67 6e 69 73 65 64 20 73 74 61 74 65 20 22 cognised state "
5550: 20 28 74 65 73 74 3a 67 65 74 2d 73 74 61 74 65 (test:get-state
5560: 20 74 65 73 74 64 61 74 29 29 29 29 29 29 29 0a testdat))))))).
5570: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
5580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 4e 44 =========.;; END
55c0: 20 4f 46 20 4e 45 57 20 53 54 55 46 46 0a 3b 3b OF NEW STUFF.;;
55d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
55f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5610: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
5620: 28 67 65 74 2d 64 69 72 2d 75 70 2d 6e 20 64 69 (get-dir-up-n di
5630: 72 20 2e 20 70 61 72 61 6d 73 29 20 0a 20 20 28 r . params) . (
5640: 6c 65 74 20 28 28 64 70 61 72 74 73 20 20 28 73 let ((dparts (s
5650: 74 72 69 6e 67 2d 73 70 6c 69 74 20 64 69 72 20 tring-split dir
5660: 22 2f 22 29 29 0a 09 28 63 6f 75 6e 74 20 20 20 "/"))..(count
5670: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
5680: 73 29 20 31 20 28 63 61 72 20 70 61 72 61 6d 73 s) 1 (car params
5690: 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 22 )))). (conc "
56a0: 2f 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 /" (string-inter
56b0: 73 70 65 72 73 65 20 0a 09 20 20 20 20 20 20 20 sperse ..
56c0: 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 (take dparts (-
56d0: 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 (length dparts)
56e0: 63 6f 75 6e 74 29 29 0a 09 20 20 20 20 20 20 20 count))..
56f0: 22 2f 22 29 29 29 29 0a 3b 3b 20 52 65 6d 6f 76 "/")))).;; Remov
5700: 65 20 72 75 6e 73 0a 3b 3b 20 66 69 65 6c 64 73 e runs.;; fields
5710: 20 61 72 65 20 70 61 73 73 69 6e 67 20 69 6e 20 are passing in
5720: 74 68 72 6f 75 67 68 20 0a 28 64 65 66 69 6e 65 through .(define
5730: 20 28 72 75 6e 73 3a 72 65 6d 6f 76 65 2d 72 75 (runs:remove-ru
5740: 6e 73 20 64 62 20 72 75 6e 6e 61 6d 65 70 61 74 ns db runnamepat
5750: 74 20 74 65 73 74 70 61 74 74 20 69 74 65 6d 70 t testpatt itemp
5760: 61 74 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b att). (let* ((k
5770: 65 79 73 20 20 20 20 20 20 20 20 28 72 64 62 3a eys (rdb:
5780: 67 65 74 2d 6b 65 79 73 20 64 62 29 29 0a 09 20 get-keys db))..
5790: 28 72 75 6e 64 61 74 20 20 20 20 20 20 28 72 75 (rundat (ru
57a0: 6e 73 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 ns:get-runs-by-p
57b0: 61 74 74 20 64 62 20 6b 65 79 73 20 72 75 6e 6e att db keys runn
57c0: 61 6d 65 70 61 74 74 29 29 0a 09 20 28 68 65 61 amepatt)).. (hea
57d0: 64 65 72 20 20 20 20 20 20 28 76 65 63 74 6f 72 der (vector
57e0: 2d 72 65 66 20 72 75 6e 64 61 74 20 30 29 29 0a -ref rundat 0)).
57f0: 09 20 28 72 75 6e 73 20 20 20 20 20 20 20 20 28 . (runs (
5800: 76 65 63 74 6f 72 2d 72 65 66 20 72 75 6e 64 61 vector-ref runda
5810: 74 20 31 29 29 29 0a 20 20 20 20 28 64 65 62 75 t 1))). (debu
5820: 67 3a 70 72 69 6e 74 20 31 20 22 48 65 61 64 65 g:print 1 "Heade
5830: 72 3a 20 22 20 68 65 61 64 65 72 29 0a 20 20 20 r: " header).
5840: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
5850: 28 6c 61 6d 62 64 61 20 28 72 75 6e 29 0a 20 20 (lambda (run).
5860: 20 20 20 20 20 28 6c 65 74 20 28 28 72 75 6e 6b (let ((runk
5870: 65 79 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 ey (string-inter
5880: 73 70 65 72 73 65 20 28 6d 61 70 20 28 6c 61 6d sperse (map (lam
5890: 62 64 61 20 28 6b 29 0a 09 09 09 09 09 09 28 64 bda (k).......(d
58a0: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
58b0: 65 61 64 65 72 20 72 75 6e 20 68 65 61 64 65 72 eader run header
58c0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 6b 20 30 (vector-ref k 0
58d0: 29 29 29 20 6b 65 79 73 29 20 22 2f 22 29 29 0a ))) keys) "/")).
58e0: 09 20 20 20 20 20 28 64 69 72 73 2d 74 6f 2d 72 . (dirs-to-r
58f0: 65 6d 6f 76 65 20 28 6d 61 6b 65 2d 68 61 73 68 emove (make-hash
5900: 2d 74 61 62 6c 65 29 29 29 0a 09 20 28 6c 65 74 -table))).. (let
5910: 2a 20 28 28 72 75 6e 2d 69 64 20 28 64 62 3a 67 * ((run-id (db:g
5920: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
5930: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
5940: 64 22 29 20 29 0a 09 09 28 74 65 73 74 73 20 20 d") )...(tests
5950: 28 72 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 (rdb:get-tests-f
5960: 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 65 or-run db (db:ge
5970: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
5980: 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 64 r run header "id
5990: 22 29 20 74 65 73 74 70 61 74 74 20 69 74 65 6d ") testpatt item
59a0: 70 61 74 74 20 27 28 29 20 27 28 29 29 29 0a 09 patt '() '()))..
59b0: 09 28 6c 61 73 74 74 70 61 74 68 20 22 2f 64 6f .(lasttpath "/do
59c0: 65 73 2f 6e 6f 74 2f 65 78 69 73 74 2f 49 2f 68 es/not/exist/I/h
59d0: 6f 70 65 22 29 29 0a 0a 09 20 20 20 28 69 66 20 ope"))... (if
59e0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 65 73 74 (not (null? test
59f0: 73 29 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 s)).. (beg
5a00: 69 6e 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 in... (debug:pri
5a10: 6e 74 20 31 20 22 52 65 6d 6f 76 69 6e 67 20 74 nt 1 "Removing t
5a20: 65 73 74 73 20 66 6f 72 20 72 75 6e 3a 20 22 20 ests for run: "
5a30: 72 75 6e 6b 65 79 20 22 20 22 20 28 64 62 3a 67 runkey " " (db:g
5a40: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
5a50: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 72 er run header "r
5a60: 75 6e 6e 61 6d 65 22 29 29 0a 09 09 20 28 66 6f unname"))... (fo
5a70: 72 2d 65 61 63 68 0a 09 09 20 20 28 6c 61 6d 62 r-each... (lamb
5a80: 64 61 20 28 74 65 73 74 29 0a 09 09 20 20 20 20 da (test)...
5a90: 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 (let* ((item-pat
5aa0: 68 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 h (db:test-get-i
5ab0: 74 65 6d 2d 70 61 74 68 20 74 65 73 74 29 29 0a tem-path test)).
5ac0: 09 09 09 20 20 20 28 74 65 73 74 2d 6e 61 6d 65 ... (test-name
5ad0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 (db:test-get-te
5ae0: 73 74 6e 61 6d 65 20 74 65 73 74 29 29 0a 09 09 stname test))...
5af0: 09 20 20 20 28 72 75 6e 2d 64 69 72 20 20 20 28 . (run-dir (
5b00: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
5b10: 69 72 20 74 65 73 74 29 29 29 0a 09 09 20 20 20 ir test)))...
5b20: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
5b30: 31 20 22 20 20 22 20 28 64 62 3a 74 65 73 74 2d 1 " " (db:test-
5b40: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
5b50: 74 29 20 22 20 69 64 3a 20 22 20 28 64 62 3a 74 t) " id: " (db:t
5b60: 65 73 74 2d 67 65 74 2d 69 64 20 74 65 73 74 29 est-get-id test)
5b70: 20 22 20 22 20 69 74 65 6d 2d 70 61 74 68 29 0a " " item-path).
5b80: 09 09 20 20 20 20 20 20 28 72 64 62 3a 64 65 6c .. (rdb:del
5b90: 65 74 65 2d 74 65 73 74 2d 72 65 63 6f 72 64 73 ete-test-records
5ba0: 20 64 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 db (db:test-get
5bb0: 2d 69 64 20 74 65 73 74 29 29 0a 09 09 20 20 20 -id test))...
5bc0: 20 20 20 28 69 66 20 28 3e 20 28 73 74 72 69 6e (if (> (strin
5bd0: 67 2d 6c 65 6e 67 74 68 20 72 75 6e 2d 64 69 72 g-length run-dir
5be0: 29 20 35 29 20 3b 3b 20 62 61 64 20 68 65 75 72 ) 5) ;; bad heur
5bf0: 69 73 74 69 63 20 62 75 74 20 73 68 6f 75 6c 64 istic but should
5c00: 20 70 72 65 76 65 6e 74 20 2f 74 6d 70 20 2f 68 prevent /tmp /h
5c10: 6f 6d 65 20 65 74 63 2e 0a 09 09 09 20 20 28 6c ome etc..... (l
5c20: 65 74 20 28 28 66 75 6c 6c 70 61 74 68 20 72 75 et ((fullpath ru
5c30: 6e 2d 64 69 72 29 29 20 3b 3b 20 22 2f 22 20 28 n-dir)) ;; "/" (
5c40: 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 65 6d db:test-get-item
5c50: 2d 70 61 74 68 20 74 65 73 74 29 29 29 29 0a 09 -path test))))..
5c60: 09 09 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 .. (set! last
5c70: 74 70 61 74 68 20 66 75 6c 6c 70 61 74 68 29 0a tpath fullpath).
5c80: 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
5c90: 6c 65 2d 73 65 74 21 20 64 69 72 73 2d 74 6f 2d le-set! dirs-to-
5ca0: 72 65 6d 6f 76 65 20 66 75 6c 6c 70 61 74 68 20 remove fullpath
5cb0: 23 74 29 0a 09 09 09 20 20 20 20 3b 3b 20 54 68 #t).... ;; Th
5cc0: 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 77 61 73 20 e following was
5cd0: 74 68 65 20 73 61 66 65 20 64 65 6c 65 74 65 20 the safe delete
5ce0: 63 6f 64 65 20 62 75 74 20 69 74 20 77 61 73 20 code but it was
5cf0: 6e 6f 74 20 62 65 69 6e 67 20 65 78 65 63 74 75 not being exectu
5d00: 74 65 64 2e 0a 09 09 09 20 20 20 20 3b 3b 20 28 ted..... ;; (
5d10: 6c 65 74 2a 20 28 28 64 69 72 73 2d 63 6f 75 6e let* ((dirs-coun
5d20: 74 20 28 2b 20 31 20 28 6c 65 6e 67 74 68 20 6b t (+ 1 (length k
5d30: 65 79 73 29 28 6c 65 6e 67 74 68 20 28 73 74 72 eys)(length (str
5d40: 69 6e 67 2d 73 70 6c 69 74 20 69 74 65 6d 2d 70 ing-split item-p
5d50: 61 74 68 20 22 2f 22 29 29 29 29 0a 09 09 09 20 ath "/"))))....
5d60: 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 64 69 ;; (di
5d70: 72 2d 74 6f 2d 72 65 6d 20 28 67 65 74 2d 64 69 r-to-rem (get-di
5d80: 72 2d 75 70 2d 6e 20 66 75 6c 6c 70 61 74 68 20 r-up-n fullpath
5d90: 64 69 72 73 2d 63 6f 75 6e 74 29 29 0a 09 09 09 dirs-count))....
5da0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 72 ;; (r
5db0: 65 6d 61 69 6e 69 6e 67 64 20 28 73 74 72 69 6e emainingd (strin
5dc0: 67 2d 73 75 62 73 74 69 74 75 74 65 20 28 72 65 g-substitute (re
5dd0: 67 65 78 70 20 28 63 6f 6e 63 20 22 5e 22 20 64 gexp (conc "^" d
5de0: 69 72 2d 74 6f 2d 72 65 6d 20 22 2f 22 29 29 20 ir-to-rem "/"))
5df0: 22 22 20 66 75 6c 6c 70 61 74 68 29 29 0a 09 09 "" fullpath))...
5e00: 09 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 . ;; (
5e10: 63 6d 64 20 28 63 6f 6e 63 20 22 63 64 20 22 20 cmd (conc "cd "
5e20: 64 69 72 2d 74 6f 2d 72 65 6d 20 22 3b 20 72 6d dir-to-rem "; rm
5e30: 64 69 72 20 2d 70 20 22 20 72 65 6d 61 69 6e 69 dir -p " remaini
5e40: 6e 67 64 20 29 29 29 0a 09 09 09 20 20 20 20 3b ngd ))).... ;
5e50: 3b 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 ; (if (file-ex
5e60: 69 73 74 73 3f 20 66 75 6c 6c 70 61 74 68 29 0a ists? fullpath).
5e70: 09 09 09 20 20 20 20 3b 3b 20 20 20 20 20 20 20 ... ;;
5e80: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 3b 3b (begin.... ;;
5e90: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
5ea0: 70 72 69 6e 74 20 31 20 63 6d 64 29 0a 09 09 09 print 1 cmd)....
5eb0: 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 28 ;; (
5ec0: 73 79 73 74 65 6d 20 63 6d 64 29 29 29 0a 09 09 system cmd)))...
5ed0: 09 20 20 20 20 3b 3b 20 20 20 29 29 0a 09 09 09 . ;; ))....
5ee0: 20 20 20 20 29 29 29 29 0a 09 09 20 20 20 20 74 ))))... t
5ef0: 65 73 74 73 29 29 29 0a 0a 09 20 20 20 3b 3b 20 ests)))... ;;
5f00: 6c 6f 6f 6b 20 74 68 6f 75 67 68 20 74 68 65 20 look though the
5f10: 64 69 72 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 66 dirs-to-remove f
5f20: 6f 72 20 63 61 6e 64 69 64 61 74 65 73 20 66 6f or candidates fo
5f30: 72 20 72 65 6d 6f 76 61 6c 2e 20 44 6f 20 74 68 r removal. Do th
5f40: 69 73 20 61 66 74 65 72 20 64 65 6c 65 74 69 6e is after deletin
5f50: 67 20 74 68 65 20 72 65 63 6f 72 64 73 0a 09 20 g the records..
5f60: 20 20 3b 3b 20 66 6f 72 20 65 61 63 68 20 74 65 ;; for each te
5f70: 73 74 20 69 6e 20 63 61 73 65 20 77 65 20 67 65 st in case we ge
5f80: 74 20 6b 69 6c 6c 65 64 2e 20 54 68 61 74 20 73 t killed. That s
5f90: 68 6f 75 6c 64 20 6d 69 6e 69 6d 69 7a 65 20 74 hould minimize t
5fa0: 68 65 20 64 65 74 72 69 74 75 73 20 6c 65 66 74 he detritus left
5fb0: 20 6f 6e 20 64 69 73 6b 0a 09 20 20 20 3b 3b 20 on disk.. ;;
5fc0: 70 72 6f 63 65 73 73 20 74 68 65 20 64 69 72 73 process the dirs
5fd0: 20 66 72 6f 6d 20 6c 6f 6e 67 65 73 74 20 73 74 from longest st
5fe0: 72 69 6e 67 20 6c 65 6e 67 74 68 20 74 6f 20 73 ring length to s
5ff0: 68 6f 72 74 65 73 74 0a 09 20 20 20 28 66 6f 72 hortest.. (for
6000: 2d 65 61 63 68 20 0a 09 20 20 20 20 28 6c 61 6d -each .. (lam
6010: 62 64 61 20 28 64 69 72 2d 74 6f 2d 72 65 6d 6f bda (dir-to-remo
6020: 76 65 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 ve).. (if (
6030: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 69 72 file-exists? dir
6040: 2d 74 6f 2d 72 65 6d 6f 76 65 29 0a 09 09 20 20 -to-remove)...
6050: 28 6c 65 74 20 28 28 64 69 72 2d 69 6e 2d 64 62 (let ((dir-in-db
6060: 20 27 28 29 29 29 0a 09 09 20 20 20 20 28 73 71 '()))... (sq
6070: 6c 69 74 65 33 3a 66 6f 72 2d 65 61 63 68 2d 72 lite3:for-each-r
6080: 6f 77 0a 09 09 20 20 20 20 20 28 6c 61 6d 62 64 ow... (lambd
6090: 61 20 28 64 69 72 29 0a 09 09 20 20 20 20 20 20 a (dir)...
60a0: 20 28 73 65 74 21 20 64 69 72 2d 69 6e 2d 64 62 (set! dir-in-db
60b0: 20 28 63 6f 6e 73 20 64 69 72 20 64 69 72 2d 69 (cons dir dir-i
60c0: 6e 2d 64 62 29 29 29 0a 09 09 20 20 20 20 20 64 n-db)))... d
60d0: 62 20 22 53 45 4c 45 43 54 20 72 75 6e 64 69 72 b "SELECT rundir
60e0: 20 46 52 4f 4d 20 74 65 73 74 73 20 57 48 45 52 FROM tests WHER
60f0: 45 20 72 75 6e 64 69 72 20 4c 49 4b 45 20 3f 3b E rundir LIKE ?;
6100: 22 20 0a 09 09 20 20 20 20 20 28 63 6f 6e 63 20 " ... (conc
6110: 22 25 22 20 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 "%" dir-to-remov
6120: 65 20 22 25 22 29 29 20 3b 3b 20 79 65 73 2c 20 e "%")) ;; yes,
6130: 49 27 6d 20 67 6f 69 6e 67 20 74 6f 20 62 61 69 I'm going to bai
6140: 6c 20 69 66 20 74 68 65 72 65 20 69 73 20 61 6e l if there is an
6150: 79 74 68 69 6e 67 20 6c 69 6b 65 20 74 68 69 73 ything like this
6160: 20 64 69 72 20 69 6e 20 74 68 65 20 64 62 0a 09 dir in the db..
6170: 09 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
6180: 64 69 72 2d 69 6e 2d 64 62 29 0a 09 09 09 28 62 dir-in-db)....(b
6190: 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 egin.... (debug
61a0: 3a 70 72 69 6e 74 20 32 20 22 52 65 6d 6f 76 69 :print 2 "Removi
61b0: 6e 67 20 64 69 72 65 63 74 6f 72 79 20 77 69 74 ng directory wit
61c0: 68 20 7a 65 72 6f 20 64 62 20 72 65 66 65 72 65 h zero db refere
61d0: 6e 63 65 73 3a 20 22 20 64 69 72 2d 74 6f 2d 72 nces: " dir-to-r
61e0: 65 6d 6f 76 65 29 0a 09 09 09 20 20 28 73 79 73 emove).... (sys
61f0: 74 65 6d 20 28 63 6f 6e 63 20 22 72 6d 20 2d 72 tem (conc "rm -r
6200: 66 20 22 20 64 69 72 2d 74 6f 2d 72 65 6d 6f 76 f " dir-to-remov
6210: 65 29 29 0a 09 09 09 20 20 28 68 61 73 68 2d 74 e)).... (hash-t
6220: 61 62 6c 65 2d 64 65 6c 65 74 65 21 20 64 69 72 able-delete! dir
6230: 73 2d 74 6f 2d 72 65 6d 6f 76 65 20 64 69 72 2d s-to-remove dir-
6240: 74 6f 2d 72 65 6d 6f 76 65 29 29 0a 09 09 09 28 to-remove))....(
6250: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 53 debug:print 2 "S
6260: 6b 69 70 70 69 6e 67 20 72 65 6d 6f 76 61 6c 20 kipping removal
6270: 6f 66 20 22 20 64 69 72 2d 74 6f 2d 72 65 6d 6f of " dir-to-remo
6280: 76 65 20 22 20 66 6f 72 20 6e 6f 77 20 61 73 20 ve " for now as
6290: 69 74 20 73 74 69 6c 6c 20 68 61 73 20 72 65 66 it still has ref
62a0: 65 72 65 6e 63 65 73 20 69 6e 20 74 68 65 20 64 erences in the d
62b0: 61 74 61 62 61 73 65 22 29 29 29 29 29 0a 09 20 atabase")))))..
62c0: 20 20 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 (sort (hash-t
62d0: 61 62 6c 65 2d 6b 65 79 73 20 64 69 72 73 2d 74 able-keys dirs-t
62e0: 6f 2d 72 65 6d 6f 76 65 29 20 28 6c 61 6d 62 64 o-remove) (lambd
62f0: 61 20 28 61 20 62 29 28 3e 20 28 73 74 72 69 6e a (a b)(> (strin
6300: 67 2d 6c 65 6e 67 74 68 20 61 29 28 73 74 72 69 g-length a)(stri
6310: 6e 67 2d 6c 65 6e 67 74 68 20 62 29 29 29 29 29 ng-length b)))))
6320: 0a 0a 09 20 20 20 3b 3b 20 72 65 6d 6f 76 65 20 ... ;; remove
6330: 74 68 65 20 72 75 6e 20 69 66 20 7a 65 72 6f 20 the run if zero
6340: 74 65 73 74 73 20 72 65 6d 61 69 6e 0a 09 20 20 tests remain..
6350: 20 28 6c 65 74 20 28 28 72 65 6d 74 65 73 74 73 (let ((remtests
6360: 20 28 72 64 62 3a 67 65 74 2d 74 65 73 74 73 2d (rdb:get-tests-
6370: 66 6f 72 2d 72 75 6e 20 64 62 20 28 64 62 3a 67 for-run db (db:g
6380: 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 et-value-by-head
6390: 65 72 20 72 75 6e 20 68 65 61 64 65 72 20 22 69 er run header "i
63a0: 64 22 29 20 23 66 20 23 66 20 27 28 29 20 27 28 d") #f #f '() '(
63b0: 29 29 29 29 0a 09 20 20 20 20 20 28 69 66 20 28 )))).. (if (
63c0: 6e 75 6c 6c 3f 20 72 65 6d 74 65 73 74 73 29 20 null? remtests)
63d0: 3b 3b 20 6e 6f 20 6d 6f 72 65 20 74 65 73 74 73 ;; no more tests
63e0: 20 72 65 6d 61 69 6e 69 6e 67 0a 09 09 20 28 6c remaining... (l
63f0: 65 74 2a 20 28 28 64 70 61 72 74 73 20 20 28 73 et* ((dparts (s
6400: 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 73 74 tring-split last
6410: 74 70 61 74 68 20 22 2f 22 29 29 0a 09 09 09 28 tpath "/"))....(
6420: 72 75 6e 70 61 74 68 20 28 63 6f 6e 63 20 22 2f runpath (conc "/
6430: 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 " (string-inters
6440: 70 65 72 73 65 20 0a 09 09 09 09 09 20 20 20 20 perse ......
6450: 28 74 61 6b 65 20 64 70 61 72 74 73 20 28 2d 20 (take dparts (-
6460: 28 6c 65 6e 67 74 68 20 64 70 61 72 74 73 29 20 (length dparts)
6470: 31 29 29 0a 09 09 09 09 09 20 20 20 20 22 2f 22 1))...... "/"
6480: 29 29 29 29 0a 09 09 20 20 20 28 64 65 62 75 67 ))))... (debug
6490: 3a 70 72 69 6e 74 20 31 20 22 52 65 6d 6f 76 69 :print 1 "Removi
64a0: 6e 67 20 72 75 6e 3a 20 22 20 72 75 6e 6b 65 79 ng run: " runkey
64b0: 20 22 20 22 20 28 64 62 3a 67 65 74 2d 76 61 6c " " (db:get-val
64c0: 75 65 2d 62 79 2d 68 65 61 64 65 72 20 72 75 6e ue-by-header run
64d0: 20 68 65 61 64 65 72 20 22 72 75 6e 6e 61 6d 65 header "runname
64e0: 22 29 29 0a 09 09 20 20 20 28 64 62 3a 64 65 6c "))... (db:del
64f0: 65 74 65 2d 72 75 6e 20 64 62 20 72 75 6e 2d 69 ete-run db run-i
6500: 64 29 0a 09 09 20 20 20 3b 3b 20 6e 65 65 64 20 d)... ;; need
6510: 74 6f 20 66 69 67 75 72 65 20 6f 75 74 20 74 68 to figure out th
6520: 65 20 70 61 74 68 20 74 6f 20 74 68 65 20 72 75 e path to the ru
6530: 6e 20 64 69 72 20 61 6e 64 20 72 65 6d 6f 76 65 n dir and remove
6540: 20 69 74 20 69 66 20 65 6d 70 74 79 0a 09 09 20 it if empty...
6550: 20 20 3b 3b 20 20 20 20 28 69 66 20 28 6e 75 6c ;; (if (nul
6560: 6c 3f 20 28 67 6c 6f 62 20 28 63 6f 6e 63 20 72 l? (glob (conc r
6570: 75 6e 70 61 74 68 20 22 2f 2a 22 29 29 29 0a 09 unpath "/*")))..
6580: 09 20 20 20 3b 3b 20 20 20 20 20 20 20 20 28 62 . ;; (b
6590: 65 67 69 6e 0a 09 09 20 20 20 3b 3b 20 09 20 28 egin... ;; . (
65a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 52 debug:print 1 "R
65b0: 65 6d 6f 76 69 6e 67 20 72 75 6e 20 64 69 72 20 emoving run dir
65c0: 22 20 72 75 6e 70 61 74 68 29 0a 09 09 20 20 20 " runpath)...
65d0: 3b 3b 20 09 20 28 73 79 73 74 65 6d 20 28 63 6f ;; . (system (co
65e0: 6e 63 20 22 72 6d 64 69 72 20 2d 70 20 22 20 72 nc "rmdir -p " r
65f0: 75 6e 70 61 74 68 29 29 29 29 0a 09 09 20 20 20 unpath))))...
6600: 29 29 29 29 0a 09 20 29 29 0a 20 20 20 20 20 72 )))).. )). r
6610: 75 6e 73 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d uns)))..;;======
6620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6660: 0a 3b 3b 20 52 6f 75 74 69 6e 65 73 20 66 6f 72 .;; Routines for
6670: 20 6d 61 6e 69 70 75 6c 61 74 69 6e 67 20 72 75 manipulating ru
6680: 6e 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ns.;;===========
6690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
66d0: 53 69 6e 63 65 20 6d 61 6e 79 20 63 61 6c 6c 73 Since many calls
66e0: 20 74 6f 20 61 20 72 75 6e 20 72 65 71 75 69 72 to a run requir
66f0: 65 20 70 72 65 74 74 79 20 6d 75 63 68 20 74 68 e pretty much th
6700: 65 20 73 61 6d 65 20 73 65 74 75 70 20 0a 3b 3b e same setup .;;
6710: 20 74 68 69 73 20 77 72 61 70 70 65 72 20 69 73 this wrapper is
6720: 20 75 73 65 64 20 74 6f 20 72 65 64 75 63 65 20 used to reduce
6730: 74 68 65 20 72 65 70 6c 69 63 61 74 69 6f 6e 20 the replication
6740: 6f 66 20 63 6f 64 65 0a 28 64 65 66 69 6e 65 20 of code.(define
6750: 28 67 65 6e 65 72 61 6c 2d 72 75 6e 2d 63 61 6c (general-run-cal
6760: 6c 20 73 77 69 74 63 68 6e 61 6d 65 20 61 63 74 l switchname act
6770: 69 6f 6e 2d 64 65 73 63 20 70 72 6f 63 29 0a 20 ion-desc proc).
6780: 20 28 6c 65 74 20 28 28 72 75 6e 6e 61 6d 65 20 (let ((runname
6790: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
67a0: 72 75 6e 6e 61 6d 65 22 29 29 0a 09 28 74 61 72 runname"))..(tar
67b0: 67 65 74 20 20 28 69 66 20 28 61 72 67 73 3a 67 get (if (args:g
67c0: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
67d0: 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 )... (args:g
67e0: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
67f0: 29 0a 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 )... (args:g
6800: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
6810: 22 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a ")))). (cond.
6820: 20 20 20 20 20 28 28 6e 6f 74 20 74 61 72 67 65 ((not targe
6830: 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a t). (debug:
6840: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
6850: 4d 69 73 73 69 6e 67 20 72 65 71 75 69 72 65 64 Missing required
6860: 20 70 61 72 61 6d 65 74 65 72 20 66 6f 72 20 22 parameter for "
6870: 20 73 77 69 74 63 68 6e 61 6d 65 20 22 2c 20 79 switchname ", y
6880: 6f 75 20 6d 75 73 74 20 73 70 65 63 69 66 79 20 ou must specify
6890: 74 68 65 20 74 61 72 67 65 74 20 77 69 74 68 20 the target with
68a0: 2d 74 61 72 67 65 74 22 29 0a 20 20 20 20 20 20 -target").
68b0: 28 65 78 69 74 20 33 29 29 0a 20 20 20 20 20 28 (exit 3)). (
68c0: 28 6e 6f 74 20 72 75 6e 6e 61 6d 65 29 0a 20 20 (not runname).
68d0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
68e0: 20 30 20 22 45 52 52 4f 52 3a 20 4d 69 73 73 69 0 "ERROR: Missi
68f0: 6e 67 20 72 65 71 75 69 72 65 64 20 70 61 72 61 ng required para
6900: 6d 65 74 65 72 20 66 6f 72 20 22 20 73 77 69 74 meter for " swit
6910: 63 68 6e 61 6d 65 20 22 2c 20 79 6f 75 20 6d 75 chname ", you mu
6920: 73 74 20 73 70 65 63 69 66 79 20 74 68 65 20 72 st specify the r
6930: 75 6e 20 6e 61 6d 65 20 77 69 74 68 20 3a 72 75 un name with :ru
6940: 6e 6e 61 6d 65 20 72 75 6e 6e 61 6d 65 22 29 0a nname runname").
6950: 20 20 20 20 20 20 28 65 78 69 74 20 33 29 29 0a (exit 3)).
6960: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
6970: 20 28 6c 65 74 20 28 28 64 62 20 20 20 23 66 29 (let ((db #f)
6980: 0a 09 20 20 20 20 28 6b 65 79 73 20 23 66 29 29 .. (keys #f))
6990: 0a 09 28 69 66 20 28 6e 6f 74 20 28 73 65 74 75 ..(if (not (setu
69a0: 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 p-for-run))..
69b0: 20 28 62 65 67 69 6e 20 0a 09 20 20 20 20 20 20 (begin ..
69c0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
69d0: 46 61 69 6c 65 64 20 74 6f 20 73 65 74 75 70 2c Failed to setup,
69e0: 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 exiting")..
69f0: 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 73 (exit 1)))..(s
6a00: 65 74 21 20 64 62 20 20 20 28 6f 70 65 6e 2d 64 et! db (open-d
6a10: 62 29 29 0a 09 28 69 66 20 28 6e 6f 74 20 28 61 b))..(if (not (a
6a20: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 rgs:get-arg "-se
6a30: 72 76 65 72 22 29 29 0a 09 20 20 20 20 28 73 65 rver")).. (se
6a40: 72 76 65 72 3a 63 6c 69 65 6e 74 2d 73 65 74 75 rver:client-setu
6a50: 70 20 64 62 29 29 0a 09 28 73 65 74 21 20 6b 65 p db))..(set! ke
6a60: 79 73 20 28 72 64 62 3a 67 65 74 2d 6b 65 79 73 ys (rdb:get-keys
6a70: 20 64 62 29 29 0a 09 3b 3b 20 68 61 76 65 20 65 db))..;; have e
6a80: 6e 6f 75 67 68 20 74 6f 20 70 72 6f 63 65 73 73 nough to process
6a90: 20 2d 74 61 72 67 65 74 20 6f 72 20 2d 72 65 71 -target or -req
6aa0: 74 61 72 67 20 68 65 72 65 0a 09 28 69 66 20 28 targ here..(if (
6ab0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
6ac0: 65 71 74 61 72 67 22 29 0a 09 20 20 20 20 28 6c eqtarg").. (l
6ad0: 65 74 2a 20 28 28 72 75 6e 63 6f 6e 66 69 67 66 et* ((runconfigf
6ae0: 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 68 (conc *toppath
6af0: 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 * "/runconfigs.c
6b00: 6f 6e 66 69 67 22 29 29 20 3b 3b 20 44 4f 20 4e onfig")) ;; DO N
6b10: 4f 54 20 45 56 41 4c 55 41 54 45 20 41 4c 4c 20 OT EVALUATE ALL
6b20: 0a 09 09 20 20 20 28 72 75 6e 63 6f 6e 66 69 67 ... (runconfig
6b30: 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 72 (read-config r
6b40: 75 6e 63 6f 6e 66 69 67 66 20 23 66 20 23 66 20 unconfigf #f #f
6b50: 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 23 66 environ-patt: #f
6b60: 29 29 29 20 0a 09 20 20 20 20 20 20 28 69 66 20 ))) .. (if
6b70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
6b80: 64 65 66 61 75 6c 74 20 72 75 6e 63 6f 6e 66 69 default runconfi
6b90: 67 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 g (args:get-arg
6ba0: 22 2d 72 65 71 74 61 72 67 22 29 20 23 66 29 0a "-reqtarg") #f).
6bb0: 09 09 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 .. (keys:target
6bc0: 2d 73 65 74 2d 61 72 67 73 20 6b 65 79 73 20 28 -set-args keys (
6bd0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
6be0: 65 71 74 61 72 67 22 29 20 61 72 67 73 3a 61 72 eqtarg") args:ar
6bf0: 67 2d 68 61 73 68 29 0a 09 09 20 20 28 62 65 67 g-hash)... (beg
6c00: 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a in... (debug:
6c10: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR:
6c20: 5b 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 [" (args:get-arg
6c30: 20 22 2d 72 65 71 74 61 72 67 22 29 20 22 5d 20 "-reqtarg") "]
6c40: 6e 6f 74 20 66 6f 75 6e 64 20 69 6e 20 22 20 72 not found in " r
6c50: 75 6e 63 6f 6e 66 69 67 66 29 0a 09 09 20 20 20 unconfigf)...
6c60: 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 (sqlite3:finali
6c70: 7a 65 21 20 64 62 29 0a 09 09 20 20 20 20 28 65 ze! db)... (e
6c80: 78 69 74 20 31 29 29 29 29 0a 09 20 20 20 20 28 xit 1)))).. (
6c90: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
6ca0: 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 28 6b "-target")...(k
6cb0: 65 79 73 3a 74 61 72 67 65 74 2d 73 65 74 2d 61 eys:target-set-a
6cc0: 72 67 73 20 6b 65 79 73 20 28 61 72 67 73 3a 67 rgs keys (args:g
6cd0: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
6ce0: 20 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 20 args:arg-hash)
6cf0: 61 72 67 73 3a 61 72 67 2d 68 61 73 68 29 29 29 args:arg-hash)))
6d00: 0a 09 28 69 66 20 28 6e 6f 74 20 28 63 61 72 20 ..(if (not (car
6d10: 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 29 0a 09 *configinfo*))..
6d20: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
6d30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
6d40: 20 22 45 52 52 4f 52 3a 20 41 74 74 65 6d 70 74 "ERROR: Attempt
6d50: 65 64 20 74 6f 20 22 20 61 63 74 69 6f 6e 2d 64 ed to " action-d
6d60: 65 73 63 20 22 20 62 75 74 20 72 75 6e 20 61 72 esc " but run ar
6d70: 65 61 20 63 6f 6e 66 69 67 20 66 69 6c 65 20 6e ea config file n
6d80: 6f 74 20 66 6f 75 6e 64 22 29 0a 09 20 20 20 20 ot found")..
6d90: 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 (exit 1))..
6da0: 20 3b 3b 20 45 78 74 72 61 63 74 20 6f 75 74 20 ;; Extract out
6db0: 73 74 75 66 66 20 6e 65 65 64 65 64 20 69 6e 20 stuff needed in
6dc0: 6d 6f 73 74 20 6f 72 20 6d 61 6e 79 20 63 61 6c most or many cal
6dd0: 6c 73 0a 09 20 20 20 20 3b 3b 20 68 65 72 65 20 ls.. ;; here
6de0: 74 68 65 6e 20 63 61 6c 6c 20 70 72 6f 63 0a 09 then call proc..
6df0: 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 6e (let* ((keyn
6e00: 61 6d 65 73 20 20 20 28 6d 61 70 20 6b 65 79 3a ames (map key:
6e10: 67 65 74 2d 66 69 65 6c 64 6e 61 6d 65 20 6b 65 get-fieldname ke
6e20: 79 73 29 29 0a 09 09 20 20 20 28 6b 65 79 76 61 ys))... (keyva
6e30: 6c 6c 73 74 20 20 28 6b 65 79 73 2d 3e 76 61 6c llst (keys->val
6e40: 6c 69 73 74 20 6b 65 79 73 20 23 74 29 29 29 0a list keys #t))).
6e50: 09 20 20 20 20 20 20 28 70 72 6f 63 20 64 62 20 . (proc db
6e60: 74 61 72 67 65 74 20 72 75 6e 6e 61 6d 65 20 6b target runname k
6e70: 65 79 73 20 6b 65 79 6e 61 6d 65 73 20 6b 65 79 eys keynames key
6e80: 76 61 6c 6c 73 74 29 29 29 0a 09 28 73 71 6c 69 vallst)))..(sqli
6e90: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
6ea0: 29 0a 09 28 73 65 74 21 20 2a 64 69 64 73 6f 6d )..(set! *didsom
6eb0: 65 74 68 69 6e 67 2a 20 23 74 29 29 29 29 29 29 ething* #t))))))
6ec0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
6ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 52 6f ==========.;; Ro
6f10: 6c 6c 75 70 20 72 75 6e 73 0a 3b 3b 3d 3d 3d 3d llup runs.;;====
6f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f60: 3d 3d 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 68 ==..;; Update th
6f70: 65 20 74 65 73 74 5f 6d 65 74 61 20 74 61 62 6c e test_meta tabl
6f80: 65 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 0a e for this test.
6f90: 28 64 65 66 69 6e 65 20 28 72 75 6e 73 3a 75 70 (define (runs:up
6fa0: 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 date-test_meta d
6fb0: 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 b test-name test
6fc0: 2d 63 6f 6e 66 29 0a 20 20 28 6c 65 74 20 28 28 -conf). (let ((
6fd0: 63 75 72 72 72 65 63 6f 72 64 20 28 64 62 3a 74 currrecord (db:t
6fe0: 65 73 74 6d 65 74 61 2d 67 65 74 2d 72 65 63 6f estmeta-get-reco
6ff0: 72 64 20 64 62 20 74 65 73 74 2d 6e 61 6d 65 29 rd db test-name)
7000: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 )). (if (not
7010: 63 75 72 72 72 65 63 6f 72 64 29 0a 09 28 62 65 currrecord)..(be
7020: 67 69 6e 0a 09 20 20 28 73 65 74 21 20 63 75 72 gin.. (set! cur
7030: 72 72 65 63 6f 72 64 20 28 6d 61 6b 65 2d 76 65 rrecord (make-ve
7040: 63 74 6f 72 20 31 30 20 23 66 29 29 0a 09 20 20 ctor 10 #f))..
7050: 28 64 62 3a 74 65 73 74 6d 65 74 61 2d 61 64 64 (db:testmeta-add
7060: 2d 72 65 63 6f 72 64 20 64 62 20 74 65 73 74 2d -record db test-
7070: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 66 6f 72 name))). (for
7080: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
7090: 62 64 61 20 28 6b 65 79 29 0a 20 20 20 20 20 20 bda (key).
70a0: 20 28 6c 65 74 2a 20 28 28 69 64 78 20 28 63 61 (let* ((idx (ca
70b0: 64 72 20 6b 65 79 29 29 0a 09 20 20 20 20 20 20 dr key))..
70c0: 28 66 6c 64 20 28 63 61 72 20 20 6b 65 79 29 29 (fld (car key))
70d0: 0a 09 20 20 20 20 20 20 28 76 61 6c 20 28 63 6f .. (val (co
70e0: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 nfig-lookup test
70f0: 2d 63 6f 6e 66 20 22 74 65 73 74 5f 6d 65 74 61 -conf "test_meta
7100: 22 20 66 6c 64 29 29 29 0a 09 20 3b 3b 20 28 64 " fld))).. ;; (d
7110: 65 62 75 67 3a 70 72 69 6e 74 20 35 20 22 69 64 ebug:print 5 "id
7120: 78 3a 20 22 20 69 64 78 20 22 20 66 6c 64 3a 20 x: " idx " fld:
7130: 22 20 66 6c 64 20 22 20 76 61 6c 3a 20 22 20 76 " fld " val: " v
7140: 61 6c 29 0a 09 20 28 69 66 20 28 61 6e 64 20 76 al).. (if (and v
7150: 61 6c 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 al (not (equal?
7160: 28 76 65 63 74 6f 72 2d 72 65 66 20 63 75 72 72 (vector-ref curr
7170: 72 65 63 6f 72 64 20 69 64 78 29 20 76 61 6c 29 record idx) val)
7180: 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a )).. (begin.
7190: 09 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 . (print "
71a0: 55 70 64 61 74 69 6e 67 20 22 20 74 65 73 74 2d Updating " test-
71b0: 6e 61 6d 65 20 22 20 22 20 66 6c 64 20 22 20 74 name " " fld " t
71c0: 6f 20 22 20 76 61 6c 29 0a 09 20 20 20 20 20 20 o " val)..
71d0: 20 28 64 62 3a 74 65 73 74 6d 65 74 61 2d 75 70 (db:testmeta-up
71e0: 64 61 74 65 2d 66 69 65 6c 64 20 64 62 20 74 65 date-field db te
71f0: 73 74 2d 6e 61 6d 65 20 66 6c 64 20 76 61 6c 29 st-name fld val)
7200: 29 29 29 29 0a 20 20 20 20 20 27 28 28 22 61 75 )))). '(("au
7210: 74 68 6f 72 22 20 32 29 28 22 6f 77 6e 65 72 22 thor" 2)("owner"
7220: 20 33 29 28 22 64 65 73 63 72 69 70 74 69 6f 6e 3)("description
7230: 22 20 34 29 28 22 72 65 76 69 65 77 65 64 22 20 " 4)("reviewed"
7240: 35 29 28 22 74 61 67 73 22 20 39 29 29 29 29 29 5)("tags" 9)))))
7250: 0a 0a 3b 3b 20 55 70 64 61 74 65 20 74 65 73 74 ..;; Update test
7260: 5f 6d 65 74 61 20 66 6f 72 20 61 6c 6c 20 74 65 _meta for all te
7270: 73 74 73 0a 28 64 65 66 69 6e 65 20 28 72 75 6e sts.(define (run
7280: 73 3a 75 70 64 61 74 65 2d 61 6c 6c 2d 74 65 73 s:update-all-tes
7290: 74 5f 6d 65 74 61 20 64 62 29 0a 20 20 28 6c 65 t_meta db). (le
72a0: 74 20 28 28 74 65 73 74 2d 6e 61 6d 65 73 20 28 t ((test-names (
72b0: 67 65 74 2d 61 6c 6c 2d 6c 65 67 61 6c 2d 74 65 get-all-legal-te
72c0: 73 74 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d sts))). (for-
72d0: 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
72e0: 64 61 20 28 74 65 73 74 2d 6e 61 6d 65 29 0a 20 da (test-name).
72f0: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 (let* ((te
7300: 73 74 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 st-path (conc
7310: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 74 65 73 *toppath* "/tes
7320: 74 73 2f 22 20 74 65 73 74 2d 6e 61 6d 65 29 29 ts/" test-name))
7330: 0a 09 20 20 20 20 20 20 28 74 65 73 74 2d 63 6f .. (test-co
7340: 6e 66 69 67 66 20 28 63 6f 6e 63 20 74 65 73 74 nfigf (conc test
7350: 2d 70 61 74 68 20 22 2f 74 65 73 74 63 6f 6e 66 -path "/testconf
7360: 69 67 22 29 29 0a 09 20 20 20 20 20 20 28 74 65 ig")).. (te
7370: 73 74 65 78 69 73 74 73 20 20 20 28 61 6e 64 20 stexists (and
7380: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 65 (file-exists? te
7390: 73 74 2d 63 6f 6e 66 69 67 66 29 28 66 69 6c 65 st-configf)(file
73a0: 2d 72 65 61 64 2d 61 63 63 65 73 73 3f 20 74 65 -read-access? te
73b0: 73 74 2d 63 6f 6e 66 69 67 66 29 29 29 0a 09 20 st-configf)))..
73c0: 20 20 20 20 20 3b 3b 20 72 65 61 64 20 63 6f 6e ;; read con
73d0: 66 69 67 73 20 77 69 74 68 20 74 72 69 63 6b 73 figs with tricks
73e0: 20 74 75 72 6e 65 64 20 6f 66 66 20 28 69 2e 65 turned off (i.e
73f0: 2e 20 6e 6f 20 73 79 73 74 65 6d 29 0a 09 20 20 . no system)..
7400: 20 20 20 20 28 74 65 73 74 2d 63 6f 6e 66 20 20 (test-conf
7410: 20 20 28 69 66 20 74 65 73 74 65 78 69 73 74 73 (if testexists
7420: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 65 (read-config te
7430: 73 74 2d 63 6f 6e 66 69 67 66 20 23 66 20 23 66 st-configf #f #f
7440: 29 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c )(make-hash-tabl
7450: 65 29 29 29 29 0a 09 20 28 72 75 6e 73 3a 75 70 e)))).. (runs:up
7460: 64 61 74 65 2d 74 65 73 74 5f 6d 65 74 61 20 64 date-test_meta d
7470: 62 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 b test-name test
7480: 2d 63 6f 6e 66 29 29 29 0a 20 20 20 20 20 74 65 -conf))). te
7490: 73 74 2d 6e 61 6d 65 73 29 29 29 0a 0a 3b 3b 20 st-names)))..;;
74a0: 54 68 69 73 20 63 6f 75 6c 64 20 70 72 6f 62 61 This could proba
74b0: 62 6c 79 20 62 65 20 72 65 66 61 63 74 6f 72 65 bly be refactore
74c0: 64 20 69 6e 74 6f 20 6f 6e 65 20 63 6f 6d 70 6c d into one compl
74d0: 65 78 20 71 75 65 72 79 20 2e 2e 2e 0a 28 64 65 ex query ....(de
74e0: 66 69 6e 65 20 28 72 75 6e 73 3a 72 6f 6c 6c 75 fine (runs:rollu
74f0: 70 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 p-run db keys ke
7500: 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 yvallst runname
7510: 75 73 65 72 29 20 3b 3b 20 77 61 73 20 74 61 72 user) ;; was tar
7520: 67 65 74 2c 20 6e 6f 77 20 6b 65 79 76 61 6c 6c get, now keyvall
7530: 73 74 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e st. (debug:prin
7540: 74 20 34 20 22 72 75 6e 73 3a 72 6f 6c 6c 75 70 t 4 "runs:rollup
7550: 2d 72 75 6e 2c 20 6b 65 79 73 3a 20 22 20 6b 65 -run, keys: " ke
7560: 79 73 20 22 20 6b 65 79 76 61 6c 6c 73 74 3a 20 ys " keyvallst:
7570: 22 20 6b 65 79 76 61 6c 6c 73 74 20 22 20 3a 72 " keyvallst " :r
7580: 75 6e 6e 61 6d 65 20 22 20 72 75 6e 6e 61 6d 65 unname " runname
7590: 20 22 20 75 73 65 72 3a 20 22 20 75 73 65 72 29 " user: " user)
75a0: 0a 20 20 28 6c 65 74 2a 20 28 3b 20 28 6b 65 79 . (let* (; (key
75b0: 76 61 6c 6c 6c 73 74 20 20 20 20 20 20 28 6b 65 valllst (ke
75c0: 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 ys:target->keyva
75d0: 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a l keys target)).
75e0: 09 20 28 6e 65 77 2d 72 75 6e 2d 69 64 20 20 20 . (new-run-id
75f0: 20 20 20 28 72 75 6e 73 3a 72 65 67 69 73 74 65 (runs:registe
7600: 72 2d 72 75 6e 20 64 62 20 6b 65 79 73 20 6b 65 r-run db keys ke
7610: 79 76 61 6c 6c 73 74 20 72 75 6e 6e 61 6d 65 20 yvallst runname
7620: 22 6e 65 77 22 20 22 6e 2f 61 22 20 75 73 65 72 "new" "n/a" user
7630: 29 29 0a 09 20 28 70 72 65 76 2d 74 65 73 74 73 )).. (prev-tests
7640: 20 20 20 20 20 20 28 74 65 73 74 3a 67 65 74 2d (test:get-
7650: 6d 61 74 63 68 69 6e 67 2d 70 72 65 76 69 6f 75 matching-previou
7660: 73 2d 74 65 73 74 2d 72 75 6e 2d 72 65 63 6f 72 s-test-run-recor
7670: 64 73 20 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 ds db new-run-id
7680: 20 22 25 22 20 22 25 22 29 29 0a 09 20 28 63 75 "%" "%")).. (cu
7690: 72 72 2d 74 65 73 74 73 20 20 20 20 20 20 28 72 rr-tests (r
76a0: 64 62 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 db:get-tests-for
76b0: 2d 72 75 6e 20 64 62 20 6e 65 77 2d 72 75 6e 2d -run db new-run-
76c0: 69 64 20 22 25 22 20 22 25 22 20 27 28 29 20 27 id "%" "%" '() '
76d0: 28 29 29 29 0a 09 20 28 63 75 72 72 2d 74 65 73 ())).. (curr-tes
76e0: 74 73 2d 68 61 73 68 20 28 6d 61 6b 65 2d 68 61 ts-hash (make-ha
76f0: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
7700: 28 64 62 3a 75 70 64 61 74 65 2d 72 75 6e 2d 65 (db:update-run-e
7710: 76 65 6e 74 5f 74 69 6d 65 20 64 62 20 6e 65 77 vent_time db new
7720: 2d 72 75 6e 2d 69 64 29 0a 20 20 20 20 3b 3b 20 -run-id). ;;
7730: 69 6e 64 65 78 20 74 68 65 20 61 6c 72 65 61 64 index the alread
7740: 79 20 73 61 76 65 64 20 74 65 73 74 73 20 62 79 y saved tests by
7750: 20 74 65 73 74 6e 61 6d 65 20 61 6e 64 20 69 74 testname and it
7760: 65 6d 64 61 74 20 69 6e 20 63 75 72 72 2d 74 65 emdat in curr-te
7770: 73 74 73 2d 68 61 73 68 0a 20 20 20 20 28 66 6f sts-hash. (fo
7780: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
7790: 62 64 61 20 28 74 65 73 74 64 61 74 29 0a 20 20 bda (testdat).
77a0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
77b0: 74 6e 61 6d 65 20 20 28 64 62 3a 74 65 73 74 2d tname (db:test-
77c0: 67 65 74 2d 74 65 73 74 6e 61 6d 65 20 74 65 73 get-testname tes
77d0: 74 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 69 tdat)).. (i
77e0: 74 65 6d 2d 70 61 74 68 20 28 64 62 3a 74 65 73 tem-path (db:tes
77f0: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
7800: 74 65 73 74 64 61 74 29 29 0a 09 20 20 20 20 20 testdat))..
7810: 20 28 66 75 6c 6c 2d 6e 61 6d 65 20 28 63 6f 6e (full-name (con
7820: 63 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 c testname "/" i
7830: 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 28 68 tem-path))).. (h
7840: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 ash-table-set! c
7850: 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
7860: 75 6c 6c 2d 6e 61 6d 65 20 74 65 73 74 64 61 74 ull-name testdat
7870: 29 29 29 0a 20 20 20 20 20 63 75 72 72 2d 74 65 ))). curr-te
7880: 73 74 73 29 0a 20 20 20 20 3b 3b 20 4e 4f 50 45 sts). ;; NOPE
7890: 3a 20 4e 6f 6e 2d 6f 70 74 69 6d 61 6c 20 61 70 : Non-optimal ap
78a0: 70 72 6f 61 63 68 2e 20 54 72 79 20 74 68 69 73 proach. Try this
78b0: 20 69 6e 73 74 65 61 64 2e 0a 20 20 20 20 3b 3b instead.. ;;
78c0: 20 20 20 31 2e 20 74 65 73 74 73 20 61 72 65 20 1. tests are
78d0: 72 65 63 65 69 76 65 64 20 69 6e 20 61 20 6c 69 received in a li
78e0: 73 74 2c 20 6d 6f 73 74 20 72 65 63 65 6e 74 20 st, most recent
78f0: 66 69 72 73 74 0a 20 20 20 20 3b 3b 20 20 20 32 first. ;; 2
7900: 2e 20 72 65 70 6c 61 63 65 20 74 68 65 20 72 6f . replace the ro
7910: 6c 6c 75 70 20 74 65 73 74 20 77 69 74 68 20 74 llup test with t
7920: 68 65 20 6e 65 77 20 2a 61 6c 77 61 79 73 2a 0a he new *always*.
7930: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 (for-each .
7940: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 74 65 73 (lambda (tes
7950: 74 64 61 74 29 0a 20 20 20 20 20 20 20 28 6c 65 tdat). (le
7960: 74 2a 20 28 28 74 65 73 74 6e 61 6d 65 20 20 28 t* ((testname (
7970: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
7980: 6e 61 6d 65 20 74 65 73 74 64 61 74 29 29 0a 09 name testdat))..
7990: 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 74 68 (item-path
79a0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 74 (db:test-get-it
79b0: 65 6d 2d 70 61 74 68 20 74 65 73 74 64 61 74 29 em-path testdat)
79c0: 29 0a 09 20 20 20 20 20 20 28 66 75 6c 6c 2d 6e ).. (full-n
79d0: 61 6d 65 20 28 63 6f 6e 63 20 74 65 73 74 6e 61 ame (conc testna
79e0: 6d 65 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 me "/" item-path
79f0: 29 29 0a 09 20 20 20 20 20 20 28 70 72 65 76 2d )).. (prev-
7a00: 74 65 73 74 2d 64 61 74 20 28 68 61 73 68 2d 74 test-dat (hash-t
7a10: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
7a20: 20 63 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 curr-tests-hash
7a30: 20 66 75 6c 6c 2d 6e 61 6d 65 20 23 66 29 29 0a full-name #f)).
7a40: 09 20 20 20 20 20 20 28 74 65 73 74 2d 73 74 65 . (test-ste
7a50: 70 73 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d ps (db:get-
7a60: 73 74 65 70 73 2d 66 6f 72 2d 74 65 73 74 20 64 steps-for-test d
7a70: 62 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 b (db:test-get-i
7a80: 64 20 74 65 73 74 64 61 74 29 29 29 0a 09 20 20 d testdat)))..
7a90: 20 20 20 20 28 6e 65 77 2d 74 65 73 74 2d 72 65 (new-test-re
7aa0: 63 6f 72 64 20 23 66 29 29 0a 09 20 3b 3b 20 72 cord #f)).. ;; r
7ab0: 65 70 6c 61 63 65 20 74 68 65 73 65 20 77 69 74 eplace these wit
7ac0: 68 20 69 6e 73 65 72 74 20 2e 2e 2e 20 73 65 6c h insert ... sel
7ad0: 65 63 74 0a 09 20 28 61 70 70 6c 79 20 73 71 6c ect.. (apply sql
7ae0: 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a 09 09 ite3:execute ...
7af0: 64 62 20 0a 09 09 28 63 6f 6e 63 20 22 49 4e 53 db ...(conc "INS
7b00: 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 ERT OR REPLACE I
7b10: 4e 54 4f 20 74 65 73 74 73 20 28 72 75 6e 5f 69 NTO tests (run_i
7b20: 64 2c 74 65 73 74 6e 61 6d 65 2c 73 74 61 74 65 d,testname,state
7b30: 2c 73 74 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 ,status,event_ti
7b40: 6d 65 2c 68 6f 73 74 2c 63 70 75 6c 6f 61 64 2c me,host,cpuload,
7b50: 64 69 73 6b 66 72 65 65 2c 75 6e 61 6d 65 2c 72 diskfree,uname,r
7b60: 75 6e 64 69 72 2c 69 74 65 6d 5f 70 61 74 68 2c undir,item_path,
7b70: 72 75 6e 5f 64 75 72 61 74 69 6f 6e 2c 66 69 6e run_duration,fin
7b80: 61 6c 5f 6c 6f 67 66 2c 63 6f 6d 6d 65 6e 74 29 al_logf,comment)
7b90: 20 22 0a 09 09 20 20 20 20 20 20 22 56 41 4c 55 "... "VALU
7ba0: 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c ES (?,?,?,?,?,?,
7bb0: 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 ?,?,?,?,?,?,?,?)
7bc0: 3b 22 29 0a 09 09 6e 65 77 2d 72 75 6e 2d 69 64 ;")...new-run-id
7bd0: 20 28 63 64 64 72 20 28 76 65 63 74 6f 72 2d 3e (cddr (vector->
7be0: 6c 69 73 74 20 74 65 73 74 64 61 74 29 29 29 0a list testdat))).
7bf0: 09 20 28 73 65 74 21 20 6e 65 77 2d 74 65 73 74 . (set! new-test
7c00: 64 61 74 20 28 63 61 72 20 28 72 64 62 3a 67 65 dat (car (rdb:ge
7c10: 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 t-tests-for-run
7c20: 64 62 20 6e 65 77 2d 72 75 6e 2d 69 64 20 74 65 db new-run-id te
7c30: 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 stname item-path
7c40: 20 27 28 29 20 27 28 29 29 29 29 0a 09 20 28 68 '() '()))).. (h
7c50: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 63 ash-table-set! c
7c60: 75 72 72 2d 74 65 73 74 73 2d 68 61 73 68 20 66 urr-tests-hash f
7c70: 75 6c 6c 2d 6e 61 6d 65 20 6e 65 77 2d 74 65 73 ull-name new-tes
7c80: 74 64 61 74 29 20 3b 3b 20 74 68 69 73 20 63 6f tdat) ;; this co
7c90: 75 6c 64 20 62 65 20 63 6f 6e 66 75 73 69 6e 67 uld be confusing
7ca0: 2c 20 77 68 69 63 68 20 72 65 63 6f 72 64 20 73 , which record s
7cb0: 68 6f 75 6c 64 20 67 6f 20 69 6e 74 6f 20 74 68 hould go into th
7cc0: 65 20 6c 6f 6f 6b 75 70 20 74 61 62 6c 65 3f 0a e lookup table?.
7cd0: 09 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 . ;; Now duplica
7ce0: 74 65 20 74 68 65 20 74 65 73 74 20 73 74 65 70 te the test step
7cf0: 73 0a 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 s.. (debug:print
7d00: 20 34 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 4 "Copying reco
7d10: 72 64 73 20 69 6e 20 74 65 73 74 5f 73 74 65 70 rds in test_step
7d20: 73 20 66 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 s from test_id="
7d30: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
7d40: 20 74 65 73 74 64 61 74 29 20 22 20 74 6f 20 22 testdat) " to "
7d50: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 (db:test-get-id
7d60: 20 6e 65 77 2d 74 65 73 74 64 61 74 29 29 0a 09 new-testdat))..
7d70: 20 28 73 71 6c 69 74 65 33 3a 65 78 65 63 75 74 (sqlite3:execut
7d80: 65 20 0a 09 20 20 64 62 20 0a 09 20 20 28 63 6f e .. db .. (co
7d90: 6e 63 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 nc "INSERT OR RE
7da0: 50 4c 41 43 45 20 49 4e 54 4f 20 74 65 73 74 5f PLACE INTO test_
7db0: 73 74 65 70 73 20 28 74 65 73 74 5f 69 64 2c 73 steps (test_id,s
7dc0: 74 65 70 6e 61 6d 65 2c 73 74 61 74 65 2c 73 74 tepname,state,st
7dd0: 61 74 75 73 2c 65 76 65 6e 74 5f 74 69 6d 65 2c atus,event_time,
7de0: 63 6f 6d 6d 65 6e 74 29 20 22 0a 09 09 22 53 45 comment) "..."SE
7df0: 4c 45 43 54 20 22 20 28 64 62 3a 74 65 73 74 2d LECT " (db:test-
7e00: 67 65 74 2d 69 64 20 6e 65 77 2d 74 65 73 74 64 get-id new-testd
7e10: 61 74 29 20 22 2c 73 74 65 70 6e 61 6d 65 2c 73 at) ",stepname,s
7e20: 74 61 74 65 2c 73 74 61 74 75 73 2c 65 76 65 6e tate,status,even
7e30: 74 5f 74 69 6d 65 2c 63 6f 6d 6d 65 6e 74 20 46 t_time,comment F
7e40: 52 4f 4d 20 74 65 73 74 5f 73 74 65 70 73 20 57 ROM test_steps W
7e50: 48 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 HERE test_id=?;"
7e60: 29 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 ).. (db:test-ge
7e70: 74 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 09 t-id testdat))..
7e80: 20 3b 3b 20 4e 6f 77 20 64 75 70 6c 69 63 61 74 ;; Now duplicat
7e90: 65 20 74 68 65 20 74 65 73 74 20 64 61 74 61 0a e the test data.
7ea0: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 . (debug:print 4
7eb0: 20 22 43 6f 70 79 69 6e 67 20 72 65 63 6f 72 64 "Copying record
7ec0: 73 20 69 6e 20 74 65 73 74 5f 64 61 74 61 20 66 s in test_data f
7ed0: 72 6f 6d 20 74 65 73 74 5f 69 64 3d 22 20 28 64 rom test_id=" (d
7ee0: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 74 65 b:test-get-id te
7ef0: 73 74 64 61 74 29 20 22 20 74 6f 20 22 20 28 64 stdat) " to " (d
7f00: 62 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 b:test-get-id ne
7f10: 77 2d 74 65 73 74 64 61 74 29 29 0a 09 20 28 73 w-testdat)).. (s
7f20: 71 6c 69 74 65 33 3a 65 78 65 63 75 74 65 20 0a qlite3:execute .
7f30: 09 20 20 64 62 20 0a 09 20 20 28 63 6f 6e 63 20 . db .. (conc
7f40: 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 "INSERT OR REPLA
7f50: 43 45 20 49 4e 54 4f 20 74 65 73 74 5f 64 61 74 CE INTO test_dat
7f60: 61 20 28 74 65 73 74 5f 69 64 2c 63 61 74 65 67 a (test_id,categ
7f70: 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 6c ory,variable,val
7f80: 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c 2c ue,expected,tol,
7f90: 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 29 20 22 units,comment) "
7fa0: 0a 09 09 22 53 45 4c 45 43 54 20 22 20 28 64 62 ..."SELECT " (db
7fb0: 3a 74 65 73 74 2d 67 65 74 2d 69 64 20 6e 65 77 :test-get-id new
7fc0: 2d 74 65 73 74 64 61 74 29 20 22 2c 63 61 74 65 -testdat) ",cate
7fd0: 67 6f 72 79 2c 76 61 72 69 61 62 6c 65 2c 76 61 gory,variable,va
7fe0: 6c 75 65 2c 65 78 70 65 63 74 65 64 2c 74 6f 6c lue,expected,tol
7ff0: 2c 75 6e 69 74 73 2c 63 6f 6d 6d 65 6e 74 20 46 ,units,comment F
8000: 52 4f 4d 20 74 65 73 74 5f 64 61 74 61 20 57 48 ROM test_data WH
8010: 45 52 45 20 74 65 73 74 5f 69 64 3d 3f 3b 22 29 ERE test_id=?;")
8020: 0a 09 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 .. (db:test-get
8030: 2d 69 64 20 74 65 73 74 64 61 74 29 29 0a 09 20 -id testdat))..
8040: 29 29 0a 20 20 20 20 20 70 72 65 76 2d 74 65 73 )). prev-tes
8050: 74 73 29 29 29 0a 09 20 0a 20 20 20 20 20 0a ts))).. . .