0000: 0a 3b 3b 20 43 6f 70 79 72 69 67 68 74 20 32 30 .;; Copyright 20
0010: 30 36 2d 32 30 31 33 2c 20 4d 61 74 74 68 65 77 06-2013, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 3d 3d 3d PURPOSE...;;===
0150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0190: 3d 3d 3d 0a 3b 3b 20 6c 61 75 6e 63 68 20 61 20 ===.;; launch a
01a0: 74 61 73 6b 20 2d 20 74 68 69 73 20 72 75 6e 73 task - this runs
01b0: 20 6f 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 74 on the originat
01c0: 69 6e 67 20 68 6f 73 74 2c 20 74 65 73 74 73 20 ing host, tests
01d0: 74 68 65 6d 73 65 6c 76 65 73 0a 3b 3b 0a 3b 3b themselves.;;.;;
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 72 65 67 ======..(use reg
0230: 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 62 61 ex regex-case ba
0240: 73 65 36 34 20 73 71 6c 69 74 65 33 20 73 72 66 se64 sqlite3 srf
0250: 69 2d 31 38 20 64 69 72 65 63 74 6f 72 79 2d 75 i-18 directory-u
0260: 74 69 6c 73 20 70 6f 73 69 78 2d 65 78 74 72 61 tils posix-extra
0270: 73 20 7a 33 20 63 61 6c 6c 2d 77 69 74 68 2d 65 s z3 call-with-e
0280: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
0290: 62 6c 65 73 20 63 73 76 29 0a 28 75 73 65 20 74 bles csv).(use t
02a0: 79 70 65 64 2d 72 65 63 6f 72 64 73 20 70 61 74 yped-records pat
02b0: 68 6e 61 6d 65 2d 65 78 70 61 6e 64 20 6d 61 74 hname-expand mat
02c0: 63 68 61 62 6c 65 29 0a 0a 28 69 6d 70 6f 72 74 chable)..(import
02d0: 20 28 70 72 65 66 69 78 20 62 61 73 65 36 34 20 (prefix base64
02e0: 62 61 73 65 36 34 3a 29 29 0a 28 69 6d 70 6f 72 base64:)).(impor
02f0: 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 t (prefix sqlite
0300: 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 3 sqlite3:))..(d
0310: 65 63 6c 61 72 65 20 28 75 6e 69 74 20 6c 61 75 eclare (unit lau
0320: 6e 63 68 29 29 0a 28 64 65 63 6c 61 72 65 20 28 nch)).(declare (
0330: 75 73 65 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 uses common)).(d
0340: 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6e eclare (uses con
0350: 66 69 67 66 29 29 0a 28 64 65 63 6c 61 72 65 20 figf)).(declare
0360: 28 75 73 65 73 20 64 62 29 29 0a 3b 3b 20 28 64 (uses db)).;; (d
0370: 65 63 6c 61 72 65 20 28 75 73 65 73 20 73 64 62 eclare (uses sdb
0380: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
0390: 73 20 74 64 62 29 29 0a 3b 3b 20 28 64 65 63 6c s tdb)).;; (decl
03a0: 61 72 65 20 28 75 73 65 73 20 66 69 6c 65 64 62 are (uses filedb
03b0: 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f ))..(include "co
03c0: 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d mmon_records.scm
03d0: 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6b 65 79 ").(include "key
03e0: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 _records.scm").(
03f0: 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 63 6f include "db_reco
0400: 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 3d 3d 3d rds.scm")..;;===
0410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0450: 3d 3d 3d 0a 3b 3b 20 65 7a 73 74 65 70 73 0a 3b ===.;; ezsteps.;
0460: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
0470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
04a0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 65 7a 73 74 =======..;; ezst
04b0: 65 70 73 20 77 65 72 65 20 67 6f 69 6e 67 20 74 eps were going t
04c0: 6f 20 62 65 20 63 6f 64 65 64 20 61 73 0a 3b 3b o be coded as.;;
04d0: 20 73 74 65 70 6e 61 6d 65 5b 2c 70 72 65 64 73 stepname[,preds
04e0: 74 65 70 31 2c 70 72 65 64 73 74 65 70 32 20 2e tep1,predstep2 .
04f0: 2e 2e 5d 20 5b 7b 56 41 52 31 3d 66 69 72 73 74 ..] [{VAR1=first
0500: 2c 73 65 63 6f 6e 64 2c 74 68 69 72 64 7d 5d 20 ,second,third}]
0510: 63 6f 6d 6d 61 6e 64 20 74 6f 20 65 78 65 63 75 command to execu
0520: 74 65 0a 3b 3b 20 20 20 42 55 54 0a 3b 3b 20 6e te.;; BUT.;; n
0530: 6f 77 20 61 72 65 0a 3b 3b 20 73 74 65 70 6e 61 ow are.;; stepna
0540: 6d 65 20 7b 56 41 52 3d 66 69 72 73 74 2c 73 65 me {VAR=first,se
0550: 63 6f 6e 64 2c 74 68 69 72 64 20 2e 2e 2e 7d 20 cond,third ...}
0560: 63 6f 6d 6d 61 6e 64 20 2e 2e 2e 0a 3b 3b 20 77 command ....;; w
0570: 68 65 72 65 20 74 68 65 20 7b 56 41 52 3d 66 69 here the {VAR=fi
0580: 72 73 74 2c 73 65 63 6f 6e 64 2c 74 68 69 72 64 rst,second,third
0590: 20 2e 2e 2e 7d 20 69 73 20 6f 70 74 69 6f 6e 61 ...} is optiona
05a0: 6c 2e 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 6e 20 l...;; given an
05b0: 65 78 69 74 20 63 6f 64 65 20 61 6e 64 20 77 68 exit code and wh
05c0: 65 74 68 65 72 20 6f 72 20 6e 6f 74 20 6c 6f 67 ether or not log
05d0: 70 72 6f 20 77 61 73 20 75 73 65 64 20 63 61 6c pro was used cal
05e0: 63 75 6c 61 74 65 20 4f 4b 2f 42 41 44 0a 3b 3b culate OK/BAD.;;
05f0: 20 72 65 74 75 72 6e 20 23 74 20 69 66 20 77 65 return #t if we
0600: 20 61 72 65 20 6f 6b 2c 20 23 66 20 6f 74 68 65 are ok, #f othe
0610: 72 77 69 73 65 0a 28 64 65 66 69 6e 65 20 28 73 rwise.(define (s
0620: 74 65 70 72 75 6e 2d 67 6f 6f 64 3f 20 6c 6f 67 teprun-good? log
0630: 70 72 6f 20 65 78 69 74 63 6f 64 65 29 0a 20 20 pro exitcode).
0640: 28 6f 72 20 28 65 71 3f 20 65 78 69 74 63 6f 64 (or (eq? exitcod
0650: 65 20 30 29 0a 20 20 20 20 20 20 28 61 6e 64 20 e 0). (and
0660: 6c 6f 67 70 72 6f 20 28 65 71 3f 20 65 78 69 74 logpro (eq? exit
0670: 63 6f 64 65 20 32 29 29 29 29 0a 0a 3b 3b 20 69 code 2))))..;; i
0680: 66 20 68 61 6e 64 65 64 20 61 20 73 74 72 69 6e f handed a strin
0690: 67 2c 20 70 72 6f 63 65 73 73 20 69 74 2c 20 65 g, process it, e
06a0: 6c 73 65 20 6c 6f 6f 6b 20 66 6f 72 20 4d 54 5f lse look for MT_
06b0: 43 4d 44 49 4e 46 4f 0a 28 64 65 66 69 6e 65 20 CMDINFO.(define
06c0: 28 6c 61 75 6e 63 68 3a 67 65 74 2d 63 6d 64 69 (launch:get-cmdi
06d0: 6e 66 6f 2d 61 73 73 6f 63 2d 6c 69 73 74 20 23 nfo-assoc-list #
06e0: 21 6b 65 79 20 28 65 6e 63 6f 64 65 64 2d 63 6d !key (encoded-cm
06f0: 64 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 28 d #f)). (let ((
0700: 65 6e 63 63 6d 64 20 28 69 66 20 65 6e 63 6f 64 enccmd (if encod
0710: 65 64 2d 63 6d 64 20 65 6e 63 6f 64 65 64 2d 63 ed-cmd encoded-c
0720: 6d 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 43 md (getenv "MT_C
0730: 4d 44 49 4e 46 4f 22 29 29 29 29 0a 20 20 20 20 MDINFO")))).
0740: 28 69 66 20 65 6e 63 63 6d 64 0a 09 28 63 6f 6d (if enccmd..(com
0750: 6d 6f 6e 3a 72 65 61 64 2d 65 6e 63 6f 64 65 64 mon:read-encoded
0760: 2d 73 74 72 69 6e 67 20 65 6e 63 63 6d 64 29 0a -string enccmd).
0770: 09 27 28 29 29 29 29 0a 0a 3b 3b 20 20 20 20 20 .'())))..;;
0780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0790: 20 20 30 20 20 20 20 20 20 20 20 20 20 20 31 20 0 1
07a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 32 20 20 2
07b0: 20 20 20 20 20 20 20 20 20 20 20 20 33 0a 28 64 3.(d
07c0: 65 66 73 74 72 75 63 74 20 6c 61 75 6e 63 68 3a efstruct launch:
07d0: 65 69 6e 66 20 28 70 69 64 20 23 74 29 28 65 78 einf (pid #t)(ex
07e0: 69 74 2d 73 74 61 74 75 73 20 23 74 29 28 65 78 it-status #t)(ex
07f0: 69 74 2d 63 6f 64 65 20 23 74 29 28 72 6f 6c 6c it-code #t)(roll
0800: 75 70 2d 73 74 61 74 75 73 20 30 29 29 0a 0a 3b up-status 0))..;
0810: 3b 20 72 65 74 75 72 6e 20 28 63 6f 6e 63 20 73 ; return (conc s
0820: 74 61 74 75 73 20 22 3a 20 22 20 63 6f 6d 6d 65 tatus ": " comme
0830: 6e 74 29 20 66 72 6f 6d 20 74 68 65 20 66 69 6e nt) from the fin
0840: 61 6c 20 73 65 63 74 69 6f 6e 20 73 6f 20 74 68 al section so th
0850: 61 74 0a 3b 3b 20 20 20 74 68 65 20 63 6f 6d 6d at.;; the comm
0860: 65 6e 74 20 63 61 6e 20 62 65 20 73 65 74 20 69 ent can be set i
0870: 6e 20 74 68 65 20 73 74 65 70 20 72 65 63 6f 72 n the step recor
0880: 64 20 69 6e 20 6c 61 75 6e 63 68 2e 73 63 6d 0a d in launch.scm.
0890: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 6e ;;.(define (laun
08a0: 63 68 3a 6c 6f 61 64 2d 6c 6f 67 70 72 6f 2d 64 ch:load-logpro-d
08b0: 61 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 at run-id test-i
08c0: 64 20 73 74 65 70 6e 61 6d 65 29 0a 20 20 28 6c d stepname). (l
08d0: 65 74 20 28 28 63 6e 61 6d 65 20 28 63 6f 6e 63 et ((cname (conc
08e0: 20 73 74 65 70 6e 61 6d 65 20 22 2e 64 61 74 22 stepname ".dat"
08f0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c ))). (if (fil
0900: 65 2d 65 78 69 73 74 73 3f 20 63 6e 61 6d 65 29 e-exists? cname)
0910: 0a 09 28 6c 65 74 2a 20 28 28 64 61 74 20 20 28 ..(let* ((dat (
0920: 72 65 61 64 2d 63 6f 6e 66 69 67 20 63 6e 61 6d read-config cnam
0930: 65 20 23 66 20 23 66 29 29 0a 09 20 20 20 20 20 e #f #f))..
0940: 20 20 28 63 73 76 72 20 28 64 62 3a 6c 6f 67 70 (csvr (db:logp
0950: 72 6f 2d 64 61 74 2d 3e 63 73 76 20 64 61 74 20 ro-dat->csv dat
0960: 73 74 65 70 6e 61 6d 65 29 29 0a 09 20 20 20 20 stepname))..
0970: 20 20 20 28 63 73 76 74 20 28 6c 65 74 2d 76 61 (csvt (let-va
0980: 6c 75 65 73 20 28 28 28 66 6d 74 2d 63 65 6c 6c lues (((fmt-cell
0990: 20 66 6d 74 2d 72 65 63 6f 72 64 20 66 6d 74 2d fmt-record fmt-
09a0: 63 73 76 29 20 28 6d 61 6b 65 2d 66 6f 72 6d 61 csv) (make-forma
09b0: 74 20 22 2c 22 29 29 29 0a 09 09 20 20 20 20 20 t ",")))...
09c0: 20 20 28 66 6d 74 2d 63 73 76 20 28 6d 61 70 20 (fmt-csv (map
09d0: 6c 69 73 74 2d 3e 63 73 76 2d 72 65 63 6f 72 64 list->csv-record
09e0: 20 63 73 76 72 29 29 29 29 0a 09 20 20 20 20 20 csvr))))..
09f0: 20 20 28 73 74 61 74 75 73 20 28 63 6f 6e 66 69 (status (confi
0a00: 67 66 3a 6c 6f 6f 6b 75 70 20 64 61 74 20 22 66 gf:lookup dat "f
0a10: 69 6e 61 6c 22 20 22 65 78 69 74 2d 73 74 61 74 inal" "exit-stat
0a20: 75 73 22 29 29 0a 09 20 20 20 20 20 20 20 28 6d us")).. (m
0a30: 73 67 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a sg (configf:
0a40: 6c 6f 6f 6b 75 70 20 64 61 74 20 22 66 69 6e 61 lookup dat "fina
0a50: 6c 22 20 22 6d 65 73 73 61 67 65 22 29 29 29 0a l" "message"))).
0a60: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 63 73 (if cs
0a70: 76 74 20 20 3b 3b 20 74 68 69 73 20 69 66 20 62 vt ;; this if b
0a80: 6c 6f 63 6b 65 64 20 73 74 61 63 6b 20 64 75 6d locked stack dum
0a90: 70 20 63 61 75 73 65 64 20 62 79 20 2e 64 61 74 p caused by .dat
0aa0: 20 66 69 6c 65 20 66 72 6f 6d 20 6c 6f 67 70 72 file from logpr
0ab0: 6f 20 62 65 69 6e 67 20 30 2d 62 79 74 65 2e 20 o being 0-byte.
0ac0: 20 66 69 78 65 64 20 62 79 20 75 70 67 72 61 64 fixed by upgrad
0ad0: 69 6e 67 20 6c 6f 67 70 72 6f 0a 20 20 20 20 20 ing logpro.
0ae0: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 63 73 (rmt:cs
0af0: 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 75 6e v->test-data run
0b00: 2d 69 64 20 74 65 73 74 2d 69 64 20 63 73 76 74 -id test-id csvt
0b10: 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ).. (debug:
0b20: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
0b30: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
0b40: 52 3a 20 6e 6f 20 63 73 76 64 61 74 20 65 78 69 R: no csvdat exi
0b50: 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 64 3a 20 sts for run-id:
0b60: 22 20 72 75 6e 2d 69 64 20 22 20 74 65 73 74 2d " run-id " test-
0b70: 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 id: " test-id "
0b80: 73 74 65 70 6e 61 6d 65 3a 20 22 20 73 74 65 70 stepname: " step
0b90: 6e 61 6d 65 20 22 2c 20 63 68 65 63 6b 20 74 68 name ", check th
0ba0: 61 74 20 6c 6f 67 70 72 6f 20 76 65 72 73 69 6f at logpro versio
0bb0: 6e 20 69 73 20 31 2e 31 35 20 6f 72 20 6e 65 77 n is 1.15 or new
0bc0: 65 72 22 29 29 0a 09 20 20 3b 3b 20 20 28 64 65 er")).. ;; (de
0bd0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
0be0: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
0bf0: 6f 72 74 2a 20 22 45 72 72 6f 72 3a 20 72 75 6e ort* "Error: run
0c00: 2d 69 64 2f 74 65 73 74 2d 69 64 2f 73 74 65 70 -id/test-id/step
0c10: 6e 61 6d 65 3d 22 72 75 6e 2d 69 64 22 2f 22 74 name="run-id"/"t
0c20: 65 73 74 2d 69 64 22 2f 22 73 74 65 70 6e 61 6d est-id"/"stepnam
0c30: 65 22 20 3d 3e 20 62 61 64 20 63 73 76 72 3d 22 e" => bad csvr="
0c40: 63 73 76 72 29 0a 09 20 20 3b 3b 20 20 29 0a 09 csvr).. ;; )..
0c50: 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 65 71 (cond.. ((eq
0c60: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 ual? status "PAS
0c70: 53 22 29 20 22 50 41 53 53 22 29 20 3b 3b 20 73 S") "PASS") ;; s
0c80: 6b 69 70 20 74 68 65 20 6d 65 73 73 61 67 65 20 kip the message
0c90: 70 61 72 74 20 69 66 20 73 74 61 74 75 73 20 69 part if status i
0ca0: 73 20 70 61 73 73 0a 09 20 20 20 28 73 74 61 74 s pass.. (stat
0cb0: 75 73 20 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 us (conc (config
0cc0: 66 3a 6c 6f 6f 6b 75 70 20 64 61 74 20 22 66 69 f:lookup dat "fi
0cd0: 6e 61 6c 22 20 22 65 78 69 74 2d 73 74 61 74 75 nal" "exit-statu
0ce0: 73 22 29 20 22 3a 20 22 20 28 69 66 20 6d 73 67 s") ": " (if msg
0cf0: 20 6d 73 67 20 22 6e 6f 20 6d 65 73 73 61 67 65 msg "no message
0d00: 22 29 29 29 0a 09 20 20 20 28 65 6c 73 65 20 23 "))).. (else #
0d10: 66 29 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 f)))..#f)))..(de
0d20: 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 72 75 6e fine (launch:run
0d30: 73 74 65 70 20 65 7a 73 74 65 70 20 72 75 6e 2d step ezstep run-
0d40: 69 64 20 74 65 73 74 2d 69 64 20 65 78 69 74 2d id test-id exit-
0d50: 69 6e 66 6f 20 6d 20 74 61 6c 20 74 65 73 74 63 info m tal testc
0d60: 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 28 onfig). (let* (
0d70: 28 73 74 65 70 6e 61 6d 65 20 20 20 20 20 20 20 (stepname
0d80: 28 63 61 72 20 65 7a 73 74 65 70 29 29 20 20 3b (car ezstep)) ;
0d90: 3b 20 64 6f 20 73 74 75 66 66 20 74 6f 20 72 75 ; do stuff to ru
0da0: 6e 20 74 68 65 20 73 74 65 70 0a 09 20 28 73 74 n the step.. (st
0db0: 65 70 69 6e 66 6f 20 20 20 20 20 20 20 28 63 61 epinfo (ca
0dc0: 64 72 20 65 7a 73 74 65 70 29 29 0a 09 20 28 73 dr ezstep)).. (s
0dd0: 74 65 70 70 61 72 74 73 20 20 20 20 20 20 28 73 tepparts (s
0de0: 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 tring-match (reg
0df0: 65 78 70 20 22 5e 28 5c 5c 7b 28 5b 5e 5c 5c 7d exp "^(\\{([^\\}
0e00: 5d 2a 29 5c 5c 7d 5c 5c 73 2a 7c 29 28 2e 2a 29 ]*)\\}\\s*|)(.*)
0e10: 24 22 29 20 73 74 65 70 69 6e 66 6f 29 29 0a 09 $") stepinfo))..
0e20: 20 28 73 74 65 70 70 61 72 6d 73 20 20 20 20 20 (stepparms
0e30: 20 28 6c 69 73 74 2d 72 65 66 20 73 74 65 70 70 (list-ref stepp
0e40: 61 72 74 73 20 32 29 29 20 3b 3b 20 66 6f 72 20 arts 2)) ;; for
0e50: 66 75 74 75 72 65 20 75 73 65 2c 20 7b 56 41 52 future use, {VAR
0e60: 3d 31 2c 32 2c 33 7d 2c 20 72 75 6e 20 73 74 65 =1,2,3}, run ste
0e70: 70 20 66 6f 72 20 65 61 63 68 20 0a 09 20 28 73 p for each .. (s
0e80: 74 65 70 63 6d 64 20 20 20 20 20 20 20 20 28 6c tepcmd (l
0e90: 69 73 74 2d 72 65 66 20 73 74 65 70 70 61 72 74 ist-ref steppart
0ea0: 73 20 33 29 29 0a 09 20 28 73 63 72 69 70 74 20 s 3)).. (script
0eb0: 20 20 20 20 20 20 20 20 22 22 29 20 3b 20 22 23 "") ; "#
0ec0: 21 2f 62 69 6e 2f 62 61 73 68 5c 6e 22 29 20 3b !/bin/bash\n") ;
0ed0: 3b 20 79 65 70 2c 20 77 65 20 64 65 70 65 6e 64 ; yep, we depend
0ee0: 20 6f 6e 20 62 69 6e 2f 62 61 73 68 20 46 49 58 on bin/bash FIX
0ef0: 4d 45 21 21 21 5c 0a 09 20 28 6c 6f 67 70 72 6f ME!!!\.. (logpro
0f00: 2d 66 69 6c 65 20 20 20 20 28 63 6f 6e 63 20 73 -file (conc s
0f10: 74 65 70 6e 61 6d 65 20 22 2e 6c 6f 67 70 72 6f tepname ".logpro
0f20: 22 29 29 0a 09 20 28 68 74 6d 6c 2d 66 69 6c 65 ")).. (html-file
0f30: 20 20 20 20 20 20 28 63 6f 6e 63 20 73 74 65 70 (conc step
0f40: 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 09 name ".html"))..
0f50: 20 28 64 61 74 2d 66 69 6c 65 20 20 20 20 20 20 (dat-file
0f60: 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 6d 65 20 (conc stepname
0f70: 22 2e 64 61 74 22 29 29 0a 09 20 28 74 63 6f 6e ".dat")).. (tcon
0f80: 66 69 67 2d 6c 6f 67 70 72 6f 20 28 63 6f 6e 66 fig-logpro (conf
0f90: 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 igf:lookup testc
0fa0: 6f 6e 66 69 67 20 22 6c 6f 67 70 72 6f 22 20 73 onfig "logpro" s
0fb0: 74 65 70 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 tepname)).. (log
0fc0: 70 72 6f 2d 75 73 65 64 20 20 20 20 28 66 69 6c pro-used (fil
0fd0: 65 2d 65 78 69 73 74 73 3f 20 6c 6f 67 70 72 6f e-exists? logpro
0fe0: 2d 66 69 6c 65 29 29 29 0a 0a 20 20 20 20 28 69 -file))).. (i
0ff0: 66 20 28 61 6e 64 20 74 63 6f 6e 66 69 67 2d 6c f (and tconfig-l
1000: 6f 67 70 72 6f 0a 09 20 20 20 20 20 28 6e 6f 74 ogpro.. (not
1010: 20 6c 6f 67 70 72 6f 2d 75 73 65 64 29 29 20 3b logpro-used)) ;
1020: 3b 20 6e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c 65 ; no logpro file
1030: 20 66 6f 75 6e 64 20 62 75 74 20 68 61 76 65 20 found but have
1040: 61 20 64 65 66 6e 20 69 6e 20 74 68 65 20 74 65 a defn in the te
1050: 73 74 63 6f 6e 66 69 67 0a 09 28 62 65 67 69 6e stconfig..(begin
1060: 0a 09 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 .. (with-output
1070: 2d 74 6f 2d 66 69 6c 65 20 6c 6f 67 70 72 6f 2d -to-file logpro-
1080: 66 69 6c 65 0a 09 20 20 20 20 28 6c 61 6d 62 64 file.. (lambd
1090: 61 20 28 29 0a 09 20 20 20 20 20 20 28 70 72 69 a ().. (pri
10a0: 6e 74 20 22 3b 3b 20 6c 6f 67 70 72 6f 20 66 69 nt ";; logpro fi
10b0: 6c 65 20 65 78 74 72 61 63 74 65 64 20 66 72 6f le extracted fro
10c0: 6d 20 74 65 73 74 63 6f 6e 66 69 67 5c 6e 22 0a m testconfig\n".
10d0: 09 09 20 20 20 20 20 22 3b 3b 22 29 0a 09 20 20 .. ";;")..
10e0: 20 20 20 20 28 70 72 69 6e 74 20 74 63 6f 6e 66 (print tconf
10f0: 69 67 2d 6c 6f 67 70 72 6f 29 29 29 0a 09 20 20 ig-logpro)))..
1100: 28 73 65 74 21 20 6c 6f 67 70 72 6f 2d 75 73 65 (set! logpro-use
1110: 64 20 23 74 29 29 29 0a 20 20 20 20 0a 20 20 20 d #t))). .
1120: 20 3b 3b 20 4e 42 2f 2f 20 63 61 6e 20 73 61 66 ;; NB// can saf
1130: 65 6c 79 20 61 73 73 75 6d 65 20 77 65 20 61 72 ely assume we ar
1140: 65 20 69 6e 20 74 65 73 74 2d 61 72 65 61 20 64 e in test-area d
1150: 69 72 65 63 74 6f 72 79 0a 20 20 20 20 28 64 65 irectory. (de
1160: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
1170: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
1180: 65 7a 73 74 65 70 73 3a 5c 6e 20 73 74 65 70 6e ezsteps:\n stepn
1190: 61 6d 65 3a 20 22 20 73 74 65 70 6e 61 6d 65 20 ame: " stepname
11a0: 22 20 73 74 65 70 69 6e 66 6f 3a 20 22 20 73 74 " stepinfo: " st
11b0: 65 70 69 6e 66 6f 20 22 20 73 74 65 70 70 61 72 epinfo " steppar
11c0: 74 73 3a 20 22 20 73 74 65 70 70 61 72 74 73 0a ts: " stepparts.
11d0: 09 09 20 22 20 73 74 65 70 70 61 72 6d 73 3a 20 .. " stepparms:
11e0: 22 20 73 74 65 70 70 61 72 6d 73 20 22 20 73 74 " stepparms " st
11f0: 65 70 63 6d 64 3a 20 22 20 73 74 65 70 63 6d 64 epcmd: " stepcmd
1200: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 3b 3b ). . ;; ;;
1210: 20 66 69 72 73 74 20 73 6f 75 72 63 65 20 74 68 first source th
1220: 65 20 70 72 65 76 69 6f 75 73 20 65 6e 76 69 72 e previous envir
1230: 6f 6e 6d 65 6e 74 0a 20 20 20 20 3b 3b 20 28 6c onment. ;; (l
1240: 65 74 20 28 28 70 72 65 76 2d 65 6e 76 20 28 63 et ((prev-env (c
1250: 6f 6e 63 20 22 2e 65 7a 73 74 65 70 73 2f 22 20 onc ".ezsteps/"
1260: 70 72 65 76 73 74 65 70 20 28 69 66 20 28 73 74 prevstep (if (st
1270: 72 69 6e 67 2d 73 65 61 72 63 68 20 28 72 65 67 ring-search (reg
1280: 65 78 70 20 22 63 73 68 22 29 20 0a 20 20 20 20 exp "csh") .
1290: 3b 3b 20 20 20 20 20 20 09 09 09 09 09 09 09 20 ;; .......
12a0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
12b0: 2d 76 61 72 69 61 62 6c 65 20 22 53 48 45 4c 4c -variable "SHELL
12c0: 22 29 29 20 22 2e 63 73 68 22 20 22 2e 73 68 22 ")) ".csh" ".sh"
12d0: 29 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 )))). ;; (i
12e0: 66 20 28 61 6e 64 20 70 72 65 76 73 74 65 70 20 f (and prevstep
12f0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 72 (file-exists? pr
1300: 65 76 2d 65 6e 76 29 29 0a 20 20 20 20 3b 3b 20 ev-env)). ;;
1310: 20 20 20 20 20 20 28 73 65 74 21 20 73 63 72 69 (set! scri
1320: 70 74 20 28 63 6f 6e 63 20 73 63 72 69 70 74 20 pt (conc script
1330: 22 73 6f 75 72 63 65 20 22 20 70 72 65 76 2d 65 "source " prev-e
1340: 6e 76 29 29 29 29 0a 20 20 20 20 0a 20 20 20 20 nv)))). .
1350: 3b 3b 20 63 61 6c 6c 20 74 68 65 20 63 6f 6d 6d ;; call the comm
1360: 61 6e 64 20 75 73 69 6e 67 20 6d 74 5f 65 7a 73 and using mt_ezs
1370: 74 65 70 0a 20 20 20 20 3b 3b 20 28 73 65 74 21 tep. ;; (set!
1380: 20 73 63 72 69 70 74 20 28 63 6f 6e 63 20 22 6d script (conc "m
1390: 74 5f 65 7a 73 74 65 70 20 22 20 73 74 65 70 6e t_ezstep " stepn
13a0: 61 6d 65 20 22 20 22 20 28 69 66 20 70 72 65 76 ame " " (if prev
13b0: 73 74 65 70 20 70 72 65 76 73 74 65 70 20 22 78 step prevstep "x
13c0: 22 29 20 22 20 22 20 73 74 65 70 63 6d 64 29 29 ") " " stepcmd))
13d0: 0a 20 20 20 20 0a 20 20 20 20 28 64 65 62 75 67 . . (debug
13e0: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
13f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 63 72 t-log-port* "scr
1400: 69 70 74 3a 20 22 20 73 63 72 69 70 74 29 0a 20 ipt: " script).
1410: 20 20 20 28 72 6d 74 3a 74 65 73 74 73 74 65 70 (rmt:teststep
1420: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e -set-status! run
1430: 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 65 70 -id test-id step
1440: 6e 61 6d 65 20 22 73 74 61 72 74 22 20 22 2d 22 name "start" "-"
1450: 20 23 66 20 23 66 29 0a 20 20 20 20 3b 3b 20 6e #f #f). ;; n
1460: 6f 77 20 6c 61 75 6e 63 68 20 74 68 65 20 61 63 ow launch the ac
1470: 74 75 61 6c 20 70 72 6f 63 65 73 73 0a 20 20 20 tual process.
1480: 20 28 63 61 6c 6c 2d 77 69 74 68 2d 65 6e 76 69 (call-with-envi
1490: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
14a0: 73 20 0a 20 20 20 20 20 28 6c 69 73 74 20 28 63 s . (list (c
14b0: 6f 6e 73 20 22 50 41 54 48 22 20 28 63 6f 6e 63 ons "PATH" (conc
14c0: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
14d0: 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 54 48 t-variable "PATH
14e0: 22 29 20 22 3a 2e 22 29 29 29 0a 20 20 20 20 20 ") ":."))).
14f0: 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b 20 28 70 (lambda () ;; (p
1500: 72 6f 63 65 73 73 2d 72 75 6e 20 22 2f 62 69 6e rocess-run "/bin
1510: 2f 62 61 73 68 22 20 22 2d 63 22 20 22 65 78 65 /bash" "-c" "exe
1520: 63 20 6c 73 20 2d 6c 20 2f 74 6d 70 2f 66 6f 6f c ls -l /tmp/foo
1530: 62 61 72 20 3e 20 2f 74 6d 70 2f 64 65 6c 6d 65 bar > /tmp/delme
1540: 2d 6d 6f 72 65 2e 6c 6f 67 20 32 3e 26 31 22 29 -more.log 2>&1")
1550: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
1560: 63 6d 64 20 28 63 6f 6e 63 20 73 74 65 70 63 6d cmd (conc stepcm
1570: 64 20 22 20 3e 20 22 20 73 74 65 70 6e 61 6d 65 d " > " stepname
1580: 20 22 2e 6c 6f 67 20 32 3e 26 31 22 29 29 20 3b ".log 2>&1")) ;
1590: 3b 20 3e 6f 75 74 66 69 6c 65 20 32 3e 26 31 20 ; >outfile 2>&1
15a0: 0a 09 20 20 20 20 20 20 28 70 69 64 20 28 70 72 .. (pid (pr
15b0: 6f 63 65 73 73 2d 72 75 6e 20 22 2f 62 69 6e 2f ocess-run "/bin/
15c0: 62 61 73 68 22 20 28 6c 69 73 74 20 22 2d 63 22 bash" (list "-c"
15d0: 20 63 6d 64 29 29 29 29 0a 0a 20 20 20 20 20 20 cmd))))..
15e0: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
15f0: 74 6f 2d 66 69 6c 65 20 22 4d 61 6b 65 66 69 6c to-file "Makefil
1600: 65 2e 65 7a 73 74 65 70 73 22 0a 20 20 20 20 20 e.ezsteps".
1610: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
1620: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 . (p
1630: 72 69 6e 74 20 73 74 65 70 6e 61 6d 65 20 22 2e rint stepname ".
1640: 6c 6f 67 20 3a 22 29 0a 20 20 20 20 20 20 20 20 log :").
1650: 20 20 20 20 20 28 70 72 69 6e 74 20 22 5c 74 22 (print "\t"
1660: 20 63 6d 64 29 0a 20 20 20 20 20 20 20 20 20 20 cmd).
1670: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
1680: 73 74 73 3f 20 28 63 6f 6e 63 20 73 74 65 70 6e sts? (conc stepn
1690: 61 6d 65 20 22 2e 6c 6f 67 70 72 6f 22 29 29 0a ame ".logpro")).
16a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
16b0: 20 28 70 72 69 6e 74 20 22 5c 74 6c 6f 67 70 72 (print "\tlogpr
16c0: 6f 20 22 20 73 74 65 70 6e 61 6d 65 20 22 2e 6c o " stepname ".l
16d0: 6f 67 70 72 6f 20 22 20 73 74 65 70 6e 61 6d 65 ogpro " stepname
16e0: 20 22 2e 68 74 6d 6c 20 3c 20 22 20 73 74 65 70 ".html < " step
16f0: 6e 61 6d 65 20 22 2e 6c 6f 67 22 29 29 0a 20 20 name ".log")).
1700: 20 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e (prin
1710: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
1720: 28 70 72 69 6e 74 20 73 74 65 70 6e 61 6d 65 20 (print stepname
1730: 22 20 3a 20 22 20 73 74 65 70 6e 61 6d 65 20 22 " : " stepname "
1740: 2e 6c 6f 67 22 29 0a 20 20 20 20 20 20 20 20 20 .log").
1750: 20 20 20 20 28 70 72 69 6e 74 29 29 0a 20 20 20 (print)).
1760: 20 20 20 20 20 20 20 20 23 3a 61 70 70 65 6e 64 #:append
1770: 29 0a 0a 09 20 28 72 6d 74 3a 74 65 73 74 2d 73 )... (rmt:test-s
1780: 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 et-top-process-p
1790: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
17a0: 64 20 70 69 64 29 0a 09 20 28 6c 65 74 20 70 72 d pid).. (let pr
17b0: 6f 63 65 73 73 6c 6f 6f 70 20 28 28 69 20 30 29 ocessloop ((i 0)
17c0: 29 0a 09 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 ).. (let-value
17d0: 73 20 28 28 28 70 69 64 2d 76 61 6c 20 65 78 69 s (((pid-val exi
17e0: 74 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f t-status exit-co
17f0: 64 65 29 28 70 72 6f 63 65 73 73 2d 77 61 69 74 de)(process-wait
1800: 20 70 69 64 20 23 74 29 29 29 0a 09 09 20 20 20 pid #t)))...
1810: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
1820: 20 6d 29 0a 09 09 20 20 20 20 20 20 20 28 6c 61 m)... (la
1830: 75 6e 63 68 3a 65 69 6e 66 2d 70 69 64 2d 73 65 unch:einf-pid-se
1840: 74 21 20 20 20 20 20 20 20 20 20 65 78 69 74 2d t! exit-
1850: 69 6e 66 6f 20 70 69 64 29 20 20 20 20 20 20 20 info pid)
1860: 20 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 ;; (vector-set
1870: 21 20 65 78 69 74 2d 69 6e 66 6f 20 30 20 70 69 ! exit-info 0 pi
1880: 64 29 0a 09 09 20 20 20 20 20 20 20 28 6c 61 75 d)... (lau
1890: 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 73 74 nch:einf-exit-st
18a0: 61 74 75 73 2d 73 65 74 21 20 65 78 69 74 2d 69 atus-set! exit-i
18b0: 6e 66 6f 20 65 78 69 74 2d 73 74 61 74 75 73 29 nfo exit-status)
18c0: 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 ;; (vector-set!
18d0: 20 65 78 69 74 2d 69 6e 66 6f 20 31 20 65 78 69 exit-info 1 exi
18e0: 74 2d 73 74 61 74 75 73 29 0a 09 09 20 20 20 20 t-status)...
18f0: 20 20 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d (launch:einf-
1900: 65 78 69 74 2d 63 6f 64 65 2d 73 65 74 21 20 20 exit-code-set!
1910: 20 65 78 69 74 2d 69 6e 66 6f 20 65 78 69 74 2d exit-info exit-
1920: 63 6f 64 65 29 20 20 20 3b 3b 20 28 76 65 63 74 code) ;; (vect
1930: 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 or-set! exit-inf
1940: 6f 20 32 20 65 78 69 74 2d 63 6f 64 65 29 0a 09 o 2 exit-code)..
1950: 09 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 . (mutex-u
1960: 6e 6c 6f 63 6b 21 20 6d 29 0a 09 09 20 20 20 20 nlock! m)...
1970: 20 20 20 28 69 66 20 28 65 71 3f 20 70 69 64 2d (if (eq? pid-
1980: 76 61 6c 20 30 29 0a 09 09 09 20 20 20 28 62 65 val 0).... (be
1990: 67 69 6e 0a 09 09 09 20 20 20 20 20 28 74 68 72 gin.... (thr
19a0: 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 09 ead-sleep! 2)...
19b0: 09 20 20 20 20 20 28 70 72 6f 63 65 73 73 6c 6f . (processlo
19c0: 6f 70 20 28 2b 20 69 20 31 29 29 29 29 0a 09 09 op (+ i 1))))...
19d0: 20 20 20 20 20 20 20 29 29 29 29 29 0a 20 20 20 ))))).
19e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
19f0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
1a00: 67 2d 70 6f 72 74 2a 20 22 73 74 65 70 20 22 20 g-port* "step "
1a10: 73 74 65 70 6e 61 6d 65 20 22 20 63 6f 6d 70 6c stepname " compl
1a20: 65 74 65 64 20 77 69 74 68 20 65 78 69 74 20 63 eted with exit c
1a30: 6f 64 65 20 22 20 28 6c 61 75 6e 63 68 3a 65 69 ode " (launch:ei
1a40: 6e 66 2d 65 78 69 74 2d 63 6f 64 65 20 65 78 69 nf-exit-code exi
1a50: 74 2d 69 6e 66 6f 29 29 20 3b 3b 20 28 76 65 63 t-info)) ;; (vec
1a60: 74 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 tor-ref exit-inf
1a70: 6f 20 32 29 29 0a 20 20 20 20 3b 3b 20 6e 6f 77 o 2)). ;; now
1a80: 20 72 75 6e 20 6c 6f 67 70 72 6f 20 69 66 20 6e run logpro if n
1a90: 65 65 64 65 64 0a 20 20 20 20 28 69 66 20 6c 6f eeded. (if lo
1aa0: 67 70 72 6f 2d 75 73 65 64 0a 09 28 6c 65 74 20 gpro-used..(let
1ab0: 28 28 70 69 64 20 28 70 72 6f 63 65 73 73 2d 72 ((pid (process-r
1ac0: 75 6e 20 28 63 6f 6e 63 20 22 6c 6f 67 70 72 6f un (conc "logpro
1ad0: 20 22 20 6c 6f 67 70 72 6f 2d 66 69 6c 65 20 22 " logpro-file "
1ae0: 20 22 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 6d " (conc stepnam
1af0: 65 20 22 2e 68 74 6d 6c 22 29 20 22 20 3c 20 22 e ".html") " < "
1b00: 20 73 74 65 70 6e 61 6d 65 20 22 2e 6c 6f 67 22 stepname ".log"
1b10: 29 29 29 29 0a 09 20 20 28 6c 65 74 20 70 72 6f )))).. (let pro
1b20: 63 65 73 73 6c 6f 6f 70 20 28 28 69 20 30 29 29 cessloop ((i 0))
1b30: 0a 09 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 .. (let-value
1b40: 73 20 28 28 28 70 69 64 2d 76 61 6c 20 65 78 69 s (((pid-val exi
1b50: 74 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f t-status exit-co
1b60: 64 65 29 28 70 72 6f 63 65 73 73 2d 77 61 69 74 de)(process-wait
1b70: 20 70 69 64 20 23 74 29 29 29 0a 09 09 09 28 6d pid #t)))....(m
1b80: 75 74 65 78 2d 6c 6f 63 6b 21 20 6d 29 0a 09 09 utex-lock! m)...
1b90: 09 3b 3b 20 28 6d 61 6b 65 2d 6c 61 75 6e 63 68 .;; (make-launch
1ba0: 3a 65 69 6e 66 20 70 69 64 3a 20 70 69 64 20 65 :einf pid: pid e
1bb0: 78 69 74 2d 73 74 61 74 75 73 3a 20 65 78 69 74 xit-status: exit
1bc0: 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f 64 -status exit-cod
1bd0: 65 3a 20 65 78 69 74 2d 63 6f 64 65 29 0a 09 09 e: exit-code)...
1be0: 09 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 70 69 .(launch:einf-pi
1bf0: 64 2d 73 65 74 21 20 20 20 20 20 20 20 20 20 65 d-set! e
1c00: 78 69 74 2d 69 6e 66 6f 20 70 69 64 29 20 20 20 xit-info pid)
1c10: 20 20 20 20 20 20 3b 3b 20 28 76 65 63 74 6f 72 ;; (vector
1c20: 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 -set! exit-info
1c30: 30 20 70 69 64 29 0a 09 09 09 28 6c 61 75 6e 63 0 pid)....(launc
1c40: 68 3a 65 69 6e 66 2d 65 78 69 74 2d 73 74 61 74 h:einf-exit-stat
1c50: 75 73 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 us-set! exit-inf
1c60: 6f 20 65 78 69 74 2d 73 74 61 74 75 73 29 20 3b o exit-status) ;
1c70: 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 ; (vector-set! e
1c80: 78 69 74 2d 69 6e 66 6f 20 31 20 65 78 69 74 2d xit-info 1 exit-
1c90: 73 74 61 74 75 73 29 0a 09 09 09 28 6c 61 75 6e status)....(laun
1ca0: 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 ch:einf-exit-cod
1cb0: 65 2d 73 65 74 21 20 20 20 65 78 69 74 2d 69 6e e-set! exit-in
1cc0: 66 6f 20 65 78 69 74 2d 63 6f 64 65 29 20 20 20 fo exit-code)
1cd0: 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 ;; (vector-set!
1ce0: 65 78 69 74 2d 69 6e 66 6f 20 32 20 65 78 69 74 exit-info 2 exit
1cf0: 2d 63 6f 64 65 29 0a 09 09 09 28 6d 75 74 65 78 -code)....(mutex
1d00: 2d 75 6e 6c 6f 63 6b 21 20 6d 29 0a 09 09 09 28 -unlock! m)....(
1d10: 69 66 20 28 65 71 3f 20 70 69 64 2d 76 61 6c 20 if (eq? pid-val
1d20: 30 29 0a 09 09 09 20 20 20 20 28 62 65 67 69 6e 0).... (begin
1d30: 0a 09 09 09 20 20 20 20 20 20 28 74 68 72 65 61 .... (threa
1d40: 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 09 09 20 d-sleep! 2)....
1d50: 20 20 20 20 20 28 70 72 6f 63 65 73 73 6c 6f 6f (processloo
1d60: 70 20 28 2b 20 69 20 31 29 29 29 29 29 0a 09 20 p (+ i 1)))))..
1d70: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
1d80: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
1d90: 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c 6f 67 70 72 log-port* "logpr
1da0: 6f 20 66 6f 72 20 73 74 65 70 20 22 20 73 74 65 o for step " ste
1db0: 70 6e 61 6d 65 20 22 20 65 78 69 74 65 64 20 77 pname " exited w
1dc0: 69 74 68 20 63 6f 64 65 20 22 20 28 6c 61 75 6e ith code " (laun
1dd0: 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 ch:einf-exit-cod
1de0: 65 20 65 78 69 74 2d 69 6e 66 6f 29 29 29 29 29 e exit-info)))))
1df0: 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ;; (vector-ref
1e00: 65 78 69 74 2d 69 6e 66 6f 20 32 29 29 29 29 29 exit-info 2)))))
1e10: 0a 20 20 20 20 0a 20 20 20 20 28 6c 65 74 20 28 . . (let (
1e20: 28 65 78 69 6e 66 6f 20 28 6c 61 75 6e 63 68 3a (exinfo (launch:
1e30: 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 65 20 65 einf-exit-code e
1e40: 78 69 74 2d 69 6e 66 6f 29 29 20 3b 3b 20 28 76 xit-info)) ;; (v
1e50: 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 ector-ref exit-i
1e60: 6e 66 6f 20 32 29 29 0a 09 20 20 28 6c 6f 67 66 nfo 2)).. (logf
1e70: 6e 61 20 28 69 66 20 6c 6f 67 70 72 6f 2d 75 73 na (if logpro-us
1e80: 65 64 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 6d ed (conc stepnam
1e90: 65 20 22 2e 68 74 6d 6c 22 29 20 22 22 29 29 0a e ".html") "")).
1ea0: 09 20 20 28 63 6f 6d 6d 65 6e 74 20 23 66 29 29 . (comment #f))
1eb0: 0a 20 20 20 20 20 20 28 69 66 20 6c 6f 67 70 72 . (if logpr
1ec0: 6f 2d 75 73 65 64 0a 09 20 20 28 6c 65 74 20 28 o-used.. (let (
1ed0: 28 64 61 74 66 69 6c 65 20 28 63 6f 6e 63 20 73 (datfile (conc s
1ee0: 74 65 70 6e 61 6d 65 20 22 2e 64 61 74 22 29 29 tepname ".dat"))
1ef0: 29 0a 09 20 20 20 20 3b 3b 20 6c 6f 61 64 20 74 ).. ;; load t
1f00: 68 65 20 2e 64 61 74 20 66 69 6c 65 20 69 6e 74 he .dat file int
1f10: 6f 20 74 68 65 20 74 65 73 74 5f 64 61 74 61 20 o the test_data
1f20: 74 61 62 6c 65 20 69 66 20 69 74 20 65 78 69 73 table if it exis
1f30: 74 73 0a 09 20 20 20 20 28 69 66 20 28 66 69 6c ts.. (if (fil
1f40: 65 2d 65 78 69 73 74 73 3f 20 64 61 74 66 69 6c e-exists? datfil
1f50: 65 29 0a 09 09 28 73 65 74 21 20 63 6f 6d 6d 65 e)...(set! comme
1f60: 6e 74 20 28 6c 61 75 6e 63 68 3a 6c 6f 61 64 2d nt (launch:load-
1f70: 6c 6f 67 70 72 6f 2d 64 61 74 20 72 75 6e 2d 69 logpro-dat run-i
1f80: 64 20 74 65 73 74 2d 69 64 20 73 74 65 70 6e 61 d test-id stepna
1f90: 6d 65 29 29 29 0a 09 20 20 20 20 28 72 6d 74 3a me))).. (rmt:
1fa0: 74 65 73 74 2d 73 65 74 2d 6c 6f 67 21 20 72 75 test-set-log! ru
1fb0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 28 63 6f n-id test-id (co
1fc0: 6e 63 20 73 74 65 70 6e 61 6d 65 20 22 2e 68 74 nc stepname ".ht
1fd0: 6d 6c 22 29 29 29 29 0a 20 20 20 20 20 20 28 72 ml")))). (r
1fe0: 6d 74 3a 74 65 73 74 73 74 65 70 2d 73 65 74 2d mt:teststep-set-
1ff0: 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 status! run-id t
2000: 65 73 74 2d 69 64 20 73 74 65 70 6e 61 6d 65 20 est-id stepname
2010: 22 65 6e 64 22 20 65 78 69 6e 66 6f 20 63 6f 6d "end" exinfo com
2020: 6d 65 6e 74 20 6c 6f 67 66 6e 61 29 29 0a 20 20 ment logfna)).
2030: 20 20 3b 3b 20 73 65 74 20 74 68 65 20 74 65 73 ;; set the tes
2040: 74 20 66 69 6e 61 6c 20 73 74 61 74 75 73 0a 20 t final status.
2050: 20 20 20 28 6c 65 74 2a 20 28 28 70 72 6f 63 65 (let* ((proce
2060: 73 73 2d 65 78 69 74 2d 73 74 61 74 75 73 20 28 ss-exit-status (
2070: 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 launch:einf-exit
2080: 2d 63 6f 64 65 20 65 78 69 74 2d 69 6e 66 6f 29 -code exit-info)
2090: 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 ) ;; (vector-ref
20a0: 20 65 78 69 74 2d 69 6e 66 6f 20 32 29 29 0a 09 exit-info 2))..
20b0: 20 20 20 28 74 68 69 73 2d 73 74 65 70 2d 73 74 (this-step-st
20c0: 61 74 75 73 20 28 63 6f 6e 64 0a 09 09 09 20 20 atus (cond....
20d0: 20 20 20 20 28 28 61 6e 64 20 28 65 71 3f 20 70 ((and (eq? p
20e0: 72 6f 63 65 73 73 2d 65 78 69 74 2d 73 74 61 74 rocess-exit-stat
20f0: 75 73 20 32 29 20 6c 6f 67 70 72 6f 2d 75 73 65 us 2) logpro-use
2100: 64 29 20 27 77 61 72 6e 29 20 20 20 3b 3b 20 6c d) 'warn) ;; l
2110: 6f 67 70 72 6f 20 32 20 3d 20 77 61 72 6e 69 6e ogpro 2 = warnin
2120: 67 73 0a 09 09 09 20 20 20 20 20 20 28 28 61 6e gs.... ((an
2130: 64 20 28 65 71 3f 20 70 72 6f 63 65 73 73 2d 65 d (eq? process-e
2140: 78 69 74 2d 73 74 61 74 75 73 20 33 29 20 6c 6f xit-status 3) lo
2150: 67 70 72 6f 2d 75 73 65 64 29 20 27 63 68 65 63 gpro-used) 'chec
2160: 6b 29 20 20 3b 3b 20 6c 6f 67 70 72 6f 20 33 20 k) ;; logpro 3
2170: 3d 20 63 68 65 63 6b 0a 09 09 09 20 20 20 20 20 = check....
2180: 20 28 28 61 6e 64 20 28 65 71 3f 20 70 72 6f 63 ((and (eq? proc
2190: 65 73 73 2d 65 78 69 74 2d 73 74 61 74 75 73 20 ess-exit-status
21a0: 34 29 20 6c 6f 67 70 72 6f 2d 75 73 65 64 29 20 4) logpro-used)
21b0: 27 77 61 69 76 65 64 29 20 3b 3b 20 6c 6f 67 70 'waived) ;; logp
21c0: 72 6f 20 34 20 3d 20 77 61 69 76 65 64 0a 09 09 ro 4 = waived...
21d0: 09 20 20 20 20 20 20 28 28 61 6e 64 20 28 65 71 . ((and (eq
21e0: 3f 20 70 72 6f 63 65 73 73 2d 65 78 69 74 2d 73 ? process-exit-s
21f0: 74 61 74 75 73 20 35 29 20 6c 6f 67 70 72 6f 2d tatus 5) logpro-
2200: 75 73 65 64 29 20 27 61 62 6f 72 74 29 20 20 3b used) 'abort) ;
2210: 3b 20 6c 6f 67 70 72 6f 20 35 20 3d 20 61 62 6f ; logpro 5 = abo
2220: 72 74 0a 09 09 09 20 20 20 20 20 20 28 28 61 6e rt.... ((an
2230: 64 20 28 65 71 3f 20 70 72 6f 63 65 73 73 2d 65 d (eq? process-e
2240: 78 69 74 2d 73 74 61 74 75 73 20 36 29 20 6c 6f xit-status 6) lo
2250: 67 70 72 6f 2d 75 73 65 64 29 20 27 73 6b 69 70 gpro-used) 'skip
2260: 29 20 20 20 3b 3b 20 6c 6f 67 70 72 6f 20 36 20 ) ;; logpro 6
2270: 3d 20 73 6b 69 70 0a 09 09 09 20 20 20 20 20 20 = skip....
2280: 28 28 65 71 3f 20 70 72 6f 63 65 73 73 2d 65 78 ((eq? process-ex
2290: 69 74 2d 73 74 61 74 75 73 20 30 29 20 20 20 20 it-status 0)
22a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 '
22b0: 70 61 73 73 29 20 20 20 3b 3b 20 6c 6f 67 70 72 pass) ;; logpr
22c0: 6f 20 30 20 3d 20 70 61 73 73 0a 09 09 09 20 20 o 0 = pass....
22d0: 20 20 20 20 28 65 6c 73 65 20 27 66 61 69 6c 29 (else 'fail)
22e0: 29 29 0a 09 20 20 20 28 6f 76 65 72 61 6c 6c 2d )).. (overall-
22f0: 73 74 61 74 75 73 20 20 20 28 63 6f 6e 64 0a 09 status (cond..
2300: 09 09 20 20 20 20 20 20 28 28 65 71 3f 20 28 6c .. ((eq? (l
2310: 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 aunch:einf-rollu
2320: 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e p-status exit-in
2330: 66 6f 29 20 32 29 20 27 77 61 72 6e 29 20 3b 3b fo) 2) 'warn) ;;
2340: 20 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 28 rollup-status (
2350: 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 2d vector-ref exit-
2360: 69 6e 66 6f 20 33 29 0a 09 09 09 20 20 20 20 20 info 3)....
2370: 20 28 28 65 71 3f 20 28 6c 61 75 6e 63 68 3a 65 ((eq? (launch:e
2380: 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 75 inf-rollup-statu
2390: 73 20 65 78 69 74 2d 69 6e 66 6f 29 20 30 29 20 s exit-info) 0)
23a0: 27 70 61 73 73 29 20 3b 3b 20 28 76 65 63 74 6f 'pass) ;; (vecto
23b0: 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 r-ref exit-info
23c0: 33 29 0a 09 09 09 20 20 20 20 20 20 28 65 6c 73 3).... (els
23d0: 65 20 27 66 61 69 6c 29 29 29 0a 09 20 20 20 28 e 'fail))).. (
23e0: 6e 65 78 74 2d 73 74 61 74 75 73 20 20 20 20 20 next-status
23f0: 20 28 63 6f 6e 64 20 0a 09 09 09 20 20 20 20 20 (cond ....
2400: 20 28 28 65 71 3f 20 6f 76 65 72 61 6c 6c 2d 73 ((eq? overall-s
2410: 74 61 74 75 73 20 27 70 61 73 73 29 20 74 68 69 tatus 'pass) thi
2420: 73 2d 73 74 65 70 2d 73 74 61 74 75 73 29 0a 09 s-step-status)..
2430: 09 09 20 20 20 20 20 20 28 28 65 71 3f 20 6f 76 .. ((eq? ov
2440: 65 72 61 6c 6c 2d 73 74 61 74 75 73 20 27 77 61 erall-status 'wa
2450: 72 6e 29 0a 09 09 09 20 20 20 20 20 20 20 28 69 rn).... (i
2460: 66 20 28 65 71 3f 20 74 68 69 73 2d 73 74 65 70 f (eq? this-step
2470: 2d 73 74 61 74 75 73 20 27 66 61 69 6c 29 20 27 -status 'fail) '
2480: 66 61 69 6c 20 27 77 61 72 6e 29 29 0a 09 09 09 fail 'warn))....
2490: 20 20 20 20 20 20 28 28 65 71 3f 20 6f 76 65 72 ((eq? over
24a0: 61 6c 6c 2d 73 74 61 74 75 73 20 27 61 62 6f 72 all-status 'abor
24b0: 74 29 20 27 61 62 6f 72 74 29 0a 09 09 09 20 20 t) 'abort)....
24c0: 20 20 20 20 28 65 6c 73 65 20 27 66 61 69 6c 29 (else 'fail)
24d0: 29 29 0a 09 20 20 20 28 6e 65 78 74 2d 73 74 61 )).. (next-sta
24e0: 74 65 20 20 20 20 20 20 20 3b 3b 20 22 52 55 4e te ;; "RUN
24f0: 4e 49 4e 47 22 29 20 3b 3b 20 57 48 59 20 57 41 NING") ;; WHY WA
2500: 53 20 54 48 49 53 20 43 48 41 4e 47 45 44 20 54 S THIS CHANGED T
2510: 4f 20 4e 4f 54 20 55 53 45 20 28 6e 75 6c 6c 3f O NOT USE (null?
2520: 20 74 61 6c 29 20 3f 3f 0a 09 20 20 20 20 28 63 tal) ??.. (c
2530: 6f 6e 64 0a 09 20 20 20 20 20 28 28 6e 75 6c 6c ond.. ((null
2540: 3f 20 74 61 6c 29 20 3b 3b 20 6d 6f 72 65 20 74 ? tal) ;; more t
2550: 6f 20 72 75 6e 3f 0a 09 20 20 20 20 20 20 22 43 o run?.. "C
2560: 4f 4d 50 4c 45 54 45 44 22 29 0a 09 20 20 20 20 OMPLETED")..
2570: 20 28 65 6c 73 65 20 22 52 55 4e 4e 49 4e 47 22 (else "RUNNING"
2580: 29 29 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 )))). (debu
2590: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
25a0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 78 lt-log-port* "Ex
25b0: 69 74 20 76 61 6c 75 65 20 72 65 63 65 69 76 65 it value receive
25c0: 64 3a 20 22 20 28 6c 61 75 6e 63 68 3a 65 69 6e d: " (launch:ein
25d0: 66 2d 65 78 69 74 2d 63 6f 64 65 20 65 78 69 74 f-exit-code exit
25e0: 2d 69 6e 66 6f 29 20 22 20 6c 6f 67 70 72 6f 2d -info) " logpro-
25f0: 75 73 65 64 3a 20 22 20 6c 6f 67 70 72 6f 2d 75 used: " logpro-u
2600: 73 65 64 20 0a 09 09 20 20 20 22 20 74 68 69 73 sed ... " this
2610: 2d 73 74 65 70 2d 73 74 61 74 75 73 3a 20 22 20 -step-status: "
2620: 74 68 69 73 2d 73 74 65 70 2d 73 74 61 74 75 73 this-step-status
2630: 20 22 20 6f 76 65 72 61 6c 6c 2d 73 74 61 74 75 " overall-statu
2640: 73 3a 20 22 20 6f 76 65 72 61 6c 6c 2d 73 74 61 s: " overall-sta
2650: 74 75 73 20 0a 09 09 20 20 20 22 20 6e 65 78 74 tus ... " next
2660: 2d 73 74 61 74 75 73 3a 20 22 20 6e 65 78 74 2d -status: " next-
2670: 73 74 61 74 75 73 20 22 20 72 6f 6c 6c 75 70 2d status " rollup-
2680: 73 74 61 74 75 73 3a 20 22 20 20 28 6c 61 75 6e status: " (laun
2690: 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 ch:einf-rollup-s
26a0: 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 tatus exit-info)
26b0: 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 ) ;; (vector-ref
26c0: 20 65 78 69 74 2d 69 6e 66 6f 20 33 29 29 0a 20 exit-info 3)).
26d0: 20 20 20 20 20 28 63 61 73 65 20 6e 65 78 74 2d (case next-
26e0: 73 74 61 74 75 73 0a 09 28 28 77 61 72 6e 29 0a status..((warn).
26f0: 09 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 . (launch:einf-r
2700: 6f 6c 6c 75 70 2d 73 74 61 74 75 73 2d 73 65 74 ollup-status-set
2710: 21 20 65 78 69 74 2d 69 6e 66 6f 20 32 29 20 3b ! exit-info 2) ;
2720: 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 ; (vector-set! e
2730: 78 69 74 2d 69 6e 66 6f 20 33 20 32 29 20 3b 3b xit-info 3 2) ;;
2740: 20 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 0a 09 rollup-status..
2750: 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 2d 73 65 ;; NB// test-se
2760: 74 2d 73 74 61 74 75 73 21 20 64 6f 65 73 20 72 t-status! does r
2770: 64 62 20 63 61 6c 6c 73 20 75 6e 64 65 72 20 74 db calls under t
2780: 68 65 20 68 6f 6f 64 0a 09 20 28 74 65 73 74 73 he hood.. (tests
2790: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 :test-set-status
27a0: 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 ! run-id test-id
27b0: 20 6e 65 78 74 2d 73 74 61 74 65 20 22 57 41 52 next-state "WAR
27c0: 4e 22 20 0a 09 09 09 09 20 28 69 66 20 28 65 71 N" ..... (if (eq
27d0: 3f 20 74 68 69 73 2d 73 74 65 70 2d 73 74 61 74 ? this-step-stat
27e0: 75 73 20 27 77 61 72 6e 29 20 22 4c 6f 67 70 72 us 'warn) "Logpr
27f0: 6f 20 77 61 72 6e 69 6e 67 20 66 6f 75 6e 64 22 o warning found"
2800: 20 23 66 29 0a 09 09 09 09 20 23 66 29 29 0a 09 #f)..... #f))..
2810: 28 28 63 68 65 63 6b 29 0a 09 20 28 6c 61 75 6e ((check).. (laun
2820: 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 ch:einf-rollup-s
2830: 74 61 74 75 73 2d 73 65 74 21 20 65 78 69 74 2d tatus-set! exit-
2840: 69 6e 66 6f 20 33 29 20 3b 3b 20 28 76 65 63 74 info 3) ;; (vect
2850: 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 or-set! exit-inf
2860: 6f 20 33 20 33 29 20 3b 3b 20 72 6f 6c 6c 75 70 o 3 3) ;; rollup
2870: 2d 73 74 61 74 75 73 0a 09 20 3b 3b 20 4e 42 2f -status.. ;; NB/
2880: 2f 20 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 / test-set-statu
2890: 73 21 20 64 6f 65 73 20 72 64 62 20 63 61 6c 6c s! does rdb call
28a0: 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 s under the hood
28b0: 0a 09 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 .. (tests:test-s
28c0: 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 et-status! run-i
28d0: 64 20 74 65 73 74 2d 69 64 20 6e 65 78 74 2d 73 d test-id next-s
28e0: 74 61 74 65 20 22 43 48 45 43 4b 22 20 0a 09 09 tate "CHECK" ...
28f0: 09 09 20 28 69 66 20 28 65 71 3f 20 74 68 69 73 .. (if (eq? this
2900: 2d 73 74 65 70 2d 73 74 61 74 75 73 20 27 63 68 -step-status 'ch
2910: 65 63 6b 29 20 22 4c 6f 67 70 72 6f 20 63 68 65 eck) "Logpro che
2920: 63 6b 20 66 6f 75 6e 64 22 20 23 66 29 0a 09 09 ck found" #f)...
2930: 09 09 20 23 66 29 29 0a 09 28 28 77 61 69 76 65 .. #f))..((waive
2940: 64 29 0a 09 20 28 6c 61 75 6e 63 68 3a 65 69 6e d).. (launch:ein
2950: 66 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 2d f-rollup-status-
2960: 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 34 set! exit-info 4
2970: 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 ) ;; (vector-set
2980: 21 20 65 78 69 74 2d 69 6e 66 6f 20 33 20 33 29 ! exit-info 3 3)
2990: 20 3b 3b 20 72 6f 6c 6c 75 70 2d 73 74 61 74 75 ;; rollup-statu
29a0: 73 0a 09 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 s.. ;; NB// test
29b0: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 6f 65 -set-status! doe
29c0: 73 20 72 64 62 20 63 61 6c 6c 73 20 75 6e 64 65 s rdb calls unde
29d0: 72 20 74 68 65 20 68 6f 6f 64 0a 09 20 28 74 65 r the hood.. (te
29e0: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 sts:test-set-sta
29f0: 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 tus! run-id test
2a00: 2d 69 64 20 6e 65 78 74 2d 73 74 61 74 65 20 22 -id next-state "
2a10: 57 41 49 56 45 44 22 20 0a 09 09 09 09 20 28 69 WAIVED" ..... (i
2a20: 66 20 28 65 71 3f 20 74 68 69 73 2d 73 74 65 70 f (eq? this-step
2a30: 2d 73 74 61 74 75 73 20 27 63 68 65 63 6b 29 20 -status 'check)
2a40: 22 4c 6f 67 70 72 6f 20 77 61 69 76 65 64 20 66 "Logpro waived f
2a50: 6f 75 6e 64 22 20 23 66 29 0a 09 09 09 09 20 23 ound" #f)..... #
2a60: 66 29 29 0a 09 28 28 61 62 6f 72 74 29 0a 09 20 f))..((abort)..
2a70: 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c (launch:einf-rol
2a80: 6c 75 70 2d 73 74 61 74 75 73 2d 73 65 74 21 20 lup-status-set!
2a90: 65 78 69 74 2d 69 6e 66 6f 20 35 29 20 3b 3b 20 exit-info 5) ;;
2aa0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 (vector-set! exi
2ab0: 74 2d 69 6e 66 6f 20 33 20 34 29 20 3b 3b 20 72 t-info 3 4) ;; r
2ac0: 6f 6c 6c 75 70 2d 73 74 61 74 75 73 0a 09 20 3b ollup-status.. ;
2ad0: 3b 20 4e 42 2f 2f 20 74 65 73 74 2d 73 65 74 2d ; NB// test-set-
2ae0: 73 74 61 74 75 73 21 20 64 6f 65 73 20 72 64 62 status! does rdb
2af0: 20 63 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 calls under the
2b00: 20 68 6f 6f 64 0a 09 20 28 74 65 73 74 73 3a 74 hood.. (tests:t
2b10: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
2b20: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e run-id test-id n
2b30: 65 78 74 2d 73 74 61 74 65 20 22 41 42 4f 52 54 ext-state "ABORT
2b40: 22 20 0a 09 09 09 09 20 28 69 66 20 28 65 71 3f " ..... (if (eq?
2b50: 20 74 68 69 73 2d 73 74 65 70 2d 73 74 61 74 75 this-step-statu
2b60: 73 20 27 61 62 6f 72 74 29 20 22 4c 6f 67 70 72 s 'abort) "Logpr
2b70: 6f 20 61 62 6f 72 74 20 66 6f 75 6e 64 22 20 23 o abort found" #
2b80: 66 29 0a 09 09 09 09 20 23 66 29 29 0a 09 28 28 f)..... #f))..((
2b90: 73 6b 69 70 29 0a 09 20 28 6c 61 75 6e 63 68 3a skip).. (launch:
2ba0: 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 einf-rollup-stat
2bb0: 75 73 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 us-set! exit-inf
2bc0: 6f 20 36 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d o 6) ;; (vector-
2bd0: 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 33 set! exit-info 3
2be0: 20 34 29 20 3b 3b 20 72 6f 6c 6c 75 70 2d 73 74 4) ;; rollup-st
2bf0: 61 74 75 73 0a 09 20 3b 3b 20 4e 42 2f 2f 20 74 atus.. ;; NB// t
2c00: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
2c10: 64 6f 65 73 20 72 64 62 20 63 61 6c 6c 73 20 75 does rdb calls u
2c20: 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 0a 09 20 nder the hood..
2c30: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
2c40: 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 status! run-id t
2c50: 65 73 74 2d 69 64 20 6e 65 78 74 2d 73 74 61 74 est-id next-stat
2c60: 65 20 22 53 4b 49 50 22 20 0a 09 09 09 09 20 28 e "SKIP" ..... (
2c70: 69 66 20 28 65 71 3f 20 74 68 69 73 2d 73 74 65 if (eq? this-ste
2c80: 70 2d 73 74 61 74 75 73 20 27 73 6b 69 70 29 20 p-status 'skip)
2c90: 22 4c 6f 67 70 72 6f 20 73 6b 69 70 20 66 6f 75 "Logpro skip fou
2ca0: 6e 64 22 20 23 66 29 0a 09 09 09 09 20 23 66 29 nd" #f)..... #f)
2cb0: 29 0a 09 28 28 70 61 73 73 29 0a 09 20 28 74 65 )..((pass).. (te
2cc0: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 sts:test-set-sta
2cd0: 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 tus! run-id test
2ce0: 2d 69 64 20 6e 65 78 74 2d 73 74 61 74 65 20 22 -id next-state "
2cf0: 50 41 53 53 22 20 23 66 20 23 66 29 29 0a 09 28 PASS" #f #f))..(
2d00: 65 6c 73 65 20 3b 3b 20 27 66 61 69 6c 0a 09 20 else ;; 'fail..
2d10: 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c (launch:einf-rol
2d20: 6c 75 70 2d 73 74 61 74 75 73 2d 73 65 74 21 20 lup-status-set!
2d30: 65 78 69 74 2d 69 6e 66 6f 20 31 29 20 3b 3b 20 exit-info 1) ;;
2d40: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 (vector-set! exi
2d50: 74 2d 69 6e 66 6f 20 33 20 31 29 20 3b 3b 20 66 t-info 3 1) ;; f
2d60: 6f 72 63 65 20 66 61 69 6c 2c 20 74 68 69 73 20 orce fail, this
2d70: 75 73 65 64 20 74 6f 20 62 65 20 6e 65 78 74 2d used to be next-
2d80: 73 74 61 74 65 20 62 75 74 20 74 68 61 74 20 64 state but that d
2d90: 6f 65 73 6e 27 74 20 6d 61 6b 65 20 73 65 6e 73 oesn't make sens
2da0: 65 2e 20 73 68 6f 75 6c 64 20 61 6c 77 61 79 73 e. should always
2db0: 20 62 65 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 be "COMPLETED"
2dc0: 0a 09 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 .. (tests:test-s
2dd0: 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 et-status! run-i
2de0: 64 20 74 65 73 74 2d 69 64 20 22 43 4f 4d 50 4c d test-id "COMPL
2df0: 45 54 45 44 22 20 22 46 41 49 4c 22 20 28 63 6f ETED" "FAIL" (co
2e00: 6e 63 20 22 46 61 69 6c 65 64 20 61 74 20 73 74 nc "Failed at st
2e10: 65 70 20 22 20 73 74 65 70 6e 61 6d 65 29 20 23 ep " stepname) #
2e20: 66 29 0a 09 20 29 29 29 0a 20 20 20 20 6c 6f 67 f).. ))). log
2e30: 70 72 6f 2d 75 73 65 64 29 29 0a 0a 28 64 65 66 pro-used))..(def
2e40: 69 6e 65 20 28 6c 61 75 6e 63 68 3a 6d 61 6e 61 ine (launch:mana
2e50: 67 65 2d 73 74 65 70 73 20 72 75 6e 2d 69 64 20 ge-steps run-id
2e60: 74 65 73 74 2d 69 64 20 69 74 65 6d 2d 70 61 74 test-id item-pat
2e70: 68 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 h fullrunscript
2e80: 65 7a 73 74 65 70 73 20 74 65 73 74 2d 6e 61 6d ezsteps test-nam
2e90: 65 20 74 63 6f 6e 66 69 67 72 65 67 20 65 78 69 e tconfigreg exi
2ea0: 74 2d 69 6e 66 6f 20 6d 29 0a 20 20 3b 3b 20 28 t-info m). ;; (
2eb0: 6c 65 74 2d 76 61 6c 75 65 73 0a 20 20 3b 3b 20 let-values. ;;
2ec0: 20 28 28 28 70 69 64 20 65 78 69 74 2d 73 74 61 (((pid exit-sta
2ed0: 74 75 73 20 65 78 69 74 2d 63 6f 64 65 29 0a 20 tus exit-code).
2ee0: 20 3b 3b 20 20 20 20 28 72 75 6e 2d 6e 2d 77 61 ;; (run-n-wa
2ef0: 69 74 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 it fullrunscript
2f00: 29 29 29 0a 20 20 3b 3b 20 28 74 65 73 74 73 3a ))). ;; (tests:
2f10: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
2f20: 20 74 65 73 74 2d 69 64 20 22 52 55 4e 4e 49 4e test-id "RUNNIN
2f30: 47 22 20 22 6e 2f 61 22 20 23 66 20 23 66 29 0a G" "n/a" #f #f).
2f40: 20 20 3b 3b 20 53 69 6e 63 65 20 77 65 20 73 68 ;; Since we sh
2f50: 6f 75 6c 64 20 68 61 76 65 20 61 20 63 6c 65 61 ould have a clea
2f60: 6e 20 73 6c 61 74 65 20 61 74 20 74 68 69 73 20 n slate at this
2f70: 74 69 6d 65 20 74 68 65 72 65 20 69 73 20 6e 6f time there is no
2f80: 20 6e 65 65 64 20 74 6f 20 64 6f 20 0a 20 20 3b need to do . ;
2f90: 3b 20 61 6e 79 20 6f 66 20 74 68 65 20 6f 74 68 ; any of the oth
2fa0: 65 72 20 73 74 75 66 66 20 74 68 61 74 20 74 65 er stuff that te
2fb0: 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 sts:test-set-sta
2fc0: 74 75 73 21 20 64 6f 65 73 2e 20 4c 65 74 27 73 tus! does. Let's
2fd0: 20 6a 75 73 74 20 0a 20 20 3b 3b 20 66 6f 72 63 just . ;; forc
2fe0: 65 20 52 55 4e 4e 49 4e 47 2f 6e 2f 61 0a 0a 20 e RUNNING/n/a..
2ff0: 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 65 ;; (thread-slee
3000: 70 21 20 30 2e 33 29 0a 20 20 3b 3b 20 28 74 65 p! 0.3). ;; (te
3010: 73 74 73 3a 74 65 73 74 2d 66 6f 72 63 65 2d 73 sts:test-force-s
3020: 74 61 74 65 2d 73 74 61 74 75 73 21 20 72 75 6e tate-status! run
3030: 2d 69 64 20 74 65 73 74 2d 69 64 20 22 52 55 4e -id test-id "RUN
3040: 4e 49 4e 47 22 20 22 6e 2f 61 22 29 0a 20 20 28 NING" "n/a"). (
3050: 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 rmt:set-state-st
3060: 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 atus-and-roll-up
3070: 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 -items run-id te
3080: 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 st-name item-pat
3090: 68 20 22 52 55 4e 4e 49 4e 47 22 20 23 66 20 23 h "RUNNING" #f #
30a0: 66 29 20 0a 20 20 3b 3b 20 28 74 68 72 65 61 64 f) . ;; (thread
30b0: 2d 73 6c 65 65 70 21 20 30 2e 33 29 20 3b 3b 20 -sleep! 0.3) ;;
30c0: 4e 46 53 20 73 6c 6f 77 6e 65 73 73 20 68 61 73 NFS slowness has
30d0: 20 63 61 75 73 65 64 20 67 72 69 65 66 20 68 65 caused grief he
30e0: 72 65 0a 0a 20 20 3b 3b 20 69 66 20 74 68 65 72 re.. ;; if ther
30f0: 65 20 69 73 20 61 20 72 75 6e 73 63 72 69 70 74 e is a runscript
3100: 20 64 6f 20 69 74 20 66 69 72 73 74 0a 20 20 28 do it first. (
3110: 69 66 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 if fullrunscript
3120: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 70 69 . (let ((pi
3130: 64 20 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 66 d (process-run f
3140: 75 6c 6c 72 75 6e 73 63 72 69 70 74 29 29 29 0a ullrunscript))).
3150: 09 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 74 .(rmt:test-set-t
3160: 6f 70 2d 70 72 6f 63 65 73 73 2d 70 69 64 20 72 op-process-pid r
3170: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 70 69 un-id test-id pi
3180: 64 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 d)..(let loop ((
3190: 69 20 30 29 29 0a 09 20 20 28 6c 65 74 2d 76 61 i 0)).. (let-va
31a0: 6c 75 65 73 0a 09 20 20 20 28 28 28 70 69 64 2d lues.. (((pid-
31b0: 76 61 6c 20 65 78 69 74 2d 73 74 61 74 75 73 20 val exit-status
31c0: 65 78 69 74 2d 63 6f 64 65 29 20 28 70 72 6f 63 exit-code) (proc
31d0: 65 73 73 2d 77 61 69 74 20 70 69 64 20 23 74 29 ess-wait pid #t)
31e0: 29 29 0a 09 20 20 20 28 6d 75 74 65 78 2d 6c 6f )).. (mutex-lo
31f0: 63 6b 21 20 6d 29 0a 09 20 20 20 28 6c 61 75 6e ck! m).. (laun
3200: 63 68 3a 65 69 6e 66 2d 70 69 64 2d 73 65 74 21 ch:einf-pid-set!
3210: 20 20 20 20 20 20 20 20 20 20 20 65 78 69 74 2d exit-
3220: 69 6e 66 6f 20 20 70 69 64 29 20 20 20 20 20 20 info pid)
3230: 20 20 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 ;; (vector-se
3240: 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 30 20 70 t! exit-info 0 p
3250: 69 64 29 0a 09 20 20 20 28 6c 61 75 6e 63 68 3a id).. (launch:
3260: 65 69 6e 66 2d 65 78 69 74 2d 73 74 61 74 75 73 einf-exit-status
3270: 2d 73 65 74 21 20 20 20 65 78 69 74 2d 69 6e 66 -set! exit-inf
3280: 6f 20 20 65 78 69 74 2d 73 74 61 74 75 73 29 20 o exit-status)
3290: 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 ;; (vector-set!
32a0: 65 78 69 74 2d 69 6e 66 6f 20 31 20 65 78 69 74 exit-info 1 exit
32b0: 2d 73 74 61 74 75 73 29 0a 09 20 20 20 28 6c 61 -status).. (la
32c0: 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 63 unch:einf-exit-c
32d0: 6f 64 65 2d 73 65 74 21 20 20 20 20 20 65 78 69 ode-set! exi
32e0: 74 2d 69 6e 66 6f 20 20 65 78 69 74 2d 63 6f 64 t-info exit-cod
32f0: 65 29 20 20 20 3b 3b 20 28 76 65 63 74 6f 72 2d e) ;; (vector-
3300: 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 32 set! exit-info 2
3310: 20 65 78 69 74 2d 63 6f 64 65 29 0a 09 20 20 20 exit-code)..
3320: 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c (launch:einf-rol
3330: 6c 75 70 2d 73 74 61 74 75 73 2d 73 65 74 21 20 lup-status-set!
3340: 65 78 69 74 2d 69 6e 66 6f 20 20 65 78 69 74 2d exit-info exit-
3350: 63 6f 64 65 29 20 20 20 3b 3b 20 28 76 65 63 74 code) ;; (vect
3360: 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 or-set! exit-inf
3370: 6f 20 33 20 65 78 69 74 2d 63 6f 64 65 29 20 20 o 3 exit-code)
3380: 3b 3b 20 72 6f 6c 6c 75 70 20 73 74 61 74 75 73 ;; rollup status
3390: 0a 09 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f .. (mutex-unlo
33a0: 63 6b 21 20 6d 29 0a 09 20 20 20 28 69 66 20 28 ck! m).. (if (
33b0: 65 71 3f 20 70 69 64 2d 76 61 6c 20 30 29 0a 09 eq? pid-val 0)..
33c0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 (begin...
33d0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
33e0: 32 29 0a 09 09 20 28 6c 6f 6f 70 20 28 2b 20 69 2)... (loop (+ i
33f0: 20 31 29 29 29 0a 09 20 20 20 20 20 20 20 29 29 1))).. ))
3400: 29 29 29 0a 20 20 3b 3b 20 74 68 65 6e 2c 20 69 ))). ;; then, i
3410: 66 20 72 75 6e 73 63 72 69 70 74 20 72 61 6e 20 f runscript ran
3420: 6f 6b 20 28 6f 72 20 64 69 64 20 6e 6f 74 20 67 ok (or did not g
3430: 65 74 20 63 61 6c 6c 65 64 29 0a 20 20 3b 3b 20 et called). ;;
3440: 64 6f 20 61 6c 6c 20 74 68 65 20 65 7a 73 74 65 do all the ezste
3450: 70 73 20 28 69 66 20 61 6e 79 29 0a 20 20 28 69 ps (if any). (i
3460: 66 20 65 7a 73 74 65 70 73 0a 20 20 20 20 20 20 f ezsteps.
3470: 28 6c 65 74 2a 20 28 28 74 65 73 74 63 6f 6e 66 (let* ((testconf
3480: 69 67 20 3b 3b 20 28 72 65 61 64 2d 63 6f 6e 66 ig ;; (read-conf
3490: 69 67 20 28 63 6f 6e 63 20 77 6f 72 6b 2d 61 72 ig (conc work-ar
34a0: 65 61 20 22 2f 74 65 73 74 63 6f 6e 66 69 67 22 ea "/testconfig"
34b0: 29 20 23 66 20 23 74 20 65 6e 76 69 72 6f 6e 2d ) #f #t environ-
34c0: 70 61 74 74 3a 20 22 70 72 65 2d 6c 61 75 6e 63 patt: "pre-launc
34d0: 68 2d 65 6e 76 2d 76 61 72 73 22 29 29 20 3b 3b h-env-vars")) ;;
34e0: 20 46 49 58 4d 45 3f 3f 3f 20 69 73 20 61 6c 6c FIXME??? is all
34f0: 6f 77 2d 73 79 73 74 65 6d 20 6f 6b 20 68 65 72 ow-system ok her
3500: 65 3f 0a 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 e?.. ;; NOT
3510: 45 3a 20 69 74 20 69 73 20 74 65 6d 70 74 69 6e E: it is temptin
3520: 67 20 74 6f 20 74 75 72 6e 20 6f 66 66 20 66 6f g to turn off fo
3530: 72 63 65 2d 63 72 65 61 74 65 20 6f 66 20 74 65 rce-create of te
3540: 73 74 63 6f 6e 66 69 67 20 62 75 74 20 64 79 6e stconfig but dyn
3550: 61 6d 69 63 0a 09 20 20 20 20 20 20 3b 3b 20 20 amic.. ;;
3560: 20 20 20 20 20 65 7a 73 74 65 70 20 6e 61 6d 65 ezstep name
3570: 73 20 6e 65 65 64 20 61 20 66 75 6c 6c 20 72 65 s need a full re
3580: 2d 65 76 61 6c 20 68 65 72 65 2e 0a 09 20 20 20 -eval here...
3590: 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 (tests:get-te
35a0: 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 stconfig test-na
35b0: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 74 63 6f me item-path tco
35c0: 6e 66 69 67 72 65 67 20 23 74 20 66 6f 72 63 65 nfigreg #t force
35d0: 2d 63 72 65 61 74 65 3a 20 23 74 29 29 20 3b 3b -create: #t)) ;;
35e0: 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 'return-procs))
35f0: 29 0a 09 20 20 20 20 20 28 65 7a 73 74 65 70 73 ).. (ezsteps
3600: 6c 73 74 20 28 69 66 20 28 68 61 73 68 2d 74 61 lst (if (hash-ta
3610: 62 6c 65 3f 20 74 65 73 74 63 6f 6e 66 69 67 29 ble? testconfig)
3620: 0a 09 09 09 20 20 20 20 20 28 68 61 73 68 2d 74 .... (hash-t
3630: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
3640: 20 74 65 73 74 63 6f 6e 66 69 67 20 22 65 7a 73 testconfig "ezs
3650: 74 65 70 73 22 20 27 28 29 29 0a 09 09 09 20 20 teps" '())....
3660: 20 20 20 23 66 29 29 29 0a 09 28 69 66 20 74 65 #f)))..(if te
3670: 73 74 63 6f 6e 66 69 67 0a 09 20 20 20 20 28 68 stconfig.. (h
3680: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
3690: 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 65 73 testconfigs* tes
36a0: 74 2d 6e 61 6d 65 20 74 65 73 74 63 6f 6e 66 69 t-name testconfi
36b0: 67 29 20 3b 3b 20 63 61 63 68 65 64 20 66 6f 72 g) ;; cached for
36c0: 20 6c 61 7a 79 20 72 65 61 64 73 20 6c 61 74 65 lazy reads late
36d0: 72 20 2e 2e 2e 0a 09 20 20 20 20 28 62 65 67 69 r ..... (begi
36e0: 6e 0a 09 20 20 20 20 20 20 28 6c 61 75 6e 63 68 n.. (launch
36f0: 3a 73 65 74 75 70 29 0a 09 20 20 20 20 20 20 28 :setup).. (
3700: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3710: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3720: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 74 65 "WARNING: no te
3730: 73 74 63 6f 6e 66 69 67 20 66 6f 75 6e 64 20 66 stconfig found f
3740: 6f 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 or " test-name "
3750: 20 69 6e 20 73 65 61 72 63 68 20 70 61 74 68 3a in search path:
3760: 5c 6e 20 20 22 0a 09 09 09 20 20 20 28 73 74 72 \n ".... (str
3770: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
3780: 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 73 (tests:get-tests
3790: 2d 73 65 61 72 63 68 2d 70 61 74 68 20 2a 63 6f -search-path *co
37a0: 6e 66 69 67 64 61 74 2a 29 20 22 5c 6e 20 20 22 nfigdat*) "\n "
37b0: 29 29 29 29 0a 09 3b 3b 20 61 66 74 65 72 20 61 ))))..;; after a
37c0: 6c 6c 20 74 68 61 74 2c 20 73 74 69 6c 6c 20 6e ll that, still n
37d0: 6f 20 74 65 73 74 63 6f 6e 66 69 67 3f 20 54 69 o testconfig? Ti
37e0: 6d 65 20 74 6f 20 61 62 6f 72 74 0a 09 28 69 66 me to abort..(if
37f0: 20 28 6e 6f 74 20 74 65 73 74 63 6f 6e 66 69 67 (not testconfig
3800: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
3810: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3820: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
3830: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 lt-log-port* "Fa
3840: 69 6c 65 64 20 74 6f 20 72 65 73 6f 6c 76 65 20 iled to resolve
3850: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 2c megatest.config,
3860: 20 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 runconfigs.conf
3870: 69 67 20 61 6e 64 20 74 65 73 74 63 6f 6e 66 69 ig and testconfi
3880: 67 20 69 73 73 75 65 73 2e 20 47 69 76 69 6e 67 g issues. Giving
3890: 20 75 70 20 6e 6f 77 22 29 0a 09 20 20 20 20 20 up now")..
38a0: 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 69 66 (exit 1)))..(if
38b0: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
38c0: 74 73 3f 20 22 2e 65 7a 73 74 65 70 73 22 29 29 ts? ".ezsteps"))
38d0: 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 (create-director
38e0: 79 20 22 2e 65 7a 73 74 65 70 73 22 29 29 0a 09 y ".ezsteps"))..
38f0: 3b 3b 20 69 66 20 65 7a 73 74 65 70 73 20 77 61 ;; if ezsteps wa
3900: 73 20 64 65 66 69 6e 65 64 20 74 68 65 6e 20 77 s defined then w
3910: 65 20 61 72 65 20 73 75 72 65 20 74 6f 20 68 61 e are sure to ha
3920: 76 65 20 61 74 20 6c 65 61 73 74 20 6f 6e 65 20 ve at least one
3930: 73 74 65 70 20 62 75 74 20 63 68 65 63 6b 20 61 step but check a
3940: 6e 79 77 61 79 0a 09 28 69 66 20 28 6e 6f 74 20 nyway..(if (not
3950: 28 3e 20 28 6c 65 6e 67 74 68 20 65 7a 73 74 65 (> (length ezste
3960: 70 73 6c 73 74 29 20 30 29 29 0a 09 20 20 20 20 pslst) 0))..
3970: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
3980: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
3990: 67 2d 70 6f 72 74 2a 20 22 65 7a 73 74 65 70 73 g-port* "ezsteps
39a0: 20 64 65 66 69 6e 65 64 20 62 75 74 20 65 7a 73 defined but ezs
39b0: 74 65 70 73 6c 73 74 20 69 73 20 7a 65 72 6f 20 tepslst is zero
39c0: 6c 65 6e 67 74 68 22 29 0a 09 20 20 20 20 28 6c length").. (l
39d0: 65 74 20 6c 6f 6f 70 20 28 28 65 7a 73 74 65 70 et loop ((ezstep
39e0: 20 28 63 61 72 20 65 7a 73 74 65 70 73 6c 73 74 (car ezstepslst
39f0: 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 61 6c ))... (tal
3a00: 20 20 20 20 28 63 64 72 20 65 7a 73 74 65 70 73 (cdr ezsteps
3a10: 6c 73 74 29 29 0a 09 09 20 20 20 20 20 20 20 28 lst))... (
3a20: 70 72 65 76 73 74 65 70 20 23 66 29 29 0a 09 20 prevstep #f))..
3a30: 20 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 65 78 ;; check ex
3a40: 69 74 2d 69 6e 66 6f 20 28 76 65 63 74 6f 72 2d it-info (vector-
3a50: 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 31 29 ref exit-info 1)
3a60: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6c 61 75 .. (if (lau
3a70: 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 73 74 nch:einf-exit-st
3a80: 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 20 atus exit-info)
3a90: 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 65 ;; (vector-ref e
3aa0: 78 69 74 2d 69 6e 66 6f 20 31 29 0a 09 09 20 20 xit-info 1)...
3ab0: 28 6c 65 74 20 28 28 6c 6f 67 70 72 6f 2d 75 73 (let ((logpro-us
3ac0: 65 64 20 28 6c 61 75 6e 63 68 3a 72 75 6e 73 74 ed (launch:runst
3ad0: 65 70 20 65 7a 73 74 65 70 20 72 75 6e 2d 69 64 ep ezstep run-id
3ae0: 20 74 65 73 74 2d 69 64 20 65 78 69 74 2d 69 6e test-id exit-in
3af0: 66 6f 20 6d 20 74 61 6c 20 74 65 73 74 63 6f 6e fo m tal testcon
3b00: 66 69 67 29 29 0a 09 09 09 28 73 74 65 70 6e 61 fig))....(stepna
3b10: 6d 65 20 20 20 20 28 63 61 72 20 65 7a 73 74 65 me (car ezste
3b20: 70 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 69 66 p)))... ;; if
3b30: 20 6c 6f 67 70 72 6f 2d 75 73 65 64 20 72 65 61 logpro-used rea
3b40: 64 20 69 6e 20 74 68 65 20 73 74 65 70 6e 61 6d d in the stepnam
3b50: 65 2e 64 61 74 20 66 69 6c 65 0a 09 09 20 20 20 e.dat file...
3b60: 20 28 69 66 20 28 61 6e 64 20 6c 6f 67 70 72 6f (if (and logpro
3b70: 2d 75 73 65 64 20 28 66 69 6c 65 2d 65 78 69 73 -used (file-exis
3b80: 74 73 3f 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 ts? (conc stepna
3b90: 6d 65 20 22 2e 64 61 74 22 29 29 29 0a 09 09 09 me ".dat")))....
3ba0: 28 6c 61 75 6e 63 68 3a 6c 6f 61 64 2d 6c 6f 67 (launch:load-log
3bb0: 70 72 6f 2d 64 61 74 20 72 75 6e 2d 69 64 20 74 pro-dat run-id t
3bc0: 65 73 74 2d 69 64 20 73 74 65 70 6e 61 6d 65 29 est-id stepname)
3bd0: 29 0a 09 09 20 20 20 20 28 69 66 20 28 73 74 65 )... (if (ste
3be0: 70 72 75 6e 2d 67 6f 6f 64 3f 20 6c 6f 67 70 72 prun-good? logpr
3bf0: 6f 2d 75 73 65 64 20 28 6c 61 75 6e 63 68 3a 65 o-used (launch:e
3c00: 69 6e 66 2d 65 78 69 74 2d 63 6f 64 65 20 65 78 inf-exit-code ex
3c10: 69 74 2d 69 6e 66 6f 29 29 0a 09 09 09 28 69 66 it-info))....(if
3c20: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
3c30: 29 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 )).... (loop
3c40: 28 63 61 72 20 74 61 6c 29 20 28 63 64 72 20 74 (car tal) (cdr t
3c50: 61 6c 29 20 73 74 65 70 6e 61 6d 65 29 29 0a 09 al) stepname))..
3c60: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 ..(debug:print 4
3c70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3c80: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 73 74 rt* "WARNING: st
3c90: 65 70 20 22 20 28 63 61 72 20 65 7a 73 74 65 70 ep " (car ezstep
3ca0: 29 20 22 20 66 61 69 6c 65 64 2e 20 53 74 6f 70 ) " failed. Stop
3cb0: 70 69 6e 67 22 29 29 29 0a 09 09 20 20 28 64 65 ping")))... (de
3cc0: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
3cd0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3ce0: 57 41 52 4e 49 4e 47 3a 20 61 20 70 72 69 6f 72 WARNING: a prior
3cf0: 20 73 74 65 70 20 66 61 69 6c 65 64 2c 20 73 74 step failed, st
3d00: 6f 70 70 69 6e 67 20 61 74 20 22 20 65 7a 73 74 opping at " ezst
3d10: 65 70 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 ep)))))))..(defi
3d20: 6e 65 20 28 6c 61 75 6e 63 68 3a 6d 6f 6e 69 74 ne (launch:monit
3d30: 6f 72 2d 6a 6f 62 20 72 75 6e 2d 69 64 20 74 65 or-job run-id te
3d40: 73 74 2d 69 64 20 69 74 65 6d 2d 70 61 74 68 20 st-id item-path
3d50: 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 65 7a fullrunscript ez
3d60: 73 74 65 70 73 20 74 65 73 74 2d 6e 61 6d 65 20 steps test-name
3d70: 74 63 6f 6e 66 69 67 72 65 67 20 65 78 69 74 2d tconfigreg exit-
3d80: 69 6e 66 6f 20 6d 20 77 6f 72 6b 2d 61 72 65 61 info m work-area
3d90: 20 72 75 6e 74 6c 69 6d 20 6d 69 73 63 2d 66 6c runtlim misc-fl
3da0: 61 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 ags). (let* ((s
3db0: 74 61 72 74 2d 73 65 63 6f 6e 64 73 20 28 63 75 tart-seconds (cu
3dc0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
3dd0: 09 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 20 . (calc-minutes
3de0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
3df0: 20 28 69 6e 65 78 61 63 74 2d 3e 65 78 61 63 74 (inexact->exact
3e00: 20 0a 09 09 09 20 20 20 28 72 6f 75 6e 64 20 0a .... (round .
3e10: 09 09 09 20 20 20 20 28 2d 20 0a 09 09 09 20 20 ... (- ....
3e20: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
3e30: 6e 64 73 29 20 0a 09 09 09 20 20 20 20 20 73 74 nds) .... st
3e40: 61 72 74 2d 73 65 63 6f 6e 64 73 29 29 29 29 29 art-seconds)))))
3e50: 0a 09 20 28 6b 69 6c 6c 2d 74 72 69 65 73 20 30 .. (kill-tries 0
3e60: 29 29 0a 20 20 20 20 3b 3b 20 28 74 65 73 74 73 )). ;; (tests
3e70: 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 :set-full-meta-i
3e80: 6e 66 6f 20 23 66 20 74 65 73 74 2d 69 64 20 72 nfo #f test-id r
3e90: 75 6e 2d 69 64 20 28 63 61 6c 63 2d 6d 69 6e 75 un-id (calc-minu
3ea0: 74 65 73 29 20 77 6f 72 6b 2d 61 72 65 61 29 0a tes) work-area).
3eb0: 20 20 20 20 3b 3b 20 28 74 65 73 74 73 3a 73 65 ;; (tests:se
3ec0: 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f t-full-meta-info
3ed0: 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
3ee0: 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 20 77 (calc-minutes) w
3ef0: 6f 72 6b 2d 61 72 65 61 29 0a 20 20 20 20 28 74 ork-area). (t
3f00: 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 ests:set-full-me
3f10: 74 61 2d 69 6e 66 6f 20 23 66 20 74 65 73 74 2d ta-info #f test-
3f20: 69 64 20 72 75 6e 2d 69 64 20 28 63 61 6c 63 2d id run-id (calc-
3f30: 6d 69 6e 75 74 65 73 29 20 77 6f 72 6b 2d 61 72 minutes) work-ar
3f40: 65 61 20 31 30 29 0a 20 20 20 20 28 6c 65 74 20 ea 10). (let
3f50: 6c 6f 6f 70 20 28 28 6d 69 6e 75 74 65 73 20 20 loop ((minutes
3f60: 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 29 (calc-minutes))
3f70: 0a 09 20 20 20 20 20 20 20 28 63 70 75 2d 6c 6f .. (cpu-lo
3f80: 61 64 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 ad (alist-ref '
3f90: 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 28 63 adj-core-load (c
3fa0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d 61 6c ommon:get-normal
3fb0: 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 23 66 ized-cpu-load #f
3fc0: 29 29 29 0a 09 20 20 20 20 20 20 20 28 64 69 73 ))).. (dis
3fd0: 6b 2d 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 k-free (get-df (
3fe0: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
3ff0: 79 29 29 29 29 0a 20 20 20 20 20 20 28 6c 65 74 y)))). (let
4000: 20 28 28 6e 65 77 2d 63 70 75 2d 6c 6f 61 64 20 ((new-cpu-load
4010: 28 6c 65 74 2a 20 28 28 6c 6f 61 64 20 20 28 61 (let* ((load (a
4020: 6c 69 73 74 2d 72 65 66 20 27 61 64 6a 2d 63 6f list-ref 'adj-co
4030: 72 65 2d 6c 6f 61 64 20 28 63 6f 6d 6d 6f 6e 3a re-load (common:
4040: 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 get-normalized-c
4050: 70 75 2d 6c 6f 61 64 20 23 66 29 29 29 0a 09 09 pu-load #f)))...
4060: 09 09 20 28 64 65 6c 74 61 20 28 61 62 73 20 28 .. (delta (abs (
4070: 2d 20 6c 6f 61 64 20 63 70 75 2d 6c 6f 61 64 29 - load cpu-load)
4080: 29 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 ))).... (if (
4090: 3e 20 64 65 6c 74 61 20 30 2e 31 29 20 3b 3b 20 > delta 0.1) ;;
40a0: 64 6f 6e 27 74 20 62 6f 74 68 65 72 20 75 70 64 don't bother upd
40b0: 61 74 69 6e 67 20 77 69 74 68 20 73 6d 61 6c 6c ating with small
40c0: 20 63 68 61 6e 67 65 73 0a 09 09 09 09 6c 6f 61 changes.....loa
40d0: 64 0a 09 09 09 09 23 66 29 29 29 0a 09 20 20 20 d.....#f)))..
40e0: 20 28 6e 65 77 2d 64 69 73 6b 2d 66 72 65 65 20 (new-disk-free
40f0: 28 6c 65 74 2a 20 28 28 64 66 20 20 20 20 28 67 (let* ((df (g
4100: 65 74 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 et-df (current-d
4110: 69 72 65 63 74 6f 72 79 29 29 29 0a 09 09 09 09 irectory))).....
4120: 20 20 28 64 65 6c 74 61 20 28 61 62 73 20 28 2d (delta (abs (-
4130: 20 64 66 20 64 69 73 6b 2d 66 72 65 65 29 29 29 df disk-free)))
4140: 29 0a 09 09 09 20 20 20 20 20 28 69 66 20 28 3e ).... (if (>
4150: 20 64 65 6c 74 61 20 32 30 30 29 20 3b 3b 20 69 delta 200) ;; i
4160: 67 6e 6f 72 65 20 63 68 61 6e 67 65 73 20 75 6e gnore changes un
4170: 64 65 72 20 32 30 30 20 4d 65 67 0a 09 09 09 09 der 200 Meg.....
4180: 20 64 66 0a 09 09 09 09 20 23 66 29 29 29 29 0a df..... #f)))).
4190: 09 28 73 65 74 21 20 6b 69 6c 6c 2d 6a 6f 62 3f .(set! kill-job?
41a0: 20 28 6f 72 20 28 74 65 73 74 2d 67 65 74 2d 6b (or (test-get-k
41b0: 69 6c 6c 2d 72 65 71 75 65 73 74 20 72 75 6e 2d ill-request run-
41c0: 69 64 20 74 65 73 74 2d 69 64 29 20 3b 3b 20 72 id test-id) ;; r
41d0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
41e0: 69 74 65 6d 64 61 74 29 29 0a 09 09 09 20 20 20 itemdat))....
41f0: 20 28 61 6e 64 20 72 75 6e 74 6c 69 6d 20 28 6c (and runtlim (l
4200: 65 74 2a 20 28 28 72 75 6e 2d 73 65 63 6f 6e 64 et* ((run-second
4210: 73 20 20 20 28 2d 20 28 63 75 72 72 65 6e 74 2d s (- (current-
4220: 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 73 seconds) start-s
4230: 65 63 6f 6e 64 73 29 29 0a 09 09 09 09 09 09 28 econds)).......(
4240: 74 69 6d 65 2d 65 78 63 65 65 64 65 64 20 28 3e time-exceeded (>
4250: 20 72 75 6e 2d 73 65 63 6f 6e 64 73 20 72 75 6e run-seconds run
4260: 74 6c 69 6d 29 29 29 0a 09 09 09 09 09 20 20 20 tlim)))......
4270: 28 69 66 20 74 69 6d 65 2d 65 78 63 65 65 64 65 (if time-exceede
4280: 64 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 62 d...... (b
4290: 65 67 69 6e 0a 09 09 09 09 09 09 20 28 64 65 62 egin....... (deb
42a0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
42b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
42c0: 74 2a 20 22 4b 49 4c 4c 49 4e 47 20 54 45 53 54 t* "KILLING TEST
42d0: 20 44 55 45 20 54 4f 20 54 49 4d 45 20 4c 49 4d DUE TO TIME LIM
42e0: 49 54 20 45 58 43 45 45 44 45 44 21 20 52 75 6e IT EXCEEDED! Run
42f0: 74 69 6d 65 3d 22 20 72 75 6e 2d 73 65 63 6f 6e time=" run-secon
4300: 64 73 20 22 20 73 65 63 6f 6e 64 73 2c 20 6c 69 ds " seconds, li
4310: 6d 69 74 3d 22 20 72 75 6e 74 6c 69 6d 29 0a 09 mit=" runtlim)..
4320: 09 09 09 09 09 20 23 74 29 0a 09 09 09 09 09 20 ..... #t)......
4330: 20 20 20 20 20 20 23 66 29 29 29 29 29 0a 09 28 #f)))))..(
4340: 74 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 6e tests:update-cen
4350: 74 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 tral-meta-info r
4360: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 un-id test-id ne
4370: 77 2d 63 70 75 2d 6c 6f 61 64 20 6e 65 77 2d 64 w-cpu-load new-d
4380: 69 73 6b 2d 66 72 65 65 20 28 63 61 6c 63 2d 6d isk-free (calc-m
4390: 69 6e 75 74 65 73 29 20 23 66 20 23 66 29 0a 09 inutes) #f #f)..
43a0: 28 69 66 20 6b 69 6c 6c 2d 6a 6f 62 3f 20 0a 09 (if kill-job? ..
43b0: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
43c0: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d (mutex-lock! m
43d0: 29 0a 09 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 ).. ;; NOTE
43e0: 3a 20 54 68 65 20 70 69 64 20 63 61 6e 20 63 68 : The pid can ch
43f0: 61 6e 67 65 20 61 73 20 64 69 66 66 65 72 65 6e ange as differen
4400: 74 20 73 74 65 70 73 20 61 72 65 20 72 75 6e 2e t steps are run.
4410: 20 44 6f 20 77 65 20 6e 65 65 64 20 68 61 6e 64 Do we need hand
4420: 73 68 61 6b 69 6e 67 20 62 65 74 77 65 65 6e 20 shaking between
4430: 74 68 69 73 0a 09 20 20 20 20 20 20 3b 3b 20 20 this.. ;;
4440: 20 20 20 20 20 73 65 63 74 69 6f 6e 20 61 6e 64 section and
4450: 20 74 68 65 20 72 75 6e 69 74 20 73 65 63 74 69 the runit secti
4460: 6f 6e 3f 20 4f 72 20 61 64 64 20 61 20 6c 6f 6f on? Or add a loo
4470: 70 20 74 68 61 74 20 74 72 69 65 73 20 74 68 72 p that tries thr
4480: 65 65 20 74 69 6d 65 73 20 77 69 74 68 20 61 20 ee times with a
4490: 31 2f 34 20 73 65 63 6f 6e 64 0a 09 20 20 20 20 1/4 second..
44a0: 20 20 3b 3b 20 20 20 20 20 20 20 62 65 74 77 65 ;; betwe
44b0: 65 6e 20 74 72 69 65 73 3f 0a 09 20 20 20 20 20 en tries?..
44c0: 20 28 6c 65 74 2a 20 28 28 70 69 64 31 20 28 6c (let* ((pid1 (l
44d0: 61 75 6e 63 68 3a 65 69 6e 66 2d 70 69 64 20 65 aunch:einf-pid e
44e0: 78 69 74 2d 69 6e 66 6f 29 29 20 3b 3b 20 28 76 xit-info)) ;; (v
44f0: 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 ector-ref exit-i
4500: 6e 66 6f 20 30 29 29 0a 09 09 20 20 20 20 20 28 nfo 0))... (
4510: 70 69 64 32 20 28 72 6d 74 3a 74 65 73 74 2d 67 pid2 (rmt:test-g
4520: 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 73 2d 70 et-top-process-p
4530: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 id run-id test-i
4540: 64 29 29 0a 09 09 20 20 20 20 20 28 70 69 64 73 d))... (pids
4550: 20 28 64 65 6c 65 74 65 2d 64 75 70 6c 69 63 61 (delete-duplica
4560: 74 65 73 20 28 66 69 6c 74 65 72 20 6e 75 6d 62 tes (filter numb
4570: 65 72 3f 20 28 6c 69 73 74 20 70 69 64 31 20 70 er? (list pid1 p
4580: 69 64 32 29 29 29 29 29 0a 09 09 28 69 66 20 28 id2)))))...(if (
4590: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 70 69 64 73 29 not (null? pids)
45a0: 29 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 )... (begin..
45b0: 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
45c0: 0a 09 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 ... (lambd
45d0: 61 20 28 70 69 64 29 0a 09 09 09 20 28 68 61 6e a (pid).... (han
45e0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
45f0: 09 09 20 20 65 78 6e 0a 09 09 09 20 20 28 62 65 .. exn.... (be
4600: 67 69 6e 0a 09 09 09 20 20 20 20 28 64 65 62 75 gin.... (debu
4610: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
4620: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4630: 2a 20 22 55 6e 61 62 6c 65 20 74 6f 20 6b 69 6c * "Unable to kil
4640: 6c 20 70 72 6f 63 65 73 73 20 77 69 74 68 20 70 l process with p
4650: 69 64 20 22 20 70 69 64 20 22 2c 20 70 6f 73 73 id " pid ", poss
4660: 69 62 6c 79 20 61 6c 72 65 61 64 79 20 6b 69 6c ibly already kil
4670: 6c 65 64 2e 22 29 0a 09 09 09 20 20 20 20 28 64 led.").... (d
4680: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
4690: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
46a0: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 " message: " ((c
46b0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
46c0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
46d0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 'message) exn)))
46e0: 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 .... (debug:pri
46f0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
4700: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
4710: 3a 20 52 65 71 75 65 73 74 20 72 65 63 65 69 76 : Request receiv
4720: 65 64 20 74 6f 20 6b 69 6c 6c 20 6a 6f 62 20 22 ed to kill job "
4730: 20 70 69 64 29 20 3b 3b 20 20 22 20 28 61 74 74 pid) ;; " (att
4740: 65 6d 70 74 20 23 20 22 20 6b 69 6c 6c 2d 74 72 empt # " kill-tr
4750: 69 65 73 20 22 29 22 29 0a 09 09 09 20 20 28 64 ies ")").... (d
4760: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
4770: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
4780: 6f 72 74 2a 20 22 53 69 67 6e 61 6c 20 6d 61 73 ort* "Signal mas
4790: 6b 3d 22 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b k=" (signal-mask
47a0: 29 29 0a 09 09 09 20 20 3b 3b 20 28 69 66 20 28 )).... ;; (if (
47b0: 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 3f 20 70 process:alive? p
47c0: 69 64 29 0a 09 09 09 20 20 3b 3b 20 20 20 20 20 id).... ;;
47d0: 28 62 65 67 69 6e 0a 09 09 09 20 20 28 6d 61 70 (begin.... (map
47e0: 20 28 6c 61 6d 62 64 61 20 28 70 69 64 2d 6e 75 (lambda (pid-nu
47f0: 6d 29 0a 09 09 09 09 20 28 70 72 6f 63 65 73 73 m)..... (process
4800: 2d 73 69 67 6e 61 6c 20 70 69 64 2d 6e 75 6d 20 -signal pid-num
4810: 73 69 67 6e 61 6c 2f 74 65 72 6d 29 29 0a 09 09 signal/term))...
4820: 09 20 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 . (process
4830: 3a 67 65 74 2d 73 75 62 2d 70 69 64 73 20 70 69 :get-sub-pids pi
4840: 64 29 29 0a 09 09 09 20 20 28 74 68 72 65 61 64 d)).... (thread
4850: 2d 73 6c 65 65 70 21 20 35 29 0a 09 09 09 20 20 -sleep! 5)....
4860: 3b 3b 20 28 69 66 20 28 70 72 6f 63 65 73 73 3a ;; (if (process:
4870: 70 72 6f 63 65 73 73 2d 61 6c 69 76 65 3f 20 70 process-alive? p
4880: 69 64 29 0a 09 09 09 20 20 28 6d 61 70 20 28 6c id).... (map (l
4890: 61 6d 62 64 61 20 28 70 69 64 2d 6e 75 6d 29 0a ambda (pid-num).
48a0: 09 09 09 09 20 28 68 61 6e 64 6c 65 2d 65 78 63 .... (handle-exc
48b0: 65 70 74 69 6f 6e 73 0a 09 09 09 09 20 20 65 78 eptions..... ex
48c0: 6e 0a 09 09 09 09 20 20 23 66 0a 09 09 09 09 20 n..... #f.....
48d0: 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c (process-signal
48e0: 20 70 69 64 2d 6e 75 6d 20 73 69 67 6e 61 6c 2f pid-num signal/
48f0: 6b 69 6c 6c 29 29 29 0a 09 09 09 20 20 20 20 20 kill)))....
4900: 20 20 28 70 72 6f 63 65 73 73 3a 67 65 74 2d 73 (process:get-s
4910: 75 62 2d 70 69 64 73 20 70 69 64 29 29 29 29 0a ub-pids pid)))).
4920: 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 .. ;; (
4930: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
4940: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
4950: 70 6f 72 74 2a 20 22 6e 6f 74 20 6b 69 6c 6c 69 port* "not killi
4960: 6e 67 20 70 72 6f 63 65 73 73 20 22 20 70 69 64 ng process " pid
4970: 20 22 20 61 73 20 69 74 20 69 73 20 6e 6f 74 20 " as it is not
4980: 61 6c 69 76 65 22 29 29 29 29 0a 09 09 20 20 20 alive"))))...
4990: 20 20 20 20 70 69 64 73 29 0a 09 09 20 20 20 20 pids)...
49a0: 20 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 (tests:test-se
49b0: 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 t-status! run-id
49c0: 20 74 65 73 74 2d 69 64 20 22 4b 49 4c 4c 45 44 test-id "KILLED
49d0: 22 20 20 22 4b 49 4c 4c 45 44 22 20 28 61 72 67 " "KILLED" (arg
49e0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 s:get-arg "-m")
49f0: 23 66 29 29 0a 09 09 20 20 20 20 28 62 65 67 69 #f))... (begi
4a00: 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 n... (debug
4a10: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
4a20: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4a30: 2a 20 22 4e 6f 74 68 69 6e 67 20 74 6f 20 6b 69 * "Nothing to ki
4a40: 6c 6c 2c 20 70 69 64 31 3d 22 20 70 69 64 31 20 ll, pid1=" pid1
4a50: 22 2c 20 70 69 64 32 3d 22 20 70 69 64 32 29 0a ", pid2=" pid2).
4a60: 09 09 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 .. (tests:t
4a70: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
4a80: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 run-id test-id "
4a90: 4b 49 4c 4c 45 44 22 20 20 22 46 41 49 4c 45 44 KILLED" "FAILED
4aa0: 20 54 4f 20 4b 49 4c 4c 22 20 28 61 72 67 73 3a TO KILL" (args:
4ab0: 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 23 66 get-arg "-m") #f
4ac0: 29 0a 09 09 20 20 20 20 20 20 29 29 29 0a 09 20 )... )))..
4ad0: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
4ae0: 63 6b 21 20 6d 29 0a 09 20 20 20 20 20 20 3b 3b ck! m).. ;;
4af0: 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 73 74 69 no point in sti
4b00: 63 6b 69 6e 67 20 61 72 6f 75 6e 64 2e 20 45 78 cking around. Ex
4b10: 69 74 20 6e 6f 77 2e 0a 09 20 20 20 20 20 20 28 it now... (
4b20: 65 78 69 74 29 29 29 0a 09 28 69 66 20 28 68 61 exit)))..(if (ha
4b30: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
4b40: 61 75 6c 74 20 6d 69 73 63 2d 66 6c 61 67 73 20 ault misc-flags
4b50: 27 6b 65 65 70 2d 67 6f 69 6e 67 20 23 66 29 0a 'keep-going #f).
4b60: 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 . (begin..
4b70: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
4b80: 21 20 33 29 20 3b 3b 20 28 2b 20 33 20 28 72 61 ! 3) ;; (+ 3 (ra
4b90: 6e 64 6f 6d 20 36 29 29 29 20 3b 3b 20 61 64 64 ndom 6))) ;; add
4ba0: 20 73 6f 6d 65 20 6a 69 74 74 65 72 20 74 6f 20 some jitter to
4bb0: 74 68 65 20 63 61 6c 6c 20 68 6f 6d 65 20 74 69 the call home ti
4bc0: 6d 65 20 74 6f 20 73 70 72 65 61 64 20 6f 75 74 me to spread out
4bd0: 20 74 68 65 20 64 62 20 61 63 63 65 73 73 65 73 the db accesses
4be0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 68 61 73 .. (if (has
4bf0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4c00: 75 6c 74 20 6d 69 73 63 2d 66 6c 61 67 73 20 27 ult misc-flags '
4c10: 6b 65 65 70 2d 67 6f 69 6e 67 20 23 66 29 20 20 keep-going #f)
4c20: 3b 3b 20 6b 65 65 70 20 6f 72 69 67 69 6e 61 6c ;; keep original
4c30: 73 20 66 6f 72 20 63 70 75 2d 6c 6f 61 64 20 61 s for cpu-load a
4c40: 6e 64 20 64 69 73 6b 2d 66 72 65 65 20 75 6e 6c nd disk-free unl
4c50: 65 73 73 20 74 68 65 79 20 63 68 61 6e 67 65 20 ess they change
4c60: 6d 6f 72 65 20 74 68 61 6e 20 74 68 65 20 61 6c more than the al
4c70: 6c 6f 77 65 64 20 64 65 6c 74 61 0a 09 09 20 20 lowed delta...
4c80: 28 6c 6f 6f 70 20 28 63 61 6c 63 2d 6d 69 6e 75 (loop (calc-minu
4c90: 74 65 73 29 20 28 6f 72 20 6e 65 77 2d 63 70 75 tes) (or new-cpu
4ca0: 2d 6c 6f 61 64 20 63 70 75 2d 6c 6f 61 64 29 20 -load cpu-load)
4cb0: 28 6f 72 20 6e 65 77 2d 64 69 73 6b 2d 66 72 65 (or new-disk-fre
4cc0: 65 20 64 69 73 6b 2d 66 72 65 65 29 29 29 29 29 e disk-free)))))
4cd0: 29 29 0a 20 20 20 20 28 74 65 73 74 73 3a 75 70 )). (tests:up
4ce0: 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 date-central-met
4cf0: 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 a-info run-id te
4d00: 73 74 2d 69 64 20 28 67 65 74 2d 63 70 75 2d 6c st-id (get-cpu-l
4d10: 6f 61 64 29 20 28 67 65 74 2d 64 66 20 28 63 75 oad) (get-df (cu
4d20: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
4d30: 29 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 20 )(calc-minutes)
4d40: 23 66 20 23 66 29 29 29 20 3b 3b 20 4e 4f 54 45 #f #f))) ;; NOTE
4d50: 3a 20 43 68 65 63 6b 69 6e 67 20 74 77 69 63 65 : Checking twice
4d60: 20 66 6f 72 20 6b 65 65 70 2d 67 6f 69 6e 67 20 for keep-going
4d70: 69 73 20 69 6e 74 65 6e 74 69 6f 6e 61 6c 0a 0a is intentional..
4d80: 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 .(define (launch
4d90: 3a 65 78 65 63 75 74 65 20 65 6e 63 6f 64 65 64 :execute encoded
4da0: 2d 63 6d 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 -cmd). (let* ((
4db0: 63 6d 64 69 6e 66 6f 20 20 20 20 28 63 6f 6d 6d cmdinfo (comm
4dc0: 6f 6e 3a 72 65 61 64 2d 65 6e 63 6f 64 65 64 2d on:read-encoded-
4dd0: 73 74 72 69 6e 67 20 65 6e 63 6f 64 65 64 2d 63 string encoded-c
4de0: 6d 64 29 29 0a 09 20 28 74 63 6f 6e 66 69 67 72 md)).. (tconfigr
4df0: 65 67 20 23 66 29 29 0a 20 20 20 20 28 73 65 74 eg #f)). (set
4e00: 65 6e 76 20 22 4d 54 5f 43 4d 44 49 4e 46 4f 22 env "MT_CMDINFO"
4e10: 20 65 6e 63 6f 64 65 64 2d 63 6d 64 29 0a 20 20 encoded-cmd).
4e20: 20 20 3b 3b 28 62 62 2d 63 68 65 63 6b 2d 70 61 ;;(bb-check-pa
4e30: 74 68 20 6d 73 67 3a 20 22 6c 61 75 6e 63 68 3a th msg: "launch:
4e40: 65 78 65 63 75 74 65 20 69 6e 63 6f 6d 69 6e 67 execute incoming
4e50: 22 29 0a 20 20 20 20 28 69 66 20 28 6c 69 73 74 "). (if (list
4e60: 3f 20 63 6d 64 69 6e 66 6f 29 20 3b 3b 20 28 28 ? cmdinfo) ;; ((
4e70: 74 65 73 74 70 61 74 68 20 2f 74 6d 70 2f 6d 72 testpath /tmp/mr
4e80: 77 65 6c 6c 61 6e 2f 6a 61 7a 7a 6d 69 6e 64 2f wellan/jazzmind/
4e90: 73 72 63 2f 65 78 61 6d 70 6c 65 5f 72 75 6e 2f src/example_run/
4ea0: 74 65 73 74 73 2f 73 71 6c 69 74 65 73 70 65 65 tests/sqlitespee
4eb0: 64 29 0a 09 3b 3b 20 28 74 65 73 74 2d 6e 61 6d d)..;; (test-nam
4ec0: 65 20 73 71 6c 69 74 65 73 70 65 65 64 29 20 28 e sqlitespeed) (
4ed0: 72 75 6e 73 63 72 69 70 74 20 72 75 6e 73 63 72 runscript runscr
4ee0: 69 70 74 2e 72 62 29 20 28 64 62 2d 68 6f 73 74 ipt.rb) (db-host
4ef0: 20 6c 6f 63 61 6c 68 6f 73 74 29 20 28 72 75 6e localhost) (run
4f00: 2d 69 64 20 31 29 29 0a 09 28 6c 65 74 2a 20 28 -id 1))..(let* (
4f10: 28 74 65 73 74 70 61 74 68 20 20 28 61 73 73 6f (testpath (asso
4f20: 63 2f 64 65 66 61 75 6c 74 20 27 74 65 73 74 70 c/default 'testp
4f30: 61 74 68 20 20 63 6d 64 69 6e 66 6f 29 29 20 20 ath cmdinfo))
4f40: 3b 3b 20 74 65 73 74 70 61 74 68 20 69 73 20 74 ;; testpath is t
4f50: 68 65 20 74 65 73 74 20 73 70 65 63 20 61 72 65 he test spec are
4f60: 61 0a 09 20 20 20 20 20 20 20 28 74 6f 70 2d 70 a.. (top-p
4f70: 61 74 68 20 20 28 61 73 73 6f 63 2f 64 65 66 61 ath (assoc/defa
4f80: 75 6c 74 20 27 74 6f 70 70 61 74 68 20 20 20 63 ult 'toppath c
4f90: 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 mdinfo))..
4fa0: 20 28 77 6f 72 6b 2d 61 72 65 61 20 28 61 73 73 (work-area (ass
4fb0: 6f 63 2f 64 65 66 61 75 6c 74 20 27 77 6f 72 6b oc/default 'work
4fc0: 2d 61 72 65 61 20 63 6d 64 69 6e 66 6f 29 29 20 -area cmdinfo))
4fd0: 20 3b 3b 20 77 6f 72 6b 2d 61 72 65 61 20 69 73 ;; work-area is
4fe0: 20 74 68 65 20 74 65 73 74 20 72 75 6e 20 61 72 the test run ar
4ff0: 65 61 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 ea.. (test
5000: 2d 6e 61 6d 65 20 28 61 73 73 6f 63 2f 64 65 66 -name (assoc/def
5010: 61 75 6c 74 20 27 74 65 73 74 2d 6e 61 6d 65 20 ault 'test-name
5020: 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 cmdinfo))..
5030: 20 20 28 72 75 6e 73 63 72 69 70 74 20 28 61 73 (runscript (as
5040: 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 6e soc/default 'run
5050: 73 63 72 69 70 74 20 63 6d 64 69 6e 66 6f 29 29 script cmdinfo))
5060: 0a 09 20 20 20 20 20 20 20 28 65 7a 73 74 65 70 .. (ezstep
5070: 73 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 s (assoc/defau
5080: 6c 74 20 27 65 7a 73 74 65 70 73 20 20 20 63 6d lt 'ezsteps cm
5090: 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 dinfo))..
50a0: 3b 3b 20 28 72 75 6e 72 65 6d 6f 74 65 20 28 61 ;; (runremote (a
50b0: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 ssoc/default 'ru
50c0: 6e 72 65 6d 6f 74 65 20 63 6d 64 69 6e 66 6f 29 nremote cmdinfo)
50d0: 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 28 74 72 ).. ;; (tr
50e0: 61 6e 73 70 6f 72 74 20 28 61 73 73 6f 63 2f 64 ansport (assoc/d
50f0: 65 66 61 75 6c 74 20 27 74 72 61 6e 73 70 6f 72 efault 'transpor
5100: 74 20 63 6d 64 69 6e 66 6f 29 29 20 20 3b 3b 20 t cmdinfo)) ;;
5110: 6e 6f 74 20 75 73 65 64 0a 09 20 20 20 20 20 20 not used..
5120: 20 3b 3b 20 28 73 65 72 76 65 72 69 6e 66 20 28 ;; (serverinf (
5130: 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 73 assoc/default 's
5140: 65 72 76 65 72 69 6e 66 20 63 6d 64 69 6e 66 6f erverinf cmdinfo
5150: 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 28 70 )).. ;; (p
5160: 6f 72 74 20 20 20 20 20 20 28 61 73 73 6f 63 2f ort (assoc/
5170: 64 65 66 61 75 6c 74 20 27 70 6f 72 74 20 20 20 default 'port
5180: 20 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 cmdinfo))..
5190: 20 20 20 20 20 28 73 65 72 76 65 72 75 72 6c 20 (serverurl
51a0: 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 (assoc/default '
51b0: 73 65 72 76 65 72 75 72 6c 20 63 6d 64 69 6e 66 serverurl cmdinf
51c0: 6f 29 29 0a 09 20 20 20 20 20 20 20 28 68 6f 6d o)).. (hom
51d0: 65 68 6f 73 74 20 20 28 61 73 73 6f 63 2f 64 65 ehost (assoc/de
51e0: 66 61 75 6c 74 20 27 68 6f 6d 65 68 6f 73 74 20 fault 'homehost
51f0: 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 cmdinfo))..
5200: 20 20 20 28 72 75 6e 2d 69 64 20 20 20 20 28 61 (run-id (a
5210: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 ssoc/default 'ru
5220: 6e 2d 69 64 20 20 20 20 63 6d 64 69 6e 66 6f 29 n-id cmdinfo)
5230: 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d ).. (test-
5240: 69 64 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 id (assoc/defa
5250: 75 6c 74 20 27 74 65 73 74 2d 69 64 20 20 20 63 ult 'test-id c
5260: 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 mdinfo))..
5270: 20 28 74 61 72 67 65 74 20 20 20 20 28 61 73 73 (target (ass
5280: 6f 63 2f 64 65 66 61 75 6c 74 20 27 74 61 72 67 oc/default 'targ
5290: 65 74 20 20 20 20 63 6d 64 69 6e 66 6f 29 29 0a et cmdinfo)).
52a0: 09 20 20 20 20 20 20 20 28 61 72 65 61 6e 61 6d . (areanam
52b0: 65 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c e (assoc/defaul
52c0: 74 20 27 61 72 65 61 6e 61 6d 65 20 20 63 6d 64 t 'areaname cmd
52d0: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 info)).. (
52e0: 69 74 65 6d 64 61 74 20 20 20 28 61 73 73 6f 63 itemdat (assoc
52f0: 2f 64 65 66 61 75 6c 74 20 27 69 74 65 6d 64 61 /default 'itemda
5300: 74 20 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 t cmdinfo))..
5310: 20 20 20 20 20 20 28 65 6e 76 2d 6f 76 72 64 20 (env-ovrd
5320: 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 (assoc/default
5330: 27 65 6e 76 2d 6f 76 72 64 20 20 63 6d 64 69 6e 'env-ovrd cmdin
5340: 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 fo)).. (se
5350: 74 2d 76 61 72 73 20 20 28 61 73 73 6f 63 2f 64 t-vars (assoc/d
5360: 65 66 61 75 6c 74 20 27 73 65 74 2d 76 61 72 73 efault 'set-vars
5370: 20 20 63 6d 64 69 6e 66 6f 29 29 20 3b 3b 20 70 cmdinfo)) ;; p
5380: 72 65 2d 6f 76 65 72 72 69 64 65 73 20 66 72 6f re-overrides fro
5390: 6d 20 2d 73 65 74 76 61 72 0a 09 20 20 20 20 20 m -setvar..
53a0: 20 20 28 72 75 6e 6e 61 6d 65 20 20 20 28 61 73 (runname (as
53b0: 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 6e soc/default 'run
53c0: 6e 61 6d 65 20 20 20 63 6d 64 69 6e 66 6f 29 29 name cmdinfo))
53d0: 0a 09 20 20 20 20 20 20 20 28 6d 65 67 61 74 65 .. (megate
53e0: 73 74 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 st (assoc/defau
53f0: 6c 74 20 27 6d 65 67 61 74 65 73 74 20 20 63 6d lt 'megatest cm
5400: 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 dinfo))..
5410: 28 72 75 6e 74 6c 69 6d 20 20 20 28 61 73 73 6f (runtlim (asso
5420: 63 2f 64 65 66 61 75 6c 74 20 27 72 75 6e 74 6c c/default 'runtl
5430: 69 6d 20 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 im cmdinfo))..
5440: 20 20 20 20 20 20 20 28 63 6f 6e 74 6f 75 72 20 (contour
5450: 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 (assoc/default
5460: 20 27 63 6f 6e 74 6f 75 72 20 20 20 63 6d 64 69 'contour cmdi
5470: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 69 nfo)).. (i
5480: 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c tem-path (item-l
5490: 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 ist->path itemda
54a0: 74 29 29 0a 09 20 20 20 20 20 20 20 28 6d 74 2d t)).. (mt-
54b0: 62 69 6e 64 69 72 2d 70 61 74 68 20 28 61 73 73 bindir-path (ass
54c0: 6f 63 2f 64 65 66 61 75 6c 74 20 27 6d 74 2d 62 oc/default 'mt-b
54d0: 69 6e 64 69 72 2d 70 61 74 68 20 63 6d 64 69 6e indir-path cmdin
54e0: 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 6b 65 fo)).. (ke
54f0: 79 73 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 ys #f)..
5500: 20 20 20 20 28 6b 65 79 76 61 6c 73 20 20 20 23 (keyvals #
5510: 66 29 0a 09 20 20 20 20 20 20 20 28 66 75 6c 6c f).. (full
5520: 72 75 6e 73 63 72 69 70 74 20 28 69 66 20 28 6e runscript (if (n
5530: 6f 74 20 72 75 6e 73 63 72 69 70 74 29 0a 20 20 ot runscript).
5540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5560: 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 #f.
5570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5580: 20 20 20 20 20 28 69 66 20 28 73 75 62 73 74 72 (if (substr
5590: 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 72 75 ing-index "/" ru
55a0: 6e 73 63 72 69 70 74 29 0a 20 20 20 20 20 20 20 nscript).
55b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 r
55d0: 75 6e 73 63 72 69 70 74 20 3b 3b 20 75 73 65 20 unscript ;; use
55e0: 75 6e 61 64 75 6c 74 65 72 65 64 20 69 66 20 63 unadultered if c
55f0: 6f 6e 74 61 69 6e 73 20 73 6c 61 73 68 65 73 0a ontains slashes.
5600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5620: 20 20 20 20 20 20 28 6c 65 74 20 28 28 66 75 6c (let ((ful
5630: 6c 6e 20 28 63 6f 6e 63 20 74 65 73 74 70 61 74 ln (conc testpat
5640: 68 20 22 2f 22 20 72 75 6e 73 63 72 69 70 74 29 h "/" runscript)
5650: 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 20 20 ))..
5660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5670: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 (if (and (
5680: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c file-exists? ful
5690: 6c 6e 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ln).
56a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
56c0: 20 20 20 20 20 20 20 28 66 69 6c 65 2d 65 78 65 (file-exe
56d0: 63 75 74 65 2d 61 63 63 65 73 73 3f 20 66 75 6c cute-access? ful
56e0: 6c 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ln)).
56f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5710: 20 20 20 66 75 6c 6c 6e 0a 20 20 20 20 20 20 20 fulln.
5720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5740: 20 20 20 20 20 20 20 72 75 6e 73 63 72 69 70 74 runscript
5750: 29 29 29 29 29 20 3b 3b 20 61 73 73 75 6d 65 20 ))))) ;; assume
5760: 69 74 20 69 73 20 6f 6e 20 74 68 65 20 70 61 74 it is on the pat
5770: 68 0a 09 20 20 20 20 20 20 20 29 20 3b 3b 20 28 h.. ) ;; (
5780: 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 30 29 rollup-status 0)
5790: 0a 0a 09 20 20 28 69 66 20 63 6f 6e 74 6f 75 72 ... (if contour
57a0: 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 43 4f 4e (setenv "MT_CON
57b0: 54 4f 55 52 22 20 63 6f 6e 74 6f 75 72 29 29 0a TOUR" contour)).
57c0: 09 20 20 0a 09 20 20 3b 3b 20 69 6d 6d 65 64 69 . .. ;; immedi
57d0: 61 74 65 64 20 73 65 74 20 73 6f 6d 65 20 6b 65 ated set some ke
57e0: 79 20 76 61 72 69 61 62 6c 65 73 20 66 72 6f 6d y variables from
57f0: 20 43 4d 44 49 4e 46 4f 20 64 61 74 61 2c 20 79 CMDINFO data, y
5800: 65 73 2c 20 74 68 65 73 65 20 77 69 6c 6c 20 62 es, these will b
5810: 65 20 73 65 74 20 61 67 61 69 6e 20 62 65 6c 6f e set again belo
5820: 77 20 2e 2e 2e 0a 09 20 20 3b 3b 0a 09 20 20 28 w ..... ;;.. (
5830: 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 53 setenv "MT_TESTS
5840: 55 49 54 45 4e 41 4d 45 22 20 61 72 65 61 6e 61 UITENAME" areana
5850: 6d 65 29 0a 09 20 20 28 73 65 74 65 6e 76 20 22 me).. (setenv "
5860: 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 MT_RUN_AREA_HOME
5870: 22 20 74 6f 70 2d 70 61 74 68 29 0a 09 20 20 28 " top-path).. (
5880: 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 74 set! *toppath* t
5890: 6f 70 2d 70 61 74 68 29 0a 09 20 20 28 73 65 74 op-path).. (set
58a0: 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 52 55 4e env "MT_TEST_RUN
58b0: 5f 44 49 52 22 20 20 77 6f 72 6b 2d 61 72 65 61 _DIR" work-area
58c0: 29 0a 0a 09 20 20 3b 3b 20 4f 6e 20 4e 46 53 20 )... ;; On NFS
58d0: 69 74 20 63 61 6e 20 62 65 20 73 6c 6f 77 20 61 it can be slow a
58e0: 6e 64 20 75 6e 72 65 6c 69 61 62 6c 65 20 74 6f nd unreliable to
58f0: 20 67 65 74 20 6e 65 65 64 65 64 20 73 74 61 72 get needed star
5900: 74 75 70 20 69 6e 66 6f 72 6d 61 74 69 6f 6e 2e tup information.
5910: 0a 09 20 20 3b 3b 20 20 69 2e 20 43 68 65 63 6b .. ;; i. Check
5920: 20 69 66 20 77 65 20 61 72 65 20 6f 6e 20 74 68 if we are on th
5930: 65 20 68 6f 6d 65 68 6f 73 74 2c 20 69 66 20 73 e homehost, if s
5940: 6f 2c 20 70 72 6f 63 65 65 64 0a 09 20 20 3b 3b o, proceed.. ;;
5950: 20 69 69 2e 20 43 68 65 63 6b 20 69 66 20 68 6f ii. Check if ho
5960: 73 74 20 61 6e 64 20 70 6f 72 74 20 70 61 73 73 st and port pass
5970: 65 64 20 69 6e 20 76 69 61 20 43 4d 44 49 4e 46 ed in via CMDINF
5980: 4f 20 61 72 65 20 76 61 6c 69 64 20 61 6e 64 20 O are valid and
5990: 69 66 0a 09 20 20 3b 3b 20 20 20 20 20 70 6f 73 if.. ;; pos
59a0: 73 69 62 6c 65 20 75 73 65 20 74 68 65 6d 2e 0a sible use them..
59b0: 09 20 20 28 6c 65 74 20 28 28 62 65 73 74 61 64 . (let ((bestad
59c0: 72 73 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 rs (server:get-b
59d0: 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 est-guess-addres
59e0: 73 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 s (get-host-name
59f0: 29 29 29 0a 09 09 28 6e 65 65 64 63 61 72 65 20 )))...(needcare
5a00: 23 66 29 29 0a 09 20 20 20 20 28 69 66 20 28 65 #f)).. (if (e
5a10: 71 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 62 qual? homehost b
5a20: 65 73 74 61 64 72 73 29 20 3b 3b 20 77 65 20 61 estadrs) ;; we a
5a30: 72 65 20 6c 69 6b 65 6c 79 20 6f 6e 20 74 68 65 re likely on the
5a40: 20 68 6f 6d 65 68 6f 73 74 0a 09 09 28 64 65 62 homehost...(deb
5a50: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
5a60: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5a70: 74 2a 20 22 74 65 73 74 20 22 20 74 65 73 74 2d t* "test " test-
5a80: 6e 61 6d 65 20 22 20 61 70 70 65 61 72 73 20 74 name " appears t
5a90: 6f 20 62 65 20 72 75 6e 6e 69 6e 67 20 6f 6e 20 o be running on
5aa0: 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 22 20 68 the homehost " h
5ab0: 6f 6d 65 68 6f 73 74 29 0a 09 09 28 6c 65 74 20 omehost)...(let
5ac0: 28 28 68 6f 73 74 2d 70 6f 72 74 20 28 69 66 20 ((host-port (if
5ad0: 73 65 72 76 65 72 75 72 6c 20 28 73 74 72 69 6e serverurl (strin
5ae0: 67 2d 73 70 6c 69 74 20 73 65 72 76 65 72 75 72 g-split serverur
5af0: 6c 20 22 3a 22 29 20 23 66 29 29 29 0a 09 09 20 l ":") #f)))...
5b00: 20 28 69 66 20 28 6e 6f 74 20 2a 72 75 6e 72 65 (if (not *runre
5b10: 6d 6f 74 65 2a 29 28 73 65 74 21 20 2a 72 75 6e mote*)(set! *run
5b20: 72 65 6d 6f 74 65 2a 20 28 6d 61 6b 65 2d 72 65 remote* (make-re
5b30: 6d 6f 74 65 29 29 29 20 3b 3b 20 69 6e 69 74 20 mote))) ;; init
5b40: 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 09 09 20 20 *runremote*...
5b50: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 68 6f 6d (if (string? hom
5b60: 65 68 6f 73 74 29 0a 09 09 20 20 20 20 20 20 28 ehost)... (
5b70: 69 66 20 28 61 6e 64 20 68 6f 73 74 2d 70 6f 72 if (and host-por
5b80: 74 0a 09 09 09 20 20 20 20 20 20 20 28 3e 20 28 t.... (> (
5b90: 6c 65 6e 67 74 68 20 68 6f 73 74 2d 70 6f 72 74 length host-port
5ba0: 29 20 31 29 29 0a 09 09 09 20 20 28 6c 65 74 2a ) 1)).... (let*
5bb0: 20 28 28 68 6f 73 74 20 20 20 20 20 20 28 63 61 ((host (ca
5bc0: 72 20 68 6f 73 74 2d 70 6f 72 74 29 29 0a 20 20 r host-port)).
5bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5bf0: 70 6f 72 74 20 20 20 20 20 20 28 63 61 64 72 20 port (cadr
5c00: 68 6f 73 74 2d 70 6f 72 74 29 29 0a 20 20 20 20 host-port)).
5c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
5c30: 61 72 74 2d 72 65 73 20 28 68 74 74 70 2d 74 72 art-res (http-tr
5c40: 61 6e 73 70 6f 72 74 3a 63 6c 69 65 6e 74 2d 63 ansport:client-c
5c50: 6f 6e 6e 65 63 74 20 68 6f 73 74 20 70 6f 72 74 onnect host port
5c60: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c80: 20 20 20 20 28 70 69 6e 67 2d 72 65 73 20 20 28 (ping-res (
5c90: 72 6d 74 3a 6c 6f 67 69 6e 2d 6e 6f 2d 61 75 74 rmt:login-no-aut
5ca0: 6f 2d 63 6c 69 65 6e 74 2d 73 65 74 75 70 20 73 o-client-setup s
5cb0: 74 61 72 74 2d 72 65 73 29 29 29 0a 09 09 09 20 tart-res)))....
5cc0: 20 20 20 28 69 66 20 28 61 6e 64 20 73 74 61 72 (if (and star
5cd0: 74 2d 72 65 73 0a 09 09 09 09 20 20 20 20 20 70 t-res..... p
5ce0: 69 6e 67 2d 72 65 73 29 0a 09 09 09 09 3b 3b 20 ing-res).....;;
5cf0: 28 62 65 67 69 6e 20 3b 3b 20 6c 65 74 20 28 28 (begin ;; let ((
5d00: 75 72 6c 20 20 28 68 74 74 70 2d 74 72 61 6e 73 url (http-trans
5d10: 70 6f 72 74 3a 73 65 72 76 65 72 2d 64 61 74 2d port:server-dat-
5d20: 6d 61 6b 65 2d 75 72 6c 20 73 74 61 72 74 2d 72 make-url start-r
5d30: 65 73 29 29 29 0a 09 09 09 09 28 62 65 67 69 6e es))).....(begin
5d40: 0a 09 09 09 09 20 20 28 72 65 6d 6f 74 65 2d 63 ..... (remote-c
5d50: 6f 6e 6e 64 61 74 2d 73 65 74 21 20 2a 72 75 6e onndat-set! *run
5d60: 72 65 6d 6f 74 65 2a 20 73 74 61 72 74 2d 72 65 remote* start-re
5d70: 73 29 0a 09 09 09 09 20 20 3b 3b 20 28 72 65 6d s)..... ;; (rem
5d80: 6f 74 65 2d 73 65 72 76 65 72 2d 75 72 6c 2d 73 ote-server-url-s
5d90: 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 et! *runremote*
5da0: 75 72 6c 29 0a 09 09 09 09 20 20 3b 3b 20 28 69 url)..... ;; (i
5db0: 66 20 28 73 65 72 76 65 72 3a 70 69 6e 67 20 75 f (server:ping u
5dc0: 72 6c 29 0a 09 09 09 09 20 20 28 64 65 62 75 67 rl)..... (debug
5dd0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
5de0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5df0: 20 22 63 6f 6e 6e 65 63 74 65 64 20 74 6f 20 22 "connected to "
5e00: 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 20 22 host ":" port "
5e10: 20 75 73 69 6e 67 20 43 4d 44 49 4e 46 4f 20 64 using CMDINFO d
5e20: 61 74 61 2e 22 29 29 0a 09 09 09 09 28 62 65 67 ata.")).....(beg
5e30: 69 6e 0a 09 09 09 09 20 20 28 64 65 62 75 67 3a in..... (debug:
5e40: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5e50: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5e60: 22 68 61 76 65 20 43 4d 44 49 4e 46 4f 20 64 61 "have CMDINFO da
5e70: 74 61 20 62 75 74 20 66 61 69 6c 65 64 20 74 6f ta but failed to
5e80: 20 63 6f 6e 6e 65 63 74 20 74 6f 20 22 20 68 6f connect to " ho
5e90: 73 74 20 22 3a 22 20 70 6f 72 74 29 0a 09 09 09 st ":" port)....
5ea0: 09 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 6d . (set! *runrem
5eb0: 6f 74 65 2a 20 23 66 29 29 0a 09 09 09 09 20 20 ote* #f)).....
5ec0: 3b 3b 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 ;; (remote-connd
5ed0: 61 74 2d 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f at-set! *runremo
5ee0: 74 65 2a 20 23 66 29 29 0a 09 09 09 09 29 29 0a te* #f)).....)).
5ef0: 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 ... (begin....
5f00: 20 20 20 28 73 65 74 21 20 2a 72 75 6e 72 65 6d (set! *runrem
5f10: 6f 74 65 2a 20 23 66 29 0a 09 09 09 20 20 20 20 ote* #f)....
5f20: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5f30: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
5f40: 2d 70 6f 72 74 2a 20 28 69 66 20 68 6f 73 74 2d -port* (if host-
5f50: 70 6f 72 74 0a 09 09 09 09 09 09 09 09 20 20 20 port.........
5f60: 20 20 20 20 28 63 6f 6e 63 20 22 72 65 63 65 69 (conc "recei
5f70: 76 65 64 20 69 6e 76 61 6c 69 64 20 68 6f 73 74 ved invalid host
5f80: 2d 70 6f 72 74 20 69 6e 66 6f 72 6d 61 74 69 6f -port informatio
5f90: 6e 20 22 20 68 6f 73 74 2d 70 6f 72 74 29 0a 09 n " host-port)..
5fa0: 09 09 09 09 09 09 09 20 20 20 20 20 20 20 22 6e ....... "n
5fb0: 6f 20 68 6f 73 74 2d 70 6f 72 74 20 69 6e 66 6f o host-port info
5fc0: 72 6d 61 74 69 6f 6e 20 72 65 63 65 69 76 65 64 rmation received
5fd0: 22 29 29 0a 09 09 09 20 20 20 20 3b 3b 20 70 6f ")).... ;; po
5fe0: 74 65 6e 74 69 61 6c 20 66 6f 72 20 62 61 64 20 tential for bad
5ff0: 73 69 74 75 61 74 69 6f 6e 20 69 66 20 73 69 6d situation if sim
6000: 75 6c 74 61 6e 65 6f 75 73 20 73 74 61 72 74 69 ultaneous starti
6010: 6e 67 20 6f 66 20 68 75 6e 64 72 65 64 73 20 6f ng of hundreds o
6020: 66 20 6a 6f 62 73 20 6f 6e 20 73 65 72 76 65 72 f jobs on server
6030: 73 2c 20 73 65 74 20 6e 65 65 64 63 61 72 65 2e s, set needcare.
6040: 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 6e 65 .... (set! ne
6050: 65 64 63 61 72 65 20 23 74 29 29 29 0a 09 09 20 edcare #t)))...
6060: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 (begin....(
6070: 73 65 74 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a set! *runremote*
6080: 20 23 66 29 0a 09 09 09 28 64 65 62 75 67 3a 70 #f)....(debug:p
6090: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
60a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
60b0: 72 65 63 65 69 76 65 64 20 6e 6f 20 68 6f 6d 65 received no home
60c0: 68 6f 73 74 20 69 6e 66 6f 72 6d 61 74 69 6f 6e host information
60d0: 2e 20 50 6c 65 61 73 65 20 72 65 70 6f 72 74 20 . Please report
60e0: 74 68 69 73 20 74 6f 20 73 75 70 70 6f 72 74 20 this to support
60f0: 61 73 20 69 74 20 73 68 6f 75 6c 64 20 6e 6f 74 as it should not
6100: 20 68 61 70 70 65 6e 2e 22 29 0a 09 09 09 28 73 happen.")....(s
6110: 65 74 21 20 6e 65 65 64 63 61 72 65 20 23 74 29 et! needcare #t)
6120: 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 6e 65 )))).. (if ne
6130: 65 64 63 61 72 65 20 20 3b 3b 20 64 75 65 20 74 edcare ;; due t
6140: 6f 20 76 65 72 79 20 73 6c 6f 77 20 4e 46 53 20 o very slow NFS
6150: 77 65 20 77 69 6c 6c 20 64 6f 20 61 20 62 72 75 we will do a bru
6160: 74 65 20 66 6f 72 63 65 20 6d 6b 64 69 72 20 74 te force mkdir t
6170: 6f 20 65 6e 73 75 72 65 20 74 68 61 74 20 74 68 o ensure that th
6180: 65 20 64 69 72 65 63 74 6f 72 79 20 69 6e 6f 64 e directory inod
6190: 65 20 69 74 20 74 72 75 6c 79 20 61 76 61 69 6c e it truly avail
61a0: 61 62 6c 65 20 6f 6e 20 74 68 69 73 20 68 6f 73 able on this hos
61b0: 74 0a 09 09 28 6c 65 74 20 28 28 6c 6f 67 64 69 t...(let ((logdi
61c0: 72 20 28 63 6f 6e 63 20 74 6f 70 2d 70 61 74 68 r (conc top-path
61d0: 20 22 2f 6c 6f 67 73 22 29 29 29 20 3b 3b 20 77 "/logs"))) ;; w
61e0: 65 27 6c 6c 20 74 72 79 20 74 6f 20 63 72 65 61 e'll try to crea
61f0: 74 65 20 74 68 69 73 20 64 69 72 65 63 74 6f 72 te this director
6200: 79 0a 09 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 y... (handle-ex
6210: 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 20 20 ceptions...
6220: 20 65 78 6e 0a 09 09 20 20 20 20 20 20 28 64 65 exn... (de
6230: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
6240: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6250: 46 61 69 6c 65 64 20 74 6f 20 63 72 65 61 74 65 Failed to create
6260: 20 64 69 72 65 63 74 6f 72 79 20 22 20 6c 6f 67 directory " log
6270: 64 69 72 20 22 20 65 78 70 65 63 74 20 70 72 6f dir " expect pro
6280: 62 6c 65 6d 73 2c 20 6d 65 73 73 61 67 65 3a 20 blems, message:
6290: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
62a0: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
62b0: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
62c0: 78 6e 29 29 0a 09 09 20 20 20 20 28 63 72 65 61 xn))... (crea
62d0: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 6c 6f 67 te-directory log
62e0: 64 69 72 20 23 74 29 29 29 29 29 0a 09 09 20 20 dir #t)))))...
62f0: 0a 09 20 20 3b 3b 20 4e 46 53 20 6d 69 67 68 74 .. ;; NFS might
6300: 20 6e 6f 74 20 68 61 76 65 20 70 72 6f 70 61 67 not have propag
6310: 61 74 65 64 20 74 68 65 20 64 69 72 65 63 74 6f ated the directo
6320: 72 79 20 6d 65 74 61 20 64 61 74 61 20 74 6f 20 ry meta data to
6330: 74 68 65 20 72 75 6e 20 68 6f 73 74 20 2d 20 67 the run host - g
6340: 69 76 65 20 69 74 20 74 69 6d 65 20 69 66 20 6e ive it time if n
6350: 65 65 64 65 64 0a 09 20 20 28 6c 65 74 20 6c 6f eeded.. (let lo
6360: 6f 70 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 09 op ((count 0))..
6370: 20 20 20 20 28 69 66 20 28 6f 72 20 28 66 69 6c (if (or (fil
6380: 65 2d 65 78 69 73 74 73 3f 20 74 6f 70 2d 70 61 e-exists? top-pa
6390: 74 68 29 0a 09 09 20 20 20 20 28 3e 20 63 6f 75 th)... (> cou
63a0: 6e 74 20 31 30 29 29 0a 09 09 28 63 68 61 6e 67 nt 10))...(chang
63b0: 65 2d 64 69 72 65 63 74 6f 72 79 20 74 6f 70 2d e-directory top-
63c0: 70 61 74 68 29 0a 09 09 28 62 65 67 69 6e 0a 09 path)...(begin..
63d0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
63e0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
63f0: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f 74 20 ort* "INFO: Not
6400: 73 74 61 72 74 69 6e 67 20 6a 6f 62 20 79 65 74 starting job yet
6410: 20 2d 20 64 69 72 65 63 74 6f 72 79 20 22 20 74 - directory " t
6420: 6f 70 2d 70 61 74 68 20 22 20 6e 6f 74 20 66 6f op-path " not fo
6430: 75 6e 64 22 29 0a 09 09 20 20 28 74 68 72 65 61 und")... (threa
6440: 64 2d 73 6c 65 65 70 21 20 31 30 29 0a 09 09 20 d-sleep! 10)...
6450: 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 (loop (+ count
6460: 31 29 29 29 29 29 0a 09 20 20 28 6c 61 75 6e 63 1))))).. (launc
6470: 68 3a 73 65 74 75 70 29 20 3b 3b 20 73 68 6f 75 h:setup) ;; shou
6480: 6c 64 20 62 65 20 70 72 6f 70 65 72 6c 79 20 69 ld be properly i
6490: 6e 20 74 68 65 20 74 6f 70 2d 70 61 74 68 20 6e n the top-path n
64a0: 6f 77 0a 09 20 20 28 73 65 74 21 20 74 63 6f 6e ow.. (set! tcon
64b0: 66 69 67 72 65 67 20 28 74 65 73 74 73 3a 67 65 figreg (tests:ge
64c0: 74 2d 61 6c 6c 29 29 0a 09 20 20 28 6c 65 74 20 t-all)).. (let
64d0: 28 28 73 69 67 68 61 6e 64 20 28 6c 61 6d 62 64 ((sighand (lambd
64e0: 61 20 28 73 69 67 6e 75 6d 29 0a 09 09 09 20 20 a (signum)....
64f0: 20 3b 3b 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b ;; (signal-mask
6500: 21 20 73 69 67 6e 75 6d 29 20 3b 3b 20 74 6f 20 ! signum) ;; to
6510: 6d 61 73 6b 20 6f 72 20 6e 6f 74 3f 20 73 65 65 mask or not? see
6520: 6d 73 20 74 6f 20 63 61 75 73 65 20 69 73 73 75 ms to cause issu
6530: 65 73 20 69 6e 20 65 78 69 74 69 6e 67 0a 09 09 es in exiting...
6540: 09 20 20 20 28 69 66 20 28 65 71 3f 20 73 69 67 . (if (eq? sig
6550: 6e 75 6d 20 73 69 67 6e 61 6c 2f 73 74 6f 70 29 num signal/stop)
6560: 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
6570: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
6580: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6590: 74 2a 20 22 61 74 74 65 6d 70 74 20 74 6f 20 53 t* "attempt to S
65a0: 54 4f 50 20 70 72 6f 63 65 73 73 2e 20 45 78 69 TOP process. Exi
65b0: 74 69 6e 67 2e 22 29 29 0a 09 09 09 20 20 20 28 ting.")).... (
65c0: 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 set! *time-to-ex
65d0: 69 74 2a 20 23 74 29 0a 09 09 09 20 20 20 28 70 it* #t).... (p
65e0: 72 69 6e 74 20 22 52 65 63 65 69 76 65 64 20 73 rint "Received s
65f0: 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 ignal " signum "
6600: 2c 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 62 65 , cleaning up be
6610: 66 6f 72 65 20 65 78 69 74 2e 20 50 6c 65 61 73 fore exit. Pleas
6620: 65 20 77 61 69 74 2e 2e 2e 22 29 0a 09 09 09 20 e wait...")....
6630: 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 (let ((th1 (ma
6640: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
6650: 61 20 28 29 0a 09 09 09 09 09 09 20 20 20 20 20 a ().......
6660: 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 (rmt:test-set-st
6670: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
6680: 64 20 74 65 73 74 2d 69 64 20 22 49 4e 43 4f 4d d test-id "INCOM
6690: 50 4c 45 54 45 22 20 22 4b 49 4c 4c 45 44 22 20 PLETE" "KILLED"
66a0: 23 66 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 #f)....... (
66b0: 70 72 69 6e 74 20 22 4b 69 6c 6c 65 64 20 62 79 print "Killed by
66c0: 20 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d signal " signum
66d0: 20 22 2e 20 45 78 69 74 69 6e 67 22 29 0a 09 09 ". Exiting")...
66e0: 09 09 09 09 20 20 20 20 20 28 74 68 72 65 61 64 .... (thread
66f0: 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 09 09 09 -sleep! 1)......
6700: 09 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 . (exit 1)))
6710: 29 0a 09 09 09 09 20 28 74 68 32 20 28 6d 61 6b )..... (th2 (mak
6720: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
6730: 20 28 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 ()....... (
6740: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 thread-sleep! 2)
6750: 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb
6760: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
6770: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 44 ult-log-port* "D
6780: 6f 6e 65 22 29 0a 09 09 09 09 09 09 20 20 20 20 one").......
6790: 20 28 65 78 69 74 20 34 29 29 29 29 29 0a 09 09 (exit 4)))))...
67a0: 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 . (thread-st
67b0: 61 72 74 21 20 74 68 32 29 0a 09 09 09 20 20 20 art! th2)....
67c0: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
67d0: 20 74 68 31 29 0a 09 09 09 20 20 20 20 20 28 74 th1).... (t
67e0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 hread-join! th2)
67f0: 29 29 29 29 0a 09 20 20 20 20 28 73 65 74 2d 73 )))).. (set-s
6800: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 ignal-handler! s
6810: 69 67 6e 61 6c 2f 69 6e 74 20 73 69 67 68 61 6e ignal/int sighan
6820: 64 29 0a 09 20 20 20 20 28 73 65 74 2d 73 69 67 d).. (set-sig
6830: 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 nal-handler! sig
6840: 6e 61 6c 2f 74 65 72 6d 20 73 69 67 68 61 6e 64 nal/term sighand
6850: 29 0a 09 20 20 20 20 29 20 3b 3b 20 28 73 65 74 ).. ) ;; (set
6860: 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 -signal-handler!
6870: 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 69 67 signal/stop sig
6880: 68 61 6e 64 29 0a 09 20 20 0a 09 20 20 3b 3b 20 hand).. .. ;;
6890: 44 6f 20 6e 6f 74 20 72 75 6e 20 74 68 65 20 74 Do not run the t
68a0: 65 73 74 20 69 66 20 69 74 20 69 73 20 52 45 4d est if it is REM
68b0: 4f 56 49 4e 47 2c 20 52 55 4e 4e 49 4e 47 2c 20 OVING, RUNNING,
68c0: 4b 49 4c 4c 52 45 51 20 6f 72 20 52 45 4d 4f 54 KILLREQ or REMOT
68d0: 45 48 4f 53 54 53 54 41 52 54 2c 0a 09 20 20 3b EHOSTSTART,.. ;
68e0: 3b 20 4d 61 72 6b 20 74 68 65 20 74 65 73 74 20 ; Mark the test
68f0: 61 73 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 as REMOTEHOSTSTA
6900: 52 54 20 2a 49 4d 4d 45 44 49 41 54 45 4c 59 2a RT *IMMEDIATELY*
6910: 0a 09 20 20 3b 3b 0a 09 20 20 28 6c 65 74 2a 20 .. ;;.. (let*
6920: 28 28 74 65 73 74 2d 69 6e 66 6f 20 28 72 6d 74 ((test-info (rmt
6930: 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 :get-test-info-b
6940: 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 y-id run-id test
6950: 2d 69 64 29 29 0a 09 09 20 28 74 65 73 74 2d 68 -id))... (test-h
6960: 6f 73 74 20 28 64 62 3a 74 65 73 74 2d 67 65 74 ost (db:test-get
6970: 2d 68 6f 73 74 20 20 20 20 20 20 20 20 74 65 73 -host tes
6980: 74 2d 69 6e 66 6f 29 29 0a 09 09 20 28 74 65 73 t-info))... (tes
6990: 74 2d 70 69 64 20 20 28 64 62 3a 74 65 73 74 2d t-pid (db:test-
69a0: 67 65 74 2d 70 72 6f 63 65 73 73 5f 69 64 20 20 get-process_id
69b0: 74 65 73 74 2d 69 6e 66 6f 29 29 29 0a 09 20 20 test-info)))..
69c0: 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 28 (cond.. ((
69d0: 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
69e0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 2d 69 get-state test-i
69f0: 6e 66 6f 29 20 27 28 22 49 4e 43 4f 4d 50 4c 45 nfo) '("INCOMPLE
6a00: 54 45 22 20 22 4b 49 4c 4c 45 44 22 20 22 55 4e TE" "KILLED" "UN
6a10: 4b 4e 4f 57 4e 22 20 22 4b 49 4c 4c 52 45 51 22 KNOWN" "KILLREQ"
6a20: 20 22 53 54 55 43 4b 22 29 29 20 3b 3b 20 70 72 "STUCK")) ;; pr
6a30: 69 6f 72 20 72 75 6e 20 6f 66 20 74 68 69 73 20 ior run of this
6a40: 74 65 73 74 20 64 69 64 6e 27 74 20 63 6f 6d 70 test didn't comp
6a50: 6c 65 74 65 2c 20 67 6f 20 61 68 65 61 64 20 61 lete, go ahead a
6a60: 6e 64 20 74 72 79 20 74 6f 20 72 65 72 75 6e 0a nd try to rerun.
6a70: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
6a80: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
6a90: 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 og-port* "INFO:
6aa0: 74 65 73 74 20 69 73 20 49 4e 43 4f 4d 50 4c 45 test is INCOMPLE
6ab0: 54 45 20 6f 72 20 4b 49 4c 4c 45 44 2c 20 74 72 TE or KILLED, tr
6ac0: 65 61 74 20 74 68 69 73 20 65 78 65 63 75 74 65 eat this execute
6ad0: 20 63 61 6c 6c 20 61 73 20 61 20 72 65 72 75 6e call as a rerun
6ae0: 20 72 65 71 75 65 73 74 22 29 0a 09 20 20 20 20 request")..
6af0: 20 20 3b 3b 20 28 74 65 73 74 73 3a 74 65 73 74 ;; (tests:test
6b00: 2d 66 6f 72 63 65 2d 73 74 61 74 65 2d 73 74 61 -force-state-sta
6b10: 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 tus! run-id test
6b20: 2d 69 64 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 -id "REMOTEHOSTS
6b30: 54 41 52 54 22 20 22 6e 2f 61 22 29 0a 09 20 20 TART" "n/a")..
6b40: 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 (rmt:test-se
6b50: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 t-state-status r
6b60: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 52 un-id test-id "R
6b70: 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 EMOTEHOSTSTART"
6b80: 22 6e 2f 61 22 20 23 66 29 0a 09 20 20 20 20 20 "n/a" #f)..
6b90: 20 29 20 3b 3b 20 70 72 69 6d 65 20 69 74 20 66 ) ;; prime it f
6ba0: 6f 72 20 72 75 6e 6e 69 6e 67 0a 09 20 20 20 20 or running..
6bb0: 20 28 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 ((member (db:te
6bc0: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 st-get-state tes
6bd0: 74 2d 69 6e 66 6f 29 20 27 28 22 52 55 4e 4e 49 t-info) '("RUNNI
6be0: 4e 47 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 NG" "REMOTEHOSTS
6bf0: 54 41 52 54 22 29 29 0a 09 20 20 20 20 20 20 28 TART")).. (
6c00: 69 66 20 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 if (process:aliv
6c10: 65 2d 6f 6e 2d 68 6f 73 74 3f 20 74 65 73 74 2d e-on-host? test-
6c20: 68 6f 73 74 20 74 65 73 74 2d 70 69 64 29 0a 09 host test-pid)..
6c30: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
6c40: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
6c50: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
6c60: 20 73 74 61 74 65 20 69 73 20 22 20 20 28 64 62 state is " (db
6c70: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
6c80: 74 65 73 74 2d 69 6e 66 6f 29 20 22 20 61 6e 64 test-info) " and
6c90: 20 70 72 6f 63 65 73 73 20 22 20 74 65 73 74 2d process " test-
6ca0: 70 69 64 20 22 20 69 73 20 73 74 69 6c 6c 20 72 pid " is still r
6cb0: 75 6e 6e 69 6e 67 20 6f 6e 20 68 6f 73 74 20 22 unning on host "
6cc0: 20 74 65 73 74 2d 68 6f 73 74 20 22 2c 20 63 61 test-host ", ca
6cd0: 6e 6e 6f 74 20 70 72 6f 63 65 65 64 22 29 0a 09 nnot proceed")..
6ce0: 09 20 20 3b 3b 20 28 74 65 73 74 73 3a 74 65 73 . ;; (tests:tes
6cf0: 74 2d 66 6f 72 63 65 2d 73 74 61 74 65 2d 73 74 t-force-state-st
6d00: 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 atus! run-id tes
6d10: 74 2d 69 64 20 22 52 45 4d 4f 54 45 48 4f 53 54 t-id "REMOTEHOST
6d20: 53 54 41 52 54 22 20 22 6e 2f 61 22 29 0a 09 09 START" "n/a")...
6d30: 20 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d (rmt:test-set-
6d40: 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e state-status run
6d50: 2d 69 64 20 74 65 73 74 2d 69 64 20 22 52 45 4d -id test-id "REM
6d60: 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 6e OTEHOSTSTART" "n
6d70: 2f 61 22 20 23 66 29 0a 09 09 20 20 29 29 0a 09 /a" #f)... ))..
6d80: 20 20 20 20 20 28 28 6e 6f 74 20 28 6d 65 6d 62 ((not (memb
6d90: 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
6da0: 73 74 61 74 65 20 74 65 73 74 2d 69 6e 66 6f 29 state test-info)
6db0: 20 27 28 22 52 45 4d 4f 56 49 4e 47 22 20 22 52 '("REMOVING" "R
6dc0: 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 EMOTEHOSTSTART"
6dd0: 22 52 55 4e 4e 49 4e 47 22 20 22 4b 49 4c 4c 52 "RUNNING" "KILLR
6de0: 45 51 22 29 29 29 0a 09 20 20 20 20 20 20 3b 3b EQ"))).. ;;
6df0: 20 28 74 65 73 74 73 3a 74 65 73 74 2d 66 6f 72 (tests:test-for
6e00: 63 65 2d 73 74 61 74 65 2d 73 74 61 74 75 73 21 ce-state-status!
6e10: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
6e20: 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 "REMOTEHOSTSTART
6e30: 22 20 22 6e 2f 61 22 29 0a 09 20 20 20 20 20 20 " "n/a")..
6e40: 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 73 74 (rmt:test-set-st
6e50: 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 ate-status run-i
6e60: 64 20 74 65 73 74 2d 69 64 20 22 52 45 4d 4f 54 d test-id "REMOT
6e70: 45 48 4f 53 54 53 54 41 52 54 22 20 22 6e 2f 61 EHOSTSTART" "n/a
6e80: 22 20 23 66 29 0a 09 20 20 20 20 20 20 29 0a 09 " #f).. )..
6e90: 20 20 20 20 20 28 65 6c 73 65 20 3b 3b 20 28 6d (else ;; (m
6ea0: 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 ember (db:test-g
6eb0: 65 74 2d 73 74 61 74 65 20 74 65 73 74 2d 69 6e et-state test-in
6ec0: 66 6f 29 20 27 28 22 52 45 4d 4f 56 49 4e 47 22 fo) '("REMOVING"
6ed0: 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 "REMOTEHOSTSTAR
6ee0: 54 22 20 22 52 55 4e 4e 49 4e 47 22 20 22 4b 49 T" "RUNNING" "KI
6ef0: 4c 4c 52 45 51 22 29 29 0a 09 20 20 20 20 20 20 LLREQ"))..
6f00: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
6f10: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
6f20: 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 73 74 g-port* "test st
6f30: 61 74 65 20 69 73 20 22 20 28 64 62 3a 74 65 73 ate is " (db:tes
6f40: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t-get-state test
6f50: 2d 69 6e 66 6f 29 20 22 2c 20 63 61 6e 6e 6f 74 -info) ", cannot
6f60: 20 70 72 6f 63 65 65 64 22 29 0a 09 20 20 20 20 proceed")..
6f70: 20 20 28 65 78 69 74 29 29 29 29 0a 09 20 20 0a (exit)))).. .
6f80: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
6f90: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
6fa0: 6f 72 74 2a 20 22 45 78 65 63 74 75 69 6e 67 20 ort* "Exectuing
6fb0: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 28 69 " test-name " (i
6fc0: 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 29 20 d: " test-id ")
6fd0: 6f 6e 20 22 20 28 67 65 74 2d 68 6f 73 74 2d 6e on " (get-host-n
6fe0: 61 6d 65 29 29 0a 09 20 20 28 73 65 74 21 20 6b ame)).. (set! k
6ff0: 65 79 73 20 20 20 20 20 20 20 28 72 6d 74 3a 67 eys (rmt:g
7000: 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 3b 3b 20 et-keys)).. ;;
7010: 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 61 74 65 (runs:set-megate
7020: 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d st-env-vars run-
7030: 69 64 20 69 6e 6b 65 79 73 3a 20 6b 65 79 73 20 id inkeys: keys
7040: 69 6e 6b 65 79 76 61 6c 73 3a 20 6b 65 79 76 61 inkeyvals: keyva
7050: 6c 73 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 ls) ;; these may
7060: 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 be needed by th
7070: 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 e launching proc
7080: 65 73 73 0a 09 20 20 3b 3b 20 6f 6e 65 20 6f 66 ess.. ;; one of
7090: 20 74 68 65 73 65 20 69 73 20 64 65 66 75 6e 63 these is defunc
70a0: 74 2f 72 65 64 75 6e 64 61 6e 74 20 2e 2e 2e 0a t/redundant ....
70b0: 09 20 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 . (if (not (lau
70c0: 6e 63 68 3a 73 65 74 75 70 20 66 6f 72 63 65 3a nch:setup force:
70d0: 20 23 74 29 29 0a 09 20 20 20 20 20 20 28 62 65 #t)).. (be
70e0: 67 69 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 69 gin...(debug:pri
70f0: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
7100: 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 g-port* "Failed
7110: 74 6f 20 73 65 74 75 70 2c 20 65 78 69 74 69 6e to setup, exitin
7120: 67 22 29 20 0a 09 09 3b 3b 20 28 73 71 6c 69 74 g") ...;; (sqlit
7130: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 e3:finalize! db)
7140: 0a 09 09 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 ...;; (sqlite3:f
7150: 69 6e 61 6c 69 7a 65 21 20 74 64 62 29 0a 09 09 inalize! tdb)...
7160: 28 65 78 69 74 20 31 29 29 29 0a 09 20 20 28 63 (exit 1))).. (c
7170: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
7180: 2a 74 6f 70 70 61 74 68 2a 29 20 0a 0a 09 20 20 *toppath*) ...
7190: 3b 3b 20 4e 4f 54 45 3a 20 43 75 72 72 65 6e 74 ;; NOTE: Current
71a0: 20 6f 72 64 65 72 20 69 73 20 74 6f 20 70 72 6f order is to pro
71b0: 63 65 73 73 20 72 75 6e 63 6f 6e 66 69 67 73 20 cess runconfigs
71c0: 2a 62 65 66 6f 72 65 2a 20 73 65 74 74 69 6e 67 *before* setting
71d0: 20 74 68 65 20 4d 54 5f 20 76 61 72 73 2e 20 54 the MT_ vars. T
71e0: 68 69 73 20 0a 09 20 20 3b 3b 20 20 20 20 20 20 his .. ;;
71f0: 20 73 65 65 6d 73 20 6e 6f 6e 2d 69 64 65 61 6c seems non-ideal
7200: 20 62 75 74 20 63 6f 75 6c 64 20 77 65 6c 6c 20 but could well
7210: 62 72 65 61 6b 20 73 74 75 66 66 0a 09 20 20 3b break stuff.. ;
7220: 3b 20 20 20 20 42 55 47 3f 20 42 55 47 3f 20 42 ; BUG? BUG? B
7230: 55 47 3f 0a 09 20 20 0a 09 20 20 28 6c 65 74 20 UG?.. .. (let
7240: 28 28 72 63 6f 6e 66 69 67 20 28 66 75 6c 6c 2d ((rconfig (full-
7250: 72 75 6e 63 6f 6e 66 69 67 73 2d 72 65 61 64 29 runconfigs-read)
7260: 29 20 3b 3b 20 28 72 65 61 64 2d 63 6f 6e 66 69 ) ;; (read-confi
7270: 67 20 28 63 6f 6e 63 20 20 2a 74 6f 70 70 61 74 g (conc *toppat
7280: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
7290: 63 6f 6e 66 69 67 22 29 20 23 66 20 23 74 20 73 config") #f #t s
72a0: 65 63 74 69 6f 6e 73 3a 20 28 6c 69 73 74 20 22 ections: (list "
72b0: 64 65 66 61 75 6c 74 22 20 74 61 72 67 65 74 29 default" target)
72c0: 29 29 29 0a 09 09 28 77 63 6f 6e 66 69 67 20 28 )))...(wconfig (
72d0: 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 77 61 69 read-config "wai
72e0: 76 65 72 73 2e 63 6f 6e 66 69 67 22 20 23 66 20 vers.config" #f
72f0: 23 74 20 73 65 63 74 69 6f 6e 73 3a 20 60 28 20 #t sections: `(
7300: 22 64 65 66 61 75 6c 74 22 20 2c 74 61 72 67 65 "default" ,targe
7310: 74 20 29 29 29 29 20 3b 3b 20 72 65 61 64 20 74 t )))) ;; read t
7320: 68 65 20 77 61 69 76 65 72 73 20 63 6f 6e 66 69 he waivers confi
7330: 67 20 69 66 20 69 74 20 65 78 69 73 74 73 0a 09 g if it exists..
7340: 20 20 20 20 3b 3b 20 28 73 65 74 75 70 2d 65 6e ;; (setup-en
7350: 76 2d 64 65 66 61 75 6c 74 73 20 28 63 6f 6e 63 v-defaults (conc
7360: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
7370: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
7380: 20 72 75 6e 2d 69 64 20 28 6d 61 6b 65 2d 68 61 run-id (make-ha
7390: 73 68 2d 74 61 62 6c 65 29 20 6b 65 79 76 61 6c sh-table) keyval
73a0: 73 20 74 61 72 67 65 74 29 0a 09 20 20 20 20 3b s target).. ;
73b0: 3b 20 28 73 65 74 2d 72 75 6e 2d 63 6f 6e 66 69 ; (set-run-confi
73c0: 67 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 6b 65 g-vars run-id ke
73d0: 79 76 61 6c 73 20 74 61 72 67 65 74 29 20 3b 3b yvals target) ;;
73e0: 20 28 64 62 3a 67 65 74 2d 74 61 72 67 65 74 20 (db:get-target
73f0: 64 62 20 72 75 6e 2d 69 64 29 29 0a 09 20 20 20 db run-id))..
7400: 20 3b 3b 20 4e 6f 77 20 68 61 76 65 20 72 75 6e ;; Now have run
7410: 63 6f 6e 66 69 67 73 20 64 61 74 61 20 6c 6f 61 configs data loa
7420: 64 65 64 2c 20 73 65 74 20 65 6e 76 69 72 6f 6e ded, set environ
7430: 6d 65 6e 74 20 76 61 72 73 0a 09 20 20 20 20 28 ment vars.. (
7440: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
7450: 20 28 73 65 63 74 69 6f 6e 29 0a 09 09 09 28 66 (section)....(f
7460: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
7470: 28 76 61 72 76 61 6c 29 0a 09 09 09 09 20 20 20 (varval).....
7480: 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 61 72 (let ((var (car
7490: 20 76 61 72 76 61 6c 29 29 0a 09 09 09 09 09 20 varval))......
74a0: 20 28 76 61 6c 20 28 63 61 64 72 20 76 61 72 76 (val (cadr varv
74b0: 61 6c 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 al))).....
74c0: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
74d0: 3f 20 76 61 72 29 28 73 74 72 69 6e 67 3f 20 76 ? var)(string? v
74e0: 61 6c 29 29 0a 09 09 09 09 09 20 20 28 62 65 67 al))...... (beg
74f0: 69 6e 0a 09 09 09 09 09 20 20 20 20 28 73 65 74 in...... (set
7500: 65 6e 76 20 76 61 72 20 28 63 6f 6e 66 69 67 3a env var (config:
7510: 65 76 61 6c 2d 73 74 72 69 6e 67 2d 69 6e 2d 65 eval-string-in-e
7520: 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 6c 29 29 nvironment val))
7530: 29 20 3b 3b 20 76 61 6c 29 0a 09 09 09 09 09 20 ) ;; val)......
7540: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
7550: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
7560: 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 76 61 og-port* "bad va
7570: 72 69 61 62 6c 65 20 73 70 65 63 2c 20 22 20 76 riable spec, " v
7580: 61 72 20 22 3d 22 20 76 61 6c 29 29 29 29 0a 09 ar "=" val))))..
7590: 09 09 09 20 20 28 63 6f 6e 66 69 67 66 3a 67 65 ... (configf:ge
75a0: 74 2d 73 65 63 74 69 6f 6e 20 72 63 6f 6e 66 69 t-section rconfi
75b0: 67 20 73 65 63 74 69 6f 6e 29 29 29 0a 09 09 20 g section)))...
75c0: 20 20 20 20 20 28 6c 69 73 74 20 22 64 65 66 61 (list "defa
75d0: 75 6c 74 22 20 74 61 72 67 65 74 29 29 29 0a 20 ult" target))).
75e0: 20 20 20 20 20 20 20 20 20 3b 3b 28 62 62 2d 63 ;;(bb-c
75f0: 68 65 63 6b 2d 70 61 74 68 20 6d 73 67 3a 20 22 heck-path msg: "
7600: 6c 61 75 6e 63 68 3a 65 78 65 63 75 74 65 20 70 launch:execute p
7610: 6f 73 74 20 62 6c 6f 63 6b 20 31 22 29 0a 0a 09 ost block 1")...
7620: 20 20 3b 3b 20 4e 46 53 20 6d 69 67 68 74 20 6e ;; NFS might n
7630: 6f 74 20 68 61 76 65 20 70 72 6f 70 61 67 61 74 ot have propagat
7640: 65 64 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 ed the directory
7650: 20 6d 65 74 61 20 64 61 74 61 20 74 6f 20 74 68 meta data to th
7660: 65 20 72 75 6e 20 68 6f 73 74 20 2d 20 67 69 76 e run host - giv
7670: 65 20 69 74 20 74 69 6d 65 20 69 66 20 6e 65 65 e it time if nee
7680: 64 65 64 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 ded.. (let loop
7690: 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 09 20 20 ((count 0))..
76a0: 20 20 28 69 66 20 28 6f 72 20 28 66 69 6c 65 2d (if (or (file-
76b0: 65 78 69 73 74 73 3f 20 77 6f 72 6b 2d 61 72 65 exists? work-are
76c0: 61 29 0a 09 09 20 20 20 20 28 3e 20 63 6f 75 6e a)... (> coun
76d0: 74 20 31 30 29 29 0a 09 09 28 63 68 61 6e 67 65 t 10))...(change
76e0: 2d 64 69 72 65 63 74 6f 72 79 20 77 6f 72 6b 2d -directory work-
76f0: 61 72 65 61 29 0a 09 09 28 62 65 67 69 6e 0a 09 area)...(begin..
7700: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
7710: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
7720: 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e 6f 74 20 ort* "INFO: Not
7730: 73 74 61 72 74 69 6e 67 20 6a 6f 62 20 79 65 74 starting job yet
7740: 20 2d 20 64 69 72 65 63 74 6f 72 79 20 22 20 77 - directory " w
7750: 6f 72 6b 2d 61 72 65 61 20 22 20 6e 6f 74 20 66 ork-area " not f
7760: 6f 75 6e 64 22 29 0a 09 09 20 20 28 74 68 72 65 ound")... (thre
7770: 61 64 2d 73 6c 65 65 70 21 20 31 30 29 0a 09 09 ad-sleep! 10)...
7780: 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 (loop (+ count
7790: 20 31 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 1))))).
77a0: 20 20 3b 3b 28 62 62 2d 63 68 65 63 6b 2d 70 61 ;;(bb-check-pa
77b0: 74 68 20 6d 73 67 3a 20 22 6c 61 75 6e 63 68 3a th msg: "launch:
77c0: 65 78 65 63 75 74 65 20 70 6f 73 74 20 62 6c 6f execute post blo
77d0: 63 6b 20 31 2e 35 22 29 0a 09 20 20 3b 3b 20 28 ck 1.5").. ;; (
77e0: 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 change-directory
77f0: 20 77 6f 72 6b 2d 61 72 65 61 29 20 0a 09 20 20 work-area) ..
7800: 28 73 65 74 21 20 6b 65 79 76 61 6c 73 20 20 20 (set! keyvals
7810: 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b (keys:target->k
7820: 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 eyval keys targe
7830: 74 29 29 0a 09 20 20 3b 3b 20 61 70 70 6c 79 20 t)).. ;; apply
7840: 70 72 65 2d 6f 76 65 72 72 69 64 65 73 20 62 65 pre-overrides be
7850: 66 6f 72 65 20 6f 74 68 65 72 20 76 61 72 69 61 fore other varia
7860: 62 6c 65 73 2e 20 54 68 65 20 70 72 65 2d 6f 76 bles. The pre-ov
7870: 65 72 72 69 64 65 20 76 61 72 73 20 6d 75 73 74 erride vars must
7880: 20 6e 6f 74 0a 09 20 20 3b 3b 20 63 6c 6f 62 62 not.. ;; clobb
7890: 65 72 73 20 74 68 69 6e 67 73 20 66 72 6f 6d 20 ers things from
78a0: 74 68 65 20 6f 66 66 69 63 69 61 6c 20 73 6f 75 the official sou
78b0: 72 63 65 73 20 73 75 63 68 20 61 73 20 6d 65 67 rces such as meg
78c0: 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 61 6e 64 atest.config and
78d0: 20 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 runconfigs.conf
78e0: 69 67 0a 09 20 20 28 69 66 20 28 73 74 72 69 6e ig.. (if (strin
78f0: 67 3f 20 73 65 74 2d 76 61 72 73 29 0a 09 20 20 g? set-vars)..
7900: 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 70 61 (let ((varpa
7910: 69 72 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 irs (string-spli
7920: 74 20 73 65 74 2d 76 61 72 73 20 22 2c 22 29 29 t set-vars ","))
7930: 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 )...(debug:print
7940: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
7950: 70 6f 72 74 2a 20 22 76 61 72 70 61 69 72 73 3a port* "varpairs:
7960: 20 22 20 76 61 72 70 61 69 72 73 29 0a 09 09 28 " varpairs)...(
7970: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 76 61 72 map (lambda (var
7980: 70 61 69 72 29 0a 09 09 20 20 20 20 20 20 20 28 pair)... (
7990: 6c 65 74 20 28 28 76 61 72 76 61 6c 20 28 73 74 let ((varval (st
79a0: 72 69 6e 67 2d 73 70 6c 69 74 20 76 61 72 70 61 ring-split varpa
79b0: 69 72 20 22 3d 22 29 29 29 0a 09 09 09 20 28 69 ir "="))).... (i
79c0: 66 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 76 f (eq? (length v
79d0: 61 72 76 61 6c 29 20 32 29 0a 09 09 09 20 20 20 arval) 2)....
79e0: 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 61 (let ((var (ca
79f0: 72 20 76 61 72 76 61 6c 29 29 0a 09 09 09 09 20 r varval)).....
7a00: 20 20 28 76 61 6c 20 28 63 61 64 72 20 76 61 72 (val (cadr var
7a10: 76 61 6c 29 29 29 0a 09 09 09 20 20 20 20 20 20 val)))....
7a20: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 (debug:print 1
7a30: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
7a40: 74 2a 20 22 41 64 64 69 6e 67 20 70 72 65 2d 76 t* "Adding pre-v
7a50: 61 72 2f 76 61 6c 20 22 20 76 61 72 20 22 20 3d ar/val " var " =
7a60: 20 22 20 76 61 6c 20 22 20 74 6f 20 74 68 65 20 " val " to the
7a70: 65 6e 76 69 72 6f 6e 6d 65 6e 74 22 29 0a 09 09 environment")...
7a80: 09 20 20 20 20 20 20 20 28 73 65 74 65 6e 76 20 . (setenv
7a90: 76 61 72 20 76 61 6c 29 29 29 29 29 0a 09 09 20 var val)))))...
7aa0: 20 20 20 20 76 61 72 70 61 69 72 73 29 29 29 0a varpairs))).
7ab0: 20 20 20 20 20 20 20 20 20 20 3b 3b 28 62 62 2d ;;(bb-
7ac0: 63 68 65 63 6b 2d 70 61 74 68 20 6d 73 67 3a 20 check-path msg:
7ad0: 22 6c 61 75 6e 63 68 3a 65 78 65 63 75 74 65 20 "launch:execute
7ae0: 70 6f 73 74 20 62 6c 6f 63 6b 20 32 22 29 0a 09 post block 2")..
7af0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 (for-each..
7b00: 28 6c 61 6d 62 64 61 20 28 76 61 72 76 61 6c 29 (lambda (varval)
7b10: 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 .. (let ((va
7b20: 72 20 28 63 61 72 20 76 61 72 76 61 6c 29 29 0a r (car varval)).
7b30: 09 09 20 20 20 28 76 61 6c 20 28 63 61 64 72 20 .. (val (cadr
7b40: 76 61 72 76 61 6c 29 29 29 0a 09 20 20 20 20 20 varval)))..
7b50: 20 20 28 69 66 20 76 61 6c 0a 09 09 20 20 20 28 (if val... (
7b60: 73 65 74 65 6e 76 20 76 61 72 20 76 61 6c 29 0a setenv var val).
7b70: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 .. (begin...
7b80: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
7b90: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
7ba0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 71 75 -log-port* "requ
7bb0: 69 72 65 64 20 76 61 72 69 61 62 6c 65 20 22 20 ired variable "
7bc0: 76 61 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 68 var " does not h
7bd0: 61 76 65 20 61 20 76 61 6c 69 64 20 76 61 6c 75 ave a valid valu
7be0: 65 2e 20 45 78 69 74 69 6e 67 22 29 0a 09 09 20 e. Exiting")...
7bf0: 20 20 20 20 28 65 78 69 74 29 29 29 29 29 0a 09 (exit)))))..
7c00: 20 20 20 20 20 28 6c 69 73 74 20 0a 09 20 20 20 (list ..
7c10: 20 20 20 28 6c 69 73 74 20 20 22 4d 54 5f 54 45 (list "MT_TE
7c20: 53 54 5f 52 55 4e 5f 44 49 52 22 20 77 6f 72 6b ST_RUN_DIR" work
7c30: 2d 61 72 65 61 29 0a 09 20 20 20 20 20 20 28 6c -area).. (l
7c40: 69 73 74 20 20 22 4d 54 5f 54 45 53 54 5f 4e 41 ist "MT_TEST_NA
7c50: 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 ME" test-name)..
7c60: 20 20 20 20 20 20 28 6c 69 73 74 20 20 22 4d 54 (list "MT
7c70: 5f 49 54 45 4d 5f 49 4e 46 4f 22 20 28 63 6f 6e _ITEM_INFO" (con
7c80: 63 20 69 74 65 6d 64 61 74 29 29 0a 09 20 20 20 c itemdat))..
7c90: 20 20 20 28 6c 69 73 74 20 20 22 4d 54 5f 49 54 (list "MT_IT
7ca0: 45 4d 50 41 54 48 22 20 20 69 74 65 6d 2d 70 61 EMPATH" item-pa
7cb0: 74 68 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 th).. (list
7cc0: 20 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 "MT_RUNNAME"
7cd0: 20 72 75 6e 6e 61 6d 65 29 0a 09 20 20 20 20 20 runname)..
7ce0: 20 28 6c 69 73 74 20 20 22 4d 54 5f 4d 45 47 41 (list "MT_MEGA
7cf0: 54 45 53 54 22 20 20 6d 65 67 61 74 65 73 74 29 TEST" megatest)
7d00: 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 20 22 .. (list "
7d10: 4d 54 5f 54 41 52 47 45 54 22 20 20 20 20 74 61 MT_TARGET" ta
7d20: 72 67 65 74 29 0a 09 20 20 20 20 20 20 28 6c 69 rget).. (li
7d30: 73 74 20 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 st "MT_LINKTREE
7d40: 22 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c " (common:get-l
7d50: 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 28 63 6f inktree)) ;; (co
7d60: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
7d70: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
7d80: 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 0a 09 20 "linktree"))..
7d90: 20 20 20 20 20 28 6c 69 73 74 20 20 22 4d 54 5f (list "MT_
7da0: 54 45 53 54 53 55 49 54 45 4e 41 4d 45 22 20 28 TESTSUITENAME" (
7db0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 common:get-tests
7dc0: 75 69 74 65 2d 6e 61 6d 65 29 29 29 29 0a 20 20 uite-name)))).
7dd0: 20 20 20 20 20 20 20 20 3b 3b 28 62 62 2d 63 68 ;;(bb-ch
7de0: 65 63 6b 2d 70 61 74 68 20 6d 73 67 3a 20 22 6c eck-path msg: "l
7df0: 61 75 6e 63 68 3a 65 78 65 63 75 74 65 20 70 6f aunch:execute po
7e00: 73 74 20 62 6c 6f 63 6b 20 33 22 29 0a 0a 09 20 st block 3")...
7e10: 20 28 69 66 20 6d 74 2d 62 69 6e 64 69 72 2d 70 (if mt-bindir-p
7e20: 61 74 68 20 28 73 65 74 65 6e 76 20 22 50 41 54 ath (setenv "PAT
7e30: 48 22 20 28 63 6f 6e 63 20 28 67 65 74 65 6e 76 H" (conc (getenv
7e40: 20 22 50 41 54 48 22 29 20 22 3a 22 20 6d 74 2d "PATH") ":" mt-
7e50: 62 69 6e 64 69 72 2d 70 61 74 68 29 29 29 0a 20 bindir-path))).
7e60: 20 20 20 20 20 20 20 20 20 3b 3b 28 62 62 2d 63 ;;(bb-c
7e70: 68 65 63 6b 2d 70 61 74 68 20 6d 73 67 3a 20 22 heck-path msg: "
7e80: 6c 61 75 6e 63 68 3a 65 78 65 63 75 74 65 20 70 launch:execute p
7e90: 6f 73 74 20 62 6c 6f 63 6b 20 34 22 29 0a 09 20 ost block 4")..
7ea0: 20 3b 3b 20 28 63 68 61 6e 67 65 2d 64 69 72 65 ;; (change-dire
7eb0: 63 74 6f 72 79 20 74 6f 70 2d 70 61 74 68 29 0a ctory top-path).
7ec0: 09 20 20 3b 3b 20 43 61 6e 20 73 65 74 75 70 20 . ;; Can setup
7ed0: 61 73 20 63 6c 69 65 6e 74 20 66 6f 72 20 73 65 as client for se
7ee0: 72 76 65 72 20 6d 6f 64 65 20 6e 6f 77 0a 09 20 rver mode now..
7ef0: 20 3b 3b 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 ;; (client:setu
7f00: 70 29 0a 0a 09 20 20 0a 09 20 20 3b 3b 20 65 6e p)... .. ;; en
7f10: 76 69 72 6f 6e 6d 65 6e 74 20 6f 76 65 72 72 69 vironment overri
7f20: 64 65 73 20 61 72 65 20 64 6f 6e 65 20 2a 62 65 des are done *be
7f30: 66 6f 72 65 2a 20 74 68 65 20 72 65 6d 61 69 6e fore* the remain
7f40: 69 6e 67 20 63 72 69 74 69 63 61 6c 20 65 6e 76 ing critical env
7f50: 61 72 73 2e 0a 09 20 20 28 61 6c 69 73 74 2d 3e ars... (alist->
7f60: 65 6e 76 2d 76 61 72 73 20 65 6e 76 2d 6f 76 72 env-vars env-ovr
7f70: 64 29 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 28 d). ;;(
7f80: 62 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 6d 73 bb-check-path ms
7f90: 67 3a 20 22 6c 61 75 6e 63 68 3a 65 78 65 63 75 g: "launch:execu
7fa0: 74 65 20 70 6f 73 74 20 62 6c 6f 63 6b 20 34 31 te post block 41
7fb0: 22 29 0a 09 20 20 28 72 75 6e 73 3a 73 65 74 2d ").. (runs:set-
7fc0: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
7fd0: 73 20 72 75 6e 2d 69 64 20 69 6e 6b 65 79 73 3a s run-id inkeys:
7fe0: 20 6b 65 79 73 20 69 6e 6b 65 79 76 61 6c 73 3a keys inkeyvals:
7ff0: 20 6b 65 79 76 61 6c 73 29 0a 20 20 20 20 20 20 keyvals).
8000: 20 20 20 20 3b 3b 28 62 62 2d 63 68 65 63 6b 2d ;;(bb-check-
8010: 70 61 74 68 20 6d 73 67 3a 20 22 6c 61 75 6e 63 path msg: "launc
8020: 68 3a 65 78 65 63 75 74 65 20 70 6f 73 74 20 62 h:execute post b
8030: 6c 6f 63 6b 20 34 32 22 29 0a 09 20 20 28 73 65 lock 42").. (se
8040: 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 61 72 73 20 t-item-env-vars
8050: 69 74 65 6d 64 61 74 29 0a 20 20 20 20 20 20 20 itemdat).
8060: 20 20 20 3b 3b 28 62 62 2d 63 68 65 63 6b 2d 70 ;;(bb-check-p
8070: 61 74 68 20 6d 73 67 3a 20 22 6c 61 75 6e 63 68 ath msg: "launch
8080: 3a 65 78 65 63 75 74 65 20 70 6f 73 74 20 62 6c :execute post bl
8090: 6f 63 6b 20 34 33 22 29 0a 09 20 20 28 73 61 76 ock 43").. (sav
80a0: 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 73 e-environment-as
80b0: 2d 66 69 6c 65 73 20 22 6d 65 67 61 74 65 73 74 -files "megatest
80c0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 28 "). ;;(
80d0: 62 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 6d 73 bb-check-path ms
80e0: 67 3a 20 22 6c 61 75 6e 63 68 3a 65 78 65 63 75 g: "launch:execu
80f0: 74 65 20 70 6f 73 74 20 62 6c 6f 63 6b 20 34 34 te post block 44
8100: 22 29 0a 09 20 20 3b 3b 20 6f 70 65 6e 2d 72 75 ").. ;; open-ru
8110: 6e 2d 63 6c 6f 73 65 20 6e 6f 74 20 6e 65 65 64 n-close not need
8120: 65 64 20 66 6f 72 20 74 65 73 74 2d 73 65 74 2d ed for test-set-
8130: 6d 65 74 61 2d 69 6e 66 6f 0a 09 20 20 3b 3b 20 meta-info.. ;;
8140: 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d (tests:set-full-
8150: 6d 65 74 61 2d 69 6e 66 6f 20 23 66 20 74 65 73 meta-info #f tes
8160: 74 2d 69 64 20 72 75 6e 2d 69 64 20 30 20 77 6f t-id run-id 0 wo
8170: 72 6b 2d 61 72 65 61 29 0a 09 20 20 3b 3b 20 28 rk-area).. ;; (
8180: 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d tests:set-full-m
8190: 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 eta-info test-id
81a0: 20 72 75 6e 2d 69 64 20 30 20 77 6f 72 6b 2d 61 run-id 0 work-a
81b0: 72 65 61 29 0a 09 20 20 28 74 65 73 74 73 3a 73 rea).. (tests:s
81c0: 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 et-full-meta-inf
81d0: 6f 20 23 66 20 74 65 73 74 2d 69 64 20 72 75 6e o #f test-id run
81e0: 2d 69 64 20 30 20 77 6f 72 6b 2d 61 72 65 61 20 -id 0 work-area
81f0: 31 30 29 0a 0a 09 20 20 3b 3b 20 28 74 68 72 65 10)... ;; (thre
8200: 61 64 2d 73 6c 65 65 70 21 20 30 2e 33 29 20 3b ad-sleep! 0.3) ;
8210: 3b 20 4e 46 53 20 73 6c 6f 77 6e 65 73 73 20 68 ; NFS slowness h
8220: 61 73 20 63 61 75 73 65 64 20 67 72 69 65 66 20 as caused grief
8230: 68 65 72 65 0a 0a 09 20 20 28 69 66 20 28 61 72 here... (if (ar
8240: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 78 74 65 gs:get-arg "-xte
8250: 72 6d 22 29 0a 09 20 20 20 20 20 20 28 73 65 74 rm").. (set
8260: 21 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 ! fullrunscript
8270: 22 78 74 65 72 6d 22 29 0a 09 20 20 20 20 20 20 "xterm")..
8280: 28 69 66 20 28 61 6e 64 20 66 75 6c 6c 72 75 6e (if (and fullrun
8290: 73 63 72 69 70 74 20 0a 09 09 20 20 20 20 20 20 script ...
82a0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
82b0: 75 6c 6c 72 75 6e 73 63 72 69 70 74 29 0a 09 09 ullrunscript)...
82c0: 20 20 20 20 20 20 20 28 6e 6f 74 20 28 66 69 6c (not (fil
82d0: 65 2d 65 78 65 63 75 74 65 2d 61 63 63 65 73 73 e-execute-access
82e0: 3f 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 29 ? fullrunscript)
82f0: 29 29 0a 09 09 20 20 28 73 79 73 74 65 6d 20 28 ))... (system (
8300: 63 6f 6e 63 20 22 63 68 6d 6f 64 20 75 67 2b 78 conc "chmod ug+x
8310: 20 22 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 " fullrunscript
8320: 29 29 29 29 0a 0a 09 20 20 3b 3b 20 57 65 20 61 ))))... ;; We a
8330: 72 65 20 61 62 6f 75 74 20 74 6f 20 61 63 74 75 re about to actu
8340: 61 6c 6c 79 20 6b 69 63 6b 20 6f 66 66 20 74 68 ally kick off th
8350: 65 20 74 65 73 74 0a 09 20 20 3b 3b 20 73 6f 20 e test.. ;; so
8360: 74 68 69 73 20 69 73 20 61 20 67 6f 6f 64 20 70 this is a good p
8370: 6c 61 63 65 20 74 6f 20 72 65 6d 6f 76 65 20 74 lace to remove t
8380: 68 65 20 72 65 63 6f 72 64 73 20 66 6f 72 20 0a he records for .
8390: 09 20 20 3b 3b 20 61 6e 79 20 70 72 65 76 69 6f . ;; any previo
83a0: 75 73 20 72 75 6e 73 0a 09 20 20 3b 3b 20 28 64 us runs.. ;; (d
83b0: 62 3a 74 65 73 74 2d 72 65 6d 6f 76 65 2d 73 74 b:test-remove-st
83c0: 65 70 73 20 64 62 20 72 75 6e 2d 69 64 20 74 65 eps db run-id te
83d0: 73 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a stname itemdat).
83e0: 09 20 20 3b 3b 20 0a 09 20 20 28 6c 65 74 2a 20 . ;; .. (let*
83f0: 28 28 6d 20 20 20 20 20 20 20 20 20 20 20 20 28 ((m (
8400: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 09 09 20 make-mutex))...
8410: 28 6b 69 6c 6c 2d 6a 6f 62 3f 20 20 20 20 23 66 (kill-job? #f
8420: 29 0a 09 09 20 28 65 78 69 74 2d 69 6e 66 6f 20 )... (exit-info
8430: 20 20 20 28 6d 61 6b 65 2d 6c 61 75 6e 63 68 3a (make-launch:
8440: 65 69 6e 66 20 70 69 64 3a 20 23 74 20 65 78 69 einf pid: #t exi
8450: 74 2d 73 74 61 74 75 73 3a 20 23 74 20 65 78 69 t-status: #t exi
8460: 74 2d 63 6f 64 65 3a 20 23 74 20 72 6f 6c 6c 75 t-code: #t rollu
8470: 70 2d 73 74 61 74 75 73 3a 20 30 29 29 20 3b 3b p-status: 0)) ;;
8480: 20 70 69 64 20 65 78 69 74 2d 73 74 61 74 75 73 pid exit-status
8490: 20 65 78 69 74 2d 63 6f 64 65 20 28 69 2e 65 2e exit-code (i.e.
84a0: 20 70 72 6f 63 65 73 73 20 77 61 73 20 73 75 63 process was suc
84b0: 63 65 73 73 66 75 6c 6c 79 20 72 75 6e 29 20 72 cessfully run) r
84c0: 6f 6c 6c 75 70 2d 73 74 61 74 75 73 0a 09 09 20 ollup-status...
84d0: 28 6a 6f 62 2d 74 68 72 65 61 64 20 20 20 23 66 (job-thread #f
84e0: 29 0a 09 09 20 3b 3b 20 28 6b 65 65 70 2d 67 6f )... ;; (keep-go
84f0: 69 6e 67 20 20 20 23 74 29 0a 09 09 20 28 6d 69 ing #t)... (mi
8500: 73 63 2d 66 6c 61 67 73 20 20 20 28 6c 65 74 20 sc-flags (let
8510: 28 28 68 74 20 28 6d 61 6b 65 2d 68 61 73 68 2d ((ht (make-hash-
8520: 74 61 62 6c 65 29 29 29 0a 09 09 09 09 20 28 68 table)))..... (h
8530: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 ash-table-set! h
8540: 74 20 27 6b 65 65 70 2d 67 6f 69 6e 67 20 23 74 t 'keep-going #t
8550: 29 0a 09 09 09 09 20 68 74 29 29 0a 09 09 20 28 )..... ht))... (
8560: 72 75 6e 69 74 20 20 20 20 20 20 20 20 28 6c 61 runit (la
8570: 6d 62 64 61 20 28 29 0a 09 09 09 09 20 28 6c 61 mbda ()..... (la
8580: 75 6e 63 68 3a 6d 61 6e 61 67 65 2d 73 74 65 70 unch:manage-step
8590: 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 s run-id test-id
85a0: 20 69 74 65 6d 2d 70 61 74 68 20 66 75 6c 6c 72 item-path fullr
85b0: 75 6e 73 63 72 69 70 74 20 65 7a 73 74 65 70 73 unscript ezsteps
85c0: 20 74 65 73 74 2d 6e 61 6d 65 20 74 63 6f 6e 66 test-name tconf
85d0: 69 67 72 65 67 20 65 78 69 74 2d 69 6e 66 6f 20 igreg exit-info
85e0: 6d 29 29 29 0a 09 09 20 28 6d 6f 6e 69 74 6f 72 m)))... (monitor
85f0: 6a 6f 62 20 20 20 28 6c 61 6d 62 64 61 20 28 29 job (lambda ()
8600: 0a 09 09 09 09 20 28 6c 61 75 6e 63 68 3a 6d 6f ..... (launch:mo
8610: 6e 69 74 6f 72 2d 6a 6f 62 20 20 72 75 6e 2d 69 nitor-job run-i
8620: 64 20 74 65 73 74 2d 69 64 20 69 74 65 6d 2d 70 d test-id item-p
8630: 61 74 68 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 ath fullrunscrip
8640: 74 20 65 7a 73 74 65 70 73 20 74 65 73 74 2d 6e t ezsteps test-n
8650: 61 6d 65 20 74 63 6f 6e 66 69 67 72 65 67 20 65 ame tconfigreg e
8660: 78 69 74 2d 69 6e 66 6f 20 6d 20 77 6f 72 6b 2d xit-info m work-
8670: 61 72 65 61 20 72 75 6e 74 6c 69 6d 20 6d 69 73 area runtlim mis
8680: 63 2d 66 6c 61 67 73 29 29 29 0a 09 09 20 28 74 c-flags)))... (t
8690: 68 31 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b h1 (mak
86a0: 65 2d 74 68 72 65 61 64 20 6d 6f 6e 69 74 6f 72 e-thread monitor
86b0: 6a 6f 62 20 22 6d 6f 6e 69 74 6f 72 20 6a 6f 62 job "monitor job
86c0: 22 29 29 0a 09 09 20 28 74 68 32 20 20 20 20 20 "))... (th2
86d0: 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 (make-threa
86e0: 64 20 72 75 6e 69 74 20 22 72 75 6e 20 6a 6f 62 d runit "run job
86f0: 22 29 29 29 0a 09 20 20 20 20 28 73 65 74 21 20 "))).. (set!
8700: 6a 6f 62 2d 74 68 72 65 61 64 20 74 68 32 29 0a job-thread th2).
8710: 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 . (thread-sta
8720: 72 74 21 20 74 68 31 29 0a 09 20 20 20 20 28 74 rt! th1).. (t
8730: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 hread-start! th2
8740: 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 6a ).. (thread-j
8750: 6f 69 6e 21 20 74 68 32 29 0a 09 20 20 20 20 28 oin! th2).. (
8760: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
8770: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
8780: 70 6f 72 74 2a 20 22 4d 65 67 61 74 65 73 74 20 port* "Megatest
8790: 65 78 65 63 74 75 74 65 20 6f 66 20 74 65 73 74 exectute of test
87a0: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2c 20 " test-name ",
87b0: 69 74 65 6d 20 70 61 74 68 20 22 20 69 74 65 6d item path " item
87c0: 2d 70 61 74 68 20 22 20 63 6f 6d 70 6c 65 74 65 -path " complete
87d0: 2e 20 4e 6f 74 69 66 79 69 6e 67 20 74 68 65 20 . Notifying the
87e0: 64 62 20 2e 2e 2e 22 29 0a 09 20 20 20 20 28 68 db ...").. (h
87f0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 6d ash-table-set! m
8800: 69 73 63 2d 66 6c 61 67 73 20 27 6b 65 65 70 2d isc-flags 'keep-
8810: 67 6f 69 6e 67 20 23 66 29 0a 09 20 20 20 20 28 going #f).. (
8820: 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 thread-join! th1
8830: 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 73 ).. (thread-s
8840: 6c 65 65 70 21 20 31 29 20 20 20 20 20 20 20 3b leep! 1) ;
8850: 3b 20 67 69 76 62 65 20 74 68 72 65 61 64 20 74 ; givbe thread t
8860: 68 31 20 61 20 63 68 61 6e 63 65 20 74 6f 20 62 h1 a chance to b
8870: 65 20 64 6f 6e 65 20 54 4f 44 4f 3a 20 56 65 72 e done TODO: Ver
8880: 69 66 79 20 74 68 69 73 20 69 73 20 6e 65 65 64 ify this is need
8890: 65 64 2e 20 41 74 20 30 2e 31 20 49 20 77 61 73 ed. At 0.1 I was
88a0: 20 67 65 74 74 69 6e 67 20 66 61 69 6c 20 74 6f getting fail to
88b0: 20 73 74 6f 70 2c 20 69 6e 63 72 65 61 73 65 64 stop, increased
88c0: 20 74 6f 20 74 6f 74 61 6c 20 6f 66 20 31 2e 31 to total of 1.1
88d0: 20 73 65 63 2e 0a 09 20 20 20 20 28 6d 75 74 65 sec... (mute
88e0: 78 2d 6c 6f 63 6b 21 20 6d 29 0a 09 20 20 20 20 x-lock! m)..
88f0: 28 6c 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 (let* ((item-pat
8900: 68 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 h (item-list->pa
8910: 74 68 20 69 74 65 6d 64 61 74 29 29 0a 09 09 20 th itemdat))...
8920: 20 20 3b 3b 20 6f 6e 6c 79 20 73 74 61 74 65 20 ;; only state
8930: 61 6e 64 20 73 74 61 74 75 73 20 6e 65 65 64 65 and status neede
8940: 64 20 2d 20 75 73 65 20 6c 61 7a 79 20 72 6f 75 d - use lazy rou
8950: 74 69 6e 65 0a 09 09 20 20 20 28 74 65 73 74 69 tine... (testi
8960: 6e 66 6f 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 nfo (rmt:get-te
8970: 73 74 69 6e 66 6f 2d 73 74 61 74 65 2d 73 74 61 stinfo-state-sta
8980: 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d tus run-id test-
8990: 69 64 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 id))).. ;;
89a0: 41 6d 20 49 20 63 6f 6d 70 6c 65 74 65 64 3f 0a Am I completed?.
89b0: 09 20 20 20 20 20 20 28 69 66 20 28 6d 65 6d 62 . (if (memb
89c0: 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d er (db:test-get-
89d0: 73 74 61 74 65 20 74 65 73 74 69 6e 66 6f 29 20 state testinfo)
89e0: 27 28 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 '("REMOTEHOSTSTA
89f0: 52 54 22 20 22 52 55 4e 4e 49 4e 47 22 29 29 20 RT" "RUNNING"))
8a00: 3b 3b 20 4e 4f 54 45 3a 20 49 74 20 73 68 6f 75 ;; NOTE: It shou
8a10: 6c 64 20 2a 6e 6f 74 2a 20 62 65 20 52 45 4d 4f ld *not* be REMO
8a20: 54 45 48 4f 53 54 53 54 41 52 54 20 62 75 74 20 TEHOSTSTART but
8a30: 66 6f 72 20 72 65 61 73 6f 6e 73 20 49 20 64 6f for reasons I do
8a40: 6e 27 74 20 79 65 74 20 75 6e 64 65 72 73 74 61 n't yet understa
8a50: 6e 64 20 69 74 20 73 6f 6d 65 74 69 6d 65 73 20 nd it sometimes
8a60: 67 65 74 73 20 73 74 75 63 6b 20 69 6e 20 74 68 gets stuck in th
8a70: 61 74 20 73 74 61 74 65 20 3b 3b 20 28 6e 6f 74 at state ;; (not
8a80: 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 (equal? (db:tes
8a90: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t-get-state test
8aa0: 69 6e 66 6f 29 20 22 43 4f 4d 50 4c 45 54 45 44 info) "COMPLETED
8ab0: 22 29 29 0a 09 09 20 20 28 6c 65 74 20 28 28 6e "))... (let ((n
8ac0: 65 77 2d 73 74 61 74 65 20 20 28 69 66 20 6b 69 ew-state (if ki
8ad0: 6c 6c 2d 6a 6f 62 3f 20 22 4b 49 4c 4c 45 44 22 ll-job? "KILLED"
8ae0: 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 20 3b 3b "COMPLETED") ;;
8af0: 20 28 69 66 20 28 65 71 3f 20 28 76 65 63 74 6f (if (eq? (vecto
8b00: 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 r-ref exit-info
8b10: 32 29 20 30 29 20 3b 3b 20 65 78 69 74 65 64 20 2) 0) ;; exited
8b20: 77 69 74 68 20 22 67 6f 6f 64 22 20 73 74 61 74 with "good" stat
8b30: 75 73 0a 09 09 09 09 20 20 20 20 20 20 20 20 20 us.....
8b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
8b60: 3b 20 22 43 4f 4d 50 4c 45 54 45 44 22 0a 09 09 ; "COMPLETED"...
8b70: 09 09 09 09 09 20 20 20 20 20 20 20 20 20 20 20 .....
8b80: 20 20 20 20 20 3b 3b 20 28 64 62 3a 74 65 73 74 ;; (db:test
8b90: 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 69 -get-state testi
8ba0: 6e 66 6f 29 29 29 20 20 20 3b 3b 20 65 6c 73 65 nfo))) ;; else
8bb0: 20 70 72 65 73 65 76 65 20 74 68 65 20 73 74 61 preseve the sta
8bc0: 74 65 20 61 73 20 73 65 74 20 77 69 74 68 69 6e te as set within
8bd0: 20 74 68 65 20 74 65 73 74 0a 09 09 09 09 20 20 the test.....
8be0: 20 20 29 0a 09 09 09 28 6e 65 77 2d 73 74 61 74 )....(new-stat
8bf0: 75 73 20 28 63 6f 6e 64 0a 09 09 09 09 20 20 20 us (cond.....
8c00: 20 20 28 28 6e 6f 74 20 28 6c 61 75 6e 63 68 3a ((not (launch:
8c10: 65 69 6e 66 2d 65 78 69 74 2d 73 74 61 74 75 73 einf-exit-status
8c20: 20 65 78 69 74 2d 69 6e 66 6f 29 29 20 22 46 41 exit-info)) "FA
8c30: 49 4c 22 29 20 3b 3b 20 6a 6f 62 20 66 61 69 6c IL") ;; job fail
8c40: 65 64 20 74 6f 20 72 75 6e 20 2e 2e 2e 20 28 76 ed to run ... (v
8c50: 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 ector-ref exit-i
8c60: 6e 66 6f 20 31 29 0a 09 09 09 09 20 20 20 20 20 nfo 1).....
8c70: 28 28 65 71 3f 20 28 6c 61 75 6e 63 68 3a 65 69 ((eq? (launch:ei
8c80: 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 nf-rollup-status
8c90: 20 65 78 69 74 2d 69 6e 66 6f 29 20 30 29 20 20 exit-info) 0)
8ca0: 20 20 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 ;; (vector-re
8cb0: 66 20 65 78 69 74 2d 69 6e 66 6f 20 33 29 0a 09 f exit-info 3)..
8cc0: 09 09 09 20 20 20 20 20 20 3b 3b 20 69 66 20 74 ... ;; if t
8cd0: 68 65 20 63 75 72 72 65 6e 74 20 73 74 61 74 75 he current statu
8ce0: 73 20 69 73 20 41 55 54 4f 20 74 68 65 6e 20 64 s is AUTO then d
8cf0: 65 66 65 72 20 74 6f 20 74 68 65 20 63 61 6c 63 efer to the calc
8d00: 75 6c 61 74 65 64 20 76 61 6c 75 65 20 28 69 2e ulated value (i.
8d10: 65 2e 20 6c 65 61 76 65 20 74 68 69 73 20 41 55 e. leave this AU
8d20: 54 4f 29 0a 09 09 09 09 20 20 20 20 20 20 28 69 TO)..... (i
8d30: 66 20 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 f (equal? (db:te
8d40: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 st-get-status te
8d50: 73 74 69 6e 66 6f 29 20 22 41 55 54 4f 22 29 20 stinfo) "AUTO")
8d60: 22 41 55 54 4f 22 20 22 50 41 53 53 22 29 29 0a "AUTO" "PASS")).
8d70: 09 09 09 09 20 20 20 20 20 28 28 65 71 3f 20 28 .... ((eq? (
8d80: 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c launch:einf-roll
8d90: 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 up-status exit-i
8da0: 6e 66 6f 29 20 31 29 20 22 46 41 49 4c 22 29 20 nfo) 1) "FAIL")
8db0: 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ;; (vector-ref
8dc0: 65 78 69 74 2d 69 6e 66 6f 20 33 29 0a 09 09 09 exit-info 3)....
8dd0: 09 20 20 20 20 20 28 28 65 71 3f 20 28 6c 61 75 . ((eq? (lau
8de0: 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d nch:einf-rollup-
8df0: 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f status exit-info
8e00: 29 20 32 29 09 20 20 20 20 20 3b 3b 09 28 76 65 ) 2). ;;.(ve
8e10: 63 74 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 6e ctor-ref exit-in
8e20: 66 6f 20 33 29 0a 09 09 09 09 20 20 20 20 20 20 fo 3).....
8e30: 3b 3b 20 69 66 20 74 68 65 20 63 75 72 72 65 6e ;; if the curren
8e40: 74 20 73 74 61 74 75 73 20 69 73 20 41 55 54 4f t status is AUTO
8e50: 20 74 68 65 20 64 65 66 65 72 20 74 6f 20 74 68 the defer to th
8e60: 65 20 63 61 6c 63 75 6c 61 74 65 64 20 76 61 6c e calculated val
8e70: 75 65 20 62 75 74 20 71 75 61 6c 69 66 79 20 28 ue but qualify (
8e80: 69 2e 65 2e 20 6d 61 6b 65 20 74 68 69 73 20 41 i.e. make this A
8e90: 55 54 4f 2d 57 41 52 4e 29 0a 09 09 09 09 20 20 UTO-WARN).....
8ea0: 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 (if (equal?
8eb0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
8ec0: 74 75 73 20 74 65 73 74 69 6e 66 6f 29 20 22 41 tus testinfo) "A
8ed0: 55 54 4f 22 29 20 22 41 55 54 4f 2d 57 41 52 4e UTO") "AUTO-WARN
8ee0: 22 20 22 57 41 52 4e 22 29 29 0a 09 09 09 09 20 " "WARN")).....
8ef0: 20 20 20 20 28 28 65 71 3f 20 28 6c 61 75 6e 63 ((eq? (launc
8f00: 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 h:einf-rollup-st
8f10: 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 20 atus exit-info)
8f20: 33 29 20 22 43 48 45 43 4b 22 29 0a 09 09 09 09 3) "CHECK").....
8f30: 20 20 20 20 20 28 28 65 71 3f 20 28 6c 61 75 6e ((eq? (laun
8f40: 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 ch:einf-rollup-s
8f50: 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 tatus exit-info)
8f60: 20 34 29 20 22 57 41 49 56 45 44 22 29 0a 09 09 4) "WAIVED")...
8f70: 09 09 20 20 20 20 20 28 28 65 71 3f 20 28 6c 61 .. ((eq? (la
8f80: 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 unch:einf-rollup
8f90: 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 -status exit-inf
8fa0: 6f 29 20 35 29 20 22 41 42 4f 52 54 22 29 0a 09 o) 5) "ABORT")..
8fb0: 09 09 09 20 20 20 20 20 28 28 65 71 3f 20 28 6c ... ((eq? (l
8fc0: 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 aunch:einf-rollu
8fd0: 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e p-status exit-in
8fe0: 66 6f 29 20 36 29 20 22 53 4b 49 50 22 29 0a 09 fo) 6) "SKIP")..
8ff0: 09 09 09 20 20 20 20 20 28 65 6c 73 65 20 22 46 ... (else "F
9000: 41 49 4c 22 29 29 29 29 20 3b 3b 20 28 64 62 3a AIL")))) ;; (db:
9010: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 test-get-status
9020: 74 65 73 74 69 6e 66 6f 29 29 29 0a 09 09 20 20 testinfo)))...
9030: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
9040: 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 1 *default-l
9050: 6f 67 2d 70 6f 72 74 2a 20 22 54 65 73 74 20 65 og-port* "Test e
9060: 78 69 74 65 64 20 69 6e 20 73 74 61 74 65 3d 22 xited in state="
9070: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
9080: 61 74 65 20 74 65 73 74 69 6e 66 6f 29 20 22 2c ate testinfo) ",
9090: 20 73 65 74 74 69 6e 67 20 73 74 61 74 65 2f 73 setting state/s
90a0: 74 61 74 75 73 20 62 61 73 65 64 20 6f 6e 20 65 tatus based on e
90b0: 78 69 74 20 63 6f 64 65 20 6f 66 20 22 20 28 6c xit code of " (l
90c0: 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d aunch:einf-exit-
90d0: 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f status exit-info
90e0: 29 20 22 20 61 6e 64 20 72 6f 6c 6c 75 70 2d 73 ) " and rollup-s
90f0: 74 61 74 75 73 20 6f 66 20 22 20 28 6c 61 75 6e tatus of " (laun
9100: 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 ch:einf-rollup-s
9110: 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 tatus exit-info)
9120: 29 0a 09 09 20 20 20 20 28 74 65 73 74 73 3a 74 )... (tests:t
9130: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
9140: 72 75 6e 2d 69 64 20 0a 09 09 09 09 09 20 20 20 run-id ......
9150: 20 74 65 73 74 2d 69 64 20 0a 09 09 09 09 09 20 test-id ......
9160: 20 20 20 6e 65 77 2d 73 74 61 74 65 0a 09 09 09 new-state....
9170: 09 09 20 20 20 20 6e 65 77 2d 73 74 61 74 75 73 .. new-status
9180: 0a 09 09 09 09 09 20 20 20 20 28 61 72 67 73 3a ...... (args:
9190: 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 23 66 get-arg "-m") #f
91a0: 29 0a 09 09 20 20 20 20 3b 3b 20 6e 65 65 64 20 )... ;; need
91b0: 74 6f 20 75 70 64 61 74 65 20 74 68 65 20 74 6f to update the to
91c0: 70 20 74 65 73 74 20 72 65 63 6f 72 64 20 69 66 p test record if
91d0: 20 50 41 53 53 20 6f 72 20 46 41 49 4c 20 61 6e PASS or FAIL an
91e0: 64 20 74 68 69 73 20 69 73 20 61 20 73 75 62 74 d this is a subt
91f0: 65 73 74 0a 09 09 20 20 20 20 3b 3b 20 4e 4f 20 est... ;; NO
9200: 4e 45 45 44 20 54 4f 20 43 41 4c 4c 20 73 65 74 NEED TO CALL set
9210: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e -state-status-an
9220: 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 d-roll-up-items
9230: 48 45 52 45 2c 20 54 48 49 53 20 49 53 20 44 4f HERE, THIS IS DO
9240: 4e 45 20 49 4e 20 73 65 74 2d 73 74 61 74 65 2d NE IN set-state-
9250: 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d status-and-roll-
9260: 75 70 2d 69 74 65 6d 73 20 63 61 6c 6c 65 64 20 up-items called
9270: 62 79 20 74 65 73 74 73 3a 74 65 73 74 2d 73 65 by tests:test-se
9280: 74 2d 73 74 61 74 75 73 21 0a 09 09 20 20 20 20 t-status!...
9290: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 66 6f 72 )).. ;; for
92a0: 20 61 75 74 6f 6d 61 74 65 64 20 63 72 65 61 74 automated creat
92b0: 69 6f 6e 20 6f 66 20 74 68 65 20 72 6f 6c 6c 75 ion of the rollu
92c0: 70 20 68 74 6d 6c 20 66 69 6c 65 20 74 68 69 73 p html file this
92d0: 20 69 73 20 61 20 67 6f 6f 64 20 70 6c 61 63 65 is a good place
92e0: 2e 2e 2e 0a 09 20 20 20 20 20 20 28 69 66 20 28 ..... (if (
92f0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d not (equal? item
9300: 2d 70 61 74 68 20 22 22 29 29 0a 09 09 20 20 28 -path ""))... (
9310: 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d tests:summarize-
9320: 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 items run-id tes
9330: 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 23 t-id test-name #
9340: 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 f)).. (test
9350: 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 65 73 74 s:summarize-test
9360: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
9370: 20 20 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 63 65 ;; don't force
9380: 20 2d 20 6a 75 73 74 20 75 70 64 61 74 65 20 69 - just update i
9390: 66 20 6e 6f 0a 09 20 20 20 20 20 20 28 72 6d 74 f no.. (rmt
93a0: 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 :update-run-stat
93b0: 73 20 72 75 6e 2d 69 64 20 28 72 6d 74 3a 67 65 s run-id (rmt:ge
93c0: 74 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 t-raw-run-stats
93d0: 72 75 6e 2d 69 64 29 29 29 0a 09 20 20 20 20 28 run-id))).. (
93e0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 29 mutex-unlock! m)
93f0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
9400: 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 2 *default-lo
9410: 67 2d 70 6f 72 74 2a 20 22 4f 75 74 70 75 74 20 g-port* "Output
9420: 66 72 6f 6d 20 72 75 6e 6e 69 6e 67 20 22 20 66 from running " f
9430: 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 22 2c 20 ullrunscript ",
9440: 70 69 64 20 22 20 28 6c 61 75 6e 63 68 3a 65 69 pid " (launch:ei
9450: 6e 66 2d 70 69 64 20 65 78 69 74 2d 69 6e 66 6f nf-pid exit-info
9460: 29 20 22 20 69 6e 20 77 6f 72 6b 20 61 72 65 61 ) " in work area
9470: 20 22 20 0a 09 09 09 20 77 6f 72 6b 2d 61 72 65 " .... work-are
9480: 61 20 22 3a 5c 6e 3d 3d 3d 3d 5c 6e 20 65 78 69 a ":\n====\n exi
9490: 74 20 63 6f 64 65 20 22 20 28 6c 61 75 6e 63 68 t code " (launch
94a0: 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 65 20 :einf-exit-code
94b0: 65 78 69 74 2d 69 6e 66 6f 29 20 22 5c 6e 22 20 exit-info) "\n"
94c0: 22 3d 3d 3d 3d 5c 6e 22 29 0a 09 20 20 20 20 28 "====\n").. (
94d0: 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 3a if (not (launch:
94e0: 65 69 6e 66 2d 65 78 69 74 2d 73 74 61 74 75 73 einf-exit-status
94f0: 20 65 78 69 74 2d 69 6e 66 6f 29 29 0a 09 09 28 exit-info))...(
9500: 65 78 69 74 20 34 29 29 29 29 29 29 29 0a 0a 28 exit 4)))))))..(
9510: 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 63 define (launch:c
9520: 61 63 68 65 2d 63 6f 6e 66 69 67 29 0a 20 20 3b ache-config). ;
9530: 3b 20 69 66 20 77 65 20 68 61 76 65 20 61 20 6c ; if we have a l
9540: 69 6e 6b 74 72 65 65 20 61 6e 64 20 2d 72 75 6e inktree and -run
9550: 74 65 73 74 73 20 61 6e 64 20 2d 74 61 72 67 65 tests and -targe
9560: 74 20 61 6e 64 20 74 68 65 20 64 69 72 65 63 74 t and the direct
9570: 6f 72 79 20 65 78 69 73 74 73 20 64 75 6d 70 20 ory exists dump
9580: 74 68 65 20 63 6f 6e 66 69 67 0a 20 20 3b 3b 20 the config. ;;
9590: 74 6f 20 6d 65 67 61 74 65 73 74 2d 28 63 75 72 to megatest-(cur
95a0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 2e 63 66 rent-seconds).cf
95b0: 67 20 61 6e 64 20 73 79 6d 6c 69 6e 6b 20 69 74 g and symlink it
95c0: 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 63 66 67 to megatest.cfg
95d0: 0a 20 20 28 69 66 20 28 61 6e 64 20 2a 63 6f 6e . (if (and *con
95e0: 66 69 67 64 61 74 2a 20 0a 09 20 20 20 28 6f 72 figdat* .. (or
95f0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
9600: 2d 72 75 6e 22 29 0a 09 20 20 20 20 20 20 20 28 -run").. (
9610: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
9620: 75 6e 74 65 73 74 73 22 29 0a 09 20 20 20 20 20 untests")..
9630: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
9640: 22 2d 65 78 65 63 75 74 65 22 29 29 29 0a 20 20 "-execute"))).
9650: 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b (let* ((link
9660: 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 tree (common:get
9670: 2d 6c 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 28 -linktree)) ;; (
9680: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
9690: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 4c 49 4e variable "MT_LIN
96a0: 4b 54 52 45 45 22 29 29 0a 09 20 20 20 20 20 28 KTREE")).. (
96b0: 74 61 72 67 65 74 20 20 20 28 63 6f 6d 6d 6f 6e target (common
96c0: 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 :args-get-target
96d0: 20 65 78 69 74 2d 69 66 2d 62 61 64 3a 20 23 74 exit-if-bad: #t
96e0: 29 29 0a 09 20 20 20 20 20 28 72 75 6e 6e 61 6d )).. (runnam
96f0: 65 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 e (or (args:get
9700: 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 -arg "-runname")
9710: 0a 09 09 09 20 20 20 28 61 72 67 73 3a 67 65 74 .... (args:get
9720: 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 -arg ":runname")
9730: 0a 09 09 09 20 20 20 28 67 65 74 65 6e 76 20 22 .... (getenv "
9740: 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 29 29 0a 09 MT_RUNNAME")))..
9750: 20 20 20 20 20 28 66 75 6c 6c 64 69 72 20 20 28 (fulldir (
9760: 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f conc linktree "/
9770: 22 0a 09 09 09 20 20 20 20 20 74 61 72 67 65 74 ".... target
9780: 20 22 2f 22 0a 09 09 09 20 20 20 20 20 72 75 6e "/".... run
9790: 6e 61 6d 65 29 29 29 0a 09 28 69 66 20 28 61 6e name)))..(if (an
97a0: 64 20 6c 69 6e 6b 74 72 65 65 20 28 66 69 6c 65 d linktree (file
97b0: 2d 65 78 69 73 74 73 3f 20 6c 69 6e 6b 74 72 65 -exists? linktre
97c0: 65 29 29 20 3b 3b 20 63 61 6e 27 74 20 70 72 6f e)) ;; can't pro
97d0: 63 65 65 64 20 77 69 74 68 6f 75 74 20 6c 69 6e ceed without lin
97e0: 6b 74 72 65 65 0a 09 20 20 20 20 28 62 65 67 69 ktree.. (begi
97f0: 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a n.. (debug:
9800: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
9810: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
9820: 22 48 61 76 65 20 2d 72 75 6e 20 77 69 74 68 20 "Have -run with
9830: 74 61 72 67 65 74 3d 22 20 74 61 72 67 65 74 20 target=" target
9840: 22 2c 20 72 75 6e 6e 61 6d 65 3d 22 20 72 75 6e ", runname=" run
9850: 6e 61 6d 65 20 22 2c 20 66 75 6c 6c 64 69 72 3d name ", fulldir=
9860: 22 20 66 75 6c 6c 64 69 72 20 22 2c 20 74 65 73 " fulldir ", tes
9870: 74 70 61 74 74 3d 22 20 28 6f 72 20 28 61 72 67 tpatt=" (or (arg
9880: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 s:get-arg "-test
9890: 70 61 74 74 22 29 20 22 25 22 29 29 0a 09 20 20 patt") "%"))..
98a0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 (if (not (fi
98b0: 6c 65 2d 65 78 69 73 74 73 3f 20 66 75 6c 6c 64 le-exists? fulld
98c0: 69 72 29 29 0a 09 09 20 20 28 63 72 65 61 74 65 ir))... (create
98d0: 2d 64 69 72 65 63 74 6f 72 79 20 66 75 6c 6c 64 -directory fulld
98e0: 69 72 20 23 74 29 29 20 3b 3b 20 6e 65 65 64 20 ir #t)) ;; need
98f0: 74 6f 20 70 72 6f 74 65 63 74 20 77 69 74 68 20 to protect with
9900: 65 78 63 65 70 74 69 6f 6e 20 68 61 6e 64 6c 65 exception handle
9910: 72 20 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 r .. (if (a
9920: 6e 64 20 74 61 72 67 65 74 0a 09 09 20 20 20 20 nd target...
9930: 20 20 20 72 75 6e 6e 61 6d 65 0a 09 09 20 20 20 runname...
9940: 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (file-exists
9950: 3f 20 66 75 6c 6c 64 69 72 29 29 0a 09 09 20 20 ? fulldir))...
9960: 28 6c 65 74 20 28 28 74 6d 70 66 69 6c 65 20 20 (let ((tmpfile
9970: 28 63 6f 6e 63 20 66 75 6c 6c 64 69 72 20 22 2f (conc fulldir "/
9980: 2e 6d 65 67 61 74 65 73 74 2e 63 66 67 2e 22 20 .megatest.cfg."
9990: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
99a0: 29 29 29 0a 09 09 09 28 74 61 72 67 66 69 6c 65 )))....(targfile
99b0: 20 28 63 6f 6e 63 20 66 75 6c 6c 64 69 72 20 22 (conc fulldir "
99c0: 2f 2e 6d 65 67 61 74 65 73 74 2e 63 66 67 2d 22 /.megatest.cfg-"
99d0: 20 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 megatest-versi
99e0: 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 74 2d on "-" megatest-
99f0: 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a 09 09 fossil-hash))...
9a00: 09 28 72 63 6f 6e 66 69 67 20 20 28 63 6f 6e 63 .(rconfig (conc
9a10: 20 66 75 6c 6c 64 69 72 20 22 2f 2e 72 75 6e 63 fulldir "/.runc
9a20: 6f 6e 66 69 67 2e 22 20 6d 65 67 61 74 65 73 74 onfig." megatest
9a30: 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 -version "-" meg
9a40: 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 atest-fossil-has
9a50: 68 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 h)))... (if (
9a60: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 63 6f file-exists? rco
9a70: 6e 66 69 67 29 20 3b 3b 20 6f 6e 6c 79 20 63 61 nfig) ;; only ca
9a80: 63 68 65 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e che megatest.con
9a90: 66 69 67 20 41 46 54 45 52 20 72 75 6e 63 6f 6e fig AFTER runcon
9aa0: 66 69 67 73 20 68 61 73 20 62 65 65 6e 20 63 61 figs has been ca
9ab0: 63 68 65 64 0a 09 09 09 28 62 65 67 69 6e 0a 09 ched....(begin..
9ac0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
9ad0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
9ae0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 61 63 68 -log-port* "Cach
9af0: 69 6e 67 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e ing megatest.con
9b00: 66 69 67 20 69 6e 20 22 20 74 6d 70 66 69 6c 65 fig in " tmpfile
9b10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9b20: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
9b30: 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d (not (common:in-
9b40: 72 75 6e 6e 69 6e 67 2d 74 65 73 74 3f 29 29 0a running-test?)).
9b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
9b70: 6f 6e 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 onfigf:write-ali
9b80: 73 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 74 st *configdat* t
9b90: 6d 70 66 69 6c 65 29 29 0a 09 09 09 20 20 28 73 mpfile)).... (s
9ba0: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6c 6e 20 ystem (conc "ln
9bb0: 2d 73 66 20 22 20 74 6d 70 66 69 6c 65 20 22 20 -sf " tmpfile "
9bc0: 22 20 74 61 72 67 66 69 6c 65 29 29 29 29 0a 09 " targfile))))..
9bd0: 09 20 20 20 20 29 29 29 0a 09 20 20 20 20 28 64 . ))).. (d
9be0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
9bf0: 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 1 *default-log-p
9c00: 6f 72 74 2a 20 22 4e 6f 20 6c 69 6e 6b 74 72 65 ort* "No linktre
9c10: 65 20 79 65 74 2c 20 6e 6f 20 63 61 63 68 69 6e e yet, no cachin
9c20: 67 20 63 6f 6e 66 69 67 73 2e 22 29 29 29 29 29 g configs.")))))
9c30: 0a 0a 0a 3b 3b 20 67 61 74 68 65 72 20 61 76 61 ...;; gather ava
9c40: 69 6c 61 62 6c 65 20 69 6e 66 6f 72 6d 61 74 69 ilable informati
9c50: 6f 6e 2c 20 69 66 20 6c 65 67 69 74 20 72 65 61 on, if legit rea
9c60: 64 20 63 6f 6e 66 69 67 73 20 69 6e 20 74 68 69 d configs in thi
9c70: 73 20 6f 72 64 65 72 3a 0a 3b 3b 0a 3b 3b 20 20 s order:.;;.;;
9c80: 20 69 66 20 68 61 76 65 20 63 61 63 68 65 3b 0a if have cache;.
9c90: 3b 3b 20 20 20 20 20 20 72 65 61 64 20 69 74 20 ;; read it
9ca0: 61 20 72 65 74 75 72 6e 20 69 74 0a 3b 3b 20 20 a return it.;;
9cb0: 20 65 6c 73 65 0a 3b 3b 20 20 20 20 20 6d 65 67 else.;; meg
9cc0: 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 20 20 20 atest.config
9cd0: 20 28 64 6f 20 6e 6f 74 20 63 61 63 68 65 29 0a (do not cache).
9ce0: 3b 3b 20 20 20 20 20 72 75 6e 63 6f 6e 66 69 67 ;; runconfig
9cf0: 73 2e 63 6f 6e 66 69 67 20 20 20 28 63 61 63 68 s.config (cach
9d00: 65 20 69 66 20 61 6c 6c 20 76 61 72 73 20 61 76 e if all vars av
9d10: 61 69 6c 29 0a 3b 3b 20 20 20 20 20 6d 65 67 61 ail).;; mega
9d20: 74 65 73 74 2e 63 6f 6e 66 69 67 20 20 20 20 20 test.config
9d30: 28 63 61 63 68 65 20 69 66 20 61 6c 6c 20 76 61 (cache if all va
9d40: 72 73 20 61 76 61 69 6c 29 0a 3b 3b 20 20 20 72 rs avail).;; r
9d50: 65 74 75 72 6e 73 3a 0a 3b 3b 20 20 20 20 20 2a eturns:.;; *
9d60: 74 6f 70 70 61 74 68 2a 0a 3b 3b 20 20 20 73 69 toppath*.;; si
9d70: 64 65 20 65 66 66 65 63 74 73 3a 0a 3b 3b 20 20 de effects:.;;
9d80: 20 20 20 73 65 74 73 3b 20 2a 63 6f 6e 66 69 67 sets; *config
9d90: 64 61 74 2a 20 20 20 20 28 6d 65 67 61 74 65 73 dat* (megates
9da0: 74 2e 63 6f 6e 66 69 67 20 69 6e 66 6f 29 0a 3b t.config info).;
9db0: 3b 20 20 20 20 20 20 20 20 20 20 20 2a 72 75 6e ; *run
9dc0: 63 6f 6e 66 69 67 64 61 74 2a 20 28 72 75 6e 63 configdat* (runc
9dd0: 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 20 69 6e onfigs.config in
9de0: 66 6f 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 fo).;;
9df0: 20 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 *configstatus*
9e00: 28 73 74 61 74 75 73 20 6f 66 20 74 68 65 20 72 (status of the r
9e10: 65 61 64 20 64 61 74 61 29 0a 3b 3b 0a 28 64 65 ead data).;;.(de
9e20: 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 73 65 74 fine (launch:set
9e30: 75 70 20 23 21 6b 65 79 20 28 66 6f 72 63 65 20 up #!key (force
9e40: 23 66 29 20 28 61 72 65 61 70 61 74 68 20 23 66 #f) (areapath #f
9e50: 29 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b )). (mutex-lock
9e60: 21 20 2a 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d ! *launch-setup-
9e70: 6d 75 74 65 78 2a 29 0a 20 20 28 69 66 20 28 61 mutex*). (if (a
9e80: 6e 64 20 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 nd *toppath*..
9e90: 20 28 65 71 3f 20 2a 63 6f 6e 66 69 67 73 74 61 (eq? *configsta
9ea0: 74 75 73 2a 20 27 66 75 6c 6c 64 61 74 61 29 29 tus* 'fulldata))
9eb0: 20 3b 3b 20 67 6f 74 20 69 74 20 61 6c 6c 0a 20 ;; got it all.
9ec0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 (begin..(de
9ed0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
9ee0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
9ef0: 4e 4f 54 45 3a 20 73 6b 69 70 70 69 6e 67 20 6c NOTE: skipping l
9f00: 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 79 aunch:setup-body
9f10: 20 63 61 6c 6c 20 73 69 6e 63 65 20 77 65 20 68 call since we h
9f20: 61 76 65 20 66 75 6c 6c 64 61 74 61 22 29 0a 09 ave fulldata")..
9f30: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
9f40: 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 74 launch-setup-mut
9f50: 65 78 2a 29 0a 09 2a 74 6f 70 70 61 74 68 2a 29 ex*)..*toppath*)
9f60: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
9f70: 73 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d s (launch:setup-
9f80: 62 6f 64 79 20 66 6f 72 63 65 3a 20 66 6f 72 63 body force: forc
9f90: 65 20 61 72 65 61 70 61 74 68 3a 20 61 72 65 61 e areapath: area
9fa0: 70 61 74 68 29 29 29 0a 09 28 6d 75 74 65 78 2d path)))..(mutex-
9fb0: 75 6e 6c 6f 63 6b 21 20 2a 6c 61 75 6e 63 68 2d unlock! *launch-
9fc0: 73 65 74 75 70 2d 6d 75 74 65 78 2a 29 0a 09 72 setup-mutex*)..r
9fd0: 65 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 es)))..(define (
9fe0: 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 launch:setup-bod
9ff0: 79 20 23 21 6b 65 79 20 28 66 6f 72 63 65 2d 72 y #!key (force-r
a000: 65 72 65 61 64 20 23 66 29 20 28 61 72 65 61 70 eread #f) (areap
a010: 61 74 68 20 23 66 29 29 0a 20 20 28 69 66 20 28 ath #f)). (if (
a020: 61 6e 64 20 28 65 71 3f 20 2a 63 6f 6e 66 69 67 and (eq? *config
a030: 73 74 61 74 75 73 2a 20 27 66 75 6c 6c 64 61 74 status* 'fulldat
a040: 61 29 0a 09 20 20 20 2a 74 6f 70 70 61 74 68 2a a).. *toppath*
a050: 0a 09 20 20 20 28 6e 6f 74 20 66 6f 72 63 65 2d .. (not force-
a060: 72 65 72 65 61 64 29 29 20 3b 3b 20 6e 6f 20 6e reread)) ;; no n
a070: 65 65 64 20 74 6f 20 72 65 70 72 6f 63 65 73 73 eed to reprocess
a080: 0a 20 20 20 20 20 20 2a 74 6f 70 70 61 74 68 2a . *toppath*
a090: 20 20 20 3b 3b 20 72 65 74 75 72 6e 20 74 6f 70 ;; return top
a0a0: 70 61 74 68 0a 20 20 20 20 20 20 28 6c 65 74 2a path. (let*
a0b0: 20 28 28 75 73 65 2d 63 61 63 68 65 20 28 63 6f ((use-cache (co
a0c0: 6d 6d 6f 6e 3a 75 73 65 2d 63 61 63 68 65 3f 29 mmon:use-cache?)
a0d0: 29 0a 09 20 20 20 20 20 28 74 6f 70 70 61 74 68 ).. (toppath
a0e0: 20 20 28 6f 72 20 2a 74 6f 70 70 61 74 68 2a 20 (or *toppath*
a0f0: 61 72 65 61 70 61 74 68 20 28 67 65 74 65 6e 76 areapath (getenv
a100: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
a110: 4d 45 22 29 29 29 20 3b 3b 20 70 72 65 73 65 72 ME"))) ;; preser
a120: 76 65 20 74 6f 70 70 61 74 68 0a 09 20 20 20 20 ve toppath..
a130: 20 0a 09 20 20 20 20 20 28 72 75 6e 6e 61 6d 65 .. (runname
a140: 20 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 (common:args-g
a150: 65 74 2d 72 75 6e 6e 61 6d 65 29 29 0a 09 20 20 et-runname))..
a160: 20 20 20 28 74 61 72 67 65 74 20 20 20 28 63 6f (target (co
a170: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 mmon:args-get-ta
a180: 72 67 65 74 29 29 0a 09 20 20 20 20 20 28 6c 69 rget)).. (li
a190: 6e 6b 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 67 nktree (common:g
a1a0: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 0a 09 20 et-linktree))..
a1b0: 20 20 20 20 28 63 6f 6e 74 6f 75 72 20 20 23 66 (contour #f
a1c0: 29 20 3b 3b 20 4e 4f 54 20 52 45 41 44 59 20 46 ) ;; NOT READY F
a1d0: 4f 52 20 54 48 49 53 20 28 61 72 67 73 3a 67 65 OR THIS (args:ge
a1e0: 74 2d 61 72 67 20 22 2d 63 6f 6e 74 6f 75 72 22 t-arg "-contour"
a1f0: 29 29 0a 09 20 20 20 20 20 28 73 65 63 74 69 6f )).. (sectio
a200: 6e 73 20 28 69 66 20 74 61 72 67 65 74 20 28 6c ns (if target (l
a210: 69 73 74 20 22 64 65 66 61 75 6c 74 22 20 74 61 ist "default" ta
a220: 72 67 65 74 29 20 23 66 29 29 20 3b 3b 20 66 6f rget) #f)) ;; fo
a230: 72 20 72 75 6e 63 6f 6e 66 69 67 73 0a 09 20 20 r runconfigs..
a240: 20 20 20 28 6d 74 63 6f 6e 66 69 67 20 28 6f 72 (mtconfig (or
a250: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
a260: 2d 63 6f 6e 66 69 67 22 29 20 22 6d 65 67 61 74 -config") "megat
a270: 65 73 74 2e 63 6f 6e 66 69 67 22 29 29 20 3b 3b est.config")) ;;
a280: 20 61 6c 6c 6f 77 20 6f 76 65 72 72 69 64 69 6e allow overridin
a290: 67 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 g megatest.confi
a2a0: 67 20 0a 09 20 20 20 20 20 28 72 75 6e 64 69 72 g .. (rundir
a2b0: 20 20 20 28 69 66 20 28 61 6e 64 20 72 75 6e 6e (if (and runn
a2c0: 61 6d 65 20 74 61 72 67 65 74 20 6c 69 6e 6b 74 ame target linkt
a2d0: 72 65 65 29 0a 09 09 09 20 20 20 28 63 6f 6e 63 ree).... (conc
a2e0: 20 6c 69 6e 6b 74 72 65 65 20 28 69 66 20 63 6f linktree (if co
a2f0: 6e 74 6f 75 72 20 28 63 6f 6e 63 20 22 2f 22 20 ntour (conc "/"
a300: 63 6f 6e 74 6f 75 72 29 20 22 22 29 20 22 2f 22 contour) "") "/"
a310: 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 6e target "/" runn
a320: 61 6d 65 29 0a 09 09 09 20 20 20 23 66 29 29 0a ame).... #f)).
a330: 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 09 20 ..
a340: 20 20 20 20 28 6d 74 63 61 63 68 65 66 20 28 61 (mtcachef (a
a350: 6e 64 20 72 75 6e 64 69 72 20 28 63 6f 6e 63 20 nd rundir (conc
a360: 72 75 6e 64 69 72 20 22 2f 22 20 22 2e 6d 65 67 rundir "/" ".meg
a370: 61 74 65 73 74 2e 63 66 67 2d 22 20 20 6d 65 67 atest.cfg-" meg
a380: 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d atest-version "-
a390: 22 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 " megatest-fossi
a3a0: 6c 2d 68 61 73 68 29 29 29 0a 09 20 20 20 20 20 l-hash)))..
a3b0: 28 72 63 63 61 63 68 65 66 20 28 61 6e 64 20 72 (rccachef (and r
a3c0: 75 6e 64 69 72 20 28 63 6f 6e 63 20 72 75 6e 64 undir (conc rund
a3d0: 69 72 20 22 2f 22 20 22 2e 72 75 6e 63 6f 6e 66 ir "/" ".runconf
a3e0: 69 67 73 2e 63 66 67 2d 22 20 20 6d 65 67 61 74 igs.cfg-" megat
a3f0: 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 est-version "-"
a400: 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d megatest-fossil-
a410: 68 61 73 68 29 29 29 0a 09 20 20 20 20 20 28 63 hash))).. (c
a420: 61 6e 63 72 65 61 74 65 20 28 61 6e 64 20 72 75 ancreate (and ru
a430: 6e 64 69 72 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c ndir (common:fil
a440: 65 2d 65 78 69 73 74 73 3f 20 72 75 6e 64 69 72 e-exists? rundir
a450: 29 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 )(file-write-acc
a460: 65 73 73 3f 20 72 75 6e 64 69 72 29 20 28 6e 6f ess? rundir) (no
a470: 74 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e t (common:in-run
a480: 6e 69 6e 67 2d 74 65 73 74 3f 29 29 29 29 29 0a ning-test?))))).
a490: 09 3b 3b 20 28 63 78 74 20 20 20 20 20 20 20 28 .;; (cxt (
a4a0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
a4b0: 65 66 61 75 6c 74 20 2a 63 6f 6e 74 65 78 74 73 efault *contexts
a4c0: 2a 20 74 6f 70 70 61 74 68 20 23 66 29 29 29 0a * toppath #f))).
a4d0: 0a 09 3b 3b 20 63 72 65 61 74 65 20 6f 75 72 20 ..;; create our
a4e0: 63 78 74 20 66 6f 72 20 74 68 69 73 20 61 72 65 cxt for this are
a4f0: 61 20 69 66 20 69 74 20 64 6f 65 73 6e 27 74 20 a if it doesn't
a500: 61 6c 72 65 61 64 79 20 65 78 69 73 74 0a 09 3b already exist..;
a510: 3b 20 28 69 66 20 28 6e 6f 74 20 63 78 74 29 28 ; (if (not cxt)(
a520: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
a530: 2a 63 6f 6e 74 65 78 74 73 2a 20 74 6f 70 70 61 *contexts* toppa
a540: 74 68 20 28 6d 61 6b 65 2d 63 78 74 29 29 29 0a th (make-cxt))).
a550: 09 0a 09 3b 3b 20 28 70 72 69 6e 74 20 22 72 75 ...;; (print "ru
a560: 6e 6e 61 6d 65 3a 20 22 20 72 75 6e 6e 61 6d 65 nname: " runname
a570: 20 22 20 74 61 72 67 65 74 3a 20 22 20 74 61 72 " target: " tar
a580: 67 65 74 20 22 20 6d 74 63 61 63 68 65 66 3a 20 get " mtcachef:
a590: 22 20 6d 74 63 61 63 68 65 66 20 22 20 72 63 63 " mtcachef " rcc
a5a0: 61 63 68 65 66 3a 20 22 20 72 63 63 61 63 68 65 achef: " rccache
a5b0: 66 29 0a 09 28 73 65 74 21 20 2a 74 6f 70 70 61 f)..(set! *toppa
a5c0: 74 68 2a 20 74 6f 70 70 61 74 68 29 20 3b 3b 20 th* toppath) ;;
a5d0: 54 68 69 73 20 69 73 20 6e 65 65 64 65 64 20 77 This is needed w
a5e0: 68 65 6e 20 77 65 20 61 72 65 20 72 75 6e 6e 69 hen we are runni
a5f0: 6e 67 20 61 73 20 61 20 74 65 73 74 20 75 73 69 ng as a test usi
a600: 6e 67 20 43 4d 44 49 4e 46 4f 20 61 73 20 61 20 ng CMDINFO as a
a610: 64 61 74 61 73 6f 75 72 63 65 0a 09 28 63 6f 6e datasource..(con
a620: 64 0a 09 20 3b 3b 20 69 66 20 6d 74 63 61 63 68 d.. ;; if mtcach
a630: 65 66 20 65 78 69 73 74 73 20 6a 75 73 74 20 72 ef exists just r
a640: 65 61 64 20 69 74 2c 20 68 6f 77 65 76 65 72 20 ead it, however
a650: 77 65 20 6e 65 65 64 20 74 6f 20 61 73 73 75 6d we need to assum
a660: 65 20 74 6f 70 70 61 74 68 20 69 73 20 61 76 61 e toppath is ava
a670: 69 6c 61 62 6c 65 20 69 6e 20 24 4d 54 5f 52 55 ilable in $MT_RU
a680: 4e 5f 41 52 45 41 5f 48 4f 4d 45 0a 09 20 28 28 N_AREA_HOME.. ((
a690: 61 6e 64 20 6d 74 63 61 63 68 65 66 20 28 63 6f and mtcachef (co
a6a0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
a6b0: 3f 20 6d 74 63 61 63 68 65 66 29 20 28 67 65 74 ? mtcachef) (get
a6c0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
a6d0: 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 5f 41 52 iable "MT_RUN_AR
a6e0: 45 41 5f 48 4f 4d 45 22 29 20 75 73 65 2d 63 61 EA_HOME") use-ca
a6f0: 63 68 65 29 0a 09 20 20 28 73 65 74 21 20 2a 63 che).. (set! *c
a700: 6f 6e 66 69 67 64 61 74 2a 20 20 20 20 28 63 6f onfigdat* (co
a710: 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 73 74 nfigf:read-alist
a720: 20 6d 74 63 61 63 68 65 66 29 29 0a 09 20 20 28 mtcachef)).. (
a730: 73 65 74 21 20 2a 72 75 6e 63 6f 6e 66 69 67 64 set! *runconfigd
a740: 61 74 2a 20 28 63 6f 6e 66 69 67 66 3a 72 65 61 at* (configf:rea
a750: 64 2d 61 6c 69 73 74 20 72 63 63 61 63 68 65 66 d-alist rccachef
a760: 29 29 0a 09 20 20 28 73 65 74 21 20 2a 63 6f 6e )).. (set! *con
a770: 66 69 67 69 6e 66 6f 2a 20 20 20 28 6c 69 73 74 figinfo* (list
a780: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 20 28 67 *configdat* (g
a790: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
a7a0: 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 5f ariable "MT_RUN_
a7b0: 41 52 45 41 5f 48 4f 4d 45 22 29 29 29 0a 09 20 AREA_HOME")))..
a7c0: 20 28 73 65 74 21 20 2a 63 6f 6e 66 69 67 73 74 (set! *configst
a7d0: 61 74 75 73 2a 20 27 66 75 6c 6c 64 61 74 61 29 atus* 'fulldata)
a7e0: 0a 09 20 20 28 73 65 74 21 20 2a 74 6f 70 70 61 .. (set! *toppa
a7f0: 74 68 2a 20 20 20 20 20 20 28 67 65 74 2d 65 6e th* (get-en
a800: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
a810: 6c 65 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f le "MT_RUN_AREA_
a820: 48 4f 4d 45 22 29 29 0a 09 20 20 2a 74 6f 70 70 HOME")).. *topp
a830: 61 74 68 2a 29 0a 09 20 3b 3b 20 77 65 20 68 61 ath*).. ;; we ha
a840: 76 65 20 61 6c 6c 20 74 68 65 20 69 6e 66 6f 20 ve all the info
a850: 6e 65 65 64 65 64 20 74 6f 20 66 75 6c 6c 79 20 needed to fully
a860: 70 72 6f 63 65 73 73 20 72 75 6e 63 6f 6e 66 69 process runconfi
a870: 67 73 20 61 6e 64 20 6d 65 67 61 74 65 73 74 2e gs and megatest.
a880: 63 6f 6e 66 69 67 0a 09 20 28 6d 74 63 61 63 68 config.. (mtcach
a890: 65 66 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ef
a8a0: 0a 09 20 20 28 6c 65 74 2a 20 28 28 66 69 72 73 .. (let* ((firs
a8b0: 74 2d 70 61 73 73 20 20 20 20 28 66 69 6e 64 2d t-pass (find-
a8c0: 61 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 67 20 and-read-config
a8d0: 20 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f 20 73 ;; NB// s
a8e0: 65 74 73 20 4d 54 5f 52 55 4e 5f 41 52 45 41 5f ets MT_RUN_AREA_
a8f0: 48 4f 4d 45 20 61 73 20 73 69 64 65 20 65 66 66 HOME as side eff
a900: 65 63 74 0a 09 09 09 09 20 6d 74 63 6f 6e 66 69 ect..... mtconfi
a910: 67 0a 09 09 09 09 20 65 6e 76 69 72 6f 6e 2d 70 g..... environ-p
a920: 61 74 74 3a 20 22 65 6e 76 2d 6f 76 65 72 72 69 att: "env-overri
a930: 64 65 22 0a 09 09 09 09 20 67 69 76 65 6e 2d 74 de"..... given-t
a940: 6f 70 70 61 74 68 3a 20 74 6f 70 70 61 74 68 0a oppath: toppath.
a950: 09 09 09 09 20 70 61 74 68 65 6e 76 76 61 72 3a .... pathenvvar:
a960: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
a970: 4d 45 22 29 29 0a 09 09 20 28 66 69 72 73 74 2d ME"))... (first-
a980: 72 75 6e 64 61 74 20 20 28 6c 65 74 20 28 28 74 rundat (let ((t
a990: 6f 70 70 61 74 68 20 28 69 66 20 74 6f 70 70 61 oppath (if toppa
a9a0: 74 68 20 0a 09 09 09 09 09 09 20 20 20 74 6f 70 th ....... top
a9b0: 70 61 74 68 0a 09 09 09 09 09 09 20 20 20 28 63 path....... (c
a9c0: 61 72 20 66 69 72 73 74 2d 70 61 73 73 29 29 29 ar first-pass)))
a9d0: 29 0a 09 09 09 09 20 20 28 72 65 61 64 2d 63 6f )..... (read-co
a9e0: 6e 66 69 67 20 3b 3b 20 28 63 6f 6e 63 20 74 6f nfig ;; (conc to
a9f0: 70 70 61 74 68 20 22 2f 72 75 6e 63 6f 6e 66 69 ppath "/runconfi
aa00: 67 73 2e 63 6f 6e 66 69 67 22 29 20 3b 3b 20 74 gs.config") ;; t
aa10: 68 69 73 20 73 68 6f 75 6c 64 20 62 65 20 63 6f his should be co
aa20: 6e 76 65 72 74 65 64 20 74 6f 20 72 75 6e 63 6f nverted to runco
aa30: 6e 66 69 67 3a 72 65 61 64 20 62 75 74 20 69 74 nfig:read but it
aa40: 20 69 73 20 6e 6f 6e 2d 74 72 69 76 69 61 6c 2c is non-trivial,
aa50: 20 6c 65 61 76 69 6e 67 20 69 74 20 66 6f 72 20 leaving it for
aa60: 6e 6f 77 2e 0a 09 09 09 09 20 20 20 28 63 6f 6e now...... (con
aa70: 63 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 74 c (if (string? t
aa80: 6f 70 70 61 74 68 29 0a 09 09 09 09 09 20 20 20 oppath)......
aa90: 20 20 74 6f 70 70 61 74 68 0a 09 09 09 09 09 20 toppath......
aaa0: 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (get-environ
aab0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
aac0: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
aad0: 29 29 0a 09 09 09 09 09 20 22 2f 72 75 6e 63 6f ))...... "/runco
aae0: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 0a 09 nfigs.config")..
aaf0: 09 09 09 20 20 20 2a 72 75 6e 63 6f 6e 66 69 67 ... *runconfig
ab00: 64 61 74 2a 20 23 74 20 0a 09 09 09 09 20 20 20 dat* #t .....
ab10: 73 65 63 74 69 6f 6e 73 3a 20 73 65 63 74 69 6f sections: sectio
ab20: 6e 73 29 29 29 29 0a 09 20 20 20 20 28 73 65 74 ns)))).. (set
ab30: 21 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a ! *runconfigdat*
ab40: 20 66 69 72 73 74 2d 72 75 6e 64 61 74 29 0a 09 first-rundat)..
ab50: 20 20 20 20 28 69 66 20 66 69 72 73 74 2d 70 61 (if first-pa
ab60: 73 73 20 20 3b 3b 20 0a 09 09 28 62 65 67 69 6e ss ;; ...(begin
ab70: 0a 09 09 20 20 28 73 65 74 21 20 2a 63 6f 6e 66 ... (set! *conf
ab80: 69 67 64 61 74 2a 20 20 28 63 61 72 20 66 69 72 igdat* (car fir
ab90: 73 74 2d 70 61 73 73 29 29 0a 09 09 20 20 28 73 st-pass))... (s
aba0: 65 74 21 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a et! *configinfo*
abb0: 20 66 69 72 73 74 2d 70 61 73 73 29 0a 09 09 20 first-pass)...
abc0: 20 28 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a (set! *toppath*
abd0: 20 20 20 20 28 6f 72 20 74 6f 70 70 61 74 68 20 (or toppath
abe0: 28 63 61 64 72 20 66 69 72 73 74 2d 70 61 73 73 (cadr first-pass
abf0: 29 29 29 20 3b 3b 20 75 73 65 20 74 68 65 20 67 ))) ;; use the g
ac00: 61 74 68 65 72 65 64 20 64 61 74 61 20 75 6e 6c athered data unl
ac10: 65 73 73 20 61 6c 72 65 61 64 79 20 68 61 76 65 ess already have
ac20: 20 69 74 0a 09 09 20 20 28 73 65 74 21 20 74 6f it... (set! to
ac30: 70 70 61 74 68 20 20 20 20 20 20 2a 74 6f 70 70 ppath *topp
ac40: 61 74 68 2a 29 0a 09 09 20 20 28 69 66 20 28 6e ath*)... (if (n
ac50: 6f 74 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 ot *toppath*)...
ac60: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
ac70: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
ac80: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
ac90: 67 2d 70 6f 72 74 2a 20 22 79 6f 75 20 61 72 65 g-port* "you are
aca0: 20 6e 6f 74 20 69 6e 20 61 20 6d 65 67 61 74 65 not in a megate
acb0: 73 74 20 61 72 65 61 21 22 29 0a 09 09 09 28 65 st area!")....(e
acc0: 78 69 74 20 31 29 29 29 0a 09 09 20 20 28 73 65 xit 1)))... (se
acd0: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 tenv "MT_RUN_ARE
ace0: 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 61 74 68 A_HOME" *toppath
acf0: 2a 29 0a 09 09 20 20 3b 3b 20 74 68 65 20 73 65 *)... ;; the se
ad00: 65 64 20 72 65 61 64 20 69 73 20 64 6f 6e 65 2c ed read is done,
ad10: 20 6e 6f 77 20 72 65 61 64 20 72 75 6e 63 6f 6e now read runcon
ad20: 66 69 67 73 2c 20 63 61 63 68 65 20 69 74 20 74 figs, cache it t
ad30: 68 65 6e 20 72 65 61 64 20 6d 65 67 61 74 65 73 hen read megates
ad40: 74 2e 63 6f 6e 66 69 67 20 6f 6e 65 20 6d 6f 72 t.config one mor
ad50: 65 20 74 69 6d 65 20 61 6e 64 20 63 61 63 68 65 e time and cache
ad60: 20 69 74 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 it... (let* ((
ad70: 6b 65 79 73 20 20 20 20 20 20 20 20 20 28 72 6d keys (rm
ad80: 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 09 09 t:get-keys))....
ad90: 20 28 6b 65 79 2d 76 61 6c 73 20 20 20 20 20 28 (key-vals (
ada0: 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 keys:target->key
adb0: 76 61 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 val keys target)
adc0: 29 0a 09 09 09 20 28 6c 69 6e 6b 74 72 65 65 20 ).... (linktree
add0: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
ade0: 6c 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 28 6f linktree)) ;; (o
adf0: 72 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 r (getenv "MT_LI
ae00: 4e 4b 54 52 45 45 22 29 28 69 66 20 2a 63 6f 6e NKTREE")(if *con
ae10: 66 69 67 64 61 74 2a 20 28 63 6f 6e 66 69 67 66 figdat* (configf
ae20: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
ae30: 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 69 6e at* "setup" "lin
ae40: 6b 74 72 65 65 22 29 20 23 66 29 29 29 0a 09 09 ktree") #f)))...
ae50: 09 09 09 3b 20 20 20 20 20 28 69 66 20 2a 63 6f ...; (if *co
ae60: 6e 66 69 67 64 61 74 2a 0a 09 09 09 09 09 3b 20 nfigdat*......;
ae70: 09 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f . (configf:loo
ae80: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
ae90: 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 "setup" "linktre
aea0: 65 22 29 0a 09 09 09 09 09 3b 20 09 20 20 20 28 e")......; . (
aeb0: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
aec0: 2f 6c 74 22 29 29 29 29 0a 09 09 09 20 28 73 65 /lt")))).... (se
aed0: 63 6f 6e 64 2d 70 61 73 73 20 20 28 66 69 6e 64 cond-pass (find
aee0: 2d 61 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 67 -and-read-config
aef0: 0a 09 09 09 09 09 6d 74 63 6f 6e 66 69 67 0a 09 ......mtconfig..
af00: 09 09 09 09 65 6e 76 69 72 6f 6e 2d 70 61 74 74 ....environ-patt
af10: 3a 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 65 22 : "env-override"
af20: 0a 09 09 09 09 09 67 69 76 65 6e 2d 74 6f 70 70 ......given-topp
af30: 61 74 68 3a 20 74 6f 70 70 61 74 68 0a 09 09 09 ath: toppath....
af40: 09 09 70 61 74 68 65 6e 76 76 61 72 3a 20 22 4d ..pathenvvar: "M
af50: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
af60: 29 29 0a 09 09 09 20 28 72 75 6e 63 6f 6e 66 69 )).... (runconfi
af70: 67 64 61 74 20 28 62 65 67 69 6e 20 20 20 20 20 gdat (begin
af80: 3b 3b 20 74 68 69 73 20 72 65 61 64 20 6f 66 20 ;; this read of
af90: 74 68 65 20 72 75 6e 63 6f 6e 66 69 67 73 20 77 the runconfigs w
afa0: 69 6c 6c 20 73 65 65 20 61 6e 79 20 61 64 6a 75 ill see any adju
afb0: 73 74 6d 65 6e 74 73 20 6d 61 64 65 20 62 79 20 stments made by
afc0: 72 65 2d 72 65 61 64 69 6e 67 20 6d 65 67 61 74 re-reading megat
afd0: 65 73 74 2e 63 6f 6e 66 69 67 0a 09 09 09 09 09 est.config......
afe0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
aff0: 64 61 20 28 6b 74 29 0a 09 09 09 09 09 09 20 20 da (kt).......
b000: 20 20 20 28 73 65 74 65 6e 76 20 28 63 61 72 20 (setenv (car
b010: 6b 74 29 20 28 63 61 64 72 20 6b 74 29 29 29 0a kt) (cadr kt))).
b020: 09 09 09 09 09 09 20 20 20 6b 65 79 2d 76 61 6c ...... key-val
b030: 73 29 0a 09 09 09 09 09 20 28 72 65 61 64 2d 63 s)...... (read-c
b040: 6f 6e 66 69 67 20 28 63 6f 6e 63 20 74 6f 70 70 onfig (conc topp
b050: 61 74 68 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 ath "/runconfigs
b060: 2e 63 6f 6e 66 69 67 22 29 20 2a 72 75 6e 63 6f .config") *runco
b070: 6e 66 69 67 64 61 74 2a 20 23 74 20 3b 3b 20 63 nfigdat* #t ;; c
b080: 6f 6e 73 69 64 65 72 20 75 73 69 6e 67 20 72 75 onsider using ru
b090: 6e 63 6f 6e 66 69 67 3a 72 65 61 64 20 73 6f 6d nconfig:read som
b0a0: 65 20 64 61 79 20 2e 2e 2e 0a 09 09 09 09 09 09 e day ..........
b0b0: 20 20 20 20 20 20 73 65 63 74 69 6f 6e 73 3a 20 sections:
b0c0: 73 65 63 74 69 6f 6e 73 29 29 29 29 0a 09 09 20 sections))))...
b0d0: 20 20 20 28 69 66 20 63 61 6e 63 72 65 61 74 65 (if cancreate
b0e0: 20 28 63 6f 6e 66 69 67 66 3a 77 72 69 74 65 2d (configf:write-
b0f0: 61 6c 69 73 74 20 72 75 6e 63 6f 6e 66 69 67 64 alist runconfigd
b100: 61 74 20 72 63 63 61 63 68 65 66 29 29 0a 09 09 at rccachef))...
b110: 20 20 20 20 28 73 65 74 21 20 2a 72 75 6e 63 6f (set! *runco
b120: 6e 66 69 67 64 61 74 2a 20 72 75 6e 63 6f 6e 66 nfigdat* runconf
b130: 69 67 64 61 74 29 0a 09 09 20 20 20 20 28 69 66 igdat)... (if
b140: 20 63 61 6e 63 72 65 61 74 65 20 28 63 6f 6e 66 cancreate (conf
b150: 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 74 20 igf:write-alist
b160: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 6d 74 63 61 *configdat* mtca
b170: 63 68 65 66 29 29 0a 09 09 20 20 20 20 28 69 66 chef))... (if
b180: 20 63 61 6e 63 72 65 61 74 65 20 28 73 65 74 21 cancreate (set!
b190: 20 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 *configstatus*
b1a0: 27 66 75 6c 6c 64 61 74 61 29 29 29 29 0a 09 09 'fulldata))))...
b1b0: 3b 3b 20 6e 6f 20 63 6f 6e 66 69 67 73 20 66 6f ;; no configs fo
b1c0: 75 6e 64 3f 20 73 68 6f 75 6c 64 20 6e 6f 74 20 und? should not
b1d0: 68 61 70 70 65 6e 20 62 75 74 20 6c 65 74 27 73 happen but let's
b1e0: 20 74 72 79 20 74 6f 20 72 65 63 6f 76 65 72 20 try to recover
b1f0: 67 72 61 63 65 66 75 6c 6c 79 2c 20 72 65 74 75 gracefully, retu
b200: 72 6e 20 61 6e 20 65 6d 70 74 79 20 68 61 73 68 rn an empty hash
b210: 2d 74 61 62 6c 65 0a 09 09 28 73 65 74 21 20 2a -table...(set! *
b220: 63 6f 6e 66 69 67 64 61 74 2a 20 28 6d 61 6b 65 configdat* (make
b230: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 09 -hash-table))...
b240: 29 29 29 0a 09 20 3b 3b 20 65 6c 73 65 20 72 65 ))).. ;; else re
b250: 61 64 20 77 68 61 74 20 79 6f 75 20 63 61 6e 20 ad what you can
b260: 61 6e 64 20 73 65 74 20 74 68 65 20 66 6c 61 67 and set the flag
b270: 20 61 63 63 6f 72 64 69 6e 67 6c 79 0a 09 20 28 accordingly.. (
b280: 65 6c 73 65 0a 09 20 20 28 6c 65 74 2a 20 28 28 else.. (let* ((
b290: 63 66 67 64 61 74 20 20 20 28 66 69 6e 64 2d 61 cfgdat (find-a
b2a0: 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 67 20 0a nd-read-config .
b2b0: 09 09 09 20 20 20 20 28 6f 72 20 28 61 72 67 73 ... (or (args
b2c0: 3a 67 65 74 2d 61 72 67 20 22 2d 63 6f 6e 66 69 :get-arg "-confi
b2d0: 67 22 29 20 22 6d 65 67 61 74 65 73 74 2e 63 6f g") "megatest.co
b2e0: 6e 66 69 67 22 29 0a 09 09 09 20 20 20 20 65 6e nfig").... en
b2f0: 76 69 72 6f 6e 2d 70 61 74 74 3a 20 22 65 6e 76 viron-patt: "env
b300: 2d 6f 76 65 72 72 69 64 65 22 0a 09 09 09 20 20 -override"....
b310: 20 20 67 69 76 65 6e 2d 74 6f 70 70 61 74 68 3a given-toppath:
b320: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
b330: 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 t-variable "MT_R
b340: 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 0a 09 UN_AREA_HOME")..
b350: 09 09 20 20 20 20 70 61 74 68 65 6e 76 76 61 72 .. pathenvvar
b360: 3a 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 : "MT_RUN_AREA_H
b370: 4f 4d 45 22 29 29 29 0a 09 20 20 20 20 28 69 66 OME"))).. (if
b380: 20 63 66 67 64 61 74 0a 09 09 28 6c 65 74 2a 20 cfgdat...(let*
b390: 28 28 74 6f 70 70 61 74 68 20 20 28 6f 72 20 28 ((toppath (or (
b3a0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
b3b0: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e variable "MT_RUN
b3c0: 5f 41 52 45 41 5f 48 4f 4d 45 22 29 28 63 61 64 _AREA_HOME")(cad
b3d0: 72 20 63 66 67 64 61 74 29 29 29 0a 09 09 20 20 r cfgdat)))...
b3e0: 20 20 20 20 20 28 72 64 61 74 20 20 20 20 20 28 (rdat (
b3f0: 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e read-config (con
b400: 63 20 74 6f 70 70 61 74 68 20 20 3b 3b 20 63 6f c toppath ;; co
b410: 6e 76 65 72 74 20 74 68 69 73 20 74 6f 20 75 73 nvert this to us
b420: 65 20 72 75 6e 63 6f 6e 66 69 67 3a 72 65 61 64 e runconfig:read
b430: 21 0a 09 09 09 09 09 09 20 20 20 20 22 2f 72 75 !....... "/ru
b440: 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 nconfigs.config"
b450: 29 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a ) *runconfigdat*
b460: 20 23 74 20 73 65 63 74 69 6f 6e 73 3a 20 73 65 #t sections: se
b470: 63 74 69 6f 6e 73 29 29 29 0a 09 09 20 20 28 73 ctions)))... (s
b480: 65 74 21 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a et! *configinfo*
b490: 20 20 20 63 66 67 64 61 74 29 0a 09 09 20 20 28 cfgdat)... (
b4a0: 73 65 74 21 20 2a 63 6f 6e 66 69 67 64 61 74 2a set! *configdat*
b4b0: 20 20 20 20 28 63 61 72 20 63 66 67 64 61 74 29 (car cfgdat)
b4c0: 29 0a 09 09 20 20 28 73 65 74 21 20 2a 72 75 6e )... (set! *run
b4d0: 63 6f 6e 66 69 67 64 61 74 2a 20 72 64 61 74 29 configdat* rdat)
b4e0: 0a 09 09 20 20 28 73 65 74 21 20 2a 74 6f 70 70 ... (set! *topp
b4f0: 61 74 68 2a 20 20 20 20 20 20 74 6f 70 70 61 74 ath* toppat
b500: 68 29 0a 09 09 20 20 28 73 65 74 21 20 2a 63 6f h)... (set! *co
b510: 6e 66 69 67 73 74 61 74 75 73 2a 20 27 70 61 72 nfigstatus* 'par
b520: 74 69 61 6c 29 29 0a 09 09 28 62 65 67 69 6e 0a tial))...(begin.
b530: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
b540: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
b550: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 6f 20 t-log-port* "No
b560: 22 20 6d 74 63 6f 6e 66 69 67 20 22 20 66 69 6c " mtconfig " fil
b570: 65 20 66 6f 75 6e 64 2e 20 47 69 76 69 6e 67 20 e found. Giving
b580: 75 70 2e 22 29 0a 09 09 20 20 28 65 78 69 74 20 up.")... (exit
b590: 32 29 29 29 29 29 29 0a 09 3b 3b 20 61 64 64 69 2))))))..;; addi
b5a0: 74 69 6f 6e 61 6c 20 68 6f 75 73 65 20 6b 65 65 tional house kee
b5b0: 70 69 6e 67 0a 09 28 6c 65 74 2a 20 28 28 6c 69 ping..(let* ((li
b5c0: 6e 6b 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 67 nktree (common:g
b5d0: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 29 0a 09 et-linktree)))..
b5e0: 20 20 28 69 66 20 6c 69 6e 6b 74 72 65 65 0a 09 (if linktree..
b5f0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
b600: 69 66 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a if (not (common:
b610: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c 69 6e file-exists? lin
b620: 6b 74 72 65 65 29 29 0a 09 09 20 20 20 20 28 62 ktree))... (b
b630: 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 68 61 egin... (ha
b640: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
b650: 09 09 09 20 20 65 78 6e 0a 09 09 09 20 20 28 62 ... exn.... (b
b660: 65 67 69 6e 0a 09 09 09 20 20 20 20 28 64 65 62 egin.... (deb
b670: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
b680: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
b690: 72 74 2a 20 22 53 6f 6d 65 74 68 69 6e 67 20 77 rt* "Something w
b6a0: 65 6e 74 20 77 72 6f 6e 67 20 77 68 65 6e 20 74 ent wrong when t
b6b0: 72 79 69 6e 67 20 74 6f 20 63 72 65 61 74 65 20 rying to create
b6c0: 6c 69 6e 6b 74 72 65 65 20 64 69 72 20 61 74 20 linktree dir at
b6d0: 22 20 6c 69 6e 6b 74 72 65 65 29 0a 09 09 09 20 " linktree)....
b6e0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
b6f0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
b700: 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 ort* " message:
b710: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
b720: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
b730: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
b740: 78 6e 29 29 0a 09 09 09 20 20 20 20 28 65 78 69 xn)).... (exi
b750: 74 20 31 29 29 0a 09 09 09 28 63 72 65 61 74 65 t 1))....(create
b760: 2d 64 69 72 65 63 74 6f 72 79 20 6c 69 6e 6b 74 -directory linkt
b770: 72 65 65 20 23 74 29 29 29 29 0a 09 09 28 68 61 ree #t))))...(ha
b780: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
b790: 09 09 20 20 20 20 65 78 6e 0a 09 09 20 20 20 20 .. exn...
b7a0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 (begin... (
b7b0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
b7c0: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
b7d0: 2d 70 6f 72 74 2a 20 22 53 6f 6d 65 74 68 69 6e -port* "Somethin
b7e0: 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 77 68 65 g went wrong whe
b7f0: 6e 20 74 72 79 69 6e 67 20 74 6f 20 63 72 65 61 n trying to crea
b800: 74 65 20 6c 69 6e 6b 20 74 6f 20 6c 69 6e 6b 74 te link to linkt
b810: 72 65 65 20 61 74 20 22 20 2a 74 6f 70 70 61 74 ree at " *toppat
b820: 68 2a 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 h*)... (deb
b830: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
b840: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
b850: 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
b860: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
b870: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
b880: 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 0a 09 essage) exn)))..
b890: 09 20 20 28 6c 65 74 20 28 28 74 6c 69 6e 6b 20 . (let ((tlink
b8a0: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
b8b0: 22 2f 6c 74 22 29 29 29 0a 09 09 20 20 20 20 28 "/lt")))... (
b8c0: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 if (not (file-ex
b8d0: 69 73 74 73 3f 20 74 6c 69 6e 6b 29 29 0a 09 09 ists? tlink))...
b8e0: 09 28 63 72 65 61 74 65 2d 73 79 6d 62 6f 6c 69 .(create-symboli
b8f0: 63 2d 6c 69 6e 6b 20 6c 69 6e 6b 74 72 65 65 20 c-link linktree
b900: 74 6c 69 6e 6b 29 29 29 29 29 0a 09 20 20 20 20 tlink)))))..
b910: 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 (begin...(debu
b920: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
b930: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
b940: 74 2a 20 22 6c 69 6e 6b 74 72 65 65 20 6e 6f 74 t* "linktree not
b950: 20 64 65 66 69 6e 65 64 20 69 6e 20 5b 73 65 74 defined in [set
b960: 75 70 5d 20 73 65 63 74 69 6f 6e 20 6f 66 20 6d up] section of m
b970: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 egatest.config")
b980: 0a 09 09 29 29 29 0a 09 28 69 66 20 28 61 6e 64 ...)))..(if (and
b990: 20 2a 74 6f 70 70 61 74 68 2a 0a 09 09 20 28 64 *toppath*... (d
b9a0: 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f irectory-exists?
b9b0: 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 20 *toppath*))..
b9c0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
b9d0: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f (setenv "MT_RUN_
b9e0: 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 AREA_HOME" *topp
b9f0: 61 74 68 2a 29 0a 09 20 20 20 20 20 20 28 73 65 ath*).. (se
ba00: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 53 55 49 tenv "MT_TESTSUI
ba10: 54 45 4e 41 4d 45 22 20 28 63 6f 6d 6d 6f 6e 3a TENAME" (common:
ba20: 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 get-testsuite-na
ba30: 6d 65 29 29 29 0a 09 20 20 20 20 28 62 65 67 69 me))).. (begi
ba40: 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a n.. (debug:
ba50: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
ba60: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
ba70: 20 22 66 61 69 6c 65 64 20 74 6f 20 66 69 6e 64 "failed to find
ba80: 20 74 68 65 20 74 6f 70 20 70 61 74 68 20 74 6f the top path to
ba90: 20 79 6f 75 72 20 4d 65 67 61 74 65 73 74 20 61 your Megatest a
baa0: 72 65 61 2e 22 29 0a 09 20 20 20 20 20 20 3b 3b rea.").. ;;
bab0: 28 65 78 69 74 20 31 29 0a 09 20 20 20 20 20 20 (exit 1)..
bac0: 28 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 (set! *toppath*
bad0: 23 66 29 20 3b 3b 20 66 6f 72 63 65 20 69 74 20 #f) ;; force it
bae0: 74 6f 20 62 65 20 66 61 6c 73 65 20 73 6f 20 77 to be false so w
baf0: 65 20 72 65 74 75 72 6e 20 23 66 0a 09 20 20 20 e return #f..
bb00: 20 20 20 23 66 0a 09 20 20 20 20 20 20 29 29 0a #f.. )).
bb10: 09 3b 3b 20 69 66 20 68 61 76 65 20 2d 61 70 70 .;; if have -app
bb20: 65 6e 64 2d 63 6f 6e 66 69 67 20 74 68 65 6e 20 end-config then
bb30: 72 65 61 64 20 61 6e 64 20 61 70 70 65 6e 64 20 read and append
bb40: 68 65 72 65 0a 09 28 6c 65 74 20 28 28 63 66 6e here..(let ((cfn
bb50: 61 6d 65 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ame (args:get-ar
bb60: 67 20 22 2d 61 70 70 65 6e 64 2d 63 6f 6e 66 69 g "-append-confi
bb70: 67 22 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e g"))).. (if (an
bb80: 64 20 63 66 6e 61 6d 65 0a 09 09 20 20 20 28 66 d cfname... (f
bb90: 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 73 73 3f ile-read-access?
bba0: 20 63 66 6e 61 6d 65 29 29 0a 09 20 20 20 20 20 cfname))..
bbb0: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 63 66 (read-config cf
bbc0: 6e 61 6d 65 20 2a 63 6f 6e 66 69 67 64 61 74 2a name *configdat*
bbd0: 20 23 74 29 29 29 20 3b 3b 20 76 61 6c 75 65 73 #t))) ;; values
bbe0: 20 61 72 65 20 61 64 64 65 64 20 74 6f 20 74 68 are added to th
bbf0: 65 20 68 61 73 68 2c 20 6e 6f 20 6e 65 65 64 20 e hash, no need
bc00: 74 6f 20 64 6f 20 61 6e 79 74 68 69 6e 67 20 73 to do anything s
bc10: 70 65 63 69 61 6c 2e 0a 09 2a 74 6f 70 70 61 74 pecial...*toppat
bc20: 68 2a 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 h*)))..(define (
bc30: 67 65 74 2d 62 65 73 74 2d 64 69 73 6b 20 63 6f get-best-disk co
bc40: 6e 66 64 61 74 20 74 65 73 74 63 6f 6e 66 69 67 nfdat testconfig
bc50: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 73 6b ). (let* ((disk
bc60: 73 20 20 20 28 6f 72 20 28 61 6e 64 20 74 65 73 s (or (and tes
bc70: 74 63 6f 6e 66 69 67 20 28 68 61 73 68 2d 74 61 tconfig (hash-ta
bc80: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
bc90: 74 65 73 74 63 6f 6e 66 69 67 20 22 64 69 73 6b testconfig "disk
bca0: 73 22 20 23 66 29 29 0a 09 09 20 20 20 20 20 20 s" #f))...
bcb0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
bcc0: 64 65 66 61 75 6c 74 20 63 6f 6e 66 64 61 74 20 default confdat
bcd0: 22 64 69 73 6b 73 22 20 23 66 29 29 29 0a 09 20 "disks" #f)))..
bce0: 28 6d 69 6e 73 70 61 63 65 20 28 6c 65 74 20 28 (minspace (let (
bcf0: 28 6d 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b (m (configf:look
bd00: 75 70 20 63 6f 6e 66 64 61 74 20 22 73 65 74 75 up confdat "setu
bd10: 70 22 20 22 6d 69 6e 73 70 61 63 65 22 29 29 29 p" "minspace")))
bd20: 0a 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 2d ... (string-
bd30: 3e 6e 75 6d 62 65 72 20 28 6f 72 20 6d 20 22 31 >number (or m "1
bd40: 30 30 30 30 22 29 29 29 29 29 0a 20 20 20 20 28 0000"))))). (
bd50: 69 66 20 64 69 73 6b 73 20 0a 09 28 6c 65 74 20 if disks ..(let
bd60: 28 28 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 ((res (common:ge
bd70: 74 2d 64 69 73 6b 2d 77 69 74 68 2d 6d 6f 73 74 t-disk-with-most
bd80: 2d 66 72 65 65 2d 73 70 61 63 65 20 64 69 73 6b -free-space disk
bd90: 73 20 6d 69 6e 73 70 61 63 65 29 29 29 20 3b 3b s minspace))) ;;
bda0: 20 6d 69 6e 20 73 69 7a 65 20 6f 66 20 31 30 30 min size of 100
bdb0: 30 2c 20 73 65 65 6d 73 20 74 61 64 20 64 75 6d 0, seems tad dum
bdc0: 62 0a 09 20 20 28 69 66 20 72 65 73 0a 09 20 20 b.. (if res..
bdd0: 20 20 20 20 28 63 64 72 20 72 65 73 29 0a 09 20 (cdr res)..
bde0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 69 (begin...(i
bdf0: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
be00: 69 73 65 2d 70 72 69 6e 74 20 32 30 20 22 4e 6f ise-print 20 "No
be10: 20 76 61 6c 69 64 20 64 69 73 6b 73 20 6f 72 20 valid disks or
be20: 6e 6f 20 64 69 73 6b 20 77 69 74 68 20 65 6e 6f no disk with eno
be30: 75 67 68 20 73 70 61 63 65 22 29 0a 09 09 20 20 ugh space")...
be40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
be50: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
be60: 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 6f 20 76 61 log-port* "No va
be70: 6c 69 64 20 64 69 73 6b 73 20 66 6f 75 6e 64 20 lid disks found
be80: 69 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 in megatest.conf
be90: 69 67 2e 20 50 6c 65 61 73 65 20 61 64 64 20 73 ig. Please add s
bea0: 6f 6d 65 20 74 6f 20 79 6f 75 72 20 5b 64 69 73 ome to your [dis
beb0: 6b 73 5d 20 73 65 63 74 69 6f 6e 20 61 6e 64 20 ks] section and
bec0: 65 6e 73 75 72 65 20 74 68 65 20 64 69 72 65 63 ensure the direc
bed0: 74 6f 72 79 20 65 78 69 73 74 73 20 61 6e 64 20 tory exists and
bee0: 68 61 73 20 65 6e 6f 75 67 68 20 73 70 61 63 65 has enough space
bef0: 21 5c 6e 20 20 20 20 59 6f 75 20 63 61 6e 20 63 !\n You can c
bf00: 68 61 6e 67 65 20 6d 69 6e 73 70 61 63 65 20 69 hange minspace i
bf10: 6e 20 74 68 65 20 5b 73 65 74 75 70 5d 20 73 65 n the [setup] se
bf20: 63 74 69 6f 6e 20 6f 66 20 6d 65 67 61 74 65 73 ction of megates
bf30: 74 2e 63 6f 6e 66 69 67 2e 20 43 75 72 72 65 6e t.config. Curren
bf40: 74 20 73 65 74 74 69 6e 67 20 69 73 3a 20 22 20 t setting is: "
bf50: 6d 69 6e 73 70 61 63 65 29 29 0a 09 09 28 65 78 minspace))...(ex
bf60: 69 74 20 31 29 29 29 29 29 29 29 20 3b 3b 20 54 it 1))))))) ;; T
bf70: 4f 44 4f 20 2d 20 6d 6f 76 65 20 74 68 65 20 65 ODO - move the e
bf80: 78 69 74 20 74 6f 20 74 68 65 20 63 61 6c 6c 69 xit to the calli
bf90: 6e 67 20 6c 6f 63 61 74 69 6f 6e 20 61 6e 64 20 ng location and
bfa0: 72 65 74 75 72 6e 20 23 66 0a 0a 3b 3b 20 44 65 return #f..;; De
bfb0: 73 69 72 65 64 20 64 69 72 65 63 74 6f 72 79 20 sired directory
bfc0: 73 74 72 75 63 74 75 72 65 3a 0a 3b 3b 0a 3b 3b structure:.;;.;;
bfd0: 20 20 3c 6c 69 6e 6b 64 69 72 3e 20 2d 20 3c 74 <linkdir> - <t
bfe0: 61 72 67 65 74 3e 20 2d 20 3c 74 65 73 74 6e 61 arget> - <testna
bff0: 6d 65 3e 20 2d 2e 0a 3b 3b 20 20 20 20 20 20 20 me> -..;;
c000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7c 0a |.
c020: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
c030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c040: 20 20 20 20 20 20 20 76 0a 3b 3b 20 20 3c 72 75 v.;; <ru
c050: 6e 64 69 72 3e 20 20 2d 20 20 3c 74 61 72 67 65 ndir> - <targe
c060: 74 3e 20 20 2d 20 20 20 20 3c 74 65 73 74 6e 61 t> - <testna
c070: 6d 65 3e 20 2d 7c 2d 20 3c 69 74 65 6d 70 61 74 me> -|- <itempat
c080: 68 28 73 29 3e 0a 3b 3b 0a 3b 3b 20 20 64 69 72 h(s)>.;;.;; dir
c090: 20 73 74 6f 72 65 64 20 69 6e 20 74 65 73 74 20 stored in test
c0a0: 69 73 3a 0a 3b 3b 20 0a 3b 3b 20 20 3c 6c 69 6e is:.;; .;; <lin
c0b0: 6b 64 69 72 3e 20 2d 20 3c 74 61 72 67 65 74 3e kdir> - <target>
c0c0: 20 2d 20 3c 74 65 73 74 6e 61 6d 65 3e 20 5b 20 - <testname> [
c0d0: 2d 20 3c 69 74 65 6d 70 61 74 68 3e 20 5d 0a 3b - <itempath> ].;
c0e0: 3b 20 0a 3b 3b 20 41 6c 6c 20 6c 6f 67 20 66 69 ; .;; All log fi
c0f0: 6c 65 20 6c 69 6e 6b 73 20 73 68 6f 75 6c 64 20 le links should
c100: 62 65 20 73 74 6f 72 65 64 20 72 65 6c 61 74 69 be stored relati
c110: 76 65 20 74 6f 20 74 68 65 20 74 6f 70 20 6f 66 ve to the top of
c120: 20 6c 69 6e 6b 20 70 61 74 68 0a 3b 3b 20 20 0a link path.;; .
c130: 3b 3b 20 3c 74 61 72 67 65 74 3e 20 2d 20 3c 74 ;; <target> - <t
c140: 65 73 74 6e 61 6d 65 3e 20 5b 20 2d 20 3c 69 74 estname> [ - <it
c150: 65 6d 70 61 74 68 3e 20 5d 20 0a 3b 3b 0a 28 64 empath> ] .;;.(d
c160: 65 66 69 6e 65 20 28 63 72 65 61 74 65 2d 77 6f efine (create-wo
c170: 72 6b 2d 61 72 65 61 20 72 75 6e 2d 69 64 20 72 rk-area run-id r
c180: 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 6c 73 20 un-info keyvals
c190: 74 65 73 74 2d 69 64 20 74 65 73 74 2d 73 72 63 test-id test-src
c1a0: 2d 70 61 74 68 20 64 69 73 6b 2d 70 61 74 68 20 -path disk-path
c1b0: 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 testname itemdat
c1c0: 20 23 21 6b 65 79 20 28 72 65 6d 74 72 69 65 73 #!key (remtries
c1d0: 20 32 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 2)). (let* ((i
c1e0: 74 65 6d 2d 70 61 74 68 20 28 69 66 20 28 73 74 tem-path (if (st
c1f0: 72 69 6e 67 3f 20 69 74 65 6d 64 61 74 29 20 69 ring? itemdat) i
c200: 74 65 6d 64 61 74 20 28 69 74 65 6d 2d 6c 69 73 temdat (item-lis
c210: 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 t->path itemdat)
c220: 29 29 20 3b 3b 20 69 66 20 70 61 73 73 20 69 6e )) ;; if pass in
c230: 20 73 74 72 69 6e 67 20 2d 20 6a 75 73 74 20 75 string - just u
c240: 73 65 20 69 74 0a 09 20 28 72 75 6e 6e 61 6d 65 se it.. (runname
c250: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 (if (string?
c260: 72 75 6e 2d 69 6e 66 6f 29 20 3b 3b 20 69 66 20 run-info) ;; if
c270: 77 65 20 70 61 73 73 20 69 6e 20 61 20 73 74 72 we pass in a str
c280: 69 6e 67 20 61 73 20 72 75 6e 2d 69 6e 66 6f 20 ing as run-info
c290: 75 73 65 20 69 74 20 61 73 20 72 75 6e 2d 6e 61 use it as run-na
c2a0: 6d 65 2e 0a 09 09 09 72 75 6e 2d 69 6e 66 6f 0a me.....run-info.
c2b0: 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 65 ...(db:get-value
c2c0: 2d 62 79 2d 68 65 61 64 65 72 20 28 64 62 3a 67 -by-header (db:g
c2d0: 65 74 2d 72 6f 77 73 20 72 75 6e 2d 69 6e 66 6f et-rows run-info
c2e0: 29 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 2d ).......(db:get-
c2f0: 68 65 61 64 65 72 20 72 75 6e 2d 69 6e 66 6f 29 header run-info)
c300: 0a 09 09 09 09 09 09 22 72 75 6e 6e 61 6d 65 22 ......."runname"
c310: 29 29 29 0a 09 20 28 63 6f 6e 74 6f 75 72 20 20 ))).. (contour
c320: 20 23 66 29 20 3b 3b 20 4e 4f 54 20 52 45 41 44 #f) ;; NOT READ
c330: 59 20 46 4f 52 20 54 48 49 53 20 28 61 72 67 73 Y FOR THIS (args
c340: 3a 67 65 74 2d 61 72 67 20 22 2d 63 6f 6e 74 6f :get-arg "-conto
c350: 75 72 22 29 29 0a 09 20 3b 3b 20 63 6f 6e 76 65 ur")).. ;; conve
c360: 72 74 20 62 61 63 6b 20 74 6f 20 64 62 3a 20 66 rt back to db: f
c370: 72 6f 6d 20 72 64 62 3a 20 2d 20 74 68 69 73 20 rom rdb: - this
c380: 69 73 20 61 6c 77 61 79 73 20 72 75 6e 20 61 74 is always run at
c390: 20 73 65 72 76 65 72 20 65 6e 64 0a 09 20 28 74 server end.. (t
c3a0: 61 72 67 65 74 20 20 20 28 73 74 72 69 6e 67 2d arget (string-
c3b0: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
c3c0: 20 63 61 64 72 20 6b 65 79 76 61 6c 73 29 20 22 cadr keyvals) "
c3d0: 2f 22 29 29 0a 0a 09 20 28 6e 6f 74 2d 69 74 65 /"))... (not-ite
c3e0: 72 61 74 65 64 20 20 28 65 71 75 61 6c 3f 20 22 rated (equal? "
c3f0: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 0a 09 " item-path))...
c400: 20 3b 3b 20 61 6c 6c 20 74 65 73 74 73 20 61 72 ;; all tests ar
c410: 65 20 66 6f 75 6e 64 20 61 74 20 3c 72 75 6e 64 e found at <rund
c420: 69 72 3e 2f 74 65 73 74 2d 62 61 73 65 20 6f 72 ir>/test-base or
c430: 20 3c 6c 69 6e 6b 64 69 72 3e 2f 74 65 73 74 2d <linkdir>/test-
c440: 62 61 73 65 0a 09 20 28 74 65 73 74 74 6f 70 2d base.. (testtop-
c450: 62 61 73 65 20 28 63 6f 6e 63 20 74 61 72 67 65 base (conc targe
c460: 74 20 22 2f 22 20 72 75 6e 6e 61 6d 65 20 22 2f t "/" runname "/
c470: 22 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 20 28 " testname)).. (
c480: 74 65 73 74 2d 62 61 73 65 20 20 20 20 28 63 6f test-base (co
c490: 6e 63 20 74 65 73 74 74 6f 70 2d 62 61 73 65 20 nc testtop-base
c4a0: 28 69 66 20 6e 6f 74 2d 69 74 65 72 61 74 65 64 (if not-iterated
c4b0: 20 22 22 20 22 2f 22 29 20 69 74 65 6d 2d 70 61 "" "/") item-pa
c4c0: 74 68 29 29 0a 0a 09 20 3b 3b 20 6e 62 2f 2f 20 th))... ;; nb//
c4d0: 69 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 6e if itempath is n
c4e0: 6f 74 20 22 22 20 74 68 65 6e 20 69 74 20 69 73 ot "" then it is
c4f0: 20 70 72 65 66 69 78 65 64 20 77 69 74 68 20 22 prefixed with "
c500: 2f 22 0a 09 20 28 74 6f 70 74 65 73 74 2d 70 61 /".. (toptest-pa
c510: 74 68 20 28 63 6f 6e 63 20 64 69 73 6b 2d 70 61 th (conc disk-pa
c520: 74 68 20 28 69 66 20 63 6f 6e 74 6f 75 72 20 28 th (if contour (
c530: 63 6f 6e 63 20 22 2f 22 20 63 6f 6e 74 6f 75 72 conc "/" contour
c540: 29 20 22 22 29 20 22 2f 22 20 74 65 73 74 74 6f ) "") "/" testto
c550: 70 2d 62 61 73 65 29 29 0a 09 20 28 74 65 73 74 p-base)).. (test
c560: 2d 70 61 74 68 20 20 20 20 28 63 6f 6e 63 20 64 -path (conc d
c570: 69 73 6b 2d 70 61 74 68 20 28 69 66 20 63 6f 6e isk-path (if con
c580: 74 6f 75 72 20 28 63 6f 6e 63 20 22 2f 22 20 63 tour (conc "/" c
c590: 6f 6e 74 6f 75 72 29 20 22 22 29 20 22 2f 22 20 ontour) "") "/"
c5a0: 74 65 73 74 2d 62 61 73 65 29 29 0a 0a 09 20 3b test-base))... ;
c5b0: 3b 20 65 6e 73 75 72 65 20 74 68 69 73 20 65 78 ; ensure this ex
c5c0: 69 73 74 73 20 66 69 72 73 74 20 61 73 20 6c 69 ists first as li
c5d0: 6e 6b 73 20 74 6f 20 73 75 62 74 65 73 74 73 20 nks to subtests
c5e0: 6d 75 73 74 20 62 65 20 63 72 65 61 74 65 64 20 must be created
c5f0: 74 68 65 72 65 0a 09 20 28 6c 69 6e 6b 74 72 65 there.. (linktre
c600: 65 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c e (common:get-l
c610: 69 6e 6b 74 72 65 65 29 29 0a 09 20 3b 3b 20 57 inktree)).. ;; W
c620: 41 53 3a 20 28 6c 65 74 20 28 28 72 64 20 28 63 AS: (let ((rd (c
c630: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f onfig-lookup *co
c640: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
c650: 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 0a 09 "linktree")))..
c660: 20 3b 3b 20 20 20 20 20 20 20 20 20 28 69 66 20 ;; (if
c670: 72 64 20 72 64 20 28 63 6f 6e 63 20 2a 74 6f 70 rd rd (conc *top
c680: 70 61 74 68 2a 20 22 2f 72 75 6e 73 22 29 29 29 path* "/runs")))
c690: 29 0a 09 20 3b 3b 20 77 68 69 63 68 20 73 65 65 ).. ;; which see
c6a0: 6d 73 20 77 72 6f 6e 67 20 2e 2e 2e 0a 0a 09 20 ms wrong ......
c6b0: 28 6c 6e 6b 62 61 73 65 20 20 20 28 63 6f 6e 63 (lnkbase (conc
c6c0: 20 6c 69 6e 6b 74 72 65 65 20 28 69 66 20 63 6f linktree (if co
c6d0: 6e 74 6f 75 72 20 28 63 6f 6e 63 20 22 2f 22 20 ntour (conc "/"
c6e0: 63 6f 6e 74 6f 75 72 29 20 22 22 29 20 22 2f 22 contour) "") "/"
c6f0: 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 6e target "/" runn
c700: 61 6d 65 29 29 0a 09 20 28 6c 6e 6b 70 61 74 68 ame)).. (lnkpath
c710: 20 20 20 28 63 6f 6e 63 20 6c 6e 6b 62 61 73 65 (conc lnkbase
c720: 20 22 2f 22 20 74 65 73 74 6e 61 6d 65 29 29 0a "/" testname)).
c730: 09 20 28 6c 6e 6b 70 61 74 68 66 20 20 28 63 6f . (lnkpathf (co
c740: 6e 63 20 6c 6e 6b 70 61 74 68 20 28 69 66 20 6e nc lnkpath (if n
c750: 6f 74 2d 69 74 65 72 61 74 65 64 20 22 22 20 22 ot-iterated "" "
c760: 2f 22 29 20 69 74 65 6d 2d 70 61 74 68 29 29 0a /") item-path)).
c770: 09 20 28 6c 6e 6b 74 61 72 67 65 74 20 28 63 6f . (lnktarget (co
c780: 6e 63 20 6c 6e 6b 70 61 74 68 20 22 2f 22 20 69 nc lnkpath "/" i
c790: 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a 20 20 20 tem-path)))..
c7a0: 20 3b 3b 20 55 70 64 61 74 65 20 74 68 65 20 72 ;; Update the r
c7b0: 75 6e 64 69 72 20 70 61 74 68 20 69 6e 20 74 68 undir path in th
c7c0: 65 20 74 65 73 74 20 72 65 63 6f 72 64 20 66 6f e test record fo
c7d0: 72 20 61 6c 6c 2c 20 72 75 6e 64 69 72 3d 70 68 r all, rundir=ph
c7e0: 79 73 69 63 61 6c 2c 20 73 68 6f 72 74 64 69 72 ysical, shortdir
c7f0: 3d 6c 6f 67 69 63 61 6c 0a 20 20 20 20 3b 3b 20 =logical. ;;
c800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c830: 72 75 6e 64 69 72 20 20 20 73 68 6f 72 74 64 69 rundir shortdi
c840: 72 0a 20 20 20 20 28 72 6d 74 3a 67 65 6e 65 72 r. (rmt:gener
c850: 61 6c 2d 63 61 6c 6c 20 27 74 65 73 74 2d 73 65 al-call 'test-se
c860: 74 2d 72 75 6e 64 69 72 2d 73 68 6f 72 74 64 69 t-rundir-shortdi
c870: 72 20 72 75 6e 2d 69 64 20 6c 6e 6b 70 61 74 68 r run-id lnkpath
c880: 66 20 74 65 73 74 2d 70 61 74 68 20 74 65 73 74 f test-path test
c890: 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 72 name item-path r
c8a0: 75 6e 2d 69 64 29 0a 0a 20 20 20 20 28 64 65 62 un-id).. (deb
c8b0: 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 ug:print 2 *defa
c8c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
c8d0: 4e 46 4f 3a 5c 6e 20 20 20 20 20 20 20 6c 6e 6b NFO:\n lnk
c8e0: 62 61 73 65 3d 22 20 6c 6e 6b 62 61 73 65 20 22 base=" lnkbase "
c8f0: 5c 6e 20 20 20 20 20 20 20 6c 6e 6b 70 61 74 68 \n lnkpath
c900: 3d 22 20 6c 6e 6b 70 61 74 68 20 22 5c 6e 20 20 =" lnkpath "\n
c910: 74 6f 70 74 65 73 74 2d 70 61 74 68 3d 22 20 74 toptest-path=" t
c920: 6f 70 74 65 73 74 2d 70 61 74 68 20 22 5c 6e 20 optest-path "\n
c930: 20 20 20 20 74 65 73 74 2d 70 61 74 68 3d 22 20 test-path="
c940: 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 28 test-path). (
c950: 69 66 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a if (not (common:
c960: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c 69 6e file-exists? lin
c970: 6b 74 72 65 65 29 29 0a 09 28 62 65 67 69 6e 0a ktree))..(begin.
c980: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
c990: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
c9a0: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6c ort* "WARNING: l
c9b0: 69 6e 6b 74 72 65 65 20 64 69 64 20 6e 6f 74 20 inktree did not
c9c0: 65 78 69 73 74 21 20 43 72 65 61 74 69 6e 67 20 exist! Creating
c9d0: 69 74 20 6e 6f 77 20 61 74 20 22 20 6c 69 6e 6b it now at " link
c9e0: 74 72 65 65 29 0a 09 20 20 28 63 72 65 61 74 65 tree).. (create
c9f0: 2d 64 69 72 65 63 74 6f 72 79 20 6c 69 6e 6b 74 -directory linkt
ca00: 72 65 65 20 23 74 29 29 29 20 3b 3b 20 28 73 79 ree #t))) ;; (sy
ca10: 73 74 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 stem (conc "mkdi
ca20: 72 20 2d 70 20 22 20 6c 69 6e 6b 74 72 65 65 29 r -p " linktree)
ca30: 29 29 29 0a 20 20 20 20 3b 3b 20 63 72 65 61 74 ))). ;; creat
ca40: 65 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 e the directory
ca50: 66 6f 72 20 74 68 65 20 74 65 73 74 73 20 64 69 for the tests di
ca60: 72 20 6c 69 6e 6b 73 2c 20 74 68 69 73 20 69 73 r links, this is
ca70: 20 6e 65 65 64 65 64 20 6e 6f 20 6d 61 74 74 65 needed no matte
ca80: 72 20 77 68 61 74 2e 2e 2e 0a 20 20 20 20 28 69 r what.... (i
ca90: 66 20 28 61 6e 64 20 28 6e 6f 74 20 28 63 6f 6d f (and (not (com
caa0: 6d 6f 6e 3a 64 69 72 65 63 74 6f 72 79 2d 65 78 mon:directory-ex
cab0: 69 73 74 73 3f 20 6c 6e 6b 62 61 73 65 29 29 0a ists? lnkbase)).
cac0: 09 20 20 20 20 20 28 6e 6f 74 20 28 63 6f 6d 6d . (not (comm
cad0: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
cae0: 6c 6e 6b 62 61 73 65 29 29 29 0a 09 28 68 61 6e lnkbase)))..(han
caf0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
cb00: 20 65 78 6e 0a 09 20 28 62 65 67 69 6e 0a 09 20 exn.. (begin..
cb10: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
cb20: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
cb30: 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 72 6f 62 6c log-port* "Probl
cb40: 65 6d 20 63 72 65 61 74 69 6e 67 20 6c 69 6e 6b em creating link
cb50: 74 72 65 65 20 62 61 73 65 20 61 74 20 22 20 6c tree base at " l
cb60: 6e 6b 62 61 73 65 29 0a 09 20 20 20 28 70 72 69 nkbase).. (pri
cb70: 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 nt-error-message
cb80: 20 65 78 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 exn (current-er
cb90: 72 6f 72 2d 70 6f 72 74 29 29 29 0a 09 20 28 63 ror-port))).. (c
cba0: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
cbb0: 6c 6e 6b 62 61 73 65 20 23 74 29 29 29 0a 20 20 lnkbase #t))).
cbc0: 20 20 0a 20 20 20 20 3b 3b 20 75 70 64 61 74 65 . ;; update
cbd0: 20 74 68 65 20 74 6f 70 74 65 73 74 20 72 65 63 the toptest rec
cbe0: 6f 72 64 20 77 69 74 68 20 69 74 73 20 6c 6f 63 ord with its loc
cbf0: 61 74 69 6f 6e 20 72 75 6e 64 69 72 2c 20 63 61 ation rundir, ca
cc00: 63 68 65 20 74 68 65 20 70 61 74 68 0a 20 20 20 che the path.
cc10: 20 3b 3b 20 54 68 69 73 20 77 61 73 73 20 68 69 ;; This wass hi
cc20: 67 68 6c 79 20 69 6e 65 66 66 69 63 69 65 6e 74 ghly inefficient
cc30: 2c 20 6f 6e 65 20 64 62 20 77 72 69 74 65 20 66 , one db write f
cc40: 6f 72 20 65 76 65 72 79 20 73 75 62 74 65 73 74 or every subtest
cc50: 2c 20 70 6f 74 65 6e 74 69 61 6c 6c 79 0a 20 20 , potentially.
cc60: 20 20 3b 3b 20 74 68 6f 75 73 61 6e 64 73 20 6f ;; thousands o
cc70: 66 20 75 6e 6e 65 63 65 73 73 61 72 79 20 75 70 f unnecessary up
cc80: 64 61 74 65 73 2c 20 63 61 63 68 65 20 74 68 65 dates, cache the
cc90: 20 66 61 63 74 20 69 74 20 77 61 73 20 73 65 74 fact it was set
cca0: 20 61 6e 64 20 64 6f 6e 27 74 20 73 65 74 20 69 and don't set i
ccb0: 74 20 0a 20 20 20 20 3b 3b 20 61 67 61 69 6e 2e t . ;; again.
ccc0: 20 0a 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 63 72 .. ;; Now cr
ccd0: 65 61 74 65 20 74 68 65 20 6c 69 6e 6b 20 66 72 eate the link fr
cce0: 6f 6d 20 74 68 65 20 74 65 73 74 20 70 61 74 68 om the test path
ccf0: 20 74 6f 20 74 68 65 20 6c 69 6e 6b 20 74 72 65 to the link tre
cd00: 65 2c 20 68 6f 77 65 76 65 72 0a 20 20 20 20 3b e, however. ;
cd10: 3b 20 69 66 20 74 68 65 20 74 65 73 74 20 69 73 ; if the test is
cd20: 20 69 74 65 72 61 74 65 64 20 69 74 20 69 73 20 iterated it is
cd30: 6e 65 63 65 73 73 61 72 79 20 74 6f 20 63 72 65 necessary to cre
cd40: 61 74 65 20 74 68 65 20 70 61 72 65 6e 74 20 70 ate the parent p
cd50: 61 74 68 0a 20 20 20 20 3b 3b 20 74 6f 20 74 68 ath. ;; to th
cd60: 65 20 69 74 65 72 61 74 69 6f 6e 2e 20 75 73 65 e iteration. use
cd70: 20 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 pathname-direct
cd80: 6f 72 79 20 74 6f 20 74 72 69 6d 20 74 68 65 20 ory to trim the
cd90: 70 61 74 68 20 62 79 20 6f 6e 65 0a 20 20 20 20 path by one.
cda0: 3b 3b 20 6c 65 76 65 6c 0a 20 20 20 20 28 69 66 ;; level. (if
cdb0: 20 28 6e 6f 74 20 6e 6f 74 2d 69 74 65 72 61 74 (not not-iterat
cdc0: 65 64 29 20 3b 3b 20 69 2e 65 2e 20 69 74 65 72 ed) ;; i.e. iter
cdd0: 61 74 65 64 0a 09 28 6c 65 74 20 28 28 69 74 65 ated..(let ((ite
cde0: 72 61 74 65 64 2d 70 61 72 65 6e 74 20 20 28 70 rated-parent (p
cdf0: 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 athname-director
ce00: 79 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 68 20 y (conc lnkpath
ce10: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
ce20: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
ce30: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
ce40: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 72 65 t-log-port* "Cre
ce50: 61 74 69 6e 67 20 69 74 65 72 61 74 65 64 20 70 ating iterated p
ce60: 61 72 65 6e 74 20 22 20 69 74 65 72 61 74 65 64 arent " iterated
ce70: 2d 70 61 72 65 6e 74 29 0a 09 20 20 28 68 61 6e -parent).. (han
ce80: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
ce90: 20 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 69 exn.. (begi
cea0: 6e 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 n.. (debug:p
ceb0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
cec0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
ced0: 22 20 46 61 69 6c 65 64 20 74 6f 20 63 72 65 61 " Failed to crea
cee0: 74 65 20 64 69 72 65 63 74 6f 72 79 20 22 20 69 te directory " i
cef0: 74 65 72 61 74 65 64 2d 70 61 72 65 6e 74 20 28 terated-parent (
cf00: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
cf10: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
cf20: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
cf30: 20 22 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 ", exiting")..
cf40: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 (exit 1))..
cf50: 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 (create-direct
cf60: 6f 72 79 20 69 74 65 72 61 74 65 64 2d 70 61 72 ory iterated-par
cf70: 65 6e 74 20 23 74 29 29 29 29 0a 0a 20 20 20 20 ent #t))))..
cf80: 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 (if (symbolic-li
cf90: 6e 6b 3f 20 6c 6e 6b 70 61 74 68 29 20 0a 09 28 nk? lnkpath) ..(
cfa0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
cfb0: 73 0a 09 20 65 78 6e 0a 09 20 28 62 65 67 69 6e s.. exn.. (begin
cfc0: 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
cfd0: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
cfe0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 46 lt-log-port* " F
cff0: 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 ailed to remove
d000: 73 79 6d 6c 69 6e 6b 20 22 20 6c 6e 6b 70 61 74 symlink " lnkpat
d010: 68 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 h ((condition-pr
d020: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
d030: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
d040: 78 6e 29 20 22 2c 20 65 78 69 74 69 6e 67 22 29 xn) ", exiting")
d050: 0a 09 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 .. (exit 1))..
d060: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 6c 6e (delete-file ln
d070: 6b 70 61 74 68 29 29 29 0a 0a 20 20 20 20 28 69 kpath))).. (i
d080: 66 20 28 6e 6f 74 20 28 6f 72 20 28 66 69 6c 65 f (not (or (file
d090: 2d 65 78 69 73 74 73 3f 20 6c 6e 6b 70 61 74 68 -exists? lnkpath
d0a0: 29 0a 09 09 20 28 73 79 6d 62 6f 6c 69 63 2d 6c )... (symbolic-l
d0b0: 69 6e 6b 3f 20 6c 6e 6b 70 61 74 68 29 29 29 0a ink? lnkpath))).
d0c0: 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 .(handle-excepti
d0d0: 6f 6e 73 0a 09 20 65 78 6e 0a 09 20 28 62 65 67 ons.. exn.. (beg
d0e0: 69 6e 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 in.. (debug:pr
d0f0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
d100: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
d110: 20 46 61 69 6c 65 64 20 74 6f 20 63 72 65 61 74 Failed to creat
d120: 65 20 73 79 6d 6c 69 6e 6b 20 22 20 6c 6e 6b 70 e symlink " lnkp
d130: 61 74 68 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d ath ((condition-
d140: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
d150: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
d160: 20 65 78 6e 29 20 22 2c 20 65 78 69 74 69 6e 67 exn) ", exiting
d170: 22 29 0a 09 20 20 20 28 65 78 69 74 20 31 29 29 ").. (exit 1))
d180: 0a 09 20 28 63 72 65 61 74 65 2d 73 79 6d 62 6f .. (create-symbo
d190: 6c 69 63 2d 6c 69 6e 6b 20 74 6f 70 74 65 73 74 lic-link toptest
d1a0: 2d 70 61 74 68 20 6c 6e 6b 70 61 74 68 29 29 29 -path lnkpath)))
d1b0: 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 4e 42 20 . . ;; NB
d1c0: 2d 20 54 68 69 73 20 77 61 73 20 6e 6f 74 20 77 - This was not w
d1d0: 6f 72 6b 69 6e 67 20 72 69 67 68 74 20 2d 20 73 orking right - s
d1e0: 6f 6d 65 20 74 6f 70 20 74 65 73 74 73 20 61 72 ome top tests ar
d1f0: 65 20 6e 6f 74 20 67 65 74 74 69 6e 67 20 74 68 e not getting th
d200: 65 20 70 61 74 68 20 73 65 74 21 21 21 0a 20 20 e path set!!!.
d210: 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 44 6f 20 74 ;;. ;; Do t
d220: 68 65 20 73 65 74 74 69 6e 67 20 6f 66 20 74 68 he setting of th
d230: 69 73 20 72 65 63 6f 72 64 20 61 66 74 65 72 20 is record after
d240: 74 68 65 20 70 61 74 68 73 20 61 72 65 20 63 72 the paths are cr
d250: 65 61 74 65 64 20 73 6f 20 74 68 61 74 20 74 68 eated so that th
d260: 65 20 73 68 6f 72 74 64 69 72 20 63 61 6e 20 0a e shortdir can .
d270: 20 20 20 20 3b 3b 20 62 65 20 73 65 74 20 74 6f ;; be set to
d280: 20 74 68 65 20 72 65 61 6c 20 64 69 72 65 63 74 the real direct
d290: 6f 72 79 20 6c 6f 63 61 74 69 6f 6e 2e 20 54 68 ory location. Th
d2a0: 69 73 20 69 73 20 73 61 66 65 72 20 66 6f 72 20 is is safer for
d2b0: 66 75 74 75 72 65 20 63 6c 65 61 6e 20 75 70 20 future clean up
d2c0: 69 66 20 74 68 65 20 6c 69 6e 6b 0a 20 20 20 20 if the link.
d2d0: 3b 3b 20 74 72 65 65 20 69 73 20 64 61 6d 61 67 ;; tree is damag
d2e0: 65 64 20 6f 72 20 6c 6f 73 74 2e 0a 20 20 20 20 ed or lost..
d2f0: 3b 3b 20 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ;; . (if (not
d300: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
d310: 2f 64 65 66 61 75 6c 74 20 2a 74 6f 70 74 65 73 /default *toptes
d320: 74 2d 70 61 74 68 73 2a 20 74 65 73 74 6e 61 6d t-paths* testnam
d330: 65 20 23 66 29 29 0a 09 28 6c 65 74 2a 20 28 28 e #f))..(let* ((
d340: 74 65 73 74 69 6e 66 6f 20 20 20 20 20 20 20 28 testinfo (
d350: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
d360: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
d370: 65 73 74 2d 69 64 29 29 20 3b 3b 20 20 72 75 6e est-id)) ;; run
d380: 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 -id testname ite
d390: 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 m-path))..
d3a0: 20 28 63 75 72 72 2d 74 65 73 74 2d 70 61 74 68 (curr-test-path
d3b0: 20 28 69 66 20 74 65 73 74 69 6e 66 6f 20 3b 3b (if testinfo ;;
d3c0: 20 28 66 69 6c 65 64 62 3a 67 65 74 2d 70 61 74 (filedb:get-pat
d3d0: 68 20 2a 66 64 62 2a 0a 09 09 09 09 09 09 09 20 h *fdb*........
d3e0: 20 20 20 20 3b 3b 20 28 64 62 3a 67 65 74 2d 70 ;; (db:get-p
d3f0: 61 74 68 20 64 62 73 74 72 75 63 74 0a 09 09 09 ath dbstruct....
d400: 09 20 20 20 3b 3b 20 28 72 6d 74 3a 73 64 62 2d . ;; (rmt:sdb-
d410: 71 72 79 20 27 67 65 74 73 74 72 20 0a 09 09 09 qry 'getstr ....
d420: 09 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 . (db:test-get
d430: 2d 72 75 6e 64 69 72 20 74 65 73 74 69 6e 66 6f -rundir testinfo
d440: 29 20 3b 3b 20 29 20 3b 3b 20 29 0a 09 09 09 09 ) ;; ) ;; ).....
d450: 20 20 20 23 66 29 29 29 0a 09 20 20 28 68 61 73 #f))).. (has
d460: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 6f h-table-set! *to
d470: 70 74 65 73 74 2d 70 61 74 68 73 2a 20 74 65 73 ptest-paths* tes
d480: 74 6e 61 6d 65 20 63 75 72 72 2d 74 65 73 74 2d tname curr-test-
d490: 70 61 74 68 29 0a 09 20 20 3b 3b 20 4e 42 2f 2f path).. ;; NB//
d4a0: 20 57 61 73 20 74 68 69 73 20 66 6f 72 20 74 68 Was this for th
d4b0: 65 20 74 65 73 74 20 6f 72 20 66 6f 72 20 74 68 e test or for th
d4c0: 65 20 70 61 72 65 6e 74 20 69 6e 20 61 6e 20 69 e parent in an i
d4d0: 74 65 72 61 74 65 64 20 74 65 73 74 3f 0a 09 20 terated test?..
d4e0: 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
d4f0: 6c 6c 20 27 74 65 73 74 2d 73 65 74 2d 72 75 6e ll 'test-set-run
d500: 64 69 72 2d 73 68 6f 72 74 64 69 72 20 72 75 6e dir-shortdir run
d510: 2d 69 64 20 6c 6e 6b 70 61 74 68 20 0a 09 09 09 -id lnkpath ....
d520: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
d530: 69 73 74 73 3f 20 6c 6e 6b 70 61 74 68 29 0a 09 ists? lnkpath)..
d540: 09 09 09 3b 3b 20 28 72 65 73 6f 6c 76 65 2d 70 ...;; (resolve-p
d550: 61 74 68 6e 61 6d 65 20 6c 6e 6b 70 61 74 68 29 athname lnkpath)
d560: 0a 09 09 09 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 .....(common:nic
d570: 65 2d 70 61 74 68 20 6c 6e 6b 70 61 74 68 29 0a e-path lnkpath).
d580: 09 09 09 09 6c 6e 6b 70 61 74 68 29 0a 09 09 09 ....lnkpath)....
d590: 20 20 20 20 74 65 73 74 6e 61 6d 65 20 22 22 20 testname ""
d5a0: 72 75 6e 2d 69 64 29 0a 09 20 20 3b 3b 20 28 72 run-id).. ;; (r
d5b0: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
d5c0: 27 74 65 73 74 2d 73 65 74 2d 72 75 6e 64 69 72 'test-set-rundir
d5d0: 20 72 75 6e 2d 69 64 20 6c 6e 6b 70 61 74 68 20 run-id lnkpath
d5e0: 74 65 73 74 6e 61 6d 65 20 22 22 29 20 3b 3b 20 testname "") ;;
d5f0: 74 6f 70 74 65 73 74 2d 70 61 74 68 29 0a 09 20 toptest-path)..
d600: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 63 75 (if (or (not cu
d610: 72 72 2d 74 65 73 74 2d 70 61 74 68 29 0a 09 09 rr-test-path)...
d620: 20 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 (not (director
d630: 79 2d 65 78 69 73 74 73 3f 20 74 6f 70 74 65 73 y-exists? toptes
d640: 74 2d 70 61 74 68 29 29 29 0a 09 20 20 20 20 20 t-path)))..
d650: 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 67 (begin...(debug
d660: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
d670: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
d680: 20 22 43 72 65 61 74 69 6e 67 20 22 20 74 6f 70 "Creating " top
d690: 74 65 73 74 2d 70 61 74 68 20 22 20 61 6e 64 20 test-path " and
d6a0: 6c 69 6e 6b 20 22 20 6c 6e 6b 70 61 74 68 29 0a link " lnkpath).
d6b0: 09 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 ..(handle-except
d6c0: 69 6f 6e 73 0a 09 09 20 65 78 6e 0a 09 09 20 23 ions... exn... #
d6d0: 66 20 3b 3b 20 64 6f 6e 27 74 20 63 61 72 65 20 f ;; don't care
d6e0: 74 6f 20 63 61 74 63 68 20 61 6e 64 20 64 65 61 to catch and dea
d6f0: 6c 20 77 69 74 68 20 65 72 72 6f 72 73 20 68 65 l with errors he
d700: 72 65 20 66 6f 72 20 6e 6f 77 2e 0a 09 09 20 28 re for now.... (
d710: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
d720: 20 74 6f 70 74 65 73 74 2d 70 61 74 68 20 23 74 toptest-path #t
d730: 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 ))...(hash-table
d740: 2d 73 65 74 21 20 2a 74 6f 70 74 65 73 74 2d 70 -set! *toptest-p
d750: 61 74 68 73 2a 20 74 65 73 74 6e 61 6d 65 20 74 aths* testname t
d760: 6f 70 74 65 73 74 2d 70 61 74 68 29 29 29 29 29 optest-path)))))
d770: 0a 0a 20 20 20 20 3b 3b 20 54 68 65 20 74 6f 70 .. ;; The top
d780: 74 65 73 74 20 70 61 74 68 20 68 61 73 20 62 65 test path has be
d790: 65 6e 20 63 72 65 61 74 65 64 2c 20 74 68 65 20 en created, the
d7a0: 6c 69 6e 6b 20 74 6f 20 74 68 65 20 74 65 73 74 link to the test
d7b0: 20 69 6e 20 74 68 65 20 6c 69 6e 6b 74 72 65 65 in the linktree
d7c0: 20 68 61 73 0a 20 20 20 20 3b 3b 20 62 65 65 6e has. ;; been
d7d0: 20 63 72 65 61 74 65 64 2e 20 4e 6f 77 2c 20 69 created. Now, i
d7e0: 66 20 74 68 69 73 20 69 73 20 61 6e 20 69 74 65 f this is an ite
d7f0: 72 61 74 65 64 20 74 65 73 74 20 74 68 65 20 72 rated test the r
d800: 65 61 6c 20 74 65 73 74 20 64 69 72 20 6d 75 73 eal test dir mus
d810: 74 20 62 65 20 63 72 65 61 74 65 64 0a 20 20 20 t be created.
d820: 20 28 69 66 20 28 6e 6f 74 20 6e 6f 74 2d 69 74 (if (not not-it
d830: 65 72 61 74 65 64 29 20 3b 3b 20 74 68 69 73 20 erated) ;; this
d840: 69 73 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 is an iterated t
d850: 65 73 74 0a 09 28 62 65 67 69 6e 20 3b 3b 20 28 est..(begin ;; (
d860: 6c 65 74 20 28 28 6c 6e 6b 74 61 72 67 65 74 20 let ((lnktarget
d870: 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 68 20 22 2f (conc lnkpath "/
d880: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 " item-path)))..
d890: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
d8a0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
d8b0: 72 74 2a 20 22 53 65 74 74 69 6e 67 20 75 70 20 rt* "Setting up
d8c0: 73 75 62 20 74 65 73 74 20 72 75 6e 20 61 72 65 sub test run are
d8d0: 61 22 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 a").. (debug:pr
d8e0: 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c int 2 *default-l
d8f0: 6f 67 2d 70 6f 72 74 2a 20 22 20 2d 20 63 72 65 og-port* " - cre
d900: 61 74 69 6e 67 20 72 75 6e 20 61 72 65 61 20 69 ating run area i
d910: 6e 20 22 20 74 65 73 74 2d 70 61 74 68 29 0a 09 n " test-path)..
d920: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
d930: 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 ions.. exn..
d940: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 28 64 (begin.. (d
d950: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
d960: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
d970: 70 6f 72 74 2a 20 22 20 46 61 69 6c 65 64 20 74 port* " Failed t
d980: 6f 20 63 72 65 61 74 65 20 64 69 72 65 63 74 6f o create directo
d990: 72 79 20 22 20 74 65 73 74 2d 70 61 74 68 20 28 ry " test-path (
d9a0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
d9b0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
d9c0: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
d9d0: 20 22 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 ", exiting")..
d9e0: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 (exit 1))..
d9f0: 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 (create-direct
da00: 6f 72 79 20 74 65 73 74 2d 70 61 74 68 20 23 74 ory test-path #t
da10: 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 )).. (debug:pri
da20: 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 2 *default-lo
da30: 67 2d 70 6f 72 74 2a 20 0a 09 09 20 20 20 20 20 g-port* ...
da40: 20 20 22 20 2d 20 63 72 65 61 74 69 6e 67 20 6c " - creating l
da50: 69 6e 6b 20 66 72 6f 6d 3a 20 22 20 74 65 73 74 ink from: " test
da60: 2d 70 61 74 68 20 22 5c 6e 22 0a 09 09 20 20 20 -path "\n"...
da70: 20 20 20 20 22 20 20 20 20 20 20 20 20 20 20 20 "
da80: 20 20 20 20 20 20 20 20 74 6f 3a 20 22 20 6c 6e to: " ln
da90: 6b 74 61 72 67 65 74 29 0a 0a 09 20 20 3b 3b 20 ktarget)... ;;
daa0: 49 66 20 74 68 65 72 65 20 69 73 20 61 6c 72 65 If there is alre
dab0: 61 64 79 20 61 20 73 79 6d 6c 69 6e 6b 20 64 65 ady a symlink de
dac0: 6c 65 74 65 20 69 74 20 61 6e 64 20 72 65 63 72 lete it and recr
dad0: 65 61 74 65 20 69 74 2e 0a 09 20 20 28 68 61 6e eate it... (han
dae0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
daf0: 20 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 69 exn.. (begi
db00: 6e 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 n.. (debug:p
db10: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
db20: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
db30: 22 20 46 61 69 6c 65 64 20 74 6f 20 72 65 2d 63 " Failed to re-c
db40: 72 65 61 74 65 20 6c 69 6e 6b 20 22 20 6c 6e 6b reate link " lnk
db50: 74 61 72 67 65 74 20 28 28 63 6f 6e 64 69 74 69 target ((conditi
db60: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
db70: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
db80: 67 65 29 20 65 78 6e 29 20 22 2c 20 65 78 69 74 ge) exn) ", exit
db90: 69 6e 67 22 29 0a 09 20 20 20 20 20 28 65 78 69 ing").. (exi
dba0: 74 29 29 0a 09 20 20 20 28 69 66 20 28 73 79 6d t)).. (if (sym
dbb0: 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 6c 6e 6b 74 bolic-link? lnkt
dbc0: 61 72 67 65 74 29 20 20 20 20 20 28 64 65 6c 65 arget) (dele
dbd0: 74 65 2d 66 69 6c 65 20 6c 6e 6b 74 61 72 67 65 te-file lnktarge
dbe0: 74 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 t)).. (if (not
dbf0: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c (file-exists? l
dc00: 6e 6b 74 61 72 67 65 74 29 29 20 28 63 72 65 61 nktarget)) (crea
dc10: 74 65 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b te-symbolic-link
dc20: 20 74 65 73 74 2d 70 61 74 68 20 6c 6e 6b 74 61 test-path lnkta
dc30: 72 67 65 74 29 29 29 29 29 0a 0a 20 20 20 20 28 rget))))).. (
dc40: 69 66 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f if (not (directo
dc50: 72 79 3f 20 74 65 73 74 2d 70 61 74 68 29 29 0a ry? test-path)).
dc60: 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f .(create-directo
dc70: 72 79 20 74 65 73 74 2d 70 61 74 68 20 23 74 29 ry test-path #t)
dc80: 29 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 68 ) ;; this is a h
dc90: 61 63 6b 2c 20 49 20 64 6f 6e 27 74 20 6b 6e 6f ack, I don't kno
dca0: 77 20 77 68 79 20 6f 75 74 20 6f 66 20 74 68 65 w why out of the
dcb0: 20 62 6c 75 65 20 74 68 69 73 20 70 61 74 68 20 blue this path
dcc0: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 20 73 does not exist s
dcd0: 6f 6d 65 74 69 6d 65 73 0a 0a 20 20 20 20 28 69 ometimes.. (i
dce0: 66 20 28 61 6e 64 20 74 65 73 74 2d 73 72 63 2d f (and test-src-
dcf0: 70 61 74 68 20 28 64 69 72 65 63 74 6f 72 79 3f path (directory?
dd00: 20 74 65 73 74 2d 70 61 74 68 29 29 0a 09 28 62 test-path))..(b
dd10: 65 67 69 6e 0a 09 20 20 28 6c 65 74 2a 20 28 28 egin.. (let* ((
dd20: 6f 76 72 63 6d 64 20 28 6c 65 74 20 28 28 63 6d ovrcmd (let ((cm
dd30: 64 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 d (config-lookup
dd40: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
dd50: 74 75 70 22 20 22 74 65 73 74 63 6f 70 79 63 6d tup" "testcopycm
dd60: 64 22 29 29 29 0a 09 09 09 20 20 20 28 69 66 20 d"))).... (if
dd70: 63 6d 64 0a 09 09 09 20 20 20 20 20 20 20 3b 3b cmd.... ;;
dd80: 20 73 75 62 73 74 69 74 75 74 65 20 74 68 65 20 substitute the
dd90: 54 45 53 54 5f 53 52 43 5f 50 41 54 48 20 61 6e TEST_SRC_PATH an
dda0: 64 20 54 45 53 54 5f 54 41 52 47 5f 50 41 54 48 d TEST_TARG_PATH
ddb0: 0a 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 .... (stri
ddc0: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 54 ng-substitute "T
ddd0: 45 53 54 5f 54 41 52 47 5f 50 41 54 48 22 20 74 EST_TARG_PATH" t
dde0: 65 73 74 2d 70 61 74 68 0a 09 09 09 09 09 09 20 est-path.......
ddf0: 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 (string-substit
de00: 75 74 65 20 22 54 45 53 54 5f 53 52 43 5f 50 41 ute "TEST_SRC_PA
de10: 54 48 22 20 74 65 73 74 2d 73 72 63 2d 70 61 74 TH" test-src-pat
de20: 68 20 63 6d 64 20 23 74 29 20 23 74 29 0a 09 09 h cmd #t) #t)...
de30: 09 20 20 20 20 20 20 20 23 66 29 29 29 0a 09 09 . #f)))...
de40: 20 28 63 6d 64 20 20 20 20 28 69 66 20 6f 76 72 (cmd (if ovr
de50: 63 6d 64 20 0a 09 09 09 20 20 20 20 20 6f 76 72 cmd .... ovr
de60: 63 6d 64 0a 09 09 09 20 20 20 20 20 28 63 6f 6e cmd.... (con
de70: 63 20 22 72 73 79 6e 63 20 2d 61 76 22 20 28 69 c "rsync -av" (i
de80: 66 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d f (debug:debug-m
de90: 6f 64 65 20 31 29 20 22 22 20 22 71 22 29 20 22 ode 1) "" "q") "
dea0: 20 22 20 74 65 73 74 2d 73 72 63 2d 70 61 74 68 " test-src-path
deb0: 20 22 2f 20 22 20 74 65 73 74 2d 70 61 74 68 20 "/ " test-path
dec0: 22 2f 22 0a 09 09 09 09 20 20 20 22 20 3e 3e 20 "/"..... " >>
ded0: 22 20 74 65 73 74 2d 70 61 74 68 20 22 2f 6d 74 " test-path "/mt
dee0: 5f 6c 61 75 6e 63 68 2e 6c 6f 67 20 32 3e 3e 20 _launch.log 2>>
def0: 22 20 74 65 73 74 2d 70 61 74 68 20 22 2f 6d 74 " test-path "/mt
df00: 5f 6c 61 75 6e 63 68 2e 6c 6f 67 22 29 29 29 0a _launch.log"))).
df10: 09 09 20 28 73 74 61 74 75 73 20 28 73 79 73 74 .. (status (syst
df20: 65 6d 20 63 6d 64 29 29 29 0a 09 20 20 20 20 28 em cmd))).. (
df30: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 73 74 61 if (not (eq? sta
df40: 74 75 73 20 30 29 29 0a 09 09 28 64 65 62 75 67 tus 0))...(debug
df50: 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c :print 2 *defaul
df60: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 t-log-port* "ERR
df70: 4f 52 3a 20 70 72 6f 62 6c 65 6d 20 77 69 74 68 OR: problem with
df80: 20 72 75 6e 6e 69 6e 67 20 5c 22 22 20 63 6d 64 running \"" cmd
df90: 20 22 5c 22 22 29 29 29 0a 09 20 20 28 6c 69 73 "\""))).. (lis
dfa0: 74 20 6c 6e 6b 70 61 74 68 66 20 6c 6e 6b 70 61 t lnkpathf lnkpa
dfb0: 74 68 20 29 29 0a 09 28 69 66 20 28 61 6e 64 20 th ))..(if (and
dfc0: 74 65 73 74 2d 73 72 63 2d 70 61 74 68 20 28 3e test-src-path (>
dfd0: 20 72 65 6d 74 72 69 65 73 20 30 29 29 0a 09 20 remtries 0))..
dfe0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
dff0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
e000: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
e010: 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 og-port* "Failed
e020: 20 74 6f 20 63 72 65 61 74 65 20 77 6f 72 6b 20 to create work
e030: 61 72 65 61 20 61 74 20 22 20 74 65 73 74 2d 70 area at " test-p
e040: 61 74 68 20 22 20 77 69 74 68 20 6c 69 6e 6b 20 ath " with link
e050: 61 74 20 22 20 6c 6e 6b 74 61 72 67 65 74 20 22 at " lnktarget "
e060: 2c 20 72 65 6d 61 69 6e 69 6e 67 20 61 74 74 65 , remaining atte
e070: 6d 70 74 73 20 22 20 72 65 6d 74 72 69 65 73 29 mpts " remtries)
e080: 0a 09 20 20 20 20 20 20 3b 3b 20 0a 09 20 20 20 .. ;; ..
e090: 20 20 20 28 63 72 65 61 74 65 2d 77 6f 72 6b 2d (create-work-
e0a0: 61 72 65 61 20 72 75 6e 2d 69 64 20 72 75 6e 2d area run-id run-
e0b0: 69 6e 66 6f 20 6b 65 79 76 61 6c 73 20 74 65 73 info keyvals tes
e0c0: 74 2d 69 64 20 74 65 73 74 2d 73 72 63 2d 70 61 t-id test-src-pa
e0d0: 74 68 20 64 69 73 6b 2d 70 61 74 68 20 74 65 73 th disk-path tes
e0e0: 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 20 72 65 tname itemdat re
e0f0: 6d 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 74 72 mtries: (- remtr
e100: 69 65 73 20 31 29 29 29 0a 09 20 20 20 20 28 6c ies 1))).. (l
e110: 69 73 74 20 23 66 20 23 66 29 29 29 29 29 0a 0a ist #f #f)))))..
e120: 3b 3b 20 31 2e 20 6c 6f 6f 6b 20 74 68 6f 75 67 ;; 1. look thoug
e130: 68 20 64 69 73 6b 73 20 6c 69 73 74 20 66 6f 72 h disks list for
e140: 20 64 69 73 6b 20 77 69 74 68 20 6d 6f 73 74 20 disk with most
e150: 73 70 61 63 65 0a 3b 3b 20 32 2e 20 63 72 65 61 space.;; 2. crea
e160: 74 65 20 72 75 6e 20 64 69 72 20 6f 6e 20 64 69 te run dir on di
e170: 73 6b 2c 20 70 61 74 68 20 6e 61 6d 65 20 69 73 sk, path name is
e180: 20 6d 65 61 6e 69 6e 67 66 75 6c 0a 3b 3b 20 33 meaningful.;; 3
e190: 2e 20 63 72 65 61 74 65 20 6c 69 6e 6b 20 66 72 . create link fr
e1a0: 6f 6d 20 72 75 6e 20 64 69 72 20 74 6f 20 6d 65 om run dir to me
e1b0: 67 61 74 65 73 74 20 72 75 6e 73 20 61 72 65 61 gatest runs area
e1c0: 20 0a 3b 3b 20 34 2e 20 72 65 6d 6f 74 65 6c 79 .;; 4. remotely
e1d0: 20 72 75 6e 20 74 68 65 20 74 65 73 74 20 6f 6e run the test on
e1e0: 20 61 6c 6c 6f 63 61 74 65 64 20 68 6f 73 74 0a allocated host.
e1f0: 3b 3b 20 20 20 20 2d 20 63 6f 75 6c 64 20 62 65 ;; - could be
e200: 20 73 73 68 20 74 6f 20 68 6f 73 74 20 66 72 6f ssh to host fro
e210: 6d 20 68 6f 73 74 73 20 74 61 62 6c 65 20 28 75 m hosts table (u
e220: 70 64 61 74 65 20 72 65 67 75 6c 61 72 6c 79 20 pdate regularly
e230: 77 69 74 68 20 6c 6f 61 64 29 0a 3b 3b 20 20 20 with load).;;
e240: 20 2d 20 63 6f 75 6c 64 20 62 65 20 6e 65 74 62 - could be netb
e250: 61 74 63 68 0a 3b 3b 20 20 20 20 20 20 28 6c 61 atch.;; (la
e260: 75 6e 63 68 2d 74 65 73 74 20 64 62 20 28 63 61 unch-test db (ca
e270: 64 72 20 73 74 61 74 75 73 29 20 74 65 73 74 2d dr status) test-
e280: 63 6f 6e 66 29 29 0a 28 64 65 66 69 6e 65 20 28 conf)).(define (
e290: 6c 61 75 6e 63 68 2d 74 65 73 74 20 74 65 73 74 launch-test test
e2a0: 2d 69 64 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 -id run-id run-i
e2b0: 6e 66 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e nfo keyvals runn
e2c0: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 74 65 ame test-conf te
e2d0: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 st-name test-pat
e2e0: 68 20 69 74 65 6d 64 61 74 20 70 61 72 61 6d 73 h itemdat params
e2f0: 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 ). (mutex-lock!
e300: 20 2a 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d *launch-setup-m
e310: 75 74 65 78 2a 29 20 3b 3b 20 73 65 74 74 69 6e utex*) ;; settin
e320: 67 20 76 61 72 69 61 62 6c 65 73 20 61 6e 64 20 g variables and
e330: 70 72 6f 63 65 73 73 69 6e 67 20 74 68 65 20 74 processing the t
e340: 65 73 74 63 6f 6e 66 69 67 20 69 73 20 4e 4f 54 estconfig is NOT
e350: 20 74 68 72 65 61 64 2d 73 61 66 65 2c 20 72 65 thread-safe, re
e360: 75 73 65 20 74 68 65 20 6c 61 75 6e 63 68 2d 73 use the launch-s
e370: 65 74 75 70 20 6d 75 74 65 78 0a 20 20 28 6c 65 etup mutex. (le
e380: 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 20 t* ((item-path
e390: 20 20 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d (item-list-
e3a0: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 0a >path itemdat)).
e3b0: 09 20 28 63 6f 6e 74 6f 75 72 20 20 20 20 20 20 . (contour
e3c0: 20 20 20 23 66 29 29 20 3b 3b 20 4e 4f 54 20 52 #f)) ;; NOT R
e3d0: 45 41 44 59 20 46 4f 52 20 54 48 49 53 20 28 61 EADY FOR THIS (a
e3e0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 63 6f rgs:get-arg "-co
e3f0: 6e 74 6f 75 72 22 29 29 29 0a 20 20 20 20 28 6c ntour"))). (l
e400: 65 74 20 6c 6f 6f 70 20 28 28 64 65 6c 74 61 20 et loop ((delta
e410: 20 20 20 20 20 20 20 28 2d 20 28 63 75 72 72 65 (- (curre
e420: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a 6c 61 73 nt-seconds) *las
e430: 74 2d 6c 61 75 6e 63 68 2a 29 29 0a 09 20 20 20 t-launch*))..
e440: 20 20 20 20 28 6c 61 75 6e 63 68 2d 64 65 6c 61 (launch-dela
e450: 79 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 y (string->numbe
e460: 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c r (or (configf:l
e470: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
e480: 2a 20 22 73 65 74 75 70 22 20 22 6c 61 75 6e 63 * "setup" "launc
e490: 68 2d 64 65 6c 61 79 22 29 20 22 35 22 29 29 29 h-delay") "5")))
e4a0: 29 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 6c ). (if (> l
e4b0: 61 75 6e 63 68 2d 64 65 6c 61 79 20 64 65 6c 74 aunch-delay delt
e4c0: 61 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 a).. (begin..
e4d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
e4e0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
e4f0: 6f 67 2d 70 6f 72 74 2a 20 22 44 65 6c 61 79 69 og-port* "Delayi
e500: 6e 67 20 6c 61 75 6e 63 68 20 6f 66 20 22 20 74 ng launch of " t
e510: 65 73 74 2d 6e 61 6d 65 20 22 20 66 6f 72 20 22 est-name " for "
e520: 20 28 2d 20 6c 61 75 6e 63 68 2d 64 65 6c 61 79 (- launch-delay
e530: 20 64 65 6c 74 61 29 20 22 20 73 65 63 6f 6e 64 delta) " second
e540: 73 22 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 s").. (thread
e550: 2d 73 6c 65 65 70 21 20 28 2d 20 6c 61 75 6e 63 -sleep! (- launc
e560: 68 2d 64 65 6c 61 79 20 64 65 6c 74 61 29 29 0a h-delay delta)).
e570: 09 20 20 20 20 28 6c 6f 6f 70 20 28 2d 20 28 63 . (loop (- (c
e580: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
e590: 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a 29 20 6c *last-launch*) l
e5a0: 61 75 6e 63 68 2d 64 65 6c 61 79 29 29 29 29 0a aunch-delay)))).
e5b0: 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 (change-dire
e5c0: 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 ctory *toppath*)
e5d0: 0a 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 . (alist->env
e5e0: 2d 76 61 72 73 20 3b 3b 20 63 6f 6e 73 6f 6c 69 -vars ;; consoli
e5f0: 64 61 74 65 20 74 68 69 73 20 63 6f 64 65 20 77 date this code w
e600: 69 74 68 20 74 68 65 20 63 6f 64 65 20 69 6e 20 ith the code in
e610: 6d 65 67 61 74 65 73 74 2e 73 63 6d 20 66 6f 72 megatest.scm for
e620: 20 22 2d 65 78 65 63 75 74 65 22 2c 20 2a 6d 61 "-execute", *ma
e630: 79 62 65 2a 20 2d 20 74 68 65 20 6c 6f 6e 67 65 ybe* - the longe
e640: 72 20 74 68 65 79 20 61 72 65 20 73 65 74 20 74 r they are set t
e650: 68 65 20 6c 6f 6e 67 65 72 20 65 61 63 68 20 6c he longer each l
e660: 61 75 6e 63 68 20 74 61 6b 65 73 20 28 6d 75 73 aunch takes (mus
e670: 74 20 62 65 20 6e 6f 6e 2d 6f 76 65 72 6c 61 70 t be non-overlap
e680: 70 69 6e 67 20 77 69 74 68 20 74 68 65 20 76 61 ping with the va
e690: 72 73 29 0a 20 20 20 20 20 28 61 70 70 65 6e 64 rs). (append
e6a0: 0a 20 20 20 20 20 20 28 6c 69 73 74 0a 20 20 20 . (list.
e6b0: 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f 52 55 (list "MT_RU
e6c0: 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f N_AREA_HOME" *to
e6d0: 70 70 61 74 68 2a 29 0a 20 20 20 20 20 20 20 28 ppath*). (
e6e0: 6c 69 73 74 20 22 4d 54 5f 54 45 53 54 5f 4e 41 list "MT_TEST_NA
e6f0: 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 20 ME" test-name).
e700: 20 20 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f (list "MT_
e710: 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 RUNNAME" runna
e720: 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 69 73 74 me). (list
e730: 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 20 20 "MT_ITEMPATH"
e740: 69 74 65 6d 2d 70 61 74 68 29 0a 20 20 20 20 20 item-path).
e750: 20 20 28 6c 69 73 74 20 22 4d 54 5f 43 4f 4e 54 (list "MT_CONT
e760: 4f 55 52 22 20 20 20 63 6f 6e 74 6f 75 72 29 0a OUR" contour).
e770: 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 69 ). i
e780: 74 65 6d 64 61 74 29 29 0a 20 20 20 20 28 6c 65 temdat)). (le
e790: 74 2a 20 28 28 74 72 65 67 69 73 74 72 79 20 20 t* ((tregistry
e7a0: 20 20 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d (tests:get-
e7b0: 61 6c 6c 29 29 20 3b 3b 20 74 68 69 72 64 20 70 all)) ;; third p
e7c0: 61 72 61 6d 20 28 62 65 6c 6f 77 29 20 69 73 20 aram (below) is
e7d0: 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 0a 20 system-allowed.
e7e0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 66 6f 72 ;; for
e7f0: 20 74 63 6f 6e 66 69 67 2c 20 77 68 79 20 64 6f tconfig, why do
e800: 20 77 65 20 61 6c 6c 6f 77 20 66 61 6c 6c 62 61 we allow fallba
e810: 63 6b 20 74 6f 20 74 65 73 74 2d 63 6f 6e 66 3f ck to test-conf?
e820: 0a 09 20 20 20 28 74 63 6f 6e 66 69 67 20 20 20 .. (tconfig
e830: 20 20 20 20 20 20 28 6f 72 20 28 74 65 73 74 73 (or (tests
e840: 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 :get-testconfig
e850: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
e860: 61 74 68 20 74 72 65 67 69 73 74 72 79 20 23 74 ath tregistry #t
e870: 20 66 6f 72 63 65 2d 63 72 65 61 74 65 3a 20 23 force-create: #
e880: 74 29 0a 09 09 09 09 28 62 65 67 69 6e 0a 20 20 t).....(begin.
e890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e8b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
e8c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
e8d0: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 66 61 6c 6c * "WARNING: fall
e8e0: 69 6e 67 20 62 61 63 6b 20 74 6f 20 70 72 65 2d ing back to pre-
e8f0: 63 61 6c 63 75 6c 61 74 65 64 20 74 65 73 74 63 calculated testc
e900: 6f 6e 66 69 67 2e 20 54 68 69 73 20 69 73 20 6c onfig. This is l
e910: 69 6b 65 6c 79 20 6e 6f 74 20 64 65 73 69 72 65 ikely not desire
e920: 64 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 d.").
e930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e940: 20 20 20 20 20 20 20 74 65 73 74 2d 63 6f 6e 66 test-conf
e950: 29 29 29 20 3b 3b 20 66 6f 72 63 65 20 72 65 2d ))) ;; force re-
e960: 72 65 61 64 20 6e 6f 77 20 74 68 61 74 20 61 6c read now that al
e970: 6c 20 76 61 72 73 20 61 72 65 20 73 65 74 0a 09 l vars are set..
e980: 20 20 20 28 75 73 65 73 68 65 6c 6c 20 20 20 20 (useshell
e990: 20 20 20 20 28 6c 65 74 20 28 28 75 73 68 20 28 (let ((ush (
e9a0: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
e9b0: 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f onfigdat* "jobto
e9c0: 6f 6c 73 22 20 20 20 20 20 22 75 73 65 73 68 65 ols" "useshe
e9d0: 6c 6c 22 29 29 29 0a 09 09 09 20 20 20 20 20 20 ll")))....
e9e0: 28 69 66 20 75 73 68 20 0a 09 09 09 09 20 20 28 (if ush ..... (
e9f0: 69 66 20 28 65 71 75 61 6c 3f 20 75 73 68 20 22 if (equal? ush "
ea00: 6e 6f 22 29 20 3b 3b 20 6d 75 73 74 20 75 73 65 no") ;; must use
ea10: 20 22 6e 6f 22 20 74 6f 20 4e 4f 54 20 75 73 65 "no" to NOT use
ea20: 20 73 68 65 6c 6c 0a 09 09 09 09 20 20 20 20 20 shell.....
ea30: 20 23 66 0a 09 09 09 09 20 20 20 20 20 20 75 73 #f..... us
ea40: 68 29 0a 09 09 09 09 20 20 23 74 29 29 29 20 20 h)..... #t)))
ea50: 20 20 20 3b 3b 20 64 65 66 61 75 6c 74 20 69 73 ;; default is
ea60: 20 79 65 73 0a 09 20 20 20 28 72 75 6e 73 63 72 yes.. (runscr
ea70: 69 70 74 20 20 20 20 20 20 20 28 63 6f 6e 66 69 ipt (confi
ea80: 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 g-lookup tconfig
ea90: 20 20 20 22 73 65 74 75 70 22 20 20 20 20 20 20 "setup"
eaa0: 20 20 22 72 75 6e 73 63 72 69 70 74 22 29 29 0a "runscript")).
eab0: 09 20 20 20 28 65 7a 73 74 65 70 73 20 20 20 20 . (ezsteps
eac0: 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 (> (length
ead0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
eae0: 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 69 67 20 default tconfig
eaf0: 22 65 7a 73 74 65 70 73 22 20 27 28 29 29 29 20 "ezsteps" '()))
eb00: 30 29 29 20 3b 3b 20 64 6f 6e 27 74 20 73 65 6e 0)) ;; don't sen
eb10: 64 20 61 6c 6c 20 74 68 65 20 73 74 65 70 73 2c d all the steps,
eb20: 20 63 6f 75 6c 64 20 62 65 20 62 69 67 0a 09 20 could be big..
eb30: 20 20 3b 3b 20 28 64 69 73 6b 73 70 61 63 65 20 ;; (diskspace
eb40: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f (config-lo
eb50: 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 20 20 22 okup tconfig "
eb60: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 64 requirements" "d
eb70: 69 73 6b 73 70 61 63 65 22 29 29 0a 09 20 20 20 iskspace"))..
eb80: 3b 3b 20 28 6d 65 6d 6f 72 79 20 20 20 20 20 20 ;; (memory
eb90: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
eba0: 75 70 20 74 63 6f 6e 66 69 67 20 20 20 22 72 65 up tconfig "re
ebb0: 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6d 65 6d quirements" "mem
ebc0: 6f 72 79 22 29 29 0a 09 20 20 20 3b 3b 20 28 68 ory")).. ;; (h
ebd0: 6f 73 74 73 20 20 20 20 20 20 20 20 20 20 20 28 osts (
ebe0: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 config-lookup *c
ebf0: 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f onfigdat* "jobto
ec00: 6f 6c 73 22 20 20 20 20 20 22 77 6f 72 6b 68 6f ols" "workho
ec10: 73 74 73 22 29 29 20 3b 3b 20 49 27 6d 20 70 72 sts")) ;; I'm pr
ec20: 65 74 74 79 20 73 75 72 65 20 74 68 69 73 20 77 etty sure this w
ec30: 61 73 20 6e 65 76 65 72 20 63 6f 6d 70 6c 65 74 as never complet
ec40: 65 64 0a 09 20 20 20 28 72 65 6d 6f 74 65 2d 6d ed.. (remote-m
ec50: 65 67 61 74 65 73 74 20 28 63 6f 6e 66 69 67 2d egatest (config-
ec60: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
ec70: 74 2a 20 22 73 65 74 75 70 22 20 22 65 78 65 63 t* "setup" "exec
ec80: 75 74 61 62 6c 65 22 29 29 0a 09 20 20 20 28 72 utable")).. (r
ec90: 75 6e 2d 74 69 6d 65 2d 6c 69 6d 69 74 20 20 28 un-time-limit (
eca0: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
ecb0: 75 70 20 20 74 63 6f 6e 66 69 67 20 20 20 22 72 up tconfig "r
ecc0: 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 72 75 equirements" "ru
ecd0: 6e 74 69 6d 65 6c 69 6d 22 29 0a 09 09 09 09 28 ntimelim").....(
ece0: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 20 configf:lookup
ecf0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
ed00: 75 70 22 20 22 72 75 6e 74 69 6d 65 6c 69 6d 22 up" "runtimelim"
ed10: 29 29 29 0a 09 20 20 20 3b 3b 20 46 49 58 4d 45 ))).. ;; FIXME
ed20: 20 53 4f 4d 45 44 41 59 3a 20 6e 6f 74 20 67 6f SOMEDAY: not go
ed30: 6f 64 20 68 6f 77 20 74 68 69 73 20 69 73 20 73 od how this is s
ed40: 6f 20 6f 62 74 75 73 65 2c 20 74 68 69 73 20 68 o obtuse, this h
ed50: 61 63 6b 20 69 73 20 74 6f 20 0a 09 20 20 20 3b ack is to .. ;
ed60: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
ed70: 20 61 6c 6c 6f 77 20 72 75 6e 6e 69 6e 67 20 66 allow running f
ed80: 72 6f 6d 20 64 61 73 68 62 6f 61 72 64 2e 20 45 rom dashboard. E
ed90: 78 74 72 61 63 74 20 74 68 65 20 70 61 74 68 0a xtract the path.
eda0: 09 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 . ;;
edb0: 20 20 20 20 20 20 66 72 6f 6d 20 74 68 65 20 63 from the c
edc0: 61 6c 6c 65 64 20 6d 65 67 61 74 65 73 74 20 61 alled megatest a
edd0: 6e 64 20 63 6f 6e 76 65 72 74 20 64 61 73 68 62 nd convert dashb
ede0: 6f 61 72 64 0a 09 20 20 20 3b 3b 20 20 20 20 20 oard.. ;;
edf0: 20 20 20 20 20 20 20 20 09 20 20 6f 72 20 64 62 . or db
ee00: 6f 61 72 64 20 74 6f 20 6d 65 67 61 74 65 73 74 oard to megatest
ee10: 0a 09 20 20 20 28 6c 6f 63 61 6c 2d 6d 65 67 61 .. (local-mega
ee20: 74 65 73 74 20 20 28 6c 65 74 2a 20 28 28 6c 6d test (let* ((lm
ee30: 20 20 28 63 61 72 20 28 61 72 67 76 29 29 29 0a (car (argv))).
ee40: 09 09 09 09 20 20 20 28 64 69 72 20 28 70 61 74 .... (dir (pat
ee50: 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 hname-directory
ee60: 6c 6d 29 29 0a 09 09 09 09 20 20 20 28 65 78 65 lm))..... (exe
ee70: 20 28 70 61 74 68 6e 61 6d 65 2d 73 74 72 69 70 (pathname-strip
ee80: 2d 64 69 72 65 63 74 6f 72 79 20 6c 6d 29 29 29 -directory lm)))
ee90: 0a 09 09 09 20 20 20 20 20 20 28 63 6f 6e 63 20 .... (conc
eea0: 28 69 66 20 64 69 72 20 28 63 6f 6e 63 20 64 69 (if dir (conc di
eeb0: 72 20 22 2f 22 29 20 22 22 29 0a 09 09 09 09 20 r "/") "").....
eec0: 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 (case (string
eed0: 2d 3e 73 79 6d 62 6f 6c 20 65 78 65 29 0a 09 09 ->symbol exe)...
eee0: 09 09 20 20 20 20 20 20 28 28 64 62 6f 61 72 64 .. ((dboard
eef0: 29 20 20 20 20 22 2e 2e 2f 6d 65 67 61 74 65 73 ) "../megates
ef00: 74 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 28 t")..... ((
ef10: 6d 74 65 73 74 29 20 20 20 20 20 22 2e 2e 2f 6d mtest) "../m
ef20: 65 67 61 74 65 73 74 22 29 0a 09 09 09 09 20 20 egatest").....
ef30: 20 20 20 20 28 28 64 61 73 68 62 6f 61 72 64 29 ((dashboard)
ef40: 20 22 6d 65 67 61 74 65 73 74 22 29 0a 09 09 09 "megatest")....
ef50: 09 20 20 20 20 20 20 28 65 6c 73 65 20 65 78 65 . (else exe
ef60: 29 29 29 29 29 0a 09 20 20 20 28 6c 61 75 6e 63 ))))).. (launc
ef70: 68 65 72 20 20 20 20 20 20 20 20 28 63 6f 6d 6d her (comm
ef80: 6f 6e 3a 67 65 74 2d 6c 61 75 6e 63 68 65 72 20 on:get-launcher
ef90: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 74 65 73 74 *configdat* test
efa0: 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 -name item-path)
efb0: 29 20 3b 3b 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f ) ;; (config-loo
efc0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
efd0: 22 6a 6f 62 74 6f 6f 6c 73 22 20 20 20 20 20 22 "jobtools" "
efe0: 6c 61 75 6e 63 68 65 72 22 29 29 0a 09 20 20 20 launcher"))..
eff0: 28 74 65 73 74 2d 73 69 67 20 20 20 20 20 20 20 (test-sig
f000: 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 (conc (common:g
f010: 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d et-testsuite-nam
f020: 65 29 20 22 3a 22 20 74 65 73 74 2d 6e 61 6d 65 e) ":" test-name
f030: 20 22 3a 22 20 69 74 65 6d 2d 70 61 74 68 29 29 ":" item-path))
f040: 20 3b 3b 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e ;; (item-list->
f050: 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 29 20 path itemdat)))
f060: 3b 3b 20 74 65 73 74 2d 70 61 74 68 20 69 73 20 ;; test-path is
f070: 74 68 65 20 66 75 6c 6c 20 70 61 74 68 20 69 6e the full path in
f080: 63 6c 75 64 69 6e 67 20 74 68 65 20 69 74 65 6d cluding the item
f090: 2d 70 61 74 68 0a 09 20 20 20 28 77 6f 72 6b 2d -path.. (work-
f0a0: 61 72 65 61 20 20 20 20 20 20 20 23 66 29 0a 09 area #f)..
f0b0: 20 20 20 28 74 6f 70 74 65 73 74 2d 77 6f 72 6b (toptest-work
f0c0: 2d 61 72 65 61 20 23 66 29 20 3b 3b 20 66 6f 72 -area #f) ;; for
f0d0: 20 69 74 65 72 61 74 65 64 20 74 65 73 74 73 20 iterated tests
f0e0: 74 68 65 20 74 6f 70 20 74 65 73 74 20 63 6f 6e the top test con
f0f0: 74 61 69 6e 73 20 64 61 74 61 20 72 65 6c 65 76 tains data relev
f100: 61 6e 74 20 66 6f 72 20 61 6c 6c 0a 09 20 20 20 ant for all..
f110: 28 64 69 73 6b 70 61 74 68 20 20 20 23 66 29 0a (diskpath #f).
f120: 09 20 20 20 28 63 6d 64 70 61 72 6d 73 20 20 20 . (cmdparms
f130: 23 66 29 0a 09 20 20 20 28 66 75 6c 6c 63 6d 64 #f).. (fullcmd
f140: 20 20 20 20 23 66 29 20 3b 3b 20 28 64 65 66 69 #f) ;; (defi
f150: 6e 65 20 61 20 28 77 69 74 68 2d 6f 75 74 70 75 ne a (with-outpu
f160: 74 2d 74 6f 2d 73 74 72 69 6e 67 20 28 6c 61 6d t-to-string (lam
f170: 62 64 61 20 28 29 28 77 72 69 74 65 20 78 29 29 bda ()(write x))
f180: 29 29 0a 09 20 20 20 28 6d 74 2d 62 69 6e 64 69 )).. (mt-bindi
f190: 72 2d 70 61 74 68 20 23 66 29 0a 09 20 20 20 28 r-path #f).. (
f1a0: 74 65 73 74 69 6e 66 6f 20 20 20 28 72 6d 74 3a testinfo (rmt:
f1b0: 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 get-test-info-by
f1c0: 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d -id run-id test-
f1d0: 69 64 29 29 0a 09 20 20 20 28 6d 74 5f 74 61 72 id)).. (mt_tar
f1e0: 67 65 74 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 get (string-int
f1f0: 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 ersperse (map ca
f200: 64 72 20 6b 65 79 76 61 6c 73 29 20 22 2f 22 29 dr keyvals) "/")
f210: 29 0a 09 20 20 20 28 64 65 62 75 67 2d 70 61 72 ).. (debug-par
f220: 61 6d 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 am (append (if (
f230: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 args:get-arg "-d
f240: 65 62 75 67 22 29 20 20 28 6c 69 73 74 20 22 2d ebug") (list "-
f250: 64 65 62 75 67 22 20 28 61 72 67 73 3a 67 65 74 debug" (args:get
f260: 2d 61 72 67 20 22 2d 64 65 62 75 67 22 29 29 20 -arg "-debug"))
f270: 27 28 29 29 0a 09 09 09 09 28 69 66 20 28 61 72 '()).....(if (ar
f280: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6c 6f 67 gs:get-arg "-log
f290: 67 69 6e 67 22 29 28 6c 69 73 74 20 22 2d 6c 6f ging")(list "-lo
f2a0: 67 67 69 6e 67 22 29 20 27 28 29 29 29 29 29 0a gging") '())))).
f2b0: 20 20 20 20 20 20 3b 3b 20 28 69 66 20 68 6f 73 ;; (if hos
f2c0: 74 73 20 28 73 65 74 21 20 68 6f 73 74 73 20 28 ts (set! hosts (
f2d0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 68 6f 73 string-split hos
f2e0: 74 73 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 73 ts))). ;; s
f2f0: 65 74 20 74 68 65 20 6d 65 67 61 74 65 73 74 20 et the megatest
f300: 74 6f 20 62 65 20 63 61 6c 6c 65 64 20 6f 6e 20 to be called on
f310: 74 68 65 20 72 65 6d 6f 74 65 20 68 6f 73 74 0a the remote host.
f320: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 72 (if (not r
f330: 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 29 28 emote-megatest)(
f340: 73 65 74 21 20 72 65 6d 6f 74 65 2d 6d 65 67 61 set! remote-mega
f350: 74 65 73 74 20 6c 6f 63 61 6c 2d 6d 65 67 61 74 test local-megat
f360: 65 73 74 29 29 20 3b 3b 20 22 6d 65 67 61 74 65 est)) ;; "megate
f370: 73 74 22 29 29 0a 20 20 20 20 20 20 28 73 65 74 st")). (set
f380: 21 20 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 ! mt-bindir-path
f390: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
f3a0: 74 6f 72 79 20 72 65 6d 6f 74 65 2d 6d 65 67 61 tory remote-mega
f3b0: 74 65 73 74 29 29 0a 20 20 20 20 20 20 28 69 66 test)). (if
f3c0: 20 6c 61 75 6e 63 68 65 72 20 28 73 65 74 21 20 launcher (set!
f3d0: 6c 61 75 6e 63 68 65 72 20 28 73 74 72 69 6e 67 launcher (string
f3e0: 2d 73 70 6c 69 74 20 6c 61 75 6e 63 68 65 72 29 -split launcher)
f3f0: 29 29 0a 20 20 20 20 20 20 3b 3b 20 73 65 74 20 )). ;; set
f400: 75 70 20 74 68 65 20 72 75 6e 20 77 6f 72 6b 20 up the run work
f410: 61 72 65 61 20 66 6f 72 20 74 68 69 73 20 74 65 area for this te
f420: 73 74 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e st. (if (an
f430: 64 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 d (args:get-arg
f440: 22 2d 70 72 65 63 6c 65 61 6e 22 29 20 3b 3b 20 "-preclean") ;;
f450: 75 73 65 72 20 68 61 73 20 72 65 71 75 65 73 74 user has request
f460: 65 64 20 74 6f 20 70 72 65 63 6c 65 61 6e 20 66 ed to preclean f
f470: 6f 72 20 74 68 69 73 20 72 75 6e 0a 09 20 20 20 or this run..
f480: 20 20 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 (not (member
f490: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 (db:test-get-ru
f4a0: 6e 64 69 72 20 74 65 73 74 69 6e 66 6f 29 28 6c ndir testinfo)(l
f4b0: 69 73 74 20 22 6e 2f 61 22 20 22 2f 74 6d 70 2f ist "n/a" "/tmp/
f4c0: 62 61 64 6e 61 6d 65 22 29 29 29 29 20 3b 3b 20 badname")))) ;;
f4d0: 6e 2f 61 20 69 73 20 61 20 70 6c 61 63 65 68 6f n/a is a placeho
f4e0: 6c 64 65 72 20 61 6e 64 20 74 68 75 73 20 6e 6f lder and thus no
f4f0: 74 20 61 20 72 65 61 64 20 64 69 72 0a 09 20 20 t a read dir..
f500: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 (begin.. (deb
f510: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
f520: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
f530: 74 2a 20 22 61 74 74 65 6d 70 74 69 6e 67 20 74 t* "attempting t
f540: 6f 20 70 72 65 63 6c 65 61 6e 20 64 69 72 65 63 o preclean direc
f550: 74 6f 72 79 20 22 20 28 64 62 3a 74 65 73 74 2d tory " (db:test-
f560: 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 69 get-rundir testi
f570: 6e 66 6f 29 20 22 20 66 6f 72 20 74 65 73 74 20 nfo) " for test
f580: 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 " test-name "/"
f590: 69 74 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 item-path)..
f5a0: 28 72 75 6e 73 3a 72 65 6d 6f 76 65 2d 74 65 73 (runs:remove-tes
f5b0: 74 2d 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 t-directory test
f5c0: 69 6e 66 6f 20 27 72 65 6d 6f 76 65 2d 64 61 74 info 'remove-dat
f5d0: 61 2d 6f 6e 6c 79 29 29 29 20 3b 3b 20 72 65 6d a-only))) ;; rem
f5e0: 6f 76 65 20 64 61 74 61 20 6f 6e 6c 79 2c 20 64 ove data only, d
f5f0: 6f 20 6e 6f 74 20 70 65 72 74 75 72 62 20 74 68 o not perturb th
f600: 65 20 72 65 63 6f 72 64 0a 20 20 20 20 20 20 0a e record. .
f610: 20 20 20 20 20 20 3b 3b 20 70 72 65 76 65 6e 74 ;; prevent
f620: 20 6f 76 65 72 6c 61 70 70 69 6e 67 20 61 63 74 overlapping act
f630: 69 6f 6e 73 20 2d 20 73 65 74 20 74 6f 20 4c 41 ions - set to LA
f640: 55 4e 43 48 45 44 20 61 73 20 65 61 72 6c 79 20 UNCHED as early
f650: 61 73 20 70 6f 73 73 69 62 6c 65 0a 20 20 20 20 as possible.
f660: 20 20 3b 3b 0a 20 20 20 20 20 20 3b 3b 20 74 68 ;;. ;; th
f670: 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 63 61 6c 6c e following call
f680: 20 68 61 6e 64 6c 65 73 20 77 61 69 76 65 72 20 handles waiver
f690: 70 72 6f 70 6f 67 61 74 69 6f 6e 2e 20 63 61 6e propogation. can
f6a0: 6e 6f 74 20 79 65 74 20 63 6f 6e 64 65 6e 73 65 not yet condense
f6b0: 20 69 6e 74 6f 20 72 6f 6c 6c 2d 75 70 2d 70 61 into roll-up-pa
f6c0: 73 73 2d 66 61 69 6c 0a 20 20 20 20 20 20 28 74 ss-fail. (t
f6d0: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 ests:test-set-st
f6e0: 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 atus! run-id tes
f6f0: 74 2d 69 64 20 22 4c 41 55 4e 43 48 45 44 22 20 t-id "LAUNCHED"
f700: 22 6e 2f 61 22 20 23 66 20 23 66 29 20 3b 3b 20 "n/a" #f #f) ;;
f710: 28 69 66 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c (if launch-resul
f720: 74 73 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 ts launch-result
f730: 73 20 22 46 41 49 4c 45 44 22 29 29 0a 20 20 20 s "FAILED")).
f740: 20 20 20 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 (rmt:set-stat
f750: 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c e-status-and-rol
f760: 6c 2d 75 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 l-up-items run-i
f770: 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d d test-name item
f780: 2d 70 61 74 68 20 23 66 20 22 4c 41 55 4e 43 48 -path #f "LAUNCH
f790: 45 44 22 20 23 66 29 0a 20 20 20 20 20 20 3b 3b ED" #f). ;;
f7a0: 20 28 70 70 20 28 68 61 73 68 2d 74 61 62 6c 65 (pp (hash-table
f7b0: 2d 3e 61 6c 69 73 74 20 74 63 6f 6e 66 69 67 29 ->alist tconfig)
f7c0: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 64 69 ). (set! di
f7d0: 73 6b 70 61 74 68 20 28 67 65 74 2d 62 65 73 74 skpath (get-best
f7e0: 2d 64 69 73 6b 20 2a 63 6f 6e 66 69 67 64 61 74 -disk *configdat
f7f0: 2a 20 74 63 6f 6e 66 69 67 29 29 0a 20 20 20 20 * tconfig)).
f800: 20 20 28 69 66 20 64 69 73 6b 70 61 74 68 0a 09 (if diskpath..
f810: 20 20 28 6c 65 74 20 28 28 64 61 74 20 20 28 63 (let ((dat (c
f820: 72 65 61 74 65 2d 77 6f 72 6b 2d 61 72 65 61 20 reate-work-area
f830: 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 run-id run-info
f840: 6b 65 79 76 61 6c 73 20 74 65 73 74 2d 69 64 20 keyvals test-id
f850: 74 65 73 74 2d 70 61 74 68 20 64 69 73 6b 70 61 test-path diskpa
f860: 74 68 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 th test-name ite
f870: 6d 64 61 74 29 29 29 0a 09 20 20 20 20 28 73 65 mdat))).. (se
f880: 74 21 20 77 6f 72 6b 2d 61 72 65 61 20 28 63 61 t! work-area (ca
f890: 72 20 64 61 74 29 29 0a 09 20 20 20 20 28 73 65 r dat)).. (se
f8a0: 74 21 20 74 6f 70 74 65 73 74 2d 77 6f 72 6b 2d t! toptest-work-
f8b0: 61 72 65 61 20 28 63 61 64 72 20 64 61 74 29 29 area (cadr dat))
f8c0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
f8d0: 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 nt-info 2 *defau
f8e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 73 lt-log-port* "Us
f8f0: 69 6e 67 20 77 6f 72 6b 20 61 72 65 61 20 22 20 ing work area "
f900: 77 6f 72 6b 2d 61 72 65 61 29 29 0a 09 20 20 28 work-area)).. (
f910: 62 65 67 69 6e 0a 09 20 20 20 20 28 73 65 74 21 begin.. (set!
f920: 20 77 6f 72 6b 2d 61 72 65 61 20 28 63 6f 6e 63 work-area (conc
f930: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 74 6d 70 test-path "/tmp
f940: 5f 72 75 6e 22 29 29 0a 09 20 20 20 20 28 63 72 _run")).. (cr
f950: 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 77 eate-directory w
f960: 6f 72 6b 2d 61 72 65 61 20 23 74 29 0a 09 20 20 ork-area #t)..
f970: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
f980: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
f990: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 4e 6f rt* "WARNING: No
f9a0: 20 64 69 73 6b 20 77 6f 72 6b 20 61 72 65 61 20 disk work area
f9b0: 73 70 65 63 69 66 69 65 64 20 2d 20 72 75 6e 6e specified - runn
f9c0: 69 6e 67 20 69 6e 20 74 68 65 20 74 65 73 74 20 ing in the test
f9d0: 64 69 72 65 63 74 6f 72 79 20 75 6e 64 65 72 20 directory under
f9e0: 74 6d 70 5f 72 75 6e 22 29 29 29 0a 20 20 20 20 tmp_run"))).
f9f0: 20 20 28 73 65 74 21 20 63 6d 64 70 61 72 6d 73 (set! cmdparms
fa00: 20 28 62 61 73 65 36 34 3a 62 61 73 65 36 34 2d (base64:base64-
fa10: 65 6e 63 6f 64 65 20 0a 09 09 20 20 20 20 20 20 encode ...
fa20: 28 7a 33 3a 65 6e 63 6f 64 65 2d 62 75 66 66 65 (z3:encode-buffe
fa30: 72 20 0a 09 09 20 20 20 20 20 20 20 28 77 69 74 r ... (wit
fa40: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 h-output-to-stri
fa50: 6e 67 0a 09 09 09 20 28 6c 61 6d 62 64 61 20 28 ng.... (lambda (
fa60: 29 20 3b 3b 20 28 6c 69 73 74 20 27 68 6f 73 74 ) ;; (list 'host
fa70: 73 20 20 20 20 20 68 6f 73 74 73 29 0a 09 09 09 s hosts)....
fa80: 20 20 20 28 77 72 69 74 65 20 28 6c 69 73 74 20 (write (list
fa90: 28 6c 69 73 74 20 27 74 65 73 74 70 61 74 68 20 (list 'testpath
faa0: 20 74 65 73 74 2d 70 61 74 68 29 0a 09 09 09 09 test-path).....
fab0: 09 3b 3b 20 28 6c 69 73 74 20 27 74 72 61 6e 73 .;; (list 'trans
fac0: 70 6f 72 74 20 28 63 6f 6e 63 20 2a 74 72 61 6e port (conc *tran
fad0: 73 70 6f 72 74 2d 74 79 70 65 2a 29 29 0a 09 09 sport-type*))...
fae0: 09 09 09 3b 3b 20 28 6c 69 73 74 20 27 73 65 72 ...;; (list 'ser
faf0: 76 65 72 69 6e 66 20 2a 73 65 72 76 65 72 2d 69 verinf *server-i
fb00: 6e 66 6f 2a 29 0a 09 09 09 09 09 28 6c 69 73 74 nfo*)......(list
fb10: 20 27 68 6f 6d 65 68 6f 73 74 20 20 28 6c 65 74 'homehost (let
fb20: 2a 20 28 28 68 68 64 61 74 20 28 63 6f 6d 6d 6f * ((hhdat (commo
fb30: 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 n:get-homehost))
fb40: 29 0a 09 09 09 09 09 09 09 20 20 20 28 69 66 20 )........ (if
fb50: 68 68 64 61 74 0a 09 09 09 09 09 09 09 20 20 20 hhdat........
fb60: 20 20 20 20 28 63 61 72 20 68 68 64 61 74 29 0a (car hhdat).
fb70: 09 09 09 09 09 09 09 20 20 20 20 20 20 20 23 66 ....... #f
fb80: 29 29 29 0a 09 09 09 09 09 28 6c 69 73 74 20 27 )))......(list '
fb90: 73 65 72 76 65 72 75 72 6c 20 28 69 66 20 2a 72 serverurl (if *r
fba0: 75 6e 72 65 6d 6f 74 65 2a 0a 09 09 09 09 09 09 unremote*.......
fbb0: 09 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 73 65 . (remote-se
fbc0: 72 76 65 72 2d 75 72 6c 20 2a 72 75 6e 72 65 6d rver-url *runrem
fbd0: 6f 74 65 2a 29 0a 09 09 09 09 09 09 09 20 20 20 ote*)........
fbe0: 20 20 23 66 29 29 20 3b 3b 0a 09 09 09 09 09 28 #f)) ;;......(
fbf0: 6c 69 73 74 20 27 61 72 65 61 6e 61 6d 65 20 20 list 'areaname
fc00: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 (common:get-test
fc10: 73 75 69 74 65 2d 6e 61 6d 65 29 29 0a 09 09 09 suite-name))....
fc20: 09 09 28 6c 69 73 74 20 27 74 6f 70 70 61 74 68 ..(list 'toppath
fc30: 20 20 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 *toppath*)...
fc40: 09 09 09 28 6c 69 73 74 20 27 77 6f 72 6b 2d 61 ...(list 'work-a
fc50: 72 65 61 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 rea work-area)..
fc60: 09 09 09 09 28 6c 69 73 74 20 27 74 65 73 74 2d ....(list 'test-
fc70: 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 29 20 name test-name)
fc80: 0a 09 09 09 09 09 28 6c 69 73 74 20 27 72 75 6e ......(list 'run
fc90: 73 63 72 69 70 74 20 72 75 6e 73 63 72 69 70 74 script runscript
fca0: 29 20 0a 09 09 09 09 09 28 6c 69 73 74 20 27 72 ) ......(list 'r
fcb0: 75 6e 2d 69 64 20 20 20 20 72 75 6e 2d 69 64 20 un-id run-id
fcc0: 20 20 29 0a 09 09 09 09 09 28 6c 69 73 74 20 27 )......(list '
fcd0: 74 65 73 74 2d 69 64 20 20 20 74 65 73 74 2d 69 test-id test-i
fce0: 64 20 20 29 0a 09 09 09 09 09 3b 3b 20 28 6c 69 d )......;; (li
fcf0: 73 74 20 27 69 74 65 6d 2d 70 61 74 68 20 69 74 st 'item-path it
fd00: 65 6d 2d 70 61 74 68 20 29 0a 09 09 09 09 09 28 em-path )......(
fd10: 6c 69 73 74 20 27 69 74 65 6d 64 61 74 20 20 20 list 'itemdat
fd20: 69 74 65 6d 64 61 74 20 20 29 0a 09 09 09 09 09 itemdat )......
fd30: 28 6c 69 73 74 20 27 6d 65 67 61 74 65 73 74 20 (list 'megatest
fd40: 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 remote-megatest
fd50: 29 0a 09 09 09 09 09 28 6c 69 73 74 20 27 65 7a )......(list 'ez
fd60: 73 74 65 70 73 20 20 20 65 7a 73 74 65 70 73 29 steps ezsteps)
fd70: 20 0a 09 09 09 09 09 28 6c 69 73 74 20 27 74 61 ......(list 'ta
fd80: 72 67 65 74 20 20 20 20 6d 74 5f 74 61 72 67 65 rget mt_targe
fd90: 74 29 0a 09 09 09 09 09 28 6c 69 73 74 20 27 63 t)......(list 'c
fda0: 6f 6e 74 6f 75 72 20 20 20 63 6f 6e 74 6f 75 72 ontour contour
fdb0: 29 0a 09 09 09 09 09 28 6c 69 73 74 20 27 72 75 )......(list 'ru
fdc0: 6e 74 6c 69 6d 20 20 20 28 69 66 20 72 75 6e 2d ntlim (if run-
fdd0: 74 69 6d 65 2d 6c 69 6d 69 74 20 28 63 6f 6d 6d time-limit (comm
fde0: 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 2d 3e 73 on:hms-string->s
fdf0: 65 63 6f 6e 64 73 20 72 75 6e 2d 74 69 6d 65 2d econds run-time-
fe00: 6c 69 6d 69 74 29 20 23 66 29 29 0a 09 09 09 09 limit) #f)).....
fe10: 09 28 6c 69 73 74 20 27 65 6e 76 2d 6f 76 72 64 .(list 'env-ovrd
fe20: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
fe30: 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 f/default *confi
fe40: 67 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 gdat* "env-overr
fe50: 69 64 65 22 20 27 28 29 29 29 20 0a 09 09 09 09 ide" '())) .....
fe60: 09 28 6c 69 73 74 20 27 73 65 74 2d 76 61 72 73 .(list 'set-vars
fe70: 20 20 28 69 66 20 70 61 72 61 6d 73 20 28 68 61 (if params (ha
fe80: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
fe90: 61 75 6c 74 20 70 61 72 61 6d 73 20 22 2d 73 65 ault params "-se
fea0: 74 76 61 72 73 22 20 23 66 29 29 29 0a 09 09 09 tvars" #f)))....
feb0: 09 09 28 6c 69 73 74 20 27 72 75 6e 6e 61 6d 65 ..(list 'runname
fec0: 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 09 09 09 runname).....
fed0: 09 28 6c 69 73 74 20 27 6d 74 2d 62 69 6e 64 69 .(list 'mt-bindi
fee0: 72 2d 70 61 74 68 20 6d 74 2d 62 69 6e 64 69 72 r-path mt-bindir
fef0: 2d 70 61 74 68 29 29 29 29 29 29 29 29 0a 20 20 -path)))))))).
ff00: 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 63 6c . ;; cl
ff10: 65 61 6e 20 6f 75 74 20 73 74 65 70 20 72 65 63 ean out step rec
ff20: 6f 72 64 73 20 66 72 6f 6d 20 70 72 65 76 69 6f ords from previo
ff30: 75 73 20 72 75 6e 20 69 66 20 74 68 65 79 20 65 us run if they e
ff40: 78 69 73 74 0a 20 20 20 20 20 20 3b 3b 20 28 72 xist. ;; (r
ff50: 6d 74 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 73 mt:delete-test-s
ff60: 74 65 70 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d tep-records run-
ff70: 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 20 20 id test-id).
ff80: 20 20 3b 3b 20 69 66 20 74 68 65 20 64 69 72 20 ;; if the dir
ff90: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 20 77 does not exist w
ffa0: 65 20 6d 61 79 20 68 61 76 65 20 61 20 69 74 65 e may have a ite
ffb0: 6d 70 61 74 68 20 77 68 65 72 65 20 69 6e 64 69 mpath where indi
ffc0: 76 69 64 75 61 6c 20 76 61 72 69 61 62 6c 65 73 vidual variables
ffd0: 20 61 72 65 20 61 20 70 61 74 68 2c 20 6c 61 75 are a path, lau
ffe0: 6e 63 68 20 61 6e 79 77 61 79 0a 20 20 20 20 20 nch anyway.
fff0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
10000 73 3f 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 20 s? work-area)..
10010 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
10020 72 79 20 77 6f 72 6b 2d 61 72 65 61 29 29 20 3b ry work-area)) ;
10030 3b 20 73 6f 20 74 68 61 74 20 6c 6f 67 20 66 69 ; so that log fi
10040 6c 65 73 20 66 72 6f 6d 20 74 68 65 20 6c 61 75 les from the lau
10050 6e 63 68 20 70 72 6f 63 65 73 73 20 64 6f 6e 27 nch process don'
10060 74 20 63 6c 75 74 74 65 72 20 74 68 65 20 74 65 t clutter the te
10070 73 74 20 64 69 72 0a 20 20 20 20 20 20 28 63 6f st dir. (co
10080 6e 64 0a 20 20 20 20 20 20 20 3b 3b 20 28 28 61 nd. ;; ((a
10090 6e 64 20 6c 61 75 6e 63 68 65 72 20 68 6f 73 74 nd launcher host
100a0 73 29 20 3b 3b 20 6d 75 73 74 20 62 65 20 75 73 s) ;; must be us
100b0 69 6e 67 20 73 73 68 20 68 6f 73 74 6e 61 6d 65 ing ssh hostname
100c0 0a 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 73 . ;; (s
100d0 65 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 70 et! fullcmd (app
100e0 65 6e 64 20 6c 61 75 6e 63 68 65 72 20 28 63 61 end launcher (ca
100f0 72 20 68 6f 73 74 73 29 28 6c 69 73 74 20 72 65 r hosts)(list re
10100 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 22 2d mote-megatest "-
10110 6d 22 20 74 65 73 74 2d 73 69 67 20 22 2d 65 78 m" test-sig "-ex
10120 65 63 75 74 65 22 20 63 6d 64 70 61 72 6d 73 29 ecute" cmdparms)
10130 20 64 65 62 75 67 2d 70 61 72 61 6d 29 29 29 0a debug-param))).
10140 20 20 20 20 20 20 20 3b 3b 20 28 73 65 74 21 20 ;; (set!
10150 66 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 fullcmd (append
10160 6c 61 75 6e 63 68 65 72 20 28 63 61 72 20 68 6f launcher (car ho
10170 73 74 73 29 28 6c 69 73 74 20 72 65 6d 6f 74 65 sts)(list remote
10180 2d 6d 65 67 61 74 65 73 74 20 74 65 73 74 2d 73 -megatest test-s
10190 69 67 20 22 2d 65 78 65 63 75 74 65 22 20 63 6d ig "-execute" cm
101a0 64 70 61 72 6d 73 29 29 29 29 0a 20 20 20 20 20 dparms)))).
101b0 20 20 28 6c 61 75 6e 63 68 65 72 0a 09 28 73 65 (launcher..(se
101c0 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 70 65 t! fullcmd (appe
101d0 6e 64 20 6c 61 75 6e 63 68 65 72 20 28 6c 69 73 nd launcher (lis
101e0 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 t remote-megates
101f0 74 20 22 2d 6d 22 20 74 65 73 74 2d 73 69 67 20 t "-m" test-sig
10200 22 2d 65 78 65 63 75 74 65 22 20 63 6d 64 70 61 "-execute" cmdpa
10210 72 6d 73 29 20 64 65 62 75 67 2d 70 61 72 61 6d rms) debug-param
10220 29 29 29 0a 20 20 20 20 20 20 20 3b 3b 20 28 73 ))). ;; (s
10230 65 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 70 et! fullcmd (app
10240 65 6e 64 20 6c 61 75 6e 63 68 65 72 20 28 6c 69 end launcher (li
10250 73 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 st remote-megate
10260 73 74 20 74 65 73 74 2d 73 69 67 20 22 2d 65 78 st test-sig "-ex
10270 65 63 75 74 65 22 20 63 6d 64 70 61 72 6d 73 29 ecute" cmdparms)
10280 29 29 29 0a 20 20 20 20 20 20 20 28 65 6c 73 65 ))). (else
10290 0a 09 28 69 66 20 28 6e 6f 74 20 75 73 65 73 68 ..(if (not usesh
102a0 65 6c 6c 29 28 64 65 62 75 67 3a 70 72 69 6e 74 ell)(debug:print
102b0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
102c0 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
102d0 69 6e 74 65 72 6e 61 6c 20 6c 61 75 6e 63 68 69 internal launchi
102e0 6e 67 20 77 69 6c 6c 20 6e 6f 74 20 77 6f 72 6b ng will not work
102f0 20 77 65 6c 6c 20 77 69 74 68 6f 75 74 20 5c 22 well without \"
10300 75 73 65 73 68 65 6c 6c 20 79 65 73 5c 22 20 69 useshell yes\" i
10310 6e 20 79 6f 75 72 20 5b 6a 6f 62 74 6f 6f 6c 73 n your [jobtools
10320 5d 20 73 65 63 74 69 6f 6e 22 29 29 0a 09 28 73 ] section"))..(s
10330 65 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 70 et! fullcmd (app
10340 65 6e 64 20 28 6c 69 73 74 20 72 65 6d 6f 74 65 end (list remote
10350 2d 6d 65 67 61 74 65 73 74 20 22 2d 6d 22 20 74 -megatest "-m" t
10360 65 73 74 2d 73 69 67 20 22 2d 65 78 65 63 75 74 est-sig "-execut
10370 65 22 20 63 6d 64 70 61 72 6d 73 29 20 64 65 62 e" cmdparms) deb
10380 75 67 2d 70 61 72 61 6d 20 28 6c 69 73 74 20 28 ug-param (list (
10390 69 66 20 75 73 65 73 68 65 6c 6c 20 22 26 22 20 if useshell "&"
103a0 22 22 29 29 29 29 29 29 0a 20 20 20 20 20 20 3b "")))))). ;
103b0 3b 20 28 73 65 74 21 20 66 75 6c 6c 63 6d 64 20 ; (set! fullcmd
103c0 28 6c 69 73 74 20 72 65 6d 6f 74 65 2d 6d 65 67 (list remote-meg
103d0 61 74 65 73 74 20 74 65 73 74 2d 73 69 67 20 22 atest test-sig "
103e0 2d 65 78 65 63 75 74 65 22 20 63 6d 64 70 61 72 -execute" cmdpar
103f0 6d 73 20 28 69 66 20 75 73 65 73 68 65 6c 6c 20 ms (if useshell
10400 22 26 22 20 22 22 29 29 29 29 29 0a 20 20 20 20 "&" ""))))).
10410 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
10420 61 72 67 20 22 2d 78 74 65 72 6d 22 29 28 73 65 arg "-xterm")(se
10430 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 70 65 t! fullcmd (appe
10440 6e 64 20 66 75 6c 6c 63 6d 64 20 28 6c 69 73 74 nd fullcmd (list
10450 20 22 2d 78 74 65 72 6d 22 29 29 29 29 0a 20 20 "-xterm")))).
10460 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
10470 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 1 *default-log-
10480 70 6f 72 74 2a 20 22 4c 61 75 6e 63 68 69 6e 67 port* "Launching
10490 20 22 20 77 6f 72 6b 2d 61 72 65 61 29 0a 20 20 " work-area).
104a0 20 20 20 20 3b 3b 20 73 65 74 20 70 72 65 2d 6c ;; set pre-l
104b0 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 73 20 62 aunch-env-vars b
104c0 65 66 6f 72 65 20 6c 61 75 6e 63 68 69 6e 67 2c efore launching,
104d0 20 6b 65 65 70 20 74 68 65 20 76 61 72 73 20 69 keep the vars i
104e0 6e 20 70 72 65 76 76 61 6c 73 20 61 6e 64 20 70 n prevvals and p
104f0 75 74 20 74 68 65 20 65 6e 76 69 6f 6e 6d 65 6e ut the envionmen
10500 74 20 62 61 63 6b 20 77 68 65 6e 20 64 6f 6e 65 t back when done
10510 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
10520 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
10530 6f 67 2d 70 6f 72 74 2a 20 22 66 75 6c 6c 63 6d og-port* "fullcm
10540 64 3a 20 22 20 66 75 6c 6c 63 6d 64 29 0a 20 20 d: " fullcmd).
10550 20 20 20 20 28 73 65 74 21 20 2a 6c 61 73 74 2d (set! *last-
10560 6c 61 75 6e 63 68 2a 20 28 63 75 72 72 65 6e 74 launch* (current
10570 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 61 6c -seconds)) ;; al
10580 6c 20 74 68 61 74 20 6a 75 6e 6b 20 61 62 6f 76 l that junk abov
10590 65 20 74 61 6b 65 73 20 74 69 6d 65 2c 20 73 65 e takes time, se
105a0 74 20 74 68 69 73 20 61 73 20 6c 61 74 65 20 61 t this as late a
105b0 73 20 70 6f 73 73 69 62 6c 65 2e 0a 20 20 20 20 s possible..
105c0 20 20 28 6c 65 74 2a 20 28 28 63 6f 6d 6d 6f 6e (let* ((common
105d0 70 72 65 76 76 61 6c 73 20 28 61 6c 69 73 74 2d prevvals (alist-
105e0 3e 65 6e 76 2d 76 61 72 73 0a 09 09 09 20 20 20 >env-vars....
105f0 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
10600 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 ef/default *conf
10610 69 67 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 igdat* "env-over
10620 72 69 64 65 22 20 27 28 29 29 29 29 0a 09 20 20 ride" '())))..
10630 20 20 20 28 6d 69 73 63 70 72 65 76 76 61 6c 73 (miscprevvals
10640 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 (alist->env-v
10650 61 72 73 20 3b 3b 20 63 6f 6e 73 6f 6c 69 64 61 ars ;; consolida
10660 74 65 20 74 68 69 73 20 63 6f 64 65 20 77 69 74 te this code wit
10670 68 20 74 68 65 20 63 6f 64 65 20 69 6e 20 6d 65 h the code in me
10680 67 61 74 65 73 74 2e 73 63 6d 20 66 6f 72 20 22 gatest.scm for "
10690 2d 65 78 65 63 75 74 65 22 0a 09 09 09 20 20 20 -execute"....
106a0 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 (append (list
106b0 20 28 6c 69 73 74 20 22 4d 54 5f 54 45 53 54 5f (list "MT_TEST_
106c0 52 55 4e 5f 44 49 52 22 20 77 6f 72 6b 2d 61 72 RUN_DIR" work-ar
106d0 65 61 29 0a 09 09 09 09 09 20 20 20 20 28 6c 69 ea)...... (li
106e0 73 74 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 st "MT_TEST_NAME
106f0 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 " test-name)....
10700 09 09 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f .. (list "MT_
10710 49 54 45 4d 5f 49 4e 46 4f 22 20 28 63 6f 6e 63 ITEM_INFO" (conc
10720 20 69 74 65 6d 64 61 74 29 29 20 0a 09 09 09 09 itemdat)) .....
10730 09 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f 52 . (list "MT_R
10740 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d UNNAME" runnam
10750 65 29 0a 09 09 09 09 09 20 20 20 20 28 6c 69 73 e)...... (lis
10760 74 20 22 4d 54 5f 54 41 52 47 45 54 22 20 20 20 t "MT_TARGET"
10770 20 6d 74 5f 74 61 72 67 65 74 29 0a 09 09 09 09 mt_target).....
10780 09 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f 49 . (list "MT_I
10790 54 45 4d 50 41 54 48 22 20 20 69 74 65 6d 2d 70 TEMPATH" item-p
107a0 61 74 68 29 0a 09 09 09 09 09 20 20 20 20 29 0a ath)...... ).
107b0 09 09 09 09 20 20 20 20 20 20 69 74 65 6d 64 61 .... itemda
107c0 74 29 29 29 0a 09 20 20 20 20 20 28 74 65 73 74 t))).. (test
107d0 70 72 65 76 76 61 6c 73 20 20 20 28 61 6c 69 73 prevvals (alis
107e0 74 2d 3e 65 6e 76 2d 76 61 72 73 0a 09 09 09 20 t->env-vars....
107f0 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
10800 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 63 6f -ref/default tco
10810 6e 66 69 67 20 22 70 72 65 2d 6c 61 75 6e 63 68 nfig "pre-launch
10820 2d 65 6e 76 2d 6f 76 65 72 72 69 64 65 73 22 20 -env-overrides"
10830 27 28 29 29 29 29 0a 09 20 20 20 20 20 3b 3b 20 '()))).. ;;
10840 4c 61 75 6e 63 68 77 61 69 74 20 64 65 66 61 75 Launchwait defau
10850 6c 74 73 20 74 6f 20 74 72 75 65 2c 20 6d 75 73 lts to true, mus
10860 74 20 6f 76 65 72 72 69 64 65 20 69 74 20 74 6f t override it to
10870 20 74 75 72 6e 20 6f 66 66 20 77 61 69 74 0a 09 turn off wait..
10880 20 20 20 20 20 28 6c 61 75 6e 63 68 77 61 69 74 (launchwait
10890 20 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f (if (equal?
108a0 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
108b0 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
108c0 74 75 70 22 20 22 6c 61 75 6e 63 68 77 61 69 74 tup" "launchwait
108d0 22 29 20 22 6e 6f 22 29 20 23 66 20 23 74 29 29 ") "no") #f #t))
108e0 0a 09 20 20 20 20 20 28 6c 61 75 6e 63 68 2d 72 .. (launch-r
108f0 65 73 75 6c 74 73 20 28 61 70 70 6c 79 20 28 69 esults (apply (i
10900 66 20 6c 61 75 6e 63 68 77 61 69 74 0a 09 09 09 f launchwait....
10910 09 09 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 ..process:cmd-ru
10920 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 2d 3e 6c n-with-stderr->l
10930 69 73 74 0a 09 09 09 09 09 70 72 6f 63 65 73 73 ist......process
10940 2d 72 75 6e 29 0a 09 09 09 09 20 20 20 20 28 69 -run)..... (i
10950 66 20 75 73 65 73 68 65 6c 6c 0a 09 09 09 09 09 f useshell......
10960 28 6c 65 74 20 28 28 63 6d 64 73 74 72 20 28 73 (let ((cmdstr (s
10970 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
10980 65 20 66 75 6c 6c 63 6d 64 20 22 20 22 29 29 29 e fullcmd " ")))
10990 0a 09 09 09 09 09 20 20 28 69 66 20 6c 61 75 6e ...... (if laun
109a0 63 68 77 61 69 74 0a 09 09 09 09 09 20 20 20 20 chwait......
109b0 20 20 63 6d 64 73 74 72 0a 09 09 09 09 09 20 20 cmdstr......
109c0 20 20 20 20 28 63 6f 6e 63 20 63 6d 64 73 74 72 (conc cmdstr
109d0 20 22 20 3e 3e 20 6d 74 5f 6c 61 75 6e 63 68 2e " >> mt_launch.
109e0 6c 6f 67 20 32 3e 26 31 20 26 22 29 29 29 0a 09 log 2>&1 &")))..
109f0 09 09 09 09 28 63 61 72 20 66 75 6c 6c 63 6d 64 ....(car fullcmd
10a00 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 75 ))..... (if u
10a10 73 65 73 68 65 6c 6c 0a 09 09 09 09 09 27 28 29 seshell......'()
10a20 0a 09 09 09 09 09 28 63 64 72 20 66 75 6c 6c 63 ......(cdr fullc
10a30 6d 64 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 md))))).
10a40 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
10a50 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 74 launch-setup-mut
10a60 65 78 2a 29 20 3b 3b 20 79 65 73 2c 20 72 65 61 ex*) ;; yes, rea
10a70 6c 6c 79 20 73 68 6f 75 6c 64 20 6d 75 74 65 78 lly should mutex
10a80 20 61 6c 6c 20 74 68 65 20 77 61 79 20 74 6f 20 all the way to
10a90 68 65 72 65 2e 20 4e 65 65 64 20 74 6f 20 70 75 here. Need to pu
10aa0 74 20 74 68 69 73 20 65 6e 74 69 72 65 20 70 72 t this entire pr
10ab0 6f 63 65 73 73 20 69 6e 74 6f 20 61 20 66 6f 72 ocess into a for
10ac0 6b 2e 0a 09 28 69 66 20 28 6e 6f 74 20 6c 61 75 k...(if (not lau
10ad0 6e 63 68 77 61 69 74 29 20 3b 3b 20 67 69 76 65 nchwait) ;; give
10ae0 20 74 68 65 20 4f 53 20 61 20 6c 69 74 74 6c 65 the OS a little
10af0 20 74 69 6d 65 20 74 6f 20 61 6c 6c 6f 77 20 74 time to allow t
10b00 68 65 20 70 72 6f 63 65 73 73 20 74 6f 20 73 74 he process to st
10b10 61 72 74 0a 09 20 20 20 20 28 74 68 72 65 61 64 art.. (thread
10b20 2d 73 6c 65 65 70 21 20 30 2e 30 31 29 29 0a 09 -sleep! 0.01))..
10b30 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
10b40 66 69 6c 65 20 22 6d 74 5f 6c 61 75 6e 63 68 2e file "mt_launch.
10b50 6c 6f 67 22 0a 09 20 20 28 6c 61 6d 62 64 61 20 log".. (lambda
10b60 28 29 0a 09 20 20 20 20 28 70 72 69 6e 74 20 22 ().. (print "
10b70 4c 41 55 4e 43 48 43 4d 44 3a 20 22 20 28 73 74 LAUNCHCMD: " (st
10b80 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
10b90 20 66 75 6c 6c 63 6d 64 20 22 20 22 29 29 0a 09 fullcmd " "))..
10ba0 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 6c (if (list? l
10bb0 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 29 0a 09 aunch-results)..
10bc0 09 28 61 70 70 6c 79 20 70 72 69 6e 74 20 6c 61 .(apply print la
10bd0 75 6e 63 68 2d 72 65 73 75 6c 74 73 29 0a 09 09 unch-results)...
10be0 28 70 72 69 6e 74 20 22 4e 4f 54 45 3a 20 6c 61 (print "NOTE: la
10bf0 75 6e 63 68 65 64 20 5c 22 22 20 66 75 6c 6c 63 unched \"" fullc
10c00 6d 64 20 22 5c 22 5c 6e 20 20 62 75 74 20 64 69 md "\"\n but di
10c10 64 20 6e 6f 74 20 77 61 69 74 20 66 6f 72 20 69 d not wait for i
10c20 74 20 74 6f 20 70 72 6f 63 65 65 64 2e 20 41 64 t to proceed. Ad
10c30 64 20 74 68 65 20 66 6f 6c 6c 6f 77 69 6e 67 20 d the following
10c40 74 6f 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 to megatest.conf
10c50 69 67 20 5c 6e 5b 73 65 74 75 70 5d 5c 6e 6c 61 ig \n[setup]\nla
10c60 75 6e 63 68 77 61 69 74 20 79 65 73 5c 6e 20 20 unchwait yes\n
10c70 69 66 20 79 6f 75 20 68 61 76 65 20 70 72 6f 62 if you have prob
10c80 6c 65 6d 73 20 77 69 74 68 20 74 68 69 73 22 29 lems with this")
10c90 29 0a 09 20 20 20 20 23 3a 61 70 70 65 6e 64 29 ).. #:append)
10ca0 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
10cb0 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
10cc0 6f 72 74 2a 20 22 4c 61 75 6e 63 68 69 6e 67 20 ort* "Launching
10cd0 63 6f 6d 70 6c 65 74 65 64 2c 20 75 70 64 61 74 completed, updat
10ce0 69 6e 67 20 64 62 22 29 0a 09 28 64 65 62 75 67 ing db")..(debug
10cf0 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c :print 2 *defaul
10d00 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4c 61 75 t-log-port* "Lau
10d10 6e 63 68 20 72 65 73 75 6c 74 73 3a 20 22 20 6c nch results: " l
10d20 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 29 0a 09 aunch-results)..
10d30 28 69 66 20 28 6e 6f 74 20 6c 61 75 6e 63 68 2d (if (not launch-
10d40 72 65 73 75 6c 74 73 29 0a 09 20 20 20 20 28 62 results).. (b
10d50 65 67 69 6e 0a 09 20 20 20 20 20 20 28 70 72 69 egin.. (pri
10d60 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 nt "ERROR: Faile
10d70 64 20 74 6f 20 72 75 6e 20 22 20 28 73 74 72 69 d to run " (stri
10d80 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 66 ng-intersperse f
10d90 75 6c 6c 63 6d 64 20 22 20 22 29 20 22 2c 20 65 ullcmd " ") ", e
10da0 78 69 74 69 6e 67 20 6e 6f 77 22 29 0a 09 20 20 xiting now")..
10db0 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a ;; (sqlite3:
10dc0 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 20 finalize! db)..
10dd0 20 20 20 20 20 3b 3b 20 67 6f 6f 64 20 6f 6c 65 ;; good ole
10de0 20 22 65 78 69 74 22 20 73 65 65 6d 73 20 6e 6f "exit" seems no
10df0 74 20 74 6f 20 77 6f 72 6b 0a 09 20 20 20 20 20 t to work..
10e00 20 3b 3b 20 28 5f 65 78 69 74 20 39 29 0a 09 20 ;; (_exit 9)..
10e10 20 20 20 20 20 3b 3b 20 62 75 74 20 74 68 69 73 ;; but this
10e20 20 68 61 63 6b 20 77 69 6c 6c 20 77 6f 72 6b 21 hack will work!
10e30 20 54 68 61 6e 6b 73 20 67 6f 20 74 6f 20 41 6c Thanks go to Al
10e40 61 6e 20 50 6f 73 74 20 6f 66 20 74 68 65 20 43 an Post of the C
10e50 68 69 63 6b 65 6e 20 65 6d 61 69 6c 20 6c 69 73 hicken email lis
10e60 74 0a 09 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f t.. ;; NB//
10e70 20 49 73 20 74 68 69 73 20 73 74 69 6c 6c 20 6e Is this still n
10e80 65 65 64 65 64 3f 20 53 68 6f 75 6c 64 20 62 65 eeded? Should be
10e90 20 73 61 66 65 20 74 6f 20 67 6f 20 62 61 63 6b safe to go back
10ea0 20 74 6f 20 22 65 78 69 74 22 20 6e 6f 77 3f 0a to "exit" now?.
10eb0 09 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 2d . (process-
10ec0 73 69 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d signal (current-
10ed0 70 72 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e process-id) sign
10ee0 61 6c 2f 6b 69 6c 6c 29 0a 09 20 20 20 20 20 20 al/kill)..
10ef0 29 29 0a 09 28 61 6c 69 73 74 2d 3e 65 6e 76 2d ))..(alist->env-
10f00 76 61 72 73 20 6d 69 73 63 70 72 65 76 76 61 6c vars miscprevval
10f10 73 29 0a 09 28 61 6c 69 73 74 2d 3e 65 6e 76 2d s)..(alist->env-
10f20 76 61 72 73 20 74 65 73 74 70 72 65 76 76 61 6c vars testprevval
10f30 73 29 0a 09 28 61 6c 69 73 74 2d 3e 65 6e 76 2d s)..(alist->env-
10f40 76 61 72 73 20 63 6f 6d 6d 6f 6e 70 72 65 76 76 vars commonprevv
10f50 61 6c 73 29 0a 09 6c 61 75 6e 63 68 2d 72 65 73 als)..launch-res
10f60 75 6c 74 73 29 29 0a 20 20 20 20 28 63 68 61 6e ults)). (chan
10f70 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f ge-directory *to
10f80 70 70 61 74 68 2a 29 29 29 0a 0a 3b 3b 20 72 65 ppath*)))..;; re
10f90 63 6f 76 65 72 20 61 20 74 65 73 74 20 77 68 65 cover a test whe
10fa0 72 65 20 74 68 65 20 74 6f 70 20 63 6f 6e 74 72 re the top contr
10fb0 6f 6c 6c 69 6e 67 20 6d 74 65 73 74 20 6d 61 79 olling mtest may
10fc0 20 68 61 76 65 20 64 69 65 64 0a 3b 3b 0a 28 64 have died.;;.(d
10fd0 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 72 65 efine (launch:re
10fe0 63 6f 76 65 72 2d 74 65 73 74 20 72 75 6e 2d 69 cover-test run-i
10ff0 64 20 74 65 73 74 2d 69 64 29 0a 20 20 3b 3b 20 d test-id). ;;
11000 74 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 69 73 this function is
11010 20 63 61 6c 6c 65 64 20 6f 6e 20 74 68 65 20 74 called on the t
11020 65 73 74 20 72 75 6e 20 68 6f 73 74 20 76 69 61 est run host via
11030 20 73 73 68 0a 20 20 3b 3b 0a 20 20 3b 3b 20 31 ssh. ;;. ;; 1
11040 2e 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 70 72 . look at the pr
11050 6f 63 65 73 73 20 66 72 6f 6d 20 70 69 64 0a 20 ocess from pid.
11060 20 3b 3b 20 20 20 20 2d 20 69 73 20 69 74 20 6f ;; - is it o
11070 77 6e 65 64 20 62 79 20 63 61 6c 6c 69 6e 67 20 wned by calling
11080 75 73 65 72 0a 20 20 3b 3b 20 20 20 20 2d 20 69 user. ;; - i
11090 74 20 69 74 27 73 20 72 75 6e 20 64 69 72 65 63 t it's run direc
110a0 74 6f 72 79 20 63 6f 72 72 65 63 74 20 66 6f 72 tory correct for
110b0 20 74 68 65 20 74 65 73 74 0a 20 20 3b 3b 20 20 the test. ;;
110c0 20 20 2d 20 69 73 20 74 68 65 72 65 20 61 20 63 - is there a c
110d0 6f 6e 74 72 6f 6c 6c 69 6e 67 20 6d 74 65 73 74 ontrolling mtest
110e0 20 28 6d 61 79 62 65 20 73 74 75 63 6b 29 0a 20 (maybe stuck).
110f0 20 3b 3b 20 32 2e 20 69 66 20 72 65 63 6f 76 65 ;; 2. if recove
11100 72 79 20 69 73 20 6e 65 65 64 65 64 20 77 61 74 ry is needed wat
11110 63 68 20 70 69 64 0a 20 20 3b 3b 20 20 20 20 2d ch pid. ;; -
11120 20 77 68 65 6e 20 69 74 20 65 78 69 74 73 20 74 when it exits t
11130 61 6b 65 20 74 68 65 20 65 78 69 74 20 63 6f 64 ake the exit cod
11140 65 20 61 6e 64 20 64 6f 20 74 68 65 20 6e 65 65 e and do the nee
11150 64 66 75 6c 0a 20 20 3b 3b 0a 20 20 28 6c 65 74 dful. ;;. (let
11160 2a 20 28 28 70 69 64 20 28 72 6d 74 3a 74 65 73 * ((pid (rmt:tes
11170 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 65 73 t-get-top-proces
11180 73 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 s-id run-id test
11190 2d 69 64 29 29 0a 09 20 28 70 73 72 65 73 20 28 -id)).. (psres (
111a0 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
111b0 70 69 70 65 0a 09 09 20 28 63 6f 6e 63 20 22 70 pipe... (conc "p
111c0 73 20 2d 46 20 2d 75 20 22 20 28 63 75 72 72 65 s -F -u " (curre
111d0 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 22 20 nt-user-name) "
111e0 7c 20 67 72 65 70 20 2d 45 20 27 22 20 70 69 64 | grep -E '" pid
111f0 20 22 20 27 20 7c 20 67 72 65 70 20 2d 76 20 27 " ' | grep -v '
11200 67 72 65 70 20 2d 45 20 22 20 70 69 64 20 22 27 grep -E " pid "'
11210 22 29 0a 09 09 20 28 6c 61 6d 62 64 61 20 28 29 ")... (lambda ()
11220 0a 09 09 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 ... (read-line
11230 29 29 29 29 0a 09 20 28 72 75 6e 64 69 72 20 28 )))).. (rundir (
11240 69 66 20 28 73 74 72 69 6e 67 3f 20 70 73 72 65 if (string? psre
11250 73 29 20 3b 3b 20 72 65 61 6c 20 70 72 6f 63 65 s) ;; real proce
11260 73 73 20 6f 77 6e 65 64 20 62 79 20 75 73 65 72 ss owned by user
11270 0a 09 09 20 20 20 20 20 28 72 65 61 64 2d 73 79 ... (read-sy
11280 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 20 28 63 6f 6e mbolic-link (con
11290 63 20 22 2f 70 72 6f 63 2f 22 20 70 69 64 20 22 c "/proc/" pid "
112a0 2f 63 77 64 22 29 29 0a 09 09 20 20 20 20 20 23 /cwd"))... #
112b0 66 29 29 29 0a 20 20 20 20 3b 3b 20 6e 6f 77 20 f))). ;; now
112c0 77 61 69 74 20 6f 6e 20 74 68 61 74 20 70 72 6f wait on that pro
112d0 63 65 73 73 20 69 66 20 61 6c 6c 20 69 73 20 63 cess if all is c
112e0 6f 72 72 65 63 74 0a 20 20 20 20 3b 3b 20 70 65 orrect. ;; pe
112f0 72 69 6f 64 69 63 61 6c 6c 79 20 75 70 64 61 74 riodically updat
11300 65 20 74 68 65 20 64 62 20 77 69 74 68 20 72 75 e the db with ru
11310 6e 74 69 6d 65 0a 20 20 20 20 3b 3b 20 77 68 65 ntime. ;; whe
11320 6e 20 74 68 65 20 70 72 6f 63 65 73 73 20 65 78 n the process ex
11330 69 74 73 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 its look at the
11340 64 62 2c 20 69 66 20 73 74 69 6c 6c 20 52 55 4e db, if still RUN
11350 4e 49 4e 47 20 61 66 74 65 72 20 31 30 20 73 65 NING after 10 se
11360 63 6f 6e 64 73 20 73 65 74 0a 20 20 20 20 3b 3b conds set. ;;
11370 20 73 74 61 74 65 2f 73 74 61 74 75 73 20 61 70 state/status ap
11380 70 72 6f 70 72 69 61 74 65 6c 79 0a 20 20 20 20 propriately.
11390 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 69 (process-wait pi
113a0 64 29 29 29 0a d))).