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 29 0a 0a 28 hname-expand)..(
02c0: 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 62 import (prefix b
02d0: 61 73 65 36 34 20 62 61 73 65 36 34 3a 29 29 0a ase64 base64:)).
02e0: 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 (import (prefix
02f0: 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a sqlite3 sqlite3:
0300: 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e ))..(declare (un
0310: 69 74 20 6c 61 75 6e 63 68 29 29 0a 28 64 65 63 it launch)).(dec
0320: 6c 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f lare (uses commo
0330: 6e 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 n)).(declare (us
0340: 65 73 20 63 6f 6e 66 69 67 66 29 29 0a 28 64 65 es configf)).(de
0350: 63 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 29 clare (uses db))
0360: 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 73 .;; (declare (us
0370: 65 73 20 73 64 62 29 29 0a 28 64 65 63 6c 61 72 es sdb)).(declar
0380: 65 20 28 75 73 65 73 20 74 64 62 29 29 0a 3b 3b e (uses tdb)).;;
0390: 20 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 (declare (uses
03a0: 66 69 6c 65 64 62 29 29 0a 0a 28 69 6e 63 6c 75 filedb))..(inclu
03b0: 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 de "common_recor
03c0: 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 ds.scm").(includ
03d0: 65 20 22 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 e "key_records.s
03e0: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 cm").(include "d
03f0: 62 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a b_records.scm").
0400: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
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 0a 3b 3b 20 65 7a 73 =========.;; ezs
0450: 74 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d teps.;;=========
0460: 3d 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 0a 0a 3b =============..;
04a0: 3b 20 65 7a 73 74 65 70 73 20 77 65 72 65 20 67 ; ezsteps were g
04b0: 6f 69 6e 67 20 74 6f 20 62 65 20 63 6f 64 65 64 oing to be coded
04c0: 20 61 73 0a 3b 3b 20 73 74 65 70 6e 61 6d 65 5b as.;; stepname[
04d0: 2c 70 72 65 64 73 74 65 70 31 2c 70 72 65 64 73 ,predstep1,preds
04e0: 74 65 70 32 20 2e 2e 2e 5d 20 5b 7b 56 41 52 31 tep2 ...] [{VAR1
04f0: 3d 66 69 72 73 74 2c 73 65 63 6f 6e 64 2c 74 68 =first,second,th
0500: 69 72 64 7d 5d 20 63 6f 6d 6d 61 6e 64 20 74 6f ird}] command to
0510: 20 65 78 65 63 75 74 65 0a 3b 3b 20 20 20 42 55 execute.;; BU
0520: 54 0a 3b 3b 20 6e 6f 77 20 61 72 65 0a 3b 3b 20 T.;; now are.;;
0530: 73 74 65 70 6e 61 6d 65 20 7b 56 41 52 3d 66 69 stepname {VAR=fi
0540: 72 73 74 2c 73 65 63 6f 6e 64 2c 74 68 69 72 64 rst,second,third
0550: 20 2e 2e 2e 7d 20 63 6f 6d 6d 61 6e 64 20 2e 2e ...} command ..
0560: 2e 0a 3b 3b 20 77 68 65 72 65 20 74 68 65 20 7b ..;; where the {
0570: 56 41 52 3d 66 69 72 73 74 2c 73 65 63 6f 6e 64 VAR=first,second
0580: 2c 74 68 69 72 64 20 2e 2e 2e 7d 20 69 73 20 6f ,third ...} is o
0590: 70 74 69 6f 6e 61 6c 2e 0a 0a 3b 3b 20 67 69 76 ptional...;; giv
05a0: 65 6e 20 61 6e 20 65 78 69 74 20 63 6f 64 65 20 en an exit code
05b0: 61 6e 64 20 77 68 65 74 68 65 72 20 6f 72 20 6e and whether or n
05c0: 6f 74 20 6c 6f 67 70 72 6f 20 77 61 73 20 75 73 ot logpro was us
05d0: 65 64 20 63 61 6c 63 75 6c 61 74 65 20 4f 4b 2f ed calculate OK/
05e0: 42 41 44 0a 3b 3b 20 72 65 74 75 72 6e 20 23 74 BAD.;; return #t
05f0: 20 69 66 20 77 65 20 61 72 65 20 6f 6b 2c 20 23 if we are ok, #
0600: 66 20 6f 74 68 65 72 77 69 73 65 0a 28 64 65 66 f otherwise.(def
0610: 69 6e 65 20 28 73 74 65 70 72 75 6e 2d 67 6f 6f ine (steprun-goo
0620: 64 3f 20 6c 6f 67 70 72 6f 20 65 78 69 74 63 6f d? logpro exitco
0630: 64 65 29 0a 20 20 28 6f 72 20 28 65 71 3f 20 65 de). (or (eq? e
0640: 78 69 74 63 6f 64 65 20 30 29 0a 20 20 20 20 20 xitcode 0).
0650: 20 28 61 6e 64 20 6c 6f 67 70 72 6f 20 28 65 71 (and logpro (eq
0660: 3f 20 65 78 69 74 63 6f 64 65 20 32 29 29 29 29 ? exitcode 2))))
0670: 0a 0a 3b 3b 20 69 66 20 68 61 6e 64 65 64 20 61 ..;; if handed a
0680: 20 73 74 72 69 6e 67 2c 20 70 72 6f 63 65 73 73 string, process
0690: 20 69 74 2c 20 65 6c 73 65 20 6c 6f 6f 6b 20 66 it, else look f
06a0: 6f 72 20 4d 54 5f 43 4d 44 49 4e 46 4f 0a 28 64 or MT_CMDINFO.(d
06b0: 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 67 65 efine (launch:ge
06c0: 74 2d 63 6d 64 69 6e 66 6f 2d 61 73 73 6f 63 2d t-cmdinfo-assoc-
06d0: 6c 69 73 74 20 23 21 6b 65 79 20 28 65 6e 63 6f list #!key (enco
06e0: 64 65 64 2d 63 6d 64 20 23 66 29 29 0a 20 20 28 ded-cmd #f)). (
06f0: 6c 65 74 20 28 28 65 6e 63 63 6d 64 20 28 69 66 let ((enccmd (if
0700: 20 65 6e 63 6f 64 65 64 2d 63 6d 64 20 65 6e 63 encoded-cmd enc
0710: 6f 64 65 64 2d 63 6d 64 20 28 67 65 74 65 6e 76 oded-cmd (getenv
0720: 20 22 4d 54 5f 43 4d 44 49 4e 46 4f 22 29 29 29 "MT_CMDINFO")))
0730: 29 0a 20 20 20 20 28 69 66 20 65 6e 63 63 6d 64 ). (if enccmd
0740: 0a 09 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 65 ..(common:read-e
0750: 6e 63 6f 64 65 64 2d 73 74 72 69 6e 67 20 65 6e ncoded-string en
0760: 63 63 6d 64 29 0a 09 27 28 29 29 29 29 0a 0a 3b ccmd)..'())))..;
0770: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
0780: 20 20 20 20 20 20 20 20 30 20 20 20 20 20 20 20 0
0790: 20 20 20 20 31 20 20 20 20 20 20 20 20 20 20 20 1
07a0: 20 20 20 32 20 20 20 20 20 20 20 20 20 20 20 20 2
07b0: 20 20 33 0a 28 64 65 66 73 74 72 75 63 74 20 6c 3.(defstruct l
07c0: 61 75 6e 63 68 3a 65 69 6e 66 20 28 70 69 64 20 aunch:einf (pid
07d0: 23 74 29 28 65 78 69 74 2d 73 74 61 74 75 73 20 #t)(exit-status
07e0: 23 74 29 28 65 78 69 74 2d 63 6f 64 65 20 23 74 #t)(exit-code #t
07f0: 29 28 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 )(rollup-status
0800: 30 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 28 0))..;; return (
0810: 63 6f 6e 63 20 73 74 61 74 75 73 20 22 3a 20 22 conc status ": "
0820: 20 63 6f 6d 6d 65 6e 74 29 20 66 72 6f 6d 20 74 comment) from t
0830: 68 65 20 66 69 6e 61 6c 20 73 65 63 74 69 6f 6e he final section
0840: 20 73 6f 20 74 68 61 74 0a 3b 3b 20 20 20 74 68 so that.;; th
0850: 65 20 63 6f 6d 6d 65 6e 74 20 63 61 6e 20 62 65 e comment can be
0860: 20 73 65 74 20 69 6e 20 74 68 65 20 73 74 65 70 set in the step
0870: 20 72 65 63 6f 72 64 20 69 6e 20 6c 61 75 6e 63 record in launc
0880: 68 2e 73 63 6d 0a 3b 3b 0a 28 64 65 66 69 6e 65 h.scm.;;.(define
0890: 20 28 6c 61 75 6e 63 68 3a 6c 6f 61 64 2d 6c 6f (launch:load-lo
08a0: 67 70 72 6f 2d 64 61 74 20 72 75 6e 2d 69 64 20 gpro-dat run-id
08b0: 74 65 73 74 2d 69 64 20 73 74 65 70 6e 61 6d 65 test-id stepname
08c0: 29 0a 20 20 28 6c 65 74 20 28 28 63 6e 61 6d 65 ). (let ((cname
08d0: 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 6d 65 20 (conc stepname
08e0: 22 2e 64 61 74 22 29 29 29 0a 20 20 20 20 28 69 ".dat"))). (i
08f0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
0900: 63 6e 61 6d 65 29 0a 09 28 6c 65 74 2a 20 28 28 cname)..(let* ((
0910: 64 61 74 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 dat (read-confi
0920: 67 20 63 6e 61 6d 65 20 23 66 20 23 66 29 29 0a g cname #f #f)).
0930: 09 20 20 20 20 20 20 20 28 63 73 76 72 20 28 64 . (csvr (d
0940: 62 3a 6c 6f 67 70 72 6f 2d 64 61 74 2d 3e 63 73 b:logpro-dat->cs
0950: 76 20 64 61 74 20 73 74 65 70 6e 61 6d 65 29 29 v dat stepname))
0960: 0a 09 20 20 20 20 20 20 20 28 63 73 76 74 20 28 .. (csvt (
0970: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 20 28 66 let-values (( (f
0980: 6d 74 2d 63 65 6c 6c 20 66 6d 74 2d 72 65 63 6f mt-cell fmt-reco
0990: 72 64 20 66 6d 74 2d 63 73 76 29 20 28 6d 61 6b rd fmt-csv) (mak
09a0: 65 2d 66 6f 72 6d 61 74 20 22 2c 22 29 29 29 0a e-format ","))).
09b0: 09 09 09 09 20 28 66 6d 74 2d 63 73 76 20 28 6d .... (fmt-csv (m
09c0: 61 70 20 6c 69 73 74 2d 3e 63 73 76 2d 72 65 63 ap list->csv-rec
09d0: 6f 72 64 20 63 73 76 72 29 29 29 29 0a 09 20 20 ord csvr))))..
09e0: 20 20 20 20 20 28 73 74 61 74 75 73 20 28 63 6f (status (co
09f0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 64 61 74 nfigf:lookup dat
0a00: 20 22 66 69 6e 61 6c 22 20 22 65 78 69 74 2d 73 "final" "exit-s
0a10: 74 61 74 75 73 22 29 29 0a 09 20 20 20 20 20 20 tatus"))..
0a20: 20 28 6d 73 67 20 20 20 20 20 28 63 6f 6e 66 69 (msg (confi
0a30: 67 66 3a 6c 6f 6f 6b 75 70 20 64 61 74 20 22 66 gf:lookup dat "f
0a40: 69 6e 61 6c 22 20 22 6d 65 73 73 61 67 65 22 29 inal" "message")
0a50: 29 29 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 28 )). ;;(
0a60: 69 66 20 63 73 76 74 20 20 3b 3b 20 74 68 69 73 if csvt ;; this
0a70: 20 69 66 20 62 6c 6f 63 6b 65 64 20 73 74 61 63 if blocked stac
0a80: 6b 20 64 75 6d 70 20 63 61 75 73 65 64 20 62 79 k dump caused by
0a90: 20 2e 64 61 74 20 66 69 6c 65 20 66 72 6f 6d 20 .dat file from
0aa0: 6c 6f 67 70 72 6f 20 62 65 69 6e 67 20 30 2d 62 logpro being 0-b
0ab0: 79 74 65 2e 20 20 66 69 78 65 64 20 62 79 20 75 yte. fixed by u
0ac0: 70 67 72 61 64 69 6e 67 20 6c 6f 67 70 72 6f 0a pgrading logpro.
0ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
0ae0: 6d 74 3a 63 73 76 2d 3e 74 65 73 74 2d 64 61 74 mt:csv->test-dat
0af0: 61 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 a run-id test-id
0b00: 20 63 73 76 74 29 0a 20 20 20 20 20 20 20 20 20 csvt).
0b10: 20 20 20 3b 3b 20 20 28 42 42 3e 20 22 45 72 72 ;; (BB> "Err
0b20: 6f 72 3a 20 72 75 6e 2d 69 64 2f 74 65 73 74 2d or: run-id/test-
0b30: 69 64 2f 73 74 65 70 6e 61 6d 65 3d 22 72 75 6e id/stepname="run
0b40: 2d 69 64 22 2f 22 74 65 73 74 2d 69 64 22 2f 22 -id"/"test-id"/"
0b50: 73 74 65 70 6e 61 6d 65 22 20 3d 3e 20 62 61 64 stepname" => bad
0b60: 20 63 73 76 72 3d 22 63 73 76 72 29 0a 20 20 20 csvr="csvr).
0b70: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 29 0a 09 ;; )..
0b80: 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 65 71 (cond.. ((eq
0b90: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 ual? status "PAS
0ba0: 53 22 29 20 22 50 41 53 53 22 29 20 3b 3b 20 73 S") "PASS") ;; s
0bb0: 6b 69 70 20 74 68 65 20 6d 65 73 73 61 67 65 20 kip the message
0bc0: 70 61 72 74 20 69 66 20 73 74 61 74 75 73 20 69 part if status i
0bd0: 73 20 70 61 73 73 0a 09 20 20 20 28 73 74 61 74 s pass.. (stat
0be0: 75 73 20 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 us (conc (config
0bf0: 66 3a 6c 6f 6f 6b 75 70 20 64 61 74 20 22 66 69 f:lookup dat "fi
0c00: 6e 61 6c 22 20 22 65 78 69 74 2d 73 74 61 74 75 nal" "exit-statu
0c10: 73 22 29 20 22 3a 20 22 20 28 69 66 20 6d 73 67 s") ": " (if msg
0c20: 20 6d 73 67 20 22 6e 6f 20 6d 65 73 73 61 67 65 msg "no message
0c30: 22 29 29 29 0a 09 20 20 20 28 65 6c 73 65 20 23 "))).. (else #
0c40: 66 29 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 f)))..#f)))..(de
0c50: 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 72 75 6e fine (launch:run
0c60: 73 74 65 70 20 65 7a 73 74 65 70 20 72 75 6e 2d step ezstep run-
0c70: 69 64 20 74 65 73 74 2d 69 64 20 65 78 69 74 2d id test-id exit-
0c80: 69 6e 66 6f 20 6d 20 74 61 6c 20 74 65 73 74 63 info m tal testc
0c90: 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 28 onfig). (let* (
0ca0: 28 73 74 65 70 6e 61 6d 65 20 20 20 20 20 20 20 (stepname
0cb0: 28 63 61 72 20 65 7a 73 74 65 70 29 29 20 20 3b (car ezstep)) ;
0cc0: 3b 20 64 6f 20 73 74 75 66 66 20 74 6f 20 72 75 ; do stuff to ru
0cd0: 6e 20 74 68 65 20 73 74 65 70 0a 09 20 28 73 74 n the step.. (st
0ce0: 65 70 69 6e 66 6f 20 20 20 20 20 20 20 28 63 61 epinfo (ca
0cf0: 64 72 20 65 7a 73 74 65 70 29 29 0a 09 20 28 73 dr ezstep)).. (s
0d00: 74 65 70 70 61 72 74 73 20 20 20 20 20 20 28 73 tepparts (s
0d10: 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 tring-match (reg
0d20: 65 78 70 20 22 5e 28 5c 5c 7b 28 5b 5e 5c 5c 7d exp "^(\\{([^\\}
0d30: 5d 2a 29 5c 5c 7d 5c 5c 73 2a 7c 29 28 2e 2a 29 ]*)\\}\\s*|)(.*)
0d40: 24 22 29 20 73 74 65 70 69 6e 66 6f 29 29 0a 09 $") stepinfo))..
0d50: 20 28 73 74 65 70 70 61 72 6d 73 20 20 20 20 20 (stepparms
0d60: 20 28 6c 69 73 74 2d 72 65 66 20 73 74 65 70 70 (list-ref stepp
0d70: 61 72 74 73 20 32 29 29 20 3b 3b 20 66 6f 72 20 arts 2)) ;; for
0d80: 66 75 74 75 72 65 20 75 73 65 2c 20 7b 56 41 52 future use, {VAR
0d90: 3d 31 2c 32 2c 33 7d 2c 20 72 75 6e 20 73 74 65 =1,2,3}, run ste
0da0: 70 20 66 6f 72 20 65 61 63 68 20 0a 09 20 28 73 p for each .. (s
0db0: 74 65 70 63 6d 64 20 20 20 20 20 20 20 20 28 6c tepcmd (l
0dc0: 69 73 74 2d 72 65 66 20 73 74 65 70 70 61 72 74 ist-ref steppart
0dd0: 73 20 33 29 29 0a 09 20 28 73 63 72 69 70 74 20 s 3)).. (script
0de0: 20 20 20 20 20 20 20 20 22 22 29 20 3b 20 22 23 "") ; "#
0df0: 21 2f 62 69 6e 2f 62 61 73 68 5c 6e 22 29 20 3b !/bin/bash\n") ;
0e00: 3b 20 79 65 70 2c 20 77 65 20 64 65 70 65 6e 64 ; yep, we depend
0e10: 20 6f 6e 20 62 69 6e 2f 62 61 73 68 20 46 49 58 on bin/bash FIX
0e20: 4d 45 21 21 21 5c 0a 09 20 28 6c 6f 67 70 72 6f ME!!!\.. (logpro
0e30: 2d 66 69 6c 65 20 20 20 20 28 63 6f 6e 63 20 73 -file (conc s
0e40: 74 65 70 6e 61 6d 65 20 22 2e 6c 6f 67 70 72 6f tepname ".logpro
0e50: 22 29 29 0a 09 20 28 68 74 6d 6c 2d 66 69 6c 65 ")).. (html-file
0e60: 20 20 20 20 20 20 28 63 6f 6e 63 20 73 74 65 70 (conc step
0e70: 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 29 0a 09 name ".html"))..
0e80: 20 28 64 61 74 2d 66 69 6c 65 20 20 20 20 20 20 (dat-file
0e90: 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 6d 65 20 (conc stepname
0ea0: 22 2e 64 61 74 22 29 29 0a 09 20 28 74 63 6f 6e ".dat")).. (tcon
0eb0: 66 69 67 2d 6c 6f 67 70 72 6f 20 28 63 6f 6e 66 fig-logpro (conf
0ec0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 igf:lookup testc
0ed0: 6f 6e 66 69 67 20 22 6c 6f 67 70 72 6f 22 20 73 onfig "logpro" s
0ee0: 74 65 70 6e 61 6d 65 29 29 0a 09 20 28 6c 6f 67 tepname)).. (log
0ef0: 70 72 6f 2d 75 73 65 64 20 20 20 20 28 66 69 6c pro-used (fil
0f00: 65 2d 65 78 69 73 74 73 3f 20 6c 6f 67 70 72 6f e-exists? logpro
0f10: 2d 66 69 6c 65 29 29 29 0a 0a 20 20 20 20 28 69 -file))).. (i
0f20: 66 20 28 61 6e 64 20 74 63 6f 6e 66 69 67 2d 6c f (and tconfig-l
0f30: 6f 67 70 72 6f 0a 09 20 20 20 20 20 28 6e 6f 74 ogpro.. (not
0f40: 20 6c 6f 67 70 72 6f 2d 75 73 65 64 29 29 20 3b logpro-used)) ;
0f50: 3b 20 6e 6f 20 6c 6f 67 70 72 6f 20 66 69 6c 65 ; no logpro file
0f60: 20 66 6f 75 6e 64 20 62 75 74 20 68 61 76 65 20 found but have
0f70: 61 20 64 65 66 6e 20 69 6e 20 74 68 65 20 74 65 a defn in the te
0f80: 73 74 63 6f 6e 66 69 67 0a 09 28 62 65 67 69 6e stconfig..(begin
0f90: 0a 09 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 .. (with-output
0fa0: 2d 74 6f 2d 66 69 6c 65 20 6c 6f 67 70 72 6f 2d -to-file logpro-
0fb0: 66 69 6c 65 0a 09 20 20 20 20 28 6c 61 6d 62 64 file.. (lambd
0fc0: 61 20 28 29 0a 09 20 20 20 20 20 20 28 70 72 69 a ().. (pri
0fd0: 6e 74 20 22 3b 3b 20 6c 6f 67 70 72 6f 20 66 69 nt ";; logpro fi
0fe0: 6c 65 20 65 78 74 72 61 63 74 65 64 20 66 72 6f le extracted fro
0ff0: 6d 20 74 65 73 74 63 6f 6e 66 69 67 5c 6e 22 0a m testconfig\n".
1000: 09 09 20 20 20 20 20 22 3b 3b 22 29 0a 09 20 20 .. ";;")..
1010: 20 20 20 20 28 70 72 69 6e 74 20 74 63 6f 6e 66 (print tconf
1020: 69 67 2d 6c 6f 67 70 72 6f 29 29 29 0a 09 20 20 ig-logpro)))..
1030: 28 73 65 74 21 20 6c 6f 67 70 72 6f 2d 75 73 65 (set! logpro-use
1040: 64 20 23 74 29 29 29 0a 20 20 20 20 0a 20 20 20 d #t))). .
1050: 20 3b 3b 20 4e 42 2f 2f 20 63 61 6e 20 73 61 66 ;; NB// can saf
1060: 65 6c 79 20 61 73 73 75 6d 65 20 77 65 20 61 72 ely assume we ar
1070: 65 20 69 6e 20 74 65 73 74 2d 61 72 65 61 20 64 e in test-area d
1080: 69 72 65 63 74 6f 72 79 0a 20 20 20 20 28 64 65 irectory. (de
1090: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
10a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
10b0: 65 7a 73 74 65 70 73 3a 5c 6e 20 73 74 65 70 6e ezsteps:\n stepn
10c0: 61 6d 65 3a 20 22 20 73 74 65 70 6e 61 6d 65 20 ame: " stepname
10d0: 22 20 73 74 65 70 69 6e 66 6f 3a 20 22 20 73 74 " stepinfo: " st
10e0: 65 70 69 6e 66 6f 20 22 20 73 74 65 70 70 61 72 epinfo " steppar
10f0: 74 73 3a 20 22 20 73 74 65 70 70 61 72 74 73 0a ts: " stepparts.
1100: 09 09 20 22 20 73 74 65 70 70 61 72 6d 73 3a 20 .. " stepparms:
1110: 22 20 73 74 65 70 70 61 72 6d 73 20 22 20 73 74 " stepparms " st
1120: 65 70 63 6d 64 3a 20 22 20 73 74 65 70 63 6d 64 epcmd: " stepcmd
1130: 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 3b 3b ). . ;; ;;
1140: 20 66 69 72 73 74 20 73 6f 75 72 63 65 20 74 68 first source th
1150: 65 20 70 72 65 76 69 6f 75 73 20 65 6e 76 69 72 e previous envir
1160: 6f 6e 6d 65 6e 74 0a 20 20 20 20 3b 3b 20 28 6c onment. ;; (l
1170: 65 74 20 28 28 70 72 65 76 2d 65 6e 76 20 28 63 et ((prev-env (c
1180: 6f 6e 63 20 22 2e 65 7a 73 74 65 70 73 2f 22 20 onc ".ezsteps/"
1190: 70 72 65 76 73 74 65 70 20 28 69 66 20 28 73 74 prevstep (if (st
11a0: 72 69 6e 67 2d 73 65 61 72 63 68 20 28 72 65 67 ring-search (reg
11b0: 65 78 70 20 22 63 73 68 22 29 20 0a 20 20 20 20 exp "csh") .
11c0: 3b 3b 20 20 20 20 20 20 09 09 09 09 09 09 09 20 ;; .......
11d0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
11e0: 2d 76 61 72 69 61 62 6c 65 20 22 53 48 45 4c 4c -variable "SHELL
11f0: 22 29 29 20 22 2e 63 73 68 22 20 22 2e 73 68 22 ")) ".csh" ".sh"
1200: 29 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 28 69 )))). ;; (i
1210: 66 20 28 61 6e 64 20 70 72 65 76 73 74 65 70 20 f (and prevstep
1220: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 72 (file-exists? pr
1230: 65 76 2d 65 6e 76 29 29 0a 20 20 20 20 3b 3b 20 ev-env)). ;;
1240: 20 20 20 20 20 20 28 73 65 74 21 20 73 63 72 69 (set! scri
1250: 70 74 20 28 63 6f 6e 63 20 73 63 72 69 70 74 20 pt (conc script
1260: 22 73 6f 75 72 63 65 20 22 20 70 72 65 76 2d 65 "source " prev-e
1270: 6e 76 29 29 29 29 0a 20 20 20 20 0a 20 20 20 20 nv)))). .
1280: 3b 3b 20 63 61 6c 6c 20 74 68 65 20 63 6f 6d 6d ;; call the comm
1290: 61 6e 64 20 75 73 69 6e 67 20 6d 74 5f 65 7a 73 and using mt_ezs
12a0: 74 65 70 0a 20 20 20 20 3b 3b 20 28 73 65 74 21 tep. ;; (set!
12b0: 20 73 63 72 69 70 74 20 28 63 6f 6e 63 20 22 6d script (conc "m
12c0: 74 5f 65 7a 73 74 65 70 20 22 20 73 74 65 70 6e t_ezstep " stepn
12d0: 61 6d 65 20 22 20 22 20 28 69 66 20 70 72 65 76 ame " " (if prev
12e0: 73 74 65 70 20 70 72 65 76 73 74 65 70 20 22 78 step prevstep "x
12f0: 22 29 20 22 20 22 20 73 74 65 70 63 6d 64 29 29 ") " " stepcmd))
1300: 0a 20 20 20 20 0a 20 20 20 20 28 64 65 62 75 67 . . (debug
1310: 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
1320: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 63 72 t-log-port* "scr
1330: 69 70 74 3a 20 22 20 73 63 72 69 70 74 29 0a 20 ipt: " script).
1340: 20 20 20 28 72 6d 74 3a 74 65 73 74 73 74 65 70 (rmt:teststep
1350: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e -set-status! run
1360: 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 65 70 -id test-id step
1370: 6e 61 6d 65 20 22 73 74 61 72 74 22 20 22 2d 22 name "start" "-"
1380: 20 23 66 20 23 66 29 0a 20 20 20 20 3b 3b 20 6e #f #f). ;; n
1390: 6f 77 20 6c 61 75 6e 63 68 20 74 68 65 20 61 63 ow launch the ac
13a0: 74 75 61 6c 20 70 72 6f 63 65 73 73 0a 20 20 20 tual process.
13b0: 20 28 63 61 6c 6c 2d 77 69 74 68 2d 65 6e 76 69 (call-with-envi
13c0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
13d0: 73 20 0a 20 20 20 20 20 28 6c 69 73 74 20 28 63 s . (list (c
13e0: 6f 6e 73 20 22 50 41 54 48 22 20 28 63 6f 6e 63 ons "PATH" (conc
13f0: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
1400: 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 54 48 t-variable "PATH
1410: 22 29 20 22 3a 2e 22 29 29 29 0a 20 20 20 20 20 ") ":."))).
1420: 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b 20 28 70 (lambda () ;; (p
1430: 72 6f 63 65 73 73 2d 72 75 6e 20 22 2f 62 69 6e rocess-run "/bin
1440: 2f 62 61 73 68 22 20 22 2d 63 22 20 22 65 78 65 /bash" "-c" "exe
1450: 63 20 6c 73 20 2d 6c 20 2f 74 6d 70 2f 66 6f 6f c ls -l /tmp/foo
1460: 62 61 72 20 3e 20 2f 74 6d 70 2f 64 65 6c 6d 65 bar > /tmp/delme
1470: 2d 6d 6f 72 65 2e 6c 6f 67 20 32 3e 26 31 22 29 -more.log 2>&1")
1480: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
1490: 63 6d 64 20 28 63 6f 6e 63 20 73 74 65 70 63 6d cmd (conc stepcm
14a0: 64 20 22 20 3e 20 22 20 73 74 65 70 6e 61 6d 65 d " > " stepname
14b0: 20 22 2e 6c 6f 67 20 32 3e 26 31 22 29 29 20 3b ".log 2>&1")) ;
14c0: 3b 20 3e 6f 75 74 66 69 6c 65 20 32 3e 26 31 20 ; >outfile 2>&1
14d0: 0a 09 20 20 20 20 20 20 28 70 69 64 20 28 70 72 .. (pid (pr
14e0: 6f 63 65 73 73 2d 72 75 6e 20 22 2f 62 69 6e 2f ocess-run "/bin/
14f0: 62 61 73 68 22 20 28 6c 69 73 74 20 22 2d 63 22 bash" (list "-c"
1500: 20 63 6d 64 29 29 29 29 0a 09 20 28 72 6d 74 3a cmd)))).. (rmt:
1510: 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f test-set-top-pro
1520: 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 cess-pid run-id
1530: 74 65 73 74 2d 69 64 20 70 69 64 29 0a 09 20 28 test-id pid).. (
1540: 6c 65 74 20 70 72 6f 63 65 73 73 6c 6f 6f 70 20 let processloop
1550: 28 28 69 20 30 29 29 0a 09 20 20 20 28 6c 65 74 ((i 0)).. (let
1560: 2d 76 61 6c 75 65 73 20 28 28 28 70 69 64 2d 76 -values (((pid-v
1570: 61 6c 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 al exit-status e
1580: 78 69 74 2d 63 6f 64 65 29 28 70 72 6f 63 65 73 xit-code)(proces
1590: 73 2d 77 61 69 74 20 70 69 64 20 23 74 29 29 29 s-wait pid #t)))
15a0: 0a 09 09 20 20 20 20 20 20 20 28 6d 75 74 65 78 ... (mutex
15b0: 2d 6c 6f 63 6b 21 20 6d 29 0a 09 09 20 20 20 20 -lock! m)...
15c0: 20 20 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d (launch:einf-
15d0: 70 69 64 2d 73 65 74 21 20 20 20 20 20 20 20 20 pid-set!
15e0: 20 65 78 69 74 2d 69 6e 66 6f 20 70 69 64 29 20 exit-info pid)
15f0: 20 20 20 20 20 20 20 20 3b 3b 20 28 76 65 63 74 ;; (vect
1600: 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 or-set! exit-inf
1610: 6f 20 30 20 70 69 64 29 0a 09 09 20 20 20 20 20 o 0 pid)...
1620: 20 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 65 (launch:einf-e
1630: 78 69 74 2d 73 74 61 74 75 73 2d 73 65 74 21 20 xit-status-set!
1640: 65 78 69 74 2d 69 6e 66 6f 20 65 78 69 74 2d 73 exit-info exit-s
1650: 74 61 74 75 73 29 20 3b 3b 20 28 76 65 63 74 6f tatus) ;; (vecto
1660: 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f r-set! exit-info
1670: 20 31 20 65 78 69 74 2d 73 74 61 74 75 73 29 0a 1 exit-status).
1680: 09 09 20 20 20 20 20 20 20 28 6c 61 75 6e 63 68 .. (launch
1690: 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 65 2d :einf-exit-code-
16a0: 73 65 74 21 20 20 20 65 78 69 74 2d 69 6e 66 6f set! exit-info
16b0: 20 65 78 69 74 2d 63 6f 64 65 29 20 20 20 3b 3b exit-code) ;;
16c0: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 (vector-set! ex
16d0: 69 74 2d 69 6e 66 6f 20 32 20 65 78 69 74 2d 63 it-info 2 exit-c
16e0: 6f 64 65 29 0a 09 09 20 20 20 20 20 20 20 28 6d ode)... (m
16f0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 29 0a utex-unlock! m).
1700: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 65 71 .. (if (eq
1710: 3f 20 70 69 64 2d 76 61 6c 20 30 29 0a 09 09 09 ? pid-val 0)....
1720: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 20 (begin....
1730: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
1740: 20 32 29 0a 09 09 09 20 20 20 20 20 28 70 72 6f 2).... (pro
1750: 63 65 73 73 6c 6f 6f 70 20 28 2b 20 69 20 31 29 cessloop (+ i 1)
1760: 29 29 29 0a 09 09 20 20 20 20 20 20 20 29 29 29 )))... )))
1770: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
1780: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
1790: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 ult-log-port* "s
17a0: 74 65 70 20 22 20 73 74 65 70 6e 61 6d 65 20 22 tep " stepname "
17b0: 20 63 6f 6d 70 6c 65 74 65 64 20 77 69 74 68 20 completed with
17c0: 65 78 69 74 20 63 6f 64 65 20 22 20 28 6c 61 75 exit code " (lau
17d0: 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f nch:einf-exit-co
17e0: 64 65 20 65 78 69 74 2d 69 6e 66 6f 29 29 20 3b de exit-info)) ;
17f0: 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 ; (vector-ref ex
1800: 69 74 2d 69 6e 66 6f 20 32 29 29 0a 20 20 20 20 it-info 2)).
1810: 3b 3b 20 6e 6f 77 20 72 75 6e 20 6c 6f 67 70 72 ;; now run logpr
1820: 6f 20 69 66 20 6e 65 65 64 65 64 0a 20 20 20 20 o if needed.
1830: 28 69 66 20 6c 6f 67 70 72 6f 2d 75 73 65 64 0a (if logpro-used.
1840: 09 28 6c 65 74 20 28 28 70 69 64 20 28 70 72 6f .(let ((pid (pro
1850: 63 65 73 73 2d 72 75 6e 20 28 63 6f 6e 63 20 22 cess-run (conc "
1860: 6c 6f 67 70 72 6f 20 22 20 6c 6f 67 70 72 6f 2d logpro " logpro-
1870: 66 69 6c 65 20 22 20 22 20 28 63 6f 6e 63 20 73 file " " (conc s
1880: 74 65 70 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 tepname ".html")
1890: 20 22 20 3c 20 22 20 73 74 65 70 6e 61 6d 65 20 " < " stepname
18a0: 22 2e 6c 6f 67 22 29 29 29 29 0a 09 20 20 28 6c ".log")))).. (l
18b0: 65 74 20 70 72 6f 63 65 73 73 6c 6f 6f 70 20 28 et processloop (
18c0: 28 69 20 30 29 29 0a 09 20 20 20 20 28 6c 65 74 (i 0)).. (let
18d0: 2d 76 61 6c 75 65 73 20 28 28 28 70 69 64 2d 76 -values (((pid-v
18e0: 61 6c 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 al exit-status e
18f0: 78 69 74 2d 63 6f 64 65 29 28 70 72 6f 63 65 73 xit-code)(proces
1900: 73 2d 77 61 69 74 20 70 69 64 20 23 74 29 29 29 s-wait pid #t)))
1910: 0a 09 09 09 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 ....(mutex-lock!
1920: 20 6d 29 0a 09 09 09 3b 3b 20 28 6d 61 6b 65 2d m)....;; (make-
1930: 6c 61 75 6e 63 68 3a 65 69 6e 66 20 70 69 64 3a launch:einf pid:
1940: 20 70 69 64 20 65 78 69 74 2d 73 74 61 74 75 73 pid exit-status
1950: 3a 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 : exit-status ex
1960: 69 74 2d 63 6f 64 65 3a 20 65 78 69 74 2d 63 6f it-code: exit-co
1970: 64 65 29 0a 09 09 09 28 6c 61 75 6e 63 68 3a 65 de)....(launch:e
1980: 69 6e 66 2d 70 69 64 2d 73 65 74 21 20 20 20 20 inf-pid-set!
1990: 20 20 20 20 20 65 78 69 74 2d 69 6e 66 6f 20 70 exit-info p
19a0: 69 64 29 20 20 20 20 20 20 20 20 20 3b 3b 20 28 id) ;; (
19b0: 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 74 vector-set! exit
19c0: 2d 69 6e 66 6f 20 30 20 70 69 64 29 0a 09 09 09 -info 0 pid)....
19d0: 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 (launch:einf-exi
19e0: 74 2d 73 74 61 74 75 73 2d 73 65 74 21 20 65 78 t-status-set! ex
19f0: 69 74 2d 69 6e 66 6f 20 65 78 69 74 2d 73 74 61 it-info exit-sta
1a00: 74 75 73 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d tus) ;; (vector-
1a10: 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 31 set! exit-info 1
1a20: 20 65 78 69 74 2d 73 74 61 74 75 73 29 0a 09 09 exit-status)...
1a30: 09 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 .(launch:einf-ex
1a40: 69 74 2d 63 6f 64 65 2d 73 65 74 21 20 20 20 65 it-code-set! e
1a50: 78 69 74 2d 69 6e 66 6f 20 65 78 69 74 2d 63 6f xit-info exit-co
1a60: 64 65 29 20 20 20 3b 3b 20 28 76 65 63 74 6f 72 de) ;; (vector
1a70: 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 -set! exit-info
1a80: 32 20 65 78 69 74 2d 63 6f 64 65 29 0a 09 09 09 2 exit-code)....
1a90: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d (mutex-unlock! m
1aa0: 29 0a 09 09 09 28 69 66 20 28 65 71 3f 20 70 69 )....(if (eq? pi
1ab0: 64 2d 76 61 6c 20 30 29 0a 09 09 09 20 20 20 20 d-val 0)....
1ac0: 28 62 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 (begin....
1ad0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
1ae0: 29 0a 09 09 09 20 20 20 20 20 20 28 70 72 6f 63 ).... (proc
1af0: 65 73 73 6c 6f 6f 70 20 28 2b 20 69 20 31 29 29 essloop (+ i 1))
1b00: 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a ))).. (debug:
1b10: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
1b20: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1b30: 22 6c 6f 67 70 72 6f 20 66 6f 72 20 73 74 65 70 "logpro for step
1b40: 20 22 20 73 74 65 70 6e 61 6d 65 20 22 20 65 78 " stepname " ex
1b50: 69 74 65 64 20 77 69 74 68 20 63 6f 64 65 20 22 ited with code "
1b60: 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 (launch:einf-ex
1b70: 69 74 2d 63 6f 64 65 20 65 78 69 74 2d 69 6e 66 it-code exit-inf
1b80: 6f 29 29 29 29 29 20 3b 3b 20 28 76 65 63 74 6f o))))) ;; (vecto
1b90: 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 r-ref exit-info
1ba0: 32 29 29 29 29 29 0a 20 20 20 20 0a 20 20 20 20 2))))). .
1bb0: 28 6c 65 74 20 28 28 65 78 69 6e 66 6f 20 28 6c (let ((exinfo (l
1bc0: 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d aunch:einf-exit-
1bd0: 63 6f 64 65 20 65 78 69 74 2d 69 6e 66 6f 29 29 code exit-info))
1be0: 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 20 ;; (vector-ref
1bf0: 65 78 69 74 2d 69 6e 66 6f 20 32 29 29 0a 09 20 exit-info 2))..
1c00: 20 28 6c 6f 67 66 6e 61 20 28 69 66 20 6c 6f 67 (logfna (if log
1c10: 70 72 6f 2d 75 73 65 64 20 28 63 6f 6e 63 20 73 pro-used (conc s
1c20: 74 65 70 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 29 tepname ".html")
1c30: 20 22 22 29 29 0a 09 20 20 28 63 6f 6d 6d 65 6e "")).. (commen
1c40: 74 20 23 66 29 29 0a 20 20 20 20 20 20 28 69 66 t #f)). (if
1c50: 20 6c 6f 67 70 72 6f 2d 75 73 65 64 0a 09 20 20 logpro-used..
1c60: 28 6c 65 74 20 28 28 64 61 74 66 69 6c 65 20 28 (let ((datfile (
1c70: 63 6f 6e 63 20 73 74 65 70 6e 61 6d 65 20 22 2e conc stepname ".
1c80: 64 61 74 22 29 29 29 0a 09 20 20 20 20 3b 3b 20 dat"))).. ;;
1c90: 6c 6f 61 64 20 74 68 65 20 2e 64 61 74 20 66 69 load the .dat fi
1ca0: 6c 65 20 69 6e 74 6f 20 74 68 65 20 74 65 73 74 le into the test
1cb0: 5f 64 61 74 61 20 74 61 62 6c 65 20 69 66 20 69 _data table if i
1cc0: 74 20 65 78 69 73 74 73 0a 09 20 20 20 20 28 69 t exists.. (i
1cd0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
1ce0: 64 61 74 66 69 6c 65 29 0a 09 09 28 73 65 74 21 datfile)...(set!
1cf0: 20 63 6f 6d 6d 65 6e 74 20 28 6c 61 75 6e 63 68 comment (launch
1d00: 3a 6c 6f 61 64 2d 6c 6f 67 70 72 6f 2d 64 61 74 :load-logpro-dat
1d10: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
1d20: 73 74 65 70 6e 61 6d 65 29 29 29 0a 09 20 20 20 stepname)))..
1d30: 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d 6c (rmt:test-set-l
1d40: 6f 67 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d og! run-id test-
1d50: 69 64 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 6d id (conc stepnam
1d60: 65 20 22 2e 68 74 6d 6c 22 29 29 29 29 0a 20 20 e ".html")))).
1d70: 20 20 20 20 28 72 6d 74 3a 74 65 73 74 73 74 65 (rmt:testste
1d80: 70 2d 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 p-set-status! ru
1d90: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 73 74 65 n-id test-id ste
1da0: 70 6e 61 6d 65 20 22 65 6e 64 22 20 65 78 69 6e pname "end" exin
1db0: 66 6f 20 63 6f 6d 6d 65 6e 74 20 6c 6f 67 66 6e fo comment logfn
1dc0: 61 29 29 0a 20 20 20 20 3b 3b 20 73 65 74 20 74 a)). ;; set t
1dd0: 68 65 20 74 65 73 74 20 66 69 6e 61 6c 20 73 74 he test final st
1de0: 61 74 75 73 0a 20 20 20 20 28 6c 65 74 2a 20 28 atus. (let* (
1df0: 28 70 72 6f 63 65 73 73 2d 65 78 69 74 2d 73 74 (process-exit-st
1e00: 61 74 75 73 20 28 6c 61 75 6e 63 68 3a 65 69 6e atus (launch:ein
1e10: 66 2d 65 78 69 74 2d 63 6f 64 65 20 65 78 69 74 f-exit-code exit
1e20: 2d 69 6e 66 6f 29 29 20 3b 3b 20 28 76 65 63 74 -info)) ;; (vect
1e30: 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f or-ref exit-info
1e40: 20 32 29 29 0a 09 20 20 20 28 74 68 69 73 2d 73 2)).. (this-s
1e50: 74 65 70 2d 73 74 61 74 75 73 20 28 63 6f 6e 64 tep-status (cond
1e60: 0a 09 09 09 20 20 20 20 20 20 28 28 61 6e 64 20 .... ((and
1e70: 28 65 71 3f 20 70 72 6f 63 65 73 73 2d 65 78 69 (eq? process-exi
1e80: 74 2d 73 74 61 74 75 73 20 32 29 20 6c 6f 67 70 t-status 2) logp
1e90: 72 6f 2d 75 73 65 64 29 20 27 77 61 72 6e 29 20 ro-used) 'warn)
1ea0: 20 20 3b 3b 20 6c 6f 67 70 72 6f 20 32 20 3d 20 ;; logpro 2 =
1eb0: 77 61 72 6e 69 6e 67 73 0a 09 09 09 20 20 20 20 warnings....
1ec0: 20 20 28 28 61 6e 64 20 28 65 71 3f 20 70 72 6f ((and (eq? pro
1ed0: 63 65 73 73 2d 65 78 69 74 2d 73 74 61 74 75 73 cess-exit-status
1ee0: 20 33 29 20 6c 6f 67 70 72 6f 2d 75 73 65 64 29 3) logpro-used)
1ef0: 20 27 63 68 65 63 6b 29 20 20 3b 3b 20 6c 6f 67 'check) ;; log
1f00: 70 72 6f 20 33 20 3d 20 63 68 65 63 6b 0a 09 09 pro 3 = check...
1f10: 09 20 20 20 20 20 20 28 28 61 6e 64 20 28 65 71 . ((and (eq
1f20: 3f 20 70 72 6f 63 65 73 73 2d 65 78 69 74 2d 73 ? process-exit-s
1f30: 74 61 74 75 73 20 34 29 20 6c 6f 67 70 72 6f 2d tatus 4) logpro-
1f40: 75 73 65 64 29 20 27 77 61 69 76 65 64 29 20 3b used) 'waived) ;
1f50: 3b 20 6c 6f 67 70 72 6f 20 34 20 3d 20 77 61 69 ; logpro 4 = wai
1f60: 76 65 64 0a 09 09 09 20 20 20 20 20 20 28 28 61 ved.... ((a
1f70: 6e 64 20 28 65 71 3f 20 70 72 6f 63 65 73 73 2d nd (eq? process-
1f80: 65 78 69 74 2d 73 74 61 74 75 73 20 35 29 20 6c exit-status 5) l
1f90: 6f 67 70 72 6f 2d 75 73 65 64 29 20 27 61 62 6f ogpro-used) 'abo
1fa0: 72 74 29 20 20 3b 3b 20 6c 6f 67 70 72 6f 20 35 rt) ;; logpro 5
1fb0: 20 3d 20 61 62 6f 72 74 0a 09 09 09 20 20 20 20 = abort....
1fc0: 20 20 28 28 61 6e 64 20 28 65 71 3f 20 70 72 6f ((and (eq? pro
1fd0: 63 65 73 73 2d 65 78 69 74 2d 73 74 61 74 75 73 cess-exit-status
1fe0: 20 36 29 20 6c 6f 67 70 72 6f 2d 75 73 65 64 29 6) logpro-used)
1ff0: 20 27 73 6b 69 70 29 20 20 20 3b 3b 20 6c 6f 67 'skip) ;; log
2000: 70 72 6f 20 36 20 3d 20 73 6b 69 70 0a 09 09 09 pro 6 = skip....
2010: 20 20 20 20 20 20 28 28 65 71 3f 20 70 72 6f 63 ((eq? proc
2020: 65 73 73 2d 65 78 69 74 2d 73 74 61 74 75 73 20 ess-exit-status
2030: 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
2040: 20 20 20 20 20 27 70 61 73 73 29 20 20 20 3b 3b 'pass) ;;
2050: 20 6c 6f 67 70 72 6f 20 30 20 3d 20 70 61 73 73 logpro 0 = pass
2060: 0a 09 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 .... (else
2070: 27 66 61 69 6c 29 29 29 0a 09 20 20 20 28 6f 76 'fail))).. (ov
2080: 65 72 61 6c 6c 2d 73 74 61 74 75 73 20 20 20 28 erall-status (
2090: 63 6f 6e 64 0a 09 09 09 20 20 20 20 20 20 28 28 cond.... ((
20a0: 65 71 3f 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 eq? (launch:einf
20b0: 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 -rollup-status e
20c0: 78 69 74 2d 69 6e 66 6f 29 20 32 29 20 27 77 61 xit-info) 2) 'wa
20d0: 72 6e 29 20 3b 3b 20 72 6f 6c 6c 75 70 2d 73 74 rn) ;; rollup-st
20e0: 61 74 75 73 20 28 76 65 63 74 6f 72 2d 72 65 66 atus (vector-ref
20f0: 20 65 78 69 74 2d 69 6e 66 6f 20 33 29 0a 09 09 exit-info 3)...
2100: 09 20 20 20 20 20 20 28 28 65 71 3f 20 28 6c 61 . ((eq? (la
2110: 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 unch:einf-rollup
2120: 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 -status exit-inf
2130: 6f 29 20 30 29 20 27 70 61 73 73 29 20 3b 3b 20 o) 0) 'pass) ;;
2140: 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 (vector-ref exit
2150: 2d 69 6e 66 6f 20 33 29 0a 09 09 09 20 20 20 20 -info 3)....
2160: 20 20 28 65 6c 73 65 20 27 66 61 69 6c 29 29 29 (else 'fail)))
2170: 0a 09 20 20 20 28 6e 65 78 74 2d 73 74 61 74 75 .. (next-statu
2180: 73 20 20 20 20 20 20 28 63 6f 6e 64 20 0a 09 09 s (cond ...
2190: 09 20 20 20 20 20 20 28 28 65 71 3f 20 6f 76 65 . ((eq? ove
21a0: 72 61 6c 6c 2d 73 74 61 74 75 73 20 27 70 61 73 rall-status 'pas
21b0: 73 29 20 74 68 69 73 2d 73 74 65 70 2d 73 74 61 s) this-step-sta
21c0: 74 75 73 29 0a 09 09 09 20 20 20 20 20 20 28 28 tus).... ((
21d0: 65 71 3f 20 6f 76 65 72 61 6c 6c 2d 73 74 61 74 eq? overall-stat
21e0: 75 73 20 27 77 61 72 6e 29 0a 09 09 09 20 20 20 us 'warn)....
21f0: 20 20 20 20 28 69 66 20 28 65 71 3f 20 74 68 69 (if (eq? thi
2200: 73 2d 73 74 65 70 2d 73 74 61 74 75 73 20 27 66 s-step-status 'f
2210: 61 69 6c 29 20 27 66 61 69 6c 20 27 77 61 72 6e ail) 'fail 'warn
2220: 29 29 0a 09 09 09 20 20 20 20 20 20 28 28 65 71 )).... ((eq
2230: 3f 20 6f 76 65 72 61 6c 6c 2d 73 74 61 74 75 73 ? overall-status
2240: 20 27 61 62 6f 72 74 29 20 27 61 62 6f 72 74 29 'abort) 'abort)
2250: 0a 09 09 09 20 20 20 20 20 20 28 65 6c 73 65 20 .... (else
2260: 27 66 61 69 6c 29 29 29 0a 09 20 20 20 28 6e 65 'fail))).. (ne
2270: 78 74 2d 73 74 61 74 65 20 20 20 20 20 20 20 3b xt-state ;
2280: 3b 20 22 52 55 4e 4e 49 4e 47 22 29 20 3b 3b 20 ; "RUNNING") ;;
2290: 57 48 59 20 57 41 53 20 54 48 49 53 20 43 48 41 WHY WAS THIS CHA
22a0: 4e 47 45 44 20 54 4f 20 4e 4f 54 20 55 53 45 20 NGED TO NOT USE
22b0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3f 3f 0a 09 (null? tal) ??..
22c0: 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 (cond..
22d0: 28 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 ((null? tal) ;;
22e0: 6d 6f 72 65 20 74 6f 20 72 75 6e 3f 0a 09 20 20 more to run?..
22f0: 20 20 20 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 "COMPLETED")
2300: 0a 09 20 20 20 20 20 28 65 6c 73 65 20 22 52 55 .. (else "RU
2310: 4e 4e 49 4e 47 22 29 29 29 29 0a 20 20 20 20 20 NNING")))).
2320: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
2330: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2340: 74 2a 20 22 45 78 69 74 20 76 61 6c 75 65 20 72 t* "Exit value r
2350: 65 63 65 69 76 65 64 3a 20 22 20 28 6c 61 75 6e eceived: " (laun
2360: 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 ch:einf-exit-cod
2370: 65 20 65 78 69 74 2d 69 6e 66 6f 29 20 22 20 6c e exit-info) " l
2380: 6f 67 70 72 6f 2d 75 73 65 64 3a 20 22 20 6c 6f ogpro-used: " lo
2390: 67 70 72 6f 2d 75 73 65 64 20 0a 09 09 20 20 20 gpro-used ...
23a0: 22 20 74 68 69 73 2d 73 74 65 70 2d 73 74 61 74 " this-step-stat
23b0: 75 73 3a 20 22 20 74 68 69 73 2d 73 74 65 70 2d us: " this-step-
23c0: 73 74 61 74 75 73 20 22 20 6f 76 65 72 61 6c 6c status " overall
23d0: 2d 73 74 61 74 75 73 3a 20 22 20 6f 76 65 72 61 -status: " overa
23e0: 6c 6c 2d 73 74 61 74 75 73 20 0a 09 09 20 20 20 ll-status ...
23f0: 22 20 6e 65 78 74 2d 73 74 61 74 75 73 3a 20 22 " next-status: "
2400: 20 6e 65 78 74 2d 73 74 61 74 75 73 20 22 20 72 next-status " r
2410: 6f 6c 6c 75 70 2d 73 74 61 74 75 73 3a 20 22 20 ollup-status: "
2420: 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f (launch:einf-ro
2430: 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 llup-status exit
2440: 2d 69 6e 66 6f 29 29 20 3b 3b 20 28 76 65 63 74 -info)) ;; (vect
2450: 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f or-ref exit-info
2460: 20 33 29 29 0a 20 20 20 20 20 20 28 63 61 73 65 3)). (case
2470: 20 6e 65 78 74 2d 73 74 61 74 75 73 0a 09 28 28 next-status..((
2480: 77 61 72 6e 29 0a 09 20 28 6c 61 75 6e 63 68 3a warn).. (launch:
2490: 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 einf-rollup-stat
24a0: 75 73 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 us-set! exit-inf
24b0: 6f 20 32 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d o 2) ;; (vector-
24c0: 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 33 set! exit-info 3
24d0: 20 32 29 20 3b 3b 20 72 6f 6c 6c 75 70 2d 73 74 2) ;; rollup-st
24e0: 61 74 75 73 0a 09 20 3b 3b 20 4e 42 2f 2f 20 74 atus.. ;; NB// t
24f0: 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 est-set-status!
2500: 64 6f 65 73 20 72 64 62 20 63 61 6c 6c 73 20 75 does rdb calls u
2510: 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 0a 09 20 nder the hood..
2520: 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d (tests:test-set-
2530: 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 status! run-id t
2540: 65 73 74 2d 69 64 20 6e 65 78 74 2d 73 74 61 74 est-id next-stat
2550: 65 20 22 57 41 52 4e 22 20 0a 09 09 09 09 20 28 e "WARN" ..... (
2560: 69 66 20 28 65 71 3f 20 74 68 69 73 2d 73 74 65 if (eq? this-ste
2570: 70 2d 73 74 61 74 75 73 20 27 77 61 72 6e 29 20 p-status 'warn)
2580: 22 4c 6f 67 70 72 6f 20 77 61 72 6e 69 6e 67 20 "Logpro warning
2590: 66 6f 75 6e 64 22 20 23 66 29 0a 09 09 09 09 20 found" #f).....
25a0: 23 66 29 29 0a 09 28 28 63 68 65 63 6b 29 0a 09 #f))..((check)..
25b0: 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f (launch:einf-ro
25c0: 6c 6c 75 70 2d 73 74 61 74 75 73 2d 73 65 74 21 llup-status-set!
25d0: 20 65 78 69 74 2d 69 6e 66 6f 20 33 29 20 3b 3b exit-info 3) ;;
25e0: 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 (vector-set! ex
25f0: 69 74 2d 69 6e 66 6f 20 33 20 33 29 20 3b 3b 20 it-info 3 3) ;;
2600: 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 0a 09 20 rollup-status..
2610: 3b 3b 20 4e 42 2f 2f 20 74 65 73 74 2d 73 65 74 ;; NB// test-set
2620: 2d 73 74 61 74 75 73 21 20 64 6f 65 73 20 72 64 -status! does rd
2630: 62 20 63 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 b calls under th
2640: 65 20 68 6f 6f 64 0a 09 20 28 74 65 73 74 73 3a e hood.. (tests:
2650: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
2660: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
2670: 6e 65 78 74 2d 73 74 61 74 65 20 22 43 48 45 43 next-state "CHEC
2680: 4b 22 20 0a 09 09 09 09 20 28 69 66 20 28 65 71 K" ..... (if (eq
2690: 3f 20 74 68 69 73 2d 73 74 65 70 2d 73 74 61 74 ? this-step-stat
26a0: 75 73 20 27 63 68 65 63 6b 29 20 22 4c 6f 67 70 us 'check) "Logp
26b0: 72 6f 20 63 68 65 63 6b 20 66 6f 75 6e 64 22 20 ro check found"
26c0: 23 66 29 0a 09 09 09 09 20 23 66 29 29 0a 09 28 #f)..... #f))..(
26d0: 28 77 61 69 76 65 64 29 0a 09 20 28 6c 61 75 6e (waived).. (laun
26e0: 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 ch:einf-rollup-s
26f0: 74 61 74 75 73 2d 73 65 74 21 20 65 78 69 74 2d tatus-set! exit-
2700: 69 6e 66 6f 20 34 29 20 3b 3b 20 28 76 65 63 74 info 4) ;; (vect
2710: 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 or-set! exit-inf
2720: 6f 20 33 20 33 29 20 3b 3b 20 72 6f 6c 6c 75 70 o 3 3) ;; rollup
2730: 2d 73 74 61 74 75 73 0a 09 20 3b 3b 20 4e 42 2f -status.. ;; NB/
2740: 2f 20 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 / test-set-statu
2750: 73 21 20 64 6f 65 73 20 72 64 62 20 63 61 6c 6c s! does rdb call
2760: 73 20 75 6e 64 65 72 20 74 68 65 20 68 6f 6f 64 s under the hood
2770: 0a 09 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 .. (tests:test-s
2780: 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 et-status! run-i
2790: 64 20 74 65 73 74 2d 69 64 20 6e 65 78 74 2d 73 d test-id next-s
27a0: 74 61 74 65 20 22 57 41 49 56 45 44 22 20 0a 09 tate "WAIVED" ..
27b0: 09 09 09 20 28 69 66 20 28 65 71 3f 20 74 68 69 ... (if (eq? thi
27c0: 73 2d 73 74 65 70 2d 73 74 61 74 75 73 20 27 63 s-step-status 'c
27d0: 68 65 63 6b 29 20 22 4c 6f 67 70 72 6f 20 77 61 heck) "Logpro wa
27e0: 69 76 65 64 20 66 6f 75 6e 64 22 20 23 66 29 0a ived found" #f).
27f0: 09 09 09 09 20 23 66 29 29 0a 09 28 28 61 62 6f .... #f))..((abo
2800: 72 74 29 0a 09 20 28 6c 61 75 6e 63 68 3a 65 69 rt).. (launch:ei
2810: 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 nf-rollup-status
2820: 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 -set! exit-info
2830: 35 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 5) ;; (vector-se
2840: 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 33 20 34 t! exit-info 3 4
2850: 29 20 3b 3b 20 72 6f 6c 6c 75 70 2d 73 74 61 74 ) ;; rollup-stat
2860: 75 73 0a 09 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 us.. ;; NB// tes
2870: 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 6f t-set-status! do
2880: 65 73 20 72 64 62 20 63 61 6c 6c 73 20 75 6e 64 es rdb calls und
2890: 65 72 20 74 68 65 20 68 6f 6f 64 0a 09 20 28 74 er the hood.. (t
28a0: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 ests:test-set-st
28b0: 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 atus! run-id tes
28c0: 74 2d 69 64 20 6e 65 78 74 2d 73 74 61 74 65 20 t-id next-state
28d0: 22 41 42 4f 52 54 22 20 0a 09 09 09 09 20 28 69 "ABORT" ..... (i
28e0: 66 20 28 65 71 3f 20 74 68 69 73 2d 73 74 65 70 f (eq? this-step
28f0: 2d 73 74 61 74 75 73 20 27 61 62 6f 72 74 29 20 -status 'abort)
2900: 22 4c 6f 67 70 72 6f 20 61 62 6f 72 74 20 66 6f "Logpro abort fo
2910: 75 6e 64 22 20 23 66 29 0a 09 09 09 09 20 23 66 und" #f)..... #f
2920: 29 29 0a 09 28 28 73 6b 69 70 29 0a 09 20 28 6c ))..((skip).. (l
2930: 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 aunch:einf-rollu
2940: 70 2d 73 74 61 74 75 73 2d 73 65 74 21 20 65 78 p-status-set! ex
2950: 69 74 2d 69 6e 66 6f 20 36 29 20 3b 3b 20 28 76 it-info 6) ;; (v
2960: 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 74 2d ector-set! exit-
2970: 69 6e 66 6f 20 33 20 34 29 20 3b 3b 20 72 6f 6c info 3 4) ;; rol
2980: 6c 75 70 2d 73 74 61 74 75 73 0a 09 20 3b 3b 20 lup-status.. ;;
2990: 4e 42 2f 2f 20 74 65 73 74 2d 73 65 74 2d 73 74 NB// test-set-st
29a0: 61 74 75 73 21 20 64 6f 65 73 20 72 64 62 20 63 atus! does rdb c
29b0: 61 6c 6c 73 20 75 6e 64 65 72 20 74 68 65 20 68 alls under the h
29c0: 6f 6f 64 0a 09 20 28 74 65 73 74 73 3a 74 65 73 ood.. (tests:tes
29d0: 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 t-set-status! ru
29e0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 6e 65 78 n-id test-id nex
29f0: 74 2d 73 74 61 74 65 20 22 53 4b 49 50 22 20 0a t-state "SKIP" .
2a00: 09 09 09 09 20 28 69 66 20 28 65 71 3f 20 74 68 .... (if (eq? th
2a10: 69 73 2d 73 74 65 70 2d 73 74 61 74 75 73 20 27 is-step-status '
2a20: 73 6b 69 70 29 20 22 4c 6f 67 70 72 6f 20 73 6b skip) "Logpro sk
2a30: 69 70 20 66 6f 75 6e 64 22 20 23 66 29 0a 09 09 ip found" #f)...
2a40: 09 09 20 23 66 29 29 0a 09 28 28 70 61 73 73 29 .. #f))..((pass)
2a50: 0a 09 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 .. (tests:test-s
2a60: 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 et-status! run-i
2a70: 64 20 74 65 73 74 2d 69 64 20 6e 65 78 74 2d 73 d test-id next-s
2a80: 74 61 74 65 20 22 50 41 53 53 22 20 23 66 20 23 tate "PASS" #f #
2a90: 66 29 29 0a 09 28 65 6c 73 65 20 3b 3b 20 27 66 f))..(else ;; 'f
2aa0: 61 69 6c 0a 09 20 28 6c 61 75 6e 63 68 3a 65 69 ail.. (launch:ei
2ab0: 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 nf-rollup-status
2ac0: 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 -set! exit-info
2ad0: 31 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 1) ;; (vector-se
2ae0: 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 33 20 31 t! exit-info 3 1
2af0: 29 20 3b 3b 20 66 6f 72 63 65 20 66 61 69 6c 2c ) ;; force fail,
2b00: 20 74 68 69 73 20 75 73 65 64 20 74 6f 20 62 65 this used to be
2b10: 20 6e 65 78 74 2d 73 74 61 74 65 20 62 75 74 20 next-state but
2b20: 74 68 61 74 20 64 6f 65 73 6e 27 74 20 6d 61 6b that doesn't mak
2b30: 65 20 73 65 6e 73 65 2e 20 73 68 6f 75 6c 64 20 e sense. should
2b40: 61 6c 77 61 79 73 20 62 65 20 22 43 4f 4d 50 4c always be "COMPL
2b50: 45 54 45 44 22 20 0a 09 20 28 74 65 73 74 73 3a ETED" .. (tests:
2b60: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
2b70: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
2b80: 22 43 4f 4d 50 4c 45 54 45 44 22 20 22 46 41 49 "COMPLETED" "FAI
2b90: 4c 22 20 28 63 6f 6e 63 20 22 46 61 69 6c 65 64 L" (conc "Failed
2ba0: 20 61 74 20 73 74 65 70 20 22 20 73 74 65 70 6e at step " stepn
2bb0: 61 6d 65 29 20 23 66 29 0a 09 20 29 29 29 0a 20 ame) #f).. ))).
2bc0: 20 20 20 6c 6f 67 70 72 6f 2d 75 73 65 64 29 29 logpro-used))
2bd0: 0a 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 ..(define (launc
2be0: 68 3a 6d 61 6e 61 67 65 2d 73 74 65 70 73 20 72 h:manage-steps r
2bf0: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 69 74 un-id test-id it
2c00: 65 6d 2d 70 61 74 68 20 66 75 6c 6c 72 75 6e 73 em-path fullruns
2c10: 63 72 69 70 74 20 65 7a 73 74 65 70 73 20 74 65 cript ezsteps te
2c20: 73 74 2d 6e 61 6d 65 20 74 63 6f 6e 66 69 67 72 st-name tconfigr
2c30: 65 67 20 65 78 69 74 2d 69 6e 66 6f 20 6d 29 0a eg exit-info m).
2c40: 20 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 65 73 ;; (let-values
2c50: 0a 20 20 3b 3b 20 20 28 28 28 70 69 64 20 65 78 . ;; (((pid ex
2c60: 69 74 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 it-status exit-c
2c70: 6f 64 65 29 0a 20 20 3b 3b 20 20 20 20 28 72 75 ode). ;; (ru
2c80: 6e 2d 6e 2d 77 61 69 74 20 66 75 6c 6c 72 75 6e n-n-wait fullrun
2c90: 73 63 72 69 70 74 29 29 29 0a 20 20 3b 3b 20 28 script))). ;; (
2ca0: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 tests:test-set-s
2cb0: 74 61 74 75 73 21 20 74 65 73 74 2d 69 64 20 22 tatus! test-id "
2cc0: 52 55 4e 4e 49 4e 47 22 20 22 6e 2f 61 22 20 23 RUNNING" "n/a" #
2cd0: 66 20 23 66 29 0a 20 20 3b 3b 20 53 69 6e 63 65 f #f). ;; Since
2ce0: 20 77 65 20 73 68 6f 75 6c 64 20 68 61 76 65 20 we should have
2cf0: 61 20 63 6c 65 61 6e 20 73 6c 61 74 65 20 61 74 a clean slate at
2d00: 20 74 68 69 73 20 74 69 6d 65 20 74 68 65 72 65 this time there
2d10: 20 69 73 20 6e 6f 20 6e 65 65 64 20 74 6f 20 64 is no need to d
2d20: 6f 20 0a 20 20 3b 3b 20 61 6e 79 20 6f 66 20 74 o . ;; any of t
2d30: 68 65 20 6f 74 68 65 72 20 73 74 75 66 66 20 74 he other stuff t
2d40: 68 61 74 20 74 65 73 74 73 3a 74 65 73 74 2d 73 hat tests:test-s
2d50: 65 74 2d 73 74 61 74 75 73 21 20 64 6f 65 73 2e et-status! does.
2d60: 20 4c 65 74 27 73 20 6a 75 73 74 20 0a 20 20 3b Let's just . ;
2d70: 3b 20 66 6f 72 63 65 20 52 55 4e 4e 49 4e 47 2f ; force RUNNING/
2d80: 6e 2f 61 0a 0a 20 20 3b 3b 20 28 74 68 72 65 61 n/a.. ;; (threa
2d90: 64 2d 73 6c 65 65 70 21 20 30 2e 33 29 0a 20 20 d-sleep! 0.3).
2da0: 3b 3b 20 28 74 65 73 74 73 3a 74 65 73 74 2d 66 ;; (tests:test-f
2db0: 6f 72 63 65 2d 73 74 61 74 65 2d 73 74 61 74 75 orce-state-statu
2dc0: 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 s! run-id test-i
2dd0: 64 20 22 52 55 4e 4e 49 4e 47 22 20 22 6e 2f 61 d "RUNNING" "n/a
2de0: 22 29 0a 20 20 28 72 6d 74 3a 72 6f 6c 6c 2d 75 "). (rmt:roll-u
2df0: 70 2d 70 61 73 73 2d 66 61 69 6c 2d 63 6f 75 6e p-pass-fail-coun
2e00: 74 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e ts run-id test-n
2e10: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 23 66 ame item-path #f
2e20: 20 22 52 55 4e 4e 49 4e 47 22 20 23 66 29 20 0a "RUNNING" #f) .
2e30: 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 6c 65 ;; (thread-sle
2e40: 65 70 21 20 30 2e 33 29 20 3b 3b 20 4e 46 53 20 ep! 0.3) ;; NFS
2e50: 73 6c 6f 77 6e 65 73 73 20 68 61 73 20 63 61 75 slowness has cau
2e60: 73 65 64 20 67 72 69 65 66 20 68 65 72 65 0a 0a sed grief here..
2e70: 20 20 3b 3b 20 69 66 20 74 68 65 72 65 20 69 73 ;; if there is
2e80: 20 61 20 72 75 6e 73 63 72 69 70 74 20 64 6f 20 a runscript do
2e90: 69 74 20 66 69 72 73 74 0a 20 20 28 69 66 20 66 it first. (if f
2ea0: 75 6c 6c 72 75 6e 73 63 72 69 70 74 0a 20 20 20 ullrunscript.
2eb0: 20 20 20 28 6c 65 74 20 28 28 70 69 64 20 28 70 (let ((pid (p
2ec0: 72 6f 63 65 73 73 2d 72 75 6e 20 66 75 6c 6c 72 rocess-run fullr
2ed0: 75 6e 73 63 72 69 70 74 29 29 29 0a 09 28 72 6d unscript)))..(rm
2ee0: 74 3a 74 65 73 74 2d 73 65 74 2d 74 6f 70 2d 70 t:test-set-top-p
2ef0: 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 rocess-pid run-i
2f00: 64 20 74 65 73 74 2d 69 64 20 70 69 64 29 0a 09 d test-id pid)..
2f10: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 20 30 29 (let loop ((i 0)
2f20: 29 0a 09 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 ).. (let-values
2f30: 0a 09 20 20 20 28 28 28 70 69 64 2d 76 61 6c 20 .. (((pid-val
2f40: 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 74 exit-status exit
2f50: 2d 63 6f 64 65 29 20 28 70 72 6f 63 65 73 73 2d -code) (process-
2f60: 77 61 69 74 20 70 69 64 20 23 74 29 29 29 0a 09 wait pid #t)))..
2f70: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
2f80: 6d 29 0a 09 20 20 20 28 6c 61 75 6e 63 68 3a 65 m).. (launch:e
2f90: 69 6e 66 2d 70 69 64 2d 73 65 74 21 20 20 20 20 inf-pid-set!
2fa0: 20 20 20 20 20 20 20 65 78 69 74 2d 69 6e 66 6f exit-info
2fb0: 20 20 70 69 64 29 20 20 20 20 20 20 20 20 20 3b pid) ;
2fc0: 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 ; (vector-set! e
2fd0: 78 69 74 2d 69 6e 66 6f 20 30 20 70 69 64 29 0a xit-info 0 pid).
2fe0: 09 20 20 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 . (launch:einf
2ff0: 2d 65 78 69 74 2d 73 74 61 74 75 73 2d 73 65 74 -exit-status-set
3000: 21 20 20 20 65 78 69 74 2d 69 6e 66 6f 20 20 65 ! exit-info e
3010: 78 69 74 2d 73 74 61 74 75 73 29 20 3b 3b 20 28 xit-status) ;; (
3020: 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 74 vector-set! exit
3030: 2d 69 6e 66 6f 20 31 20 65 78 69 74 2d 73 74 61 -info 1 exit-sta
3040: 74 75 73 29 0a 09 20 20 20 28 6c 61 75 6e 63 68 tus).. (launch
3050: 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 65 2d :einf-exit-code-
3060: 73 65 74 21 20 20 20 20 20 65 78 69 74 2d 69 6e set! exit-in
3070: 66 6f 20 20 65 78 69 74 2d 63 6f 64 65 29 20 20 fo exit-code)
3080: 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 ;; (vector-set!
3090: 20 65 78 69 74 2d 69 6e 66 6f 20 32 20 65 78 69 exit-info 2 exi
30a0: 74 2d 63 6f 64 65 29 0a 09 20 20 20 28 6c 61 75 t-code).. (lau
30b0: 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d nch:einf-rollup-
30c0: 73 74 61 74 75 73 2d 73 65 74 21 20 65 78 69 74 status-set! exit
30d0: 2d 69 6e 66 6f 20 20 65 78 69 74 2d 63 6f 64 65 -info exit-code
30e0: 29 20 20 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 ) ;; (vector-s
30f0: 65 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 33 20 et! exit-info 3
3100: 65 78 69 74 2d 63 6f 64 65 29 20 20 3b 3b 20 72 exit-code) ;; r
3110: 6f 6c 6c 75 70 20 73 74 61 74 75 73 0a 09 20 20 ollup status..
3120: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
3130: 6d 29 0a 09 20 20 20 28 69 66 20 28 65 71 3f 20 m).. (if (eq?
3140: 70 69 64 2d 76 61 6c 20 30 29 0a 09 20 20 20 20 pid-val 0)..
3150: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 74 68 (begin... (th
3160: 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 read-sleep! 2)..
3170: 09 20 28 6c 6f 6f 70 20 28 2b 20 69 20 31 29 29 . (loop (+ i 1))
3180: 29 0a 09 20 20 20 20 20 20 20 29 29 29 29 29 0a ).. ))))).
3190: 20 20 3b 3b 20 74 68 65 6e 2c 20 69 66 20 72 75 ;; then, if ru
31a0: 6e 73 63 72 69 70 74 20 72 61 6e 20 6f 6b 20 28 nscript ran ok (
31b0: 6f 72 20 64 69 64 20 6e 6f 74 20 67 65 74 20 63 or did not get c
31c0: 61 6c 6c 65 64 29 0a 20 20 3b 3b 20 64 6f 20 61 alled). ;; do a
31d0: 6c 6c 20 74 68 65 20 65 7a 73 74 65 70 73 20 28 ll the ezsteps (
31e0: 69 66 20 61 6e 79 29 0a 20 20 28 69 66 20 65 7a if any). (if ez
31f0: 73 74 65 70 73 0a 20 20 20 20 20 20 28 6c 65 74 steps. (let
3200: 2a 20 28 28 74 65 73 74 63 6f 6e 66 69 67 20 3b * ((testconfig ;
3210: 3b 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 ; (read-config (
3220: 63 6f 6e 63 20 77 6f 72 6b 2d 61 72 65 61 20 22 conc work-area "
3230: 2f 74 65 73 74 63 6f 6e 66 69 67 22 29 20 23 66 /testconfig") #f
3240: 20 23 74 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 #t environ-patt
3250: 3a 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e : "pre-launch-en
3260: 76 2d 76 61 72 73 22 29 29 20 3b 3b 20 46 49 58 v-vars")) ;; FIX
3270: 4d 45 3f 3f 3f 20 69 73 20 61 6c 6c 6f 77 2d 73 ME??? is allow-s
3280: 79 73 74 65 6d 20 6f 6b 20 68 65 72 65 3f 0a 09 ystem ok here?..
3290: 20 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 69 ;; NOTE: i
32a0: 74 20 69 73 20 74 65 6d 70 74 69 6e 67 20 74 6f t is tempting to
32b0: 20 74 75 72 6e 20 6f 66 66 20 66 6f 72 63 65 2d turn off force-
32c0: 63 72 65 61 74 65 20 6f 66 20 74 65 73 74 63 6f create of testco
32d0: 6e 66 69 67 20 62 75 74 20 64 79 6e 61 6d 69 63 nfig but dynamic
32e0: 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 20 20 20 .. ;;
32f0: 20 65 7a 73 74 65 70 20 6e 61 6d 65 73 20 6e 65 ezstep names ne
3300: 65 64 20 61 20 66 75 6c 6c 20 72 65 2d 65 76 61 ed a full re-eva
3310: 6c 20 68 65 72 65 2e 0a 09 20 20 20 20 20 20 28 l here... (
3320: 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 6f tests:get-testco
3330: 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 74 nfig test-name t
3340: 63 6f 6e 66 69 67 72 65 67 20 23 74 20 66 6f 72 configreg #t for
3350: 63 65 2d 63 72 65 61 74 65 3a 20 23 74 29 29 20 ce-create: #t))
3360: 3b 3b 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 ;; 'return-procs
3370: 29 29 29 0a 09 20 20 20 20 20 28 65 7a 73 74 65 ))).. (ezste
3380: 70 73 6c 73 74 20 28 69 66 20 28 68 61 73 68 2d pslst (if (hash-
3390: 74 61 62 6c 65 3f 20 74 65 73 74 63 6f 6e 66 69 table? testconfi
33a0: 67 29 0a 09 09 09 20 20 20 20 20 28 68 61 73 68 g).... (hash
33b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
33c0: 6c 74 20 74 65 73 74 63 6f 6e 66 69 67 20 22 65 lt testconfig "e
33d0: 7a 73 74 65 70 73 22 20 27 28 29 29 0a 09 09 09 zsteps" '())....
33e0: 20 20 20 20 20 23 66 29 29 29 0a 09 28 69 66 20 #f)))..(if
33f0: 74 65 73 74 63 6f 6e 66 69 67 0a 09 20 20 20 20 testconfig..
3400: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
3410: 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 74 *testconfigs* t
3420: 65 73 74 2d 6e 61 6d 65 20 74 65 73 74 63 6f 6e est-name testcon
3430: 66 69 67 29 20 3b 3b 20 63 61 63 68 65 64 20 66 fig) ;; cached f
3440: 6f 72 20 6c 61 7a 79 20 72 65 61 64 73 20 6c 61 or lazy reads la
3450: 74 65 72 20 2e 2e 2e 0a 09 20 20 20 20 28 62 65 ter ..... (be
3460: 67 69 6e 0a 09 20 20 20 20 20 20 28 6c 61 75 6e gin.. (laun
3470: 63 68 3a 73 65 74 75 70 29 0a 09 20 20 20 20 20 ch:setup)..
3480: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
3490: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
34a0: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 t* "WARNING: no
34b0: 74 65 73 74 63 6f 6e 66 69 67 20 66 6f 75 6e 64 testconfig found
34c0: 20 66 6f 72 20 22 20 74 65 73 74 2d 6e 61 6d 65 for " test-name
34d0: 20 22 20 69 6e 20 73 65 61 72 63 68 20 70 61 74 " in search pat
34e0: 68 3a 5c 6e 20 20 22 0a 09 09 09 20 20 20 28 73 h:\n ".... (s
34f0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
3500: 65 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 e (tests:get-tes
3510: 74 73 2d 73 65 61 72 63 68 2d 70 61 74 68 20 2a ts-search-path *
3520: 63 6f 6e 66 69 67 64 61 74 2a 29 20 22 5c 6e 20 configdat*) "\n
3530: 20 22 29 29 29 29 0a 09 3b 3b 20 61 66 74 65 72 "))))..;; after
3540: 20 61 6c 6c 20 74 68 61 74 2c 20 73 74 69 6c 6c all that, still
3550: 20 6e 6f 20 74 65 73 74 63 6f 6e 66 69 67 3f 20 no testconfig?
3560: 54 69 6d 65 20 74 6f 20 61 62 6f 72 74 0a 09 28 Time to abort..(
3570: 69 66 20 28 6e 6f 74 20 74 65 73 74 63 6f 6e 66 if (not testconf
3580: 69 67 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a ig).. (begin.
3590: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
35a0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
35b0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
35c0: 46 61 69 6c 65 64 20 74 6f 20 72 65 73 6f 6c 76 Failed to resolv
35d0: 65 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 e megatest.confi
35e0: 67 2c 20 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f g, runconfigs.co
35f0: 6e 66 69 67 20 61 6e 64 20 74 65 73 74 63 6f 6e nfig and testcon
3600: 66 69 67 20 69 73 73 75 65 73 2e 20 47 69 76 69 fig issues. Givi
3610: 6e 67 20 75 70 20 6e 6f 77 22 29 0a 09 20 20 20 ng up now")..
3620: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 28 (exit 1)))..(
3630: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 if (not (file-ex
3640: 69 73 74 73 3f 20 22 2e 65 7a 73 74 65 70 73 22 ists? ".ezsteps"
3650: 29 29 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 ))(create-direct
3660: 6f 72 79 20 22 2e 65 7a 73 74 65 70 73 22 29 29 ory ".ezsteps"))
3670: 0a 09 3b 3b 20 69 66 20 65 7a 73 74 65 70 73 20 ..;; if ezsteps
3680: 77 61 73 20 64 65 66 69 6e 65 64 20 74 68 65 6e was defined then
3690: 20 77 65 20 61 72 65 20 73 75 72 65 20 74 6f 20 we are sure to
36a0: 68 61 76 65 20 61 74 20 6c 65 61 73 74 20 6f 6e have at least on
36b0: 65 20 73 74 65 70 20 62 75 74 20 63 68 65 63 6b e step but check
36c0: 20 61 6e 79 77 61 79 0a 09 28 69 66 20 28 6e 6f anyway..(if (no
36d0: 74 20 28 3e 20 28 6c 65 6e 67 74 68 20 65 7a 73 t (> (length ezs
36e0: 74 65 70 73 6c 73 74 29 20 30 29 29 0a 09 20 20 tepslst) 0))..
36f0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
3700: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
3710: 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 7a 73 74 65 log-port* "ezste
3720: 70 73 20 64 65 66 69 6e 65 64 20 62 75 74 20 65 ps defined but e
3730: 7a 73 74 65 70 73 6c 73 74 20 69 73 20 7a 65 72 zstepslst is zer
3740: 6f 20 6c 65 6e 67 74 68 22 29 0a 09 20 20 20 20 o length")..
3750: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 65 7a 73 74 (let loop ((ezst
3760: 65 70 20 28 63 61 72 20 65 7a 73 74 65 70 73 6c ep (car ezstepsl
3770: 73 74 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 st))... (t
3780: 61 6c 20 20 20 20 28 63 64 72 20 65 7a 73 74 65 al (cdr ezste
3790: 70 73 6c 73 74 29 29 0a 09 09 20 20 20 20 20 20 pslst))...
37a0: 20 28 70 72 65 76 73 74 65 70 20 23 66 29 29 0a (prevstep #f)).
37b0: 09 20 20 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 . ;; check
37c0: 65 78 69 74 2d 69 6e 66 6f 20 28 76 65 63 74 6f exit-info (vecto
37d0: 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 r-ref exit-info
37e0: 31 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6c 1).. (if (l
37f0: 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d aunch:einf-exit-
3800: 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f status exit-info
3810: 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 ) ;; (vector-ref
3820: 20 65 78 69 74 2d 69 6e 66 6f 20 31 29 0a 09 09 exit-info 1)...
3830: 20 20 28 6c 65 74 20 28 28 6c 6f 67 70 72 6f 2d (let ((logpro-
3840: 75 73 65 64 20 28 6c 61 75 6e 63 68 3a 72 75 6e used (launch:run
3850: 73 74 65 70 20 65 7a 73 74 65 70 20 72 75 6e 2d step ezstep run-
3860: 69 64 20 74 65 73 74 2d 69 64 20 65 78 69 74 2d id test-id exit-
3870: 69 6e 66 6f 20 6d 20 74 61 6c 20 74 65 73 74 63 info m tal testc
3880: 6f 6e 66 69 67 29 29 0a 09 09 09 28 73 74 65 70 onfig))....(step
3890: 6e 61 6d 65 20 20 20 20 28 63 61 72 20 65 7a 73 name (car ezs
38a0: 74 65 70 29 29 29 0a 09 09 20 20 20 20 3b 3b 20 tep)))... ;;
38b0: 69 66 20 6c 6f 67 70 72 6f 2d 75 73 65 64 20 72 if logpro-used r
38c0: 65 61 64 20 69 6e 20 74 68 65 20 73 74 65 70 6e ead in the stepn
38d0: 61 6d 65 2e 64 61 74 20 66 69 6c 65 0a 09 09 20 ame.dat file...
38e0: 20 20 20 28 69 66 20 28 61 6e 64 20 6c 6f 67 70 (if (and logp
38f0: 72 6f 2d 75 73 65 64 20 28 66 69 6c 65 2d 65 78 ro-used (file-ex
3900: 69 73 74 73 3f 20 28 63 6f 6e 63 20 73 74 65 70 ists? (conc step
3910: 6e 61 6d 65 20 22 2e 64 61 74 22 29 29 29 0a 09 name ".dat")))..
3920: 09 09 28 6c 61 75 6e 63 68 3a 6c 6f 61 64 2d 6c ..(launch:load-l
3930: 6f 67 70 72 6f 2d 64 61 74 20 72 75 6e 2d 69 64 ogpro-dat run-id
3940: 20 74 65 73 74 2d 69 64 20 73 74 65 70 6e 61 6d test-id stepnam
3950: 65 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 73 e))... (if (s
3960: 74 65 70 72 75 6e 2d 67 6f 6f 64 3f 20 6c 6f 67 teprun-good? log
3970: 70 72 6f 2d 75 73 65 64 20 28 6c 61 75 6e 63 68 pro-used (launch
3980: 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 65 20 :einf-exit-code
3990: 65 78 69 74 2d 69 6e 66 6f 29 29 0a 09 09 09 28 exit-info))....(
39a0: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
39b0: 61 6c 29 29 0a 09 09 09 20 20 20 20 28 6c 6f 6f al)).... (loo
39c0: 70 20 28 63 61 72 20 74 61 6c 29 20 28 63 64 72 p (car tal) (cdr
39d0: 20 74 61 6c 29 20 73 74 65 70 6e 61 6d 65 29 29 tal) stepname))
39e0: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
39f0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
3a00: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
3a10: 73 74 65 70 20 22 20 28 63 61 72 20 65 7a 73 74 step " (car ezst
3a20: 65 70 29 20 22 20 66 61 69 6c 65 64 2e 20 53 74 ep) " failed. St
3a30: 6f 70 70 69 6e 67 22 29 29 29 0a 09 09 20 20 28 opping")))... (
3a40: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
3a50: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3a60: 20 22 57 41 52 4e 49 4e 47 3a 20 61 20 70 72 69 "WARNING: a pri
3a70: 6f 72 20 73 74 65 70 20 66 61 69 6c 65 64 2c 20 or step failed,
3a80: 73 74 6f 70 70 69 6e 67 20 61 74 20 22 20 65 7a stopping at " ez
3a90: 73 74 65 70 29 29 29 29 29 29 29 0a 0a 28 64 65 step)))))))..(de
3aa0: 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 6d 6f 6e fine (launch:mon
3ab0: 69 74 6f 72 2d 6a 6f 62 20 72 75 6e 2d 69 64 20 itor-job run-id
3ac0: 74 65 73 74 2d 69 64 20 69 74 65 6d 2d 70 61 74 test-id item-pat
3ad0: 68 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 h fullrunscript
3ae0: 65 7a 73 74 65 70 73 20 74 65 73 74 2d 6e 61 6d ezsteps test-nam
3af0: 65 20 74 63 6f 6e 66 69 67 72 65 67 20 65 78 69 e tconfigreg exi
3b00: 74 2d 69 6e 66 6f 20 6d 20 77 6f 72 6b 2d 61 72 t-info m work-ar
3b10: 65 61 20 72 75 6e 74 6c 69 6d 20 6d 69 73 63 2d ea runtlim misc-
3b20: 66 6c 61 67 73 29 0a 20 20 28 6c 65 74 2a 20 28 flags). (let* (
3b30: 28 73 74 61 72 74 2d 73 65 63 6f 6e 64 73 20 28 (start-seconds (
3b40: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
3b50: 29 0a 09 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 ).. (calc-minute
3b60: 73 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 s (lambda ()...
3b70: 09 20 20 28 69 6e 65 78 61 63 74 2d 3e 65 78 61 . (inexact->exa
3b80: 63 74 20 0a 09 09 09 20 20 20 28 72 6f 75 6e 64 ct .... (round
3b90: 20 0a 09 09 09 20 20 20 20 28 2d 20 0a 09 09 09 .... (- ....
3ba0: 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 (current-se
3bb0: 63 6f 6e 64 73 29 20 0a 09 09 09 20 20 20 20 20 conds) ....
3bc0: 73 74 61 72 74 2d 73 65 63 6f 6e 64 73 29 29 29 start-seconds)))
3bd0: 29 29 0a 09 20 28 6b 69 6c 6c 2d 74 72 69 65 73 )).. (kill-tries
3be0: 20 30 29 29 0a 20 20 20 20 3b 3b 20 28 74 65 73 0)). ;; (tes
3bf0: 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 ts:set-full-meta
3c00: 2d 69 6e 66 6f 20 23 66 20 74 65 73 74 2d 69 64 -info #f test-id
3c10: 20 72 75 6e 2d 69 64 20 28 63 61 6c 63 2d 6d 69 run-id (calc-mi
3c20: 6e 75 74 65 73 29 20 77 6f 72 6b 2d 61 72 65 61 nutes) work-area
3c30: 29 0a 20 20 20 20 3b 3b 20 28 74 65 73 74 73 3a ). ;; (tests:
3c40: 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e set-full-meta-in
3c50: 66 6f 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 fo test-id run-i
3c60: 64 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 d (calc-minutes)
3c70: 20 77 6f 72 6b 2d 61 72 65 61 29 0a 20 20 20 20 work-area).
3c80: 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d (tests:set-full-
3c90: 6d 65 74 61 2d 69 6e 66 6f 20 23 66 20 74 65 73 meta-info #f tes
3ca0: 74 2d 69 64 20 72 75 6e 2d 69 64 20 28 63 61 6c t-id run-id (cal
3cb0: 63 2d 6d 69 6e 75 74 65 73 29 20 77 6f 72 6b 2d c-minutes) work-
3cc0: 61 72 65 61 20 31 30 29 0a 20 20 20 20 28 6c 65 area 10). (le
3cd0: 74 20 6c 6f 6f 70 20 28 28 6d 69 6e 75 74 65 73 t loop ((minutes
3ce0: 20 20 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 (calc-minutes
3cf0: 29 29 0a 09 20 20 20 20 20 20 20 28 63 70 75 2d )).. (cpu-
3d00: 6c 6f 61 64 20 20 28 67 65 74 2d 63 70 75 2d 6c load (get-cpu-l
3d10: 6f 61 64 29 29 0a 09 20 20 20 20 20 20 20 28 64 oad)).. (d
3d20: 69 73 6b 2d 66 72 65 65 20 28 67 65 74 2d 64 66 isk-free (get-df
3d30: 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
3d40: 6f 72 79 29 29 29 29 0a 20 20 20 20 20 20 28 6c ory)))). (l
3d50: 65 74 20 28 28 6e 65 77 2d 63 70 75 2d 6c 6f 61 et ((new-cpu-loa
3d60: 64 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 20 20 d (let* ((load
3d70: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d (common:get-norm
3d80: 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 alized-cpu-load
3d90: 23 66 29 29 0a 09 09 09 09 20 28 64 65 6c 74 61 #f))..... (delta
3da0: 20 28 61 62 73 20 28 2d 20 6c 6f 61 64 20 63 70 (abs (- load cp
3db0: 75 2d 6c 6f 61 64 29 29 29 29 0a 09 09 09 20 20 u-load))))....
3dc0: 20 20 28 69 66 20 28 3e 20 64 65 6c 74 61 20 30 (if (> delta 0
3dd0: 2e 36 29 20 3b 3b 20 64 6f 6e 27 74 20 62 6f 74 .6) ;; don't bot
3de0: 68 65 72 20 75 70 64 61 74 69 6e 67 20 77 69 74 her updating wit
3df0: 68 20 73 6d 61 6c 6c 20 63 68 61 6e 67 65 73 0a h small changes.
3e00: 09 09 09 09 6c 6f 61 64 0a 09 09 09 09 23 66 29 ....load.....#f)
3e10: 29 29 0a 09 20 20 20 20 28 6e 65 77 2d 64 69 73 )).. (new-dis
3e20: 6b 2d 66 72 65 65 20 28 6c 65 74 2a 20 28 28 64 k-free (let* ((d
3e30: 66 20 20 20 20 28 67 65 74 2d 64 66 20 28 63 75 f (get-df (cu
3e40: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
3e50: 29 29 0a 09 09 09 09 20 20 28 64 65 6c 74 61 20 ))..... (delta
3e60: 28 61 62 73 20 28 2d 20 64 66 20 64 69 73 6b 2d (abs (- df disk-
3e70: 66 72 65 65 29 29 29 29 0a 09 09 09 20 20 20 20 free))))....
3e80: 20 28 69 66 20 28 3e 20 64 65 6c 74 61 20 32 30 (if (> delta 20
3e90: 30 29 20 3b 3b 20 69 67 6e 6f 72 65 20 63 68 61 0) ;; ignore cha
3ea0: 6e 67 65 73 20 75 6e 64 65 72 20 32 30 30 20 4d nges under 200 M
3eb0: 65 67 0a 09 09 09 09 20 64 66 0a 09 09 09 09 20 eg..... df.....
3ec0: 23 66 29 29 29 29 0a 09 28 73 65 74 21 20 6b 69 #f))))..(set! ki
3ed0: 6c 6c 2d 6a 6f 62 3f 20 28 6f 72 20 28 74 65 73 ll-job? (or (tes
3ee0: 74 2d 67 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 t-get-kill-reque
3ef0: 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 st run-id test-i
3f00: 64 29 20 3b 3b 20 72 75 6e 2d 69 64 20 74 65 73 d) ;; run-id tes
3f10: 74 2d 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 29 t-name itemdat))
3f20: 0a 09 09 09 20 20 20 20 28 61 6e 64 20 72 75 6e .... (and run
3f30: 74 6c 69 6d 20 28 6c 65 74 2a 20 28 28 72 75 6e tlim (let* ((run
3f40: 2d 73 65 63 6f 6e 64 73 20 20 20 28 2d 20 28 63 -seconds (- (c
3f50: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
3f60: 73 74 61 72 74 2d 73 65 63 6f 6e 64 73 29 29 0a start-seconds)).
3f70: 09 09 09 09 09 09 28 74 69 6d 65 2d 65 78 63 65 ......(time-exce
3f80: 65 64 65 64 20 28 3e 20 72 75 6e 2d 73 65 63 6f eded (> run-seco
3f90: 6e 64 73 20 72 75 6e 74 6c 69 6d 29 29 29 0a 09 nds runtlim)))..
3fa0: 09 09 09 09 20 20 20 28 69 66 20 74 69 6d 65 2d .... (if time-
3fb0: 65 78 63 65 65 64 65 64 0a 09 09 09 09 09 20 20 exceeded......
3fc0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 (begin.....
3fd0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d .. (debug:print-
3fe0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
3ff0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 4b 49 4c 4c 49 log-port* "KILLI
4000: 4e 47 20 54 45 53 54 20 44 55 45 20 54 4f 20 54 NG TEST DUE TO T
4010: 49 4d 45 20 4c 49 4d 49 54 20 45 58 43 45 45 44 IME LIMIT EXCEED
4020: 45 44 21 20 52 75 6e 74 69 6d 65 3d 22 20 72 75 ED! Runtime=" ru
4030: 6e 2d 73 65 63 6f 6e 64 73 20 22 20 73 65 63 6f n-seconds " seco
4040: 6e 64 73 2c 20 6c 69 6d 69 74 3d 22 20 72 75 6e nds, limit=" run
4050: 74 6c 69 6d 29 0a 09 09 09 09 09 09 20 23 74 29 tlim)....... #t)
4060: 0a 09 09 09 09 09 20 20 20 20 20 20 20 23 66 29 ...... #f)
4070: 29 29 29 29 0a 09 28 74 65 73 74 73 3a 75 70 64 ))))..(tests:upd
4080: 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 ate-central-meta
4090: 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 -info run-id tes
40a0: 74 2d 69 64 20 6e 65 77 2d 63 70 75 2d 6c 6f 61 t-id new-cpu-loa
40b0: 64 20 6e 65 77 2d 64 69 73 6b 2d 66 72 65 65 20 d new-disk-free
40c0: 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 20 23 (calc-minutes) #
40d0: 66 20 23 66 29 0a 09 28 69 66 20 6b 69 6c 6c 2d f #f)..(if kill-
40e0: 6a 6f 62 3f 20 0a 09 20 20 20 20 28 62 65 67 69 job? .. (begi
40f0: 6e 0a 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d n.. (mutex-
4100: 6c 6f 63 6b 21 20 6d 29 0a 09 20 20 20 20 20 20 lock! m)..
4110: 3b 3b 20 4e 4f 54 45 3a 20 54 68 65 20 70 69 64 ;; NOTE: The pid
4120: 20 63 61 6e 20 63 68 61 6e 67 65 20 61 73 20 64 can change as d
4130: 69 66 66 65 72 65 6e 74 20 73 74 65 70 73 20 61 ifferent steps a
4140: 72 65 20 72 75 6e 2e 20 44 6f 20 77 65 20 6e 65 re run. Do we ne
4150: 65 64 20 68 61 6e 64 73 68 61 6b 69 6e 67 20 62 ed handshaking b
4160: 65 74 77 65 65 6e 20 74 68 69 73 0a 09 20 20 20 etween this..
4170: 20 20 20 3b 3b 20 20 20 20 20 20 20 73 65 63 74 ;; sect
4180: 69 6f 6e 20 61 6e 64 20 74 68 65 20 72 75 6e 69 ion and the runi
4190: 74 20 73 65 63 74 69 6f 6e 3f 20 4f 72 20 61 64 t section? Or ad
41a0: 64 20 61 20 6c 6f 6f 70 20 74 68 61 74 20 74 72 d a loop that tr
41b0: 69 65 73 20 74 68 72 65 65 20 74 69 6d 65 73 20 ies three times
41c0: 77 69 74 68 20 61 20 31 2f 34 20 73 65 63 6f 6e with a 1/4 secon
41d0: 64 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 20 20 d.. ;;
41e0: 20 20 62 65 74 77 65 65 6e 20 74 72 69 65 73 3f between tries?
41f0: 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
4200: 70 69 64 31 20 28 6c 61 75 6e 63 68 3a 65 69 6e pid1 (launch:ein
4210: 66 2d 70 69 64 20 65 78 69 74 2d 69 6e 66 6f 29 f-pid exit-info)
4220: 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 ) ;; (vector-ref
4230: 20 65 78 69 74 2d 69 6e 66 6f 20 30 29 29 0a 09 exit-info 0))..
4240: 09 20 20 20 20 20 28 70 69 64 32 20 28 72 6d 74 . (pid2 (rmt
4250: 3a 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 :test-get-top-pr
4260: 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 ocess-pid run-id
4270: 20 74 65 73 74 2d 69 64 29 29 0a 09 09 20 20 20 test-id))...
4280: 20 20 28 70 69 64 73 20 28 64 65 6c 65 74 65 2d (pids (delete-
4290: 64 75 70 6c 69 63 61 74 65 73 20 28 66 69 6c 74 duplicates (filt
42a0: 65 72 20 6e 75 6d 62 65 72 3f 20 28 6c 69 73 74 er number? (list
42b0: 20 70 69 64 31 20 70 69 64 32 29 29 29 29 29 0a pid1 pid2))))).
42c0: 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c ..(if (not (null
42d0: 3f 20 70 69 64 73 29 29 0a 09 09 20 20 20 20 28 ? pids))... (
42e0: 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 28 66 begin... (f
42f0: 6f 72 2d 65 61 63 68 0a 09 09 20 20 20 20 20 20 or-each...
4300: 20 28 6c 61 6d 62 64 61 20 28 70 69 64 29 0a 09 (lambda (pid)..
4310: 09 09 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 .. (handle-excep
4320: 74 69 6f 6e 73 0a 09 09 09 20 20 65 78 6e 0a 09 tions.... exn..
4330: 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 20 20 .. (begin....
4340: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
4350: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
4360: 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 61 62 6c 65 og-port* "Unable
4370: 20 74 6f 20 6b 69 6c 6c 20 70 72 6f 63 65 73 73 to kill process
4380: 20 77 69 74 68 20 70 69 64 20 22 20 70 69 64 20 with pid " pid
4390: 22 2c 20 70 6f 73 73 69 62 6c 79 20 61 6c 72 65 ", possibly alre
43a0: 61 64 79 20 6b 69 6c 6c 65 64 2e 22 29 0a 09 09 ady killed.")...
43b0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
43c0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
43d0: 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 -port* " message
43e0: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
43f0: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
4400: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
4410: 20 65 78 6e 29 29 29 0a 09 09 09 20 20 28 64 65 exn))).... (de
4420: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
4430: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4440: 57 41 52 4e 49 4e 47 3a 20 52 65 71 75 65 73 74 WARNING: Request
4450: 20 72 65 63 65 69 76 65 64 20 74 6f 20 6b 69 6c received to kil
4460: 6c 20 6a 6f 62 20 22 20 70 69 64 29 20 3b 3b 20 l job " pid) ;;
4470: 20 22 20 28 61 74 74 65 6d 70 74 20 23 20 22 20 " (attempt # "
4480: 6b 69 6c 6c 2d 74 72 69 65 73 20 22 29 22 29 0a kill-tries ")").
4490: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
44a0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
44b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 69 67 t-log-port* "Sig
44c0: 6e 61 6c 20 6d 61 73 6b 3d 22 20 28 73 69 67 6e nal mask=" (sign
44d0: 61 6c 2d 6d 61 73 6b 29 29 0a 09 09 09 20 20 3b al-mask)).... ;
44e0: 3b 20 28 69 66 20 28 70 72 6f 63 65 73 73 3a 61 ; (if (process:a
44f0: 6c 69 76 65 3f 20 70 69 64 29 0a 09 09 09 20 20 live? pid)....
4500: 3b 3b 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ;; (begin...
4510: 09 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
4520: 28 70 69 64 2d 6e 75 6d 29 0a 09 09 09 09 20 28 (pid-num)..... (
4530: 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 70 process-signal p
4540: 69 64 2d 6e 75 6d 20 73 69 67 6e 61 6c 2f 74 65 id-num signal/te
4550: 72 6d 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 rm)).... (
4560: 70 72 6f 63 65 73 73 3a 67 65 74 2d 73 75 62 2d process:get-sub-
4570: 70 69 64 73 20 70 69 64 29 29 0a 09 09 09 20 20 pids pid))....
4580: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
4590: 29 0a 09 09 09 20 20 3b 3b 20 28 69 66 20 28 70 ).... ;; (if (p
45a0: 72 6f 63 65 73 73 3a 70 72 6f 63 65 73 73 2d 61 rocess:process-a
45b0: 6c 69 76 65 3f 20 70 69 64 29 0a 09 09 09 20 20 live? pid)....
45c0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 69 (map (lambda (pi
45d0: 64 2d 6e 75 6d 29 0a 09 09 09 09 20 28 68 61 6e d-num)..... (han
45e0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
45f0: 09 09 09 20 20 65 78 6e 0a 09 09 09 09 20 20 23 ... exn..... #
4600: 66 0a 09 09 09 09 20 20 28 70 72 6f 63 65 73 73 f..... (process
4610: 2d 73 69 67 6e 61 6c 20 70 69 64 2d 6e 75 6d 20 -signal pid-num
4620: 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 29 29 0a 09 signal/kill)))..
4630: 09 09 20 20 20 20 20 20 20 28 70 72 6f 63 65 73 .. (proces
4640: 73 3a 67 65 74 2d 73 75 62 2d 70 69 64 73 20 70 s:get-sub-pids p
4650: 69 64 29 29 29 29 0a 09 09 20 20 20 20 20 20 20 id))))...
4660: 3b 3b 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
4670: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
4680: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f lt-log-port* "no
4690: 74 20 6b 69 6c 6c 69 6e 67 20 70 72 6f 63 65 73 t killing proces
46a0: 73 20 22 20 70 69 64 20 22 20 61 73 20 69 74 20 s " pid " as it
46b0: 69 73 20 6e 6f 74 20 61 6c 69 76 65 22 29 29 29 is not alive")))
46c0: 29 0a 09 09 20 20 20 20 20 20 20 70 69 64 73 29 )... pids)
46d0: 0a 09 09 20 20 20 20 20 20 28 74 65 73 74 73 3a ... (tests:
46e0: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
46f0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
4700: 22 4b 49 4c 4c 45 44 22 20 20 22 4b 49 4c 4c 45 "KILLED" "KILLE
4710: 44 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 D" (args:get-arg
4720: 20 22 2d 6d 22 29 20 23 66 29 29 0a 09 09 20 20 "-m") #f))...
4730: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 (begin...
4740: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
4750: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
4760: 6f 67 2d 70 6f 72 74 2a 20 22 4e 6f 74 68 69 6e og-port* "Nothin
4770: 67 20 74 6f 20 6b 69 6c 6c 2c 20 70 69 64 31 3d g to kill, pid1=
4780: 22 20 70 69 64 31 20 22 2c 20 70 69 64 32 3d 22 " pid1 ", pid2="
4790: 20 70 69 64 32 29 0a 09 09 20 20 20 20 20 20 28 pid2)... (
47a0: 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 tests:test-set-s
47b0: 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 tatus! run-id te
47c0: 73 74 2d 69 64 20 22 4b 49 4c 4c 45 44 22 20 20 st-id "KILLED"
47d0: 22 46 41 49 4c 45 44 20 54 4f 20 4b 49 4c 4c 22 "FAILED TO KILL"
47e0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
47f0: 2d 6d 22 29 20 23 66 29 0a 09 09 20 20 20 20 20 -m") #f)...
4800: 20 29 29 29 0a 09 20 20 20 20 20 20 28 6d 75 74 ))).. (mut
4810: 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 29 0a 09 20 ex-unlock! m)..
4820: 20 20 20 20 20 3b 3b 20 6e 6f 20 70 6f 69 6e 74 ;; no point
4830: 20 69 6e 20 73 74 69 63 6b 69 6e 67 20 61 72 6f in sticking aro
4840: 75 6e 64 2e 20 45 78 69 74 20 6e 6f 77 2e 0a 09 und. Exit now...
4850: 20 20 20 20 20 20 28 65 78 69 74 29 29 29 0a 09 (exit)))..
4860: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
4870: 72 65 66 2f 64 65 66 61 75 6c 74 20 6d 69 73 63 ref/default misc
4880: 2d 66 6c 61 67 73 20 27 6b 65 65 70 2d 67 6f 69 -flags 'keep-goi
4890: 6e 67 20 23 66 29 0a 09 20 20 20 20 28 62 65 67 ng #f).. (beg
48a0: 69 6e 0a 09 20 20 20 20 20 20 28 74 68 72 65 61 in.. (threa
48b0: 64 2d 73 6c 65 65 70 21 20 33 29 20 3b 3b 20 28 d-sleep! 3) ;; (
48c0: 2b 20 33 20 28 72 61 6e 64 6f 6d 20 36 29 29 29 + 3 (random 6)))
48d0: 20 3b 3b 20 61 64 64 20 73 6f 6d 65 20 6a 69 74 ;; add some jit
48e0: 74 65 72 20 74 6f 20 74 68 65 20 63 61 6c 6c 20 ter to the call
48f0: 68 6f 6d 65 20 74 69 6d 65 20 74 6f 20 73 70 72 home time to spr
4900: 65 61 64 20 6f 75 74 20 74 68 65 20 64 62 20 61 ead out the db a
4910: 63 63 65 73 73 65 73 0a 09 20 20 20 20 20 20 28 ccesses.. (
4920: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 if (hash-table-r
4930: 65 66 2f 64 65 66 61 75 6c 74 20 6d 69 73 63 2d ef/default misc-
4940: 66 6c 61 67 73 20 27 6b 65 65 70 2d 67 6f 69 6e flags 'keep-goin
4950: 67 20 23 66 29 20 20 3b 3b 20 6b 65 65 70 20 6f g #f) ;; keep o
4960: 72 69 67 69 6e 61 6c 73 20 66 6f 72 20 63 70 75 riginals for cpu
4970: 2d 6c 6f 61 64 20 61 6e 64 20 64 69 73 6b 2d 66 -load and disk-f
4980: 72 65 65 20 75 6e 6c 65 73 73 20 74 68 65 79 20 ree unless they
4990: 63 68 61 6e 67 65 20 6d 6f 72 65 20 74 68 61 6e change more than
49a0: 20 74 68 65 20 61 6c 6c 6f 77 65 64 20 64 65 6c the allowed del
49b0: 74 61 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 ta... (loop (ca
49c0: 6c 63 2d 6d 69 6e 75 74 65 73 29 20 28 6f 72 20 lc-minutes) (or
49d0: 6e 65 77 2d 63 70 75 2d 6c 6f 61 64 20 63 70 75 new-cpu-load cpu
49e0: 2d 6c 6f 61 64 29 20 28 6f 72 20 6e 65 77 2d 64 -load) (or new-d
49f0: 69 73 6b 2d 66 72 65 65 20 64 69 73 6b 2d 66 72 isk-free disk-fr
4a00: 65 65 29 29 29 29 29 29 29 0a 20 20 20 20 28 74 ee))))))). (t
4a10: 65 73 74 73 3a 75 70 64 61 74 65 2d 63 65 6e 74 ests:update-cent
4a20: 72 61 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 72 75 ral-meta-info ru
4a30: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 28 67 65 n-id test-id (ge
4a40: 74 2d 63 70 75 2d 6c 6f 61 64 29 20 28 67 65 74 t-cpu-load) (get
4a50: 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 69 72 -df (current-dir
4a60: 65 63 74 6f 72 79 29 29 28 63 61 6c 63 2d 6d 69 ectory))(calc-mi
4a70: 6e 75 74 65 73 29 20 23 66 20 23 66 29 29 29 20 nutes) #f #f)))
4a80: 3b 3b 20 4e 4f 54 45 3a 20 43 68 65 63 6b 69 6e ;; NOTE: Checkin
4a90: 67 20 74 77 69 63 65 20 66 6f 72 20 6b 65 65 70 g twice for keep
4aa0: 2d 67 6f 69 6e 67 20 69 73 20 69 6e 74 65 6e 74 -going is intent
4ab0: 69 6f 6e 61 6c 0a 0a 28 64 65 66 69 6e 65 20 28 ional..(define (
4ac0: 6c 61 75 6e 63 68 3a 65 78 65 63 75 74 65 20 65 launch:execute e
4ad0: 6e 63 6f 64 65 64 2d 63 6d 64 29 0a 20 20 28 6c ncoded-cmd). (l
4ae0: 65 74 2a 20 28 28 63 6d 64 69 6e 66 6f 20 20 20 et* ((cmdinfo
4af0: 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 65 6e (common:read-en
4b00: 63 6f 64 65 64 2d 73 74 72 69 6e 67 20 65 6e 63 coded-string enc
4b10: 6f 64 65 64 2d 63 6d 64 29 29 0a 09 20 28 74 63 oded-cmd)).. (tc
4b20: 6f 6e 66 69 67 72 65 67 20 23 66 29 29 0a 20 20 onfigreg #f)).
4b30: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 43 4d (setenv "MT_CM
4b40: 44 49 4e 46 4f 22 20 65 6e 63 6f 64 65 64 2d 63 DINFO" encoded-c
4b50: 6d 64 29 0a 20 20 20 20 28 69 66 20 28 6c 69 73 md). (if (lis
4b60: 74 3f 20 63 6d 64 69 6e 66 6f 29 20 3b 3b 20 28 t? cmdinfo) ;; (
4b70: 28 74 65 73 74 70 61 74 68 20 2f 74 6d 70 2f 6d (testpath /tmp/m
4b80: 72 77 65 6c 6c 61 6e 2f 6a 61 7a 7a 6d 69 6e 64 rwellan/jazzmind
4b90: 2f 73 72 63 2f 65 78 61 6d 70 6c 65 5f 72 75 6e /src/example_run
4ba0: 2f 74 65 73 74 73 2f 73 71 6c 69 74 65 73 70 65 /tests/sqlitespe
4bb0: 65 64 29 0a 09 3b 3b 20 28 74 65 73 74 2d 6e 61 ed)..;; (test-na
4bc0: 6d 65 20 73 71 6c 69 74 65 73 70 65 65 64 29 20 me sqlitespeed)
4bd0: 28 72 75 6e 73 63 72 69 70 74 20 72 75 6e 73 63 (runscript runsc
4be0: 72 69 70 74 2e 72 62 29 20 28 64 62 2d 68 6f 73 ript.rb) (db-hos
4bf0: 74 20 6c 6f 63 61 6c 68 6f 73 74 29 20 28 72 75 t localhost) (ru
4c00: 6e 2d 69 64 20 31 29 29 0a 09 28 6c 65 74 2a 20 n-id 1))..(let*
4c10: 28 28 74 65 73 74 70 61 74 68 20 20 28 61 73 73 ((testpath (ass
4c20: 6f 63 2f 64 65 66 61 75 6c 74 20 27 74 65 73 74 oc/default 'test
4c30: 70 61 74 68 20 20 63 6d 64 69 6e 66 6f 29 29 20 path cmdinfo))
4c40: 20 3b 3b 20 74 65 73 74 70 61 74 68 20 69 73 20 ;; testpath is
4c50: 74 68 65 20 74 65 73 74 20 73 70 65 63 20 61 72 the test spec ar
4c60: 65 61 0a 09 20 20 20 20 20 20 20 28 74 6f 70 2d ea.. (top-
4c70: 70 61 74 68 20 20 28 61 73 73 6f 63 2f 64 65 66 path (assoc/def
4c80: 61 75 6c 74 20 27 74 6f 70 70 61 74 68 20 20 20 ault 'toppath
4c90: 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 cmdinfo))..
4ca0: 20 20 28 77 6f 72 6b 2d 61 72 65 61 20 28 61 73 (work-area (as
4cb0: 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 77 6f 72 soc/default 'wor
4cc0: 6b 2d 61 72 65 61 20 63 6d 64 69 6e 66 6f 29 29 k-area cmdinfo))
4cd0: 20 20 3b 3b 20 77 6f 72 6b 2d 61 72 65 61 20 69 ;; work-area i
4ce0: 73 20 74 68 65 20 74 65 73 74 20 72 75 6e 20 61 s the test run a
4cf0: 72 65 61 0a 09 20 20 20 20 20 20 20 28 74 65 73 rea.. (tes
4d00: 74 2d 6e 61 6d 65 20 28 61 73 73 6f 63 2f 64 65 t-name (assoc/de
4d10: 66 61 75 6c 74 20 27 74 65 73 74 2d 6e 61 6d 65 fault 'test-name
4d20: 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 cmdinfo))..
4d30: 20 20 20 28 72 75 6e 73 63 72 69 70 74 20 28 61 (runscript (a
4d40: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 ssoc/default 'ru
4d50: 6e 73 63 72 69 70 74 20 63 6d 64 69 6e 66 6f 29 nscript cmdinfo)
4d60: 29 0a 09 20 20 20 20 20 20 20 28 65 7a 73 74 65 ).. (ezste
4d70: 70 73 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 ps (assoc/defa
4d80: 75 6c 74 20 27 65 7a 73 74 65 70 73 20 20 20 63 ult 'ezsteps c
4d90: 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 mdinfo))..
4da0: 20 3b 3b 20 28 72 75 6e 72 65 6d 6f 74 65 20 28 ;; (runremote (
4db0: 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 assoc/default 'r
4dc0: 75 6e 72 65 6d 6f 74 65 20 63 6d 64 69 6e 66 6f unremote cmdinfo
4dd0: 29 29 0a 09 20 20 20 20 20 20 20 28 74 72 61 6e )).. (tran
4de0: 73 70 6f 72 74 20 28 61 73 73 6f 63 2f 64 65 66 sport (assoc/def
4df0: 61 75 6c 74 20 27 74 72 61 6e 73 70 6f 72 74 20 ault 'transport
4e00: 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 cmdinfo))..
4e10: 20 20 3b 3b 20 28 73 65 72 76 65 72 69 6e 66 20 ;; (serverinf
4e20: 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 (assoc/default '
4e30: 73 65 72 76 65 72 69 6e 66 20 63 6d 64 69 6e 66 serverinf cmdinf
4e40: 6f 29 29 0a 09 20 20 20 20 20 20 20 28 70 6f 72 o)).. (por
4e50: 74 20 20 20 20 20 20 28 61 73 73 6f 63 2f 64 65 t (assoc/de
4e60: 66 61 75 6c 74 20 27 70 6f 72 74 20 20 20 20 20 fault 'port
4e70: 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 cmdinfo))..
4e80: 20 20 20 28 72 75 6e 2d 69 64 20 20 20 20 28 61 (run-id (a
4e90: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 ssoc/default 'ru
4ea0: 6e 2d 69 64 20 20 20 20 63 6d 64 69 6e 66 6f 29 n-id cmdinfo)
4eb0: 29 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d ).. (test-
4ec0: 69 64 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 id (assoc/defa
4ed0: 75 6c 74 20 27 74 65 73 74 2d 69 64 20 20 20 63 ult 'test-id c
4ee0: 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 mdinfo))..
4ef0: 20 28 74 61 72 67 65 74 20 20 20 20 28 61 73 73 (target (ass
4f00: 6f 63 2f 64 65 66 61 75 6c 74 20 27 74 61 72 67 oc/default 'targ
4f10: 65 74 20 20 20 20 63 6d 64 69 6e 66 6f 29 29 0a et cmdinfo)).
4f20: 09 20 20 20 20 20 20 20 28 69 74 65 6d 64 61 74 . (itemdat
4f30: 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c (assoc/defaul
4f40: 74 20 27 69 74 65 6d 64 61 74 20 20 20 63 6d 64 t 'itemdat cmd
4f50: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 info)).. (
4f60: 65 6e 76 2d 6f 76 72 64 20 20 28 61 73 73 6f 63 env-ovrd (assoc
4f70: 2f 64 65 66 61 75 6c 74 20 27 65 6e 76 2d 6f 76 /default 'env-ov
4f80: 72 64 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 rd cmdinfo))..
4f90: 20 20 20 20 20 20 28 73 65 74 2d 76 61 72 73 20 (set-vars
4fa0: 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 (assoc/default
4fb0: 27 73 65 74 2d 76 61 72 73 20 20 63 6d 64 69 6e 'set-vars cmdin
4fc0: 66 6f 29 29 20 3b 3b 20 70 72 65 2d 6f 76 65 72 fo)) ;; pre-over
4fd0: 72 69 64 65 73 20 66 72 6f 6d 20 2d 73 65 74 76 rides from -setv
4fe0: 61 72 0a 09 20 20 20 20 20 20 20 28 72 75 6e 6e ar.. (runn
4ff0: 61 6d 65 20 20 20 28 61 73 73 6f 63 2f 64 65 66 ame (assoc/def
5000: 61 75 6c 74 20 27 72 75 6e 6e 61 6d 65 20 20 20 ault 'runname
5010: 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 cmdinfo))..
5020: 20 20 28 6d 65 67 61 74 65 73 74 20 20 28 61 73 (megatest (as
5030: 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 6d 65 67 soc/default 'meg
5040: 61 74 65 73 74 20 20 63 6d 64 69 6e 66 6f 29 29 atest cmdinfo))
5050: 0a 09 20 20 20 20 20 20 20 28 72 75 6e 74 6c 69 .. (runtli
5060: 6d 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 m (assoc/defau
5070: 6c 74 20 27 72 75 6e 74 6c 69 6d 20 20 20 63 6d lt 'runtlim cm
5080: 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 dinfo))..
5090: 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d (item-path (item
50a0: 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d -list->path item
50b0: 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 6d dat)).. (m
50c0: 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 28 61 t-bindir-path (a
50d0: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 6d 74 ssoc/default 'mt
50e0: 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 63 6d 64 -bindir-path cmd
50f0: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 info)).. (
5100: 6b 65 79 73 20 20 20 20 20 20 23 66 29 0a 09 20 keys #f)..
5110: 20 20 20 20 20 20 28 6b 65 79 76 61 6c 73 20 20 (keyvals
5120: 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 66 75 #f).. (fu
5130: 6c 6c 72 75 6e 73 63 72 69 70 74 20 28 69 66 20 llrunscript (if
5140: 28 6e 6f 74 20 72 75 6e 73 63 72 69 70 74 29 0a (not runscript).
5150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5170: 20 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 #f.
5180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5190: 20 20 20 20 20 20 20 28 69 66 20 28 73 75 62 73 (if (subs
51a0: 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 20 tring-index "/"
51b0: 72 75 6e 73 63 72 69 70 74 29 0a 20 20 20 20 20 runscript).
51c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51e0: 20 72 75 6e 73 63 72 69 70 74 20 3b 3b 20 75 73 runscript ;; us
51f0: 65 20 75 6e 61 64 75 6c 74 65 72 65 64 20 69 66 e unadultered if
5200: 20 63 6f 6e 74 61 69 6e 73 20 73 6c 61 73 68 65 contains slashe
5210: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
5220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5230: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 66 (let ((f
5240: 75 6c 6c 6e 20 28 63 6f 6e 63 20 74 65 73 74 70 ulln (conc testp
5250: 61 74 68 20 22 2f 22 20 72 75 6e 73 63 72 69 70 ath "/" runscrip
5260: 74 29 29 29 0a 09 20 20 20 20 20 20 20 20 20 20 t)))..
5270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5280: 20 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 (if (and
5290: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
52a0: 75 6c 6c 6e 29 0a 20 20 20 20 20 20 20 20 20 20 ulln).
52b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52d0: 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d 65 (file-e
52e0: 78 65 63 75 74 65 2d 61 63 63 65 73 73 3f 20 66 xecute-access? f
52f0: 75 6c 6c 6e 29 29 0a 20 20 20 20 20 20 20 20 20 ulln)).
5300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5320: 20 20 20 20 20 66 75 6c 6c 6e 0a 20 20 20 20 20 fulln.
5330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5350: 20 20 20 20 20 20 20 20 20 72 75 6e 73 63 72 69 runscri
5360: 70 74 29 29 29 29 29 20 3b 3b 20 61 73 73 75 6d pt))))) ;; assum
5370: 65 20 69 74 20 69 73 20 6f 6e 20 74 68 65 20 70 e it is on the p
5380: 61 74 68 0a 09 20 20 20 20 20 20 20 29 20 3b 3b ath.. ) ;;
5390: 20 28 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 (rollup-status
53a0: 30 29 0a 0a 09 20 20 3b 3b 20 4e 46 53 20 6d 69 0)... ;; NFS mi
53b0: 67 68 74 20 6e 6f 74 20 68 61 76 65 20 70 72 6f ght not have pro
53c0: 70 61 67 61 74 65 64 20 74 68 65 20 64 69 72 65 pagated the dire
53d0: 63 74 6f 72 79 20 6d 65 74 61 20 64 61 74 61 20 ctory meta data
53e0: 74 6f 20 74 68 65 20 72 75 6e 20 68 6f 73 74 20 to the run host
53f0: 2d 20 67 69 76 65 20 69 74 20 74 69 6d 65 20 69 - give it time i
5400: 66 20 6e 65 65 64 65 64 0a 09 20 20 28 6c 65 74 f needed.. (let
5410: 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 29 loop ((count 0)
5420: 29 0a 09 20 20 20 20 28 69 66 20 28 6f 72 20 28 ).. (if (or (
5430: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 6f 70 file-exists? top
5440: 2d 70 61 74 68 29 0a 09 09 20 20 20 20 28 3e 20 -path)... (>
5450: 63 6f 75 6e 74 20 31 30 29 29 0a 09 09 28 63 68 count 10))...(ch
5460: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 74 ange-directory t
5470: 6f 70 2d 70 61 74 68 29 0a 09 09 28 62 65 67 69 op-path)...(begi
5480: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
5490: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
54a0: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e g-port* "INFO: N
54b0: 6f 74 20 73 74 61 72 74 69 6e 67 20 6a 6f 62 20 ot starting job
54c0: 79 65 74 20 2d 20 64 69 72 65 63 74 6f 72 79 20 yet - directory
54d0: 22 20 74 6f 70 2d 70 61 74 68 20 22 20 6e 6f 74 " top-path " not
54e0: 20 66 6f 75 6e 64 22 29 0a 09 09 20 20 28 74 68 found")... (th
54f0: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 0a read-sleep! 10).
5500: 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f 75 .. (loop (+ cou
5510: 6e 74 20 31 29 29 29 29 29 0a 09 20 20 28 6c 61 nt 1))))).. (la
5520: 75 6e 63 68 3a 73 65 74 75 70 29 20 3b 3b 20 73 unch:setup) ;; s
5530: 68 6f 75 6c 64 20 62 65 20 70 72 6f 70 65 72 6c hould be properl
5540: 79 20 69 6e 20 74 68 65 20 74 6f 70 2d 70 61 74 y in the top-pat
5550: 68 20 6e 6f 77 0a 09 20 20 28 73 65 74 21 20 74 h now.. (set! t
5560: 63 6f 6e 66 69 67 72 65 67 20 28 74 65 73 74 73 configreg (tests
5570: 3a 67 65 74 2d 61 6c 6c 29 29 0a 09 20 20 28 6c :get-all)).. (l
5580: 65 74 20 28 28 73 69 67 68 61 6e 64 20 28 6c 61 et ((sighand (la
5590: 6d 62 64 61 20 28 73 69 67 6e 75 6d 29 0a 09 09 mbda (signum)...
55a0: 09 20 20 20 3b 3b 20 28 73 69 67 6e 61 6c 2d 6d . ;; (signal-m
55b0: 61 73 6b 21 20 73 69 67 6e 75 6d 29 20 3b 3b 20 ask! signum) ;;
55c0: 74 6f 20 6d 61 73 6b 20 6f 72 20 6e 6f 74 3f 20 to mask or not?
55d0: 73 65 65 6d 73 20 74 6f 20 63 61 75 73 65 20 69 seems to cause i
55e0: 73 73 75 65 73 20 69 6e 20 65 78 69 74 69 6e 67 ssues in exiting
55f0: 0a 09 09 09 20 20 20 28 69 66 20 28 65 71 3f 20 .... (if (eq?
5600: 73 69 67 6e 75 6d 20 73 69 67 6e 61 6c 2f 73 74 signum signal/st
5610: 6f 70 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 op).... (d
5620: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
5630: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
5640: 70 6f 72 74 2a 20 22 61 74 74 65 6d 70 74 20 74 port* "attempt t
5650: 6f 20 53 54 4f 50 20 70 72 6f 63 65 73 73 2e 20 o STOP process.
5660: 45 78 69 74 69 6e 67 2e 22 29 29 0a 09 09 09 20 Exiting."))....
5670: 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f (set! *time-to
5680: 2d 65 78 69 74 2a 20 23 74 29 0a 09 09 09 20 20 -exit* #t)....
5690: 20 28 70 72 69 6e 74 20 22 52 65 63 65 69 76 65 (print "Receive
56a0: 64 20 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 d signal " signu
56b0: 6d 20 22 2c 20 63 6c 65 61 6e 69 6e 67 20 75 70 m ", cleaning up
56c0: 20 62 65 66 6f 72 65 20 65 78 69 74 2e 20 50 6c before exit. Pl
56d0: 65 61 73 65 20 77 61 69 74 2e 2e 2e 22 29 0a 09 ease wait...")..
56e0: 09 09 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 .. (let ((th1
56f0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
5700: 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 20 20 mbda ().......
5710: 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 2d 66 (tests:test-f
5720: 6f 72 63 65 2d 73 74 61 74 65 2d 73 74 61 74 75 orce-state-statu
5730: 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 s! run-id test-i
5740: 64 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 d "INCOMPLETE" "
5750: 4b 49 4c 4c 45 44 22 29 0a 09 09 09 09 09 09 20 KILLED").......
5760: 20 20 20 20 28 70 72 69 6e 74 20 22 4b 69 6c 6c (print "Kill
5770: 65 64 20 62 79 20 73 69 67 6e 61 6c 20 22 20 73 ed by signal " s
5780: 69 67 6e 75 6d 20 22 2e 20 45 78 69 74 69 6e 67 ignum ". Exiting
5790: 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 74 ")....... (t
57a0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a hread-sleep! 1).
57b0: 09 09 09 09 09 09 20 20 20 20 20 28 65 78 69 74 ...... (exit
57c0: 20 31 29 29 29 29 0a 09 09 09 09 20 28 74 68 32 1))))..... (th2
57d0: 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c (make-thread (l
57e0: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 09 20 ambda ().......
57f0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 (thread-slee
5800: 70 21 20 32 29 0a 09 09 09 09 09 09 20 20 20 20 p! 2).......
5810: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
5820: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5830: 74 2a 20 22 44 6f 6e 65 22 29 0a 09 09 09 09 09 t* "Done")......
5840: 09 20 20 20 20 20 28 65 78 69 74 20 34 29 29 29 . (exit 4)))
5850: 29 29 0a 09 09 09 20 20 20 20 20 28 74 68 72 65 )).... (thre
5860: 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 09 ad-start! th2)..
5870: 09 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 .. (thread-s
5880: 74 61 72 74 21 20 74 68 31 29 0a 09 09 09 20 20 tart! th1)....
5890: 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 (thread-join!
58a0: 20 74 68 32 29 29 29 29 29 0a 09 20 20 20 20 28 th2))))).. (
58b0: 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c set-signal-handl
58c0: 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e 74 20 73 er! signal/int s
58d0: 69 67 68 61 6e 64 29 0a 09 20 20 20 20 28 73 65 ighand).. (se
58e0: 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 t-signal-handler
58f0: 21 20 73 69 67 6e 61 6c 2f 74 65 72 6d 20 73 69 ! signal/term si
5900: 67 68 61 6e 64 29 0a 09 20 20 20 20 29 20 3b 3b ghand).. ) ;;
5910: 20 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e (set-signal-han
5920: 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 73 74 6f dler! signal/sto
5930: 70 20 73 69 67 68 61 6e 64 29 0a 09 20 20 0a 09 p sighand).. ..
5940: 20 20 3b 3b 20 44 6f 20 6e 6f 74 20 72 75 6e 20 ;; Do not run
5950: 74 68 65 20 74 65 73 74 20 69 66 20 69 74 20 69 the test if it i
5960: 73 20 52 45 4d 4f 56 49 4e 47 2c 20 52 55 4e 4e s REMOVING, RUNN
5970: 49 4e 47 2c 20 4b 49 4c 4c 52 45 51 20 6f 72 20 ING, KILLREQ or
5980: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 2c REMOTEHOSTSTART,
5990: 0a 09 20 20 3b 3b 20 4d 61 72 6b 20 74 68 65 20 .. ;; Mark the
59a0: 74 65 73 74 20 61 73 20 52 45 4d 4f 54 45 48 4f test as REMOTEHO
59b0: 53 54 53 54 41 52 54 20 2a 49 4d 4d 45 44 49 41 STSTART *IMMEDIA
59c0: 54 45 4c 59 2a 0a 09 20 20 3b 3b 0a 09 20 20 28 TELY*.. ;;.. (
59d0: 6c 65 74 2a 20 28 28 74 65 73 74 2d 69 6e 66 6f let* ((test-info
59e0: 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 (rmt:get-test-i
59f0: 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 nfo-by-id run-id
5a00: 20 74 65 73 74 2d 69 64 29 29 0a 09 09 20 28 74 test-id))... (t
5a10: 65 73 74 2d 68 6f 73 74 20 28 64 62 3a 74 65 73 est-host (db:tes
5a20: 74 2d 67 65 74 2d 68 6f 73 74 20 20 20 20 20 20 t-get-host
5a30: 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a 09 09 test-info))...
5a40: 20 28 74 65 73 74 2d 70 69 64 20 20 28 64 62 3a (test-pid (db:
5a50: 74 65 73 74 2d 67 65 74 2d 70 72 6f 63 65 73 73 test-get-process
5a60: 5f 69 64 20 20 74 65 73 74 2d 69 6e 66 6f 29 29 _id test-info))
5a70: 29 0a 09 20 20 20 20 28 63 6f 6e 64 0a 09 20 20 ).. (cond..
5a80: 20 20 20 28 28 6d 65 6d 62 65 72 20 28 64 62 3a ((member (db:
5a90: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
5aa0: 65 73 74 2d 69 6e 66 6f 29 20 27 28 22 49 4e 43 est-info) '("INC
5ab0: 4f 4d 50 4c 45 54 45 22 20 22 4b 49 4c 4c 45 44 OMPLETE" "KILLED
5ac0: 22 20 22 55 4e 4b 4e 4f 57 4e 22 20 22 4b 49 4c " "UNKNOWN" "KIL
5ad0: 4c 52 45 51 22 20 22 53 54 55 43 4b 22 29 29 20 LREQ" "STUCK"))
5ae0: 3b 3b 20 70 72 69 6f 72 20 72 75 6e 20 6f 66 20 ;; prior run of
5af0: 74 68 69 73 20 74 65 73 74 20 64 69 64 6e 27 74 this test didn't
5b00: 20 63 6f 6d 70 6c 65 74 65 2c 20 67 6f 20 61 68 complete, go ah
5b10: 65 61 64 20 61 6e 64 20 74 72 79 20 74 6f 20 72 ead and try to r
5b20: 65 72 75 6e 0a 09 20 20 20 20 20 20 28 64 65 62 erun.. (deb
5b30: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
5b40: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
5b50: 4e 46 4f 3a 20 74 65 73 74 20 69 73 20 49 4e 43 NFO: test is INC
5b60: 4f 4d 50 4c 45 54 45 20 6f 72 20 4b 49 4c 4c 45 OMPLETE or KILLE
5b70: 44 2c 20 74 72 65 61 74 20 74 68 69 73 20 65 78 D, treat this ex
5b80: 65 63 75 74 65 20 63 61 6c 6c 20 61 73 20 61 20 ecute call as a
5b90: 72 65 72 75 6e 20 72 65 71 75 65 73 74 22 29 0a rerun request").
5ba0: 09 20 20 20 20 20 20 28 74 65 73 74 73 3a 74 65 . (tests:te
5bb0: 73 74 2d 66 6f 72 63 65 2d 73 74 61 74 65 2d 73 st-force-state-s
5bc0: 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 tatus! run-id te
5bd0: 73 74 2d 69 64 20 22 52 45 4d 4f 54 45 48 4f 53 st-id "REMOTEHOS
5be0: 54 53 54 41 52 54 22 20 22 6e 2f 61 22 29 29 20 TSTART" "n/a"))
5bf0: 3b 3b 20 70 72 69 6d 65 20 69 74 20 66 6f 72 20 ;; prime it for
5c00: 72 75 6e 6e 69 6e 67 0a 09 20 20 20 20 20 28 28 running.. ((
5c10: 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
5c20: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 2d 69 get-state test-i
5c30: 6e 66 6f 29 20 27 28 22 52 55 4e 4e 49 4e 47 22 nfo) '("RUNNING"
5c40: 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 "REMOTEHOSTSTAR
5c50: 54 22 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 T")).. (if
5c60: 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 2d 6f (process:alive-o
5c70: 6e 2d 68 6f 73 74 3f 20 74 65 73 74 2d 68 6f 73 n-host? test-hos
5c80: 74 20 74 65 73 74 2d 70 69 64 29 0a 09 09 20 20 t test-pid)...
5c90: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
5ca0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
5cb0: 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 73 74 g-port* "test st
5cc0: 61 74 65 20 69 73 20 22 20 20 28 64 62 3a 74 65 ate is " (db:te
5cd0: 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 st-get-state tes
5ce0: 74 2d 69 6e 66 6f 29 20 22 20 61 6e 64 20 70 72 t-info) " and pr
5cf0: 6f 63 65 73 73 20 22 20 74 65 73 74 2d 70 69 64 ocess " test-pid
5d00: 20 22 20 69 73 20 73 74 69 6c 6c 20 72 75 6e 6e " is still runn
5d10: 69 6e 67 20 6f 6e 20 68 6f 73 74 20 22 20 74 65 ing on host " te
5d20: 73 74 2d 68 6f 73 74 20 22 2c 20 63 61 6e 6e 6f st-host ", canno
5d30: 74 20 70 72 6f 63 65 65 64 22 29 0a 09 09 20 20 t proceed")...
5d40: 28 74 65 73 74 73 3a 74 65 73 74 2d 66 6f 72 63 (tests:test-forc
5d50: 65 2d 73 74 61 74 65 2d 73 74 61 74 75 73 21 20 e-state-status!
5d60: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 run-id test-id "
5d70: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 REMOTEHOSTSTART"
5d80: 20 22 6e 2f 61 22 29 29 29 0a 09 20 20 20 20 20 "n/a")))..
5d90: 28 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 ((not (member (d
5da0: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 b:test-get-state
5db0: 20 74 65 73 74 2d 69 6e 66 6f 29 20 27 28 22 52 test-info) '("R
5dc0: 45 4d 4f 56 49 4e 47 22 20 22 52 45 4d 4f 54 45 EMOVING" "REMOTE
5dd0: 48 4f 53 54 53 54 41 52 54 22 20 22 52 55 4e 4e HOSTSTART" "RUNN
5de0: 49 4e 47 22 20 22 4b 49 4c 4c 52 45 51 22 29 29 ING" "KILLREQ"))
5df0: 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 73 3a ).. (tests:
5e00: 74 65 73 74 2d 66 6f 72 63 65 2d 73 74 61 74 65 test-force-state
5e10: 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 20 -status! run-id
5e20: 74 65 73 74 2d 69 64 20 22 52 45 4d 4f 54 45 48 test-id "REMOTEH
5e30: 4f 53 54 53 54 41 52 54 22 20 22 6e 2f 61 22 29 OSTSTART" "n/a")
5e40: 29 0a 09 20 20 20 20 20 28 65 6c 73 65 20 3b 3b ).. (else ;;
5e50: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
5e60: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t-get-state test
5e70: 2d 69 6e 66 6f 29 20 27 28 22 52 45 4d 4f 56 49 -info) '("REMOVI
5e80: 4e 47 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 NG" "REMOTEHOSTS
5e90: 54 41 52 54 22 20 22 52 55 4e 4e 49 4e 47 22 20 TART" "RUNNING"
5ea0: 22 4b 49 4c 4c 52 45 51 22 29 29 0a 09 20 20 20 "KILLREQ"))..
5eb0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5ec0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
5ed0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
5ee0: 20 73 74 61 74 65 20 69 73 20 22 20 28 64 62 3a state is " (db:
5ef0: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
5f00: 65 73 74 2d 69 6e 66 6f 29 20 22 2c 20 63 61 6e est-info) ", can
5f10: 6e 6f 74 20 70 72 6f 63 65 65 64 22 29 0a 09 20 not proceed")..
5f20: 20 20 20 20 20 28 65 78 69 74 29 29 29 29 0a 09 (exit))))..
5f30: 20 20 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
5f40: 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 2 *default-lo
5f50: 67 2d 70 6f 72 74 2a 20 22 45 78 65 63 74 75 69 g-port* "Exectui
5f60: 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 ng " test-name "
5f70: 20 28 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 (id: " test-id
5f80: 22 29 20 6f 6e 20 22 20 28 67 65 74 2d 68 6f 73 ") on " (get-hos
5f90: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 28 73 65 74 t-name)).. (set
5fa0: 21 20 6b 65 79 73 20 20 20 20 20 20 20 28 72 6d ! keys (rm
5fb0: 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a 09 20 20 t:get-keys))..
5fc0: 3b 3b 20 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 ;; (runs:set-meg
5fd0: 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 atest-env-vars r
5fe0: 75 6e 2d 69 64 20 69 6e 6b 65 79 73 3a 20 6b 65 un-id inkeys: ke
5ff0: 79 73 20 69 6e 6b 65 79 76 61 6c 73 3a 20 6b 65 ys inkeyvals: ke
6000: 79 76 61 6c 73 29 20 3b 3b 20 74 68 65 73 65 20 yvals) ;; these
6010: 6d 61 79 20 62 65 20 6e 65 65 64 65 64 20 62 79 may be needed by
6020: 20 74 68 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 the launching p
6030: 72 6f 63 65 73 73 0a 09 20 20 3b 3b 20 6f 6e 65 rocess.. ;; one
6040: 20 6f 66 20 74 68 65 73 65 20 69 73 20 64 65 66 of these is def
6050: 75 6e 63 74 2f 72 65 64 75 6e 64 61 6e 74 20 2e unct/redundant .
6060: 2e 2e 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 28 .... (if (not (
6070: 6c 61 75 6e 63 68 3a 73 65 74 75 70 20 66 6f 72 launch:setup for
6080: 63 65 3a 20 23 74 29 29 0a 09 20 20 20 20 20 20 ce: #t))..
6090: 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 67 3a (begin...(debug:
60a0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
60b0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c -log-port* "Fail
60c0: 65 64 20 74 6f 20 73 65 74 75 70 2c 20 65 78 69 ed to setup, exi
60d0: 74 69 6e 67 22 29 20 0a 09 09 3b 3b 20 28 73 71 ting") ...;; (sq
60e0: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
60f0: 64 62 29 0a 09 09 3b 3b 20 28 73 71 6c 69 74 65 db)...;; (sqlite
6100: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 74 64 62 29 3:finalize! tdb)
6110: 0a 09 09 28 65 78 69 74 20 31 29 29 29 0a 09 20 ...(exit 1)))..
6120: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo
6130: 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 20 0a 0a ry *toppath*) ..
6140: 09 20 20 3b 3b 20 4e 4f 54 45 3a 20 43 75 72 72 . ;; NOTE: Curr
6150: 65 6e 74 20 6f 72 64 65 72 20 69 73 20 74 6f 20 ent order is to
6160: 70 72 6f 63 65 73 73 20 72 75 6e 63 6f 6e 66 69 process runconfi
6170: 67 73 20 2a 62 65 66 6f 72 65 2a 20 73 65 74 74 gs *before* sett
6180: 69 6e 67 20 74 68 65 20 4d 54 5f 20 76 61 72 73 ing the MT_ vars
6190: 2e 20 54 68 69 73 20 0a 09 20 20 3b 3b 20 20 20 . This .. ;;
61a0: 20 20 20 20 73 65 65 6d 73 20 6e 6f 6e 2d 69 64 seems non-id
61b0: 65 61 6c 20 62 75 74 20 63 6f 75 6c 64 20 77 65 eal but could we
61c0: 6c 6c 20 62 72 65 61 6b 20 73 74 75 66 66 0a 09 ll break stuff..
61d0: 20 20 3b 3b 20 20 20 20 42 55 47 3f 20 42 55 47 ;; BUG? BUG
61e0: 3f 20 42 55 47 3f 0a 09 20 20 0a 09 20 20 28 6c ? BUG?.. .. (l
61f0: 65 74 20 28 28 72 63 6f 6e 66 69 67 20 28 66 75 et ((rconfig (fu
6200: 6c 6c 2d 72 75 6e 63 6f 6e 66 69 67 73 2d 72 65 ll-runconfigs-re
6210: 61 64 29 29 29 20 3b 3b 20 28 72 65 61 64 2d 63 ad))) ;; (read-c
6220: 6f 6e 66 69 67 20 28 63 6f 6e 63 20 20 2a 74 6f onfig (conc *to
6230: 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 ppath* "/runconf
6240: 69 67 73 2e 63 6f 6e 66 69 67 22 29 20 23 66 20 igs.config") #f
6250: 23 74 20 73 65 63 74 69 6f 6e 73 3a 20 28 6c 69 #t sections: (li
6260: 73 74 20 22 64 65 66 61 75 6c 74 22 20 74 61 72 st "default" tar
6270: 67 65 74 29 29 29 29 0a 09 20 20 20 20 3b 3b 20 get)))).. ;;
6280: 28 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 (setup-env-defau
6290: 6c 74 73 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 lts (conc *toppa
62a0: 74 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 th* "/runconfigs
62b0: 2e 63 6f 6e 66 69 67 22 29 20 72 75 6e 2d 69 64 .config") run-id
62c0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
62d0: 65 29 20 6b 65 79 76 61 6c 73 20 74 61 72 67 65 e) keyvals targe
62e0: 74 29 0a 09 20 20 20 20 3b 3b 20 28 73 65 74 2d t).. ;; (set-
62f0: 72 75 6e 2d 63 6f 6e 66 69 67 2d 76 61 72 73 20 run-config-vars
6300: 72 75 6e 2d 69 64 20 6b 65 79 76 61 6c 73 20 74 run-id keyvals t
6310: 61 72 67 65 74 29 20 3b 3b 20 28 64 62 3a 67 65 arget) ;; (db:ge
6320: 74 2d 74 61 72 67 65 74 20 64 62 20 72 75 6e 2d t-target db run-
6330: 69 64 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 id)).. ;; Now
6340: 20 68 61 76 65 20 72 75 6e 63 6f 6e 66 69 67 73 have runconfigs
6350: 20 64 61 74 61 20 6c 6f 61 64 65 64 2c 20 73 65 data loaded, se
6360: 74 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 t environment va
6370: 72 73 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 rs.. (for-eac
6380: 68 20 28 6c 61 6d 62 64 61 20 28 73 65 63 74 69 h (lambda (secti
6390: 6f 6e 29 0a 09 09 09 28 66 6f 72 2d 65 61 63 68 on)....(for-each
63a0: 20 28 6c 61 6d 62 64 61 20 28 76 61 72 76 61 6c (lambda (varval
63b0: 29 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 )..... (let (
63c0: 28 76 61 72 20 28 63 61 72 20 76 61 72 76 61 6c (var (car varval
63d0: 29 29 0a 09 09 09 09 09 20 20 28 76 61 6c 20 28 ))...... (val (
63e0: 63 61 64 72 20 76 61 72 76 61 6c 29 29 29 0a 09 cadr varval)))..
63f0: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 61 6e ... (if (an
6400: 64 20 28 73 74 72 69 6e 67 3f 20 76 61 72 29 28 d (string? var)(
6410: 73 74 72 69 6e 67 3f 20 76 61 6c 29 29 0a 09 09 string? val))...
6420: 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 09 ... (begin.....
6430: 09 20 20 20 20 28 73 65 74 65 6e 76 20 76 61 72 . (setenv var
6440: 20 28 63 6f 6e 66 69 67 3a 65 76 61 6c 2d 73 74 (config:eval-st
6450: 72 69 6e 67 2d 69 6e 2d 65 6e 76 69 72 6f 6e 6d ring-in-environm
6460: 65 6e 74 20 76 61 6c 29 29 29 20 3b 3b 20 76 61 ent val))) ;; va
6470: 6c 29 0a 09 09 09 09 09 20 20 28 64 65 62 75 67 l)...... (debug
6480: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
6490: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
64a0: 2a 20 22 62 61 64 20 76 61 72 69 61 62 6c 65 20 * "bad variable
64b0: 73 70 65 63 2c 20 22 20 76 61 72 20 22 3d 22 20 spec, " var "="
64c0: 76 61 6c 29 29 29 29 0a 09 09 09 09 20 20 28 63 val))))..... (c
64d0: 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 onfigf:get-secti
64e0: 6f 6e 20 72 63 6f 6e 66 69 67 20 73 65 63 74 69 on rconfig secti
64f0: 6f 6e 29 29 29 0a 09 09 20 20 20 20 20 20 28 6c on)))... (l
6500: 69 73 74 20 22 64 65 66 61 75 6c 74 22 20 74 61 ist "default" ta
6510: 72 67 65 74 29 29 29 0a 0a 09 20 20 3b 3b 20 4e rget)))... ;; N
6520: 46 53 20 6d 69 67 68 74 20 6e 6f 74 20 68 61 76 FS might not hav
6530: 65 20 70 72 6f 70 61 67 61 74 65 64 20 74 68 65 e propagated the
6540: 20 64 69 72 65 63 74 6f 72 79 20 6d 65 74 61 20 directory meta
6550: 64 61 74 61 20 74 6f 20 74 68 65 20 72 75 6e 20 data to the run
6560: 68 6f 73 74 20 2d 20 67 69 76 65 20 69 74 20 74 host - give it t
6570: 69 6d 65 20 69 66 20 6e 65 65 64 65 64 0a 09 20 ime if needed..
6580: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 6f 75 (let loop ((cou
6590: 6e 74 20 30 29 29 0a 09 20 20 20 20 28 69 66 20 nt 0)).. (if
65a0: 28 6f 72 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (or (file-exists
65b0: 3f 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 09 20 ? work-area)...
65c0: 20 20 20 28 3e 20 63 6f 75 6e 74 20 31 30 29 29 (> count 10))
65d0: 0a 09 09 28 63 68 61 6e 67 65 2d 64 69 72 65 63 ...(change-direc
65e0: 74 6f 72 79 20 77 6f 72 6b 2d 61 72 65 61 29 0a tory work-area).
65f0: 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 ..(begin... (de
6600: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
6610: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6620: 49 4e 46 4f 3a 20 4e 6f 74 20 73 74 61 72 74 69 INFO: Not starti
6630: 6e 67 20 6a 6f 62 20 79 65 74 20 2d 20 64 69 72 ng job yet - dir
6640: 65 63 74 6f 72 79 20 22 20 77 6f 72 6b 2d 61 72 ectory " work-ar
6650: 65 61 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 ea " not found")
6660: 0a 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
6670: 65 70 21 20 31 30 29 0a 09 09 20 20 28 6c 6f 6f ep! 10)... (loo
6680: 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 29 p (+ count 1))))
6690: 29 0a 0a 09 20 20 3b 3b 20 28 63 68 61 6e 67 65 )... ;; (change
66a0: 2d 64 69 72 65 63 74 6f 72 79 20 77 6f 72 6b 2d -directory work-
66b0: 61 72 65 61 29 20 0a 09 20 20 28 73 65 74 21 20 area) .. (set!
66c0: 6b 65 79 76 61 6c 73 20 20 20 20 28 6b 65 79 73 keyvals (keys
66d0: 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 6c 20 :target->keyval
66e0: 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a 09 20 keys target))..
66f0: 20 3b 3b 20 61 70 70 6c 79 20 70 72 65 2d 6f 76 ;; apply pre-ov
6700: 65 72 72 69 64 65 73 20 62 65 66 6f 72 65 20 6f errides before o
6710: 74 68 65 72 20 76 61 72 69 61 62 6c 65 73 2e 20 ther variables.
6720: 54 68 65 20 70 72 65 2d 6f 76 65 72 72 69 64 65 The pre-override
6730: 20 76 61 72 73 20 6d 75 73 74 20 6e 6f 74 0a 09 vars must not..
6740: 20 20 3b 3b 20 63 6c 6f 62 62 65 72 73 20 74 68 ;; clobbers th
6750: 69 6e 67 73 20 66 72 6f 6d 20 74 68 65 20 6f 66 ings from the of
6760: 66 69 63 69 61 6c 20 73 6f 75 72 63 65 73 20 73 ficial sources s
6770: 75 63 68 20 61 73 20 6d 65 67 61 74 65 73 74 2e uch as megatest.
6780: 63 6f 6e 66 69 67 20 61 6e 64 20 72 75 6e 63 6f config and runco
6790: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 0a 09 20 20 nfigs.config..
67a0: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 73 65 74 (if (string? set
67b0: 2d 76 61 72 73 29 0a 09 20 20 20 20 20 20 28 6c -vars).. (l
67c0: 65 74 20 28 28 76 61 72 70 61 69 72 73 20 28 73 et ((varpairs (s
67d0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 65 74 2d tring-split set-
67e0: 76 61 72 73 20 22 2c 22 29 29 29 0a 09 09 28 64 vars ",")))...(d
67f0: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 ebug:print 4 *de
6800: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
6810: 22 76 61 72 70 61 69 72 73 3a 20 22 20 76 61 72 "varpairs: " var
6820: 70 61 69 72 73 29 0a 09 09 28 6d 61 70 20 28 6c pairs)...(map (l
6830: 61 6d 62 64 61 20 28 76 61 72 70 61 69 72 29 0a ambda (varpair).
6840: 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
6850: 76 61 72 76 61 6c 20 28 73 74 72 69 6e 67 2d 73 varval (string-s
6860: 70 6c 69 74 20 76 61 72 70 61 69 72 20 22 3d 22 plit varpair "="
6870: 29 29 29 0a 09 09 09 20 28 69 66 20 28 65 71 3f ))).... (if (eq?
6880: 20 28 6c 65 6e 67 74 68 20 76 61 72 76 61 6c 29 (length varval)
6890: 20 32 29 0a 09 09 09 20 20 20 20 20 28 6c 65 74 2).... (let
68a0: 20 28 28 76 61 72 20 28 63 61 72 20 76 61 72 76 ((var (car varv
68b0: 61 6c 29 29 0a 09 09 09 09 20 20 20 28 76 61 6c al))..... (val
68c0: 20 28 63 61 64 72 20 76 61 72 76 61 6c 29 29 29 (cadr varval)))
68d0: 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 .... (debu
68e0: 67 3a 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 g:print 1 *defau
68f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 64 lt-log-port* "Ad
6900: 64 69 6e 67 20 70 72 65 2d 76 61 72 2f 76 61 6c ding pre-var/val
6910: 20 22 20 76 61 72 20 22 20 3d 20 22 20 76 61 6c " var " = " val
6920: 20 22 20 74 6f 20 74 68 65 20 65 6e 76 69 72 6f " to the enviro
6930: 6e 6d 65 6e 74 22 29 0a 09 09 09 20 20 20 20 20 nment")....
6940: 20 20 28 73 65 74 65 6e 76 20 76 61 72 20 76 61 (setenv var va
6950: 6c 29 29 29 29 29 0a 09 09 20 20 20 20 20 76 61 l)))))... va
6960: 72 70 61 69 72 73 29 29 29 0a 09 20 20 28 66 6f rpairs))).. (fo
6970: 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d 62 r-each.. (lamb
6980: 64 61 20 28 76 61 72 76 61 6c 29 0a 09 20 20 20 da (varval)..
6990: 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 61 (let ((var (ca
69a0: 72 20 76 61 72 76 61 6c 29 29 0a 09 09 20 20 20 r varval))...
69b0: 28 76 61 6c 20 28 63 61 64 72 20 76 61 72 76 61 (val (cadr varva
69c0: 6c 29 29 29 0a 09 20 20 20 20 20 20 20 28 69 66 l))).. (if
69d0: 20 76 61 6c 0a 09 09 20 20 20 28 73 65 74 65 6e val... (seten
69e0: 76 20 76 61 72 20 76 61 6c 29 0a 09 09 20 20 20 v var val)...
69f0: 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 64 (begin... (d
6a00: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
6a10: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6a20: 70 6f 72 74 2a 20 22 72 65 71 75 69 72 65 64 20 port* "required
6a30: 76 61 72 69 61 62 6c 65 20 22 20 76 61 72 20 22 variable " var "
6a40: 20 64 6f 65 73 20 6e 6f 74 20 68 61 76 65 20 61 does not have a
6a50: 20 76 61 6c 69 64 20 76 61 6c 75 65 2e 20 45 78 valid value. Ex
6a60: 69 74 69 6e 67 22 29 0a 09 09 20 20 20 20 20 28 iting")... (
6a70: 65 78 69 74 29 29 29 29 29 0a 09 20 20 20 20 20 exit)))))..
6a80: 28 6c 69 73 74 20 0a 09 20 20 20 20 20 20 28 6c (list .. (l
6a90: 69 73 74 20 20 22 4d 54 5f 54 45 53 54 5f 52 55 ist "MT_TEST_RU
6aa0: 4e 5f 44 49 52 22 20 77 6f 72 6b 2d 61 72 65 61 N_DIR" work-area
6ab0: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 20 ).. (list
6ac0: 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 "MT_TEST_NAME" t
6ad0: 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 20 20 20 est-name)..
6ae0: 20 28 6c 69 73 74 20 20 22 4d 54 5f 49 54 45 4d (list "MT_ITEM
6af0: 5f 49 4e 46 4f 22 20 28 63 6f 6e 63 20 69 74 65 _INFO" (conc ite
6b00: 6d 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 6c mdat)).. (l
6b10: 69 73 74 20 20 22 4d 54 5f 49 54 45 4d 50 41 54 ist "MT_ITEMPAT
6b20: 48 22 20 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 H" item-path)..
6b30: 20 20 20 20 20 20 28 6c 69 73 74 20 20 22 4d 54 (list "MT
6b40: 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e _RUNNAME" runn
6b50: 61 6d 65 29 0a 09 20 20 20 20 20 20 28 6c 69 73 ame).. (lis
6b60: 74 20 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 t "MT_MEGATEST"
6b70: 20 20 6d 65 67 61 74 65 73 74 29 0a 09 20 20 20 megatest)..
6b80: 20 20 20 28 6c 69 73 74 20 20 22 4d 54 5f 54 41 (list "MT_TA
6b90: 52 47 45 54 22 20 20 20 20 74 61 72 67 65 74 29 RGET" target)
6ba0: 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 20 22 .. (list "
6bb0: 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 20 20 28 63 MT_LINKTREE" (c
6bc0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
6bd0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
6be0: 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 0a 09 " "linktree"))..
6bf0: 20 20 20 20 20 20 28 6c 69 73 74 20 20 22 4d 54 (list "MT
6c00: 5f 54 45 53 54 53 55 49 54 45 5f 4e 41 4d 45 22 _TESTSUITE_NAME"
6c10: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 (common:get-tes
6c20: 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 29 29 0a tsuite-name)))).
6c30: 0a 09 20 20 28 69 66 20 6d 74 2d 62 69 6e 64 69 .. (if mt-bindi
6c40: 72 2d 70 61 74 68 20 28 73 65 74 65 6e 76 20 22 r-path (setenv "
6c50: 50 41 54 48 22 20 28 63 6f 6e 63 20 28 67 65 74 PATH" (conc (get
6c60: 65 6e 76 20 22 50 41 54 48 22 29 20 22 3a 22 20 env "PATH") ":"
6c70: 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 29 29 mt-bindir-path))
6c80: 29 0a 09 20 20 3b 3b 20 28 63 68 61 6e 67 65 2d ).. ;; (change-
6c90: 64 69 72 65 63 74 6f 72 79 20 74 6f 70 2d 70 61 directory top-pa
6ca0: 74 68 29 0a 09 20 20 3b 3b 20 43 61 6e 20 73 65 th).. ;; Can se
6cb0: 74 75 70 20 61 73 20 63 6c 69 65 6e 74 20 66 6f tup as client fo
6cc0: 72 20 73 65 72 76 65 72 20 6d 6f 64 65 20 6e 6f r server mode no
6cd0: 77 0a 09 20 20 3b 3b 20 28 63 6c 69 65 6e 74 3a w.. ;; (client:
6ce0: 73 65 74 75 70 29 0a 0a 09 20 20 0a 09 20 20 3b setup)... .. ;
6cf0: 3b 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 6f 76 ; environment ov
6d00: 65 72 72 69 64 65 73 20 61 72 65 20 64 6f 6e 65 errides are done
6d10: 20 2a 62 65 66 6f 72 65 2a 20 74 68 65 20 72 65 *before* the re
6d20: 6d 61 69 6e 69 6e 67 20 63 72 69 74 69 63 61 6c maining critical
6d30: 20 65 6e 76 61 72 73 2e 0a 09 20 20 28 61 6c 69 envars... (ali
6d40: 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 65 6e 76 st->env-vars env
6d50: 2d 6f 76 72 64 29 0a 09 20 20 28 72 75 6e 73 3a -ovrd).. (runs:
6d60: 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 6e 76 set-megatest-env
6d70: 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 69 6e 6b -vars run-id ink
6d80: 65 79 73 3a 20 6b 65 79 73 20 69 6e 6b 65 79 76 eys: keys inkeyv
6d90: 61 6c 73 3a 20 6b 65 79 76 61 6c 73 29 0a 09 20 als: keyvals)..
6da0: 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 (set-item-env-v
6db0: 61 72 73 20 69 74 65 6d 64 61 74 29 0a 09 20 20 ars itemdat)..
6dc0: 28 73 61 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e (save-environmen
6dd0: 74 2d 61 73 2d 66 69 6c 65 73 20 22 6d 65 67 61 t-as-files "mega
6de0: 74 65 73 74 22 29 0a 09 20 20 3b 3b 20 6f 70 65 test").. ;; ope
6df0: 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 6e 6f 74 20 n-run-close not
6e00: 6e 65 65 64 65 64 20 66 6f 72 20 74 65 73 74 2d needed for test-
6e10: 73 65 74 2d 6d 65 74 61 2d 69 6e 66 6f 0a 09 20 set-meta-info..
6e20: 20 3b 3b 20 28 74 65 73 74 73 3a 73 65 74 2d 66 ;; (tests:set-f
6e30: 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 23 66 ull-meta-info #f
6e40: 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 20 test-id run-id
6e50: 30 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 20 20 0 work-area)..
6e60: 3b 3b 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 ;; (tests:set-fu
6e70: 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 ll-meta-info tes
6e80: 74 2d 69 64 20 72 75 6e 2d 69 64 20 30 20 77 6f t-id run-id 0 wo
6e90: 72 6b 2d 61 72 65 61 29 0a 09 20 20 28 74 65 73 rk-area).. (tes
6ea0: 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 ts:set-full-meta
6eb0: 2d 69 6e 66 6f 20 23 66 20 74 65 73 74 2d 69 64 -info #f test-id
6ec0: 20 72 75 6e 2d 69 64 20 30 20 77 6f 72 6b 2d 61 run-id 0 work-a
6ed0: 72 65 61 20 31 30 29 0a 0a 09 20 20 3b 3b 20 28 rea 10)... ;; (
6ee0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
6ef0: 33 29 20 3b 3b 20 4e 46 53 20 73 6c 6f 77 6e 65 3) ;; NFS slowne
6f00: 73 73 20 68 61 73 20 63 61 75 73 65 64 20 67 72 ss has caused gr
6f10: 69 65 66 20 68 65 72 65 0a 0a 09 20 20 28 69 66 ief here... (if
6f20: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
6f30: 2d 78 74 65 72 6d 22 29 0a 09 20 20 20 20 20 20 -xterm")..
6f40: 28 73 65 74 21 20 66 75 6c 6c 72 75 6e 73 63 72 (set! fullrunscr
6f50: 69 70 74 20 22 78 74 65 72 6d 22 29 0a 09 20 20 ipt "xterm")..
6f60: 20 20 20 20 28 69 66 20 28 61 6e 64 20 66 75 6c (if (and ful
6f70: 6c 72 75 6e 73 63 72 69 70 74 20 0a 09 09 20 20 lrunscript ...
6f80: 20 20 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 (file-exist
6f90: 73 3f 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 s? fullrunscript
6fa0: 29 0a 09 09 20 20 20 20 20 20 20 28 6e 6f 74 20 )... (not
6fb0: 28 66 69 6c 65 2d 65 78 65 63 75 74 65 2d 61 63 (file-execute-ac
6fc0: 63 65 73 73 3f 20 66 75 6c 6c 72 75 6e 73 63 72 cess? fullrunscr
6fd0: 69 70 74 29 29 29 0a 09 09 20 20 28 73 79 73 74 ipt)))... (syst
6fe0: 65 6d 20 28 63 6f 6e 63 20 22 63 68 6d 6f 64 20 em (conc "chmod
6ff0: 75 67 2b 78 20 22 20 66 75 6c 6c 72 75 6e 73 63 ug+x " fullrunsc
7000: 72 69 70 74 29 29 29 29 0a 0a 09 20 20 3b 3b 20 ript))))... ;;
7010: 57 65 20 61 72 65 20 61 62 6f 75 74 20 74 6f 20 We are about to
7020: 61 63 74 75 61 6c 6c 79 20 6b 69 63 6b 20 6f 66 actually kick of
7030: 66 20 74 68 65 20 74 65 73 74 0a 09 20 20 3b 3b f the test.. ;;
7040: 20 73 6f 20 74 68 69 73 20 69 73 20 61 20 67 6f so this is a go
7050: 6f 64 20 70 6c 61 63 65 20 74 6f 20 72 65 6d 6f od place to remo
7060: 76 65 20 74 68 65 20 72 65 63 6f 72 64 73 20 66 ve the records f
7070: 6f 72 20 0a 09 20 20 3b 3b 20 61 6e 79 20 70 72 or .. ;; any pr
7080: 65 76 69 6f 75 73 20 72 75 6e 73 0a 09 20 20 3b evious runs.. ;
7090: 3b 20 28 64 62 3a 74 65 73 74 2d 72 65 6d 6f 76 ; (db:test-remov
70a0: 65 2d 73 74 65 70 73 20 64 62 20 72 75 6e 2d 69 e-steps db run-i
70b0: 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 64 d testname itemd
70c0: 61 74 29 0a 09 20 20 3b 3b 20 0a 09 20 20 28 6c at).. ;; .. (l
70d0: 65 74 2a 20 28 28 6d 20 20 20 20 20 20 20 20 20 et* ((m
70e0: 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 (make-mutex))
70f0: 0a 09 09 20 28 6b 69 6c 6c 2d 6a 6f 62 3f 20 20 ... (kill-job?
7100: 20 20 23 66 29 0a 09 09 20 28 65 78 69 74 2d 69 #f)... (exit-i
7110: 6e 66 6f 20 20 20 20 28 6d 61 6b 65 2d 6c 61 75 nfo (make-lau
7120: 6e 63 68 3a 65 69 6e 66 20 70 69 64 3a 20 23 74 nch:einf pid: #t
7130: 20 65 78 69 74 2d 73 74 61 74 75 73 3a 20 23 74 exit-status: #t
7140: 20 65 78 69 74 2d 63 6f 64 65 3a 20 23 74 20 72 exit-code: #t r
7150: 6f 6c 6c 75 70 2d 73 74 61 74 75 73 3a 20 30 29 ollup-status: 0)
7160: 29 20 3b 3b 20 70 69 64 20 65 78 69 74 2d 73 74 ) ;; pid exit-st
7170: 61 74 75 73 20 65 78 69 74 2d 63 6f 64 65 20 28 atus exit-code (
7180: 69 2e 65 2e 20 70 72 6f 63 65 73 73 20 77 61 73 i.e. process was
7190: 20 73 75 63 63 65 73 73 66 75 6c 6c 79 20 72 75 successfully ru
71a0: 6e 29 20 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 n) rollup-status
71b0: 0a 09 09 20 28 6a 6f 62 2d 74 68 72 65 61 64 20 ... (job-thread
71c0: 20 20 23 66 29 0a 09 09 20 3b 3b 20 28 6b 65 65 #f)... ;; (kee
71d0: 70 2d 67 6f 69 6e 67 20 20 20 23 74 29 0a 09 09 p-going #t)...
71e0: 20 28 6d 69 73 63 2d 66 6c 61 67 73 20 20 20 28 (misc-flags (
71f0: 6c 65 74 20 28 28 68 74 20 28 6d 61 6b 65 2d 68 let ((ht (make-h
7200: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 09 09 09 ash-table)))....
7210: 09 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 . (hash-table-se
7220: 74 21 20 68 74 20 27 6b 65 65 70 2d 67 6f 69 6e t! ht 'keep-goin
7230: 67 20 23 74 29 0a 09 09 09 09 20 68 74 29 29 0a g #t)..... ht)).
7240: 09 09 20 28 72 75 6e 69 74 20 20 20 20 20 20 20 .. (runit
7250: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 (lambda ().....
7260: 20 28 6c 61 75 6e 63 68 3a 6d 61 6e 61 67 65 2d (launch:manage-
7270: 73 74 65 70 73 20 72 75 6e 2d 69 64 20 74 65 73 steps run-id tes
7280: 74 2d 69 64 20 69 74 65 6d 2d 70 61 74 68 20 66 t-id item-path f
7290: 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 65 7a 73 ullrunscript ezs
72a0: 74 65 70 73 20 74 65 73 74 2d 6e 61 6d 65 20 74 teps test-name t
72b0: 63 6f 6e 66 69 67 72 65 67 20 65 78 69 74 2d 69 configreg exit-i
72c0: 6e 66 6f 20 6d 29 29 29 0a 09 09 20 28 6d 6f 6e nfo m)))... (mon
72d0: 69 74 6f 72 6a 6f 62 20 20 20 28 6c 61 6d 62 64 itorjob (lambd
72e0: 61 20 28 29 0a 09 09 09 09 20 28 6c 61 75 6e 63 a ()..... (launc
72f0: 68 3a 6d 6f 6e 69 74 6f 72 2d 6a 6f 62 20 20 72 h:monitor-job r
7300: 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 69 74 un-id test-id it
7310: 65 6d 2d 70 61 74 68 20 66 75 6c 6c 72 75 6e 73 em-path fullruns
7320: 63 72 69 70 74 20 65 7a 73 74 65 70 73 20 74 65 cript ezsteps te
7330: 73 74 2d 6e 61 6d 65 20 74 63 6f 6e 66 69 67 72 st-name tconfigr
7340: 65 67 20 65 78 69 74 2d 69 6e 66 6f 20 6d 20 77 eg exit-info m w
7350: 6f 72 6b 2d 61 72 65 61 20 72 75 6e 74 6c 69 6d ork-area runtlim
7360: 20 6d 69 73 63 2d 66 6c 61 67 73 29 29 29 0a 09 misc-flags)))..
7370: 09 20 28 74 68 31 20 20 20 20 20 20 20 20 20 20 . (th1
7380: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 6d 6f 6e (make-thread mon
7390: 69 74 6f 72 6a 6f 62 20 22 6d 6f 6e 69 74 6f 72 itorjob "monitor
73a0: 20 6a 6f 62 22 29 29 0a 09 09 20 28 74 68 32 20 job"))... (th2
73b0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 (make-t
73c0: 68 72 65 61 64 20 72 75 6e 69 74 20 22 72 75 6e hread runit "run
73d0: 20 6a 6f 62 22 29 29 29 0a 09 20 20 20 20 28 73 job"))).. (s
73e0: 65 74 21 20 6a 6f 62 2d 74 68 72 65 61 64 20 74 et! job-thread t
73f0: 68 32 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 h2).. (thread
7400: 2d 73 74 61 72 74 21 20 74 68 31 29 0a 09 20 20 -start! th1)..
7410: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
7420: 20 74 68 32 29 0a 09 20 20 20 20 28 74 68 72 65 th2).. (thre
7430: 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 0a 09 20 ad-join! th2)..
7440: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
7450: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
7460: 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 65 67 61 74 log-port* "Megat
7470: 65 73 74 20 65 78 65 63 74 75 74 65 20 6f 66 20 est exectute of
7480: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
7490: 20 22 2c 20 69 74 65 6d 20 70 61 74 68 20 22 20 ", item path "
74a0: 69 74 65 6d 2d 70 61 74 68 20 22 20 63 6f 6d 70 item-path " comp
74b0: 6c 65 74 65 2e 20 4e 6f 74 69 66 79 69 6e 67 20 lete. Notifying
74c0: 74 68 65 20 64 62 20 2e 2e 2e 22 29 0a 09 20 20 the db ...")..
74d0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
74e0: 74 21 20 6d 69 73 63 2d 66 6c 61 67 73 20 27 6b t! misc-flags 'k
74f0: 65 65 70 2d 67 6f 69 6e 67 20 23 66 29 0a 09 20 eep-going #f)..
7500: 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 (thread-join!
7510: 20 74 68 31 29 0a 09 20 20 20 20 28 74 68 72 65 th1).. (thre
7520: 61 64 2d 73 6c 65 65 70 21 20 31 29 20 20 20 20 ad-sleep! 1)
7530: 20 20 20 3b 3b 20 67 69 76 62 65 20 74 68 72 65 ;; givbe thre
7540: 61 64 20 74 68 31 20 61 20 63 68 61 6e 63 65 20 ad th1 a chance
7550: 74 6f 20 62 65 20 64 6f 6e 65 20 54 4f 44 4f 3a to be done TODO:
7560: 20 56 65 72 69 66 79 20 74 68 69 73 20 69 73 20 Verify this is
7570: 6e 65 65 64 65 64 2e 20 41 74 20 30 2e 31 20 49 needed. At 0.1 I
7580: 20 77 61 73 20 67 65 74 74 69 6e 67 20 66 61 69 was getting fai
7590: 6c 20 74 6f 20 73 74 6f 70 2c 20 69 6e 63 72 65 l to stop, incre
75a0: 61 73 65 64 20 74 6f 20 74 6f 74 61 6c 20 6f 66 ased to total of
75b0: 20 31 2e 31 20 73 65 63 2e 0a 09 20 20 20 20 28 1.1 sec... (
75c0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d 29 0a 09 mutex-lock! m)..
75d0: 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 65 6d (let* ((item
75e0: 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 74 -path (item-list
75f0: 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 ->path itemdat))
7600: 0a 09 09 20 20 20 3b 3b 20 6f 6e 6c 79 20 73 74 ... ;; only st
7610: 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 20 6e ate and status n
7620: 65 65 64 65 64 20 2d 20 75 73 65 20 6c 61 7a 79 eeded - use lazy
7630: 20 72 6f 75 74 69 6e 65 0a 09 09 20 20 20 28 74 routine... (t
7640: 65 73 74 69 6e 66 6f 20 20 28 72 6d 74 3a 67 65 estinfo (rmt:ge
7650: 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 74 65 t-testinfo-state
7660: 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 20 74 -status run-id t
7670: 65 73 74 2d 69 64 29 29 29 0a 09 20 20 20 20 20 est-id)))..
7680: 20 3b 3b 20 41 6d 20 49 20 63 6f 6d 70 6c 65 74 ;; Am I complet
7690: 65 64 3f 0a 09 20 20 20 20 20 20 28 69 66 20 28 ed?.. (if (
76a0: 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d member (db:test-
76b0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 69 6e get-state testin
76c0: 66 6f 29 20 27 28 22 52 45 4d 4f 54 45 48 4f 53 fo) '("REMOTEHOS
76d0: 54 53 54 41 52 54 22 20 22 52 55 4e 4e 49 4e 47 TSTART" "RUNNING
76e0: 22 29 29 20 3b 3b 20 4e 4f 54 45 3a 20 49 74 20 ")) ;; NOTE: It
76f0: 73 68 6f 75 6c 64 20 2a 6e 6f 74 2a 20 62 65 20 should *not* be
7700: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 20 REMOTEHOSTSTART
7710: 62 75 74 20 66 6f 72 20 72 65 61 73 6f 6e 73 20 but for reasons
7720: 49 20 64 6f 6e 27 74 20 79 65 74 20 75 6e 64 65 I don't yet unde
7730: 72 73 74 61 6e 64 20 69 74 20 73 6f 6d 65 74 69 rstand it someti
7740: 6d 65 73 20 67 65 74 73 20 73 74 75 63 6b 20 69 mes gets stuck i
7750: 6e 20 74 68 61 74 20 73 74 61 74 65 20 3b 3b 20 n that state ;;
7760: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 64 62 (not (equal? (db
7770: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
7780: 74 65 73 74 69 6e 66 6f 29 20 22 43 4f 4d 50 4c testinfo) "COMPL
7790: 45 54 45 44 22 29 29 0a 09 09 20 20 28 6c 65 74 ETED"))... (let
77a0: 20 28 28 6e 65 77 2d 73 74 61 74 65 20 20 28 69 ((new-state (i
77b0: 66 20 6b 69 6c 6c 2d 6a 6f 62 3f 20 22 4b 49 4c f kill-job? "KIL
77c0: 4c 45 44 22 20 22 43 4f 4d 50 4c 45 54 45 44 22 LED" "COMPLETED"
77d0: 29 20 3b 3b 20 28 69 66 20 28 65 71 3f 20 28 76 ) ;; (if (eq? (v
77e0: 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 ector-ref exit-i
77f0: 6e 66 6f 20 32 29 20 30 29 20 3b 3b 20 65 78 69 nfo 2) 0) ;; exi
7800: 74 65 64 20 77 69 74 68 20 22 67 6f 6f 64 22 20 ted with "good"
7810: 73 74 61 74 75 73 0a 09 09 09 09 20 20 20 20 20 status.....
7820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7840: 20 20 20 3b 3b 20 22 43 4f 4d 50 4c 45 54 45 44 ;; "COMPLETED
7850: 22 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 20 "........
7860: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 64 62 3a ;; (db:
7870: 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 test-get-state t
7880: 65 73 74 69 6e 66 6f 29 29 29 20 20 20 3b 3b 20 estinfo))) ;;
7890: 65 6c 73 65 20 70 72 65 73 65 76 65 20 74 68 65 else preseve the
78a0: 20 73 74 61 74 65 20 61 73 20 73 65 74 20 77 69 state as set wi
78b0: 74 68 69 6e 20 74 68 65 20 74 65 73 74 0a 09 09 thin the test...
78c0: 09 09 20 20 20 20 29 0a 09 09 09 28 6e 65 77 2d .. )....(new-
78d0: 73 74 61 74 75 73 20 28 63 6f 6e 64 0a 09 09 09 status (cond....
78e0: 09 20 20 20 20 20 28 28 6e 6f 74 20 28 6c 61 75 . ((not (lau
78f0: 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 73 74 nch:einf-exit-st
7900: 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 29 atus exit-info))
7910: 20 22 46 41 49 4c 22 29 20 3b 3b 20 6a 6f 62 20 "FAIL") ;; job
7920: 66 61 69 6c 65 64 20 74 6f 20 72 75 6e 20 2e 2e failed to run ..
7930: 2e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 . (vector-ref ex
7940: 69 74 2d 69 6e 66 6f 20 31 29 0a 09 09 09 09 20 it-info 1).....
7950: 20 20 20 20 28 28 65 71 3f 20 28 6c 61 75 6e 63 ((eq? (launc
7960: 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 h:einf-rollup-st
7970: 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 20 atus exit-info)
7980: 30 29 20 20 20 20 20 3b 3b 20 28 76 65 63 74 6f 0) ;; (vecto
7990: 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 r-ref exit-info
79a0: 33 29 0a 09 09 09 09 20 20 20 20 20 20 3b 3b 20 3)..... ;;
79b0: 69 66 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 if the current s
79c0: 74 61 74 75 73 20 69 73 20 41 55 54 4f 20 74 68 tatus is AUTO th
79d0: 65 6e 20 64 65 66 65 72 20 74 6f 20 74 68 65 20 en defer to the
79e0: 63 61 6c 63 75 6c 61 74 65 64 20 76 61 6c 75 65 calculated value
79f0: 20 28 69 2e 65 2e 20 6c 65 61 76 65 20 74 68 69 (i.e. leave thi
7a00: 73 20 41 55 54 4f 29 0a 09 09 09 09 20 20 20 20 s AUTO).....
7a10: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 64 (if (equal? (d
7a20: 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 b:test-get-statu
7a30: 73 20 74 65 73 74 69 6e 66 6f 29 20 22 41 55 54 s testinfo) "AUT
7a40: 4f 22 29 20 22 41 55 54 4f 22 20 22 50 41 53 53 O") "AUTO" "PASS
7a50: 22 29 29 0a 09 09 09 09 20 20 20 20 20 28 28 65 "))..... ((e
7a60: 71 3f 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d q? (launch:einf-
7a70: 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 78 rollup-status ex
7a80: 69 74 2d 69 6e 66 6f 29 20 31 29 20 22 46 41 49 it-info) 1) "FAI
7a90: 4c 22 29 20 20 3b 3b 20 28 76 65 63 74 6f 72 2d L") ;; (vector-
7aa0: 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 33 29 ref exit-info 3)
7ab0: 0a 09 09 09 09 20 20 20 20 20 28 28 65 71 3f 20 ..... ((eq?
7ac0: 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c (launch:einf-rol
7ad0: 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d lup-status exit-
7ae0: 69 6e 66 6f 29 20 32 29 09 20 20 20 20 20 3b 3b info) 2). ;;
7af0: 09 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 .(vector-ref exi
7b00: 74 2d 69 6e 66 6f 20 33 29 0a 09 09 09 09 20 20 t-info 3).....
7b10: 20 20 20 20 3b 3b 20 69 66 20 74 68 65 20 63 75 ;; if the cu
7b20: 72 72 65 6e 74 20 73 74 61 74 75 73 20 69 73 20 rrent status is
7b30: 41 55 54 4f 20 74 68 65 20 64 65 66 65 72 20 74 AUTO the defer t
7b40: 6f 20 74 68 65 20 63 61 6c 63 75 6c 61 74 65 64 o the calculated
7b50: 20 76 61 6c 75 65 20 62 75 74 20 71 75 61 6c 69 value but quali
7b60: 66 79 20 28 69 2e 65 2e 20 6d 61 6b 65 20 74 68 fy (i.e. make th
7b70: 69 73 20 41 55 54 4f 2d 57 41 52 4e 29 0a 09 09 is AUTO-WARN)...
7b80: 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 75 .. (if (equ
7b90: 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 al? (db:test-get
7ba0: 2d 73 74 61 74 75 73 20 74 65 73 74 69 6e 66 6f -status testinfo
7bb0: 29 20 22 41 55 54 4f 22 29 20 22 41 55 54 4f 2d ) "AUTO") "AUTO-
7bc0: 57 41 52 4e 22 20 22 57 41 52 4e 22 29 29 0a 09 WARN" "WARN"))..
7bd0: 09 09 09 20 20 20 20 20 28 28 65 71 3f 20 28 6c ... ((eq? (l
7be0: 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 aunch:einf-rollu
7bf0: 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e p-status exit-in
7c00: 66 6f 29 20 33 29 20 22 43 48 45 43 4b 22 29 0a fo) 3) "CHECK").
7c10: 09 09 09 09 20 20 20 20 20 28 28 65 71 3f 20 28 .... ((eq? (
7c20: 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c launch:einf-roll
7c30: 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 up-status exit-i
7c40: 6e 66 6f 29 20 34 29 20 22 57 41 49 56 45 44 22 nfo) 4) "WAIVED"
7c50: 29 0a 09 09 09 09 20 20 20 20 20 28 28 65 71 3f )..... ((eq?
7c60: 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f (launch:einf-ro
7c70: 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 llup-status exit
7c80: 2d 69 6e 66 6f 29 20 35 29 20 22 41 42 4f 52 54 -info) 5) "ABORT
7c90: 22 29 0a 09 09 09 09 20 20 20 20 20 28 28 65 71 ")..... ((eq
7ca0: 3f 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 ? (launch:einf-r
7cb0: 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 ollup-status exi
7cc0: 74 2d 69 6e 66 6f 29 20 36 29 20 22 53 4b 49 50 t-info) 6) "SKIP
7cd0: 22 29 0a 09 09 09 09 20 20 20 20 20 28 65 6c 73 ")..... (els
7ce0: 65 20 22 46 41 49 4c 22 29 29 29 29 20 3b 3b 20 e "FAIL")))) ;;
7cf0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
7d00: 74 75 73 20 74 65 73 74 69 6e 66 6f 29 29 29 0a tus testinfo))).
7d10: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
7d20: 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 nt-info 1 *defau
7d30: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 65 lt-log-port* "Te
7d40: 73 74 20 65 78 69 74 65 64 20 69 6e 20 73 74 61 st exited in sta
7d50: 74 65 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 65 te=" (db:test-ge
7d60: 74 2d 73 74 61 74 65 20 74 65 73 74 69 6e 66 6f t-state testinfo
7d70: 29 20 22 2c 20 73 65 74 74 69 6e 67 20 73 74 61 ) ", setting sta
7d80: 74 65 2f 73 74 61 74 75 73 20 62 61 73 65 64 20 te/status based
7d90: 6f 6e 20 65 78 69 74 20 63 6f 64 65 20 6f 66 20 on exit code of
7da0: 22 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 65 " (launch:einf-e
7db0: 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 74 2d xit-status exit-
7dc0: 69 6e 66 6f 29 20 22 20 61 6e 64 20 72 6f 6c 6c info) " and roll
7dd0: 75 70 2d 73 74 61 74 75 73 20 6f 66 20 22 20 28 up-status of " (
7de0: 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c launch:einf-roll
7df0: 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 up-status exit-i
7e00: 6e 66 6f 29 29 0a 09 09 20 20 20 20 28 74 65 73 nfo))... (tes
7e10: 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 ts:test-set-stat
7e20: 75 73 21 20 72 75 6e 2d 69 64 20 0a 09 09 09 09 us! run-id .....
7e30: 09 20 20 20 20 74 65 73 74 2d 69 64 20 0a 09 09 . test-id ...
7e40: 09 09 09 20 20 20 20 6e 65 77 2d 73 74 61 74 65 ... new-state
7e50: 0a 09 09 09 09 09 20 20 20 20 6e 65 77 2d 73 74 ...... new-st
7e60: 61 74 75 73 0a 09 09 09 09 09 20 20 20 20 28 61 atus...... (a
7e70: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 rgs:get-arg "-m"
7e80: 29 20 23 66 29 0a 09 09 20 20 20 20 3b 3b 20 6e ) #f)... ;; n
7e90: 65 65 64 20 74 6f 20 75 70 64 61 74 65 20 74 68 eed to update th
7ea0: 65 20 74 6f 70 20 74 65 73 74 20 72 65 63 6f 72 e top test recor
7eb0: 64 20 69 66 20 50 41 53 53 20 6f 72 20 46 41 49 d if PASS or FAI
7ec0: 4c 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 L and this is a
7ed0: 73 75 62 74 65 73 74 0a 09 09 20 20 20 20 3b 3b subtest... ;;
7ee0: 20 4e 4f 20 4e 45 45 44 20 54 4f 20 43 41 4c 4c NO NEED TO CALL
7ef0: 20 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 roll-up-pass-fa
7f00: 69 6c 2d 63 6f 75 6e 74 73 20 48 45 52 45 2c 20 il-counts HERE,
7f10: 54 48 49 53 20 49 53 20 44 4f 4e 45 20 49 4e 20 THIS IS DONE IN
7f20: 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 69 roll-up-pass-fai
7f30: 6c 2d 63 6f 75 6e 74 73 20 63 61 6c 6c 65 64 20 l-counts called
7f40: 62 79 20 74 65 73 74 73 3a 74 65 73 74 2d 73 65 by tests:test-se
7f50: 74 2d 73 74 61 74 75 73 21 0a 09 09 20 20 20 20 t-status!...
7f60: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 66 6f 72 )).. ;; for
7f70: 20 61 75 74 6f 6d 61 74 65 64 20 63 72 65 61 74 automated creat
7f80: 69 6f 6e 20 6f 66 20 74 68 65 20 72 6f 6c 6c 75 ion of the rollu
7f90: 70 20 68 74 6d 6c 20 66 69 6c 65 20 74 68 69 73 p html file this
7fa0: 20 69 73 20 61 20 67 6f 6f 64 20 70 6c 61 63 65 is a good place
7fb0: 2e 2e 2e 0a 09 20 20 20 20 20 20 28 69 66 20 28 ..... (if (
7fc0: 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d not (equal? item
7fd0: 2d 70 61 74 68 20 22 22 29 29 0a 09 09 20 20 28 -path ""))... (
7fe0: 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d tests:summarize-
7ff0: 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 items run-id tes
8000: 74 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 23 t-id test-name #
8010: 66 29 29 0a 09 20 20 20 20 20 20 28 74 65 73 74 f)).. (test
8020: 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 74 65 73 74 s:summarize-test
8030: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
8040: 20 20 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 63 65 ;; don't force
8050: 20 2d 20 6a 75 73 74 20 75 70 64 61 74 65 20 69 - just update i
8060: 66 20 6e 6f 0a 09 20 20 20 20 20 20 28 72 6d 74 f no.. (rmt
8070: 3a 75 70 64 61 74 65 2d 72 75 6e 2d 73 74 61 74 :update-run-stat
8080: 73 20 72 75 6e 2d 69 64 20 28 72 6d 74 3a 67 65 s run-id (rmt:ge
8090: 74 2d 72 61 77 2d 72 75 6e 2d 73 74 61 74 73 20 t-raw-run-stats
80a0: 72 75 6e 2d 69 64 29 29 29 0a 09 20 20 20 20 28 run-id))).. (
80b0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 29 mutex-unlock! m)
80c0: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
80d0: 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 2 *default-lo
80e0: 67 2d 70 6f 72 74 2a 20 22 4f 75 74 70 75 74 20 g-port* "Output
80f0: 66 72 6f 6d 20 72 75 6e 6e 69 6e 67 20 22 20 66 from running " f
8100: 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 22 2c 20 ullrunscript ",
8110: 70 69 64 20 22 20 28 6c 61 75 6e 63 68 3a 65 69 pid " (launch:ei
8120: 6e 66 2d 70 69 64 20 65 78 69 74 2d 69 6e 66 6f nf-pid exit-info
8130: 29 20 22 20 69 6e 20 77 6f 72 6b 20 61 72 65 61 ) " in work area
8140: 20 22 20 0a 09 09 09 20 77 6f 72 6b 2d 61 72 65 " .... work-are
8150: 61 20 22 3a 5c 6e 3d 3d 3d 3d 5c 6e 20 65 78 69 a ":\n====\n exi
8160: 74 20 63 6f 64 65 20 22 20 28 6c 61 75 6e 63 68 t code " (launch
8170: 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f 64 65 20 :einf-exit-code
8180: 65 78 69 74 2d 69 6e 66 6f 29 20 22 5c 6e 22 20 exit-info) "\n"
8190: 22 3d 3d 3d 3d 5c 6e 22 29 0a 09 20 20 20 20 28 "====\n").. (
81a0: 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e 63 68 3a if (not (launch:
81b0: 65 69 6e 66 2d 65 78 69 74 2d 73 74 61 74 75 73 einf-exit-status
81c0: 20 65 78 69 74 2d 69 6e 66 6f 29 29 0a 09 09 28 exit-info))...(
81d0: 65 78 69 74 20 34 29 29 29 29 29 29 29 0a 0a 28 exit 4)))))))..(
81e0: 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 63 define (launch:c
81f0: 61 63 68 65 2d 63 6f 6e 66 69 67 29 0a 20 20 3b ache-config). ;
8200: 3b 20 69 66 20 77 65 20 68 61 76 65 20 61 20 6c ; if we have a l
8210: 69 6e 6b 74 72 65 65 20 61 6e 64 20 2d 72 75 6e inktree and -run
8220: 74 65 73 74 73 20 61 6e 64 20 2d 74 61 72 67 65 tests and -targe
8230: 74 20 61 6e 64 20 74 68 65 20 64 69 72 65 63 74 t and the direct
8240: 6f 72 79 20 65 78 69 73 74 73 20 64 75 6d 70 20 ory exists dump
8250: 74 68 65 20 63 6f 6e 66 69 67 0a 20 20 3b 3b 20 the config. ;;
8260: 74 6f 20 6d 65 67 61 74 65 73 74 2d 28 63 75 72 to megatest-(cur
8270: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 2e 63 66 rent-seconds).cf
8280: 67 20 61 6e 64 20 73 79 6d 6c 69 6e 6b 20 69 74 g and symlink it
8290: 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 63 66 67 to megatest.cfg
82a0: 0a 20 20 28 69 66 20 28 61 6e 64 20 2a 63 6f 6e . (if (and *con
82b0: 66 69 67 64 61 74 2a 20 0a 09 20 20 20 28 6f 72 figdat* .. (or
82c0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
82d0: 2d 72 75 6e 22 29 0a 09 20 20 20 20 20 20 20 28 -run").. (
82e0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
82f0: 75 6e 74 65 73 74 73 22 29 0a 09 20 20 20 20 20 untests")..
8300: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
8310: 22 2d 65 78 65 63 75 74 65 22 29 29 29 0a 20 20 "-execute"))).
8320: 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b (let* ((link
8330: 74 72 65 65 20 28 67 65 74 2d 65 6e 76 69 72 6f tree (get-enviro
8340: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
8350: 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 29 0a 09 MT_LINKTREE"))..
8360: 20 20 20 20 20 28 74 61 72 67 65 74 20 20 20 28 (target (
8370: 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d common:args-get-
8380: 74 61 72 67 65 74 29 29 0a 09 20 20 20 20 20 28 target)).. (
8390: 72 75 6e 6e 61 6d 65 20 20 28 6f 72 20 28 61 72 runname (or (ar
83a0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
83b0: 6e 61 6d 65 22 29 0a 09 09 09 20 20 20 28 61 72 name").... (ar
83c0: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e gs:get-arg ":run
83d0: 6e 61 6d 65 22 29 0a 09 09 09 20 20 20 28 67 65 name").... (ge
83e0: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 tenv "MT_RUNNAME
83f0: 22 29 29 29 0a 09 20 20 20 20 20 28 66 75 6c 6c "))).. (full
8400: 64 69 72 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 dir (conc linkt
8410: 72 65 65 20 22 2f 22 0a 09 09 09 20 20 20 20 20 ree "/"....
8420: 74 61 72 67 65 74 20 22 2f 22 0a 09 09 09 20 20 target "/"....
8430: 20 20 20 72 75 6e 6e 61 6d 65 29 29 29 0a 09 28 runname)))..(
8440: 69 66 20 28 61 6e 64 20 6c 69 6e 6b 74 72 65 65 if (and linktree
8450: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c (file-exists? l
8460: 69 6e 6b 74 72 65 65 29 29 20 3b 3b 20 63 61 6e inktree)) ;; can
8470: 27 74 20 70 72 6f 63 65 65 64 20 77 69 74 68 6f 't proceed witho
8480: 75 74 20 6c 69 6e 6b 74 72 65 65 0a 09 20 20 20 ut linktree..
8490: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
84a0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
84b0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
84c0: 70 6f 72 74 2a 20 22 48 61 76 65 20 2d 72 75 6e port* "Have -run
84d0: 20 77 69 74 68 20 74 61 72 67 65 74 3d 22 20 74 with target=" t
84e0: 61 72 67 65 74 20 22 2c 20 72 75 6e 6e 61 6d 65 arget ", runname
84f0: 3d 22 20 72 75 6e 6e 61 6d 65 20 22 2c 20 66 75 =" runname ", fu
8500: 6c 6c 64 69 72 3d 22 20 66 75 6c 6c 64 69 72 20 lldir=" fulldir
8510: 22 2c 20 74 65 73 74 70 61 74 74 3d 22 20 28 6f ", testpatt=" (o
8520: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
8530: 22 2d 74 65 73 74 70 61 74 74 22 29 20 22 25 22 "-testpatt") "%"
8540: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e )).. (if (n
8550: 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f ot (file-exists?
8560: 20 66 75 6c 6c 64 69 72 29 29 0a 09 09 20 20 28 fulldir))... (
8570: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
8580: 20 66 75 6c 6c 64 69 72 20 23 74 29 29 20 3b 3b fulldir #t)) ;;
8590: 20 6e 65 65 64 20 74 6f 20 70 72 6f 74 65 63 74 need to protect
85a0: 20 77 69 74 68 20 65 78 63 65 70 74 69 6f 6e 20 with exception
85b0: 68 61 6e 64 6c 65 72 20 0a 09 20 20 20 20 20 20 handler ..
85c0: 28 69 66 20 28 61 6e 64 20 74 61 72 67 65 74 0a (if (and target.
85d0: 09 09 20 20 20 20 20 20 20 72 75 6e 6e 61 6d 65 .. runname
85e0: 0a 09 09 20 20 20 20 20 20 20 28 66 69 6c 65 2d ... (file-
85f0: 65 78 69 73 74 73 3f 20 66 75 6c 6c 64 69 72 29 exists? fulldir)
8600: 29 0a 09 09 20 20 28 6c 65 74 20 28 28 74 6d 70 )... (let ((tmp
8610: 66 69 6c 65 20 20 28 63 6f 6e 63 20 66 75 6c 6c file (conc full
8620: 64 69 72 20 22 2f 2e 6d 65 67 61 74 65 73 74 2e dir "/.megatest.
8630: 63 66 67 2e 22 20 28 63 75 72 72 65 6e 74 2d 73 cfg." (current-s
8640: 65 63 6f 6e 64 73 29 29 29 0a 09 09 09 28 74 61 econds)))....(ta
8650: 72 67 66 69 6c 65 20 28 63 6f 6e 63 20 66 75 6c rgfile (conc ful
8660: 6c 64 69 72 20 22 2f 2e 6d 65 67 61 74 65 73 74 ldir "/.megatest
8670: 2e 63 66 67 2d 22 20 20 6d 65 67 61 74 65 73 74 .cfg-" megatest
8680: 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 -version "-" meg
8690: 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 atest-fossil-has
86a0: 68 29 29 0a 09 09 09 28 72 63 6f 6e 66 69 67 20 h))....(rconfig
86b0: 20 28 63 6f 6e 63 20 66 75 6c 6c 64 69 72 20 22 (conc fulldir "
86c0: 2f 2e 72 75 6e 63 6f 6e 66 69 67 2e 22 20 6d 65 /.runconfig." me
86d0: 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 gatest-version "
86e0: 2d 22 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 -" megatest-foss
86f0: 69 6c 2d 68 61 73 68 29 29 29 0a 09 09 20 20 20 il-hash)))...
8700: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
8710: 73 3f 20 72 63 6f 6e 66 69 67 29 20 3b 3b 20 6f s? rconfig) ;; o
8720: 6e 6c 79 20 63 61 63 68 65 20 6d 65 67 61 74 65 nly cache megate
8730: 73 74 2e 63 6f 6e 66 69 67 20 41 46 54 45 52 20 st.config AFTER
8740: 72 75 6e 63 6f 6e 66 69 67 73 20 68 61 73 20 62 runconfigs has b
8750: 65 65 6e 20 63 61 63 68 65 64 0a 09 09 09 28 62 een cached....(b
8760: 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 egin.... (debug
8770: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
8780: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
8790: 20 22 43 61 63 68 69 6e 67 20 6d 65 67 61 74 65 "Caching megate
87a0: 73 74 2e 63 6f 6e 66 69 67 20 69 6e 20 22 20 74 st.config in " t
87b0: 6d 70 66 69 6c 65 29 0a 09 09 09 20 20 28 63 6f mpfile).... (co
87c0: 6e 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 nfigf:write-alis
87d0: 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 74 6d t *configdat* tm
87e0: 70 66 69 6c 65 29 0a 09 09 09 20 20 28 73 79 73 pfile).... (sys
87f0: 74 65 6d 20 28 63 6f 6e 63 20 22 6c 6e 20 2d 73 tem (conc "ln -s
8800: 66 20 22 20 74 6d 70 66 69 6c 65 20 22 20 22 20 f " tmpfile " "
8810: 74 61 72 67 66 69 6c 65 29 29 29 29 0a 09 09 20 targfile))))...
8820: 20 20 20 29 29 29 0a 09 20 20 20 20 28 64 65 62 ))).. (deb
8830: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
8840: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8850: 74 2a 20 22 4e 6f 20 6c 69 6e 6b 74 72 65 65 20 t* "No linktree
8860: 79 65 74 2c 20 6e 6f 20 63 61 63 68 69 6e 67 20 yet, no caching
8870: 63 6f 6e 66 69 67 73 2e 22 29 29 29 29 29 0a 0a configs.")))))..
8880: 0a 3b 3b 20 67 61 74 68 65 72 20 61 76 61 69 6c .;; gather avail
8890: 61 62 6c 65 20 69 6e 66 6f 72 6d 61 74 69 6f 6e able information
88a0: 2c 20 69 66 20 6c 65 67 69 74 20 72 65 61 64 20 , if legit read
88b0: 63 6f 6e 66 69 67 73 20 69 6e 20 74 68 69 73 20 configs in this
88c0: 6f 72 64 65 72 3a 0a 3b 3b 0a 3b 3b 20 20 20 69 order:.;;.;; i
88d0: 66 20 68 61 76 65 20 63 61 63 68 65 3b 0a 3b 3b f have cache;.;;
88e0: 20 20 20 20 20 20 72 65 61 64 20 69 74 20 61 20 read it a
88f0: 72 65 74 75 72 6e 20 69 74 0a 3b 3b 20 20 20 65 return it.;; e
8900: 6c 73 65 0a 3b 3b 20 20 20 20 20 6d 65 67 61 74 lse.;; megat
8910: 65 73 74 2e 63 6f 6e 66 69 67 20 20 20 20 20 28 est.config (
8920: 64 6f 20 6e 6f 74 20 63 61 63 68 65 29 0a 3b 3b do not cache).;;
8930: 20 20 20 20 20 72 75 6e 63 6f 6e 66 69 67 73 2e runconfigs.
8940: 63 6f 6e 66 69 67 20 20 20 28 63 61 63 68 65 20 config (cache
8950: 69 66 20 61 6c 6c 20 76 61 72 73 20 61 76 61 69 if all vars avai
8960: 6c 29 0a 3b 3b 20 20 20 20 20 6d 65 67 61 74 65 l).;; megate
8970: 73 74 2e 63 6f 6e 66 69 67 20 20 20 20 20 28 63 st.config (c
8980: 61 63 68 65 20 69 66 20 61 6c 6c 20 76 61 72 73 ache if all vars
8990: 20 61 76 61 69 6c 29 0a 3b 3b 20 20 20 72 65 74 avail).;; ret
89a0: 75 72 6e 73 3a 0a 3b 3b 20 20 20 20 20 2a 74 6f urns:.;; *to
89b0: 70 70 61 74 68 2a 0a 3b 3b 20 20 20 73 69 64 65 ppath*.;; side
89c0: 20 65 66 66 65 63 74 73 3a 0a 3b 3b 20 20 20 20 effects:.;;
89d0: 20 73 65 74 73 3b 20 2a 63 6f 6e 66 69 67 64 61 sets; *configda
89e0: 74 2a 20 20 20 20 28 6d 65 67 61 74 65 73 74 2e t* (megatest.
89f0: 63 6f 6e 66 69 67 20 69 6e 66 6f 29 0a 3b 3b 20 config info).;;
8a00: 20 20 20 20 20 20 20 20 20 20 2a 72 75 6e 63 6f *runco
8a10: 6e 66 69 67 64 61 74 2a 20 28 72 75 6e 63 6f 6e nfigdat* (runcon
8a20: 66 69 67 73 2e 63 6f 6e 66 69 67 20 69 6e 66 6f figs.config info
8a30: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 2a ).;; *
8a40: 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 28 73 configstatus* (s
8a50: 74 61 74 75 73 20 6f 66 20 74 68 65 20 72 65 61 tatus of the rea
8a60: 64 20 64 61 74 61 29 0a 3b 3b 0a 28 64 65 66 69 d data).;;.(defi
8a70: 6e 65 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 ne (launch:setup
8a80: 20 23 21 6b 65 79 20 28 66 6f 72 63 65 20 23 66 #!key (force #f
8a90: 29 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b )). (mutex-lock
8aa0: 21 20 2a 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d ! *launch-setup-
8ab0: 6d 75 74 65 78 2a 29 0a 20 20 28 69 66 20 28 61 mutex*). (if (a
8ac0: 6e 64 20 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 nd *toppath*..
8ad0: 20 28 65 71 3f 20 2a 63 6f 6e 66 69 67 73 74 61 (eq? *configsta
8ae0: 74 75 73 2a 20 27 66 75 6c 6c 64 61 74 61 29 29 tus* 'fulldata))
8af0: 20 3b 3b 20 67 6f 74 20 69 74 20 61 6c 6c 0a 20 ;; got it all.
8b00: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 (begin..(de
8b10: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
8b20: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
8b30: 4e 4f 54 45 3a 20 73 6b 69 70 70 69 6e 67 20 6c NOTE: skipping l
8b40: 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 79 aunch:setup-body
8b50: 20 63 61 6c 6c 20 73 69 6e 63 65 20 77 65 20 68 call since we h
8b60: 61 76 65 20 66 75 6c 6c 64 61 74 61 22 29 0a 09 ave fulldata")..
8b70: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
8b80: 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 74 launch-setup-mut
8b90: 65 78 2a 29 0a 09 2a 74 6f 70 70 61 74 68 2a 29 ex*)..*toppath*)
8ba0: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
8bb0: 73 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d s (launch:setup-
8bc0: 62 6f 64 79 20 66 6f 72 63 65 3a 20 66 6f 72 63 body force: forc
8bd0: 65 29 29 29 0a 09 28 6d 75 74 65 78 2d 75 6e 6c e)))..(mutex-unl
8be0: 6f 63 6b 21 20 2a 6c 61 75 6e 63 68 2d 73 65 74 ock! *launch-set
8bf0: 75 70 2d 6d 75 74 65 78 2a 29 0a 09 72 65 73 29 up-mutex*)..res)
8c00: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 ))..(define (lau
8c10: 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 79 20 23 nch:setup-body #
8c20: 21 6b 65 79 20 28 66 6f 72 63 65 20 23 66 29 29 !key (force #f))
8c30: 0a 20 20 28 6c 65 74 2a 20 28 28 74 6f 70 70 61 . (let* ((toppa
8c40: 74 68 20 20 28 6f 72 20 2a 74 6f 70 70 61 74 68 th (or *toppath
8c50: 2a 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 * (getenv "MT_RU
8c60: 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 29 29 20 N_AREA_HOME")))
8c70: 3b 3b 20 70 72 65 73 65 72 76 65 20 74 6f 70 70 ;; preserve topp
8c80: 61 74 68 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 ath.. (runname
8c90: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
8ca0: 2d 72 75 6e 6e 61 6d 65 29 29 0a 09 20 28 74 61 -runname)).. (ta
8cb0: 72 67 65 74 20 20 20 28 63 6f 6d 6d 6f 6e 3a 61 rget (common:a
8cc0: 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 29 29 rgs-get-target))
8cd0: 0a 09 20 28 6c 69 6e 6b 74 72 65 65 20 28 63 6f .. (linktree (co
8ce0: 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 mmon:get-linktre
8cf0: 65 29 29 0a 09 20 28 73 65 63 74 69 6f 6e 73 20 e)).. (sections
8d00: 28 69 66 20 74 61 72 67 65 74 20 28 6c 69 73 74 (if target (list
8d10: 20 22 64 65 66 61 75 6c 74 22 20 74 61 72 67 65 "default" targe
8d20: 74 29 20 23 66 29 29 20 3b 3b 20 66 6f 72 20 72 t) #f)) ;; for r
8d30: 75 6e 63 6f 6e 66 69 67 73 0a 09 20 28 6d 74 63 unconfigs.. (mtc
8d40: 6f 6e 66 69 67 20 28 6f 72 20 28 61 72 67 73 3a onfig (or (args:
8d50: 67 65 74 2d 61 72 67 20 22 2d 63 6f 6e 66 69 67 get-arg "-config
8d60: 22 29 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e ") "megatest.con
8d70: 66 69 67 22 29 29 20 3b 3b 20 61 6c 6c 6f 77 20 fig")) ;; allow
8d80: 6f 76 65 72 72 69 64 69 6e 67 20 6d 65 67 61 74 overriding megat
8d90: 65 73 74 2e 63 6f 6e 66 69 67 20 0a 09 20 28 72 est.config .. (r
8da0: 75 6e 64 69 72 20 20 20 28 69 66 20 28 61 6e 64 undir (if (and
8db0: 20 72 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 20 runname target
8dc0: 6c 69 6e 6b 74 72 65 65 29 28 63 6f 6e 63 20 6c linktree)(conc l
8dd0: 69 6e 6b 74 72 65 65 20 22 2f 22 20 74 61 72 67 inktree "/" targ
8de0: 65 74 20 22 2f 22 20 72 75 6e 6e 61 6d 65 29 20 et "/" runname)
8df0: 23 66 29 29 0a 09 20 28 6d 74 63 61 63 68 65 66 #f)).. (mtcachef
8e00: 20 28 61 6e 64 20 72 75 6e 64 69 72 20 28 63 6f (and rundir (co
8e10: 6e 63 20 72 75 6e 64 69 72 20 22 2f 22 20 22 2e nc rundir "/" ".
8e20: 6d 65 67 61 74 65 73 74 2e 63 66 67 2d 22 20 20 megatest.cfg-"
8e30: 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e megatest-version
8e40: 20 22 2d 22 20 6d 65 67 61 74 65 73 74 2d 66 6f "-" megatest-fo
8e50: 73 73 69 6c 2d 68 61 73 68 29 29 29 0a 09 20 28 ssil-hash))).. (
8e60: 72 63 63 61 63 68 65 66 20 28 61 6e 64 20 72 75 rccachef (and ru
8e70: 6e 64 69 72 20 28 63 6f 6e 63 20 72 75 6e 64 69 ndir (conc rundi
8e80: 72 20 22 2f 22 20 22 2e 72 75 6e 63 6f 6e 66 69 r "/" ".runconfi
8e90: 67 73 2e 63 66 67 2d 22 20 20 6d 65 67 61 74 65 gs.cfg-" megate
8ea0: 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 6d st-version "-" m
8eb0: 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 egatest-fossil-h
8ec0: 61 73 68 29 29 29 0a 09 20 28 63 61 6e 63 72 65 ash))).. (cancre
8ed0: 61 74 65 20 28 61 6e 64 20 72 75 6e 64 69 72 20 ate (and rundir
8ee0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 75 (file-exists? ru
8ef0: 6e 64 69 72 29 28 66 69 6c 65 2d 77 72 69 74 65 ndir)(file-write
8f00: 2d 61 63 63 65 73 73 3f 20 72 75 6e 64 69 72 29 -access? rundir)
8f10: 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 78 74 )). (cxt
8f20: 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 (hash-tab
8f30: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
8f40: 63 6f 6e 74 65 78 74 73 2a 20 74 6f 70 70 61 74 contexts* toppat
8f50: 68 20 23 66 29 29 29 0a 0a 20 20 20 20 3b 3b 20 h #f))).. ;;
8f60: 63 72 65 61 74 65 20 6f 75 72 20 63 78 74 20 66 create our cxt f
8f70: 6f 72 20 74 68 69 73 20 61 72 65 61 20 69 66 20 or this area if
8f80: 69 74 20 64 6f 65 73 6e 27 74 20 61 6c 72 65 61 it doesn't alrea
8f90: 64 79 20 65 78 69 73 74 0a 20 20 20 20 28 69 66 dy exist. (if
8fa0: 20 28 6e 6f 74 20 63 78 74 29 28 68 61 73 68 2d (not cxt)(hash-
8fb0: 74 61 62 6c 65 2d 73 65 74 21 20 2a 63 6f 6e 74 table-set! *cont
8fc0: 65 78 74 73 2a 20 74 6f 70 70 61 74 68 20 28 6d exts* toppath (m
8fd0: 61 6b 65 2d 63 78 74 29 29 29 0a 0a 20 20 20 20 ake-cxt)))..
8fe0: 3b 3b 20 28 70 72 69 6e 74 20 22 72 75 6e 6e 61 ;; (print "runna
8ff0: 6d 65 3a 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 me: " runname "
9000: 74 61 72 67 65 74 3a 20 22 20 74 61 72 67 65 74 target: " target
9010: 20 22 20 6d 74 63 61 63 68 65 66 3a 20 22 20 6d " mtcachef: " m
9020: 74 63 61 63 68 65 66 20 22 20 72 63 63 61 63 68 tcachef " rccach
9030: 65 66 3a 20 22 20 72 63 63 61 63 68 65 66 29 0a ef: " rccachef).
9040: 20 20 20 20 28 73 65 74 21 20 2a 74 6f 70 70 61 (set! *toppa
9050: 74 68 2a 20 74 6f 70 70 61 74 68 29 20 3b 3b 20 th* toppath) ;;
9060: 54 68 69 73 20 69 73 20 6e 65 65 64 65 64 20 77 This is needed w
9070: 68 65 6e 20 77 65 20 61 72 65 20 72 75 6e 6e 69 hen we are runni
9080: 6e 67 20 61 73 20 61 20 74 65 73 74 20 75 73 69 ng as a test usi
9090: 6e 67 20 43 4d 44 49 4e 46 4f 20 61 73 20 61 20 ng CMDINFO as a
90a0: 64 61 74 61 73 6f 75 72 63 65 0a 20 20 20 20 28 datasource. (
90b0: 63 6f 6e 64 0a 20 20 20 20 20 3b 3b 20 64 61 74 cond. ;; dat
90c0: 61 20 77 61 73 20 72 65 61 64 20 61 6e 64 20 63 a was read and c
90d0: 61 63 68 65 64 20 61 6e 64 20 61 76 61 69 6c 61 ached and availa
90e0: 62 6c 65 20 69 6e 20 2a 63 6f 6e 66 69 67 73 74 ble in *configst
90f0: 61 74 75 73 2a 2c 20 74 6f 70 70 61 74 68 20 68 atus*, toppath h
9100: 61 73 20 61 6c 72 65 61 64 79 20 62 65 65 6e 20 as already been
9110: 73 65 74 0a 20 20 20 20 20 28 28 65 71 3f 20 2a set. ((eq? *
9120: 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 27 66 configstatus* 'f
9130: 75 6c 6c 64 61 74 61 29 0a 20 20 20 20 20 20 2a ulldata). *
9140: 74 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 20 3b toppath*). ;
9150: 3b 20 69 66 20 6d 74 63 61 63 68 65 66 20 65 78 ; if mtcachef ex
9160: 69 73 74 73 20 6a 75 73 74 20 72 65 61 64 20 69 ists just read i
9170: 74 2c 20 68 6f 77 65 76 65 72 20 77 65 20 6e 65 t, however we ne
9180: 65 64 20 74 6f 20 61 73 73 75 6d 65 20 74 6f 70 ed to assume top
9190: 70 61 74 68 20 69 73 20 61 76 61 69 6c 61 62 6c path is availabl
91a0: 65 20 69 6e 20 24 4d 54 5f 52 55 4e 5f 41 52 45 e in $MT_RUN_ARE
91b0: 41 5f 48 4f 4d 45 0a 20 20 20 20 20 28 28 61 6e A_HOME. ((an
91c0: 64 20 6d 74 63 61 63 68 65 66 20 28 66 69 6c 65 d mtcachef (file
91d0: 2d 65 78 69 73 74 73 3f 20 6d 74 63 61 63 68 65 -exists? mtcache
91e0: 66 29 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d f) (get-environm
91f0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 ent-variable "MT
9200: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 _RUN_AREA_HOME")
9210: 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 2a 63 ). (set! *c
9220: 6f 6e 66 69 67 64 61 74 2a 20 20 20 20 28 63 6f onfigdat* (co
9230: 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 73 74 nfigf:read-alist
9240: 20 6d 74 63 61 63 68 65 66 29 29 0a 20 20 20 20 mtcachef)).
9250: 20 20 28 73 65 74 21 20 2a 72 75 6e 63 6f 6e 66 (set! *runconf
9260: 69 67 64 61 74 2a 20 28 63 6f 6e 66 69 67 66 3a igdat* (configf:
9270: 72 65 61 64 2d 61 6c 69 73 74 20 72 63 63 61 63 read-alist rccac
9280: 68 65 66 29 29 0a 20 20 20 20 20 20 28 73 65 74 hef)). (set
9290: 21 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 20 20 ! *configinfo*
92a0: 20 28 6c 69 73 74 20 2a 63 6f 6e 66 69 67 64 61 (list *configda
92b0: 74 2a 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e t* (get-environ
92c0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
92d0: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
92e0: 29 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 ))). (set!
92f0: 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 27 *configstatus* '
9300: 66 75 6c 6c 64 61 74 61 29 0a 20 20 20 20 20 20 fulldata).
9310: 28 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 (set! *toppath*
9320: 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f (get-enviro
9330: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
9340: 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 MT_RUN_AREA_HOME
9350: 22 29 29 0a 20 20 20 20 20 20 2a 74 6f 70 70 61 ")). *toppa
9360: 74 68 2a 29 0a 20 20 20 20 20 3b 3b 20 77 65 20 th*). ;; we
9370: 68 61 76 65 20 61 6c 6c 20 74 68 65 20 69 6e 66 have all the inf
9380: 6f 20 6e 65 65 64 65 64 20 74 6f 20 66 75 6c 6c o needed to full
9390: 79 20 70 72 6f 63 65 73 73 20 72 75 6e 63 6f 6e y process runcon
93a0: 66 69 67 73 20 61 6e 64 20 6d 65 67 61 74 65 73 figs and megates
93b0: 74 2e 63 6f 6e 66 69 67 0a 20 20 20 20 20 28 6d t.config. (m
93c0: 74 63 61 63 68 65 66 20 20 20 20 20 20 20 20 20 tcachef
93d0: 20 20 20 20 20 0a 20 20 20 20 20 20 28 6c 65 74 . (let
93e0: 2a 20 28 28 66 69 72 73 74 2d 70 61 73 73 20 20 * ((first-pass
93f0: 20 20 28 66 69 6e 64 2d 61 6e 64 2d 72 65 61 64 (find-and-read
9400: 2d 63 6f 6e 66 69 67 20 20 20 20 20 20 20 20 3b -config ;
9410: 3b 20 4e 42 2f 2f 20 73 65 74 73 20 4d 54 5f 52 ; NB// sets MT_R
9420: 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 20 61 73 20 UN_AREA_HOME as
9430: 73 69 64 65 20 65 66 66 65 63 74 0a 09 09 09 20 side effect....
9440: 20 20 20 20 20 20 20 20 20 20 20 20 6d 74 63 6f mtco
9450: 6e 66 69 67 0a 09 09 09 09 20 20 20 20 20 65 6e nfig..... en
9460: 76 69 72 6f 6e 2d 70 61 74 74 3a 20 22 65 6e 76 viron-patt: "env
9470: 2d 6f 76 65 72 72 69 64 65 22 0a 09 09 09 09 20 -override".....
9480: 20 20 20 20 67 69 76 65 6e 2d 74 6f 70 70 61 74 given-toppat
9490: 68 3a 20 74 6f 70 70 61 74 68 0a 09 09 09 09 20 h: toppath.....
94a0: 20 20 20 20 70 61 74 68 65 6e 76 76 61 72 3a 20 pathenvvar:
94b0: 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d "MT_RUN_AREA_HOM
94c0: 45 22 29 29 0a 09 20 20 20 20 20 28 66 69 72 73 E")).. (firs
94d0: 74 2d 72 75 6e 64 61 74 20 20 28 6c 65 74 20 28 t-rundat (let (
94e0: 28 74 6f 70 70 61 74 68 20 28 69 66 20 74 6f 70 (toppath (if top
94f0: 70 61 74 68 20 0a 09 09 09 09 09 20 20 20 20 20 path ......
9500: 20 20 74 6f 70 70 61 74 68 0a 09 09 09 09 09 20 toppath......
9510: 20 20 20 20 20 20 28 63 61 72 20 66 69 72 73 74 (car first
9520: 2d 70 61 73 73 29 29 29 29 0a 09 09 09 20 20 20 -pass))))....
9530: 20 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 (read-config
9540: 3b 3b 20 28 63 6f 6e 63 20 74 6f 70 70 61 74 68 ;; (conc toppath
9550: 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f "/runconfigs.co
9560: 6e 66 69 67 22 29 0a 09 09 09 20 20 20 20 20 20 nfig")....
9570: 20 28 63 6f 6e 63 20 28 69 66 20 28 73 74 72 69 (conc (if (stri
9580: 6e 67 3f 20 74 6f 70 70 61 74 68 29 0a 09 09 09 ng? toppath)....
9590: 09 09 20 74 6f 70 70 61 74 68 0a 09 09 09 09 09 .. toppath......
95a0: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
95b0: 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 t-variable "MT_R
95c0: 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 29 0a UN_AREA_HOME")).
95d0: 09 09 09 09 20 20 20 20 20 22 2f 72 75 6e 63 6f .... "/runco
95e0: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 0a 09 nfigs.config")..
95f0: 09 09 20 20 20 20 20 20 20 2a 72 75 6e 63 6f 6e .. *runcon
9600: 66 69 67 64 61 74 2a 20 23 74 20 0a 09 09 09 20 figdat* #t ....
9610: 20 20 20 20 20 20 73 65 63 74 69 6f 6e 73 3a 20 sections:
9620: 73 65 63 74 69 6f 6e 73 29 29 29 29 0a 09 28 73 sections))))..(s
9630: 65 74 21 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 et! *runconfigda
9640: 74 2a 20 66 69 72 73 74 2d 72 75 6e 64 61 74 29 t* first-rundat)
9650: 0a 09 28 69 66 20 66 69 72 73 74 2d 70 61 73 73 ..(if first-pass
9660: 20 20 3b 3b 20 0a 09 20 20 20 20 28 62 65 67 69 ;; .. (begi
9670: 6e 0a 09 20 20 20 20 20 20 28 73 65 74 21 20 2a n.. (set! *
9680: 63 6f 6e 66 69 67 64 61 74 2a 20 20 28 63 61 72 configdat* (car
9690: 20 66 69 72 73 74 2d 70 61 73 73 29 29 0a 09 20 first-pass))..
96a0: 20 20 20 20 20 28 73 65 74 21 20 2a 63 6f 6e 66 (set! *conf
96b0: 69 67 69 6e 66 6f 2a 20 66 69 72 73 74 2d 70 61 iginfo* first-pa
96c0: 73 73 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 ss).. (set!
96d0: 20 2a 74 6f 70 70 61 74 68 2a 20 20 20 20 28 6f *toppath* (o
96e0: 72 20 74 6f 70 70 61 74 68 20 28 63 61 64 72 20 r toppath (cadr
96f0: 66 69 72 73 74 2d 70 61 73 73 29 29 29 20 3b 3b first-pass))) ;;
9700: 20 75 73 65 20 74 68 65 20 67 61 74 68 65 72 65 use the gathere
9710: 64 20 64 61 74 61 20 75 6e 6c 65 73 73 20 61 6c d data unless al
9720: 72 65 61 64 79 20 68 61 76 65 20 69 74 0a 09 20 ready have it..
9730: 20 20 20 20 20 28 73 65 74 21 20 74 6f 70 70 61 (set! toppa
9740: 74 68 20 20 20 20 20 20 2a 74 6f 70 70 61 74 68 th *toppath
9750: 2a 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e *).. (if (n
9760: 6f 74 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 ot *toppath*)...
9770: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 (begin... (
9780: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
9790: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
97a0: 2d 70 6f 72 74 2a 20 22 79 6f 75 20 61 72 65 20 -port* "you are
97b0: 6e 6f 74 20 69 6e 20 61 20 6d 65 67 61 74 65 73 not in a megates
97c0: 74 20 61 72 65 61 21 22 29 0a 09 09 20 20 20 20 t area!")...
97d0: 28 65 78 69 74 20 31 29 29 29 0a 09 20 20 20 20 (exit 1)))..
97e0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 (setenv "MT_RU
97f0: 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f N_AREA_HOME" *to
9800: 70 70 61 74 68 2a 29 0a 09 20 20 20 20 20 20 3b ppath*).. ;
9810: 3b 20 74 68 65 20 73 65 65 64 20 72 65 61 64 20 ; the seed read
9820: 69 73 20 64 6f 6e 65 2c 20 6e 6f 77 20 72 65 61 is done, now rea
9830: 64 20 72 75 6e 63 6f 6e 66 69 67 73 2c 20 63 61 d runconfigs, ca
9840: 63 68 65 20 69 74 20 74 68 65 6e 20 72 65 61 64 che it then read
9850: 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 megatest.config
9860: 20 6f 6e 65 20 6d 6f 72 65 20 74 69 6d 65 20 61 one more time a
9870: 6e 64 20 63 61 63 68 65 20 69 74 0a 09 20 20 20 nd cache it..
9880: 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 (let* ((keys
9890: 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 74 (rmt:get
98a0: 2d 6b 65 79 73 29 29 0a 09 09 20 20 20 20 20 28 -keys))... (
98b0: 6b 65 79 2d 76 61 6c 73 20 20 20 20 20 28 6b 65 key-vals (ke
98c0: 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 ys:target->keyva
98d0: 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a l keys target)).
98e0: 09 09 20 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 .. (linktree
98f0: 20 20 20 20 20 28 6f 72 20 28 67 65 74 65 6e 76 (or (getenv
9900: 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 0a "MT_LINKTREE").
9910: 09 09 09 09 20 20 20 20 20 20 20 28 69 66 20 2a .... (if *
9920: 63 6f 6e 66 69 67 64 61 74 2a 20 28 63 6f 6e 66 configdat* (conf
9930: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
9940: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
9950: 6c 69 6e 6b 74 72 65 65 22 29 20 23 66 29 29 29 linktree") #f)))
9960: 0a 09 09 20 20 20 20 20 28 73 65 63 6f 6e 64 2d ... (second-
9970: 70 61 73 73 20 20 28 66 69 6e 64 2d 61 6e 64 2d pass (find-and-
9980: 72 65 61 64 2d 63 6f 6e 66 69 67 0a 09 09 09 09 read-config.....
9990: 20 20 20 20 6d 74 63 6f 6e 66 69 67 0a 09 09 09 mtconfig....
99a0: 09 20 20 20 20 65 6e 76 69 72 6f 6e 2d 70 61 74 . environ-pat
99b0: 74 3a 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 65 t: "env-override
99c0: 22 0a 09 09 09 09 20 20 20 20 67 69 76 65 6e 2d "..... given-
99d0: 74 6f 70 70 61 74 68 3a 20 74 6f 70 70 61 74 68 toppath: toppath
99e0: 0a 09 09 09 09 20 20 20 20 70 61 74 68 65 6e 76 ..... pathenv
99f0: 76 61 72 3a 20 22 4d 54 5f 52 55 4e 5f 41 52 45 var: "MT_RUN_ARE
9a00: 41 5f 48 4f 4d 45 22 29 29 0a 09 09 20 20 20 20 A_HOME"))...
9a10: 20 28 72 75 6e 63 6f 6e 66 69 67 64 61 74 20 28 (runconfigdat (
9a20: 62 65 67 69 6e 20 20 20 20 20 3b 3b 20 74 68 69 begin ;; thi
9a30: 73 20 72 65 61 64 20 6f 66 20 74 68 65 20 72 75 s read of the ru
9a40: 6e 63 6f 6e 66 69 67 73 20 77 69 6c 6c 20 73 65 nconfigs will se
9a50: 65 20 61 6e 79 20 61 64 6a 75 73 74 6d 65 6e 74 e any adjustment
9a60: 73 20 6d 61 64 65 20 62 79 20 72 65 2d 72 65 61 s made by re-rea
9a70: 64 69 6e 67 20 6d 65 67 61 74 65 73 74 2e 63 6f ding megatest.co
9a80: 6e 66 69 67 0a 09 09 09 09 20 20 20 20 20 28 66 nfig..... (f
9a90: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
9aa0: 28 6b 74 29 0a 09 09 09 09 09 09 20 28 73 65 74 (kt)....... (set
9ab0: 65 6e 76 20 28 63 61 72 20 6b 74 29 20 28 63 61 env (car kt) (ca
9ac0: 64 72 20 6b 74 29 29 29 0a 09 09 09 09 09 20 20 dr kt)))......
9ad0: 20 20 20 20 20 6b 65 79 2d 76 61 6c 73 29 0a 09 key-vals)..
9ae0: 09 09 09 20 20 20 20 20 28 72 65 61 64 2d 63 6f ... (read-co
9af0: 6e 66 69 67 20 28 63 6f 6e 63 20 74 6f 70 70 61 nfig (conc toppa
9b00: 74 68 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e th "/runconfigs.
9b10: 63 6f 6e 66 69 67 22 29 20 2a 72 75 6e 63 6f 6e config") *runcon
9b20: 66 69 67 64 61 74 2a 20 23 74 20 0a 09 09 09 09 figdat* #t .....
9b30: 09 09 20 20 73 65 63 74 69 6f 6e 73 3a 20 73 65 .. sections: se
9b40: 63 74 69 6f 6e 73 29 29 29 29 0a 09 09 28 69 66 ctions))))...(if
9b50: 20 63 61 6e 63 72 65 61 74 65 20 28 63 6f 6e 66 cancreate (conf
9b60: 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 74 20 igf:write-alist
9b70: 72 75 6e 63 6f 6e 66 69 67 64 61 74 20 72 63 63 runconfigdat rcc
9b80: 61 63 68 65 66 29 29 0a 09 09 28 73 65 74 21 20 achef))...(set!
9b90: 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 72 *runconfigdat* r
9ba0: 75 6e 63 6f 6e 66 69 67 64 61 74 29 0a 09 09 28 unconfigdat)...(
9bb0: 69 66 20 63 61 6e 63 72 65 61 74 65 20 28 63 6f if cancreate (co
9bc0: 6e 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 nfigf:write-alis
9bd0: 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 6d 74 t *configdat* mt
9be0: 63 61 63 68 65 66 29 29 0a 09 09 28 69 66 20 63 cachef))...(if c
9bf0: 61 6e 63 72 65 61 74 65 20 28 73 65 74 21 20 2a ancreate (set! *
9c00: 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 27 66 configstatus* 'f
9c10: 75 6c 6c 64 61 74 61 29 29 29 29 0a 09 20 20 20 ulldata))))..
9c20: 20 3b 3b 20 6e 6f 20 63 6f 6e 66 69 67 73 20 66 ;; no configs f
9c30: 6f 75 6e 64 3f 20 73 68 6f 75 6c 64 20 6e 6f 74 ound? should not
9c40: 20 68 61 70 70 65 6e 20 62 75 74 20 6c 65 74 27 happen but let'
9c50: 73 20 74 72 79 20 74 6f 20 72 65 63 6f 76 65 72 s try to recover
9c60: 20 67 72 61 63 65 66 75 6c 6c 79 2c 20 72 65 74 gracefully, ret
9c70: 75 72 6e 20 61 6e 20 65 6d 70 74 79 20 68 61 73 urn an empty has
9c80: 68 2d 74 61 62 6c 65 0a 09 20 20 20 20 28 73 65 h-table.. (se
9c90: 74 21 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 28 t! *configdat* (
9ca0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
9cb0: 29 0a 09 20 20 20 20 29 29 29 0a 20 20 20 20 20 ).. ))).
9cc0: 3b 3b 20 65 6c 73 65 20 72 65 61 64 20 77 68 61 ;; else read wha
9cd0: 74 20 79 6f 75 20 63 61 6e 20 61 6e 64 20 73 65 t you can and se
9ce0: 74 20 74 68 65 20 66 6c 61 67 20 61 63 63 6f 72 t the flag accor
9cf0: 64 69 6e 67 6c 79 0a 20 20 20 20 20 28 65 6c 73 dingly. (els
9d00: 65 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 e. (let* ((
9d10: 63 66 67 64 61 74 20 20 20 28 66 69 6e 64 2d 61 cfgdat (find-a
9d20: 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 67 20 0a nd-read-config .
9d30: 09 09 09 28 6f 72 20 28 61 72 67 73 3a 67 65 74 ...(or (args:get
9d40: 2d 61 72 67 20 22 2d 63 6f 6e 66 69 67 22 29 20 -arg "-config")
9d50: 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 "megatest.config
9d60: 22 29 0a 09 09 09 65 6e 76 69 72 6f 6e 2d 70 61 ")....environ-pa
9d70: 74 74 3a 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 tt: "env-overrid
9d80: 65 22 0a 09 09 09 67 69 76 65 6e 2d 74 6f 70 70 e"....given-topp
9d90: 61 74 68 3a 20 28 67 65 74 2d 65 6e 76 69 72 6f ath: (get-enviro
9da0: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
9db0: 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 MT_RUN_AREA_HOME
9dc0: 22 29 0a 09 09 09 70 61 74 68 65 6e 76 76 61 72 ")....pathenvvar
9dd0: 3a 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 : "MT_RUN_AREA_H
9de0: 4f 4d 45 22 29 29 29 0a 09 28 69 66 20 63 66 67 OME")))..(if cfg
9df0: 64 61 74 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 dat.. (let* (
9e00: 28 74 6f 70 70 61 74 68 20 20 28 6f 72 20 28 67 (toppath (or (g
9e10: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
9e20: 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 5f ariable "MT_RUN_
9e30: 41 52 45 41 5f 48 4f 4d 45 22 29 28 63 61 64 72 AREA_HOME")(cadr
9e40: 20 63 66 67 64 61 74 29 29 29 0a 09 09 20 20 20 cfgdat)))...
9e50: 28 72 64 61 74 20 20 20 20 20 28 72 65 61 64 2d (rdat (read-
9e60: 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 74 6f 70 config (conc top
9e70: 70 61 74 68 0a 09 09 09 09 09 09 22 2f 72 75 6e path......."/run
9e80: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
9e90: 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 *runconfigdat*
9ea0: 23 74 20 73 65 63 74 69 6f 6e 73 3a 20 73 65 63 #t sections: sec
9eb0: 74 69 6f 6e 73 29 29 29 0a 09 20 20 20 20 20 20 tions)))..
9ec0: 28 73 65 74 21 20 2a 63 6f 6e 66 69 67 69 6e 66 (set! *configinf
9ed0: 6f 2a 20 20 20 63 66 67 64 61 74 29 0a 09 20 20 o* cfgdat)..
9ee0: 20 20 20 20 28 73 65 74 21 20 2a 63 6f 6e 66 69 (set! *confi
9ef0: 67 64 61 74 2a 20 20 20 20 28 63 61 72 20 63 66 gdat* (car cf
9f00: 67 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 73 gdat)).. (s
9f10: 65 74 21 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 et! *runconfigda
9f20: 74 2a 20 72 64 61 74 29 0a 09 20 20 20 20 20 20 t* rdat)..
9f30: 28 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 (set! *toppath*
9f40: 20 20 20 20 20 74 6f 70 70 61 74 68 29 0a 09 20 toppath)..
9f50: 20 20 20 20 20 28 73 65 74 21 20 2a 63 6f 6e 66 (set! *conf
9f60: 69 67 73 74 61 74 75 73 2a 20 27 70 61 72 74 69 igstatus* 'parti
9f70: 61 6c 29 29 0a 09 20 20 20 20 28 62 65 67 69 6e al)).. (begin
9f80: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
9f90: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
9fa0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
9fb0: 22 4e 6f 20 22 20 6d 74 63 6f 6e 66 69 67 20 22 "No " mtconfig "
9fc0: 20 66 69 6c 65 20 66 6f 75 6e 64 2e 20 47 69 76 file found. Giv
9fd0: 69 6e 67 20 75 70 2e 22 29 0a 09 20 20 20 20 20 ing up.")..
9fe0: 20 28 65 78 69 74 20 32 29 29 29 29 29 29 0a 20 (exit 2)))))).
9ff0: 20 20 20 3b 3b 20 61 64 64 69 74 69 6f 6e 61 6c ;; additional
a000: 20 68 6f 75 73 65 20 6b 65 65 70 69 6e 67 0a 20 house keeping.
a010: 20 20 20 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 74 (let* ((linkt
a020: 72 65 65 20 28 6f 72 20 28 67 65 74 65 6e 76 20 ree (or (getenv
a030: 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 09 "MT_LINKTREE")..
a040: 09 09 20 28 69 66 20 2a 63 6f 6e 66 69 67 64 61 .. (if *configda
a050: 74 2a 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b t* (configf:look
a060: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
a070: 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 setup" "linktree
a080: 22 29 20 23 66 29 29 29 29 0a 20 20 20 20 20 20 ") #f)))).
a090: 28 69 66 20 6c 69 6e 6b 74 72 65 65 0a 09 20 20 (if linktree..
a0a0: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 69 66 20 (begin.. (if
a0b0: 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 (not (file-exist
a0c0: 73 3f 20 6c 69 6e 6b 74 72 65 65 29 29 0a 09 09 s? linktree))...
a0d0: 28 62 65 67 69 6e 0a 09 09 20 20 28 68 61 6e 64 (begin... (hand
a0e0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
a0f0: 20 20 20 65 78 6e 0a 09 09 20 20 20 28 62 65 67 exn... (beg
a100: 69 6e 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 in... (debug
a110: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
a120: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
a130: 2a 20 22 53 6f 6d 65 74 68 69 6e 67 20 77 65 6e * "Something wen
a140: 74 20 77 72 6f 6e 67 20 77 68 65 6e 20 74 72 79 t wrong when try
a150: 69 6e 67 20 74 6f 20 63 72 65 61 74 65 20 6c 69 ing to create li
a160: 6e 6b 74 72 65 65 20 64 69 72 20 61 74 20 22 20 nktree dir at "
a170: 6c 69 6e 6b 74 72 65 65 29 0a 09 09 20 20 20 20 linktree)...
a180: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
a190: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
a1a0: 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 t* " message: "
a1b0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
a1c0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
a1d0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
a1e0: 29 29 0a 09 09 20 20 20 20 20 28 65 78 69 74 20 ))... (exit
a1f0: 31 29 29 0a 09 09 20 20 20 28 63 72 65 61 74 65 1))... (create
a200: 2d 64 69 72 65 63 74 6f 72 79 20 6c 69 6e 6b 74 -directory linkt
a210: 72 65 65 20 23 74 29 29 29 29 0a 09 20 20 20 20 ree #t))))..
a220: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
a230: 6e 73 0a 09 20 20 20 20 20 65 78 6e 0a 09 20 20 ns.. exn..
a240: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
a250: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
a260: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
a270: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 6f 6d 65 74 log-port* "Somet
a280: 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 20 hing went wrong
a290: 77 68 65 6e 20 74 72 79 69 6e 67 20 74 6f 20 63 when trying to c
a2a0: 72 65 61 74 65 20 6c 69 6e 6b 20 74 6f 20 6c 69 reate link to li
a2b0: 6e 6b 74 72 65 65 20 61 74 20 22 20 2a 74 6f 70 nktree at " *top
a2c0: 70 61 74 68 2a 29 0a 09 20 20 20 20 20 20 20 28 path*).. (
a2d0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
a2e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
a2f0: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 " message: " ((
a300: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
a310: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
a320: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
a330: 29 0a 09 20 20 20 20 20 28 6c 65 74 20 28 28 74 ).. (let ((t
a340: 6c 69 6e 6b 20 28 63 6f 6e 63 20 2a 74 6f 70 70 link (conc *topp
a350: 61 74 68 2a 20 22 2f 6c 74 22 29 29 29 0a 09 20 ath* "/lt")))..
a360: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
a370: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 74 6c 69 file-exists? tli
a380: 6e 6b 29 29 0a 09 09 20 20 20 28 63 72 65 61 74 nk))... (creat
a390: 65 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 20 e-symbolic-link
a3a0: 6c 69 6e 6b 74 72 65 65 20 74 6c 69 6e 6b 29 29 linktree tlink))
a3b0: 29 29 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 ))).. (begin..
a3c0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
a3d0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
a3e0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c 69 6e 6b -log-port* "link
a3f0: 74 72 65 65 20 6e 6f 74 20 64 65 66 69 6e 65 64 tree not defined
a400: 20 69 6e 20 5b 73 65 74 75 70 5d 20 73 65 63 74 in [setup] sect
a410: 69 6f 6e 20 6f 66 20 6d 65 67 61 74 65 73 74 2e ion of megatest.
a420: 63 6f 6e 66 69 67 22 29 0a 09 20 20 20 20 29 29 config").. ))
a430: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 2a ). (if (and *
a440: 74 6f 70 70 61 74 68 2a 0a 09 20 20 20 20 20 28 toppath*.. (
a450: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
a460: 3f 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 28 ? *toppath*))..(
a470: 62 65 67 69 6e 0a 09 20 20 28 73 65 74 65 6e 76 begin.. (setenv
a480: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
a490: 4d 45 22 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 ME" *toppath*)..
a4a0: 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 (setenv "MT_TE
a4b0: 53 54 53 55 49 54 45 5f 4e 41 4d 45 22 20 28 63 STSUITE_NAME" (c
a4c0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 ommon:get-testsu
a4d0: 69 74 65 2d 6e 61 6d 65 29 29 29 0a 09 28 62 65 ite-name)))..(be
a4e0: 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 gin.. (debug:pr
a4f0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
a500: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a510: 66 61 69 6c 65 64 20 74 6f 20 66 69 6e 64 20 74 failed to find t
a520: 68 65 20 74 6f 70 20 70 61 74 68 20 74 6f 20 79 he top path to y
a530: 6f 75 72 20 4d 65 67 61 74 65 73 74 20 61 72 65 our Megatest are
a540: 61 2e 22 29 29 29 0a 20 20 20 20 2a 74 6f 70 70 a."))). *topp
a550: 61 74 68 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 ath*))..(define
a560: 28 67 65 74 2d 62 65 73 74 2d 64 69 73 6b 20 63 (get-best-disk c
a570: 6f 6e 66 64 61 74 20 74 65 73 74 63 6f 6e 66 69 onfdat testconfi
a580: 67 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 69 73 g). (let* ((dis
a590: 6b 73 20 20 20 28 6f 72 20 28 61 6e 64 20 74 65 ks (or (and te
a5a0: 73 74 63 6f 6e 66 69 67 20 28 68 61 73 68 2d 74 stconfig (hash-t
a5b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
a5c0: 20 74 65 73 74 63 6f 6e 66 69 67 20 22 64 69 73 testconfig "dis
a5d0: 6b 73 22 20 23 66 29 29 0a 09 09 20 20 20 20 20 ks" #f))...
a5e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
a5f0: 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 64 61 74 /default confdat
a600: 20 22 64 69 73 6b 73 22 20 23 66 29 29 29 0a 09 "disks" #f)))..
a610: 20 28 6d 69 6e 73 70 61 63 65 20 28 6c 65 74 20 (minspace (let
a620: 28 28 6d 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ((m (configf:loo
a630: 6b 75 70 20 63 6f 6e 66 64 61 74 20 22 73 65 74 kup confdat "set
a640: 75 70 22 20 22 6d 69 6e 73 70 61 63 65 22 29 29 up" "minspace"))
a650: 29 0a 09 09 20 20 20 20 20 28 73 74 72 69 6e 67 )... (string
a660: 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 6d 20 22 ->number (or m "
a670: 31 30 30 30 30 22 29 29 29 29 29 0a 20 20 20 20 10000"))))).
a680: 28 69 66 20 64 69 73 6b 73 20 0a 09 28 6c 65 74 (if disks ..(let
a690: 20 28 28 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a 67 ((res (common:g
a6a0: 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d 6d 6f 73 et-disk-with-mos
a6b0: 74 2d 66 72 65 65 2d 73 70 61 63 65 20 64 69 73 t-free-space dis
a6c0: 6b 73 20 6d 69 6e 73 70 61 63 65 29 29 29 20 3b ks minspace))) ;
a6d0: 3b 20 6d 69 6e 20 73 69 7a 65 20 6f 66 20 31 30 ; min size of 10
a6e0: 30 30 2c 20 73 65 65 6d 73 20 74 61 64 20 64 75 00, seems tad du
a6f0: 6d 62 0a 09 20 20 28 69 66 20 72 65 73 0a 09 20 mb.. (if res..
a700: 20 20 20 20 20 28 63 64 72 20 72 65 73 29 0a 09 (cdr res)..
a710: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 (begin...(
a720: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
a730: 6f 69 73 65 2d 70 72 69 6e 74 20 32 30 20 22 4e oise-print 20 "N
a740: 6f 20 76 61 6c 69 64 20 64 69 73 6b 73 20 6f 72 o valid disks or
a750: 20 6e 6f 20 64 69 73 6b 20 77 69 74 68 20 65 6e no disk with en
a760: 6f 75 67 68 20 73 70 61 63 65 22 29 0a 09 09 20 ough space")...
a770: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
a780: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
a790: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 6f 20 76 -log-port* "No v
a7a0: 61 6c 69 64 20 64 69 73 6b 73 20 66 6f 75 6e 64 alid disks found
a7b0: 20 69 6e 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e in megatest.con
a7c0: 66 69 67 2e 20 50 6c 65 61 73 65 20 61 64 64 20 fig. Please add
a7d0: 73 6f 6d 65 20 74 6f 20 79 6f 75 72 20 5b 64 69 some to your [di
a7e0: 73 6b 73 5d 20 73 65 63 74 69 6f 6e 20 61 6e 64 sks] section and
a7f0: 20 65 6e 73 75 72 65 20 74 68 65 20 64 69 72 65 ensure the dire
a800: 63 74 6f 72 79 20 65 78 69 73 74 73 20 61 6e 64 ctory exists and
a810: 20 68 61 73 20 65 6e 6f 75 67 68 20 73 70 61 63 has enough spac
a820: 65 21 5c 6e 20 20 20 20 59 6f 75 20 63 61 6e 20 e!\n You can
a830: 63 68 61 6e 67 65 20 6d 69 6e 73 70 61 63 65 20 change minspace
a840: 69 6e 20 74 68 65 20 5b 73 65 74 75 70 5d 20 73 in the [setup] s
a850: 65 63 74 69 6f 6e 20 6f 66 20 6d 65 67 61 74 65 ection of megate
a860: 73 74 2e 63 6f 6e 66 69 67 2e 20 43 75 72 72 65 st.config. Curre
a870: 6e 74 20 73 65 74 74 69 6e 67 20 69 73 3a 20 22 nt setting is: "
a880: 20 6d 69 6e 73 70 61 63 65 29 29 0a 09 09 28 65 minspace))...(e
a890: 78 69 74 20 31 29 29 29 29 29 29 29 20 3b 3b 20 xit 1))))))) ;;
a8a0: 54 4f 44 4f 20 2d 20 6d 6f 76 65 20 74 68 65 20 TODO - move the
a8b0: 65 78 69 74 20 74 6f 20 74 68 65 20 63 61 6c 6c exit to the call
a8c0: 69 6e 67 20 6c 6f 63 61 74 69 6f 6e 20 61 6e 64 ing location and
a8d0: 20 72 65 74 75 72 6e 20 23 66 0a 0a 3b 3b 20 44 return #f..;; D
a8e0: 65 73 69 72 65 64 20 64 69 72 65 63 74 6f 72 79 esired directory
a8f0: 20 73 74 72 75 63 74 75 72 65 3a 0a 3b 3b 0a 3b structure:.;;.;
a900: 3b 20 20 3c 6c 69 6e 6b 64 69 72 3e 20 2d 20 3c ; <linkdir> - <
a910: 74 61 72 67 65 74 3e 20 2d 20 3c 74 65 73 74 6e target> - <testn
a920: 61 6d 65 3e 20 2d 2e 0a 3b 3b 20 20 20 20 20 20 ame> -..;;
a930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7c |
a950: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
a960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a970: 20 20 20 20 20 20 20 20 76 0a 3b 3b 20 20 3c 72 v.;; <r
a980: 75 6e 64 69 72 3e 20 20 2d 20 20 3c 74 61 72 67 undir> - <targ
a990: 65 74 3e 20 20 2d 20 20 20 20 3c 74 65 73 74 6e et> - <testn
a9a0: 61 6d 65 3e 20 2d 7c 2d 20 3c 69 74 65 6d 70 61 ame> -|- <itempa
a9b0: 74 68 28 73 29 3e 0a 3b 3b 0a 3b 3b 20 20 64 69 th(s)>.;;.;; di
a9c0: 72 20 73 74 6f 72 65 64 20 69 6e 20 74 65 73 74 r stored in test
a9d0: 20 69 73 3a 0a 3b 3b 20 0a 3b 3b 20 20 3c 6c 69 is:.;; .;; <li
a9e0: 6e 6b 64 69 72 3e 20 2d 20 3c 74 61 72 67 65 74 nkdir> - <target
a9f0: 3e 20 2d 20 3c 74 65 73 74 6e 61 6d 65 3e 20 5b > - <testname> [
aa00: 20 2d 20 3c 69 74 65 6d 70 61 74 68 3e 20 5d 0a - <itempath> ].
aa10: 3b 3b 20 0a 3b 3b 20 41 6c 6c 20 6c 6f 67 20 66 ;; .;; All log f
aa20: 69 6c 65 20 6c 69 6e 6b 73 20 73 68 6f 75 6c 64 ile links should
aa30: 20 62 65 20 73 74 6f 72 65 64 20 72 65 6c 61 74 be stored relat
aa40: 69 76 65 20 74 6f 20 74 68 65 20 74 6f 70 20 6f ive to the top o
aa50: 66 20 6c 69 6e 6b 20 70 61 74 68 0a 3b 3b 20 20 f link path.;;
aa60: 0a 3b 3b 20 3c 74 61 72 67 65 74 3e 20 2d 20 3c .;; <target> - <
aa70: 74 65 73 74 6e 61 6d 65 3e 20 5b 20 2d 20 3c 69 testname> [ - <i
aa80: 74 65 6d 70 61 74 68 3e 20 5d 20 0a 3b 3b 0a 28 tempath> ] .;;.(
aa90: 64 65 66 69 6e 65 20 28 63 72 65 61 74 65 2d 77 define (create-w
aaa0: 6f 72 6b 2d 61 72 65 61 20 72 75 6e 2d 69 64 20 ork-area run-id
aab0: 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 6c 73 run-info keyvals
aac0: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 73 72 test-id test-sr
aad0: 63 2d 70 61 74 68 20 64 69 73 6b 2d 70 61 74 68 c-path disk-path
aae0: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 64 61 testname itemda
aaf0: 74 20 23 21 6b 65 79 20 28 72 65 6d 74 72 69 65 t #!key (remtrie
ab00: 73 20 32 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 s 2)). (let* ((
ab10: 69 74 65 6d 2d 70 61 74 68 20 28 69 66 20 28 73 item-path (if (s
ab20: 74 72 69 6e 67 3f 20 69 74 65 6d 64 61 74 29 20 tring? itemdat)
ab30: 69 74 65 6d 64 61 74 20 28 69 74 65 6d 2d 6c 69 itemdat (item-li
ab40: 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 st->path itemdat
ab50: 29 29 29 20 3b 3b 20 69 66 20 70 61 73 73 20 69 ))) ;; if pass i
ab60: 6e 20 73 74 72 69 6e 67 20 2d 20 6a 75 73 74 20 n string - just
ab70: 75 73 65 20 69 74 0a 09 20 28 72 75 6e 6e 61 6d use it.. (runnam
ab80: 65 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f e (if (string?
ab90: 20 72 75 6e 2d 69 6e 66 6f 29 20 3b 3b 20 69 66 run-info) ;; if
aba0: 20 77 65 20 70 61 73 73 20 69 6e 20 61 20 73 74 we pass in a st
abb0: 72 69 6e 67 20 61 73 20 72 75 6e 2d 69 6e 66 6f ring as run-info
abc0: 20 75 73 65 20 69 74 20 61 73 20 72 75 6e 2d 6e use it as run-n
abd0: 61 6d 65 2e 0a 09 09 09 72 75 6e 2d 69 6e 66 6f ame.....run-info
abe0: 0a 09 09 09 28 64 62 3a 67 65 74 2d 76 61 6c 75 ....(db:get-valu
abf0: 65 2d 62 79 2d 68 65 61 64 65 72 20 28 64 62 3a e-by-header (db:
ac00: 67 65 74 2d 72 6f 77 73 20 72 75 6e 2d 69 6e 66 get-rows run-inf
ac10: 6f 29 0a 09 09 09 09 09 09 28 64 62 3a 67 65 74 o).......(db:get
ac20: 2d 68 65 61 64 65 72 20 72 75 6e 2d 69 6e 66 6f -header run-info
ac30: 29 0a 09 09 09 09 09 09 22 72 75 6e 6e 61 6d 65 )......."runname
ac40: 22 29 29 29 0a 09 20 3b 3b 20 63 6f 6e 76 65 72 "))).. ;; conver
ac50: 74 20 62 61 63 6b 20 74 6f 20 64 62 3a 20 66 72 t back to db: fr
ac60: 6f 6d 20 72 64 62 3a 20 2d 20 74 68 69 73 20 69 om rdb: - this i
ac70: 73 20 61 6c 77 61 79 73 20 72 75 6e 20 61 74 20 s always run at
ac80: 73 65 72 76 65 72 20 65 6e 64 0a 09 20 28 74 61 server end.. (ta
ac90: 72 67 65 74 20 20 20 28 73 74 72 69 6e 67 2d 69 rget (string-i
aca0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
acb0: 63 61 64 72 20 6b 65 79 76 61 6c 73 29 20 22 2f cadr keyvals) "/
acc0: 22 29 29 0a 0a 09 20 28 6e 6f 74 2d 69 74 65 72 "))... (not-iter
acd0: 61 74 65 64 20 20 28 65 71 75 61 6c 3f 20 22 22 ated (equal? ""
ace0: 20 69 74 65 6d 2d 70 61 74 68 29 29 0a 0a 09 20 item-path))...
acf0: 3b 3b 20 61 6c 6c 20 74 65 73 74 73 20 61 72 65 ;; all tests are
ad00: 20 66 6f 75 6e 64 20 61 74 20 3c 72 75 6e 64 69 found at <rundi
ad10: 72 3e 2f 74 65 73 74 2d 62 61 73 65 20 6f 72 20 r>/test-base or
ad20: 3c 6c 69 6e 6b 64 69 72 3e 2f 74 65 73 74 2d 62 <linkdir>/test-b
ad30: 61 73 65 0a 09 20 28 74 65 73 74 74 6f 70 2d 62 ase.. (testtop-b
ad40: 61 73 65 20 28 63 6f 6e 63 20 74 61 72 67 65 74 ase (conc target
ad50: 20 22 2f 22 20 72 75 6e 6e 61 6d 65 20 22 2f 22 "/" runname "/"
ad60: 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 20 28 74 testname)).. (t
ad70: 65 73 74 2d 62 61 73 65 20 20 20 20 28 63 6f 6e est-base (con
ad80: 63 20 74 65 73 74 74 6f 70 2d 62 61 73 65 20 28 c testtop-base (
ad90: 69 66 20 6e 6f 74 2d 69 74 65 72 61 74 65 64 20 if not-iterated
ada0: 22 22 20 22 2f 22 29 20 69 74 65 6d 2d 70 61 74 "" "/") item-pat
adb0: 68 29 29 0a 0a 09 20 3b 3b 20 6e 62 2f 2f 20 69 h))... ;; nb// i
adc0: 66 20 69 74 65 6d 70 61 74 68 20 69 73 20 6e 6f f itempath is no
add0: 74 20 22 22 20 74 68 65 6e 20 69 74 20 69 73 20 t "" then it is
ade0: 70 72 65 66 69 78 65 64 20 77 69 74 68 20 22 2f prefixed with "/
adf0: 22 0a 09 20 28 74 6f 70 74 65 73 74 2d 70 61 74 ".. (toptest-pat
ae00: 68 20 28 63 6f 6e 63 20 64 69 73 6b 2d 70 61 74 h (conc disk-pat
ae10: 68 20 22 2f 22 20 74 65 73 74 74 6f 70 2d 62 61 h "/" testtop-ba
ae20: 73 65 29 29 0a 09 20 28 74 65 73 74 2d 70 61 74 se)).. (test-pat
ae30: 68 20 20 20 20 28 63 6f 6e 63 20 64 69 73 6b 2d h (conc disk-
ae40: 70 61 74 68 20 22 2f 22 20 74 65 73 74 2d 62 61 path "/" test-ba
ae50: 73 65 29 29 0a 0a 09 20 3b 3b 20 65 6e 73 75 72 se))... ;; ensur
ae60: 65 20 74 68 69 73 20 65 78 69 73 74 73 20 66 69 e this exists fi
ae70: 72 73 74 20 61 73 20 6c 69 6e 6b 73 20 74 6f 20 rst as links to
ae80: 73 75 62 74 65 73 74 73 20 6d 75 73 74 20 62 65 subtests must be
ae90: 20 63 72 65 61 74 65 64 20 74 68 65 72 65 0a 09 created there..
aea0: 20 28 6c 69 6e 6b 74 72 65 65 20 20 28 6c 65 74 (linktree (let
aeb0: 20 28 28 72 64 20 28 63 6f 6e 66 69 67 2d 6c 6f ((rd (config-lo
aec0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
aed0: 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 "setup" "linktr
aee0: 65 65 22 29 29 29 0a 09 09 20 20 20 20 20 20 28 ee")))... (
aef0: 69 66 20 72 64 20 72 64 20 28 63 6f 6e 63 20 2a if rd rd (conc *
af00: 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 73 22 toppath* "/runs"
af10: 29 29 29 29 0a 0a 09 20 28 6c 6e 6b 62 61 73 65 ))))... (lnkbase
af20: 20 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 (conc linktre
af30: 65 20 22 2f 22 20 74 61 72 67 65 74 20 22 2f 22 e "/" target "/"
af40: 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 28 6c 6e runname)).. (ln
af50: 6b 70 61 74 68 20 20 20 28 63 6f 6e 63 20 6c 6e kpath (conc ln
af60: 6b 62 61 73 65 20 22 2f 22 20 74 65 73 74 6e 61 kbase "/" testna
af70: 6d 65 29 29 0a 09 20 28 6c 6e 6b 70 61 74 68 66 me)).. (lnkpathf
af80: 20 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 68 20 (conc lnkpath
af90: 28 69 66 20 6e 6f 74 2d 69 74 65 72 61 74 65 64 (if not-iterated
afa0: 20 22 22 20 22 2f 22 29 20 69 74 65 6d 2d 70 61 "" "/") item-pa
afb0: 74 68 29 29 0a 09 20 28 6c 6e 6b 74 61 72 67 65 th)).. (lnktarge
afc0: 74 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 68 20 t (conc lnkpath
afd0: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
afe0: 0a 0a 20 20 20 20 3b 3b 20 55 70 64 61 74 65 20 .. ;; Update
aff0: 74 68 65 20 72 75 6e 64 69 72 20 70 61 74 68 20 the rundir path
b000: 69 6e 20 74 68 65 20 74 65 73 74 20 72 65 63 6f in the test reco
b010: 72 64 20 66 6f 72 20 61 6c 6c 2c 20 72 75 6e 64 rd for all, rund
b020: 69 72 3d 70 68 79 73 69 63 61 6c 2c 20 73 68 6f ir=physical, sho
b030: 72 74 64 69 72 3d 6c 6f 67 69 63 61 6c 0a 20 20 rtdir=logical.
b040: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
b050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b070: 20 20 20 20 20 72 75 6e 64 69 72 20 20 20 73 68 rundir sh
b080: 6f 72 74 64 69 72 0a 20 20 20 20 28 72 6d 74 3a ortdir. (rmt:
b090: 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 74 65 general-call 'te
b0a0: 73 74 2d 73 65 74 2d 72 75 6e 64 69 72 2d 73 68 st-set-rundir-sh
b0b0: 6f 72 74 64 69 72 20 72 75 6e 2d 69 64 20 6c 6e ortdir run-id ln
b0c0: 6b 70 61 74 68 66 20 74 65 73 74 2d 70 61 74 68 kpathf test-path
b0d0: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 2d 70 testname item-p
b0e0: 61 74 68 20 72 75 6e 2d 69 64 29 0a 0a 20 20 20 ath run-id)..
b0f0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
b100: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
b110: 74 2a 20 22 49 4e 46 4f 3a 5c 6e 20 20 20 20 20 t* "INFO:\n
b120: 20 20 6c 6e 6b 62 61 73 65 3d 22 20 6c 6e 6b 62 lnkbase=" lnkb
b130: 61 73 65 20 22 5c 6e 20 20 20 20 20 20 20 6c 6e ase "\n ln
b140: 6b 70 61 74 68 3d 22 20 6c 6e 6b 70 61 74 68 20 kpath=" lnkpath
b150: 22 5c 6e 20 20 74 6f 70 74 65 73 74 2d 70 61 74 "\n toptest-pat
b160: 68 3d 22 20 74 6f 70 74 65 73 74 2d 70 61 74 68 h=" toptest-path
b170: 20 22 5c 6e 20 20 20 20 20 74 65 73 74 2d 70 61 "\n test-pa
b180: 74 68 3d 22 20 74 65 73 74 2d 70 61 74 68 29 0a th=" test-path).
b190: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 (if (not (fi
b1a0: 6c 65 2d 65 78 69 73 74 73 3f 20 6c 69 6e 6b 74 le-exists? linkt
b1b0: 72 65 65 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 ree))..(begin..
b1c0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
b1d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
b1e0: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6c 69 6e t* "WARNING: lin
b1f0: 6b 74 72 65 65 20 64 69 64 20 6e 6f 74 20 65 78 ktree did not ex
b200: 69 73 74 21 20 43 72 65 61 74 69 6e 67 20 69 74 ist! Creating it
b210: 20 6e 6f 77 20 61 74 20 22 20 6c 69 6e 6b 74 72 now at " linktr
b220: 65 65 29 0a 09 20 20 28 63 72 65 61 74 65 2d 64 ee).. (create-d
b230: 69 72 65 63 74 6f 72 79 20 6c 69 6e 6b 74 72 65 irectory linktre
b240: 65 20 23 74 29 29 29 20 3b 3b 20 28 73 79 73 74 e #t))) ;; (syst
b250: 65 6d 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 em (conc "mkdir
b260: 2d 70 20 22 20 6c 69 6e 6b 74 72 65 65 29 29 29 -p " linktree)))
b270: 29 0a 20 20 20 20 3b 3b 20 63 72 65 61 74 65 20 ). ;; create
b280: 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 66 6f the directory fo
b290: 72 20 74 68 65 20 74 65 73 74 73 20 64 69 72 20 r the tests dir
b2a0: 6c 69 6e 6b 73 2c 20 74 68 69 73 20 69 73 20 6e links, this is n
b2b0: 65 65 64 65 64 20 6e 6f 20 6d 61 74 74 65 72 20 eeded no matter
b2c0: 77 68 61 74 2e 2e 2e 0a 20 20 20 20 28 69 66 20 what.... (if
b2d0: 28 61 6e 64 20 28 6e 6f 74 20 28 64 69 72 65 63 (and (not (direc
b2e0: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 6c 6e 6b tory-exists? lnk
b2f0: 62 61 73 65 29 29 0a 09 20 20 20 20 20 28 6e 6f base)).. (no
b300: 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 t (file-exists?
b310: 6c 6e 6b 62 61 73 65 29 29 29 0a 09 28 68 61 6e lnkbase)))..(han
b320: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
b330: 20 65 78 6e 0a 09 20 28 62 65 67 69 6e 0a 09 20 exn.. (begin..
b340: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
b350: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
b360: 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 72 6f 62 6c log-port* "Probl
b370: 65 6d 20 63 72 65 61 74 69 6e 67 20 6c 69 6e 6b em creating link
b380: 74 72 65 65 20 62 61 73 65 20 61 74 20 22 20 6c tree base at " l
b390: 6e 6b 62 61 73 65 29 0a 09 20 20 20 28 70 72 69 nkbase).. (pri
b3a0: 6e 74 2d 65 72 72 6f 72 2d 6d 65 73 73 61 67 65 nt-error-message
b3b0: 20 65 78 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 exn (current-er
b3c0: 72 6f 72 2d 70 6f 72 74 29 29 29 0a 09 20 28 63 ror-port))).. (c
b3d0: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
b3e0: 6c 6e 6b 62 61 73 65 20 23 74 29 29 29 0a 20 20 lnkbase #t))).
b3f0: 20 20 0a 20 20 20 20 3b 3b 20 75 70 64 61 74 65 . ;; update
b400: 20 74 68 65 20 74 6f 70 74 65 73 74 20 72 65 63 the toptest rec
b410: 6f 72 64 20 77 69 74 68 20 69 74 73 20 6c 6f 63 ord with its loc
b420: 61 74 69 6f 6e 20 72 75 6e 64 69 72 2c 20 63 61 ation rundir, ca
b430: 63 68 65 20 74 68 65 20 70 61 74 68 0a 20 20 20 che the path.
b440: 20 3b 3b 20 54 68 69 73 20 77 61 73 73 20 68 69 ;; This wass hi
b450: 67 68 6c 79 20 69 6e 65 66 66 69 63 69 65 6e 74 ghly inefficient
b460: 2c 20 6f 6e 65 20 64 62 20 77 72 69 74 65 20 66 , one db write f
b470: 6f 72 20 65 76 65 72 79 20 73 75 62 74 65 73 74 or every subtest
b480: 2c 20 70 6f 74 65 6e 74 69 61 6c 6c 79 0a 20 20 , potentially.
b490: 20 20 3b 3b 20 74 68 6f 75 73 61 6e 64 73 20 6f ;; thousands o
b4a0: 66 20 75 6e 6e 65 63 65 73 73 61 72 79 20 75 70 f unnecessary up
b4b0: 64 61 74 65 73 2c 20 63 61 63 68 65 20 74 68 65 dates, cache the
b4c0: 20 66 61 63 74 20 69 74 20 77 61 73 20 73 65 74 fact it was set
b4d0: 20 61 6e 64 20 64 6f 6e 27 74 20 73 65 74 20 69 and don't set i
b4e0: 74 20 0a 20 20 20 20 3b 3b 20 61 67 61 69 6e 2e t . ;; again.
b4f0: 20 0a 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 63 72 .. ;; Now cr
b500: 65 61 74 65 20 74 68 65 20 6c 69 6e 6b 20 66 72 eate the link fr
b510: 6f 6d 20 74 68 65 20 74 65 73 74 20 70 61 74 68 om the test path
b520: 20 74 6f 20 74 68 65 20 6c 69 6e 6b 20 74 72 65 to the link tre
b530: 65 2c 20 68 6f 77 65 76 65 72 0a 20 20 20 20 3b e, however. ;
b540: 3b 20 69 66 20 74 68 65 20 74 65 73 74 20 69 73 ; if the test is
b550: 20 69 74 65 72 61 74 65 64 20 69 74 20 69 73 20 iterated it is
b560: 6e 65 63 65 73 73 61 72 79 20 74 6f 20 63 72 65 necessary to cre
b570: 61 74 65 20 74 68 65 20 70 61 72 65 6e 74 20 70 ate the parent p
b580: 61 74 68 0a 20 20 20 20 3b 3b 20 74 6f 20 74 68 ath. ;; to th
b590: 65 20 69 74 65 72 61 74 69 6f 6e 2e 20 75 73 65 e iteration. use
b5a0: 20 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 pathname-direct
b5b0: 6f 72 79 20 74 6f 20 74 72 69 6d 20 74 68 65 20 ory to trim the
b5c0: 70 61 74 68 20 62 79 20 6f 6e 65 0a 20 20 20 20 path by one.
b5d0: 3b 3b 20 6c 65 76 65 6c 0a 20 20 20 20 28 69 66 ;; level. (if
b5e0: 20 28 6e 6f 74 20 6e 6f 74 2d 69 74 65 72 61 74 (not not-iterat
b5f0: 65 64 29 20 3b 3b 20 69 2e 65 2e 20 69 74 65 72 ed) ;; i.e. iter
b600: 61 74 65 64 0a 09 28 6c 65 74 20 28 28 69 74 65 ated..(let ((ite
b610: 72 61 74 65 64 2d 70 61 72 65 6e 74 20 20 28 70 rated-parent (p
b620: 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 athname-director
b630: 79 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 68 20 y (conc lnkpath
b640: 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 "/" item-path)))
b650: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
b660: 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
b670: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 72 65 t-log-port* "Cre
b680: 61 74 69 6e 67 20 69 74 65 72 61 74 65 64 20 70 ating iterated p
b690: 61 72 65 6e 74 20 22 20 69 74 65 72 61 74 65 64 arent " iterated
b6a0: 2d 70 61 72 65 6e 74 29 0a 09 20 20 28 68 61 6e -parent).. (han
b6b0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
b6c0: 20 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 69 exn.. (begi
b6d0: 6e 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 n.. (debug:p
b6e0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
b6f0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
b700: 22 20 46 61 69 6c 65 64 20 74 6f 20 63 72 65 61 " Failed to crea
b710: 74 65 20 64 69 72 65 63 74 6f 72 79 20 22 20 69 te directory " i
b720: 74 65 72 61 74 65 64 2d 70 61 72 65 6e 74 20 28 terated-parent (
b730: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
b740: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
b750: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
b760: 20 22 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 ", exiting")..
b770: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 (exit 1))..
b780: 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 (create-direct
b790: 6f 72 79 20 69 74 65 72 61 74 65 64 2d 70 61 72 ory iterated-par
b7a0: 65 6e 74 20 23 74 29 29 29 29 0a 0a 20 20 20 20 ent #t))))..
b7b0: 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 (if (symbolic-li
b7c0: 6e 6b 3f 20 6c 6e 6b 70 61 74 68 29 20 0a 09 28 nk? lnkpath) ..(
b7d0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
b7e0: 73 0a 09 20 65 78 6e 0a 09 20 28 62 65 67 69 6e s.. exn.. (begin
b7f0: 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
b800: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
b810: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 46 lt-log-port* " F
b820: 61 69 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 ailed to remove
b830: 73 79 6d 6c 69 6e 6b 20 22 20 6c 6e 6b 70 61 74 symlink " lnkpat
b840: 68 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 h ((condition-pr
b850: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
b860: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
b870: 78 6e 29 20 22 2c 20 65 78 69 74 69 6e 67 22 29 xn) ", exiting")
b880: 0a 09 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 .. (exit 1))..
b890: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 6c 6e (delete-file ln
b8a0: 6b 70 61 74 68 29 29 29 0a 0a 20 20 20 20 28 69 kpath))).. (i
b8b0: 66 20 28 6e 6f 74 20 28 6f 72 20 28 66 69 6c 65 f (not (or (file
b8c0: 2d 65 78 69 73 74 73 3f 20 6c 6e 6b 70 61 74 68 -exists? lnkpath
b8d0: 29 0a 09 09 20 28 73 79 6d 62 6f 6c 69 63 2d 6c )... (symbolic-l
b8e0: 69 6e 6b 3f 20 6c 6e 6b 70 61 74 68 29 29 29 0a ink? lnkpath))).
b8f0: 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 .(handle-excepti
b900: 6f 6e 73 0a 09 20 65 78 6e 0a 09 20 28 62 65 67 ons.. exn.. (beg
b910: 69 6e 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 in.. (debug:pr
b920: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
b930: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
b940: 20 46 61 69 6c 65 64 20 74 6f 20 63 72 65 61 74 Failed to creat
b950: 65 20 73 79 6d 6c 69 6e 6b 20 22 20 6c 6e 6b 70 e symlink " lnkp
b960: 61 74 68 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d ath ((condition-
b970: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
b980: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
b990: 20 65 78 6e 29 20 22 2c 20 65 78 69 74 69 6e 67 exn) ", exiting
b9a0: 22 29 0a 09 20 20 20 28 65 78 69 74 20 31 29 29 ").. (exit 1))
b9b0: 0a 09 20 28 63 72 65 61 74 65 2d 73 79 6d 62 6f .. (create-symbo
b9c0: 6c 69 63 2d 6c 69 6e 6b 20 74 6f 70 74 65 73 74 lic-link toptest
b9d0: 2d 70 61 74 68 20 6c 6e 6b 70 61 74 68 29 29 29 -path lnkpath)))
b9e0: 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 4e 42 20 . . ;; NB
b9f0: 2d 20 54 68 69 73 20 77 61 73 20 6e 6f 74 20 77 - This was not w
ba00: 6f 72 6b 69 6e 67 20 72 69 67 68 74 20 2d 20 73 orking right - s
ba10: 6f 6d 65 20 74 6f 70 20 74 65 73 74 73 20 61 72 ome top tests ar
ba20: 65 20 6e 6f 74 20 67 65 74 74 69 6e 67 20 74 68 e not getting th
ba30: 65 20 70 61 74 68 20 73 65 74 21 21 21 0a 20 20 e path set!!!.
ba40: 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 44 6f 20 74 ;;. ;; Do t
ba50: 68 65 20 73 65 74 74 69 6e 67 20 6f 66 20 74 68 he setting of th
ba60: 69 73 20 72 65 63 6f 72 64 20 61 66 74 65 72 20 is record after
ba70: 74 68 65 20 70 61 74 68 73 20 61 72 65 20 63 72 the paths are cr
ba80: 65 61 74 65 64 20 73 6f 20 74 68 61 74 20 74 68 eated so that th
ba90: 65 20 73 68 6f 72 74 64 69 72 20 63 61 6e 20 0a e shortdir can .
baa0: 20 20 20 20 3b 3b 20 62 65 20 73 65 74 20 74 6f ;; be set to
bab0: 20 74 68 65 20 72 65 61 6c 20 64 69 72 65 63 74 the real direct
bac0: 6f 72 79 20 6c 6f 63 61 74 69 6f 6e 2e 20 54 68 ory location. Th
bad0: 69 73 20 69 73 20 73 61 66 65 72 20 66 6f 72 20 is is safer for
bae0: 66 75 74 75 72 65 20 63 6c 65 61 6e 20 75 70 20 future clean up
baf0: 69 66 20 74 68 65 20 6c 69 6e 6b 0a 20 20 20 20 if the link.
bb00: 3b 3b 20 74 72 65 65 20 69 73 20 64 61 6d 61 67 ;; tree is damag
bb10: 65 64 20 6f 72 20 6c 6f 73 74 2e 0a 20 20 20 20 ed or lost..
bb20: 3b 3b 20 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 ;; . (if (not
bb30: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
bb40: 2f 64 65 66 61 75 6c 74 20 2a 74 6f 70 74 65 73 /default *toptes
bb50: 74 2d 70 61 74 68 73 2a 20 74 65 73 74 6e 61 6d t-paths* testnam
bb60: 65 20 23 66 29 29 0a 09 28 6c 65 74 2a 20 28 28 e #f))..(let* ((
bb70: 74 65 73 74 69 6e 66 6f 20 20 20 20 20 20 20 28 testinfo (
bb80: 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 rmt:get-test-inf
bb90: 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 o-by-id run-id t
bba0: 65 73 74 2d 69 64 29 29 20 3b 3b 20 20 72 75 6e est-id)) ;; run
bbb0: 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 -id testname ite
bbc0: 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 m-path))..
bbd0: 20 28 63 75 72 72 2d 74 65 73 74 2d 70 61 74 68 (curr-test-path
bbe0: 20 28 69 66 20 74 65 73 74 69 6e 66 6f 20 3b 3b (if testinfo ;;
bbf0: 20 28 66 69 6c 65 64 62 3a 67 65 74 2d 70 61 74 (filedb:get-pat
bc00: 68 20 2a 66 64 62 2a 0a 09 09 09 09 09 09 09 20 h *fdb*........
bc10: 20 20 20 20 3b 3b 20 28 64 62 3a 67 65 74 2d 70 ;; (db:get-p
bc20: 61 74 68 20 64 62 73 74 72 75 63 74 0a 09 09 09 ath dbstruct....
bc30: 09 20 20 20 3b 3b 20 28 72 6d 74 3a 73 64 62 2d . ;; (rmt:sdb-
bc40: 71 72 79 20 27 67 65 74 73 74 72 20 0a 09 09 09 qry 'getstr ....
bc50: 09 20 20 20 28 64 62 3a 74 65 73 74 2d 67 65 74 . (db:test-get
bc60: 2d 72 75 6e 64 69 72 20 74 65 73 74 69 6e 66 6f -rundir testinfo
bc70: 29 20 3b 3b 20 29 20 3b 3b 20 29 0a 09 09 09 09 ) ;; ) ;; ).....
bc80: 20 20 20 23 66 29 29 29 0a 09 20 20 28 68 61 73 #f))).. (has
bc90: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 74 6f h-table-set! *to
bca0: 70 74 65 73 74 2d 70 61 74 68 73 2a 20 74 65 73 ptest-paths* tes
bcb0: 74 6e 61 6d 65 20 63 75 72 72 2d 74 65 73 74 2d tname curr-test-
bcc0: 70 61 74 68 29 0a 09 20 20 3b 3b 20 4e 42 2f 2f path).. ;; NB//
bcd0: 20 57 61 73 20 74 68 69 73 20 66 6f 72 20 74 68 Was this for th
bce0: 65 20 74 65 73 74 20 6f 72 20 66 6f 72 20 74 68 e test or for th
bcf0: 65 20 70 61 72 65 6e 74 20 69 6e 20 61 6e 20 69 e parent in an i
bd00: 74 65 72 61 74 65 64 20 74 65 73 74 3f 0a 09 20 terated test?..
bd10: 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
bd20: 6c 6c 20 27 74 65 73 74 2d 73 65 74 2d 72 75 6e ll 'test-set-run
bd30: 64 69 72 2d 73 68 6f 72 74 64 69 72 20 72 75 6e dir-shortdir run
bd40: 2d 69 64 20 6c 6e 6b 70 61 74 68 20 0a 09 09 09 -id lnkpath ....
bd50: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
bd60: 69 73 74 73 3f 20 6c 6e 6b 70 61 74 68 29 0a 09 ists? lnkpath)..
bd70: 09 09 09 3b 3b 20 28 72 65 73 6f 6c 76 65 2d 70 ...;; (resolve-p
bd80: 61 74 68 6e 61 6d 65 20 6c 6e 6b 70 61 74 68 29 athname lnkpath)
bd90: 0a 09 09 09 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 .....(common:nic
bda0: 65 2d 70 61 74 68 20 6c 6e 6b 70 61 74 68 29 0a e-path lnkpath).
bdb0: 09 09 09 09 6c 6e 6b 70 61 74 68 29 0a 09 09 09 ....lnkpath)....
bdc0: 20 20 20 20 74 65 73 74 6e 61 6d 65 20 22 22 20 testname ""
bdd0: 72 75 6e 2d 69 64 29 0a 09 20 20 3b 3b 20 28 72 run-id).. ;; (r
bde0: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
bdf0: 27 74 65 73 74 2d 73 65 74 2d 72 75 6e 64 69 72 'test-set-rundir
be00: 20 72 75 6e 2d 69 64 20 6c 6e 6b 70 61 74 68 20 run-id lnkpath
be10: 74 65 73 74 6e 61 6d 65 20 22 22 29 20 3b 3b 20 testname "") ;;
be20: 74 6f 70 74 65 73 74 2d 70 61 74 68 29 0a 09 20 toptest-path)..
be30: 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 63 75 (if (or (not cu
be40: 72 72 2d 74 65 73 74 2d 70 61 74 68 29 0a 09 09 rr-test-path)...
be50: 20 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 (not (director
be60: 79 2d 65 78 69 73 74 73 3f 20 74 6f 70 74 65 73 y-exists? toptes
be70: 74 2d 70 61 74 68 29 29 29 0a 09 20 20 20 20 20 t-path)))..
be80: 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 67 (begin...(debug
be90: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
bea0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
beb0: 20 22 43 72 65 61 74 69 6e 67 20 22 20 74 6f 70 "Creating " top
bec0: 74 65 73 74 2d 70 61 74 68 20 22 20 61 6e 64 20 test-path " and
bed0: 6c 69 6e 6b 20 22 20 6c 6e 6b 70 61 74 68 29 0a link " lnkpath).
bee0: 09 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 ..(handle-except
bef0: 69 6f 6e 73 0a 09 09 20 65 78 6e 0a 09 09 20 23 ions... exn... #
bf00: 66 20 3b 3b 20 64 6f 6e 27 74 20 63 61 72 65 20 f ;; don't care
bf10: 74 6f 20 63 61 74 63 68 20 61 6e 64 20 64 65 61 to catch and dea
bf20: 6c 20 77 69 74 68 20 65 72 72 6f 72 73 20 68 65 l with errors he
bf30: 72 65 20 66 6f 72 20 6e 6f 77 2e 0a 09 09 20 28 re for now.... (
bf40: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
bf50: 20 74 6f 70 74 65 73 74 2d 70 61 74 68 20 23 74 toptest-path #t
bf60: 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 ))...(hash-table
bf70: 2d 73 65 74 21 20 2a 74 6f 70 74 65 73 74 2d 70 -set! *toptest-p
bf80: 61 74 68 73 2a 20 74 65 73 74 6e 61 6d 65 20 74 aths* testname t
bf90: 6f 70 74 65 73 74 2d 70 61 74 68 29 29 29 29 29 optest-path)))))
bfa0: 0a 0a 20 20 20 20 3b 3b 20 54 68 65 20 74 6f 70 .. ;; The top
bfb0: 74 65 73 74 20 70 61 74 68 20 68 61 73 20 62 65 test path has be
bfc0: 65 6e 20 63 72 65 61 74 65 64 2c 20 74 68 65 20 en created, the
bfd0: 6c 69 6e 6b 20 74 6f 20 74 68 65 20 74 65 73 74 link to the test
bfe0: 20 69 6e 20 74 68 65 20 6c 69 6e 6b 74 72 65 65 in the linktree
bff0: 20 68 61 73 0a 20 20 20 20 3b 3b 20 62 65 65 6e has. ;; been
c000: 20 63 72 65 61 74 65 64 2e 20 4e 6f 77 2c 20 69 created. Now, i
c010: 66 20 74 68 69 73 20 69 73 20 61 6e 20 69 74 65 f this is an ite
c020: 72 61 74 65 64 20 74 65 73 74 20 74 68 65 20 72 rated test the r
c030: 65 61 6c 20 74 65 73 74 20 64 69 72 20 6d 75 73 eal test dir mus
c040: 74 20 62 65 20 63 72 65 61 74 65 64 0a 20 20 20 t be created.
c050: 20 28 69 66 20 28 6e 6f 74 20 6e 6f 74 2d 69 74 (if (not not-it
c060: 65 72 61 74 65 64 29 20 3b 3b 20 74 68 69 73 20 erated) ;; this
c070: 69 73 20 61 6e 20 69 74 65 72 61 74 65 64 20 74 is an iterated t
c080: 65 73 74 0a 09 28 62 65 67 69 6e 20 3b 3b 20 28 est..(begin ;; (
c090: 6c 65 74 20 28 28 6c 6e 6b 74 61 72 67 65 74 20 let ((lnktarget
c0a0: 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 68 20 22 2f (conc lnkpath "/
c0b0: 22 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 09 " item-path)))..
c0c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2
c0d0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
c0e0: 72 74 2a 20 22 53 65 74 74 69 6e 67 20 75 70 20 rt* "Setting up
c0f0: 73 75 62 20 74 65 73 74 20 72 75 6e 20 61 72 65 sub test run are
c100: 61 22 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 a").. (debug:pr
c110: 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c int 2 *default-l
c120: 6f 67 2d 70 6f 72 74 2a 20 22 20 2d 20 63 72 65 og-port* " - cre
c130: 61 74 69 6e 67 20 72 75 6e 20 61 72 65 61 20 69 ating run area i
c140: 6e 20 22 20 74 65 73 74 2d 70 61 74 68 29 0a 09 n " test-path)..
c150: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
c160: 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 ions.. exn..
c170: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 28 64 (begin.. (d
c180: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
c190: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
c1a0: 70 6f 72 74 2a 20 22 20 46 61 69 6c 65 64 20 74 port* " Failed t
c1b0: 6f 20 63 72 65 61 74 65 20 64 69 72 65 63 74 6f o create directo
c1c0: 72 79 20 22 20 74 65 73 74 2d 70 61 74 68 20 28 ry " test-path (
c1d0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
c1e0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
c1f0: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
c200: 20 22 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 ", exiting")..
c210: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 20 (exit 1))..
c220: 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 (create-direct
c230: 6f 72 79 20 74 65 73 74 2d 70 61 74 68 20 23 74 ory test-path #t
c240: 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 )).. (debug:pri
c250: 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 2 *default-lo
c260: 67 2d 70 6f 72 74 2a 20 0a 09 09 20 20 20 20 20 g-port* ...
c270: 20 20 22 20 2d 20 63 72 65 61 74 69 6e 67 20 6c " - creating l
c280: 69 6e 6b 20 66 72 6f 6d 3a 20 22 20 74 65 73 74 ink from: " test
c290: 2d 70 61 74 68 20 22 5c 6e 22 0a 09 09 20 20 20 -path "\n"...
c2a0: 20 20 20 20 22 20 20 20 20 20 20 20 20 20 20 20 "
c2b0: 20 20 20 20 20 20 20 20 74 6f 3a 20 22 20 6c 6e to: " ln
c2c0: 6b 74 61 72 67 65 74 29 0a 0a 09 20 20 3b 3b 20 ktarget)... ;;
c2d0: 49 66 20 74 68 65 72 65 20 69 73 20 61 6c 72 65 If there is alre
c2e0: 61 64 79 20 61 20 73 79 6d 6c 69 6e 6b 20 64 65 ady a symlink de
c2f0: 6c 65 74 65 20 69 74 20 61 6e 64 20 72 65 63 72 lete it and recr
c300: 65 61 74 65 20 69 74 2e 0a 09 20 20 28 68 61 6e eate it... (han
c310: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
c320: 20 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 69 exn.. (begi
c330: 6e 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 n.. (debug:p
c340: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
c350: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
c360: 22 20 46 61 69 6c 65 64 20 74 6f 20 72 65 2d 63 " Failed to re-c
c370: 72 65 61 74 65 20 6c 69 6e 6b 20 22 20 6c 6e 6b reate link " lnk
c380: 74 61 72 67 65 74 20 28 28 63 6f 6e 64 69 74 69 target ((conditi
c390: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
c3a0: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
c3b0: 67 65 29 20 65 78 6e 29 20 22 2c 20 65 78 69 74 ge) exn) ", exit
c3c0: 69 6e 67 22 29 0a 09 20 20 20 20 20 28 65 78 69 ing").. (exi
c3d0: 74 29 29 0a 09 20 20 20 28 69 66 20 28 73 79 6d t)).. (if (sym
c3e0: 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 6c 6e 6b 74 bolic-link? lnkt
c3f0: 61 72 67 65 74 29 20 20 20 20 20 28 64 65 6c 65 arget) (dele
c400: 74 65 2d 66 69 6c 65 20 6c 6e 6b 74 61 72 67 65 te-file lnktarge
c410: 74 29 29 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 t)).. (if (not
c420: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c (file-exists? l
c430: 6e 6b 74 61 72 67 65 74 29 29 20 28 63 72 65 61 nktarget)) (crea
c440: 74 65 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b te-symbolic-link
c450: 20 74 65 73 74 2d 70 61 74 68 20 6c 6e 6b 74 61 test-path lnkta
c460: 72 67 65 74 29 29 29 29 29 0a 0a 20 20 20 20 28 rget))))).. (
c470: 69 66 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f if (not (directo
c480: 72 79 3f 20 74 65 73 74 2d 70 61 74 68 29 29 0a ry? test-path)).
c490: 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f .(create-directo
c4a0: 72 79 20 74 65 73 74 2d 70 61 74 68 20 23 74 29 ry test-path #t)
c4b0: 29 20 3b 3b 20 74 68 69 73 20 69 73 20 61 20 68 ) ;; this is a h
c4c0: 61 63 6b 2c 20 49 20 64 6f 6e 27 74 20 6b 6e 6f ack, I don't kno
c4d0: 77 20 77 68 79 20 6f 75 74 20 6f 66 20 74 68 65 w why out of the
c4e0: 20 62 6c 75 65 20 74 68 69 73 20 70 61 74 68 20 blue this path
c4f0: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 20 73 does not exist s
c500: 6f 6d 65 74 69 6d 65 73 0a 0a 20 20 20 20 28 69 ometimes.. (i
c510: 66 20 28 61 6e 64 20 74 65 73 74 2d 73 72 63 2d f (and test-src-
c520: 70 61 74 68 20 28 64 69 72 65 63 74 6f 72 79 3f path (directory?
c530: 20 74 65 73 74 2d 70 61 74 68 29 29 0a 09 28 62 test-path))..(b
c540: 65 67 69 6e 0a 09 20 20 28 6c 65 74 2a 20 28 28 egin.. (let* ((
c550: 6f 76 72 63 6d 64 20 28 6c 65 74 20 28 28 63 6d ovrcmd (let ((cm
c560: 64 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 d (config-lookup
c570: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
c580: 74 75 70 22 20 22 74 65 73 74 63 6f 70 79 63 6d tup" "testcopycm
c590: 64 22 29 29 29 0a 09 09 09 20 20 20 28 69 66 20 d"))).... (if
c5a0: 63 6d 64 0a 09 09 09 20 20 20 20 20 20 20 3b 3b cmd.... ;;
c5b0: 20 73 75 62 73 74 69 74 75 74 65 20 74 68 65 20 substitute the
c5c0: 54 45 53 54 5f 53 52 43 5f 50 41 54 48 20 61 6e TEST_SRC_PATH an
c5d0: 64 20 54 45 53 54 5f 54 41 52 47 5f 50 41 54 48 d TEST_TARG_PATH
c5e0: 0a 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 .... (stri
c5f0: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 54 ng-substitute "T
c600: 45 53 54 5f 54 41 52 47 5f 50 41 54 48 22 20 74 EST_TARG_PATH" t
c610: 65 73 74 2d 70 61 74 68 0a 09 09 09 09 09 09 20 est-path.......
c620: 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 (string-substit
c630: 75 74 65 20 22 54 45 53 54 5f 53 52 43 5f 50 41 ute "TEST_SRC_PA
c640: 54 48 22 20 74 65 73 74 2d 73 72 63 2d 70 61 74 TH" test-src-pat
c650: 68 20 63 6d 64 20 23 74 29 20 23 74 29 0a 09 09 h cmd #t) #t)...
c660: 09 20 20 20 20 20 20 20 23 66 29 29 29 0a 09 09 . #f)))...
c670: 20 28 63 6d 64 20 20 20 20 28 69 66 20 6f 76 72 (cmd (if ovr
c680: 63 6d 64 20 0a 09 09 09 20 20 20 20 20 6f 76 72 cmd .... ovr
c690: 63 6d 64 0a 09 09 09 20 20 20 20 20 28 63 6f 6e cmd.... (con
c6a0: 63 20 22 72 73 79 6e 63 20 2d 61 76 22 20 28 69 c "rsync -av" (i
c6b0: 66 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d f (debug:debug-m
c6c0: 6f 64 65 20 31 29 20 22 22 20 22 71 22 29 20 22 ode 1) "" "q") "
c6d0: 20 22 20 74 65 73 74 2d 73 72 63 2d 70 61 74 68 " test-src-path
c6e0: 20 22 2f 20 22 20 74 65 73 74 2d 70 61 74 68 20 "/ " test-path
c6f0: 22 2f 22 0a 09 09 09 09 20 20 20 22 20 3e 3e 20 "/"..... " >>
c700: 22 20 74 65 73 74 2d 70 61 74 68 20 22 2f 6d 74 " test-path "/mt
c710: 5f 6c 61 75 6e 63 68 2e 6c 6f 67 20 32 3e 3e 20 _launch.log 2>>
c720: 22 20 74 65 73 74 2d 70 61 74 68 20 22 2f 6d 74 " test-path "/mt
c730: 5f 6c 61 75 6e 63 68 2e 6c 6f 67 22 29 29 29 0a _launch.log"))).
c740: 09 09 20 28 73 74 61 74 75 73 20 28 73 79 73 74 .. (status (syst
c750: 65 6d 20 63 6d 64 29 29 29 0a 09 20 20 20 20 28 em cmd))).. (
c760: 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 73 74 61 if (not (eq? sta
c770: 74 75 73 20 30 29 29 0a 09 09 28 64 65 62 75 67 tus 0))...(debug
c780: 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c :print 2 *defaul
c790: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 t-log-port* "ERR
c7a0: 4f 52 3a 20 70 72 6f 62 6c 65 6d 20 77 69 74 68 OR: problem with
c7b0: 20 72 75 6e 6e 69 6e 67 20 5c 22 22 20 63 6d 64 running \"" cmd
c7c0: 20 22 5c 22 22 29 29 29 0a 09 20 20 28 6c 69 73 "\""))).. (lis
c7d0: 74 20 6c 6e 6b 70 61 74 68 66 20 6c 6e 6b 70 61 t lnkpathf lnkpa
c7e0: 74 68 20 29 29 0a 09 28 69 66 20 28 61 6e 64 20 th ))..(if (and
c7f0: 74 65 73 74 2d 73 72 63 2d 70 61 74 68 20 28 3e test-src-path (>
c800: 20 72 65 6d 74 72 69 65 73 20 30 29 29 0a 09 20 remtries 0))..
c810: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
c820: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
c830: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
c840: 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 og-port* "Failed
c850: 20 74 6f 20 63 72 65 61 74 65 20 77 6f 72 6b 20 to create work
c860: 61 72 65 61 20 61 74 20 22 20 74 65 73 74 2d 70 area at " test-p
c870: 61 74 68 20 22 20 77 69 74 68 20 6c 69 6e 6b 20 ath " with link
c880: 61 74 20 22 20 6c 6e 6b 74 61 72 67 65 74 20 22 at " lnktarget "
c890: 2c 20 72 65 6d 61 69 6e 69 6e 67 20 61 74 74 65 , remaining atte
c8a0: 6d 70 74 73 20 22 20 72 65 6d 74 72 69 65 73 29 mpts " remtries)
c8b0: 0a 09 20 20 20 20 20 20 3b 3b 20 0a 09 20 20 20 .. ;; ..
c8c0: 20 20 20 28 63 72 65 61 74 65 2d 77 6f 72 6b 2d (create-work-
c8d0: 61 72 65 61 20 72 75 6e 2d 69 64 20 72 75 6e 2d area run-id run-
c8e0: 69 6e 66 6f 20 6b 65 79 76 61 6c 73 20 74 65 73 info keyvals tes
c8f0: 74 2d 69 64 20 74 65 73 74 2d 73 72 63 2d 70 61 t-id test-src-pa
c900: 74 68 20 64 69 73 6b 2d 70 61 74 68 20 74 65 73 th disk-path tes
c910: 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 20 72 65 tname itemdat re
c920: 6d 74 72 69 65 73 3a 20 28 2d 20 72 65 6d 74 72 mtries: (- remtr
c930: 69 65 73 20 31 29 29 29 0a 09 20 20 20 20 28 6c ies 1))).. (l
c940: 69 73 74 20 23 66 20 23 66 29 29 29 29 29 0a 0a ist #f #f)))))..
c950: 3b 3b 20 31 2e 20 6c 6f 6f 6b 20 74 68 6f 75 67 ;; 1. look thoug
c960: 68 20 64 69 73 6b 73 20 6c 69 73 74 20 66 6f 72 h disks list for
c970: 20 64 69 73 6b 20 77 69 74 68 20 6d 6f 73 74 20 disk with most
c980: 73 70 61 63 65 0a 3b 3b 20 32 2e 20 63 72 65 61 space.;; 2. crea
c990: 74 65 20 72 75 6e 20 64 69 72 20 6f 6e 20 64 69 te run dir on di
c9a0: 73 6b 2c 20 70 61 74 68 20 6e 61 6d 65 20 69 73 sk, path name is
c9b0: 20 6d 65 61 6e 69 6e 67 66 75 6c 0a 3b 3b 20 33 meaningful.;; 3
c9c0: 2e 20 63 72 65 61 74 65 20 6c 69 6e 6b 20 66 72 . create link fr
c9d0: 6f 6d 20 72 75 6e 20 64 69 72 20 74 6f 20 6d 65 om run dir to me
c9e0: 67 61 74 65 73 74 20 72 75 6e 73 20 61 72 65 61 gatest runs area
c9f0: 20 0a 3b 3b 20 34 2e 20 72 65 6d 6f 74 65 6c 79 .;; 4. remotely
ca00: 20 72 75 6e 20 74 68 65 20 74 65 73 74 20 6f 6e run the test on
ca10: 20 61 6c 6c 6f 63 61 74 65 64 20 68 6f 73 74 0a allocated host.
ca20: 3b 3b 20 20 20 20 2d 20 63 6f 75 6c 64 20 62 65 ;; - could be
ca30: 20 73 73 68 20 74 6f 20 68 6f 73 74 20 66 72 6f ssh to host fro
ca40: 6d 20 68 6f 73 74 73 20 74 61 62 6c 65 20 28 75 m hosts table (u
ca50: 70 64 61 74 65 20 72 65 67 75 6c 61 72 6c 79 20 pdate regularly
ca60: 77 69 74 68 20 6c 6f 61 64 29 0a 3b 3b 20 20 20 with load).;;
ca70: 20 2d 20 63 6f 75 6c 64 20 62 65 20 6e 65 74 62 - could be netb
ca80: 61 74 63 68 0a 3b 3b 20 20 20 20 20 20 28 6c 61 atch.;; (la
ca90: 75 6e 63 68 2d 74 65 73 74 20 64 62 20 28 63 61 unch-test db (ca
caa0: 64 72 20 73 74 61 74 75 73 29 20 74 65 73 74 2d dr status) test-
cab0: 63 6f 6e 66 29 29 0a 28 64 65 66 69 6e 65 20 28 conf)).(define (
cac0: 6c 61 75 6e 63 68 2d 74 65 73 74 20 74 65 73 74 launch-test test
cad0: 2d 69 64 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 -id run-id run-i
cae0: 6e 66 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e nfo keyvals runn
caf0: 61 6d 65 20 74 65 73 74 2d 63 6f 6e 66 20 74 65 ame test-conf te
cb00: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 st-name test-pat
cb10: 68 20 69 74 65 6d 64 61 74 20 70 61 72 61 6d 73 h itemdat params
cb20: 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 ). (mutex-lock!
cb30: 20 2a 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d *launch-setup-m
cb40: 75 74 65 78 2a 29 20 3b 3b 20 73 65 74 74 69 6e utex*) ;; settin
cb50: 67 20 76 61 72 69 61 62 6c 65 73 20 61 6e 64 20 g variables and
cb60: 70 72 6f 63 65 73 73 69 6e 67 20 74 68 65 20 74 processing the t
cb70: 65 73 74 63 6f 6e 66 69 67 20 69 73 20 4e 4f 54 estconfig is NOT
cb80: 20 74 68 72 65 61 64 2d 73 61 66 65 2c 20 72 65 thread-safe, re
cb90: 75 73 65 20 74 68 65 20 6c 61 75 6e 63 68 2d 73 use the launch-s
cba0: 65 74 75 70 20 6d 75 74 65 78 0a 20 20 28 6c 65 etup mutex. (le
cbb0: 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 20 t* ((item-path
cbc0: 20 20 20 20 20 28 69 74 65 6d 2d 6c 69 73 74 2d (item-list-
cbd0: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 29 >path itemdat)))
cbe0: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
cbf0: 28 64 65 6c 74 61 20 20 20 20 20 20 20 20 28 2d (delta (-
cc00: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
cc10: 73 29 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a s) *last-launch*
cc20: 29 29 0a 09 20 20 20 20 20 20 20 28 6c 61 75 6e )).. (laun
cc30: 63 68 2d 64 65 6c 61 79 20 28 73 74 72 69 6e 67 ch-delay (string
cc40: 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f ->number (or (co
cc50: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
cc60: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
cc70: 20 22 6c 61 75 6e 63 68 2d 64 65 6c 61 79 22 29 "launch-delay")
cc80: 20 22 35 22 29 29 29 29 0a 20 20 20 20 20 20 28 "5")))). (
cc90: 69 66 20 28 3e 20 6c 61 75 6e 63 68 2d 64 65 6c if (> launch-del
cca0: 61 79 20 64 65 6c 74 61 29 0a 09 20 20 28 62 65 ay delta).. (be
ccb0: 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a gin.. (debug:
ccc0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
ccd0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
cce0: 22 44 65 6c 61 79 69 6e 67 20 6c 61 75 6e 63 68 "Delaying launch
ccf0: 20 6f 66 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 of " test-name
cd00: 22 20 66 6f 72 20 22 20 28 2d 20 6c 61 75 6e 63 " for " (- launc
cd10: 68 2d 64 65 6c 61 79 20 64 65 6c 74 61 29 20 22 h-delay delta) "
cd20: 20 73 65 63 6f 6e 64 73 22 29 0a 09 20 20 20 20 seconds")..
cd30: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
cd40: 2d 20 6c 61 75 6e 63 68 2d 64 65 6c 61 79 20 64 - launch-delay d
cd50: 65 6c 74 61 29 29 0a 09 20 20 20 20 28 6c 6f 6f elta)).. (loo
cd60: 70 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 p (- (current-se
cd70: 63 6f 6e 64 73 29 20 2a 6c 61 73 74 2d 6c 61 75 conds) *last-lau
cd80: 6e 63 68 2a 29 20 6c 61 75 6e 63 68 2d 64 65 6c nch*) launch-del
cd90: 61 79 29 29 29 29 0a 20 20 20 20 28 63 68 61 6e ay)))). (chan
cda0: 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f ge-directory *to
cdb0: 70 70 61 74 68 2a 29 0a 20 20 20 20 28 61 6c 69 ppath*). (ali
cdc0: 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 3b 3b 20 st->env-vars ;;
cdd0: 63 6f 6e 73 6f 6c 69 64 61 74 65 20 74 68 69 73 consolidate this
cde0: 20 63 6f 64 65 20 77 69 74 68 20 74 68 65 20 63 code with the c
cdf0: 6f 64 65 20 69 6e 20 6d 65 67 61 74 65 73 74 2e ode in megatest.
ce00: 73 63 6d 20 66 6f 72 20 22 2d 65 78 65 63 75 74 scm for "-execut
ce10: 65 22 2c 20 2a 6d 61 79 62 65 2a 20 2d 20 74 68 e", *maybe* - th
ce20: 65 20 6c 6f 6e 67 65 72 20 74 68 65 79 20 61 72 e longer they ar
ce30: 65 20 73 65 74 20 74 68 65 20 6c 6f 6e 67 65 72 e set the longer
ce40: 20 65 61 63 68 20 6c 61 75 6e 63 68 20 74 61 6b each launch tak
ce50: 65 73 20 28 6d 75 73 74 20 62 65 20 6e 6f 6e 2d es (must be non-
ce60: 6f 76 65 72 6c 61 70 70 69 6e 67 20 77 69 74 68 overlapping with
ce70: 20 74 68 65 20 76 61 72 73 29 0a 20 20 20 20 20 the vars).
ce80: 28 61 70 70 65 6e 64 0a 20 20 20 20 20 20 28 6c (append. (l
ce90: 69 73 74 0a 20 20 20 20 20 20 20 28 6c 69 73 74 ist. (list
cea0: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
ceb0: 4d 45 22 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 ME" *toppath*).
cec0: 20 20 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f (list "MT_
ced0: 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d TEST_NAME" test-
cee0: 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 69 name). (li
cef0: 73 74 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 st "MT_RUNNAME"
cf00: 20 20 72 75 6e 6e 61 6d 65 29 0a 20 20 20 20 20 runname).
cf10: 20 20 28 6c 69 73 74 20 22 4d 54 5f 49 54 45 4d (list "MT_ITEM
cf20: 50 41 54 48 22 20 20 69 74 65 6d 2d 70 61 74 68 PATH" item-path
cf30: 29 0a 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 ). ).
cf40: 20 69 74 65 6d 64 61 74 29 29 0a 20 20 20 20 28 itemdat)). (
cf50: 6c 65 74 2a 20 28 28 74 72 65 67 69 73 74 72 79 let* ((tregistry
cf60: 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 67 65 (tests:ge
cf70: 74 2d 61 6c 6c 29 29 20 3b 3b 20 74 68 69 72 64 t-all)) ;; third
cf80: 20 70 61 72 61 6d 20 28 62 65 6c 6f 77 29 20 69 param (below) i
cf90: 73 20 73 79 73 74 65 6d 2d 61 6c 6c 6f 77 65 64 s system-allowed
cfa0: 0a 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 66 . ;; f
cfb0: 6f 72 20 74 63 6f 6e 66 69 67 2c 20 77 68 79 20 or tconfig, why
cfc0: 64 6f 20 77 65 20 61 6c 6c 6f 77 20 66 61 6c 6c do we allow fall
cfd0: 62 61 63 6b 20 74 6f 20 74 65 73 74 2d 63 6f 6e back to test-con
cfe0: 66 3f 0a 09 20 20 20 28 74 63 6f 6e 66 69 67 20 f?.. (tconfig
cff0: 20 20 20 20 20 20 20 20 28 6f 72 20 28 74 65 73 (or (tes
d000: 74 73 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 ts:get-testconfi
d010: 67 20 74 65 73 74 2d 6e 61 6d 65 20 74 72 65 67 g test-name treg
d020: 69 73 74 72 79 20 23 74 20 66 6f 72 63 65 2d 63 istry #t force-c
d030: 72 65 61 74 65 3a 20 23 74 29 0a 09 09 09 09 28 reate: #t).....(
d040: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
d050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d060: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
d070: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
d080: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
d090: 4e 47 3a 20 66 61 6c 6c 69 6e 67 20 62 61 63 6b NG: falling back
d0a0: 20 74 6f 20 70 72 65 2d 63 61 6c 63 75 6c 61 74 to pre-calculat
d0b0: 65 64 20 74 65 73 74 63 6f 6e 66 69 67 2e 20 54 ed testconfig. T
d0c0: 68 69 73 20 69 73 20 6c 69 6b 65 6c 79 20 6e 6f his is likely no
d0d0: 74 20 64 65 73 69 72 65 64 2e 22 29 0a 20 20 20 t desired.").
d0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d0f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 74 t
d100: 65 73 74 2d 63 6f 6e 66 29 29 29 20 3b 3b 20 66 est-conf))) ;; f
d110: 6f 72 63 65 20 72 65 2d 72 65 61 64 20 6e 6f 77 orce re-read now
d120: 20 74 68 61 74 20 61 6c 6c 20 76 61 72 73 20 61 that all vars a
d130: 72 65 20 73 65 74 0a 09 20 20 20 28 75 73 65 73 re set.. (uses
d140: 68 65 6c 6c 20 20 20 20 20 20 20 20 28 6c 65 74 hell (let
d150: 20 28 28 75 73 68 20 28 63 6f 6e 66 69 67 2d 6c ((ush (config-l
d160: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
d170: 2a 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 20 20 20 * "jobtools"
d180: 20 22 75 73 65 73 68 65 6c 6c 22 29 29 29 0a 09 "useshell")))..
d190: 09 09 20 20 20 20 20 20 28 69 66 20 75 73 68 20 .. (if ush
d1a0: 0a 09 09 09 09 20 20 28 69 66 20 28 65 71 75 61 ..... (if (equa
d1b0: 6c 3f 20 75 73 68 20 22 6e 6f 22 29 20 3b 3b 20 l? ush "no") ;;
d1c0: 6d 75 73 74 20 75 73 65 20 22 6e 6f 22 20 74 6f must use "no" to
d1d0: 20 4e 4f 54 20 75 73 65 20 73 68 65 6c 6c 0a 09 NOT use shell..
d1e0: 09 09 09 20 20 20 20 20 20 23 66 0a 09 09 09 09 ... #f.....
d1f0: 20 20 20 20 20 20 75 73 68 29 0a 09 09 09 09 20 ush).....
d200: 20 23 74 29 29 29 20 20 20 20 20 3b 3b 20 64 65 #t))) ;; de
d210: 66 61 75 6c 74 20 69 73 20 79 65 73 0a 09 20 20 fault is yes..
d220: 20 28 72 75 6e 73 63 72 69 70 74 20 20 20 20 20 (runscript
d230: 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 (config-lookup
d240: 20 74 63 6f 6e 66 69 67 20 20 20 22 73 65 74 75 tconfig "setu
d250: 70 22 20 20 20 20 20 20 20 20 22 72 75 6e 73 63 p" "runsc
d260: 72 69 70 74 22 29 29 0a 09 20 20 20 28 65 7a 73 ript")).. (ezs
d270: 74 65 70 73 20 20 20 20 20 20 20 20 20 28 3e 20 teps (>
d280: 28 6c 65 6e 67 74 68 20 28 68 61 73 68 2d 74 61 (length (hash-ta
d290: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
d2a0: 74 63 6f 6e 66 69 67 20 22 65 7a 73 74 65 70 73 tconfig "ezsteps
d2b0: 22 20 27 28 29 29 29 20 30 29 29 20 3b 3b 20 64 " '())) 0)) ;; d
d2c0: 6f 6e 27 74 20 73 65 6e 64 20 61 6c 6c 20 74 68 on't send all th
d2d0: 65 20 73 74 65 70 73 2c 20 63 6f 75 6c 64 20 62 e steps, could b
d2e0: 65 20 62 69 67 0a 09 20 20 20 3b 3b 20 28 64 69 e big.. ;; (di
d2f0: 73 6b 73 70 61 63 65 20 20 20 20 20 20 20 28 63 skspace (c
d300: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f onfig-lookup tco
d310: 6e 66 69 67 20 20 20 22 72 65 71 75 69 72 65 6d nfig "requirem
d320: 65 6e 74 73 22 20 22 64 69 73 6b 73 70 61 63 65 ents" "diskspace
d330: 22 29 29 0a 09 20 20 20 3b 3b 20 28 6d 65 6d 6f ")).. ;; (memo
d340: 72 79 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e ry (con
d350: 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 fig-lookup tconf
d360: 69 67 20 20 20 22 72 65 71 75 69 72 65 6d 65 6e ig "requiremen
d370: 74 73 22 20 22 6d 65 6d 6f 72 79 22 29 29 0a 09 ts" "memory"))..
d380: 20 20 20 3b 3b 20 28 68 6f 73 74 73 20 20 20 20 ;; (hosts
d390: 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c (config-l
d3a0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
d3b0: 2a 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 20 20 20 * "jobtools"
d3c0: 20 22 77 6f 72 6b 68 6f 73 74 73 22 29 29 20 3b "workhosts")) ;
d3d0: 3b 20 49 27 6d 20 70 72 65 74 74 79 20 73 75 72 ; I'm pretty sur
d3e0: 65 20 74 68 69 73 20 77 61 73 20 6e 65 76 65 72 e this was never
d3f0: 20 63 6f 6d 70 6c 65 74 65 64 0a 09 20 20 20 28 completed.. (
d400: 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 remote-megatest
d410: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a (config-lookup *
d420: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
d430: 70 22 20 22 65 78 65 63 75 74 61 62 6c 65 22 29 p" "executable")
d440: 29 0a 09 20 20 20 28 72 75 6e 2d 74 69 6d 65 2d ).. (run-time-
d450: 6c 69 6d 69 74 20 20 28 6f 72 20 28 63 6f 6e 66 limit (or (conf
d460: 69 67 66 3a 6c 6f 6f 6b 75 70 20 20 74 63 6f 6e igf:lookup tcon
d470: 66 69 67 20 20 20 22 72 65 71 75 69 72 65 6d 65 fig "requireme
d480: 6e 74 73 22 20 22 72 75 6e 74 69 6d 65 6c 69 6d nts" "runtimelim
d490: 22 29 0a 09 09 09 09 28 63 6f 6e 66 69 67 66 3a ").....(configf:
d4a0: 6c 6f 6f 6b 75 70 20 20 2a 63 6f 6e 66 69 67 64 lookup *configd
d4b0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e at* "setup" "run
d4c0: 74 69 6d 65 6c 69 6d 22 29 29 29 0a 09 20 20 20 timelim")))..
d4d0: 3b 3b 20 46 49 58 4d 45 20 53 4f 4d 45 44 41 59 ;; FIXME SOMEDAY
d4e0: 3a 20 6e 6f 74 20 67 6f 6f 64 20 68 6f 77 20 74 : not good how t
d4f0: 68 69 73 20 69 73 20 73 6f 20 6f 62 74 75 73 65 his is so obtuse
d500: 2c 20 74 68 69 73 20 68 61 63 6b 20 69 73 20 74 , this hack is t
d510: 6f 20 0a 09 20 20 20 3b 3b 20 20 20 20 20 20 20 o .. ;;
d520: 20 20 20 20 20 20 20 20 20 61 6c 6c 6f 77 20 72 allow r
d530: 75 6e 6e 69 6e 67 20 66 72 6f 6d 20 64 61 73 68 unning from dash
d540: 62 6f 61 72 64 2e 20 45 78 74 72 61 63 74 20 74 board. Extract t
d550: 68 65 20 70 61 74 68 0a 09 20 20 20 3b 3b 20 20 he path.. ;;
d560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66 72 fr
d570: 6f 6d 20 74 68 65 20 63 61 6c 6c 65 64 20 6d 65 om the called me
d580: 67 61 74 65 73 74 20 61 6e 64 20 63 6f 6e 76 65 gatest and conve
d590: 72 74 20 64 61 73 68 62 6f 61 72 64 0a 09 20 20 rt dashboard..
d5a0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
d5b0: 09 20 20 6f 72 20 64 62 6f 61 72 64 20 74 6f 20 . or dboard to
d5c0: 6d 65 67 61 74 65 73 74 0a 09 20 20 20 28 6c 6f megatest.. (lo
d5d0: 63 61 6c 2d 6d 65 67 61 74 65 73 74 20 20 28 6c cal-megatest (l
d5e0: 65 74 2a 20 28 28 6c 6d 20 20 28 63 61 72 20 28 et* ((lm (car (
d5f0: 61 72 67 76 29 29 29 0a 09 09 09 09 20 20 20 28 argv)))..... (
d600: 64 69 72 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 dir (pathname-di
d610: 72 65 63 74 6f 72 79 20 6c 6d 29 29 0a 09 09 09 rectory lm))....
d620: 09 20 20 20 28 65 78 65 20 28 70 61 74 68 6e 61 . (exe (pathna
d630: 6d 65 2d 73 74 72 69 70 2d 64 69 72 65 63 74 6f me-strip-directo
d640: 72 79 20 6c 6d 29 29 29 0a 09 09 09 20 20 20 20 ry lm)))....
d650: 20 20 28 63 6f 6e 63 20 28 69 66 20 64 69 72 20 (conc (if dir
d660: 28 63 6f 6e 63 20 64 69 72 20 22 2f 22 29 20 22 (conc dir "/") "
d670: 22 29 0a 09 09 09 09 20 20 20 20 28 63 61 73 65 ")..... (case
d680: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
d690: 20 65 78 65 29 0a 09 09 09 09 20 20 20 20 20 20 exe).....
d6a0: 28 28 64 62 6f 61 72 64 29 20 20 20 20 22 2e 2e ((dboard) "..
d6b0: 2f 6d 65 67 61 74 65 73 74 22 29 0a 09 09 09 09 /megatest").....
d6c0: 20 20 20 20 20 20 28 28 6d 74 65 73 74 29 20 20 ((mtest)
d6d0: 20 20 20 22 2e 2e 2f 6d 65 67 61 74 65 73 74 22 "../megatest"
d6e0: 29 0a 09 09 09 09 20 20 20 20 20 20 28 28 64 61 )..... ((da
d6f0: 73 68 62 6f 61 72 64 29 20 22 6d 65 67 61 74 65 shboard) "megate
d700: 73 74 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 st")..... (
d710: 65 6c 73 65 20 65 78 65 29 29 29 29 29 0a 09 20 else exe)))))..
d720: 20 20 28 6c 61 75 6e 63 68 65 72 20 20 20 20 20 (launcher
d730: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c (common:get-l
d740: 61 75 6e 63 68 65 72 20 2a 63 6f 6e 66 69 67 64 auncher *configd
d750: 61 74 2a 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 at* test-name it
d760: 65 6d 2d 70 61 74 68 29 29 20 3b 3b 20 28 63 6f em-path)) ;; (co
d770: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e nfig-lookup *con
d780: 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f 6f 6c figdat* "jobtool
d790: 73 22 20 20 20 20 20 22 6c 61 75 6e 63 68 65 72 s" "launcher
d7a0: 22 29 29 0a 09 20 20 20 28 74 65 73 74 2d 73 69 ")).. (test-si
d7b0: 67 20 20 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f g (conc (commo
d7c0: 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d n:get-testsuite-
d7d0: 6e 61 6d 65 29 20 22 3a 22 20 74 65 73 74 2d 6e name) ":" test-n
d7e0: 61 6d 65 20 22 3a 22 20 69 74 65 6d 2d 70 61 74 ame ":" item-pat
d7f0: 68 29 29 20 3b 3b 20 28 69 74 65 6d 2d 6c 69 73 h)) ;; (item-lis
d800: 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 t->path itemdat)
d810: 29 29 20 3b 3b 20 74 65 73 74 2d 70 61 74 68 20 )) ;; test-path
d820: 69 73 20 74 68 65 20 66 75 6c 6c 20 70 61 74 68 is the full path
d830: 20 69 6e 63 6c 75 64 69 6e 67 20 74 68 65 20 69 including the i
d840: 74 65 6d 2d 70 61 74 68 0a 09 20 20 20 28 77 6f tem-path.. (wo
d850: 72 6b 2d 61 72 65 61 20 20 23 66 29 0a 09 20 20 rk-area #f)..
d860: 20 28 74 6f 70 74 65 73 74 2d 77 6f 72 6b 2d 61 (toptest-work-a
d870: 72 65 61 20 23 66 29 20 3b 3b 20 66 6f 72 20 69 rea #f) ;; for i
d880: 74 65 72 61 74 65 64 20 74 65 73 74 73 20 74 68 terated tests th
d890: 65 20 74 6f 70 20 74 65 73 74 20 63 6f 6e 74 61 e top test conta
d8a0: 69 6e 73 20 64 61 74 61 20 72 65 6c 65 76 61 6e ins data relevan
d8b0: 74 20 66 6f 72 20 61 6c 6c 0a 09 20 20 20 28 64 t for all.. (d
d8c0: 69 73 6b 70 61 74 68 20 20 20 23 66 29 0a 09 20 iskpath #f)..
d8d0: 20 20 28 63 6d 64 70 61 72 6d 73 20 20 20 23 66 (cmdparms #f
d8e0: 29 0a 09 20 20 20 28 66 75 6c 6c 63 6d 64 20 20 ).. (fullcmd
d8f0: 20 20 23 66 29 20 3b 3b 20 28 64 65 66 69 6e 65 #f) ;; (define
d900: 20 61 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d a (with-output-
d910: 74 6f 2d 73 74 72 69 6e 67 20 28 6c 61 6d 62 64 to-string (lambd
d920: 61 20 28 29 28 77 72 69 74 65 20 78 29 29 29 29 a ()(write x))))
d930: 0a 09 20 20 20 28 6d 74 2d 62 69 6e 64 69 72 2d .. (mt-bindir-
d940: 70 61 74 68 20 23 66 29 0a 09 20 20 20 28 74 65 path #f).. (te
d950: 73 74 69 6e 66 6f 20 20 20 28 72 6d 74 3a 67 65 stinfo (rmt:ge
d960: 74 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 t-test-info-by-i
d970: 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 d run-id test-id
d980: 29 29 0a 09 20 20 20 28 6d 74 5f 74 61 72 67 65 )).. (mt_targe
d990: 74 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 t (string-inter
d9a0: 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 64 72 sperse (map cadr
d9b0: 20 6b 65 79 76 61 6c 73 29 20 22 2f 22 29 29 0a keyvals) "/")).
d9c0: 09 20 20 20 28 64 65 62 75 67 2d 70 61 72 61 6d . (debug-param
d9d0: 20 28 61 70 70 65 6e 64 20 28 69 66 20 28 61 72 (append (if (ar
d9e0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 64 65 62 gs:get-arg "-deb
d9f0: 75 67 22 29 20 20 28 6c 69 73 74 20 22 2d 64 65 ug") (list "-de
da00: 62 75 67 22 20 28 61 72 67 73 3a 67 65 74 2d 61 bug" (args:get-a
da10: 72 67 20 22 2d 64 65 62 75 67 22 29 29 20 27 28 rg "-debug")) '(
da20: 29 29 0a 09 09 09 09 28 69 66 20 28 61 72 67 73 )).....(if (args
da30: 3a 67 65 74 2d 61 72 67 20 22 2d 6c 6f 67 67 69 :get-arg "-loggi
da40: 6e 67 22 29 28 6c 69 73 74 20 22 2d 6c 6f 67 67 ng")(list "-logg
da50: 69 6e 67 22 29 20 27 28 29 29 29 29 29 0a 20 20 ing") '())))).
da60: 20 20 20 20 3b 3b 20 28 69 66 20 68 6f 73 74 73 ;; (if hosts
da70: 20 28 73 65 74 21 20 68 6f 73 74 73 20 28 73 74 (set! hosts (st
da80: 72 69 6e 67 2d 73 70 6c 69 74 20 68 6f 73 74 73 ring-split hosts
da90: 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 73 65 74 ))). ;; set
daa0: 20 74 68 65 20 6d 65 67 61 74 65 73 74 20 74 6f the megatest to
dab0: 20 62 65 20 63 61 6c 6c 65 64 20 6f 6e 20 74 68 be called on th
dac0: 65 20 72 65 6d 6f 74 65 20 68 6f 73 74 0a 20 20 e remote host.
dad0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 72 65 6d (if (not rem
dae0: 6f 74 65 2d 6d 65 67 61 74 65 73 74 29 28 73 65 ote-megatest)(se
daf0: 74 21 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 t! remote-megate
db00: 73 74 20 6c 6f 63 61 6c 2d 6d 65 67 61 74 65 73 st local-megates
db10: 74 29 29 20 3b 3b 20 22 6d 65 67 61 74 65 73 74 t)) ;; "megatest
db20: 22 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 ")). (set!
db30: 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 28 mt-bindir-path (
db40: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
db50: 72 79 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 ry remote-megate
db60: 73 74 29 29 0a 20 20 20 20 20 20 28 69 66 20 6c st)). (if l
db70: 61 75 6e 63 68 65 72 20 28 73 65 74 21 20 6c 61 auncher (set! la
db80: 75 6e 63 68 65 72 20 28 73 74 72 69 6e 67 2d 73 uncher (string-s
db90: 70 6c 69 74 20 6c 61 75 6e 63 68 65 72 29 29 29 plit launcher)))
dba0: 0a 20 20 20 20 20 20 3b 3b 20 73 65 74 20 75 70 . ;; set up
dbb0: 20 74 68 65 20 72 75 6e 20 77 6f 72 6b 20 61 72 the run work ar
dbc0: 65 61 20 66 6f 72 20 74 68 69 73 20 74 65 73 74 ea for this test
dbd0: 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 . (if (and
dbe0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
dbf0: 70 72 65 63 6c 65 61 6e 22 29 20 3b 3b 20 75 73 preclean") ;; us
dc00: 65 72 20 68 61 73 20 72 65 71 75 65 73 74 65 64 er has requested
dc10: 20 74 6f 20 70 72 65 63 6c 65 61 6e 20 66 6f 72 to preclean for
dc20: 20 74 68 69 73 20 72 75 6e 0a 09 20 20 20 20 20 this run..
dc30: 20 20 28 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 (not (member (
dc40: 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 db:test-get-rund
dc50: 69 72 20 74 65 73 74 69 6e 66 6f 29 28 6c 69 73 ir testinfo)(lis
dc60: 74 20 22 6e 2f 61 22 20 22 2f 74 6d 70 2f 62 61 t "n/a" "/tmp/ba
dc70: 64 6e 61 6d 65 22 29 29 29 29 20 3b 3b 20 6e 2f dname")))) ;; n/
dc80: 61 20 69 73 20 61 20 70 6c 61 63 65 68 6f 6c 64 a is a placehold
dc90: 65 72 20 61 6e 64 20 74 68 75 73 20 6e 6f 74 20 er and thus not
dca0: 61 20 72 65 61 64 20 64 69 72 0a 09 20 20 28 62 a read dir.. (b
dcb0: 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 egin.. (debug
dcc0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
dcd0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
dce0: 20 22 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 "attempting to
dcf0: 70 72 65 63 6c 65 61 6e 20 64 69 72 65 63 74 6f preclean directo
dd00: 72 79 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 ry " (db:test-ge
dd10: 74 2d 72 75 6e 64 69 72 20 74 65 73 74 69 6e 66 t-rundir testinf
dd20: 6f 29 20 22 20 66 6f 72 20 74 65 73 74 20 22 20 o) " for test "
dd30: 74 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 test-name "/" it
dd40: 65 6d 2d 70 61 74 68 29 0a 09 20 20 20 20 28 72 em-path).. (r
dd50: 75 6e 73 3a 72 65 6d 6f 76 65 2d 74 65 73 74 2d uns:remove-test-
dd60: 64 69 72 65 63 74 6f 72 79 20 74 65 73 74 69 6e directory testin
dd70: 66 6f 20 27 72 65 6d 6f 76 65 2d 64 61 74 61 2d fo 'remove-data-
dd80: 6f 6e 6c 79 29 29 29 20 3b 3b 20 72 65 6d 6f 76 only))) ;; remov
dd90: 65 20 64 61 74 61 20 6f 6e 6c 79 2c 20 64 6f 20 e data only, do
dda0: 6e 6f 74 20 70 65 72 74 75 72 62 20 74 68 65 20 not perturb the
ddb0: 72 65 63 6f 72 64 0a 20 20 20 20 20 20 0a 20 20 record. .
ddc0: 20 20 20 20 3b 3b 20 70 72 65 76 65 6e 74 20 6f ;; prevent o
ddd0: 76 65 72 6c 61 70 70 69 6e 67 20 61 63 74 69 6f verlapping actio
dde0: 6e 73 20 2d 20 73 65 74 20 74 6f 20 4c 41 55 4e ns - set to LAUN
ddf0: 43 48 45 44 20 61 73 20 65 61 72 6c 79 20 61 73 CHED as early as
de00: 20 70 6f 73 73 69 62 6c 65 0a 20 20 20 20 20 20 possible.
de10: 3b 3b 0a 20 20 20 20 20 20 3b 3b 20 74 68 65 20 ;;. ;; the
de20: 66 6f 6c 6c 6f 77 69 6e 67 20 63 61 6c 6c 20 68 following call h
de30: 61 6e 64 6c 65 73 20 77 61 69 76 65 72 20 70 72 andles waiver pr
de40: 6f 70 6f 67 61 74 69 6f 6e 2e 20 63 61 6e 6e 6f opogation. canno
de50: 74 20 79 65 74 20 63 6f 6e 64 65 6e 73 65 20 69 t yet condense i
de60: 6e 74 6f 20 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 nto roll-up-pass
de70: 2d 66 61 69 6c 0a 20 20 20 20 20 20 28 74 65 73 -fail. (tes
de80: 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 ts:test-set-stat
de90: 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d us! run-id test-
dea0: 69 64 20 22 4c 41 55 4e 43 48 45 44 22 20 22 6e id "LAUNCHED" "n
deb0: 2f 61 22 20 23 66 20 23 66 29 20 3b 3b 20 28 69 /a" #f #f) ;; (i
dec0: 66 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 f launch-results
ded0: 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 20 launch-results
dee0: 22 46 41 49 4c 45 44 22 29 29 0a 20 20 20 20 20 "FAILED")).
def0: 20 28 72 6d 74 3a 72 6f 6c 6c 2d 75 70 2d 70 61 (rmt:roll-up-pa
df00: 73 73 2d 66 61 69 6c 2d 63 6f 75 6e 74 73 20 72 ss-fail-counts r
df10: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
df20: 69 74 65 6d 2d 70 61 74 68 20 23 66 20 22 4c 41 item-path #f "LA
df30: 55 4e 43 48 45 44 22 20 23 66 29 0a 20 20 20 20 UNCHED" #f).
df40: 20 20 3b 3b 20 28 70 70 20 28 68 61 73 68 2d 74 ;; (pp (hash-t
df50: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 74 63 6f 6e able->alist tcon
df60: 66 69 67 29 29 0a 20 20 20 20 20 20 28 73 65 74 fig)). (set
df70: 21 20 64 69 73 6b 70 61 74 68 20 28 67 65 74 2d ! diskpath (get-
df80: 62 65 73 74 2d 64 69 73 6b 20 2a 63 6f 6e 66 69 best-disk *confi
df90: 67 64 61 74 2a 20 74 63 6f 6e 66 69 67 29 29 0a gdat* tconfig)).
dfa0: 20 20 20 20 20 20 28 69 66 20 64 69 73 6b 70 61 (if diskpa
dfb0: 74 68 0a 09 20 20 28 6c 65 74 20 28 28 64 61 74 th.. (let ((dat
dfc0: 20 20 28 63 72 65 61 74 65 2d 77 6f 72 6b 2d 61 (create-work-a
dfd0: 72 65 61 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 rea run-id run-i
dfe0: 6e 66 6f 20 6b 65 79 76 61 6c 73 20 74 65 73 74 nfo keyvals test
dff0: 2d 69 64 20 74 65 73 74 2d 70 61 74 68 20 64 69 -id test-path di
e000: 73 6b 70 61 74 68 20 74 65 73 74 2d 6e 61 6d 65 skpath test-name
e010: 20 69 74 65 6d 64 61 74 29 29 29 0a 09 20 20 20 itemdat)))..
e020: 20 28 73 65 74 21 20 77 6f 72 6b 2d 61 72 65 61 (set! work-area
e030: 20 28 63 61 72 20 64 61 74 29 29 0a 09 20 20 20 (car dat))..
e040: 20 28 73 65 74 21 20 74 6f 70 74 65 73 74 2d 77 (set! toptest-w
e050: 6f 72 6b 2d 61 72 65 61 20 28 63 61 64 72 20 64 ork-area (cadr d
e060: 61 74 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 at)).. (debug
e070: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
e080: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
e090: 20 22 55 73 69 6e 67 20 77 6f 72 6b 20 61 72 65 "Using work are
e0a0: 61 20 22 20 77 6f 72 6b 2d 61 72 65 61 29 29 0a a " work-area)).
e0b0: 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 . (begin.. (
e0c0: 73 65 74 21 20 77 6f 72 6b 2d 61 72 65 61 20 28 set! work-area (
e0d0: 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 20 22 conc test-path "
e0e0: 2f 74 6d 70 5f 72 75 6e 22 29 29 0a 09 20 20 20 /tmp_run"))..
e0f0: 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f (create-directo
e100: 72 79 20 77 6f 72 6b 2d 61 72 65 61 20 23 74 29 ry work-area #t)
e110: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
e120: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
e130: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
e140: 3a 20 4e 6f 20 64 69 73 6b 20 77 6f 72 6b 20 61 : No disk work a
e150: 72 65 61 20 73 70 65 63 69 66 69 65 64 20 2d 20 rea specified -
e160: 72 75 6e 6e 69 6e 67 20 69 6e 20 74 68 65 20 74 running in the t
e170: 65 73 74 20 64 69 72 65 63 74 6f 72 79 20 75 6e est directory un
e180: 64 65 72 20 74 6d 70 5f 72 75 6e 22 29 29 29 0a der tmp_run"))).
e190: 20 20 20 20 20 20 28 73 65 74 21 20 63 6d 64 70 (set! cmdp
e1a0: 61 72 6d 73 20 28 62 61 73 65 36 34 3a 62 61 73 arms (base64:bas
e1b0: 65 36 34 2d 65 6e 63 6f 64 65 20 0a 09 09 20 20 e64-encode ...
e1c0: 20 20 20 20 28 7a 33 3a 65 6e 63 6f 64 65 2d 62 (z3:encode-b
e1d0: 75 66 66 65 72 20 0a 09 09 20 20 20 20 20 20 20 uffer ...
e1e0: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
e1f0: 73 74 72 69 6e 67 0a 09 09 09 20 28 6c 61 6d 62 string.... (lamb
e200: 64 61 20 28 29 20 3b 3b 20 28 6c 69 73 74 20 27 da () ;; (list '
e210: 68 6f 73 74 73 20 20 20 20 20 68 6f 73 74 73 29 hosts hosts)
e220: 0a 09 09 09 20 20 20 28 77 72 69 74 65 20 28 6c .... (write (l
e230: 69 73 74 20 28 6c 69 73 74 20 27 74 65 73 74 70 ist (list 'testp
e240: 61 74 68 20 20 74 65 73 74 2d 70 61 74 68 29 0a ath test-path).
e250: 09 09 09 09 09 28 6c 69 73 74 20 27 74 72 61 6e .....(list 'tran
e260: 73 70 6f 72 74 20 28 63 6f 6e 63 20 2a 74 72 61 sport (conc *tra
e270: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 29 29 0a 09 nsport-type*))..
e280: 09 09 09 09 3b 3b 20 28 6c 69 73 74 20 27 73 65 ....;; (list 'se
e290: 72 76 65 72 69 6e 66 20 2a 73 65 72 76 65 72 2d rverinf *server-
e2a0: 69 6e 66 6f 2a 29 0a 09 09 09 09 09 28 6c 69 73 info*)......(lis
e2b0: 74 20 27 74 6f 70 70 61 74 68 20 20 20 2a 74 6f t 'toppath *to
e2c0: 70 70 61 74 68 2a 29 0a 09 09 09 09 09 28 6c 69 ppath*)......(li
e2d0: 73 74 20 27 77 6f 72 6b 2d 61 72 65 61 20 77 6f st 'work-area wo
e2e0: 72 6b 2d 61 72 65 61 29 0a 09 09 09 09 09 28 6c rk-area)......(l
e2f0: 69 73 74 20 27 74 65 73 74 2d 6e 61 6d 65 20 74 ist 'test-name t
e300: 65 73 74 2d 6e 61 6d 65 29 20 0a 09 09 09 09 09 est-name) ......
e310: 28 6c 69 73 74 20 27 72 75 6e 73 63 72 69 70 74 (list 'runscript
e320: 20 72 75 6e 73 63 72 69 70 74 29 20 0a 09 09 09 runscript) ....
e330: 09 09 28 6c 69 73 74 20 27 72 75 6e 2d 69 64 20 ..(list 'run-id
e340: 20 20 20 72 75 6e 2d 69 64 20 20 20 29 0a 09 09 run-id )...
e350: 09 09 09 28 6c 69 73 74 20 27 74 65 73 74 2d 69 ...(list 'test-i
e360: 64 20 20 20 74 65 73 74 2d 69 64 20 20 29 0a 09 d test-id )..
e370: 09 09 09 09 3b 3b 20 28 6c 69 73 74 20 27 69 74 ....;; (list 'it
e380: 65 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 74 em-path item-pat
e390: 68 20 29 0a 09 09 09 09 09 28 6c 69 73 74 20 27 h )......(list '
e3a0: 69 74 65 6d 64 61 74 20 20 20 69 74 65 6d 64 61 itemdat itemda
e3b0: 74 20 20 29 0a 09 09 09 09 09 28 6c 69 73 74 20 t )......(list
e3c0: 27 6d 65 67 61 74 65 73 74 20 20 72 65 6d 6f 74 'megatest remot
e3d0: 65 2d 6d 65 67 61 74 65 73 74 29 0a 09 09 09 09 e-megatest).....
e3e0: 09 28 6c 69 73 74 20 27 65 7a 73 74 65 70 73 20 .(list 'ezsteps
e3f0: 20 20 65 7a 73 74 65 70 73 29 20 0a 09 09 09 09 ezsteps) .....
e400: 09 28 6c 69 73 74 20 27 74 61 72 67 65 74 20 20 .(list 'target
e410: 20 20 6d 74 5f 74 61 72 67 65 74 29 0a 09 09 09 mt_target)....
e420: 09 09 28 6c 69 73 74 20 27 72 75 6e 74 6c 69 6d ..(list 'runtlim
e430: 20 20 20 28 69 66 20 72 75 6e 2d 74 69 6d 65 2d (if run-time-
e440: 6c 69 6d 69 74 20 28 63 6f 6d 6d 6f 6e 3a 68 6d limit (common:hm
e450: 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 s-string->second
e460: 73 20 72 75 6e 2d 74 69 6d 65 2d 6c 69 6d 69 74 s run-time-limit
e470: 29 20 23 66 29 29 0a 09 09 09 09 09 28 6c 69 73 ) #f))......(lis
e480: 74 20 27 65 6e 76 2d 6f 76 72 64 20 20 28 68 61 t 'env-ovrd (ha
e490: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
e4a0: 61 75 6c 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a ault *configdat*
e4b0: 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 65 22 20 "env-override"
e4c0: 27 28 29 29 29 20 0a 09 09 09 09 09 28 6c 69 73 '())) ......(lis
e4d0: 74 20 27 73 65 74 2d 76 61 72 73 20 20 28 69 66 t 'set-vars (if
e4e0: 20 70 61 72 61 6d 73 20 28 68 61 73 68 2d 74 61 params (hash-ta
e4f0: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
e500: 70 61 72 61 6d 73 20 22 2d 73 65 74 76 61 72 73 params "-setvars
e510: 22 20 23 66 29 29 29 0a 09 09 09 09 09 28 6c 69 " #f)))......(li
e520: 73 74 20 27 72 75 6e 6e 61 6d 65 20 20 20 72 75 st 'runname ru
e530: 6e 6e 61 6d 65 29 0a 09 09 09 09 09 28 6c 69 73 nname)......(lis
e540: 74 20 27 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 t 'mt-bindir-pat
e550: 68 20 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 h mt-bindir-path
e560: 29 29 29 29 29 29 29 29 0a 20 20 20 20 20 20 0a )))))))). .
e570: 20 20 20 20 20 20 3b 3b 20 63 6c 65 61 6e 20 6f ;; clean o
e580: 75 74 20 73 74 65 70 20 72 65 63 6f 72 64 73 20 ut step records
e590: 66 72 6f 6d 20 70 72 65 76 69 6f 75 73 20 72 75 from previous ru
e5a0: 6e 20 69 66 20 74 68 65 79 20 65 78 69 73 74 0a n if they exist.
e5b0: 20 20 20 20 20 20 3b 3b 20 28 72 6d 74 3a 64 65 ;; (rmt:de
e5c0: 6c 65 74 65 2d 74 65 73 74 2d 73 74 65 70 2d 72 lete-test-step-r
e5d0: 65 63 6f 72 64 73 20 72 75 6e 2d 69 64 20 74 65 ecords run-id te
e5e0: 73 74 2d 69 64 29 0a 20 20 20 20 20 20 3b 3b 20 st-id). ;;
e5f0: 69 66 20 74 68 65 20 64 69 72 20 64 6f 65 73 20 if the dir does
e600: 6e 6f 74 20 65 78 69 73 74 20 77 65 20 6d 61 79 not exist we may
e610: 20 68 61 76 65 20 61 20 69 74 65 6d 70 61 74 68 have a itempath
e620: 20 77 68 65 72 65 20 69 6e 64 69 76 69 64 75 61 where individua
e630: 6c 20 76 61 72 69 61 62 6c 65 73 20 61 72 65 20 l variables are
e640: 61 20 70 61 74 68 2c 20 6c 61 75 6e 63 68 20 61 a path, launch a
e650: 6e 79 77 61 79 0a 20 20 20 20 20 20 28 69 66 20 nyway. (if
e660: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 77 6f (file-exists? wo
e670: 72 6b 2d 61 72 65 61 29 0a 09 20 20 28 63 68 61 rk-area).. (cha
e680: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 77 6f nge-directory wo
e690: 72 6b 2d 61 72 65 61 29 29 20 3b 3b 20 73 6f 20 rk-area)) ;; so
e6a0: 74 68 61 74 20 6c 6f 67 20 66 69 6c 65 73 20 66 that log files f
e6b0: 72 6f 6d 20 74 68 65 20 6c 61 75 6e 63 68 20 70 rom the launch p
e6c0: 72 6f 63 65 73 73 20 64 6f 6e 27 74 20 63 6c 75 rocess don't clu
e6d0: 74 74 65 72 20 74 68 65 20 74 65 73 74 20 64 69 tter the test di
e6e0: 72 0a 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 r. (cond.
e6f0: 20 20 20 20 20 3b 3b 20 28 28 61 6e 64 20 6c 61 ;; ((and la
e700: 75 6e 63 68 65 72 20 68 6f 73 74 73 29 20 3b 3b uncher hosts) ;;
e710: 20 6d 75 73 74 20 62 65 20 75 73 69 6e 67 20 73 must be using s
e720: 73 68 20 68 6f 73 74 6e 61 6d 65 0a 20 20 20 20 sh hostname.
e730: 20 20 20 3b 3b 20 20 20 20 28 73 65 74 21 20 66 ;; (set! f
e740: 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 6c ullcmd (append l
e750: 61 75 6e 63 68 65 72 20 28 63 61 72 20 68 6f 73 auncher (car hos
e760: 74 73 29 28 6c 69 73 74 20 72 65 6d 6f 74 65 2d ts)(list remote-
e770: 6d 65 67 61 74 65 73 74 20 22 2d 6d 22 20 74 65 megatest "-m" te
e780: 73 74 2d 73 69 67 20 22 2d 65 78 65 63 75 74 65 st-sig "-execute
e790: 22 20 63 6d 64 70 61 72 6d 73 29 20 64 65 62 75 " cmdparms) debu
e7a0: 67 2d 70 61 72 61 6d 29 29 29 0a 20 20 20 20 20 g-param))).
e7b0: 20 20 3b 3b 20 28 73 65 74 21 20 66 75 6c 6c 63 ;; (set! fullc
e7c0: 6d 64 20 28 61 70 70 65 6e 64 20 6c 61 75 6e 63 md (append launc
e7d0: 68 65 72 20 28 63 61 72 20 68 6f 73 74 73 29 28 her (car hosts)(
e7e0: 6c 69 73 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 list remote-mega
e7f0: 74 65 73 74 20 74 65 73 74 2d 73 69 67 20 22 2d test test-sig "-
e800: 65 78 65 63 75 74 65 22 20 63 6d 64 70 61 72 6d execute" cmdparm
e810: 73 29 29 29 29 0a 20 20 20 20 20 20 20 28 6c 61 s)))). (la
e820: 75 6e 63 68 65 72 0a 09 28 73 65 74 21 20 66 75 uncher..(set! fu
e830: 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 6c 61 llcmd (append la
e840: 75 6e 63 68 65 72 20 28 6c 69 73 74 20 72 65 6d uncher (list rem
e850: 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 22 2d 6d ote-megatest "-m
e860: 22 20 74 65 73 74 2d 73 69 67 20 22 2d 65 78 65 " test-sig "-exe
e870: 63 75 74 65 22 20 63 6d 64 70 61 72 6d 73 29 20 cute" cmdparms)
e880: 64 65 62 75 67 2d 70 61 72 61 6d 29 29 29 0a 20 debug-param))).
e890: 20 20 20 20 20 20 3b 3b 20 28 73 65 74 21 20 66 ;; (set! f
e8a0: 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 6c ullcmd (append l
e8b0: 61 75 6e 63 68 65 72 20 28 6c 69 73 74 20 72 65 auncher (list re
e8c0: 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 74 65 mote-megatest te
e8d0: 73 74 2d 73 69 67 20 22 2d 65 78 65 63 75 74 65 st-sig "-execute
e8e0: 22 20 63 6d 64 70 61 72 6d 73 29 29 29 29 0a 20 " cmdparms)))).
e8f0: 20 20 20 20 20 20 28 65 6c 73 65 0a 09 28 69 66 (else..(if
e900: 20 28 6e 6f 74 20 75 73 65 73 68 65 6c 6c 29 28 (not useshell)(
e910: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
e920: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
e930: 20 22 57 41 52 4e 49 4e 47 3a 20 69 6e 74 65 72 "WARNING: inter
e940: 6e 61 6c 20 6c 61 75 6e 63 68 69 6e 67 20 77 69 nal launching wi
e950: 6c 6c 20 6e 6f 74 20 77 6f 72 6b 20 77 65 6c 6c ll not work well
e960: 20 77 69 74 68 6f 75 74 20 5c 22 75 73 65 73 68 without \"usesh
e970: 65 6c 6c 20 79 65 73 5c 22 20 69 6e 20 79 6f 75 ell yes\" in you
e980: 72 20 5b 6a 6f 62 74 6f 6f 6c 73 5d 20 73 65 63 r [jobtools] sec
e990: 74 69 6f 6e 22 29 29 0a 09 28 73 65 74 21 20 66 tion"))..(set! f
e9a0: 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 28 ullcmd (append (
e9b0: 6c 69 73 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 list remote-mega
e9c0: 74 65 73 74 20 22 2d 6d 22 20 74 65 73 74 2d 73 test "-m" test-s
e9d0: 69 67 20 22 2d 65 78 65 63 75 74 65 22 20 63 6d ig "-execute" cm
e9e0: 64 70 61 72 6d 73 29 20 64 65 62 75 67 2d 70 61 dparms) debug-pa
e9f0: 72 61 6d 20 28 6c 69 73 74 20 28 69 66 20 75 73 ram (list (if us
ea00: 65 73 68 65 6c 6c 20 22 26 22 20 22 22 29 29 29 eshell "&" "")))
ea10: 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 28 73 65 ))). ;; (se
ea20: 74 21 20 66 75 6c 6c 63 6d 64 20 28 6c 69 73 74 t! fullcmd (list
ea30: 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 remote-megatest
ea40: 20 74 65 73 74 2d 73 69 67 20 22 2d 65 78 65 63 test-sig "-exec
ea50: 75 74 65 22 20 63 6d 64 70 61 72 6d 73 20 28 69 ute" cmdparms (i
ea60: 66 20 75 73 65 73 68 65 6c 6c 20 22 26 22 20 22 f useshell "&" "
ea70: 22 29 29 29 29 29 0a 20 20 20 20 20 20 28 69 66 "))))). (if
ea80: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
ea90: 2d 78 74 65 72 6d 22 29 28 73 65 74 21 20 66 75 -xterm")(set! fu
eaa0: 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 66 75 llcmd (append fu
eab0: 6c 6c 63 6d 64 20 28 6c 69 73 74 20 22 2d 78 74 llcmd (list "-xt
eac0: 65 72 6d 22 29 29 29 29 0a 20 20 20 20 20 20 28 erm")))). (
ead0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 2a 64 debug:print 1 *d
eae0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
eaf0: 20 22 4c 61 75 6e 63 68 69 6e 67 20 22 20 77 6f "Launching " wo
eb00: 72 6b 2d 61 72 65 61 29 0a 20 20 20 20 20 20 3b rk-area). ;
eb10: 3b 20 73 65 74 20 70 72 65 2d 6c 61 75 6e 63 68 ; set pre-launch
eb20: 2d 65 6e 76 2d 76 61 72 73 20 62 65 66 6f 72 65 -env-vars before
eb30: 20 6c 61 75 6e 63 68 69 6e 67 2c 20 6b 65 65 70 launching, keep
eb40: 20 74 68 65 20 76 61 72 73 20 69 6e 20 70 72 65 the vars in pre
eb50: 76 76 61 6c 73 20 61 6e 64 20 70 75 74 20 74 68 vvals and put th
eb60: 65 20 65 6e 76 69 6f 6e 6d 65 6e 74 20 62 61 63 e envionment bac
eb70: 6b 20 77 68 65 6e 20 64 6f 6e 65 0a 20 20 20 20 k when done.
eb80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
eb90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
eba0: 72 74 2a 20 22 66 75 6c 6c 63 6d 64 3a 20 22 20 rt* "fullcmd: "
ebb0: 66 75 6c 6c 63 6d 64 29 0a 20 20 20 20 20 20 28 fullcmd). (
ebc0: 73 65 74 21 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 set! *last-launc
ebd0: 68 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f h* (current-seco
ebe0: 6e 64 73 29 29 20 3b 3b 20 61 6c 6c 20 74 68 61 nds)) ;; all tha
ebf0: 74 20 6a 75 6e 6b 20 61 62 6f 76 65 20 74 61 6b t junk above tak
ec00: 65 73 20 74 69 6d 65 2c 20 73 65 74 20 74 68 69 es time, set thi
ec10: 73 20 61 73 20 6c 61 74 65 20 61 73 20 70 6f 73 s as late as pos
ec20: 73 69 62 6c 65 2e 0a 20 20 20 20 20 20 28 6c 65 sible.. (le
ec30: 74 2a 20 28 28 63 6f 6d 6d 6f 6e 70 72 65 76 76 t* ((commonprevv
ec40: 61 6c 73 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d als (alist->env-
ec50: 76 61 72 73 0a 09 09 09 20 20 20 20 20 20 28 68 vars.... (h
ec60: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
ec70: 66 61 75 6c 74 20 2a 63 6f 6e 66 69 67 64 61 74 fault *configdat
ec80: 2a 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 65 22 * "env-override"
ec90: 20 27 28 29 29 29 29 0a 09 20 20 20 20 20 28 6d '()))).. (m
eca0: 69 73 63 70 72 65 76 76 61 6c 73 20 20 20 28 61 iscprevvals (a
ecb0: 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 3b list->env-vars ;
ecc0: 3b 20 63 6f 6e 73 6f 6c 69 64 61 74 65 20 74 68 ; consolidate th
ecd0: 69 73 20 63 6f 64 65 20 77 69 74 68 20 74 68 65 is code with the
ece0: 20 63 6f 64 65 20 69 6e 20 6d 65 67 61 74 65 73 code in megates
ecf0: 74 2e 73 63 6d 20 66 6f 72 20 22 2d 65 78 65 63 t.scm for "-exec
ed00: 75 74 65 22 0a 09 09 09 20 20 20 20 20 20 28 61 ute".... (a
ed10: 70 70 65 6e 64 20 28 6c 69 73 74 20 28 6c 69 73 ppend (list (lis
ed20: 74 20 22 4d 54 5f 54 45 53 54 5f 52 55 4e 5f 44 t "MT_TEST_RUN_D
ed30: 49 52 22 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 IR" work-area)..
ed40: 09 09 09 09 20 20 20 20 28 6c 69 73 74 20 22 4d .... (list "M
ed50: 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 T_TEST_NAME" tes
ed60: 74 2d 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 t-name)......
ed70: 20 28 6c 69 73 74 20 22 4d 54 5f 49 54 45 4d 5f (list "MT_ITEM_
ed80: 49 4e 46 4f 22 20 28 63 6f 6e 63 20 69 74 65 6d INFO" (conc item
ed90: 64 61 74 29 29 20 0a 09 09 09 09 09 20 20 20 20 dat)) ......
eda0: 28 6c 69 73 74 20 22 4d 54 5f 52 55 4e 4e 41 4d (list "MT_RUNNAM
edb0: 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 09 E" runname)...
edc0: 09 09 09 20 20 20 20 28 6c 69 73 74 20 22 4d 54 ... (list "MT
edd0: 5f 54 41 52 47 45 54 22 20 20 20 20 6d 74 5f 74 _TARGET" mt_t
ede0: 61 72 67 65 74 29 0a 09 09 09 09 09 20 20 20 20 arget)......
edf0: 28 6c 69 73 74 20 22 4d 54 5f 49 54 45 4d 50 41 (list "MT_ITEMPA
ee00: 54 48 22 20 20 69 74 65 6d 2d 70 61 74 68 29 0a TH" item-path).
ee10: 09 09 09 09 09 20 20 20 20 29 0a 09 09 09 09 20 ..... ).....
ee20: 20 20 20 20 20 69 74 65 6d 64 61 74 29 29 29 0a itemdat))).
ee30: 09 20 20 20 20 20 28 74 65 73 74 70 72 65 76 76 . (testprevv
ee40: 61 6c 73 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e als (alist->en
ee50: 76 2d 76 61 72 73 0a 09 09 09 20 20 20 20 20 20 v-vars....
ee60: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
ee70: 64 65 66 61 75 6c 74 20 74 63 6f 6e 66 69 67 20 default tconfig
ee80: 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d "pre-launch-env-
ee90: 6f 76 65 72 72 69 64 65 73 22 20 27 28 29 29 29 overrides" '()))
eea0: 29 0a 09 20 20 20 20 20 3b 3b 20 4c 61 75 6e 63 ).. ;; Launc
eeb0: 68 77 61 69 74 20 64 65 66 61 75 6c 74 73 20 74 hwait defaults t
eec0: 6f 20 74 72 75 65 2c 20 6d 75 73 74 20 6f 76 65 o true, must ove
eed0: 72 72 69 64 65 20 69 74 20 74 6f 20 74 75 72 6e rride it to turn
eee0: 20 6f 66 66 20 77 61 69 74 0a 09 20 20 20 20 20 off wait..
eef0: 28 6c 61 75 6e 63 68 77 61 69 74 20 20 20 20 20 (launchwait
ef00: 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e (if (equal? (con
ef10: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
ef20: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
ef30: 22 6c 61 75 6e 63 68 77 61 69 74 22 29 20 22 6e "launchwait") "n
ef40: 6f 22 29 20 23 66 20 23 74 29 29 0a 09 20 20 20 o") #f #t))..
ef50: 20 20 28 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 (launch-result
ef60: 73 20 28 61 70 70 6c 79 20 28 69 66 20 6c 61 75 s (apply (if lau
ef70: 6e 63 68 77 61 69 74 0a 09 09 09 09 09 70 72 6f nchwait......pro
ef80: 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 cess:cmd-run-wit
ef90: 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 74 0a 09 h-stderr->list..
efa0: 09 09 09 09 70 72 6f 63 65 73 73 2d 72 75 6e 29 ....process-run)
efb0: 0a 09 09 09 09 20 20 20 20 28 69 66 20 75 73 65 ..... (if use
efc0: 73 68 65 6c 6c 0a 09 09 09 09 09 28 6c 65 74 20 shell......(let
efd0: 28 28 63 6d 64 73 74 72 20 28 73 74 72 69 6e 67 ((cmdstr (string
efe0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 66 75 6c -intersperse ful
eff0: 6c 63 6d 64 20 22 20 22 29 29 29 0a 09 09 09 09 lcmd " "))).....
f000: 09 20 20 28 69 66 20 6c 61 75 6e 63 68 77 61 69 . (if launchwai
f010: 74 0a 09 09 09 09 09 20 20 20 20 20 20 63 6d 64 t...... cmd
f020: 73 74 72 0a 09 09 09 09 09 20 20 20 20 20 20 28 str...... (
f030: 63 6f 6e 63 20 63 6d 64 73 74 72 20 22 20 3e 3e conc cmdstr " >>
f040: 20 6d 74 5f 6c 61 75 6e 63 68 2e 6c 6f 67 20 32 mt_launch.log 2
f050: 3e 26 31 22 29 29 29 0a 09 09 09 09 09 28 63 61 >&1")))......(ca
f060: 72 20 66 75 6c 6c 63 6d 64 29 29 0a 09 09 09 09 r fullcmd)).....
f070: 20 20 20 20 28 69 66 20 75 73 65 73 68 65 6c 6c (if useshell
f080: 0a 09 09 09 09 09 27 28 29 0a 09 09 09 09 09 28 ......'()......(
f090: 63 64 72 20 66 75 6c 6c 63 6d 64 29 29 29 29 29 cdr fullcmd)))))
f0a0: 0a 20 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d . (mutex-
f0b0: 75 6e 6c 6f 63 6b 21 20 2a 6c 61 75 6e 63 68 2d unlock! *launch-
f0c0: 73 65 74 75 70 2d 6d 75 74 65 78 2a 29 20 3b 3b setup-mutex*) ;;
f0d0: 20 79 65 73 2c 20 72 65 61 6c 6c 79 20 73 68 6f yes, really sho
f0e0: 75 6c 64 20 6d 75 74 65 78 20 61 6c 6c 20 74 68 uld mutex all th
f0f0: 65 20 77 61 79 20 74 6f 20 68 65 72 65 2e 20 4e e way to here. N
f100: 65 65 64 20 74 6f 20 70 75 74 20 74 68 69 73 20 eed to put this
f110: 65 6e 74 69 72 65 20 70 72 6f 63 65 73 73 20 69 entire process i
f120: 6e 74 6f 20 61 20 66 6f 72 6b 2e 0a 09 28 69 66 nto a fork...(if
f130: 20 28 6e 6f 74 20 6c 61 75 6e 63 68 77 61 69 74 (not launchwait
f140: 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 4f 53 ) ;; give the OS
f150: 20 61 20 6c 69 74 74 6c 65 20 74 69 6d 65 20 74 a little time t
f160: 6f 20 61 6c 6c 6f 77 20 74 68 65 20 70 72 6f 63 o allow the proc
f170: 65 73 73 20 74 6f 20 73 74 61 72 74 0a 09 20 20 ess to start..
f180: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
f190: 20 30 2e 30 31 29 29 0a 09 28 77 69 74 68 2d 6f 0.01))..(with-o
f1a0: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 22 6d utput-to-file "m
f1b0: 74 5f 6c 61 75 6e 63 68 2e 6c 6f 67 22 0a 09 20 t_launch.log"..
f1c0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 20 20 (lambda ()..
f1d0: 20 28 70 72 69 6e 74 20 22 4c 41 55 4e 43 48 43 (print "LAUNCHC
f1e0: 4d 44 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 6e MD: " (string-in
f1f0: 74 65 72 73 70 65 72 73 65 20 66 75 6c 6c 63 6d tersperse fullcm
f200: 64 20 22 20 22 29 29 0a 09 20 20 20 20 28 69 66 d " ")).. (if
f210: 20 28 6c 69 73 74 3f 20 6c 61 75 6e 63 68 2d 72 (list? launch-r
f220: 65 73 75 6c 74 73 29 0a 09 09 28 61 70 70 6c 79 esults)...(apply
f230: 20 70 72 69 6e 74 20 6c 61 75 6e 63 68 2d 72 65 print launch-re
f240: 73 75 6c 74 73 29 0a 09 09 28 70 72 69 6e 74 20 sults)...(print
f250: 22 4e 4f 54 45 3a 20 6c 61 75 6e 63 68 65 64 20 "NOTE: launched
f260: 5c 22 22 20 66 75 6c 6c 63 6d 64 20 22 5c 22 5c \"" fullcmd "\"\
f270: 6e 20 20 62 75 74 20 64 69 64 20 6e 6f 74 20 77 n but did not w
f280: 61 69 74 20 66 6f 72 20 69 74 20 74 6f 20 70 72 ait for it to pr
f290: 6f 63 65 65 64 2e 20 41 64 64 20 74 68 65 20 66 oceed. Add the f
f2a0: 6f 6c 6c 6f 77 69 6e 67 20 74 6f 20 6d 65 67 61 ollowing to mega
f2b0: 74 65 73 74 2e 63 6f 6e 66 69 67 20 5c 6e 5b 73 test.config \n[s
f2c0: 65 74 75 70 5d 5c 6e 6c 61 75 6e 63 68 77 61 69 etup]\nlaunchwai
f2d0: 74 20 79 65 73 5c 6e 20 20 69 66 20 79 6f 75 20 t yes\n if you
f2e0: 68 61 76 65 20 70 72 6f 62 6c 65 6d 73 20 77 69 have problems wi
f2f0: 74 68 20 74 68 69 73 22 29 29 0a 09 20 20 20 20 th this"))..
f300: 23 3a 61 70 70 65 6e 64 29 29 0a 09 28 64 65 62 #:append))..(deb
f310: 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 ug:print 2 *defa
f320: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4c ult-log-port* "L
f330: 61 75 6e 63 68 69 6e 67 20 63 6f 6d 70 6c 65 74 aunching complet
f340: 65 64 2c 20 75 70 64 61 74 69 6e 67 20 64 62 22 ed, updating db"
f350: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
f360: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
f370: 6f 72 74 2a 20 22 4c 61 75 6e 63 68 20 72 65 73 ort* "Launch res
f380: 75 6c 74 73 3a 20 22 20 6c 61 75 6e 63 68 2d 72 ults: " launch-r
f390: 65 73 75 6c 74 73 29 0a 09 28 69 66 20 28 6e 6f esults)..(if (no
f3a0: 74 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 t launch-results
f3b0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
f3c0: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 (print "ERR
f3d0: 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 72 75 OR: Failed to ru
f3e0: 6e 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 n " (string-inte
f3f0: 72 73 70 65 72 73 65 20 66 75 6c 6c 63 6d 64 20 rsperse fullcmd
f400: 22 20 22 29 20 22 2c 20 65 78 69 74 69 6e 67 20 " ") ", exiting
f410: 6e 6f 77 22 29 0a 09 20 20 20 20 20 20 3b 3b 20 now").. ;;
f420: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz
f430: 65 21 20 64 62 29 0a 09 20 20 20 20 20 20 3b 3b e! db).. ;;
f440: 20 67 6f 6f 64 20 6f 6c 65 20 22 65 78 69 74 22 good ole "exit"
f450: 20 73 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f seems not to wo
f460: 72 6b 0a 09 20 20 20 20 20 20 3b 3b 20 28 5f 65 rk.. ;; (_e
f470: 78 69 74 20 39 29 0a 09 20 20 20 20 20 20 3b 3b xit 9).. ;;
f480: 20 62 75 74 20 74 68 69 73 20 68 61 63 6b 20 77 but this hack w
f490: 69 6c 6c 20 77 6f 72 6b 21 20 54 68 61 6e 6b 73 ill work! Thanks
f4a0: 20 67 6f 20 74 6f 20 41 6c 61 6e 20 50 6f 73 74 go to Alan Post
f4b0: 20 6f 66 20 74 68 65 20 43 68 69 63 6b 65 6e 20 of the Chicken
f4c0: 65 6d 61 69 6c 20 6c 69 73 74 0a 09 20 20 20 20 email list..
f4d0: 20 20 3b 3b 20 4e 42 2f 2f 20 49 73 20 74 68 69 ;; NB// Is thi
f4e0: 73 20 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 20 s still needed?
f4f0: 53 68 6f 75 6c 64 20 62 65 20 73 61 66 65 20 74 Should be safe t
f500: 6f 20 67 6f 20 62 61 63 6b 20 74 6f 20 22 65 78 o go back to "ex
f510: 69 74 22 20 6e 6f 77 3f 0a 09 20 20 20 20 20 20 it" now?..
f520: 28 70 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 (process-signal
f530: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
f540: 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c -id) signal/kill
f550: 29 0a 09 20 20 20 20 20 20 29 29 0a 09 28 61 6c ).. ))..(al
f560: 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 6d 69 ist->env-vars mi
f570: 73 63 70 72 65 76 76 61 6c 73 29 0a 09 28 61 6c scprevvals)..(al
f580: 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 74 65 ist->env-vars te
f590: 73 74 70 72 65 76 76 61 6c 73 29 0a 09 28 61 6c stprevvals)..(al
f5a0: 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 63 6f ist->env-vars co
f5b0: 6d 6d 6f 6e 70 72 65 76 76 61 6c 73 29 0a 09 6c mmonprevvals)..l
f5c0: 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 29 29 0a aunch-results)).
f5d0: 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 (change-dire
f5e0: 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 ctory *toppath*)
f5f0: 29 29 0a 0a 3b 3b 20 72 65 63 6f 76 65 72 20 61 ))..;; recover a
f600: 20 74 65 73 74 20 77 68 65 72 65 20 74 68 65 20 test where the
f610: 74 6f 70 20 63 6f 6e 74 72 6f 6c 6c 69 6e 67 20 top controlling
f620: 6d 74 65 73 74 20 6d 61 79 20 68 61 76 65 20 64 mtest may have d
f630: 69 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ied.;;.(define (
f640: 6c 61 75 6e 63 68 3a 72 65 63 6f 76 65 72 2d 74 launch:recover-t
f650: 65 73 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d est run-id test-
f660: 69 64 29 0a 20 20 3b 3b 20 74 68 69 73 20 66 75 id). ;; this fu
f670: 6e 63 74 69 6f 6e 20 69 73 20 63 61 6c 6c 65 64 nction is called
f680: 20 6f 6e 20 74 68 65 20 74 65 73 74 20 72 75 6e on the test run
f690: 20 68 6f 73 74 20 76 69 61 20 73 73 68 0a 20 20 host via ssh.
f6a0: 3b 3b 0a 20 20 3b 3b 20 31 2e 20 6c 6f 6f 6b 20 ;;. ;; 1. look
f6b0: 61 74 20 74 68 65 20 70 72 6f 63 65 73 73 20 66 at the process f
f6c0: 72 6f 6d 20 70 69 64 0a 20 20 3b 3b 20 20 20 20 rom pid. ;;
f6d0: 2d 20 69 73 20 69 74 20 6f 77 6e 65 64 20 62 79 - is it owned by
f6e0: 20 63 61 6c 6c 69 6e 67 20 75 73 65 72 0a 20 20 calling user.
f6f0: 3b 3b 20 20 20 20 2d 20 69 74 20 69 74 27 73 20 ;; - it it's
f700: 72 75 6e 20 64 69 72 65 63 74 6f 72 79 20 63 6f run directory co
f710: 72 72 65 63 74 20 66 6f 72 20 74 68 65 20 74 65 rrect for the te
f720: 73 74 0a 20 20 3b 3b 20 20 20 20 2d 20 69 73 20 st. ;; - is
f730: 74 68 65 72 65 20 61 20 63 6f 6e 74 72 6f 6c 6c there a controll
f740: 69 6e 67 20 6d 74 65 73 74 20 28 6d 61 79 62 65 ing mtest (maybe
f750: 20 73 74 75 63 6b 29 0a 20 20 3b 3b 20 32 2e 20 stuck). ;; 2.
f760: 69 66 20 72 65 63 6f 76 65 72 79 20 69 73 20 6e if recovery is n
f770: 65 65 64 65 64 20 77 61 74 63 68 20 70 69 64 0a eeded watch pid.
f780: 20 20 3b 3b 20 20 20 20 2d 20 77 68 65 6e 20 69 ;; - when i
f790: 74 20 65 78 69 74 73 20 74 61 6b 65 20 74 68 65 t exits take the
f7a0: 20 65 78 69 74 20 63 6f 64 65 20 61 6e 64 20 64 exit code and d
f7b0: 6f 20 74 68 65 20 6e 65 65 64 66 75 6c 0a 20 20 o the needful.
f7c0: 3b 3b 0a 20 20 28 6c 65 74 2a 20 28 28 70 69 64 ;;. (let* ((pid
f7d0: 20 28 72 6d 74 3a 74 65 73 74 2d 67 65 74 2d 74 (rmt:test-get-t
f7e0: 6f 70 2d 70 72 6f 63 65 73 73 2d 69 64 20 72 75 op-process-id ru
f7f0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 n-id test-id))..
f800: 20 28 70 73 72 65 73 20 28 77 69 74 68 2d 69 6e (psres (with-in
f810: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 09 put-from-pipe...
f820: 20 28 63 6f 6e 63 20 22 70 73 20 2d 46 20 2d 75 (conc "ps -F -u
f830: 20 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 " (current-user
f840: 2d 6e 61 6d 65 29 20 22 20 7c 20 67 72 65 70 20 -name) " | grep
f850: 2d 45 20 27 22 20 70 69 64 20 22 20 27 20 7c 20 -E '" pid " ' |
f860: 67 72 65 70 20 2d 76 20 27 67 72 65 70 20 2d 45 grep -v 'grep -E
f870: 20 22 20 70 69 64 20 22 27 22 29 0a 09 09 20 28 " pid "'")... (
f880: 6c 61 6d 62 64 61 20 28 29 0a 09 09 20 20 20 28 lambda ()... (
f890: 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 0a 09 20 read-line))))..
f8a0: 28 72 75 6e 64 69 72 20 28 69 66 20 28 73 74 72 (rundir (if (str
f8b0: 69 6e 67 3f 20 70 73 72 65 73 29 20 3b 3b 20 72 ing? psres) ;; r
f8c0: 65 61 6c 20 70 72 6f 63 65 73 73 20 6f 77 6e 65 eal process owne
f8d0: 64 20 62 79 20 75 73 65 72 0a 09 09 20 20 20 20 d by user...
f8e0: 20 28 72 65 61 64 2d 73 79 6d 62 6f 6c 69 63 2d (read-symbolic-
f8f0: 6c 69 6e 6b 20 28 63 6f 6e 63 20 22 2f 70 72 6f link (conc "/pro
f900: 63 2f 22 20 70 69 64 20 22 2f 63 77 64 22 29 29 c/" pid "/cwd"))
f910: 0a 09 09 20 20 20 20 20 23 66 29 29 29 0a 20 20 ... #f))).
f920: 20 20 3b 3b 20 6e 6f 77 20 77 61 69 74 20 6f 6e ;; now wait on
f930: 20 74 68 61 74 20 70 72 6f 63 65 73 73 20 69 66 that process if
f940: 20 61 6c 6c 20 69 73 20 63 6f 72 72 65 63 74 0a all is correct.
f950: 20 20 20 20 3b 3b 20 70 65 72 69 6f 64 69 63 61 ;; periodica
f960: 6c 6c 79 20 75 70 64 61 74 65 20 74 68 65 20 64 lly update the d
f970: 62 20 77 69 74 68 20 72 75 6e 74 69 6d 65 0a 20 b with runtime.
f980: 20 20 20 3b 3b 20 77 68 65 6e 20 74 68 65 20 70 ;; when the p
f990: 72 6f 63 65 73 73 20 65 78 69 74 73 20 6c 6f 6f rocess exits loo
f9a0: 6b 20 61 74 20 74 68 65 20 64 62 2c 20 69 66 20 k at the db, if
f9b0: 73 74 69 6c 6c 20 52 55 4e 4e 49 4e 47 20 61 66 still RUNNING af
f9c0: 74 65 72 20 31 30 20 73 65 63 6f 6e 64 73 20 73 ter 10 seconds s
f9d0: 65 74 0a 20 20 20 20 3b 3b 20 73 74 61 74 65 2f et. ;; state/
f9e0: 73 74 61 74 75 73 20 61 70 70 72 6f 70 72 69 61 status appropria
f9f0: 74 65 6c 79 0a 20 20 20 20 28 70 72 6f 63 65 73 tely. (proces
fa00: 73 2d 77 61 69 74 20 70 69 64 29 29 29 0a s-wait pid))).