Artifact
84954a75fc53f5838015ff620cf8aaf5c6f0e361:
0000: 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 30 ;; Copyright 200
0010: 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 20 6-2013, Matthew
0020: 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b 20 Welland..;; .;;
0030: 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 72 This file is par
0040: 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a 3b t of Megatest..;
0050: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
0060: 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 77 st is free softw
0070: 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 64 are: you can red
0080: 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e 64 istribute it and
0090: 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 20 /or modify.;;
00a0: 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 74 it under the t
00b0: 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 20 erms of the GNU
00c0: 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 4c General Public L
00d0: 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 73 icense as publis
00e0: 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 68 hed by.;; th
00f0: 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 20 e Free Software
0100: 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 68 Foundation, eith
0110: 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 20 er version 3 of
0120: 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 0a the License, or.
0130: 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 20 ;; (at your
0140: 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 65 option) any late
0150: 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a 3b r version..;; .;
0160: 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 69 ; Megatest i
0170: 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 6e s distributed in
0180: 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 69 the hope that i
0190: 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 6c t will be useful
01a0: 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 54 ,.;; but WIT
01b0: 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e 54 HOUT ANY WARRANT
01c0: 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e 20 Y; without even
01d0: 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 72 the implied warr
01e0: 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 4d anty of.;; M
01f0: 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 6f ERCHANTABILITY o
0200: 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 20 r FITNESS FOR A
0210: 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 4f PARTICULAR PURPO
0220: 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b 20 SE. See the.;;
0230: 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 GNU General
0240: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 66 Public License f
0250: 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 2e or more details.
0260: 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 20 .;; .;; You
0270: 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 65 should have rece
0280: 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 74 ived a copy of t
0290: 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 he GNU General P
02a0: 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b 3b ublic License.;;
02b0: 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 20 along with
02c0: 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e 6f Megatest. If no
02d0: 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f 77 t, see <http://w
02e0: 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 6e ww.gnu.org/licen
02f0: 73 65 73 2f 3e 2e 0a 3b 3b 0a 0a 0a 28 75 73 65 ses/>..;;...(use
0300: 20 73 71 6c 69 74 65 33 20 73 72 66 69 2d 31 20 sqlite3 srfi-1
0310: 70 6f 73 69 78 20 72 65 67 65 78 20 72 65 67 65 posix regex rege
0320: 78 2d 63 61 73 65 20 73 72 66 69 2d 36 39 20 64 x-case srfi-69 d
0330: 6f 74 2d 6c 6f 63 6b 69 6e 67 20 28 73 72 66 69 ot-locking (srfi
0340: 20 31 38 29 20 70 6f 73 69 78 2d 65 78 74 72 61 18) posix-extra
0350: 73 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c s directory-util
0360: 73 20 63 61 6c 6c 2d 77 69 74 68 2d 65 6e 76 69 s call-with-envi
0370: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
0380: 73 29 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 s).(import (pref
0390: 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 ix sqlite3 sqlit
03a0: 65 33 3a 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 e3:))..(declare
03b0: 28 75 6e 69 74 20 6d 74 29 29 0a 28 64 65 63 6c (unit mt)).(decl
03c0: 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a 28 are (uses db)).(
03d0: 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f declare (uses co
03e0: 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 mmon)).(declare
03f0: 28 75 73 65 73 20 69 74 65 6d 73 29 29 0a 28 64 (uses items)).(d
0400: 65 63 6c 61 72 65 20 28 75 73 65 73 20 72 75 6e eclare (uses run
0410: 63 6f 6e 66 69 67 29 29 0a 28 64 65 63 6c 61 72 config)).(declar
0420: 65 20 28 75 73 65 73 20 74 65 73 74 73 29 29 0a e (uses tests)).
0430: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 (declare (uses s
0440: 65 72 76 65 72 29 29 0a 28 64 65 63 6c 61 72 65 erver)).(declare
0450: 20 28 75 73 65 73 20 72 75 6e 73 29 29 0a 28 64 (uses runs)).(d
0460: 65 63 6c 61 72 65 20 28 75 73 65 73 20 72 6d 74 eclare (uses rmt
0470: 29 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 )).;; (declare (
0480: 75 73 65 73 20 66 69 6c 65 64 62 29 29 0a 28 64 uses filedb)).(d
0490: 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d eclare (uses com
04a0: 6d 6f 6e 6d 6f 64 29 29 0a 28 69 6d 70 6f 72 74 monmod)).(import
04b0: 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 0a 0a 0a 28 69 commonmod)...(i
04c0: 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 nclude "common_r
04d0: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e ecords.scm").(in
04e0: 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f 72 clude "key_recor
04f0: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
0500: 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 63 e "db_records.sc
0510: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 75 m").(include "ru
0520: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm").
0530: 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f 72 (include "test_r
0540: 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b ecords.scm")..;;
0550: 20 54 68 69 73 20 69 73 20 74 68 65 20 4d 65 67 This is the Meg
0560: 61 74 65 73 74 20 41 50 49 2e 20 41 6c 6c 20 67 atest API. All g
0570: 65 6e 65 72 61 6c 6c 79 20 22 75 73 65 66 75 6c enerally "useful
0580: 22 20 72 6f 75 74 69 6e 65 73 20 77 69 6c 6c 20 " routines will
0590: 62 65 20 77 72 61 70 70 65 64 20 6f 72 20 65 78 be wrapped or ex
05a0: 74 65 6e 64 65 64 0a 3b 3b 20 68 65 72 65 2e 0a tended.;; here..
05b0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
05c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 20 =========.;; R
0600: 55 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d U N S.;;========
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
0650: 3b 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e 73 ;; runs:get-runs
0660: 2d 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 20 -by-patt.;; get
0670: 72 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 20 runs by list of
0680: 63 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 69 criteria.;; regi
0690: 73 74 65 72 20 61 20 74 65 73 74 20 72 75 6e 20 ster a test run
06a0: 77 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a 3b with the db.;;.;
06b0: 3b 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d 76 ; Use: (db-get-v
06c0: 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 28 alue-by-header (
06d0: 64 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 db:get-header ru
06e0: 6e 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 6f ninfo)(db:get-ro
06f0: 77 73 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b 20 ws runinfo)).;;
0700: 20 74 6f 20 65 78 74 72 61 63 74 20 69 6e 66 6f to extract info
0710: 20 66 72 6f 6d 20 74 68 65 20 73 74 72 75 63 74 from the struct
0720: 75 72 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b 0a ure returned.;;.
0730: 28 64 65 66 69 6e 65 20 28 6d 74 3a 67 65 74 2d (define (mt:get-
0740: 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 6b 65 79 runs-by-patt key
0750: 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 61 s runnamepatt ta
0760: 72 67 70 61 74 74 29 0a 20 20 28 6c 65 74 20 6c rgpatt). (let l
0770: 6f 6f 70 20 28 28 72 75 6e 73 64 61 74 20 20 28 oop ((runsdat (
0780: 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d rmt:get-runs-by-
0790: 70 61 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d patt keys runnam
07a0: 65 70 61 74 74 20 74 61 72 67 70 61 74 74 20 30 epatt targpatt 0
07b0: 20 35 30 30 20 23 66 20 30 29 29 0a 09 20 20 20 500 #f 0))..
07c0: 20 20 28 72 65 73 20 20 20 20 20 20 27 28 29 29 (res '())
07d0: 0a 09 20 20 20 20 20 28 6f 66 66 73 65 74 20 20 .. (offset
07e0: 20 30 29 0a 09 20 20 20 20 20 28 6c 69 6d 69 74 0).. (limit
07f0: 20 20 20 20 35 30 30 29 29 0a 20 20 20 20 3b 3b 500)). ;;
0800: 20 28 70 72 69 6e 74 20 22 72 75 6e 73 64 61 74 (print "runsdat
0810: 3a 20 22 20 72 75 6e 73 64 61 74 29 0a 20 20 20 : " runsdat).
0820: 20 28 6c 65 74 2a 20 28 28 68 65 61 64 65 72 20 (let* ((header
0830: 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 (vector-ref r
0840: 75 6e 73 64 61 74 20 30 29 29 0a 09 20 20 20 28 unsdat 0)).. (
0850: 72 75 6e 73 6c 73 74 20 20 20 28 76 65 63 74 6f runslst (vecto
0860: 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 29 r-ref runsdat 1)
0870: 29 0a 09 20 20 20 28 66 75 6c 6c 2d 6c 69 73 74 ).. (full-list
0880: 20 28 61 70 70 65 6e 64 20 72 65 73 20 72 75 6e (append res run
0890: 73 6c 73 74 29 29 0a 09 20 20 20 28 68 61 76 65 slst)).. (have
08a0: 2d 6d 6f 72 65 20 28 65 71 3f 20 28 6c 65 6e 67 -more (eq? (leng
08b0: 74 68 20 72 75 6e 73 6c 73 74 29 20 6c 69 6d 69 th runslst) limi
08c0: 74 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 64 t))). ;; (d
08d0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
08e0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
08f0: 22 68 65 61 64 65 72 3a 20 22 20 68 65 61 64 65 "header: " heade
0900: 72 20 22 20 72 75 6e 73 6c 73 74 3a 20 22 20 72 r " runslst: " r
0910: 75 6e 73 6c 73 74 20 22 20 68 61 76 65 2d 6d 6f unslst " have-mo
0920: 72 65 3a 20 22 20 68 61 76 65 2d 6d 6f 72 65 29 re: " have-more)
0930: 0a 20 20 20 20 20 20 28 69 66 20 68 61 76 65 2d . (if have-
0940: 6d 6f 72 65 20 0a 09 20 20 28 6c 65 74 20 28 28 more .. (let ((
0950: 6e 65 77 2d 6f 66 66 73 65 74 20 28 2b 20 6f 66 new-offset (+ of
0960: 66 73 65 74 20 6c 69 6d 69 74 29 29 0a 09 09 28 fset limit))...(
0970: 6e 65 78 74 2d 62 61 74 63 68 20 28 72 6d 74 3a next-batch (rmt:
0980: 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 get-runs-by-patt
0990: 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 keys runnamepat
09a0: 74 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 65 t targpatt offse
09b0: 74 20 6c 69 6d 69 74 20 23 66 20 30 29 29 29 0a t limit #f 0))).
09c0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
09d0: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
09e0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 6f 72 t-log-port* "Mor
09f0: 65 20 74 68 61 6e 20 22 20 6c 69 6d 69 74 20 22 e than " limit "
0a00: 20 72 75 6e 73 2c 20 68 61 76 65 20 22 20 28 6c runs, have " (l
0a10: 65 6e 67 74 68 20 66 75 6c 6c 2d 6c 69 73 74 29 ength full-list)
0a20: 20 22 20 72 75 6e 73 20 73 6f 20 66 61 72 2e 22 " runs so far."
0a30: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
0a40: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
0a50: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e ult-log-port* "n
0a60: 65 78 74 2d 62 61 74 63 68 3a 20 22 20 6e 65 78 ext-batch: " nex
0a70: 74 2d 62 61 74 63 68 29 0a 09 20 20 20 20 28 6c t-batch).. (l
0a80: 6f 6f 70 20 6e 65 78 74 2d 62 61 74 63 68 0a 09 oop next-batch..
0a90: 09 20 20 66 75 6c 6c 2d 6c 69 73 74 0a 09 09 20 . full-list...
0aa0: 20 6e 65 77 2d 6f 66 66 73 65 74 0a 09 09 20 20 new-offset...
0ab0: 6c 69 6d 69 74 29 29 0a 09 20 28 76 65 63 74 6f limit)).. (vecto
0ac0: 72 20 68 65 61 64 65 72 20 66 75 6c 6c 2d 6c 69 r header full-li
0ad0: 73 74 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d st)))))..;;=====
0ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b20: 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 53 0a =.;; T E S T S.
0b30: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b70: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
0b80: 65 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d e (mt:get-tests-
0b90: 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 74 for-run run-id t
0ba0: 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 estpatt states s
0bb0: 74 61 74 75 73 20 23 21 6b 65 79 20 28 6e 6f 74 tatus #!key (not
0bc0: 2d 69 6e 20 23 74 29 20 28 73 6f 72 74 2d 62 79 -in #t) (sort-by
0bd0: 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 20 28 73 'event_time) (s
0be0: 6f 72 74 2d 6f 72 64 65 72 20 22 41 53 43 22 29 ort-order "ASC")
0bf0: 20 28 71 72 79 76 61 6c 73 20 23 66 29 28 6c 61 (qryvals #f)(la
0c00: 73 74 2d 75 70 64 61 74 65 20 23 66 29 29 0a 20 st-update #f)).
0c10: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 65 73 (let loop ((tes
0c20: 74 73 64 61 74 20 28 72 6d 74 3a 67 65 74 2d 74 tsdat (rmt:get-t
0c30: 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 6e ests-for-run run
0c40: 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 61 -id testpatt sta
0c50: 74 65 73 20 73 74 61 74 75 73 20 30 20 35 30 30 tes status 0 500
0c60: 20 6e 6f 74 2d 69 6e 20 73 6f 72 74 2d 62 79 20 not-in sort-by
0c70: 73 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 76 61 sort-order qryva
0c80: 6c 73 20 6c 61 73 74 2d 75 70 64 61 74 65 20 27 ls last-update '
0c90: 6e 6f 72 6d 61 6c 29 29 0a 09 20 20 20 20 20 28 normal)).. (
0ca0: 72 65 73 20 20 20 20 20 20 27 28 29 29 0a 09 20 res '())..
0cb0: 20 20 20 20 28 6f 66 66 73 65 74 20 20 20 30 29 (offset 0)
0cc0: 0a 09 20 20 20 20 20 28 6c 69 6d 69 74 20 20 20 .. (limit
0cd0: 20 35 30 30 29 29 0a 20 20 20 20 28 6c 65 74 2a 500)). (let*
0ce0: 20 28 28 66 75 6c 6c 2d 6c 69 73 74 20 28 61 70 ((full-list (ap
0cf0: 70 65 6e 64 20 72 65 73 20 74 65 73 74 73 64 61 pend res testsda
0d00: 74 29 29 0a 09 20 20 20 28 68 61 76 65 2d 6d 6f t)).. (have-mo
0d10: 72 65 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 re (eq? (length
0d20: 74 65 73 74 73 64 61 74 29 20 6c 69 6d 69 74 29 testsdat) limit)
0d30: 29 29 0a 20 20 20 20 20 20 28 69 66 20 68 61 76 )). (if hav
0d40: 65 2d 6d 6f 72 65 20 0a 09 20 20 28 6c 65 74 20 e-more .. (let
0d50: 28 28 6e 65 77 2d 6f 66 66 73 65 74 20 28 2b 20 ((new-offset (+
0d60: 6f 66 66 73 65 74 20 6c 69 6d 69 74 29 29 29 0a offset limit))).
0d70: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
0d80: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
0d90: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 6f 72 t-log-port* "Mor
0da0: 65 20 74 68 61 6e 20 22 20 6c 69 6d 69 74 20 22 e than " limit "
0db0: 20 74 65 73 74 73 2c 20 68 61 76 65 20 22 20 28 tests, have " (
0dc0: 6c 65 6e 67 74 68 20 66 75 6c 6c 2d 6c 69 73 74 length full-list
0dd0: 29 20 22 20 74 65 73 74 73 20 73 6f 20 66 61 72 ) " tests so far
0de0: 2e 22 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 .").. (loop (
0df0: 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f rmt:get-tests-fo
0e00: 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 74 65 73 r-run run-id tes
0e10: 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 61 tpatt states sta
0e20: 74 75 73 20 6e 65 77 2d 6f 66 66 73 65 74 20 6c tus new-offset l
0e30: 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 74 imit not-in sort
0e40: 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 71 -by sort-order q
0e50: 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 61 ryvals last-upda
0e60: 74 65 20 27 6e 6f 72 6d 61 6c 29 0a 09 09 20 20 te 'normal)...
0e70: 66 75 6c 6c 2d 6c 69 73 74 0a 09 09 20 20 6e 65 full-list... ne
0e80: 77 2d 6f 66 66 73 65 74 0a 09 09 20 20 6c 69 6d w-offset... lim
0e90: 69 74 29 29 0a 09 20 20 66 75 6c 6c 2d 6c 69 73 it)).. full-lis
0ea0: 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 t))))..(define (
0eb0: 6d 74 3a 6c 61 7a 79 2d 67 65 74 2d 70 72 65 72 mt:lazy-get-prer
0ec0: 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e 2d eqs-not-met run-
0ed0: 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d 69 id waitons ref-i
0ee0: 74 65 6d 2d 70 61 74 68 20 23 21 6b 65 79 20 28 tem-path #!key (
0ef0: 6d 6f 64 65 20 27 28 6e 6f 72 6d 61 6c 29 29 28 mode '(normal))(
0f00: 69 74 65 6d 6d 61 70 73 20 23 66 29 20 29 0a 20 itemmaps #f) ).
0f10: 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 (let* ((key
0f20: 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 77 61 69 (list run-id wai
0f30: 74 6f 6e 73 20 72 65 66 2d 69 74 65 6d 2d 70 61 tons ref-item-pa
0f40: 74 68 20 6d 6f 64 65 29 29 0a 09 20 28 72 65 73 th mode)).. (res
0f50: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
0f60: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 70 72 65 ref/default *pre
0f70: 2d 72 65 71 73 2d 6d 65 74 2d 63 61 63 68 65 2a -reqs-met-cache*
0f80: 20 6b 65 79 20 23 66 29 29 0a 09 20 28 75 73 65 key #f)).. (use
0f90: 72 65 73 20 28 6c 65 74 20 28 28 6c 61 73 74 2d res (let ((last-
0fa0: 74 69 6d 65 20 28 69 66 20 28 76 65 63 74 6f 72 time (if (vector
0fb0: 3f 20 72 65 73 29 20 28 76 65 63 74 6f 72 2d 72 ? res) (vector-r
0fc0: 65 66 20 72 65 73 20 30 29 20 23 66 29 29 29 0a ef res 0) #f))).
0fd0: 09 09 20 20 20 28 69 66 20 6c 61 73 74 2d 74 69 .. (if last-ti
0fe0: 6d 65 0a 09 09 20 20 20 20 20 20 20 28 3c 20 28 me... (< (
0ff0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
1000: 28 2b 20 6c 61 73 74 2d 74 69 6d 65 20 35 29 29 (+ last-time 5))
1010: 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 29 29 ... #f))))
1020: 0a 20 20 20 20 28 69 66 20 75 73 65 72 65 73 0a . (if useres.
1030: 09 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 28 .(let ((result (
1040: 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 31 vector-ref res 1
1050: 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 ))).. (debug:pr
1060: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
1070: 6f 67 2d 70 6f 72 74 2a 20 22 55 73 69 6e 67 20 og-port* "Using
1080: 6c 61 7a 79 20 76 61 6c 75 65 20 72 65 73 3a 20 lazy value res:
1090: 22 20 72 65 73 75 6c 74 29 0a 09 20 20 72 65 73 " result).. res
10a0: 75 6c 74 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 ult)..(let ((new
10b0: 72 65 73 20 28 72 6d 74 3a 67 65 74 2d 70 72 65 res (rmt:get-pre
10c0: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e reqs-not-met run
10d0: 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d -id waitons ref-
10e0: 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 3a 20 item-path mode:
10f0: 6d 6f 64 65 20 69 74 65 6d 6d 61 70 73 3a 20 69 mode itemmaps: i
1100: 74 65 6d 6d 61 70 73 29 29 29 0a 09 20 20 28 68 temmaps))).. (h
1110: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
1120: 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 63 pre-reqs-met-cac
1130: 68 65 2a 20 6b 65 79 20 28 76 65 63 74 6f 72 20 he* key (vector
1140: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
1150: 29 20 6e 65 77 72 65 73 29 29 0a 09 20 20 6e 65 ) newres)).. ne
1160: 77 72 65 73 29 29 29 29 0a 0a 28 64 65 66 69 6e wres))))..(defin
1170: 65 20 28 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 74 e (mt:get-run-st
1180: 61 74 73 20 64 62 73 74 72 75 63 74 20 72 75 6e ats dbstruct run
1190: 2d 69 64 29 0a 3b 3b 20 20 47 65 74 20 72 75 6e -id).;; Get run
11a0: 20 73 74 61 74 73 20 66 72 6f 6d 20 6c 6f 63 61 stats from loca
11b0: 6c 20 61 63 63 65 73 73 2c 20 6d 6f 76 65 20 74 l access, move t
11c0: 68 69 73 20 2e 2e 2e 20 62 75 74 20 77 68 65 72 his ... but wher
11d0: 65 3f 0a 20 20 28 64 62 3a 67 65 74 2d 72 75 6e e?. (db:get-run
11e0: 2d 73 74 61 74 73 20 64 62 73 74 72 75 63 74 20 -stats dbstruct
11f0: 72 75 6e 2d 69 64 29 29 0a 0a 28 64 65 66 69 6e run-id))..(defin
1200: 65 20 28 6d 74 3a 64 69 73 63 61 72 64 2d 62 6c e (mt:discard-bl
1210: 6f 63 6b 65 64 2d 74 65 73 74 73 20 72 75 6e 2d ocked-tests run-
1220: 69 64 20 66 61 69 6c 65 64 2d 74 65 73 74 20 74 id failed-test t
1230: 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f 72 64 ests test-record
1240: 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s). (if (null?
1250: 74 65 73 74 73 29 0a 20 20 20 20 20 20 74 65 73 tests). tes
1260: 74 73 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a ts. (begin.
1270: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
1280: 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 1 *default-lo
1290: 67 2d 70 6f 72 74 2a 20 22 44 69 73 63 61 72 64 g-port* "Discard
12a0: 69 6e 67 20 74 65 73 74 73 20 66 72 6f 6d 20 22 ing tests from "
12b0: 20 74 65 73 74 73 20 22 20 74 68 61 74 20 61 72 tests " that ar
12c0: 65 20 77 61 69 74 69 6e 67 20 6f 6e 20 22 20 66 e waiting on " f
12d0: 61 69 6c 65 64 2d 74 65 73 74 29 0a 09 28 6c 65 ailed-test)..(le
12e0: 74 20 6c 6f 6f 70 20 28 28 74 65 73 74 6e 20 28 t loop ((testn (
12f0: 63 61 72 20 74 65 73 74 73 29 29 0a 09 09 20 20 car tests))...
1300: 20 28 72 65 6d 74 20 20 28 63 64 72 20 74 65 73 (remt (cdr tes
1310: 74 73 29 29 0a 09 09 20 20 20 28 72 65 73 20 20 ts))... (res
1320: 20 27 28 29 29 29 0a 09 20 20 28 6c 65 74 2a 20 '())).. (let*
1330: 28 28 74 65 73 74 2d 64 61 74 20 28 68 61 73 68 ((test-dat (hash
1340: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
1350: 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 20 lt test-records
1360: 74 65 73 74 6e 20 28 76 65 63 74 6f 72 20 23 66 testn (vector #f
1370: 20 23 66 20 27 28 29 29 29 29 0a 09 09 20 28 77 #f '())))... (w
1380: 61 69 74 6f 6e 73 20 20 28 76 65 63 74 6f 72 2d aitons (vector-
1390: 72 65 66 20 74 65 73 74 2d 64 61 74 20 32 29 29 ref test-dat 2))
13a0: 29 0a 09 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 ).. ;; (print
13b0: 20 22 6d 74 3a 64 69 73 63 61 72 64 2d 62 6c 6f "mt:discard-blo
13c0: 63 6b 65 64 2d 74 65 73 74 73 20 72 75 6e 2d 69 cked-tests run-i
13d0: 64 3a 20 22 20 72 75 6e 2d 69 64 20 22 20 66 61 d: " run-id " fa
13e0: 69 6c 65 64 2d 74 65 73 74 3a 20 22 20 66 61 69 iled-test: " fai
13f0: 6c 65 64 2d 74 65 73 74 20 22 20 74 65 73 74 6e led-test " testn
1400: 3a 20 22 20 74 65 73 74 6e 20 22 20 77 69 74 68 : " testn " with
1410: 20 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 74 waitons: " wait
1420: 6f 6e 73 29 0a 09 20 20 20 20 28 69 66 20 28 6e ons).. (if (n
1430: 75 6c 6c 3f 20 72 65 6d 74 29 0a 09 09 28 6c 65 ull? remt)...(le
1440: 74 20 28 28 6e 65 77 2d 72 65 73 20 28 72 65 76 t ((new-res (rev
1450: 65 72 73 65 20 72 65 73 29 29 29 0a 09 09 20 20 erse res)))...
1460: 3b 3b 20 28 70 72 69 6e 74 20 22 20 20 20 20 20 ;; (print "
1470: 20 20 6e 65 77 2d 72 65 73 3a 20 22 20 6e 65 77 new-res: " new
1480: 2d 72 65 73 29 0a 09 09 20 20 6e 65 77 2d 72 65 -res)... new-re
1490: 73 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 20 s)...(loop (car
14a0: 72 65 6d 74 29 0a 09 09 20 20 20 20 20 20 28 63 remt)... (c
14b0: 64 72 20 72 65 6d 74 29 0a 09 09 20 20 20 20 20 dr remt)...
14c0: 20 28 69 66 20 28 6d 65 6d 62 65 72 20 66 61 69 (if (member fai
14d0: 6c 65 64 2d 74 65 73 74 20 77 61 69 74 6f 6e 73 led-test waitons
14e0: 29 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 ).... (begin...
14f0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
1500: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1510: 2d 70 6f 72 74 2a 20 22 44 69 73 63 61 72 64 69 -port* "Discardi
1520: 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 6e 20 ng test " testn
1530: 22 28 22 20 74 65 73 74 2d 64 61 74 20 22 29 20 "(" test-dat ")
1540: 64 75 65 20 74 6f 20 22 20 66 61 69 6c 65 64 2d due to " failed-
1550: 74 65 73 74 29 0a 09 09 09 20 20 20 20 72 65 73 test).... res
1560: 29 0a 09 09 09 20 20 28 63 6f 6e 73 20 74 65 73 ).... (cons tes
1570: 74 6e 20 72 65 73 29 29 29 29 29 29 29 29 29 0a tn res))))))))).
1580: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 =========.;; T
15d0: 52 20 49 20 47 20 47 20 45 20 52 20 53 0a 3b 3b R I G G E R S.;;
15e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1620: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
1630: 28 6d 74 3a 72 75 6e 2d 74 72 69 67 67 65 72 20 (mt:run-trigger
1640: 63 6d 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 cmd test-id test
1650: 2d 72 75 6e 64 69 72 20 74 72 69 67 67 65 72 20 -rundir trigger
1660: 6c 6f 67 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d logname test-nam
1670: 65 20 69 74 65 6d 2d 70 61 74 68 20 65 76 65 6e e item-path even
1680: 74 2d 74 69 6d 65 20 61 63 74 75 61 6c 2d 73 74 t-time actual-st
1690: 61 74 65 20 61 63 74 75 61 6c 2d 73 74 61 74 75 ate actual-statu
16a0: 73 29 0a 20 20 3b 3b 20 50 75 74 74 69 6e 67 20 s). ;; Putting
16b0: 74 68 65 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 20 the commandline
16c0: 69 6e 74 6f 20 28 20 29 27 73 20 6d 65 61 6e 73 into ( )'s means
16d0: 20 6e 6f 20 63 6f 6e 74 72 6f 6c 20 6f 76 65 72 no control over
16e0: 20 74 68 65 20 73 68 65 6c 6c 2e 20 0a 20 20 3b the shell. . ;
16f0: 3b 20 73 74 64 6f 75 74 20 61 6e 64 20 73 74 64 ; stdout and std
1700: 65 72 72 20 77 69 6c 6c 20 62 65 20 63 61 75 67 err will be caug
1710: 68 74 20 69 6e 20 74 68 65 20 4e 42 46 41 4b 45 ht in the NBFAKE
1720: 20 6f 72 20 6d 74 5f 6c 61 75 6e 63 68 2e 6c 6f or mt_launch.lo
1730: 67 20 66 69 6c 65 73 0a 20 20 3b 3b 20 6f 72 20 g files. ;; or
1740: 65 71 75 69 76 61 6c 65 6e 74 2e 20 4e 6f 20 6e equivalent. No n
1750: 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 2e 20 eed to do this.
1760: 4a 75 73 74 20 72 75 6e 20 69 74 3f 0a 20 20 28 Just run it?. (
1770: 6c 65 74 2a 20 28 28 66 75 6c 6c 63 6d 64 20 28 let* ((fullcmd (
1780: 63 6f 6e 63 20 22 6e 62 66 61 6b 65 20 22 0a 09 conc "nbfake "..
1790: 09 09 63 6d 64 20 20 20 20 20 20 20 20 20 20 20 ..cmd
17a0: 22 20 22 0a 09 09 09 74 65 73 74 2d 69 64 20 20 " "....test-id
17b0: 20 20 20 20 20 22 20 22 0a 09 09 09 74 65 73 74 " "....test
17c0: 2d 72 75 6e 64 69 72 20 20 20 22 20 22 0a 09 09 -rundir " "...
17d0: 09 74 72 69 67 67 65 72 20 20 20 20 20 20 20 22 .trigger "
17e0: 20 22 0a 09 09 09 74 65 73 74 2d 6e 61 6d 65 20 "....test-name
17f0: 20 20 20 20 22 20 22 0a 09 09 09 69 74 65 6d 2d " "....item-
1800: 70 61 74 68 20 20 20 20 20 22 20 22 20 3b 3b 20 path " " ;;
1810: 68 61 73 20 2f 20 70 72 65 70 65 6e 64 65 64 20 has / prepended
1820: 74 6f 20 64 65 61 6c 20 77 69 74 68 20 74 6f 70 to deal with top
1830: 6c 65 76 65 6c 20 74 65 73 74 73 0a 09 09 09 61 level tests....a
1840: 63 74 75 61 6c 2d 73 74 61 74 65 20 20 22 20 22 ctual-state " "
1850: 0a 09 09 09 61 63 74 75 61 6c 2d 73 74 61 74 75 ....actual-statu
1860: 73 20 22 20 22 0a 09 09 09 65 76 65 6e 74 2d 74 s " "....event-t
1870: 69 6d 65 0a 09 09 09 29 29 0a 09 20 28 70 72 65 ime....)).. (pre
1880: 76 2d 6e 62 66 61 6b 65 2d 6c 6f 67 20 28 67 65 v-nbfake-log (ge
1890: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
18a0: 72 69 61 62 6c 65 20 22 4e 42 46 41 4b 45 5f 4c riable "NBFAKE_L
18b0: 4f 47 22 29 29 29 0a 20 20 20 20 28 73 65 74 65 OG"))). (sete
18c0: 6e 76 20 22 4e 42 46 41 4b 45 5f 4c 4f 47 22 20 nv "NBFAKE_LOG"
18d0: 28 63 6f 6e 63 20 28 63 6f 6e 64 0a 09 09 09 09 (conc (cond.....
18e0: 28 28 61 6e 64 20 28 64 69 72 65 63 74 6f 72 79 ((and (directory
18f0: 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 72 75 -exists? test-ru
1900: 6e 64 69 72 29 0a 09 09 09 09 20 20 20 20 20 20 ndir).....
1910: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
1920: 73 73 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 29 ss? test-rundir)
1930: 29 0a 09 09 09 09 20 74 65 73 74 2d 72 75 6e 64 )..... test-rund
1940: 69 72 29 0a 09 09 09 09 28 28 61 6e 64 20 28 64 ir).....((and (d
1950: 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f irectory-exists?
1960: 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 09 09 *toppath*).....
1970: 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 (file-writ
1980: 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 70 61 e-access? *toppa
1990: 74 68 2a 29 29 0a 09 09 09 09 20 2a 74 6f 70 70 th*))..... *topp
19a0: 61 74 68 2a 29 0a 09 09 09 09 28 65 6c 73 65 20 ath*).....(else
19b0: 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 28 63 (conc "/tmp/" (c
19c0: 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 urrent-user-name
19d0: 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 22 )))).... "
19e0: 2f 22 20 6c 6f 67 6e 61 6d 65 29 29 0a 20 20 20 /" logname)).
19f0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
1a00: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
1a10: 67 2d 70 6f 72 74 2a 20 22 54 52 49 47 47 45 52 g-port* "TRIGGER
1a20: 45 44 20 6f 6e 20 22 20 74 72 69 67 67 65 72 20 ED on " trigger
1a30: 22 2c 20 72 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 ", running comma
1a40: 6e 64 20 22 20 66 75 6c 6c 63 6d 64 20 22 20 6f nd " fullcmd " o
1a50: 75 74 70 75 74 20 61 74 20 22 20 28 67 65 74 2d utput at " (get-
1a60: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
1a70: 61 62 6c 65 20 22 4e 42 46 41 4b 45 5f 4c 4f 47 able "NBFAKE_LOG
1a80: 22 29 29 0a 20 20 20 20 3b 3b 20 28 63 61 6c 6c ")). ;; (call
1a90: 2d 77 69 74 68 2d 65 6e 76 69 72 6f 6e 6d 65 6e -with-environmen
1aa0: 74 2d 76 61 72 69 61 62 6c 65 73 0a 20 20 20 20 t-variables.
1ab0: 3b 3b 20 20 60 28 28 22 4e 42 46 41 4b 45 5f 4c ;; `(("NBFAKE_L
1ac0: 4f 47 22 20 2e 20 2c 28 63 6f 6e 63 20 74 65 73 OG" . ,(conc tes
1ad0: 74 2d 72 75 6e 64 69 72 20 22 2f 22 20 6c 6f 67 t-rundir "/" log
1ae0: 6e 61 6d 65 29 29 29 0a 20 20 20 20 3b 3b 20 20 name))). ;;
1af0: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 28 (lambda (). (
1b00: 70 72 6f 63 65 73 73 2d 72 75 6e 20 66 75 6c 6c process-run full
1b10: 63 6d 64 29 0a 20 20 20 20 28 69 66 20 70 72 65 cmd). (if pre
1b20: 76 2d 6e 62 66 61 6b 65 2d 6c 6f 67 0a 09 28 73 v-nbfake-log..(s
1b30: 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 5f 4c 4f etenv "NBFAKE_LO
1b40: 47 22 20 70 72 65 76 2d 6e 62 66 61 6b 65 2d 6c G" prev-nbfake-l
1b50: 6f 67 29 0a 09 28 75 6e 73 65 74 65 6e 76 20 22 og)..(unsetenv "
1b60: 4e 42 46 41 4b 45 5f 4c 4f 47 22 29 29 0a 20 20 NBFAKE_LOG")).
1b70: 20 20 29 29 20 3b 3b 20 29 29 0a 0a 28 64 65 66 )) ;; ))..(def
1b80: 69 6e 65 20 28 6d 74 3a 70 72 6f 63 65 73 73 2d ine (mt:process-
1b90: 74 72 69 67 67 65 72 73 20 64 62 73 74 72 75 63 triggers dbstruc
1ba0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
1bb0: 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 newstate newsta
1bc0: 74 75 73 29 0a 20 20 28 69 66 20 74 65 73 74 2d tus). (if test-
1bd0: 69 64 20 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 id . (let*
1be0: 28 28 74 65 73 74 2d 64 61 74 20 20 20 20 20 20 ((test-dat
1bf0: 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 (db:get-test-inf
1c00: 6f 2d 62 79 2d 69 64 20 64 62 73 74 72 75 63 74 o-by-id dbstruct
1c10: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
1c20: 29 29 0a 09 28 69 66 20 74 65 73 74 2d 64 61 74 ))..(if test-dat
1c30: 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 .. (let* ((te
1c40: 73 74 2d 72 75 6e 64 69 72 20 20 20 28 64 62 3a st-rundir (db:
1c50: 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
1c60: 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 test-dat))
1c70: 20 3b 3b 20 29 20 3b 3b 20 29 0a 09 09 20 20 20 ;; ) ;; )...
1c80: 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 20 28 (test-name (
1c90: 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 74 db:test-get-test
1ca0: 6e 61 6d 65 20 20 20 20 20 74 65 73 74 2d 64 61 name test-da
1cb0: 74 29 29 0a 09 09 20 20 20 28 69 74 65 6d 2d 70 t))... (item-p
1cc0: 61 74 68 20 20 20 20 20 28 64 62 3a 74 65 73 74 ath (db:test
1cd0: 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 20 -get-item-path
1ce0: 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 09 20 test-dat))...
1cf0: 20 20 28 64 75 72 61 74 69 6f 6e 20 20 20 20 20 (duration
1d00: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
1d10: 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 2d n_duration test-
1d20: 64 61 74 29 29 0a 09 09 20 20 20 28 63 6f 6d 6d dat))... (comm
1d30: 65 6e 74 20 20 20 20 20 20 20 28 64 62 3a 74 65 ent (db:te
1d40: 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 20 st-get-comment
1d50: 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 test-dat))..
1d60: 09 20 20 20 28 65 76 65 6e 74 2d 74 69 6d 65 20 . (event-time
1d70: 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d (db:test-get-
1d80: 65 76 65 6e 74 5f 74 69 6d 65 20 20 20 74 65 73 event_time tes
1d90: 74 2d 64 61 74 29 29 0a 09 09 20 20 20 28 74 63 t-dat))... (tc
1da0: 6f 6e 66 69 67 20 20 20 20 20 20 20 23 66 29 0a onfig #f).
1db0: 09 09 20 20 20 28 73 74 61 74 65 20 20 20 20 20 .. (state
1dc0: 20 20 20 20 28 69 66 20 6e 65 77 73 74 61 74 65 (if newstate
1dd0: 20 20 6e 65 77 73 74 61 74 65 20 20 28 64 62 3a newstate (db:
1de0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 20 test-get-state
1df0: 74 65 73 74 2d 64 61 74 29 29 29 0a 09 09 20 20 test-dat)))...
1e00: 20 28 73 74 61 74 75 73 20 20 20 20 20 20 20 20 (status
1e10: 28 69 66 20 6e 65 77 73 74 61 74 75 73 20 6e 65 (if newstatus ne
1e20: 77 73 74 61 74 75 73 20 28 64 62 3a 74 65 73 74 wstatus (db:test
1e30: 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 74 -get-status test
1e40: 2d 64 61 74 29 29 29 29 0a 09 20 20 20 20 20 20 -dat))))..
1e50: 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 ;; (mutex-lock!
1e60: 2a 74 72 69 67 67 65 72 73 2d 6d 75 74 65 78 2a *triggers-mutex*
1e70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1e80: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
1e90: 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ns.
1ea0: 20 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 exn.
1eb0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
1ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
1ed0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
1ee0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1ef0: 6f 72 74 2a 20 22 20 45 78 63 65 70 74 69 6f 6e ort* " Exception
1f00: 20 69 6e 20 6d 74 3a 70 72 6f 63 65 73 73 2d 74 in mt:process-t
1f10: 72 69 67 67 65 72 73 20 66 6f 72 20 72 75 6e 2d riggers for run-
1f20: 69 64 3d 22 72 75 6e 2d 69 64 22 20 74 65 73 74 id="run-id" test
1f30: 2d 69 64 3d 22 74 65 73 74 2d 69 64 22 20 6e 65 -id="test-id" ne
1f40: 77 73 74 61 74 65 3d 22 6e 65 77 73 74 61 74 65 wstate="newstate
1f50: 22 20 6e 65 77 73 74 61 74 75 73 3d 22 6e 65 77 " newstatus="new
1f60: 73 74 61 74 75 73 0a 20 20 20 20 20 20 20 20 20 status.
1f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f80: 20 20 20 20 20 20 20 20 20 20 20 22 5c 6e 20 20 "\n
1f90: 20 65 72 72 6f 72 3a 20 22 20 28 28 63 6f 6e 64 error: " ((cond
1fa0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
1fb0: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
1fc0: 73 73 61 67 65 29 20 65 78 6e 29 0a 20 20 20 20 ssage) exn).
1fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ff0: 22 5c 6e 20 20 20 74 65 73 74 2d 72 75 6e 64 69 "\n test-rundi
2000: 72 3d 22 74 65 73 74 2d 72 75 6e 64 69 72 0a 20 r="test-rundir.
2010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2030: 20 20 20 22 5c 6e 20 20 20 74 65 73 74 2d 6e 61 "\n test-na
2040: 6d 65 3d 22 74 65 73 74 2d 6e 61 6d 65 0a 20 20 me="test-name.
2050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2070: 20 20 22 5c 6e 20 20 20 69 74 65 6d 2d 70 61 74 "\n item-pat
2080: 68 3d 22 69 74 65 6d 2d 70 61 74 68 0a 20 20 20 h="item-path.
2090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20b0: 20 22 5c 6e 20 20 20 73 74 61 74 65 3d 22 73 74 "\n state="st
20c0: 61 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ate.
20d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20e0: 20 20 20 20 20 20 20 20 22 5c 6e 20 20 20 73 74 "\n st
20f0: 61 74 75 73 3d 22 73 74 61 74 75 73 0a 20 20 20 atus="status.
2100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2120: 20 22 5c 6e 22 29 0a 20 20 20 20 20 20 20 20 20 "\n").
2130: 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 (print-c
2140: 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 all-chain (curre
2150: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
2160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2170: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 #f).
2180: 20 20 20 20 28 69 66 20 28 61 6e 64 20 74 65 73 (if (and tes
2190: 74 2d 6e 61 6d 65 0a 20 20 20 20 20 20 20 20 20 t-name.
21a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 t
21b0: 65 73 74 2d 72 75 6e 64 69 72 29 20 20 20 3b 3b est-rundir) ;;
21c0: 20 23 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 72 #f means no dir
21d0: 20 73 65 74 20 79 65 74 0a 20 20 20 20 20 20 20 set yet.
21e0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 ;; (
21f0: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
2200: 74 73 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 29 ts? test-rundir)
2210: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2220: 20 20 20 20 3b 3b 20 28 64 69 72 65 63 74 6f 72 ;; (director
2230: 79 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 29 29 y? test-rundir))
2240: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2250: 20 20 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d 65 (call-with-e
2260: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
2270: 62 6c 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 bles.
2280: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 (list (
2290: 63 6f 6e 73 20 22 4d 54 5f 54 45 53 54 5f 4e 41 cons "MT_TEST_NA
22a0: 4d 45 22 20 20 20 20 28 6f 72 20 74 65 73 74 2d ME" (or test-
22b0: 6e 61 6d 65 20 22 6e 6f 20 73 75 63 68 20 74 65 name "no such te
22c0: 73 74 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 st")).
22d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
22e0: 28 63 6f 6e 73 20 22 4d 54 5f 54 45 53 54 5f 52 (cons "MT_TEST_R
22f0: 55 4e 5f 44 49 52 22 20 28 6f 72 20 74 65 73 74 UN_DIR" (or test
2300: 2d 72 75 6e 64 69 72 20 22 6e 6f 20 74 65 73 74 -rundir "no test
2310: 20 64 69 72 65 63 74 6f 72 79 20 79 65 74 22 29 directory yet")
2320: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2330: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
2340: 73 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 20 s "MT_ITEMPATH"
2350: 20 20 20 20 28 6f 72 20 69 74 65 6d 2d 70 61 74 (or item-pat
2360: 68 20 22 22 29 29 29 0a 20 20 20 20 20 20 20 20 h ""))).
2370: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d (lam
2380: 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 bda ().
2390: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
23a0: 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 (directory-exis
23b0: 74 73 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 29 ts? test-rundir)
23c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
23d0: 20 20 20 20 20 20 20 20 20 20 20 28 70 75 73 68 (push
23e0: 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d -directory test-
23f0: 72 75 6e 64 69 72 29 0a 20 20 20 20 20 20 20 20 rundir).
2400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2410: 20 20 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 (push-director
2420: 79 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 20 20 y *toppath*)).
2430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2440: 20 20 20 20 28 73 65 74 21 20 74 63 6f 6e 66 69 (set! tconfi
2450: 67 20 28 6d 74 3a 6c 61 7a 79 2d 72 65 61 64 2d g (mt:lazy-read-
2460: 74 65 73 74 2d 63 6f 6e 66 69 67 20 74 65 73 74 test-config test
2470: 2d 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 -name)).
2480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
2490: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
24a0: 28 74 72 69 67 67 65 72 29 0a 20 20 20 20 20 20 (trigger).
24b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
24c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
24d0: 2a 20 28 28 6d 75 6e 67 65 64 2d 74 72 69 67 67 * ((munged-trigg
24e0: 65 72 20 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 er (string-trans
24f0: 6c 61 74 65 20 74 72 69 67 67 65 72 20 22 2f 20 late trigger "/
2500: 22 20 22 2d 2d 22 29 29 0a 09 09 09 09 09 28 6c " "--"))......(l
2510: 6f 67 6e 61 6d 65 20 20 20 20 20 20 20 20 28 63 ogname (c
2520: 6f 6e 63 20 22 6c 61 73 74 2d 74 72 69 67 67 65 onc "last-trigge
2530: 72 2d 22 20 6d 75 6e 67 65 64 2d 74 72 69 67 67 r-" munged-trigg
2540: 65 72 20 22 2e 6c 6f 67 22 29 29 29 0a 20 20 20 er ".log"))).
2550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2570: 20 3b 3b 20 66 69 72 73 74 20 61 6e 79 20 74 72 ;; first any tr
2580: 69 67 67 65 72 73 20 66 72 6f 6d 20 74 68 65 20 iggers from the
2590: 74 65 73 74 63 6f 6e 66 69 67 0a 20 20 20 20 20 testconfig.
25a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
25b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
25c0: 6c 65 74 20 28 28 63 6d 64 20 20 28 63 6f 6e 66 let ((cmd (conf
25d0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 igf:lookup tconf
25e0: 69 67 20 22 74 72 69 67 67 65 72 73 22 20 74 72 ig "triggers" tr
25f0: 69 67 67 65 72 29 29 29 0a 20 20 20 20 20 20 20 igger))).
2600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2620: 69 66 20 63 6d 64 20 28 6d 74 3a 72 75 6e 2d 74 if cmd (mt:run-t
2630: 72 69 67 67 65 72 20 63 6d 64 20 74 65 73 74 2d rigger cmd test-
2640: 69 64 20 74 65 73 74 2d 72 75 6e 64 69 72 20 74 id test-rundir t
2650: 72 69 67 67 65 72 20 28 63 6f 6e 63 20 22 74 63 rigger (conc "tc
2660: 6f 6e 66 69 67 2d 22 20 6c 6f 67 6e 61 6d 65 29 onfig-" logname)
2670: 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d test-name item-
2680: 70 61 74 68 20 65 76 65 6e 74 2d 74 69 6d 65 20 path event-time
2690: 73 74 61 74 65 20 73 74 61 74 75 73 29 29 29 0a state status))).
26a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26c0: 20 20 20 20 3b 3b 20 6e 65 78 74 20 61 6e 79 20 ;; next any
26d0: 74 72 69 67 67 65 72 73 20 66 72 6f 6d 20 6d 65 triggers from me
26e0: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 0a 20 20 gatest.config.
26f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2710: 20 20 28 6c 65 74 20 28 28 63 6d 64 20 20 28 63 (let ((cmd (c
2720: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
2730: 6f 6e 66 69 67 64 61 74 2a 20 22 74 72 69 67 67 onfigdat* "trigg
2740: 65 72 73 22 20 74 72 69 67 67 65 72 29 29 29 0a ers" trigger))).
2750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2770: 20 20 20 20 20 20 28 69 66 20 63 6d 64 20 28 6d (if cmd (m
2780: 74 3a 72 75 6e 2d 74 72 69 67 67 65 72 20 63 6d t:run-trigger cm
2790: 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 72 d test-id test-r
27a0: 75 6e 64 69 72 20 74 72 69 67 67 65 72 20 28 63 undir trigger (c
27b0: 6f 6e 63 20 22 6d 74 63 6f 6e 66 69 67 2d 22 20 onc "mtconfig-"
27c0: 6c 6f 67 6e 61 6d 65 29 20 74 65 73 74 2d 6e 61 logname) test-na
27d0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 65 76 65 me item-path eve
27e0: 6e 74 2d 74 69 6d 65 20 73 74 61 74 65 20 73 74 nt-time state st
27f0: 61 74 75 73 29 29 29 29 29 0a 20 20 20 20 20 20 atus))))).
2800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2810: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 0a (list.
2820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2840: 20 28 63 6f 6e 63 20 73 74 61 74 65 20 22 2f 22 (conc state "/"
2850: 20 73 74 61 74 75 73 29 0a 20 20 20 20 20 20 20 status).
2860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2870: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 (conc
2880: 73 74 61 74 65 20 22 2f 22 29 0a 20 20 20 20 20 state "/").
2890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
28a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
28b0: 63 20 22 2f 22 20 73 74 61 74 75 73 29 29 29 0a c "/" status))).
28c0: 09 09 20 20 20 20 20 28 70 6f 70 2d 64 69 72 65 .. (pop-dire
28d0: 63 74 6f 72 79 29 29 0a 20 20 20 20 20 20 20 20 ctory)).
28e0: 20 20 20 20 20 20 20 20 20 20 20 20 29 29 29 0a ))).
28f0: 09 20 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 . ;; (mutex
2900: 2d 75 6e 6c 6f 63 6b 21 20 2a 74 72 69 67 67 65 -unlock! *trigge
2910: 72 73 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 rs-mutex*)..
2920: 20 20 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d )))))..;;=====
2930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2970: 3d 0a 3b 3b 20 20 53 20 54 20 41 20 54 20 45 20 =.;; S T A T E
2980: 20 20 41 20 4e 20 44 20 20 20 53 20 54 20 41 20 A N D S T A
2990: 54 20 55 20 53 20 20 20 46 20 4f 20 52 20 20 20 T U S F O R
29a0: 54 20 45 20 53 20 54 20 53 20 0a 3b 3b 3d 3d 3d T E S T S .;;===
29b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29f0: 3d 3d 3d 0a 0a 3b 3b 20 73 70 65 65 64 20 75 70 ===..;; speed up
2a00: 20 66 6f 72 20 63 6f 6d 6d 6f 6e 20 63 61 73 65 for common case
2a10: 73 20 77 69 74 68 20 61 20 6c 69 74 74 6c 65 20 s with a little
2a20: 6c 6f 67 69 63 0a 28 64 65 66 69 6e 65 20 28 6d logic.(define (m
2a30: 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
2a40: 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 -status-by-id ru
2a50: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 n-id test-id new
2a60: 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 state newstatus
2a70: 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 69 newcomment). (i
2a80: 66 20 28 6e 6f 74 20 28 61 6e 64 20 72 75 6e 2d f (not (and run-
2a90: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 20 20 20 id test-id)).
2aa0: 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 (begin..(debu
2ab0: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
2ac0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2ad0: 74 2a 20 22 62 61 64 20 64 61 74 61 20 68 61 6e t* "bad data han
2ae0: 64 65 64 20 74 6f 20 6d 74 3a 74 65 73 74 2d 73 ded to mt:test-s
2af0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
2b00: 62 79 2d 69 64 2c 20 72 75 6e 2d 69 64 3d 22 20 by-id, run-id="
2b10: 72 75 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 69 run-id ", test-i
2b20: 64 3d 22 20 74 65 73 74 2d 69 64 20 22 2c 20 6e d=" test-id ", n
2b30: 65 77 73 74 61 74 65 3d 22 20 6e 65 77 73 74 61 ewstate=" newsta
2b40: 74 65 29 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c te)..(print-call
2b50: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
2b60: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 23 66 error-port))..#f
2b70: 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ). (begin..
2b80: 3b 3b 20 63 6f 6e 64 0a 09 3b 3b 20 28 28 61 6e ;; cond..;; ((an
2b90: 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 d newstate newst
2ba0: 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 atus newcomment)
2bb0: 0a 09 3b 3b 20 20 28 72 6d 74 3a 67 65 6e 65 72 ..;; (rmt:gener
2bc0: 61 6c 2d 63 61 6c 6c 20 27 73 74 61 74 65 2d 73 al-call 'state-s
2bd0: 74 61 74 75 73 2d 6d 73 67 20 72 75 6e 2d 69 64 tatus-msg run-id
2be0: 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 newstate newsta
2bf0: 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 20 74 tus newcomment t
2c00: 65 73 74 2d 69 64 29 29 0a 09 3b 3b 20 28 28 61 est-id))..;; ((a
2c10: 6e 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 nd newstate news
2c20: 74 61 74 75 73 29 0a 09 3b 3b 20 20 28 72 6d 74 tatus)..;; (rmt
2c30: 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 :general-call 's
2c40: 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d tate-status run-
2c50: 69 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 id newstate news
2c60: 74 61 74 75 73 20 74 65 73 74 2d 69 64 29 29 0a tatus test-id)).
2c70: 09 3b 3b 20 28 65 6c 73 65 0a 09 3b 3b 20 20 28 .;; (else..;; (
2c80: 69 66 20 6e 65 77 73 74 61 74 65 20 20 20 28 72 if newstate (r
2c90: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
2ca0: 27 73 65 74 2d 74 65 73 74 2d 73 74 61 74 65 20 'set-test-state
2cb0: 20 20 72 75 6e 2d 69 64 20 6e 65 77 73 74 61 74 run-id newstat
2cc0: 65 20 20 20 74 65 73 74 2d 69 64 29 29 0a 09 3b e test-id))..;
2cd0: 3b 20 20 28 69 66 20 6e 65 77 73 74 61 74 75 73 ; (if newstatus
2ce0: 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 (rmt:general-c
2cf0: 61 6c 6c 20 27 73 65 74 2d 74 65 73 74 2d 73 74 all 'set-test-st
2d00: 61 74 75 73 20 20 72 75 6e 2d 69 64 20 6e 65 77 atus run-id new
2d10: 73 74 61 74 75 73 20 20 74 65 73 74 2d 69 64 29 status test-id)
2d20: 29 0a 09 3b 3b 20 20 28 69 66 20 6e 65 77 63 6f )..;; (if newco
2d30: 6d 6d 65 6e 74 20 28 72 6d 74 3a 67 65 6e 65 72 mment (rmt:gener
2d40: 61 6c 2d 63 61 6c 6c 20 27 73 65 74 2d 74 65 73 al-call 'set-tes
2d50: 74 2d 63 6f 6d 6d 65 6e 74 20 72 75 6e 2d 69 64 t-comment run-id
2d60: 20 6e 65 77 63 6f 6d 6d 65 6e 74 20 74 65 73 74 newcomment test
2d70: 2d 69 64 29 29 29 29 0a 09 28 72 6d 74 3a 73 65 -id))))..(rmt:se
2d80: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 t-state-status-a
2d90: 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 nd-roll-up-items
2da0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
2db0: 23 66 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 #f newstate news
2dc0: 74 61 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 tatus newcomment
2dd0: 29 0a 09 3b 3b 20 28 6d 74 3a 70 72 6f 63 65 73 )..;; (mt:proces
2de0: 73 2d 74 72 69 67 67 65 72 73 20 72 75 6e 2d 69 s-triggers run-i
2df0: 64 20 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 d test-id newsta
2e00: 74 65 20 6e 65 77 73 74 61 74 75 73 29 0a 09 23 te newstatus)..#
2e10: 74 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 t)))...(define (
2e20: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
2e30: 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 64 2d 75 e-status-by-id-u
2e40: 6e 6c 65 73 73 2d 63 6f 6d 70 6c 65 74 65 64 20 nless-completed
2e50: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e run-id test-id n
2e60: 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 ewstate newstatu
2e70: 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 20 20 s newcomment).
2e80: 28 6c 65 74 2a 20 28 28 74 65 73 74 2d 76 65 63 (let* ((test-vec
2e90: 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
2ea0: 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 info-state-statu
2eb0: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
2ec0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 74 61 )). (sta
2ed0: 74 65 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 te (vector-r
2ee0: 65 66 20 74 65 73 74 2d 76 65 63 20 33 29 29 29 ef test-vec 3)))
2ef0: 0a 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f . (if (equal?
2f00: 20 73 74 61 74 65 20 22 43 4f 4d 50 4c 45 54 45 state "COMPLETE
2f10: 44 22 29 0a 20 20 20 20 20 20 20 20 23 74 0a 20 D"). #t.
2f20: 20 20 20 20 20 20 20 28 72 6d 74 3a 73 65 74 2d (rmt:set-
2f30: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
2f40: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
2f50: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 23 66 un-id test-id #f
2f60: 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 newstate newsta
2f70: 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 29 tus newcomment))
2f80: 29 29 0a 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 )).. .(define (
2f90: 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 mt:test-set-stat
2fa0: 65 2d 73 74 61 74 75 73 2d 62 79 2d 74 65 73 74 e-status-by-test
2fb0: 6e 61 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 name run-id test
2fc0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
2fd0: 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 74 new-state new-st
2fe0: 61 74 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e 74 atus new-comment
2ff0: 29 0a 20 20 3b 28 6c 65 74 20 28 28 74 65 73 74 ). ;(let ((test
3000: 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 -id (rmt:get-tes
3010: 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 t-id run-id test
3020: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
3030: 29 29 0a 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 )). (rmt:set-st
3040: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
3050: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e oll-up-items run
3060: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
3070: 65 6d 2d 70 61 74 68 20 6e 65 77 2d 73 74 61 74 em-path new-stat
3080: 65 20 6e 65 77 2d 73 74 61 74 75 73 20 6e 65 77 e new-status new
3090: 2d 63 6f 6d 6d 65 6e 74 29 0a 20 20 3b 3b 20 28 -comment). ;; (
30a0: 6d 74 3a 70 72 6f 63 65 73 73 2d 74 72 69 67 67 mt:process-trigg
30b0: 65 72 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d ers run-id test-
30c0: 69 64 20 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 id new-state new
30d0: 2d 73 74 61 74 75 73 29 0a 20 20 23 74 29 3b 29 -status). #t);)
30e0: 0a 09 3b 3b 28 6d 74 3a 74 65 73 74 2d 73 65 74 ..;;(mt:test-set
30f0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 -state-status-by
3100: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
3110: 69 64 20 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 id new-state new
3120: 2d 73 74 61 74 75 73 20 6e 65 77 2d 63 6f 6d 6d -status new-comm
3130: 65 6e 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ent)))..(define
3140: 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 (mt:test-set-sta
3150: 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 74 65 73 te-status-by-tes
3160: 74 6e 61 6d 65 2d 75 6e 6c 65 73 73 2d 63 6f 6d tname-unless-com
3170: 70 6c 65 74 65 64 20 72 75 6e 2d 69 64 20 74 65 pleted run-id te
3180: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
3190: 68 20 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d h new-state new-
31a0: 73 74 61 74 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 status new-comme
31b0: 6e 74 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 nt). (let ((tes
31c0: 74 2d 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 t-id (rmt:get-te
31d0: 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 st-id run-id tes
31e0: 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
31f0: 29 29 29 0a 20 20 20 20 28 6d 74 3a 74 65 73 74 ))). (mt:test
3200: 2d 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 -set-state-statu
3210: 73 2d 62 79 2d 69 64 2d 75 6e 6c 65 73 73 2d 63 s-by-id-unless-c
3220: 6f 6d 70 6c 65 74 65 64 20 72 75 6e 2d 69 64 20 ompleted run-id
3230: 74 65 73 74 2d 69 64 20 6e 65 77 2d 73 74 61 74 test-id new-stat
3240: 65 20 6e 65 77 2d 73 74 61 74 75 73 20 6e 65 77 e new-status new
3250: 2d 63 6f 6d 6d 65 6e 74 29 29 29 0a 20 20 20 20 -comment))).
3260: 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a 6c 61 7a .(define (mt:laz
3270: 79 2d 72 65 61 64 2d 74 65 73 74 2d 63 6f 6e 66 y-read-test-conf
3280: 69 67 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 ig test-name).
3290: 28 6c 65 74 20 28 28 74 63 6f 6e 66 20 28 68 61 (let ((tconf (ha
32a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
32b0: 61 75 6c 74 20 2a 74 65 73 74 63 6f 6e 66 69 67 ault *testconfig
32c0: 73 2a 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 s* test-name #f)
32d0: 29 29 0a 20 20 20 20 28 69 66 20 74 63 6f 6e 66 )). (if tconf
32e0: 0a 09 74 63 6f 6e 66 0a 09 28 6c 65 74 20 28 28 ..tconf..(let ((
32f0: 74 65 73 74 2d 64 69 72 73 20 28 74 65 73 74 73 test-dirs (tests
3300: 3a 67 65 74 2d 74 65 73 74 73 2d 73 65 61 72 63 :get-tests-searc
3310: 68 2d 70 61 74 68 20 2a 63 6f 6e 66 69 67 64 61 h-path *configda
3320: 74 2a 29 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f t*))).. (let lo
3330: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 74 65 op ((hed (car te
3340: 73 74 2d 64 69 72 73 29 29 0a 09 09 20 20 20 20 st-dirs))...
3350: 20 28 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d (tal (cdr test-
3360: 64 69 72 73 29 29 29 0a 09 20 20 20 20 3b 3b 20 dirs))).. ;;
3370: 53 65 74 74 69 6e 67 20 4d 54 5f 4c 49 4e 4b 54 Setting MT_LINKT
3380: 52 45 45 20 68 65 72 65 20 69 73 20 61 6c 6d 6f REE here is almo
3390: 73 74 20 63 65 72 74 61 69 6e 6c 79 20 75 6e 6e st certainly unn
33a0: 65 63 65 73 73 61 72 79 2e 20 0a 09 20 20 20 20 ecessary. ..
33b0: 28 6c 65 74 20 28 28 74 63 6f 6e 66 69 67 2d 66 (let ((tconfig-f
33c0: 69 6c 65 20 28 63 6f 6e 63 20 68 65 64 20 22 2f ile (conc hed "/
33d0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 74 65 " test-name "/te
33e0: 73 74 63 6f 6e 66 69 67 22 29 29 29 0a 09 20 20 stconfig")))..
33f0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 63 6f (if (and (co
3400: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
3410: 3f 20 74 63 6f 6e 66 69 67 2d 66 69 6c 65 29 0a ? tconfig-file).
3420: 09 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d 72 .. (file-r
3430: 65 61 64 2d 61 63 63 65 73 73 3f 20 74 63 6f 6e ead-access? tcon
3440: 66 69 67 2d 66 69 6c 65 29 29 0a 09 09 20 20 28 fig-file))... (
3450: 6c 65 74 20 28 28 6c 69 6e 6b 2d 74 72 65 65 2d let ((link-tree-
3460: 70 61 74 68 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 path (common:get
3470: 2d 6c 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 28 -linktree)) ;; (
3480: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
3490: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
34a0: 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 0a p" "linktree")).
34b0: 09 09 09 28 6f 6c 64 2d 6c 69 6e 6b 2d 74 72 65 ...(old-link-tre
34c0: 65 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d e (get-environm
34d0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 ent-variable "MT
34e0: 5f 4c 49 4e 4b 54 52 45 45 22 29 29 29 0a 09 09 _LINKTREE")))...
34f0: 20 20 20 20 28 69 66 20 6c 69 6e 6b 2d 74 72 65 (if link-tre
3500: 65 2d 70 61 74 68 20 28 73 65 74 65 6e 76 20 22 e-path (setenv "
3510: 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 20 6c 69 6e MT_LINKTREE" lin
3520: 6b 2d 74 72 65 65 2d 70 61 74 68 29 29 0a 09 09 k-tree-path))...
3530: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 74 63 (let ((newtc
3540: 66 67 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 fg (read-config
3550: 74 63 6f 6e 66 69 67 2d 66 69 6c 65 20 23 66 20 tconfig-file #f
3560: 23 66 29 29 29 20 3b 3b 20 4e 4f 54 45 3a 20 44 #f))) ;; NOTE: D
3570: 6f 65 73 20 4e 4f 54 20 72 75 6e 20 5b 73 79 73 oes NOT run [sys
3580: 74 65 6d 20 2e 2e 2e 5d 0a 09 09 20 20 20 20 20 tem ...]...
3590: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
35a0: 21 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 ! *testconfigs*
35b0: 74 65 73 74 2d 6e 61 6d 65 20 6e 65 77 74 63 66 test-name newtcf
35c0: 67 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 6f g)... (if o
35d0: 6c 64 2d 6c 69 6e 6b 2d 74 72 65 65 20 0a 09 09 ld-link-tree ...
35e0: 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 4c . (setenv "MT_L
35f0: 49 4e 4b 54 52 45 45 22 20 6f 6c 64 2d 6c 69 6e INKTREE" old-lin
3600: 6b 2d 74 72 65 65 29 0a 09 09 09 20 20 28 75 6e k-tree).... (un
3610: 73 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 setenv "MT_LINKT
3620: 52 45 45 22 29 29 0a 09 09 20 20 20 20 20 20 6e REE"))... n
3630: 65 77 74 63 66 67 29 29 0a 09 09 20 20 28 69 66 ewtcfg))... (if
3640: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
3650: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 (begin....(
3660: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
3670: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
3680: 2d 70 6f 72 74 2a 20 22 4e 6f 20 72 65 61 64 61 -port* "No reada
3690: 62 6c 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 ble testconfig f
36a0: 6f 75 6e 64 20 66 6f 72 20 22 20 74 65 73 74 2d ound for " test-
36b0: 6e 61 6d 65 29 0a 09 09 09 23 66 29 0a 09 09 20 name)....#f)...
36c0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
36d0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
36e0: 29 29 29 29 29 29 0a 0a ))))))..