Artifact
283ae4be89a02ae69d1deafe06ffc1f9a367f1d4:
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 0a 28 uses filedb))..(
0490: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
04a0: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 records.scm").(i
04b0: 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 6f nclude "key_reco
04c0: 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 rds.scm").(inclu
04d0: 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e 73 de "db_records.s
04e0: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 72 cm").(include "r
04f0: 75 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 un_records.scm")
0500: 0a 28 69 6e 63 6c 75 64 65 20 22 74 65 73 74 5f .(include "test_
0510: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b records.scm")..;
0520: 3b 20 54 68 69 73 20 69 73 20 74 68 65 20 4d 65 ; This is the Me
0530: 67 61 74 65 73 74 20 41 50 49 2e 20 41 6c 6c 20 gatest API. All
0540: 67 65 6e 65 72 61 6c 6c 79 20 22 75 73 65 66 75 generally "usefu
0550: 6c 22 20 72 6f 75 74 69 6e 65 73 20 77 69 6c 6c l" routines will
0560: 20 62 65 20 77 72 61 70 70 65 64 20 6f 72 20 65 be wrapped or e
0570: 78 74 65 6e 64 65 64 0a 3b 3b 20 68 65 72 65 2e xtended.;; here.
0580: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
0590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 52 ==========.;; R
05d0: 20 55 20 4e 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d U N S.;;=======
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 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
0620: 0a 3b 3b 20 72 75 6e 73 3a 67 65 74 2d 72 75 6e .;; runs:get-run
0630: 73 2d 62 79 2d 70 61 74 74 0a 3b 3b 20 67 65 74 s-by-patt.;; get
0640: 20 72 75 6e 73 20 62 79 20 6c 69 73 74 20 6f 66 runs by list of
0650: 20 63 72 69 74 65 72 69 61 0a 3b 3b 20 72 65 67 criteria.;; reg
0660: 69 73 74 65 72 20 61 20 74 65 73 74 20 72 75 6e ister a test run
0670: 20 77 69 74 68 20 74 68 65 20 64 62 0a 3b 3b 0a with the db.;;.
0680: 3b 3b 20 55 73 65 3a 20 28 64 62 2d 67 65 74 2d ;; Use: (db-get-
0690: 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 72 20 value-by-header
06a0: 28 64 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 (db:get-header r
06b0: 75 6e 69 6e 66 6f 29 28 64 62 3a 67 65 74 2d 72 uninfo)(db:get-r
06c0: 6f 77 73 20 72 75 6e 69 6e 66 6f 29 29 0a 3b 3b ows runinfo)).;;
06d0: 20 20 74 6f 20 65 78 74 72 61 63 74 20 69 6e 66 to extract inf
06e0: 6f 20 66 72 6f 6d 20 74 68 65 20 73 74 72 75 63 o from the struc
06f0: 74 75 72 65 20 72 65 74 75 72 6e 65 64 0a 3b 3b ture returned.;;
0700: 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a 67 65 74 .(define (mt:get
0710: 2d 72 75 6e 73 2d 62 79 2d 70 61 74 74 20 6b 65 -runs-by-patt ke
0720: 79 73 20 72 75 6e 6e 61 6d 65 70 61 74 74 20 74 ys runnamepatt t
0730: 61 72 67 70 61 74 74 29 0a 20 20 28 6c 65 74 20 argpatt). (let
0740: 6c 6f 6f 70 20 28 28 72 75 6e 73 64 61 74 20 20 loop ((runsdat
0750: 28 72 6d 74 3a 67 65 74 2d 72 75 6e 73 2d 62 79 (rmt:get-runs-by
0760: 2d 70 61 74 74 20 6b 65 79 73 20 72 75 6e 6e 61 -patt keys runna
0770: 6d 65 70 61 74 74 20 74 61 72 67 70 61 74 74 20 mepatt targpatt
0780: 30 20 35 30 30 20 23 66 20 30 29 29 0a 09 20 20 0 500 #f 0))..
0790: 20 20 20 28 72 65 73 20 20 20 20 20 20 27 28 29 (res '()
07a0: 29 0a 09 20 20 20 20 20 28 6f 66 66 73 65 74 20 ).. (offset
07b0: 20 20 30 29 0a 09 20 20 20 20 20 28 6c 69 6d 69 0).. (limi
07c0: 74 20 20 20 20 35 30 30 29 29 0a 20 20 20 20 3b t 500)). ;
07d0: 3b 20 28 70 72 69 6e 74 20 22 72 75 6e 73 64 61 ; (print "runsda
07e0: 74 3a 20 22 20 72 75 6e 73 64 61 74 29 0a 20 20 t: " runsdat).
07f0: 20 20 28 6c 65 74 2a 20 28 28 68 65 61 64 65 72 (let* ((header
0800: 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 (vector-ref
0810: 72 75 6e 73 64 61 74 20 30 29 29 0a 09 20 20 20 runsdat 0))..
0820: 28 72 75 6e 73 6c 73 74 20 20 20 28 76 65 63 74 (runslst (vect
0830: 6f 72 2d 72 65 66 20 72 75 6e 73 64 61 74 20 31 or-ref runsdat 1
0840: 29 29 0a 09 20 20 20 28 66 75 6c 6c 2d 6c 69 73 )).. (full-lis
0850: 74 20 28 61 70 70 65 6e 64 20 72 65 73 20 72 75 t (append res ru
0860: 6e 73 6c 73 74 29 29 0a 09 20 20 20 28 68 61 76 nslst)).. (hav
0870: 65 2d 6d 6f 72 65 20 28 65 71 3f 20 28 6c 65 6e e-more (eq? (len
0880: 67 74 68 20 72 75 6e 73 6c 73 74 29 20 6c 69 6d gth runslst) lim
0890: 69 74 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 it))). ;; (
08a0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
08b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
08c0: 20 22 68 65 61 64 65 72 3a 20 22 20 68 65 61 64 "header: " head
08d0: 65 72 20 22 20 72 75 6e 73 6c 73 74 3a 20 22 20 er " runslst: "
08e0: 72 75 6e 73 6c 73 74 20 22 20 68 61 76 65 2d 6d runslst " have-m
08f0: 6f 72 65 3a 20 22 20 68 61 76 65 2d 6d 6f 72 65 ore: " have-more
0900: 29 0a 20 20 20 20 20 20 28 69 66 20 68 61 76 65 ). (if have
0910: 2d 6d 6f 72 65 20 0a 09 20 20 28 6c 65 74 20 28 -more .. (let (
0920: 28 6e 65 77 2d 6f 66 66 73 65 74 20 28 2b 20 6f (new-offset (+ o
0930: 66 66 73 65 74 20 6c 69 6d 69 74 29 29 0a 09 09 ffset limit))...
0940: 28 6e 65 78 74 2d 62 61 74 63 68 20 28 72 6d 74 (next-batch (rmt
0950: 3a 67 65 74 2d 72 75 6e 73 2d 62 79 2d 70 61 74 :get-runs-by-pat
0960: 74 20 6b 65 79 73 20 72 75 6e 6e 61 6d 65 70 61 t keys runnamepa
0970: 74 74 20 74 61 72 67 70 61 74 74 20 6f 66 66 73 tt targpatt offs
0980: 65 74 20 6c 69 6d 69 74 20 23 66 20 30 29 29 29 et limit #f 0)))
0990: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
09a0: 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 nt-info 4 *defau
09b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 6f lt-log-port* "Mo
09c0: 72 65 20 74 68 61 6e 20 22 20 6c 69 6d 69 74 20 re than " limit
09d0: 22 20 72 75 6e 73 2c 20 68 61 76 65 20 22 20 28 " runs, have " (
09e0: 6c 65 6e 67 74 68 20 66 75 6c 6c 2d 6c 69 73 74 length full-list
09f0: 29 20 22 20 72 75 6e 73 20 73 6f 20 66 61 72 2e ) " runs so far.
0a00: 22 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 ").. (debug:p
0a10: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
0a20: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0a30: 6e 65 78 74 2d 62 61 74 63 68 3a 20 22 20 6e 65 next-batch: " ne
0a40: 78 74 2d 62 61 74 63 68 29 0a 09 20 20 20 20 28 xt-batch).. (
0a50: 6c 6f 6f 70 20 6e 65 78 74 2d 62 61 74 63 68 0a loop next-batch.
0a60: 09 09 20 20 66 75 6c 6c 2d 6c 69 73 74 0a 09 09 .. full-list...
0a70: 20 20 6e 65 77 2d 6f 66 66 73 65 74 0a 09 09 20 new-offset...
0a80: 20 6c 69 6d 69 74 29 29 0a 09 20 28 76 65 63 74 limit)).. (vect
0a90: 6f 72 20 68 65 61 64 65 72 20 66 75 6c 6c 2d 6c or header full-l
0aa0: 69 73 74 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d ist)))))..;;====
0ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0af0: 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 53 ==.;; T E S T S
0b00: 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
0b50: 6e 65 20 28 6d 74 3a 67 65 74 2d 74 65 73 74 73 ne (mt:get-tests
0b60: 2d 66 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 -for-run run-id
0b70: 74 65 73 74 70 61 74 74 20 73 74 61 74 65 73 20 testpatt states
0b80: 73 74 61 74 75 73 20 23 21 6b 65 79 20 28 6e 6f status #!key (no
0b90: 74 2d 69 6e 20 23 74 29 20 28 73 6f 72 74 2d 62 t-in #t) (sort-b
0ba0: 79 20 27 65 76 65 6e 74 5f 74 69 6d 65 29 20 28 y 'event_time) (
0bb0: 73 6f 72 74 2d 6f 72 64 65 72 20 22 41 53 43 22 sort-order "ASC"
0bc0: 29 20 28 71 72 79 76 61 6c 73 20 23 66 29 28 6c ) (qryvals #f)(l
0bd0: 61 73 74 2d 75 70 64 61 74 65 20 23 66 29 29 0a ast-update #f)).
0be0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 74 65 (let loop ((te
0bf0: 73 74 73 64 61 74 20 28 72 6d 74 3a 67 65 74 2d stsdat (rmt:get-
0c00: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 tests-for-run ru
0c10: 6e 2d 69 64 20 74 65 73 74 70 61 74 74 20 73 74 n-id testpatt st
0c20: 61 74 65 73 20 73 74 61 74 75 73 20 30 20 35 30 ates status 0 50
0c30: 30 20 6e 6f 74 2d 69 6e 20 73 6f 72 74 2d 62 79 0 not-in sort-by
0c40: 20 73 6f 72 74 2d 6f 72 64 65 72 20 71 72 79 76 sort-order qryv
0c50: 61 6c 73 20 6c 61 73 74 2d 75 70 64 61 74 65 20 als last-update
0c60: 27 6e 6f 72 6d 61 6c 29 29 0a 09 20 20 20 20 20 'normal))..
0c70: 28 72 65 73 20 20 20 20 20 20 27 28 29 29 0a 09 (res '())..
0c80: 20 20 20 20 20 28 6f 66 66 73 65 74 20 20 20 30 (offset 0
0c90: 29 0a 09 20 20 20 20 20 28 6c 69 6d 69 74 20 20 ).. (limit
0ca0: 20 20 35 30 30 29 29 0a 20 20 20 20 28 6c 65 74 500)). (let
0cb0: 2a 20 28 28 66 75 6c 6c 2d 6c 69 73 74 20 28 61 * ((full-list (a
0cc0: 70 70 65 6e 64 20 72 65 73 20 74 65 73 74 73 64 ppend res testsd
0cd0: 61 74 29 29 0a 09 20 20 20 28 68 61 76 65 2d 6d at)).. (have-m
0ce0: 6f 72 65 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 ore (eq? (length
0cf0: 20 74 65 73 74 73 64 61 74 29 20 6c 69 6d 69 74 testsdat) limit
0d00: 29 29 29 0a 20 20 20 20 20 20 28 69 66 20 68 61 ))). (if ha
0d10: 76 65 2d 6d 6f 72 65 20 0a 09 20 20 28 6c 65 74 ve-more .. (let
0d20: 20 28 28 6e 65 77 2d 6f 66 66 73 65 74 20 28 2b ((new-offset (+
0d30: 20 6f 66 66 73 65 74 20 6c 69 6d 69 74 29 29 29 offset limit)))
0d40: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
0d50: 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 nt-info 4 *defau
0d60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 6f lt-log-port* "Mo
0d70: 72 65 20 74 68 61 6e 20 22 20 6c 69 6d 69 74 20 re than " limit
0d80: 22 20 74 65 73 74 73 2c 20 68 61 76 65 20 22 20 " tests, have "
0d90: 28 6c 65 6e 67 74 68 20 66 75 6c 6c 2d 6c 69 73 (length full-lis
0da0: 74 29 20 22 20 74 65 73 74 73 20 73 6f 20 66 61 t) " tests so fa
0db0: 72 2e 22 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 r.").. (loop
0dc0: 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 73 2d 66 (rmt:get-tests-f
0dd0: 6f 72 2d 72 75 6e 20 72 75 6e 2d 69 64 20 74 65 or-run run-id te
0de0: 73 74 70 61 74 74 20 73 74 61 74 65 73 20 73 74 stpatt states st
0df0: 61 74 75 73 20 6e 65 77 2d 6f 66 66 73 65 74 20 atus new-offset
0e00: 6c 69 6d 69 74 20 6e 6f 74 2d 69 6e 20 73 6f 72 limit not-in sor
0e10: 74 2d 62 79 20 73 6f 72 74 2d 6f 72 64 65 72 20 t-by sort-order
0e20: 71 72 79 76 61 6c 73 20 6c 61 73 74 2d 75 70 64 qryvals last-upd
0e30: 61 74 65 20 27 6e 6f 72 6d 61 6c 29 0a 09 09 20 ate 'normal)...
0e40: 20 66 75 6c 6c 2d 6c 69 73 74 0a 09 09 20 20 6e full-list... n
0e50: 65 77 2d 6f 66 66 73 65 74 0a 09 09 20 20 6c 69 ew-offset... li
0e60: 6d 69 74 29 29 0a 09 20 20 66 75 6c 6c 2d 6c 69 mit)).. full-li
0e70: 73 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 st))))..(define
0e80: 28 6d 74 3a 6c 61 7a 79 2d 67 65 74 2d 70 72 65 (mt:lazy-get-pre
0e90: 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 6e reqs-not-met run
0ea0: 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 2d -id waitons ref-
0eb0: 69 74 65 6d 2d 70 61 74 68 20 23 21 6b 65 79 20 item-path #!key
0ec0: 28 6d 6f 64 65 20 27 28 6e 6f 72 6d 61 6c 29 29 (mode '(normal))
0ed0: 28 69 74 65 6d 6d 61 70 73 20 23 66 29 20 29 0a (itemmaps #f) ).
0ee0: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 (let* ((key
0ef0: 20 28 6c 69 73 74 20 72 75 6e 2d 69 64 20 77 61 (list run-id wa
0f00: 69 74 6f 6e 73 20 72 65 66 2d 69 74 65 6d 2d 70 itons ref-item-p
0f10: 61 74 68 20 6d 6f 64 65 29 29 0a 09 20 28 72 65 ath mode)).. (re
0f20: 73 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 s (hash-table
0f30: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 70 72 -ref/default *pr
0f40: 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 63 68 65 e-reqs-met-cache
0f50: 2a 20 6b 65 79 20 23 66 29 29 0a 09 20 28 75 73 * key #f)).. (us
0f60: 65 72 65 73 20 28 6c 65 74 20 28 28 6c 61 73 74 eres (let ((last
0f70: 2d 74 69 6d 65 20 28 69 66 20 28 76 65 63 74 6f -time (if (vecto
0f80: 72 3f 20 72 65 73 29 20 28 76 65 63 74 6f 72 2d r? res) (vector-
0f90: 72 65 66 20 72 65 73 20 30 29 20 23 66 29 29 29 ref res 0) #f)))
0fa0: 0a 09 09 20 20 20 28 69 66 20 6c 61 73 74 2d 74 ... (if last-t
0fb0: 69 6d 65 0a 09 09 20 20 20 20 20 20 20 28 3c 20 ime... (<
0fc0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
0fd0: 29 28 2b 20 6c 61 73 74 2d 74 69 6d 65 20 35 29 )(+ last-time 5)
0fe0: 29 0a 09 09 20 20 20 20 20 20 20 23 66 29 29 29 )... #f)))
0ff0: 29 0a 20 20 20 20 28 69 66 20 75 73 65 72 65 73 ). (if useres
1000: 0a 09 28 6c 65 74 20 28 28 72 65 73 75 6c 74 20 ..(let ((result
1010: 28 76 65 63 74 6f 72 2d 72 65 66 20 72 65 73 20 (vector-ref res
1020: 31 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 1))).. (debug:p
1030: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
1040: 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 73 69 6e 67 log-port* "Using
1050: 20 6c 61 7a 79 20 76 61 6c 75 65 20 72 65 73 3a lazy value res:
1060: 20 22 20 72 65 73 75 6c 74 29 0a 09 20 20 72 65 " result).. re
1070: 73 75 6c 74 29 0a 09 28 6c 65 74 20 28 28 6e 65 sult)..(let ((ne
1080: 77 72 65 73 20 28 72 6d 74 3a 67 65 74 2d 70 72 wres (rmt:get-pr
1090: 65 72 65 71 73 2d 6e 6f 74 2d 6d 65 74 20 72 75 ereqs-not-met ru
10a0: 6e 2d 69 64 20 77 61 69 74 6f 6e 73 20 72 65 66 n-id waitons ref
10b0: 2d 69 74 65 6d 2d 70 61 74 68 20 6d 6f 64 65 20 -item-path mode
10c0: 69 74 65 6d 6d 61 70 73 29 29 29 0a 09 20 20 28 itemmaps))).. (
10d0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
10e0: 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 *pre-reqs-met-ca
10f0: 63 68 65 2a 20 6b 65 79 20 28 76 65 63 74 6f 72 che* key (vector
1100: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
1110: 73 29 20 6e 65 77 72 65 73 29 29 0a 09 20 20 6e s) newres)).. n
1120: 65 77 72 65 73 29 29 29 29 0a 0a 28 64 65 66 69 ewres))))..(defi
1130: 6e 65 20 28 6d 74 3a 67 65 74 2d 72 75 6e 2d 73 ne (mt:get-run-s
1140: 74 61 74 73 20 64 62 73 74 72 75 63 74 20 72 75 tats dbstruct ru
1150: 6e 2d 69 64 29 0a 3b 3b 20 20 47 65 74 20 72 75 n-id).;; Get ru
1160: 6e 20 73 74 61 74 73 20 66 72 6f 6d 20 6c 6f 63 n stats from loc
1170: 61 6c 20 61 63 63 65 73 73 2c 20 6d 6f 76 65 20 al access, move
1180: 74 68 69 73 20 2e 2e 2e 20 62 75 74 20 77 68 65 this ... but whe
1190: 72 65 3f 0a 20 20 28 64 62 3a 67 65 74 2d 72 75 re?. (db:get-ru
11a0: 6e 2d 73 74 61 74 73 20 64 62 73 74 72 75 63 74 n-stats dbstruct
11b0: 20 72 75 6e 2d 69 64 29 29 0a 0a 28 64 65 66 69 run-id))..(defi
11c0: 6e 65 20 28 6d 74 3a 64 69 73 63 61 72 64 2d 62 ne (mt:discard-b
11d0: 6c 6f 63 6b 65 64 2d 74 65 73 74 73 20 72 75 6e locked-tests run
11e0: 2d 69 64 20 66 61 69 6c 65 64 2d 74 65 73 74 20 -id failed-test
11f0: 74 65 73 74 73 20 74 65 73 74 2d 72 65 63 6f 72 tests test-recor
1200: 64 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f ds). (if (null?
1210: 20 74 65 73 74 73 29 0a 20 20 20 20 20 20 74 65 tests). te
1220: 73 74 73 0a 20 20 20 20 20 20 28 62 65 67 69 6e sts. (begin
1230: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
1240: 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 1 *default-l
1250: 6f 67 2d 70 6f 72 74 2a 20 22 44 69 73 63 61 72 og-port* "Discar
1260: 64 69 6e 67 20 74 65 73 74 73 20 66 72 6f 6d 20 ding tests from
1270: 22 20 74 65 73 74 73 20 22 20 74 68 61 74 20 61 " tests " that a
1280: 72 65 20 77 61 69 74 69 6e 67 20 6f 6e 20 22 20 re waiting on "
1290: 66 61 69 6c 65 64 2d 74 65 73 74 29 0a 09 28 6c failed-test)..(l
12a0: 65 74 20 6c 6f 6f 70 20 28 28 74 65 73 74 6e 20 et loop ((testn
12b0: 28 63 61 72 20 74 65 73 74 73 29 29 0a 09 09 20 (car tests))...
12c0: 20 20 28 72 65 6d 74 20 20 28 63 64 72 20 74 65 (remt (cdr te
12d0: 73 74 73 29 29 0a 09 09 20 20 20 28 72 65 73 20 sts))... (res
12e0: 20 20 27 28 29 29 29 0a 09 20 20 28 6c 65 74 2a '())).. (let*
12f0: 20 28 28 74 65 73 74 2d 64 61 74 20 28 68 61 73 ((test-dat (has
1300: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
1310: 75 6c 74 20 74 65 73 74 2d 72 65 63 6f 72 64 73 ult test-records
1320: 20 74 65 73 74 6e 20 28 76 65 63 74 6f 72 20 23 testn (vector #
1330: 66 20 23 66 20 27 28 29 29 29 29 0a 09 09 20 28 f #f '())))... (
1340: 77 61 69 74 6f 6e 73 20 20 28 76 65 63 74 6f 72 waitons (vector
1350: 2d 72 65 66 20 74 65 73 74 2d 64 61 74 20 32 29 -ref test-dat 2)
1360: 29 29 0a 09 20 20 20 20 3b 3b 20 28 70 72 69 6e )).. ;; (prin
1370: 74 20 22 6d 74 3a 64 69 73 63 61 72 64 2d 62 6c t "mt:discard-bl
1380: 6f 63 6b 65 64 2d 74 65 73 74 73 20 72 75 6e 2d ocked-tests run-
1390: 69 64 3a 20 22 20 72 75 6e 2d 69 64 20 22 20 66 id: " run-id " f
13a0: 61 69 6c 65 64 2d 74 65 73 74 3a 20 22 20 66 61 ailed-test: " fa
13b0: 69 6c 65 64 2d 74 65 73 74 20 22 20 74 65 73 74 iled-test " test
13c0: 6e 3a 20 22 20 74 65 73 74 6e 20 22 20 77 69 74 n: " testn " wit
13d0: 68 20 77 61 69 74 6f 6e 73 3a 20 22 20 77 61 69 h waitons: " wai
13e0: 74 6f 6e 73 29 0a 09 20 20 20 20 28 69 66 20 28 tons).. (if (
13f0: 6e 75 6c 6c 3f 20 72 65 6d 74 29 0a 09 09 28 6c null? remt)...(l
1400: 65 74 20 28 28 6e 65 77 2d 72 65 73 20 28 72 65 et ((new-res (re
1410: 76 65 72 73 65 20 72 65 73 29 29 29 0a 09 09 20 verse res)))...
1420: 20 3b 3b 20 28 70 72 69 6e 74 20 22 20 20 20 20 ;; (print "
1430: 20 20 20 6e 65 77 2d 72 65 73 3a 20 22 20 6e 65 new-res: " ne
1440: 77 2d 72 65 73 29 0a 09 09 20 20 6e 65 77 2d 72 w-res)... new-r
1450: 65 73 29 0a 09 09 28 6c 6f 6f 70 20 28 63 61 72 es)...(loop (car
1460: 20 72 65 6d 74 29 0a 09 09 20 20 20 20 20 20 28 remt)... (
1470: 63 64 72 20 72 65 6d 74 29 0a 09 09 20 20 20 20 cdr remt)...
1480: 20 20 28 69 66 20 28 6d 65 6d 62 65 72 20 66 61 (if (member fa
1490: 69 6c 65 64 2d 74 65 73 74 20 77 61 69 74 6f 6e iled-test waiton
14a0: 73 29 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 s).... (begin..
14b0: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
14c0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
14d0: 67 2d 70 6f 72 74 2a 20 22 44 69 73 63 61 72 64 g-port* "Discard
14e0: 69 6e 67 20 74 65 73 74 20 22 20 74 65 73 74 6e ing test " testn
14f0: 20 22 28 22 20 74 65 73 74 2d 64 61 74 20 22 29 "(" test-dat ")
1500: 20 64 75 65 20 74 6f 20 22 20 66 61 69 6c 65 64 due to " failed
1510: 2d 74 65 73 74 29 0a 09 09 09 20 20 20 20 72 65 -test).... re
1520: 73 29 0a 09 09 09 20 20 28 63 6f 6e 73 20 74 65 s).... (cons te
1530: 73 74 6e 20 72 65 73 29 29 29 29 29 29 29 29 29 stn res)))))))))
1540: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
1550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 ==========.;; T
1590: 20 52 20 49 20 47 20 47 20 45 20 52 20 53 0a 3b R I G G E R S.;
15a0: 3b 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 3d 3d 3d 3d 3d 3d 3d ================
15d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
15f0: 20 28 6d 74 3a 72 75 6e 2d 74 72 69 67 67 65 72 (mt:run-trigger
1600: 20 63 6d 64 20 74 65 73 74 2d 69 64 20 74 65 73 cmd test-id tes
1610: 74 2d 72 75 6e 64 69 72 20 74 72 69 67 67 65 72 t-rundir trigger
1620: 20 6c 6f 67 6e 61 6d 65 20 74 65 73 74 2d 6e 61 logname test-na
1630: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 65 76 65 me item-path eve
1640: 6e 74 2d 74 69 6d 65 20 61 63 74 75 61 6c 2d 73 nt-time actual-s
1650: 74 61 74 65 20 61 63 74 75 61 6c 2d 73 74 61 74 tate actual-stat
1660: 75 73 29 0a 20 20 3b 3b 20 50 75 74 74 69 6e 67 us). ;; Putting
1670: 20 74 68 65 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 the commandline
1680: 20 69 6e 74 6f 20 28 20 29 27 73 20 6d 65 61 6e into ( )'s mean
1690: 73 20 6e 6f 20 63 6f 6e 74 72 6f 6c 20 6f 76 65 s no control ove
16a0: 72 20 74 68 65 20 73 68 65 6c 6c 2e 20 0a 20 20 r the shell. .
16b0: 3b 3b 20 73 74 64 6f 75 74 20 61 6e 64 20 73 74 ;; stdout and st
16c0: 64 65 72 72 20 77 69 6c 6c 20 62 65 20 63 61 75 derr will be cau
16d0: 67 68 74 20 69 6e 20 74 68 65 20 4e 42 46 41 4b ght in the NBFAK
16e0: 45 20 6f 72 20 6d 74 5f 6c 61 75 6e 63 68 2e 6c E or mt_launch.l
16f0: 6f 67 20 66 69 6c 65 73 0a 20 20 3b 3b 20 6f 72 og files. ;; or
1700: 20 65 71 75 69 76 61 6c 65 6e 74 2e 20 4e 6f 20 equivalent. No
1710: 6e 65 65 64 20 74 6f 20 64 6f 20 74 68 69 73 2e need to do this.
1720: 20 4a 75 73 74 20 72 75 6e 20 69 74 3f 0a 20 20 Just run it?.
1730: 28 6c 65 74 2a 20 28 28 66 75 6c 6c 63 6d 64 20 (let* ((fullcmd
1740: 28 63 6f 6e 63 20 22 6e 62 66 61 6b 65 20 22 0a (conc "nbfake ".
1750: 09 09 09 63 6d 64 20 20 20 20 20 20 20 20 20 20 ...cmd
1760: 20 22 20 22 0a 09 09 09 74 65 73 74 2d 69 64 20 " "....test-id
1770: 20 20 20 20 20 20 22 20 22 0a 09 09 09 74 65 73 " "....tes
1780: 74 2d 72 75 6e 64 69 72 20 20 20 22 20 22 0a 09 t-rundir " "..
1790: 09 09 74 72 69 67 67 65 72 20 20 20 20 20 20 20 ..trigger
17a0: 22 20 22 0a 09 09 09 74 65 73 74 2d 6e 61 6d 65 " "....test-name
17b0: 20 20 20 20 20 22 20 22 0a 09 09 09 69 74 65 6d " "....item
17c0: 2d 70 61 74 68 20 20 20 20 20 22 20 22 20 3b 3b -path " " ;;
17d0: 20 68 61 73 20 2f 20 70 72 65 70 65 6e 64 65 64 has / prepended
17e0: 20 74 6f 20 64 65 61 6c 20 77 69 74 68 20 74 6f to deal with to
17f0: 70 6c 65 76 65 6c 20 74 65 73 74 73 0a 09 09 09 plevel tests....
1800: 61 63 74 75 61 6c 2d 73 74 61 74 65 20 20 22 20 actual-state "
1810: 22 0a 09 09 09 61 63 74 75 61 6c 2d 73 74 61 74 "....actual-stat
1820: 75 73 20 22 20 22 0a 09 09 09 65 76 65 6e 74 2d us " "....event-
1830: 74 69 6d 65 0a 09 09 09 29 29 0a 09 20 28 70 72 time....)).. (pr
1840: 65 76 2d 6e 62 66 61 6b 65 2d 6c 6f 67 20 28 67 ev-nbfake-log (g
1850: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
1860: 61 72 69 61 62 6c 65 20 22 4e 42 46 41 4b 45 5f ariable "NBFAKE_
1870: 4c 4f 47 22 29 29 29 0a 20 20 20 20 28 73 65 74 LOG"))). (set
1880: 65 6e 76 20 22 4e 42 46 41 4b 45 5f 4c 4f 47 22 env "NBFAKE_LOG"
1890: 20 28 63 6f 6e 63 20 28 63 6f 6e 64 0a 09 09 09 (conc (cond....
18a0: 09 28 28 61 6e 64 20 28 64 69 72 65 63 74 6f 72 .((and (director
18b0: 79 2d 65 78 69 73 74 73 3f 20 74 65 73 74 2d 72 y-exists? test-r
18c0: 75 6e 64 69 72 29 0a 09 09 09 09 20 20 20 20 20 undir).....
18d0: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
18e0: 65 73 73 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 ess? test-rundir
18f0: 29 29 0a 09 09 09 09 20 74 65 73 74 2d 72 75 6e ))..... test-run
1900: 64 69 72 29 0a 09 09 09 09 28 28 61 6e 64 20 28 dir).....((and (
1910: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
1920: 3f 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 09 ? *toppath*)....
1930: 09 20 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 . (file-wri
1940: 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 70 te-access? *topp
1950: 61 74 68 2a 29 29 0a 09 09 09 09 20 2a 74 6f 70 ath*))..... *top
1960: 70 61 74 68 2a 29 0a 09 09 09 09 28 65 6c 73 65 path*).....(else
1970: 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 28 (conc "/tmp/" (
1980: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d current-user-nam
1990: 65 29 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 e))))....
19a0: 22 2f 22 20 6c 6f 67 6e 61 6d 65 29 29 0a 20 20 "/" logname)).
19b0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
19c0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
19d0: 6f 67 2d 70 6f 72 74 2a 20 22 54 52 49 47 47 45 og-port* "TRIGGE
19e0: 52 45 44 20 6f 6e 20 22 20 74 72 69 67 67 65 72 RED on " trigger
19f0: 20 22 2c 20 72 75 6e 6e 69 6e 67 20 63 6f 6d 6d ", running comm
1a00: 61 6e 64 20 22 20 66 75 6c 6c 63 6d 64 20 22 20 and " fullcmd "
1a10: 6f 75 74 70 75 74 20 61 74 20 22 20 28 67 65 74 output at " (get
1a20: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
1a30: 69 61 62 6c 65 20 22 4e 42 46 41 4b 45 5f 4c 4f iable "NBFAKE_LO
1a40: 47 22 29 29 0a 20 20 20 20 3b 3b 20 28 63 61 6c G")). ;; (cal
1a50: 6c 2d 77 69 74 68 2d 65 6e 76 69 72 6f 6e 6d 65 l-with-environme
1a60: 6e 74 2d 76 61 72 69 61 62 6c 65 73 0a 20 20 20 nt-variables.
1a70: 20 3b 3b 20 20 60 28 28 22 4e 42 46 41 4b 45 5f ;; `(("NBFAKE_
1a80: 4c 4f 47 22 20 2e 20 2c 28 63 6f 6e 63 20 74 65 LOG" . ,(conc te
1a90: 73 74 2d 72 75 6e 64 69 72 20 22 2f 22 20 6c 6f st-rundir "/" lo
1aa0: 67 6e 61 6d 65 29 29 29 0a 20 20 20 20 3b 3b 20 gname))). ;;
1ab0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
1ac0: 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 66 75 6c (process-run ful
1ad0: 6c 63 6d 64 29 0a 20 20 20 20 28 69 66 20 70 72 lcmd). (if pr
1ae0: 65 76 2d 6e 62 66 61 6b 65 2d 6c 6f 67 0a 09 28 ev-nbfake-log..(
1af0: 73 65 74 65 6e 76 20 22 4e 42 46 41 4b 45 5f 4c setenv "NBFAKE_L
1b00: 4f 47 22 20 70 72 65 76 2d 6e 62 66 61 6b 65 2d OG" prev-nbfake-
1b10: 6c 6f 67 29 0a 09 28 75 6e 73 65 74 65 6e 76 20 log)..(unsetenv
1b20: 22 4e 42 46 41 4b 45 5f 4c 4f 47 22 29 29 0a 20 "NBFAKE_LOG")).
1b30: 20 20 20 29 29 20 3b 3b 20 29 29 0a 0a 28 64 65 )) ;; ))..(de
1b40: 66 69 6e 65 20 28 6d 74 3a 70 72 6f 63 65 73 73 fine (mt:process
1b50: 2d 74 72 69 67 67 65 72 73 20 64 62 73 74 72 75 -triggers dbstru
1b60: 63 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 ct run-id test-i
1b70: 64 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 d newstate newst
1b80: 61 74 75 73 29 0a 20 20 28 69 66 20 74 65 73 74 atus). (if test
1b90: 2d 69 64 20 0a 20 20 20 20 20 20 28 6c 65 74 2a -id . (let*
1ba0: 20 28 28 74 65 73 74 2d 64 61 74 20 20 20 20 20 ((test-dat
1bb0: 20 28 64 62 3a 67 65 74 2d 74 65 73 74 2d 69 6e (db:get-test-in
1bc0: 66 6f 2d 62 79 2d 69 64 20 64 62 73 74 72 75 63 fo-by-id dbstruc
1bd0: 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 t run-id test-id
1be0: 29 29 29 0a 09 28 69 66 20 74 65 73 74 2d 64 61 )))..(if test-da
1bf0: 74 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 74 t.. (let* ((t
1c00: 65 73 74 2d 72 75 6e 64 69 72 20 20 20 28 64 62 est-rundir (db
1c10: 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 :test-get-rundir
1c20: 20 20 20 20 20 20 20 74 65 73 74 2d 64 61 74 29 test-dat)
1c30: 29 20 3b 3b 20 29 20 3b 3b 20 29 0a 09 09 20 20 ) ;; ) ;; )...
1c40: 20 28 74 65 73 74 2d 6e 61 6d 65 20 20 20 20 20 (test-name
1c50: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 74 65 73 (db:test-get-tes
1c60: 74 6e 61 6d 65 20 20 20 20 20 74 65 73 74 2d 64 tname test-d
1c70: 61 74 29 29 0a 09 09 20 20 20 28 69 74 65 6d 2d at))... (item-
1c80: 70 61 74 68 20 20 20 20 20 28 64 62 3a 74 65 73 path (db:tes
1c90: 74 2d 67 65 74 2d 69 74 65 6d 2d 70 61 74 68 20 t-get-item-path
1ca0: 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a 09 09 test-dat))...
1cb0: 20 20 20 28 64 75 72 61 74 69 6f 6e 20 20 20 20 (duration
1cc0: 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 (db:test-get-r
1cd0: 75 6e 5f 64 75 72 61 74 69 6f 6e 20 74 65 73 74 un_duration test
1ce0: 2d 64 61 74 29 29 0a 09 09 20 20 20 28 63 6f 6d -dat))... (com
1cf0: 6d 65 6e 74 20 20 20 20 20 20 20 28 64 62 3a 74 ment (db:t
1d00: 65 73 74 2d 67 65 74 2d 63 6f 6d 6d 65 6e 74 20 est-get-comment
1d10: 20 20 20 20 20 74 65 73 74 2d 64 61 74 29 29 0a test-dat)).
1d20: 09 09 20 20 20 28 65 76 65 6e 74 2d 74 69 6d 65 .. (event-time
1d30: 20 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 (db:test-get
1d40: 2d 65 76 65 6e 74 5f 74 69 6d 65 20 20 20 74 65 -event_time te
1d50: 73 74 2d 64 61 74 29 29 0a 09 09 20 20 20 28 74 st-dat))... (t
1d60: 63 6f 6e 66 69 67 20 20 20 20 20 20 20 23 66 29 config #f)
1d70: 0a 09 09 20 20 20 28 73 74 61 74 65 20 20 20 20 ... (state
1d80: 20 20 20 20 20 28 69 66 20 6e 65 77 73 74 61 74 (if newstat
1d90: 65 20 20 6e 65 77 73 74 61 74 65 20 20 28 64 62 e newstate (db
1da0: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
1db0: 20 74 65 73 74 2d 64 61 74 29 29 29 0a 09 09 20 test-dat)))...
1dc0: 20 20 28 73 74 61 74 75 73 20 20 20 20 20 20 20 (status
1dd0: 20 28 69 66 20 6e 65 77 73 74 61 74 75 73 20 6e (if newstatus n
1de0: 65 77 73 74 61 74 75 73 20 28 64 62 3a 74 65 73 ewstatus (db:tes
1df0: 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 73 t-get-status tes
1e00: 74 2d 64 61 74 29 29 29 29 0a 09 20 20 20 20 20 t-dat))))..
1e10: 20 3b 3b 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 ;; (mutex-lock!
1e20: 20 2a 74 72 69 67 67 65 72 73 2d 6d 75 74 65 78 *triggers-mutex
1e30: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
1e40: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
1e50: 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 ons.
1e60: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 exn.
1e70: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
1e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
1e90: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
1ea0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1eb0: 70 6f 72 74 2a 20 22 20 45 78 63 65 70 74 69 6f port* " Exceptio
1ec0: 6e 20 69 6e 20 6d 74 3a 70 72 6f 63 65 73 73 2d n in mt:process-
1ed0: 74 72 69 67 67 65 72 73 20 66 6f 72 20 72 75 6e triggers for run
1ee0: 2d 69 64 3d 22 72 75 6e 2d 69 64 22 20 74 65 73 -id="run-id" tes
1ef0: 74 2d 69 64 3d 22 74 65 73 74 2d 69 64 22 20 6e t-id="test-id" n
1f00: 65 77 73 74 61 74 65 3d 22 6e 65 77 73 74 61 74 ewstate="newstat
1f10: 65 22 20 6e 65 77 73 74 61 74 75 73 3d 22 6e 65 e" newstatus="ne
1f20: 77 73 74 61 74 75 73 0a 20 20 20 20 20 20 20 20 wstatus.
1f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f40: 20 20 20 20 20 20 20 20 20 20 20 20 22 5c 6e 20 "\n
1f50: 20 20 65 72 72 6f 72 3a 20 22 20 28 28 63 6f 6e error: " ((con
1f60: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
1f70: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
1f80: 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c 20 essage) exn) ",
1f90: 65 78 6e 3d 22 20 65 78 6e 0a 20 20 20 20 20 20 exn=" exn.
1fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 5c "\
1fc0: 6e 20 20 20 74 65 73 74 2d 72 75 6e 64 69 72 3d n test-rundir=
1fd0: 22 74 65 73 74 2d 72 75 6e 64 69 72 0a 20 20 20 "test-rundir.
1fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2000: 20 22 5c 6e 20 20 20 74 65 73 74 2d 6e 61 6d 65 "\n test-name
2010: 3d 22 74 65 73 74 2d 6e 61 6d 65 0a 20 20 20 20 ="test-name.
2020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2040: 22 5c 6e 20 20 20 69 74 65 6d 2d 70 61 74 68 3d "\n item-path=
2050: 22 69 74 65 6d 2d 70 61 74 68 0a 20 20 20 20 20 "item-path.
2060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
2080: 5c 6e 20 20 20 73 74 61 74 65 3d 22 73 74 61 74 \n state="stat
2090: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
20a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
20b0: 20 20 20 20 20 20 22 5c 6e 20 20 20 73 74 61 74 "\n stat
20c0: 75 73 3d 22 73 74 61 74 75 73 0a 20 20 20 20 20 us="status.
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 20 20 20 20 20 20 20 22 "
20f0: 5c 6e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 \n").
2100: 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c (print-cal
2110: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
2120: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 -error-port)).
2130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 #
2140: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
2150: 20 20 28 69 66 20 28 61 6e 64 20 74 65 73 74 2d (if (and test-
2160: 6e 61 6d 65 0a 20 20 20 20 20 20 20 20 20 20 20 name.
2170: 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 73 tes
2180: 74 2d 72 75 6e 64 69 72 29 20 20 20 3b 3b 20 23 t-rundir) ;; #
2190: 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 72 20 73 f means no dir s
21a0: 65 74 20 79 65 74 0a 20 20 20 20 20 20 20 20 20 et yet.
21b0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 63 6f ;; (co
21c0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
21d0: 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 29 0a 20 ? test-rundir).
21e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
21f0: 20 20 3b 3b 20 28 64 69 72 65 63 74 6f 72 79 3f ;; (directory?
2200: 20 74 65 73 74 2d 72 75 6e 64 69 72 29 29 0a 20 test-rundir)).
2210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2220: 20 20 28 63 61 6c 6c 2d 77 69 74 68 2d 65 6e 76 (call-with-env
2230: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
2240: 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 es.
2250: 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f (list (co
2260: 6e 73 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 ns "MT_TEST_NAME
2270: 22 20 20 20 20 28 6f 72 20 74 65 73 74 2d 6e 61 " (or test-na
2280: 6d 65 20 22 6e 6f 20 73 75 63 68 20 74 65 73 74 me "no such test
2290: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
22a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
22b0: 6f 6e 73 20 22 4d 54 5f 54 45 53 54 5f 52 55 4e ons "MT_TEST_RUN
22c0: 5f 44 49 52 22 20 28 6f 72 20 74 65 73 74 2d 72 _DIR" (or test-r
22d0: 75 6e 64 69 72 20 22 6e 6f 20 74 65 73 74 20 64 undir "no test d
22e0: 69 72 65 63 74 6f 72 79 20 79 65 74 22 29 29 0a irectory yet")).
22f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2300: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
2310: 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 20 20 20 "MT_ITEMPATH"
2320: 20 20 28 6f 72 20 69 74 65 6d 2d 70 61 74 68 20 (or item-path
2330: 22 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ""))).
2340: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
2350: 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 a ().
2360: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
2370: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
2380: 3f 20 74 65 73 74 2d 72 75 6e 64 69 72 29 0a 20 ? test-rundir).
2390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23a0: 20 20 20 20 20 20 20 20 20 28 70 75 73 68 2d 64 (push-d
23b0: 69 72 65 63 74 6f 72 79 20 74 65 73 74 2d 72 75 irectory test-ru
23c0: 6e 64 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 ndir).
23d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
23e0: 28 70 75 73 68 2d 64 69 72 65 63 74 6f 72 79 20 (push-directory
23f0: 2a 74 6f 70 70 61 74 68 2a 29 29 0a 20 20 20 20 *toppath*)).
2400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2410: 20 20 28 73 65 74 21 20 74 63 6f 6e 66 69 67 20 (set! tconfig
2420: 28 6d 74 3a 6c 61 7a 79 2d 72 65 61 64 2d 74 65 (mt:lazy-read-te
2430: 73 74 2d 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e st-config test-n
2440: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ame)).
2450: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 (for
2460: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 74 -each (lambda (t
2470: 72 69 67 67 65 72 29 0a 20 20 20 20 20 20 20 20 rigger).
2480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2490: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 (let*
24a0: 28 28 6d 75 6e 67 65 64 2d 74 72 69 67 67 65 72 ((munged-trigger
24b0: 20 28 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 (string-transla
24c0: 74 65 20 74 72 69 67 67 65 72 20 22 2f 20 22 20 te trigger "/ "
24d0: 22 2d 2d 22 29 29 0a 09 09 09 09 09 28 6c 6f 67 "--"))......(log
24e0: 6e 61 6d 65 20 20 20 20 20 20 20 20 28 63 6f 6e name (con
24f0: 63 20 22 6c 61 73 74 2d 74 72 69 67 67 65 72 2d c "last-trigger-
2500: 22 20 6d 75 6e 67 65 64 2d 74 72 69 67 67 65 72 " munged-trigger
2510: 20 22 2e 6c 6f 67 22 29 29 29 0a 20 20 20 20 20 ".log"))).
2520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
2540: 3b 20 66 69 72 73 74 20 61 6e 79 20 74 72 69 67 ; first any trig
2550: 67 65 72 73 20 66 72 6f 6d 20 74 68 65 20 74 65 gers from the te
2560: 73 74 63 6f 6e 66 69 67 0a 20 20 20 20 20 20 20 stconfig.
2570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2580: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
2590: 74 20 28 28 63 6d 64 20 20 28 63 6f 6e 66 69 67 t ((cmd (config
25a0: 66 3a 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 f:lookup tconfig
25b0: 20 22 74 72 69 67 67 65 72 73 22 20 74 72 69 67 "triggers" trig
25c0: 67 65 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 ger))).
25d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
25e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
25f0: 20 63 6d 64 20 28 6d 74 3a 72 75 6e 2d 74 72 69 cmd (mt:run-tri
2600: 67 67 65 72 20 63 6d 64 20 74 65 73 74 2d 69 64 gger cmd test-id
2610: 20 74 65 73 74 2d 72 75 6e 64 69 72 20 74 72 69 test-rundir tri
2620: 67 67 65 72 20 28 63 6f 6e 63 20 22 74 63 6f 6e gger (conc "tcon
2630: 66 69 67 2d 22 20 6c 6f 67 6e 61 6d 65 29 20 74 fig-" logname) t
2640: 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 est-name item-pa
2650: 74 68 20 65 76 65 6e 74 2d 74 69 6d 65 20 73 74 th event-time st
2660: 61 74 65 20 73 74 61 74 75 73 29 29 29 0a 20 20 ate status))).
2670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2690: 20 20 3b 3b 20 6e 65 78 74 20 61 6e 79 20 74 72 ;; next any tr
26a0: 69 67 67 65 72 73 20 66 72 6f 6d 20 6d 65 67 61 iggers from mega
26b0: 74 65 73 74 2e 63 6f 6e 66 69 67 0a 20 20 20 20 test.config.
26c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26e0: 28 6c 65 74 20 28 28 63 6d 64 20 20 28 63 6f 6e (let ((cmd (con
26f0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
2700: 66 69 67 64 61 74 2a 20 22 74 72 69 67 67 65 72 figdat* "trigger
2710: 73 22 20 74 72 69 67 67 65 72 29 29 29 0a 20 20 s" trigger))).
2720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2740: 20 20 20 20 28 69 66 20 63 6d 64 20 28 6d 74 3a (if cmd (mt:
2750: 72 75 6e 2d 74 72 69 67 67 65 72 20 63 6d 64 20 run-trigger cmd
2760: 74 65 73 74 2d 69 64 20 74 65 73 74 2d 72 75 6e test-id test-run
2770: 64 69 72 20 74 72 69 67 67 65 72 20 28 63 6f 6e dir trigger (con
2780: 63 20 22 6d 74 63 6f 6e 66 69 67 2d 22 20 6c 6f c "mtconfig-" lo
2790: 67 6e 61 6d 65 29 20 74 65 73 74 2d 6e 61 6d 65 gname) test-name
27a0: 20 69 74 65 6d 2d 70 61 74 68 20 65 76 65 6e 74 item-path event
27b0: 2d 74 69 6d 65 20 73 74 61 74 65 20 73 74 61 74 -time state stat
27c0: 75 73 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 us))))).
27d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27e0: 20 20 20 20 20 20 20 20 28 6c 69 73 74 0a 20 20 (list.
27f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2810: 63 6f 6e 63 20 73 74 61 74 65 20 22 2f 22 20 73 conc state "/" s
2820: 74 61 74 75 73 29 0a 20 20 20 20 20 20 20 20 20 tatus).
2830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2840: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 73 74 (conc st
2850: 61 74 65 20 22 2f 22 29 0a 20 20 20 20 20 20 20 ate "/").
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: 22 2f 22 20 73 74 61 74 75 73 29 29 29 0a 09 09 "/" status)))...
2890: 20 20 20 20 20 28 70 6f 70 2d 64 69 72 65 63 74 (pop-direct
28a0: 6f 72 79 29 29 0a 20 20 20 20 20 20 20 20 20 20 ory)).
28b0: 20 20 20 20 20 20 20 20 20 20 29 29 29 0a 09 20 )))..
28c0: 20 20 20 20 20 3b 3b 20 28 6d 75 74 65 78 2d 75 ;; (mutex-u
28d0: 6e 6c 6f 63 6b 21 20 2a 74 72 69 67 67 65 72 73 nlock! *triggers
28e0: 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 20 20 -mutex*)..
28f0: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
2900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
2940: 3b 3b 20 20 53 20 54 20 41 20 54 20 45 20 20 20 ;; S T A T E
2950: 41 20 4e 20 44 20 20 20 53 20 54 20 41 20 54 20 A N D S T A T
2960: 55 20 53 20 20 20 46 20 4f 20 52 20 20 20 54 20 U S F O R T
2970: 45 20 53 20 54 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d E S T S .;;=====
2980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
29c0: 3d 0a 0a 3b 3b 20 73 70 65 65 64 20 75 70 20 66 =..;; speed up f
29d0: 6f 72 20 63 6f 6d 6d 6f 6e 20 63 61 73 65 73 20 or common cases
29e0: 77 69 74 68 20 61 20 6c 69 74 74 6c 65 20 6c 6f with a little lo
29f0: 67 69 63 0a 28 64 65 66 69 6e 65 20 28 6d 74 3a gic.(define (mt:
2a00: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d 73 test-set-state-s
2a10: 74 61 74 75 73 2d 62 79 2d 69 64 20 72 75 6e 2d tatus-by-id run-
2a20: 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 73 74 id test-id newst
2a30: 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 6e 65 ate newstatus ne
2a40: 77 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 69 66 20 wcomment). (if
2a50: 28 6e 6f 74 20 28 61 6e 64 20 72 75 6e 2d 69 64 (not (and run-id
2a60: 20 74 65 73 74 2d 69 64 29 29 0a 20 20 20 20 20 test-id)).
2a70: 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a (begin..(debug:
2a80: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
2a90: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2aa0: 20 22 62 61 64 20 64 61 74 61 20 68 61 6e 64 65 "bad data hande
2ab0: 64 20 74 6f 20 6d 74 3a 74 65 73 74 2d 73 65 74 d to mt:test-set
2ac0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 -state-status-by
2ad0: 2d 69 64 2c 20 72 75 6e 2d 69 64 3d 22 20 72 75 -id, run-id=" ru
2ae0: 6e 2d 69 64 20 22 2c 20 74 65 73 74 2d 69 64 3d n-id ", test-id=
2af0: 22 20 74 65 73 74 2d 69 64 20 22 2c 20 6e 65 77 " test-id ", new
2b00: 73 74 61 74 65 3d 22 20 6e 65 77 73 74 61 74 65 state=" newstate
2b10: 29 0a 09 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 )..(print-call-c
2b20: 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 hain (current-er
2b30: 72 6f 72 2d 70 6f 72 74 29 29 0a 09 23 66 29 0a ror-port))..#f).
2b40: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 3b 3b (begin..;;
2b50: 20 63 6f 6e 64 0a 09 3b 3b 20 28 28 61 6e 64 20 cond..;; ((and
2b60: 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 newstate newstat
2b70: 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 09 us newcomment)..
2b80: 3b 3b 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c ;; (rmt:general
2b90: 2d 63 61 6c 6c 20 27 73 74 61 74 65 2d 73 74 61 -call 'state-sta
2ba0: 74 75 73 2d 6d 73 67 20 72 75 6e 2d 69 64 20 6e tus-msg run-id n
2bb0: 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 ewstate newstatu
2bc0: 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 20 74 65 73 s newcomment tes
2bd0: 74 2d 69 64 29 29 0a 09 3b 3b 20 28 28 61 6e 64 t-id))..;; ((and
2be0: 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 newstate newsta
2bf0: 74 75 73 29 0a 09 3b 3b 20 20 28 72 6d 74 3a 67 tus)..;; (rmt:g
2c00: 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 74 61 eneral-call 'sta
2c10: 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 te-status run-id
2c20: 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 newstate newsta
2c30: 74 75 73 20 74 65 73 74 2d 69 64 29 29 0a 09 3b tus test-id))..;
2c40: 3b 20 28 65 6c 73 65 0a 09 3b 3b 20 20 28 69 66 ; (else..;; (if
2c50: 20 6e 65 77 73 74 61 74 65 20 20 20 28 72 6d 74 newstate (rmt
2c60: 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 :general-call 's
2c70: 65 74 2d 74 65 73 74 2d 73 74 61 74 65 20 20 20 et-test-state
2c80: 72 75 6e 2d 69 64 20 6e 65 77 73 74 61 74 65 20 run-id newstate
2c90: 20 20 74 65 73 74 2d 69 64 29 29 0a 09 3b 3b 20 test-id))..;;
2ca0: 20 28 69 66 20 6e 65 77 73 74 61 74 75 73 20 20 (if newstatus
2cb0: 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c (rmt:general-cal
2cc0: 6c 20 27 73 65 74 2d 74 65 73 74 2d 73 74 61 74 l 'set-test-stat
2cd0: 75 73 20 20 72 75 6e 2d 69 64 20 6e 65 77 73 74 us run-id newst
2ce0: 61 74 75 73 20 20 74 65 73 74 2d 69 64 29 29 0a atus test-id)).
2cf0: 09 3b 3b 20 20 28 69 66 20 6e 65 77 63 6f 6d 6d .;; (if newcomm
2d00: 65 6e 74 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c ent (rmt:general
2d10: 2d 63 61 6c 6c 20 27 73 65 74 2d 74 65 73 74 2d -call 'set-test-
2d20: 63 6f 6d 6d 65 6e 74 20 72 75 6e 2d 69 64 20 6e comment run-id n
2d30: 65 77 63 6f 6d 6d 65 6e 74 20 74 65 73 74 2d 69 ewcomment test-i
2d40: 64 29 29 29 29 0a 09 28 72 6d 74 3a 73 65 74 2d d))))..(rmt:set-
2d50: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
2d60: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
2d70: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 23 66 un-id test-id #f
2d80: 20 6e 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 newstate newsta
2d90: 74 75 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a tus newcomment).
2da0: 09 3b 3b 20 28 6d 74 3a 70 72 6f 63 65 73 73 2d .;; (mt:process-
2db0: 74 72 69 67 67 65 72 73 20 72 75 6e 2d 69 64 20 triggers run-id
2dc0: 74 65 73 74 2d 69 64 20 6e 65 77 73 74 61 74 65 test-id newstate
2dd0: 20 6e 65 77 73 74 61 74 75 73 29 0a 09 23 74 29 newstatus)..#t)
2de0: 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 6d 74 ))...(define (mt
2df0: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
2e00: 73 74 61 74 75 73 2d 62 79 2d 69 64 2d 75 6e 6c status-by-id-unl
2e10: 65 73 73 2d 63 6f 6d 70 6c 65 74 65 64 20 72 75 ess-completed ru
2e20: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 77 n-id test-id new
2e30: 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 73 20 state newstatus
2e40: 6e 65 77 63 6f 6d 6d 65 6e 74 29 0a 20 20 28 6c newcomment). (l
2e50: 65 74 2a 20 28 28 74 65 73 74 2d 76 65 63 20 20 et* ((test-vec
2e60: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 69 6e (rmt:get-testin
2e70: 66 6f 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 fo-state-status
2e80: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 run-id test-id))
2e90: 0a 20 20 20 20 20 20 20 20 20 28 73 74 61 74 65 . (state
2ea0: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 (vector-ref
2eb0: 20 74 65 73 74 2d 76 65 63 20 33 29 29 29 0a 20 test-vec 3))).
2ec0: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 73 (if (equal? s
2ed0: 74 61 74 65 20 22 43 4f 4d 50 4c 45 54 45 44 22 tate "COMPLETED"
2ee0: 29 0a 20 20 20 20 20 20 20 20 23 74 0a 20 20 20 ). #t.
2ef0: 20 20 20 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 (rmt:set-st
2f00: 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 ate-status-and-r
2f10: 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e oll-up-items run
2f20: 2d 69 64 20 74 65 73 74 2d 69 64 20 23 66 20 6e -id test-id #f n
2f30: 65 77 73 74 61 74 65 20 6e 65 77 73 74 61 74 75 ewstate newstatu
2f40: 73 20 6e 65 77 63 6f 6d 6d 65 6e 74 29 29 29 29 s newcomment))))
2f50: 0a 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 6d 74 .. .(define (mt
2f60: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 2d :test-set-state-
2f70: 73 74 61 74 75 73 2d 62 79 2d 74 65 73 74 6e 61 status-by-testna
2f80: 6d 65 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e me run-id test-n
2f90: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 6e 65 ame item-path ne
2fa0: 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 74 61 74 w-state new-stat
2fb0: 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e 74 29 0a us new-comment).
2fc0: 20 20 3b 28 6c 65 74 20 28 28 74 65 73 74 2d 69 ;(let ((test-i
2fd0: 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d d (rmt:get-test-
2fe0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e id run-id test-n
2ff0: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path)))
3000: 0a 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 . (rmt:set-stat
3010: 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c e-status-and-rol
3020: 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 l-up-items run-i
3030: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
3040: 2d 70 61 74 68 20 6e 65 77 2d 73 74 61 74 65 20 -path new-state
3050: 6e 65 77 2d 73 74 61 74 75 73 20 6e 65 77 2d 63 new-status new-c
3060: 6f 6d 6d 65 6e 74 29 0a 20 20 3b 3b 20 28 6d 74 omment). ;; (mt
3070: 3a 70 72 6f 63 65 73 73 2d 74 72 69 67 67 65 72 :process-trigger
3080: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
3090: 20 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 new-state new-s
30a0: 74 61 74 75 73 29 0a 20 20 23 74 29 3b 29 0a 09 tatus). #t);)..
30b0: 3b 3b 28 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 ;;(mt:test-set-s
30c0: 74 61 74 65 2d 73 74 61 74 75 73 2d 62 79 2d 69 tate-status-by-i
30d0: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
30e0: 20 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 new-state new-s
30f0: 74 61 74 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e tatus new-commen
3100: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6d t)))..(define (m
3110: 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 65 t:test-set-state
3120: 2d 73 74 61 74 75 73 2d 62 79 2d 74 65 73 74 6e -status-by-testn
3130: 61 6d 65 2d 75 6e 6c 65 73 73 2d 63 6f 6d 70 6c ame-unless-compl
3140: 65 74 65 64 20 72 75 6e 2d 69 64 20 74 65 73 74 eted run-id test
3150: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 -name item-path
3160: 6e 65 77 2d 73 74 61 74 65 20 6e 65 77 2d 73 74 new-state new-st
3170: 61 74 75 73 20 6e 65 77 2d 63 6f 6d 6d 65 6e 74 atus new-comment
3180: 29 0a 20 20 28 6c 65 74 20 28 28 74 65 73 74 2d ). (let ((test-
3190: 69 64 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 id (rmt:get-test
31a0: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
31b0: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 name item-path))
31c0: 29 0a 20 20 20 20 28 6d 74 3a 74 65 73 74 2d 73 ). (mt:test-s
31d0: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d et-state-status-
31e0: 62 79 2d 69 64 2d 75 6e 6c 65 73 73 2d 63 6f 6d by-id-unless-com
31f0: 70 6c 65 74 65 64 20 72 75 6e 2d 69 64 20 74 65 pleted run-id te
3200: 73 74 2d 69 64 20 6e 65 77 2d 73 74 61 74 65 20 st-id new-state
3210: 6e 65 77 2d 73 74 61 74 75 73 20 6e 65 77 2d 63 new-status new-c
3220: 6f 6d 6d 65 6e 74 29 29 29 0a 20 20 20 20 0a 28 omment))). .(
3230: 64 65 66 69 6e 65 20 28 6d 74 3a 6c 61 7a 79 2d define (mt:lazy-
3240: 72 65 61 64 2d 74 65 73 74 2d 63 6f 6e 66 69 67 read-test-config
3250: 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 6c test-name). (l
3260: 65 74 20 28 28 74 63 6f 6e 66 20 28 68 61 73 68 et ((tconf (hash
3270: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3280: 6c 74 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a lt *testconfigs*
3290: 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 29 test-name #f)))
32a0: 0a 20 20 20 20 28 69 66 20 74 63 6f 6e 66 0a 09 . (if tconf..
32b0: 74 63 6f 6e 66 0a 09 28 6c 65 74 20 28 28 74 65 tconf..(let ((te
32c0: 73 74 2d 64 69 72 73 20 28 74 65 73 74 73 3a 67 st-dirs (tests:g
32d0: 65 74 2d 74 65 73 74 73 2d 73 65 61 72 63 68 2d et-tests-search-
32e0: 70 61 74 68 20 2a 63 6f 6e 66 69 67 64 61 74 2a path *configdat*
32f0: 29 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 ))).. (let loop
3300: 20 28 28 68 65 64 20 28 63 61 72 20 74 65 73 74 ((hed (car test
3310: 2d 64 69 72 73 29 29 0a 09 09 20 20 20 20 20 28 -dirs))... (
3320: 74 61 6c 20 28 63 64 72 20 74 65 73 74 2d 64 69 tal (cdr test-di
3330: 72 73 29 29 29 0a 09 20 20 20 20 3b 3b 20 53 65 rs))).. ;; Se
3340: 74 74 69 6e 67 20 4d 54 5f 4c 49 4e 4b 54 52 45 tting MT_LINKTRE
3350: 45 20 68 65 72 65 20 69 73 20 61 6c 6d 6f 73 74 E here is almost
3360: 20 63 65 72 74 61 69 6e 6c 79 20 75 6e 6e 65 63 certainly unnec
3370: 65 73 73 61 72 79 2e 20 0a 09 20 20 20 20 28 6c essary. .. (l
3380: 65 74 20 28 28 74 63 6f 6e 66 69 67 2d 66 69 6c et ((tconfig-fil
3390: 65 20 28 63 6f 6e 63 20 68 65 64 20 22 2f 22 20 e (conc hed "/"
33a0: 74 65 73 74 2d 6e 61 6d 65 20 22 2f 74 65 73 74 test-name "/test
33b0: 63 6f 6e 66 69 67 22 29 29 29 0a 09 20 20 20 20 config")))..
33c0: 20 20 28 69 66 20 28 61 6e 64 20 28 63 6f 6d 6d (if (and (comm
33d0: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
33e0: 74 63 6f 6e 66 69 67 2d 66 69 6c 65 29 0a 09 09 tconfig-file)...
33f0: 20 20 20 20 20 20 20 28 66 69 6c 65 2d 72 65 61 (file-rea
3400: 64 2d 61 63 63 65 73 73 3f 20 74 63 6f 6e 66 69 d-access? tconfi
3410: 67 2d 66 69 6c 65 29 29 0a 09 09 20 20 28 6c 65 g-file))... (le
3420: 74 20 28 28 6c 69 6e 6b 2d 74 72 65 65 2d 70 61 t ((link-tree-pa
3430: 74 68 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c th (common:get-l
3440: 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 28 63 6f inktree)) ;; (co
3450: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
3460: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
3470: 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 0a 09 09 "linktree"))...
3480: 09 28 6f 6c 64 2d 6c 69 6e 6b 2d 74 72 65 65 20 .(old-link-tree
3490: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
34a0: 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 4c t-variable "MT_L
34b0: 49 4e 4b 54 52 45 45 22 29 29 29 0a 09 09 20 20 INKTREE")))...
34c0: 20 20 28 69 66 20 6c 69 6e 6b 2d 74 72 65 65 2d (if link-tree-
34d0: 70 61 74 68 20 28 73 65 74 65 6e 76 20 22 4d 54 path (setenv "MT
34e0: 5f 4c 49 4e 4b 54 52 45 45 22 20 6c 69 6e 6b 2d _LINKTREE" link-
34f0: 74 72 65 65 2d 70 61 74 68 29 29 0a 09 09 20 20 tree-path))...
3500: 20 20 28 6c 65 74 20 28 28 6e 65 77 74 63 66 67 (let ((newtcfg
3510: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 74 63 (read-config tc
3520: 6f 6e 66 69 67 2d 66 69 6c 65 20 23 66 20 23 66 onfig-file #f #f
3530: 29 29 29 20 3b 3b 20 4e 4f 54 45 3a 20 44 6f 65 ))) ;; NOTE: Doe
3540: 73 20 4e 4f 54 20 72 75 6e 20 5b 73 79 73 74 65 s NOT run [syste
3550: 6d 20 2e 2e 2e 5d 0a 09 09 20 20 20 20 20 20 28 m ...]... (
3560: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
3570: 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 *testconfigs* te
3580: 73 74 2d 6e 61 6d 65 20 6e 65 77 74 63 66 67 29 st-name newtcfg)
3590: 0a 09 09 20 20 20 20 20 20 28 69 66 20 6f 6c 64 ... (if old
35a0: 2d 6c 69 6e 6b 2d 74 72 65 65 20 0a 09 09 09 20 -link-tree ....
35b0: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e (setenv "MT_LIN
35c0: 4b 54 52 45 45 22 20 6f 6c 64 2d 6c 69 6e 6b 2d KTREE" old-link-
35d0: 74 72 65 65 29 0a 09 09 09 20 20 28 75 6e 73 65 tree).... (unse
35e0: 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 tenv "MT_LINKTRE
35f0: 45 22 29 29 0a 09 09 20 20 20 20 20 20 6e 65 77 E"))... new
3600: 74 63 66 67 29 29 0a 09 09 20 20 28 69 66 20 28 tcfg))... (if (
3610: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 20 null? tal)...
3620: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 65 (begin....(de
3630: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
3640: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
3650: 6f 72 74 2a 20 22 4e 6f 20 72 65 61 64 61 62 6c ort* "No readabl
3660: 65 20 74 65 73 74 63 6f 6e 66 69 67 20 66 6f 75 e testconfig fou
3670: 6e 64 20 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 nd for " test-na
3680: 6d 65 29 0a 09 09 09 23 66 29 0a 09 09 20 20 20 me)....#f)...
3690: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
36a0: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
36b0: 29 29 29 29 0a 0a ))))..