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 37 2c 20 4d 61 74 74 68 65 77 06-2017, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 54 68 69 73 20 66 69 6c 65 20 69 73 20 70 61 This file is pa
0040: 72 74 20 6f 66 20 4d 65 67 61 74 65 73 74 2e 0a rt of Megatest..
0050: 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 ;; .;; Megat
0060: 65 73 74 20 69 73 20 66 72 65 65 20 73 6f 66 74 est is free soft
0070: 77 61 72 65 3a 20 79 6f 75 20 63 61 6e 20 72 65 ware: you can re
0080: 64 69 73 74 72 69 62 75 74 65 20 69 74 20 61 6e distribute it an
0090: 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b 3b 20 20 d/or modify.;;
00a0: 20 20 20 69 74 20 75 6e 64 65 72 20 74 68 65 20 it under the
00b0: 74 65 72 6d 73 20 6f 66 20 74 68 65 20 47 4e 55 terms of the GNU
00c0: 20 47 65 6e 65 72 61 6c 20 50 75 62 6c 69 63 20 General Public
00d0: 4c 69 63 65 6e 73 65 20 61 73 20 70 75 62 6c 69 License as publi
00e0: 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 20 20 74 shed by.;; t
00f0: 68 65 20 46 72 65 65 20 53 6f 66 74 77 61 72 65 he Free Software
0100: 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 65 69 74 Foundation, eit
0110: 68 65 72 20 76 65 72 73 69 6f 6e 20 33 20 6f 66 her version 3 of
0120: 20 74 68 65 20 4c 69 63 65 6e 73 65 2c 20 6f 72 the License, or
0130: 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 6f 75 72 .;; (at your
0140: 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 6c 61 74 option) any lat
0150: 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b 3b 20 0a er version..;; .
0160: 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 73 74 20 ;; Megatest
0170: 69 73 20 64 69 73 74 72 69 62 75 74 65 64 20 69 is distributed i
0180: 6e 20 74 68 65 20 68 6f 70 65 20 74 68 61 74 20 n the hope that
0190: 69 74 20 77 69 6c 6c 20 62 65 20 75 73 65 66 75 it will be usefu
01a0: 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 20 57 49 l,.;; but WI
01b0: 54 48 4f 55 54 20 41 4e 59 20 57 41 52 52 41 4e THOUT ANY WARRAN
01c0: 54 59 3b 20 77 69 74 68 6f 75 74 20 65 76 65 6e TY; without even
01d0: 20 74 68 65 20 69 6d 70 6c 69 65 64 20 77 61 72 the implied war
01e0: 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 20 20 20 ranty of.;;
01f0: 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 20 MERCHANTABILITY
0200: 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 41 or FITNESS FOR A
0210: 20 50 41 52 54 49 43 55 4c 41 52 20 50 55 52 50 PARTICULAR PURP
0220: 4f 53 45 2e 20 20 53 65 65 20 74 68 65 0a 3b 3b OSE. See the.;;
0230: 20 20 20 20 20 47 4e 55 20 47 65 6e 65 72 61 6c GNU General
0240: 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 20 Public License
0250: 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 69 6c 73 for more details
0260: 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 59 6f 75 ..;; .;; You
0270: 20 73 68 6f 75 6c 64 20 68 61 76 65 20 72 65 63 should have rec
0280: 65 69 76 65 64 20 61 20 63 6f 70 79 20 6f 66 20 eived a copy of
0290: 74 68 65 20 47 4e 55 20 47 65 6e 65 72 61 6c 20 the GNU General
02a0: 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 65 0a 3b Public License.;
02b0: 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 69 74 68 ; along with
02c0: 20 4d 65 67 61 74 65 73 74 2e 20 20 49 66 20 6e Megatest. If n
02d0: 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 3a 2f 2f ot, see <http://
02e0: 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c 69 63 65 www.gnu.org/lice
02f0: 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d nses/>...;;=====
0300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0340: 3d 0a 3b 3b 20 6c 61 75 6e 63 68 20 61 20 74 61 =.;; launch a ta
0350: 73 6b 20 2d 20 74 68 69 73 20 72 75 6e 73 20 6f sk - this runs o
0360: 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 74 69 6e n the originatin
0370: 67 20 68 6f 73 74 2c 20 74 65 73 74 73 20 74 68 g host, tests th
0380: 65 6d 73 65 6c 76 65 73 0a 3b 3b 0a 3b 3b 3d 3d emselves.;;.;;==
0390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03d0: 3d 3d 3d 3d 0a 0a 28 75 73 65 20 72 65 67 65 78 ====..(use regex
03e0: 20 72 65 67 65 78 2d 63 61 73 65 20 62 61 73 65 regex-case base
03f0: 36 34 20 73 71 6c 69 74 65 33 20 73 72 66 69 2d 64 sqlite3 srfi-
0400: 31 38 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 18 directory-uti
0410: 6c 73 20 70 6f 73 69 78 2d 65 78 74 72 61 73 20 ls posix-extras
0420: 7a 33 0a 20 20 20 20 20 63 61 6c 6c 2d 77 69 74 z3. call-wit
0430: 68 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 h-environment-va
0440: 72 69 61 62 6c 65 73 20 63 73 76 29 0a 28 75 73 riables csv).(us
0450: 65 20 74 79 70 65 64 2d 72 65 63 6f 72 64 73 20 e typed-records
0460: 70 61 74 68 6e 61 6d 65 2d 65 78 70 61 6e 64 20 pathname-expand
0470: 6d 61 74 63 68 61 62 6c 65 29 0a 0a 28 69 6d 70 matchable)..(imp
0480: 6f 72 74 20 28 70 72 65 66 69 78 20 62 61 73 65 ort (prefix base
0490: 36 34 20 62 61 73 65 36 34 3a 29 29 0a 28 69 6d 64 base64:)).(im
04a0: 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c port (prefix sql
04b0: 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a ite3 sqlite3:)).
04c0: 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 .(declare (unit
04d0: 6c 61 75 6e 63 68 29 29 0a 28 64 65 63 6c 61 72 launch)).(declar
04e0: 65 20 28 75 73 65 73 20 73 75 62 72 75 6e 29 29 e (uses subrun))
04f0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses
0500: 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 common)).(declar
0510: 65 20 28 75 73 65 73 20 63 6f 6e 66 69 67 66 29 e (uses configf)
0520: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
0530: 20 64 62 29 29 0a 28 64 65 63 6c 61 72 65 20 28 db)).(declare (
0540: 75 73 65 73 20 65 7a 73 74 65 70 73 29 29 0a 0a uses ezsteps))..
0550: 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e (include "common
0560: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 _records.scm").(
0570: 69 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 63 include "key_rec
0580: 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c ords.scm").(incl
0590: 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 2e ude "db_records.
05a0: 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 scm").(include "
05b0: 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d megatest-fossil-
05c0: 68 61 73 68 2e 73 63 6d 22 29 0a 0a 3b 3b 3d 3d hash.scm")..;;==
05d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0610: 3d 3d 3d 3d 0a 3b 3b 20 65 7a 73 74 65 70 73 0a ====.;; ezsteps.
0620: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0660: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 65 7a 73 ========..;; ezs
0670: 74 65 70 73 20 77 65 72 65 20 67 6f 69 6e 67 20 teps were going
0680: 74 6f 20 62 65 20 63 6f 64 65 64 20 61 73 0a 3b to be coded as.;
0690: 3b 20 73 74 65 70 6e 61 6d 65 5b 2c 70 72 65 64 ; stepname[,pred
06a0: 73 74 65 70 31 2c 70 72 65 64 73 74 65 70 32 20 step1,predstep2
06b0: 2e 2e 2e 5d 20 5b 7b 56 41 52 31 3d 66 69 72 73 ...] [{VAR1=firs
06c0: 74 2c 73 65 63 6f 6e 64 2c 74 68 69 72 64 7d 5d t,second,third}]
06d0: 20 63 6f 6d 6d 61 6e 64 20 74 6f 20 65 78 65 63 command to exec
06e0: 75 74 65 0a 3b 3b 20 20 20 42 55 54 0a 3b 3b 20 ute.;; BUT.;;
06f0: 6e 6f 77 20 61 72 65 0a 3b 3b 20 73 74 65 70 6e now are.;; stepn
0700: 61 6d 65 20 7b 56 41 52 3d 66 69 72 73 74 2c 73 ame {VAR=first,s
0710: 65 63 6f 6e 64 2c 74 68 69 72 64 20 2e 2e 2e 7d econd,third ...}
0720: 20 63 6f 6d 6d 61 6e 64 20 2e 2e 2e 0a 3b 3b 20 command ....;;
0730: 77 68 65 72 65 20 74 68 65 20 7b 56 41 52 3d 66 where the {VAR=f
0740: 69 72 73 74 2c 73 65 63 6f 6e 64 2c 74 68 69 72 irst,second,thir
0750: 64 20 2e 2e 2e 7d 20 69 73 20 6f 70 74 69 6f 6e d ...} is option
0760: 61 6c 2e 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 6e al...;; given an
0770: 20 65 78 69 74 20 63 6f 64 65 20 61 6e 64 20 77 exit code and w
0780: 68 65 74 68 65 72 20 6f 72 20 6e 6f 74 20 6c 6f hether or not lo
0790: 67 70 72 6f 20 77 61 73 20 75 73 65 64 20 63 61 gpro was used ca
07a0: 6c 63 75 6c 61 74 65 20 4f 4b 2f 42 41 44 0a 3b lculate OK/BAD.;
07b0: 3b 20 72 65 74 75 72 6e 20 23 74 20 69 66 20 77 ; return #t if w
07c0: 65 20 61 72 65 20 6f 6b 2c 20 23 66 20 6f 74 68 e are ok, #f oth
07d0: 65 72 77 69 73 65 0a 28 64 65 66 69 6e 65 20 28 erwise.(define (
07e0: 73 74 65 70 72 75 6e 2d 67 6f 6f 64 3f 20 6c 6f steprun-good? lo
07f0: 67 70 72 6f 20 65 78 69 74 63 6f 64 65 20 73 74 gpro exitcode st
0800: 65 70 70 61 72 6d 73 29 0a 20 20 28 6f 72 20 28 epparms). (or (
0810: 65 71 3f 20 65 78 69 74 63 6f 64 65 20 30 29 0a eq? exitcode 0).
0820: 20 20 20 20 20 20 28 61 6e 64 20 6c 6f 67 70 72 (and logpr
0830: 6f 20 28 65 71 3f 20 65 78 69 74 63 6f 64 65 20 o (eq? exitcode
0840: 32 29 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 2)) ;; shouldn't
0850: 20 74 68 69 73 20 62 65 20 28 6d 65 6d 62 65 72 this be (member
0860: 20 65 78 69 74 63 6f 64 65 20 32 20 2e 2e 2e 29 exitcode 2 ...)
0870: 20 77 69 74 68 20 74 68 65 20 6f 74 68 65 72 20 with the other
0880: 6f 6b 20 63 6f 64 65 73 3f 0a 20 20 20 20 20 20 ok codes?.
0890: 28 6c 65 74 2a 20 28 28 70 61 72 61 6d 73 20 28 (let* ((params (
08a0: 61 6c 69 73 74 2d 72 65 66 20 27 70 61 72 61 6d alist-ref 'param
08b0: 73 20 73 74 65 70 70 61 72 6d 73 29 29 20 3b 3b s stepparms)) ;;
08c0: 20 67 65 74 20 74 68 65 20 70 61 72 61 6d 73 20 get the params
08d0: 73 65 63 74 69 6f 6e 0a 09 20 20 20 20 20 28 6b section.. (k
08e0: 65 65 70 2d 67 6f 69 6e 67 20 28 69 66 20 70 61 eep-going (if pa
08f0: 72 61 6d 73 0a 09 09 09 20 20 20 20 20 28 61 6c rams.... (al
0900: 69 73 74 2d 72 65 66 20 22 6b 65 65 70 2d 67 6f ist-ref "keep-go
0910: 69 6e 67 22 20 70 61 72 61 6d 73 20 65 71 75 61 ing" params equa
0920: 6c 3f 29 0a 09 09 09 20 20 20 20 20 23 66 29 29 l?).... #f))
0930: 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 )..(debug:print
0940: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
0950: 6f 72 74 2a 20 22 6b 65 65 70 2d 67 6f 69 6e 67 ort* "keep-going
0960: 3d 22 20 6b 65 65 70 2d 67 6f 69 6e 67 29 0a 09 =" keep-going)..
0970: 28 61 6e 64 20 6b 65 65 70 2d 67 6f 69 6e 67 20 (and keep-going
0980: 28 65 71 75 61 6c 3f 20 28 63 61 72 20 6b 65 65 (equal? (car kee
0990: 70 2d 67 6f 69 6e 67 29 20 22 79 65 73 22 29 29 p-going) "yes"))
09a0: 29 29 29 0a 0a 3b 3b 20 69 66 20 68 61 6e 64 65 )))..;; if hande
09b0: 64 20 61 20 73 74 72 69 6e 67 2c 20 70 72 6f 63 d a string, proc
09c0: 65 73 73 20 69 74 2c 20 65 6c 73 65 20 6c 6f 6f ess it, else loo
09d0: 6b 20 66 6f 72 20 4d 54 5f 43 4d 44 49 4e 46 4f k for MT_CMDINFO
09e0: 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 .(define (launch
09f0: 3a 67 65 74 2d 63 6d 64 69 6e 66 6f 2d 61 73 73 :get-cmdinfo-ass
0a00: 6f 63 2d 6c 69 73 74 20 23 21 6b 65 79 20 28 65 oc-list #!key (e
0a10: 6e 63 6f 64 65 64 2d 63 6d 64 20 23 66 29 29 0a ncoded-cmd #f)).
0a20: 20 20 28 6c 65 74 20 28 28 65 6e 63 63 6d 64 20 (let ((enccmd
0a30: 28 69 66 20 65 6e 63 6f 64 65 64 2d 63 6d 64 20 (if encoded-cmd
0a40: 65 6e 63 6f 64 65 64 2d 63 6d 64 20 28 67 65 74 encoded-cmd (get
0a50: 65 6e 76 20 22 4d 54 5f 43 4d 44 49 4e 46 4f 22 env "MT_CMDINFO"
0a60: 29 29 29 29 0a 20 20 20 20 28 69 66 20 65 6e 63 )))). (if enc
0a70: 63 6d 64 0a 09 28 63 6f 6d 6d 6f 6e 3a 72 65 61 cmd..(common:rea
0a80: 64 2d 65 6e 63 6f 64 65 64 2d 73 74 72 69 6e 67 d-encoded-string
0a90: 20 65 6e 63 63 6d 64 29 0a 09 27 28 29 29 29 29 enccmd)..'())))
0aa0: 0a 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ..;;
0ab0: 20 20 20 20 20 20 20 20 20 20 20 30 20 20 20 20 0
0ac0: 20 20 20 20 20 20 20 31 20 20 20 20 20 20 20 20 1
0ad0: 20 20 20 20 20 20 32 20 20 20 20 20 20 20 20 20 2
0ae0: 20 20 20 20 20 33 0a 28 64 65 66 73 74 72 75 63 3.(defstruc
0af0: 74 20 6c 61 75 6e 63 68 3a 65 69 6e 66 20 28 70 t launch:einf (p
0b00: 69 64 20 23 74 29 28 65 78 69 74 2d 73 74 61 74 id #t)(exit-stat
0b10: 75 73 20 23 74 29 28 65 78 69 74 2d 63 6f 64 65 us #t)(exit-code
0b20: 20 23 74 29 28 72 6f 6c 6c 75 70 2d 73 74 61 74 #t)(rollup-stat
0b30: 75 73 20 30 29 29 0a 0a 3b 3b 20 72 65 74 75 72 us 0))..;; retur
0b40: 6e 20 28 63 6f 6e 63 20 73 74 61 74 75 73 20 22 n (conc status "
0b50: 3a 20 22 20 63 6f 6d 6d 65 6e 74 29 20 66 72 6f : " comment) fro
0b60: 6d 20 74 68 65 20 66 69 6e 61 6c 20 73 65 63 74 m the final sect
0b70: 69 6f 6e 20 73 6f 20 74 68 61 74 0a 3b 3b 20 20 ion so that.;;
0b80: 20 74 68 65 20 63 6f 6d 6d 65 6e 74 20 63 61 6e the comment can
0b90: 20 62 65 20 73 65 74 20 69 6e 20 74 68 65 20 73 be set in the s
0ba0: 74 65 70 20 72 65 63 6f 72 64 20 69 6e 20 6c 61 tep record in la
0bb0: 75 6e 63 68 2e 73 63 6d 0a 3b 3b 0a 28 64 65 66 unch.scm.;;.(def
0bc0: 69 6e 65 20 28 6c 61 75 6e 63 68 3a 6c 6f 61 64 ine (launch:load
0bd0: 2d 6c 6f 67 70 72 6f 2d 64 61 74 20 72 75 6e 2d -logpro-dat run-
0be0: 69 64 20 74 65 73 74 2d 69 64 20 73 74 65 70 6e id test-id stepn
0bf0: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 63 6e ame). (let ((cn
0c00: 61 6d 65 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 ame (conc stepna
0c10: 6d 65 20 22 2e 64 61 74 22 29 29 29 0a 20 20 20 me ".dat"))).
0c20: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (if (common:fil
0c30: 65 2d 65 78 69 73 74 73 3f 20 63 6e 61 6d 65 29 e-exists? cname)
0c40: 0a 09 28 6c 65 74 2a 20 28 28 64 61 74 20 20 28 ..(let* ((dat (
0c50: 72 65 61 64 2d 63 6f 6e 66 69 67 20 63 6e 61 6d read-config cnam
0c60: 65 20 23 66 20 23 66 29 29 0a 09 20 20 20 20 20 e #f #f))..
0c70: 20 20 28 63 73 76 72 20 28 64 62 3a 6c 6f 67 70 (csvr (db:logp
0c80: 72 6f 2d 64 61 74 2d 3e 63 73 76 20 64 61 74 20 ro-dat->csv dat
0c90: 73 74 65 70 6e 61 6d 65 29 29 0a 09 20 20 20 20 stepname))..
0ca0: 20 20 20 28 63 73 76 74 20 28 6c 65 74 2d 76 61 (csvt (let-va
0cb0: 6c 75 65 73 20 28 28 28 66 6d 74 2d 63 65 6c 6c lues (((fmt-cell
0cc0: 20 66 6d 74 2d 72 65 63 6f 72 64 20 66 6d 74 2d fmt-record fmt-
0cd0: 63 73 76 29 20 28 6d 61 6b 65 2d 66 6f 72 6d 61 csv) (make-forma
0ce0: 74 20 22 2c 22 29 29 29 0a 09 09 20 20 20 20 20 t ",")))...
0cf0: 20 20 28 66 6d 74 2d 63 73 76 20 28 6d 61 70 20 (fmt-csv (map
0d00: 6c 69 73 74 2d 3e 63 73 76 2d 72 65 63 6f 72 64 list->csv-record
0d10: 20 63 73 76 72 29 29 29 29 0a 09 20 20 20 20 20 csvr))))..
0d20: 20 20 28 73 74 61 74 75 73 20 28 63 6f 6e 66 69 (status (confi
0d30: 67 66 3a 6c 6f 6f 6b 75 70 20 64 61 74 20 22 66 gf:lookup dat "f
0d40: 69 6e 61 6c 22 20 22 65 78 69 74 2d 73 74 61 74 inal" "exit-stat
0d50: 75 73 22 29 29 0a 09 20 20 20 20 20 20 20 28 6d us")).. (m
0d60: 73 67 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a sg (configf:
0d70: 6c 6f 6f 6b 75 70 20 64 61 74 20 22 66 69 6e 61 lookup dat "fina
0d80: 6c 22 20 22 6d 65 73 73 61 67 65 22 29 29 29 0a l" "message"))).
0d90: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 63 73 (if cs
0da0: 76 74 20 20 3b 3b 20 74 68 69 73 20 69 66 20 62 vt ;; this if b
0db0: 6c 6f 63 6b 65 64 20 73 74 61 63 6b 20 64 75 6d locked stack dum
0dc0: 70 20 63 61 75 73 65 64 20 62 79 20 2e 64 61 74 p caused by .dat
0dd0: 20 66 69 6c 65 20 66 72 6f 6d 20 6c 6f 67 70 72 file from logpr
0de0: 6f 20 62 65 69 6e 67 20 30 2d 62 79 74 65 2e 20 o being 0-byte.
0df0: 20 66 69 78 65 64 20 62 79 20 75 70 67 72 61 64 fixed by upgrad
0e00: 69 6e 67 20 6c 6f 67 70 72 6f 0a 20 20 20 20 20 ing logpro.
0e10: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 63 73 (rmt:cs
0e20: 76 2d 3e 74 65 73 74 2d 64 61 74 61 20 72 75 6e v->test-data run
0e30: 2d 69 64 20 74 65 73 74 2d 69 64 20 63 73 76 74 -id test-id csvt
0e40: 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ).. (debug:
0e50: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
0e60: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
0e70: 52 3a 20 6e 6f 20 63 73 76 64 61 74 20 65 78 69 R: no csvdat exi
0e80: 73 74 73 20 66 6f 72 20 72 75 6e 2d 69 64 3a 20 sts for run-id:
0e90: 22 20 72 75 6e 2d 69 64 20 22 20 74 65 73 74 2d " run-id " test-
0ea0: 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 20 id: " test-id "
0eb0: 73 74 65 70 6e 61 6d 65 3a 20 22 20 73 74 65 70 stepname: " step
0ec0: 6e 61 6d 65 20 22 2c 20 63 68 65 63 6b 20 74 68 name ", check th
0ed0: 61 74 20 6c 6f 67 70 72 6f 20 76 65 72 73 69 6f at logpro versio
0ee0: 6e 20 69 73 20 31 2e 31 35 20 6f 72 20 6e 65 77 n is 1.15 or new
0ef0: 65 72 22 29 29 0a 09 20 20 3b 3b 20 20 28 64 65 er")).. ;; (de
0f00: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
0f10: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
0f20: 6f 72 74 2a 20 22 45 72 72 6f 72 3a 20 72 75 6e ort* "Error: run
0f30: 2d 69 64 2f 74 65 73 74 2d 69 64 2f 73 74 65 70 -id/test-id/step
0f40: 6e 61 6d 65 3d 22 72 75 6e 2d 69 64 22 2f 22 74 name="run-id"/"t
0f50: 65 73 74 2d 69 64 22 2f 22 73 74 65 70 6e 61 6d est-id"/"stepnam
0f60: 65 22 20 3d 3e 20 62 61 64 20 63 73 76 72 3d 22 e" => bad csvr="
0f70: 63 73 76 72 29 0a 09 20 20 3b 3b 20 20 29 0a 09 csvr).. ;; )..
0f80: 20 20 28 63 6f 6e 64 0a 09 20 20 20 28 28 65 71 (cond.. ((eq
0f90: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 ual? status "PAS
0fa0: 53 22 29 20 22 50 41 53 53 22 29 20 3b 3b 20 73 S") "PASS") ;; s
0fb0: 6b 69 70 20 74 68 65 20 6d 65 73 73 61 67 65 20 kip the message
0fc0: 70 61 72 74 20 69 66 20 73 74 61 74 75 73 20 69 part if status i
0fd0: 73 20 70 61 73 73 0a 09 20 20 20 28 73 74 61 74 s pass.. (stat
0fe0: 75 73 20 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 us (conc (config
0ff0: 66 3a 6c 6f 6f 6b 75 70 20 64 61 74 20 22 66 69 f:lookup dat "fi
1000: 6e 61 6c 22 20 22 65 78 69 74 2d 73 74 61 74 75 nal" "exit-statu
1010: 73 22 29 20 22 3a 20 22 20 28 69 66 20 6d 73 67 s") ": " (if msg
1020: 20 6d 73 67 20 22 6e 6f 20 6d 65 73 73 61 67 65 msg "no message
1030: 22 29 29 29 0a 09 20 20 20 28 65 6c 73 65 20 23 "))).. (else #
1040: 66 29 29 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 f)))..#f)))..(de
1050: 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 6d 61 6e fine (launch:man
1060: 61 67 65 2d 73 74 65 70 73 20 72 75 6e 2d 69 64 age-steps run-id
1070: 20 74 65 73 74 2d 69 64 20 69 74 65 6d 2d 70 61 test-id item-pa
1080: 74 68 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 th fullrunscript
1090: 20 65 7a 73 74 65 70 73 20 73 75 62 72 75 6e 20 ezsteps subrun
10a0: 74 65 73 74 2d 6e 61 6d 65 20 74 63 6f 6e 66 69 test-name tconfi
10b0: 67 72 65 67 20 65 78 69 74 2d 69 6e 66 6f 20 6d greg exit-info m
10c0: 29 0a 20 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 ). ;; (let-valu
10d0: 65 73 0a 20 20 3b 3b 20 20 28 28 28 70 69 64 20 es. ;; (((pid
10e0: 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 74 exit-status exit
10f0: 2d 63 6f 64 65 29 0a 20 20 3b 3b 20 20 20 20 28 -code). ;; (
1100: 72 75 6e 2d 6e 2d 77 61 69 74 20 66 75 6c 6c 72 run-n-wait fullr
1110: 75 6e 73 63 72 69 70 74 29 29 29 0a 20 20 3b 3b unscript))). ;;
1120: 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 (tests:test-set
1130: 2d 73 74 61 74 75 73 21 20 74 65 73 74 2d 69 64 -status! test-id
1140: 20 22 52 55 4e 4e 49 4e 47 22 20 22 6e 2f 61 22 "RUNNING" "n/a"
1150: 20 23 66 20 23 66 29 0a 20 20 3b 3b 20 53 69 6e #f #f). ;; Sin
1160: 63 65 20 77 65 20 73 68 6f 75 6c 64 20 68 61 76 ce we should hav
1170: 65 20 61 20 63 6c 65 61 6e 20 73 6c 61 74 65 20 e a clean slate
1180: 61 74 20 74 68 69 73 20 74 69 6d 65 20 74 68 65 at this time the
1190: 72 65 20 69 73 20 6e 6f 20 6e 65 65 64 20 74 6f re is no need to
11a0: 20 64 6f 20 0a 20 20 3b 3b 20 61 6e 79 20 6f 66 do . ;; any of
11b0: 20 74 68 65 20 6f 74 68 65 72 20 73 74 75 66 66 the other stuff
11c0: 20 74 68 61 74 20 74 65 73 74 73 3a 74 65 73 74 that tests:test
11d0: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 6f 65 -set-status! doe
11e0: 73 2e 20 4c 65 74 27 73 20 6a 75 73 74 20 0a 20 s. Let's just .
11f0: 20 3b 3b 20 66 6f 72 63 65 20 52 55 4e 4e 49 4e ;; force RUNNIN
1200: 47 2f 6e 2f 61 0a 0a 20 20 3b 3b 20 28 74 68 72 G/n/a.. ;; (thr
1210: 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 33 29 0a ead-sleep! 0.3).
1220: 20 20 3b 3b 20 28 74 65 73 74 73 3a 74 65 73 74 ;; (tests:test
1230: 2d 66 6f 72 63 65 2d 73 74 61 74 65 2d 73 74 61 -force-state-sta
1240: 74 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 tus! run-id test
1250: 2d 69 64 20 22 52 55 4e 4e 49 4e 47 22 20 22 6e -id "RUNNING" "n
1260: 2f 61 22 29 0a 20 20 28 72 6d 74 3a 73 65 74 2d /a"). (rmt:set-
1270: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
1280: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 72 -roll-up-items r
1290: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name
12a0: 69 74 65 6d 2d 70 61 74 68 20 22 52 55 4e 4e 49 item-path "RUNNI
12b0: 4e 47 22 20 23 66 20 23 66 29 20 0a 20 20 3b 3b NG" #f #f) . ;;
12c0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
12d0: 30 2e 33 29 20 3b 3b 20 4e 46 53 20 73 6c 6f 77 0.3) ;; NFS slow
12e0: 6e 65 73 73 20 68 61 73 20 63 61 75 73 65 64 20 ness has caused
12f0: 67 72 69 65 66 20 68 65 72 65 0a 0a 20 20 3b 3b grief here.. ;;
1300: 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 72 if there is a r
1310: 75 6e 73 63 72 69 70 74 20 64 6f 20 69 74 20 66 unscript do it f
1320: 69 72 73 74 0a 20 20 28 69 66 20 66 75 6c 6c 72 irst. (if fullr
1330: 75 6e 73 63 72 69 70 74 0a 20 20 20 20 20 20 28 unscript. (
1340: 6c 65 74 20 28 28 70 69 64 20 28 70 72 6f 63 65 let ((pid (proce
1350: 73 73 2d 72 75 6e 20 66 75 6c 6c 72 75 6e 73 63 ss-run fullrunsc
1360: 72 69 70 74 29 29 29 0a 09 28 72 6d 74 3a 74 65 ript)))..(rmt:te
1370: 73 74 2d 73 65 74 2d 74 6f 70 2d 70 72 6f 63 65 st-set-top-proce
1380: 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 74 65 ss-pid run-id te
1390: 73 74 2d 69 64 20 70 69 64 29 0a 09 28 6c 65 74 st-id pid)..(let
13a0: 20 6c 6f 6f 70 20 28 28 69 20 30 29 29 0a 09 20 loop ((i 0))..
13b0: 20 28 6c 65 74 2d 76 61 6c 75 65 73 0a 09 20 20 (let-values..
13c0: 20 28 28 28 70 69 64 2d 76 61 6c 20 65 78 69 74 (((pid-val exit
13d0: 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f 64 -status exit-cod
13e0: 65 29 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 e) (process-wait
13f0: 20 70 69 64 20 23 74 29 29 29 0a 09 20 20 20 28 pid #t))).. (
1400: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d 29 0a 09 mutex-lock! m)..
1410: 20 20 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d (launch:einf-
1420: 70 69 64 2d 73 65 74 21 20 20 20 20 20 20 20 20 pid-set!
1430: 20 20 20 65 78 69 74 2d 69 6e 66 6f 20 20 70 69 exit-info pi
1440: 64 29 20 20 20 20 20 20 20 20 20 3b 3b 20 28 76 d) ;; (v
1450: 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 74 2d ector-set! exit-
1460: 69 6e 66 6f 20 30 20 70 69 64 29 0a 09 20 20 20 info 0 pid)..
1470: 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 (launch:einf-exi
1480: 74 2d 73 74 61 74 75 73 2d 73 65 74 21 20 20 20 t-status-set!
1490: 65 78 69 74 2d 69 6e 66 6f 20 20 65 78 69 74 2d exit-info exit-
14a0: 73 74 61 74 75 73 29 20 3b 3b 20 28 76 65 63 74 status) ;; (vect
14b0: 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 or-set! exit-inf
14c0: 6f 20 31 20 65 78 69 74 2d 73 74 61 74 75 73 29 o 1 exit-status)
14d0: 0a 09 20 20 20 28 6c 61 75 6e 63 68 3a 65 69 6e .. (launch:ein
14e0: 66 2d 65 78 69 74 2d 63 6f 64 65 2d 73 65 74 21 f-exit-code-set!
14f0: 20 20 20 20 20 65 78 69 74 2d 69 6e 66 6f 20 20 exit-info
1500: 65 78 69 74 2d 63 6f 64 65 29 20 20 20 3b 3b 20 exit-code) ;;
1510: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 (vector-set! exi
1520: 74 2d 69 6e 66 6f 20 32 20 65 78 69 74 2d 63 6f t-info 2 exit-co
1530: 64 65 29 0a 09 20 20 20 28 6c 61 75 6e 63 68 3a de).. (launch:
1540: 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 einf-rollup-stat
1550: 75 73 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 us-set! exit-inf
1560: 6f 20 20 65 78 69 74 2d 63 6f 64 65 29 20 20 20 o exit-code)
1570: 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 ;; (vector-set!
1580: 65 78 69 74 2d 69 6e 66 6f 20 33 20 65 78 69 74 exit-info 3 exit
1590: 2d 63 6f 64 65 29 20 20 3b 3b 20 72 6f 6c 6c 75 -code) ;; rollu
15a0: 70 20 73 74 61 74 75 73 0a 09 20 20 20 28 6d 75 p status.. (mu
15b0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 29 0a 09 tex-unlock! m)..
15c0: 20 20 20 28 69 66 20 28 65 71 3f 20 70 69 64 2d (if (eq? pid-
15d0: 76 61 6c 20 30 29 0a 09 20 20 20 20 20 20 20 28 val 0).. (
15e0: 62 65 67 69 6e 0a 09 09 20 28 74 68 72 65 61 64 begin... (thread
15f0: 2d 73 6c 65 65 70 21 20 32 29 0a 09 09 20 28 6c -sleep! 2)... (l
1600: 6f 6f 70 20 28 2b 20 69 20 31 29 29 29 0a 09 20 oop (+ i 1)))..
1610: 20 20 20 20 20 20 29 29 29 29 29 0a 20 20 3b 3b ))))). ;;
1620: 20 74 68 65 6e 2c 20 69 66 20 72 75 6e 73 63 72 then, if runscr
1630: 69 70 74 20 72 61 6e 20 6f 6b 20 28 6f 72 20 64 ipt ran ok (or d
1640: 69 64 20 6e 6f 74 20 67 65 74 20 63 61 6c 6c 65 id not get calle
1650: 64 29 0a 20 20 3b 3b 20 64 6f 20 61 6c 6c 20 74 d). ;; do all t
1660: 68 65 20 65 7a 73 74 65 70 73 20 28 69 66 20 61 he ezsteps (if a
1670: 6e 79 29 0a 20 20 28 69 66 20 28 6f 72 20 65 7a ny). (if (or ez
1680: 73 74 65 70 73 20 73 75 62 72 75 6e 29 0a 20 20 steps subrun).
1690: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 74 (let* ((test
16a0: 2d 72 75 6e 2d 64 69 72 20 28 74 65 73 74 73 3a -run-dir (tests:
16b0: 67 65 74 2d 74 65 73 74 2d 70 61 74 68 2d 66 72 get-test-path-fr
16c0: 6f 6d 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 29 29 om-environment))
16d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 . (t
16e0: 65 73 74 63 6f 6e 66 69 67 20 3b 3b 20 28 72 65 estconfig ;; (re
16f0: 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 ad-config (conc
1700: 77 6f 72 6b 2d 61 72 65 61 20 22 2f 74 65 73 74 work-area "/test
1710: 63 6f 6e 66 69 67 22 29 20 23 66 20 23 74 20 65 config") #f #t e
1720: 6e 76 69 72 6f 6e 2d 70 61 74 74 3a 20 22 70 72 nviron-patt: "pr
1730: 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 76 61 72 e-launch-env-var
1740: 73 22 29 29 20 3b 3b 20 46 49 58 4d 45 3f 3f 3f s")) ;; FIXME???
1750: 20 69 73 20 61 6c 6c 6f 77 2d 73 79 73 74 65 6d is allow-system
1760: 20 6f 6b 20 68 65 72 65 3f 0a 09 20 20 20 20 20 ok here?..
1770: 20 3b 3b 20 4e 4f 54 45 3a 20 69 74 20 69 73 20 ;; NOTE: it is
1780: 74 65 6d 70 74 69 6e 67 20 74 6f 20 74 75 72 6e tempting to turn
1790: 20 6f 66 66 20 66 6f 72 63 65 2d 63 72 65 61 74 off force-creat
17a0: 65 20 6f 66 20 74 65 73 74 63 6f 6e 66 69 67 20 e of testconfig
17b0: 62 75 74 20 64 79 6e 61 6d 69 63 0a 09 20 20 20 but dynamic..
17c0: 20 20 20 3b 3b 20 20 20 20 20 20 20 65 7a 73 74 ;; ezst
17d0: 65 70 20 6e 61 6d 65 73 20 6e 65 65 64 20 61 20 ep names need a
17e0: 66 75 6c 6c 20 72 65 2d 65 76 61 6c 20 68 65 72 full re-eval her
17f0: 65 2e 0a 09 20 20 20 20 20 20 28 74 65 73 74 73 e... (tests
1800: 3a 67 65 74 2d 74 65 73 74 63 6f 6e 66 69 67 20 :get-testconfig
1810: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
1820: 61 74 68 20 74 63 6f 6e 66 69 67 72 65 67 20 23 ath tconfigreg #
1830: 74 20 66 6f 72 63 65 2d 63 72 65 61 74 65 3a 20 t force-create:
1840: 23 74 29 29 20 3b 3b 20 27 72 65 74 75 72 6e 2d #t)) ;; 'return-
1850: 70 72 6f 63 73 29 29 29 0a 09 20 20 20 20 20 28 procs))).. (
1860: 65 7a 73 74 65 70 73 6c 73 74 20 28 69 66 20 28 ezstepslst (if (
1870: 68 61 73 68 2d 74 61 62 6c 65 3f 20 74 65 73 74 hash-table? test
1880: 63 6f 6e 66 69 67 29 0a 09 09 09 20 20 20 20 20 config)....
1890: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
18a0: 64 65 66 61 75 6c 74 20 74 65 73 74 63 6f 6e 66 default testconf
18b0: 69 67 20 22 65 7a 73 74 65 70 73 22 20 27 28 29 ig "ezsteps" '()
18c0: 29 0a 09 09 09 20 20 20 20 20 23 66 29 29 29 0a ).... #f))).
18d0: 09 28 69 66 20 74 65 73 74 63 6f 6e 66 69 67 0a .(if testconfig.
18e0: 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
18f0: 2d 73 65 74 21 20 2a 74 65 73 74 63 6f 6e 66 69 -set! *testconfi
1900: 67 73 2a 20 74 65 73 74 2d 6e 61 6d 65 20 74 65 gs* test-name te
1910: 73 74 63 6f 6e 66 69 67 29 20 3b 3b 20 63 61 63 stconfig) ;; cac
1920: 68 65 64 20 66 6f 72 20 6c 61 7a 79 20 72 65 61 hed for lazy rea
1930: 64 73 20 6c 61 74 65 72 20 2e 2e 2e 0a 09 20 20 ds later .....
1940: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
1950: 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 29 0a 09 (launch:setup)..
1960: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1970: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1980: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
1990: 3a 20 6e 6f 20 74 65 73 74 63 6f 6e 66 69 67 20 : no testconfig
19a0: 66 6f 75 6e 64 20 66 6f 72 20 22 20 74 65 73 74 found for " test
19b0: 2d 6e 61 6d 65 20 22 20 69 6e 20 73 65 61 72 63 -name " in searc
19c0: 68 20 70 61 74 68 3a 5c 6e 20 20 22 0a 09 09 09 h path:\n "....
19d0: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
19e0: 73 70 65 72 73 65 20 28 74 65 73 74 73 3a 67 65 sperse (tests:ge
19f0: 74 2d 74 65 73 74 73 2d 73 65 61 72 63 68 2d 70 t-tests-search-p
1a00: 61 74 68 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 ath *configdat*)
1a10: 20 22 5c 6e 20 20 22 29 29 29 29 0a 09 3b 3b 20 "\n "))))..;;
1a20: 61 66 74 65 72 20 61 6c 6c 20 74 68 61 74 2c 20 after all that,
1a30: 73 74 69 6c 6c 20 6e 6f 20 74 65 73 74 63 6f 6e still no testcon
1a40: 66 69 67 3f 20 54 69 6d 65 20 74 6f 20 61 62 6f fig? Time to abo
1a50: 72 74 0a 09 28 69 66 20 28 6e 6f 74 20 74 65 73 rt..(if (not tes
1a60: 74 63 6f 6e 66 69 67 29 0a 09 20 20 20 20 28 62 tconfig).. (b
1a70: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 egin.. (deb
1a80: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
1a90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
1aa0: 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 72 rt* "Failed to r
1ab0: 65 73 6f 6c 76 65 20 6d 65 67 61 74 65 73 74 2e esolve megatest.
1ac0: 63 6f 6e 66 69 67 2c 20 72 75 6e 63 6f 6e 66 69 config, runconfi
1ad0: 67 73 2e 63 6f 6e 66 69 67 20 61 6e 64 20 74 65 gs.config and te
1ae0: 73 74 63 6f 6e 66 69 67 20 69 73 73 75 65 73 2e stconfig issues.
1af0: 20 47 69 76 69 6e 67 20 75 70 20 6e 6f 77 22 29 Giving up now")
1b00: 0a 09 20 20 20 20 20 20 28 65 78 69 74 20 31 29 .. (exit 1)
1b10: 29 29 0a 0a 09 3b 3b 20 63 72 65 61 74 65 20 61 ))...;; create a
1b20: 20 70 72 6f 63 20 66 6f 72 20 74 68 65 20 73 75 proc for the su
1b30: 62 72 75 6e 20 69 66 20 72 65 71 75 65 73 74 65 brun if requeste
1b40: 64 2c 20 73 61 76 65 20 74 68 61 74 20 70 72 6f d, save that pro
1b50: 63 20 69 6e 20 74 68 65 20 65 7a 73 74 65 70 73 c in the ezsteps
1b60: 20 74 61 62 6c 65 20 61 73 20 74 68 65 20 6c 61 table as the la
1b70: 73 74 20 65 6e 74 72 79 0a 09 3b 3b 20 31 2e 20 st entry..;; 1.
1b80: 67 65 74 20 73 65 63 74 69 6f 6e 20 5b 72 75 6e get section [run
1b90: 61 72 75 6e 5d 0a 09 3b 3b 20 32 2e 20 75 6e 73 arun]..;; 2. uns
1ba0: 65 74 20 4d 54 5f 2a 20 76 61 72 73 0a 09 3b 3b et MT_* vars..;;
1bb0: 20 33 2e 20 66 69 78 20 74 61 72 67 65 74 0a 09 3. fix target..
1bc0: 3b 3b 20 34 2e 20 66 69 78 20 72 75 6e 6e 61 6d ;; 4. fix runnam
1bd0: 65 0a 09 3b 3b 20 35 2e 20 66 69 78 20 74 65 73 e..;; 5. fix tes
1be0: 74 70 61 74 74 20 6f 72 20 63 61 6c 63 75 6c 61 tpatt or calcula
1bf0: 74 65 20 69 74 20 66 72 6f 6d 20 63 6f 6e 74 6f te it from conto
1c00: 75 72 0a 09 3b 3b 20 36 2e 20 6c 61 75 6e 63 68 ur..;; 6. launch
1c10: 20 74 68 65 20 72 75 6e 0a 09 3b 3b 20 37 2e 20 the run..;; 7.
1c20: 72 6f 6c 6c 20 75 70 20 74 68 65 20 72 75 6e 20 roll up the run
1c30: 72 65 73 75 6c 74 20 61 6e 64 20 6f 72 20 72 6f result and or ro
1c40: 6c 6c 20 75 70 20 74 68 65 20 6c 6f 67 70 72 6f ll up the logpro
1c50: 20 70 72 6f 63 65 73 73 65 64 20 72 65 73 75 6c processed resul
1c60: 74 0a 09 28 77 68 65 6e 20 28 63 6f 6e 66 69 67 t..(when (config
1c70: 66 3a 6c 6f 6f 6b 75 70 20 74 65 73 74 63 6f 6e f:lookup testcon
1c80: 66 69 67 20 22 73 75 62 72 75 6e 22 20 22 72 75 fig "subrun" "ru
1c90: 6e 77 61 69 74 22 29 20 3b 3b 20 77 65 20 75 73 nwait") ;; we us
1ca0: 65 20 72 75 6e 77 61 69 74 20 61 73 20 74 68 65 e runwait as the
1cb0: 20 66 6c 61 67 20 74 68 61 74 20 61 20 73 75 62 flag that a sub
1cc0: 72 75 6e 20 69 73 20 72 65 71 75 65 73 74 65 64 run is requested
1cd0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 75 . (su
1ce0: 62 72 75 6e 3a 69 6e 69 74 69 61 6c 69 7a 65 2d brun:initialize-
1cf0: 74 6f 70 72 75 6e 2d 74 65 73 74 20 74 65 73 74 toprun-test test
1d00: 63 6f 6e 66 69 67 20 74 65 73 74 2d 72 75 6e 2d config test-run-
1d10: 64 69 72 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 dir).. (let*
1d20: 28 28 6d 74 2d 63 6d 64 20 28 73 75 62 72 75 6e ((mt-cmd (subrun
1d30: 3a 6c 61 75 6e 63 68 2d 63 6d 64 20 74 65 73 74 :launch-cmd test
1d40: 2d 72 75 6e 2d 64 69 72 29 29 29 0a 20 20 20 20 -run-dir))).
1d50: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
1d60: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
1d70: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
1d80: 20 22 53 75 62 72 75 6e 20 63 6f 6d 6d 61 6e 64 "Subrun command
1d90: 20 69 73 20 5c 22 22 20 6d 74 2d 63 6d 64 20 22 is \"" mt-cmd "
1da0: 5c 22 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 \"").
1db0: 20 20 20 28 73 65 74 21 20 65 7a 73 74 65 70 73 (set! ezsteps
1dc0: 20 23 74 29 20 3b 3b 20 73 65 74 20 74 68 65 20 #t) ;; set the
1dd0: 6e 65 65 64 65 64 20 66 6c 61 67 0a 09 20 20 20 needed flag..
1de0: 20 20 20 28 73 65 74 21 20 65 7a 73 74 65 70 73 (set! ezsteps
1df0: 6c 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 lst.
1e00: 20 20 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 (append
1e10: 28 6f 72 20 65 7a 73 74 65 70 73 6c 73 74 20 27 (or ezstepslst '
1e20: 28 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ()).
1e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1e40: 28 6c 69 73 74 20 28 6c 69 73 74 20 22 73 75 62 (list (list "sub
1e50: 72 75 6e 22 20 28 63 6f 6e 63 20 22 7b 73 75 62 run" (conc "{sub
1e60: 72 75 6e 3d 74 72 75 65 7d 20 22 20 6d 74 2d 63 run=true} " mt-c
1e70: 6d 64 29 29 29 29 29 29 29 0a 0a 09 3b 3b 20 70 md)))))))...;; p
1e80: 72 6f 63 65 73 73 20 74 68 65 20 65 7a 73 74 65 rocess the ezste
1e90: 70 73 0a 09 28 69 66 20 65 7a 73 74 65 70 73 0a ps..(if ezsteps.
1ea0: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 65 6e 76 . (let* ((env
1eb0: 64 62 66 20 20 20 20 20 20 20 20 28 63 6f 6e 63 dbf (conc
1ec0: 20 22 2f 74 6d 70 2f 2e 22 28 63 75 72 72 65 6e "/tmp/."(curren
1ed0: 74 2d 75 73 65 72 2d 6e 61 6d 65 29 22 2d 22 28 t-user-name)"-"(
1ee0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
1ef0: 69 64 29 22 2d 22 72 75 6e 2d 69 64 22 2d 22 74 id)"-"run-id"-"t
1f00: 65 73 74 2d 69 64 22 2e 64 62 22 29 29 0a 09 09 est-id".db"))...
1f10: 20 20 20 28 61 6c 6c 2d 73 74 65 70 73 2d 64 61 (all-steps-da
1f20: 74 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 t (make-hash-tab
1f30: 6c 65 29 29 29 20 3b 3b 20 6b 65 65 70 20 61 6c le))) ;; keep al
1f40: 6c 20 74 68 65 20 69 6e 66 6f 20 61 72 6f 75 6e l the info aroun
1f50: 64 20 61 73 20 73 74 65 70 6e 61 6d 65 20 3d 3d d as stepname ==
1f60: 3e 20 61 6c 69 73 74 3b 0a 09 20 20 20 20 20 20 > alist;..
1f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f90: 20 20 20 20 20 20 20 20 3b 3b 3b 20 77 68 65 72 ;;; wher
1fa0: 65 20 20 27 70 61 72 61 6d 73 20 69 73 20 74 68 e 'params is th
1fb0: 65 20 70 61 72 61 6d 73 20 6c 69 73 74 20 28 61 e params list (a
1fc0: 64 64 20 6f 74 68 65 72 0a 09 20 20 20 20 20 20 dd other..
1fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1ff0: 20 20 20 20 20 20 20 20 3b 3b 3b 20 73 74 75 66 ;;; stuf
2000: 66 20 61 73 20 6e 65 65 64 65 64 29 0a 09 20 20 f as needed)..
2010: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 63 6f (if (not (co
2020: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
2030: 3f 20 22 2e 65 7a 73 74 65 70 73 22 29 29 28 63 ? ".ezsteps"))(c
2040: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
2050: 22 2e 65 7a 73 74 65 70 73 22 29 29 0a 09 20 20 ".ezsteps"))..
2060: 20 20 20 20 3b 3b 20 69 66 20 65 7a 73 74 65 70 ;; if ezstep
2070: 73 20 77 61 73 20 64 65 66 69 6e 65 64 20 74 68 s was defined th
2080: 65 6e 20 77 65 20 61 72 65 20 73 75 72 65 20 74 en we are sure t
2090: 6f 20 68 61 76 65 20 61 74 20 6c 65 61 73 74 20 o have at least
20a0: 6f 6e 65 20 73 74 65 70 20 62 75 74 20 63 68 65 one step but che
20b0: 63 6b 20 61 6e 79 77 61 79 0a 09 20 20 20 20 20 ck anyway..
20c0: 20 28 69 66 20 28 6e 6f 74 20 28 3e 20 28 6c 65 (if (not (> (le
20d0: 6e 67 74 68 20 65 7a 73 74 65 70 73 6c 73 74 29 ngth ezstepslst)
20e0: 20 30 29 29 0a 09 09 20 20 28 64 65 62 75 67 3a 0))... (debug:
20f0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
2100: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2110: 20 22 65 7a 73 74 65 70 73 20 64 65 66 69 6e 65 "ezsteps define
2120: 64 20 62 75 74 20 65 7a 73 74 65 70 73 6c 73 74 d but ezstepslst
2130: 20 69 73 20 7a 65 72 6f 20 6c 65 6e 67 74 68 22 is zero length"
2140: 29 0a 09 09 20 20 28 6c 65 74 20 28 28 61 6c 6c )... (let ((all
2150: 2d 73 74 65 70 2d 6e 61 6d 65 73 20 28 6d 61 70 -step-names (map
2160: 20 63 61 72 20 65 7a 73 74 65 70 73 6c 73 74 29 car ezstepslst)
2170: 29 29 0a 09 09 20 20 20 20 28 73 65 74 65 6e 76 ))... (setenv
2180: 20 22 4d 54 5f 53 54 45 50 5f 4e 41 4d 45 53 22 "MT_STEP_NAMES"
2190: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
21a0: 65 72 73 65 20 61 6c 6c 2d 73 74 65 70 2d 6e 61 erse all-step-na
21b0: 6d 65 73 20 22 20 22 29 29 0a 09 09 20 20 20 20 mes " "))...
21c0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 65 7a 73 74 (let loop ((ezst
21d0: 65 70 20 28 63 61 72 20 65 7a 73 74 65 70 73 6c ep (car ezstepsl
21e0: 73 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 st)).... (
21f0: 74 61 6c 20 20 20 20 28 63 64 72 20 65 7a 73 74 tal (cdr ezst
2200: 65 70 73 6c 73 74 29 29 0a 09 09 09 20 20 20 20 epslst))....
2210: 20 20 20 28 70 72 65 76 73 74 65 70 20 23 66 29 (prevstep #f)
2220: 29 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 67 )... (debug
2230: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
2240: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2250: 20 22 50 72 6f 63 65 73 73 69 6e 67 20 65 7a 73 "Processing ezs
2260: 74 65 70 20 5c 22 22 20 28 73 74 72 69 6e 67 2d tep \"" (string-
2270: 69 6e 74 65 72 73 70 65 72 73 65 20 65 7a 73 74 intersperse ezst
2280: 65 70 20 22 20 22 29 20 22 5c 22 22 29 0a 09 09 ep " ") "\"")...
2290: 20 20 20 20 20 20 3b 3b 20 63 68 65 63 6b 20 65 ;; check e
22a0: 78 69 74 2d 69 6e 66 6f 20 28 76 65 63 74 6f 72 xit-info (vector
22b0: 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 31 -ref exit-info 1
22c0: 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 6c )... (if (l
22d0: 61 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d aunch:einf-exit-
22e0: 73 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f status exit-info
22f0: 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 65 66 ) ;; (vector-ref
2300: 20 65 78 69 74 2d 69 6e 66 6f 20 31 29 0a 09 09 exit-info 1)...
2310: 09 20 20 28 6c 65 74 2a 20 28 28 6c 6f 67 70 72 . (let* ((logpr
2320: 6f 2d 75 73 65 64 20 28 6c 61 75 6e 63 68 3a 72 o-used (launch:r
2330: 75 6e 73 74 65 70 20 65 7a 73 74 65 70 20 72 75 unstep ezstep ru
2340: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 65 78 69 n-id test-id exi
2350: 74 2d 69 6e 66 6f 20 6d 0a 09 09 09 09 09 09 09 t-info m........
2360: 20 20 20 20 20 20 74 61 6c 20 74 65 73 74 63 6f tal testco
2370: 6e 66 69 67 20 61 6c 6c 2d 73 74 65 70 73 2d 64 nfig all-steps-d
2380: 61 74 20 70 72 65 76 73 74 65 70 20 65 6e 76 64 at prevstep envd
2390: 62 66 29 29 0a 09 09 09 09 20 28 73 74 65 70 6e bf))..... (stepn
23a0: 61 6d 65 20 20 20 20 28 63 61 72 20 65 7a 73 74 ame (car ezst
23b0: 65 70 29 29 0a 09 09 09 09 20 28 73 74 65 70 70 ep))..... (stepp
23c0: 61 72 6d 73 20 20 20 28 68 61 73 68 2d 74 61 62 arms (hash-tab
23d0: 6c 65 2d 72 65 66 20 61 6c 6c 2d 73 74 65 70 73 le-ref all-steps
23e0: 2d 64 61 74 20 73 74 65 70 6e 61 6d 65 29 29 29 -dat stepname)))
23f0: 0a 09 09 09 20 20 20 20 28 73 65 74 65 6e 76 20 .... (setenv
2400: 22 4d 54 5f 53 54 45 50 5f 4e 41 4d 45 22 20 73 "MT_STEP_NAME" s
2410: 74 65 70 6e 61 6d 65 29 0a 09 09 09 20 20 20 20 tepname)....
2420: 28 70 70 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (pp (hash-table-
2430: 3e 61 6c 69 73 74 20 61 6c 6c 2d 73 74 65 70 73 >alist all-steps
2440: 2d 64 61 74 29 29 0a 09 09 09 20 20 20 20 3b 3b -dat)).... ;;
2450: 20 69 66 20 6c 6f 67 70 72 6f 2d 75 73 65 64 20 if logpro-used
2460: 72 65 61 64 20 69 6e 20 74 68 65 20 73 74 65 70 read in the step
2470: 6e 61 6d 65 2e 64 61 74 20 66 69 6c 65 0a 09 09 name.dat file...
2480: 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 6c 6f . (if (and lo
2490: 67 70 72 6f 2d 75 73 65 64 20 28 63 6f 6d 6d 6f gpro-used (commo
24a0: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 n:file-exists? (
24b0: 63 6f 6e 63 20 73 74 65 70 6e 61 6d 65 20 22 2e conc stepname ".
24c0: 64 61 74 22 29 29 29 0a 09 09 09 09 28 6c 61 75 dat"))).....(lau
24d0: 6e 63 68 3a 6c 6f 61 64 2d 6c 6f 67 70 72 6f 2d nch:load-logpro-
24e0: 64 61 74 20 72 75 6e 2d 69 64 20 74 65 73 74 2d dat run-id test-
24f0: 69 64 20 73 74 65 70 6e 61 6d 65 29 29 0a 09 09 id stepname))...
2500: 09 20 20 20 20 28 69 66 20 28 73 74 65 70 72 75 . (if (stepru
2510: 6e 2d 67 6f 6f 64 3f 20 6c 6f 67 70 72 6f 2d 75 n-good? logpro-u
2520: 73 65 64 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 sed (launch:einf
2530: 2d 65 78 69 74 2d 63 6f 64 65 20 65 78 69 74 2d -exit-code exit-
2540: 69 6e 66 6f 29 20 73 74 65 70 70 61 72 6d 73 29 info) stepparms)
2550: 0a 09 09 09 09 28 69 66 20 28 6e 6f 74 20 28 6e .....(if (not (n
2560: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 09 09 20 ull? tal)).....
2570: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
2580: 6c 29 20 28 63 64 72 20 74 61 6c 29 20 73 74 65 l) (cdr tal) ste
2590: 70 6e 61 6d 65 29 29 0a 09 09 09 09 28 64 65 62 pname)).....(deb
25a0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
25b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
25c0: 41 52 4e 49 4e 47 3a 20 73 74 65 70 20 22 20 28 ARNING: step " (
25d0: 63 61 72 20 65 7a 73 74 65 70 29 20 22 20 66 61 car ezstep) " fa
25e0: 69 6c 65 64 2e 20 53 74 6f 70 70 69 6e 67 22 29 iled. Stopping")
25f0: 29 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 )).... (debug:p
2600: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2610: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
2620: 4e 47 3a 20 61 20 70 72 69 6f 72 20 73 74 65 70 NG: a prior step
2630: 20 66 61 69 6c 65 64 2c 20 73 74 6f 70 70 69 6e failed, stoppin
2640: 67 20 61 74 20 22 20 65 7a 73 74 65 70 29 29 0a g at " ezstep)).
2650: 09 09 20 20 20 20 20 20 29 29 29 29 29 29 29 29 .. ))))))))
2660: 0a 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 ..(define (launc
2670: 68 3a 6d 6f 6e 69 74 6f 72 2d 6a 6f 62 20 72 75 h:monitor-job ru
2680: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 69 74 65 n-id test-id ite
2690: 6d 2d 70 61 74 68 20 66 75 6c 6c 72 75 6e 73 63 m-path fullrunsc
26a0: 72 69 70 74 20 65 7a 73 74 65 70 73 20 74 65 73 ript ezsteps tes
26b0: 74 2d 6e 61 6d 65 20 74 63 6f 6e 66 69 67 72 65 t-name tconfigre
26c0: 67 20 65 78 69 74 2d 69 6e 66 6f 20 6d 20 77 6f g exit-info m wo
26d0: 72 6b 2d 61 72 65 61 20 72 75 6e 74 6c 69 6d 20 rk-area runtlim
26e0: 6d 69 73 63 2d 66 6c 61 67 73 29 0a 20 20 28 6c misc-flags). (l
26f0: 65 74 2a 20 28 28 75 70 64 61 74 65 2d 70 65 72 et* ((update-per
2700: 69 6f 64 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d iod (string->num
2710: 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 ber (or (configf
2720: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
2730: 61 74 2a 20 22 73 65 74 75 70 22 20 22 74 65 73 at* "setup" "tes
2740: 74 2d 73 74 61 74 73 2d 75 70 64 61 74 65 2d 70 t-stats-update-p
2750: 65 72 69 6f 64 22 29 20 22 33 30 22 29 29 29 0a eriod") "30"))).
2760: 20 20 20 20 20 20 20 20 20 28 73 74 61 72 74 2d (start-
2770: 73 65 63 6f 6e 64 73 20 28 63 75 72 72 65 6e 74 seconds (current
2780: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 63 61 -seconds)).. (ca
2790: 6c 63 2d 6d 69 6e 75 74 65 73 20 20 28 6c 61 6d lc-minutes (lam
27a0: 62 64 61 20 28 29 0a 09 09 09 20 20 28 69 6e 65 bda ().... (ine
27b0: 78 61 63 74 2d 3e 65 78 61 63 74 20 0a 09 09 09 xact->exact ....
27c0: 20 20 20 28 72 6f 75 6e 64 20 0a 09 09 09 20 20 (round ....
27d0: 20 20 28 2d 20 0a 09 09 09 20 20 20 20 20 28 63 (- .... (c
27e0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
27f0: 0a 09 09 09 20 20 20 20 20 73 74 61 72 74 2d 73 .... start-s
2800: 65 63 6f 6e 64 73 29 29 29 29 29 0a 09 20 28 6b econds))))).. (k
2810: 69 6c 6c 2d 74 72 69 65 73 20 30 29 29 0a 20 20 ill-tries 0)).
2820: 20 20 3b 3b 20 28 74 65 73 74 73 3a 73 65 74 2d ;; (tests:set-
2830: 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 23 full-meta-info #
2840: 66 20 74 65 73 74 2d 69 64 20 72 75 6e 2d 69 64 f test-id run-id
2850: 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 20 (calc-minutes)
2860: 77 6f 72 6b 2d 61 72 65 61 29 0a 20 20 20 20 3b work-area). ;
2870: 3b 20 28 74 65 73 74 73 3a 73 65 74 2d 66 75 6c ; (tests:set-ful
2880: 6c 2d 6d 65 74 61 2d 69 6e 66 6f 20 74 65 73 74 l-meta-info test
2890: 2d 69 64 20 72 75 6e 2d 69 64 20 28 63 61 6c 63 -id run-id (calc
28a0: 2d 6d 69 6e 75 74 65 73 29 20 77 6f 72 6b 2d 61 -minutes) work-a
28b0: 72 65 61 29 0a 20 20 20 20 28 74 65 73 74 73 3a rea). (tests:
28c0: 73 65 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e set-full-meta-in
28d0: 66 6f 20 23 66 20 74 65 73 74 2d 69 64 20 72 75 fo #f test-id ru
28e0: 6e 2d 69 64 20 28 63 61 6c 63 2d 6d 69 6e 75 74 n-id (calc-minut
28f0: 65 73 29 20 77 6f 72 6b 2d 61 72 65 61 20 31 30 es) work-area 10
2900: 20 75 70 64 61 74 65 2d 64 62 3a 20 23 74 29 0a update-db: #t).
2910: 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
2920: 28 6d 69 6e 75 74 65 73 20 20 20 28 63 61 6c 63 (minutes (calc
2930: 2d 6d 69 6e 75 74 65 73 29 29 0a 09 20 20 20 20 -minutes))..
2940: 20 20 20 28 63 70 75 2d 6c 6f 61 64 20 20 28 61 (cpu-load (a
2950: 6c 69 73 74 2d 72 65 66 20 27 61 64 6a 2d 63 6f list-ref 'adj-co
2960: 72 65 2d 6c 6f 61 64 20 28 63 6f 6d 6d 6f 6e 3a re-load (common:
2970: 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 get-normalized-c
2980: 70 75 2d 6c 6f 61 64 20 23 66 29 29 29 0a 09 20 pu-load #f)))..
2990: 20 20 20 20 20 20 28 64 69 73 6b 2d 66 72 65 65 (disk-free
29a0: 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 65 6e (get-df (curren
29b0: 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 0a 20 t-directory))).
29c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
29d0: 61 73 74 2d 73 79 6e 63 20 28 63 75 72 72 65 6e ast-sync (curren
29e0: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 t-seconds))).
29f0: 20 20 20 3b 3b 20 28 63 6f 6d 6d 6f 6e 3a 74 65 ;; (common:te
2a00: 6c 65 6d 65 74 72 79 2d 6c 6f 67 20 22 7a 6f 6d lemetry-log "zom
2a10: 62 69 65 22 20 28 63 6f 6e 63 20 22 6c 61 75 6e bie" (conc "laun
2a20: 63 68 3a 6d 6f 6e 69 74 6f 72 2d 6a 6f 62 20 2d ch:monitor-job -
2a30: 0a 20 20 20 20 20 20 3b 3b 20 74 6f 70 20 6f 66 . ;; top of
2a40: 20 6c 6f 6f 70 20 65 6e 63 6f 75 6e 74 65 72 65 loop encountere
2a50: 64 20 61 74 20 22 28 63 75 72 72 65 6e 74 2d 73 d at "(current-s
2a60: 65 63 6f 6e 64 73 29 22 20 77 69 74 68 0a 20 20 econds)" with.
2a70: 20 20 20 20 3b 3b 20 6c 61 73 74 2d 73 79 6e 63 ;; last-sync
2a80: 3d 22 6c 61 73 74 2d 73 79 6e 63 29 29 0a 20 20 ="last-sync)).
2a90: 20 20 20 20 28 6c 65 74 2a 20 28 28 6f 76 65 72 (let* ((over
2aa0: 2d 74 69 6d 65 20 20 20 20 20 28 3e 20 28 63 75 -time (> (cu
2ab0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 rrent-seconds) (
2ac0: 2b 20 6c 61 73 74 2d 73 79 6e 63 20 75 70 64 61 + last-sync upda
2ad0: 74 65 2d 70 65 72 69 6f 64 29 29 29 0a 20 20 20 te-period))).
2ae0: 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 2d 63 (new-c
2af0: 70 75 2d 6c 6f 61 64 20 20 28 6c 65 74 2a 20 28 pu-load (let* (
2b00: 28 6c 6f 61 64 20 20 28 61 6c 69 73 74 2d 72 65 (load (alist-re
2b10: 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 f 'adj-core-load
2b20: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 (common:get-nor
2b30: 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
2b40: 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 #f))).
2b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2b60: 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 74 61 (delta
2b70: 20 28 61 62 73 20 28 2d 20 6c 6f 61 64 20 63 70 (abs (- load cp
2b80: 75 2d 6c 6f 61 64 29 29 29 29 0a 20 20 20 20 20 u-load)))).
2b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ba0: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 (if (>
2bb0: 64 65 6c 74 61 20 30 2e 31 29 20 3b 3b 20 64 6f delta 0.1) ;; do
2bc0: 6e 27 74 20 62 6f 74 68 65 72 20 75 70 64 61 74 n't bother updat
2bd0: 69 6e 67 20 77 69 74 68 20 73 6d 61 6c 6c 20 63 ing with small c
2be0: 68 61 6e 67 65 73 0a 20 20 20 20 20 20 20 20 20 hanges.
2bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c00: 20 20 20 20 20 20 20 20 20 6c 6f 61 64 0a 20 20 load.
2c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c30: 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f))).
2c40: 20 20 20 28 6e 65 77 2d 64 69 73 6b 2d 66 72 65 (new-disk-fre
2c50: 65 20 28 6c 65 74 2a 20 28 28 64 66 20 20 20 20 e (let* ((df
2c60: 28 69 66 20 6f 76 65 72 2d 74 69 6d 65 20 3b 3b (if over-time ;;
2c70: 20 6f 6e 6c 79 20 67 65 74 20 64 66 20 65 76 65 only get df eve
2c80: 72 79 20 33 30 20 73 65 63 6f 6e 64 73 0a 20 20 ry 30 seconds.
2c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 67 65 74 (get
2cc0: 2d 64 66 20 28 63 75 72 72 65 6e 74 2d 64 69 72 -df (current-dir
2cd0: 65 63 74 6f 72 79 29 29 0a 20 20 20 20 20 20 20 ectory)).
2ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d00: 20 20 20 20 20 20 20 64 69 73 6b 2d 66 72 65 65 disk-free
2d10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d30: 20 20 20 20 20 20 28 64 65 6c 74 61 20 28 61 62 (delta (ab
2d40: 73 20 28 2d 20 64 66 20 64 69 73 6b 2d 66 72 65 s (- df disk-fre
2d50: 65 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 e)))).
2d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2d70: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 3e 20 (if (and (>
2d80: 64 66 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 df 0).
2d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3e 20 (>
2db0: 28 2f 20 64 65 6c 74 61 20 64 66 29 20 30 2e 31 (/ delta df) 0.1
2dc0: 29 29 20 3b 3b 20 28 3e 20 64 65 6c 74 61 20 32 )) ;; (> delta 2
2dd0: 30 30 29 20 3b 3b 20 69 67 6e 6f 72 65 20 63 68 00) ;; ignore ch
2de0: 61 6e 67 65 73 20 75 6e 64 65 72 20 32 30 30 20 anges under 200
2df0: 4d 65 67 0a 20 20 20 20 20 20 20 20 20 20 20 20 Meg.
2e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e10: 20 20 20 20 20 20 64 66 0a 20 20 20 20 20 20 20 df.
2e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2e30: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 29 #f)))
2e40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 . (d
2e50: 6f 2d 73 79 6e 63 20 20 20 20 20 20 20 28 6f 72 o-sync (or
2e60: 20 6e 65 77 2d 63 70 75 2d 6c 6f 61 64 20 6e 65 new-cpu-load ne
2e70: 77 2d 64 69 73 6b 2d 66 72 65 65 20 6f 76 65 72 w-disk-free over
2e80: 2d 74 69 6d 65 29 29 0a 0a 20 20 20 20 20 20 20 -time))..
2e90: 20 20 20 20 20 20 28 74 65 73 74 2d 69 6e 66 6f (test-info
2ea0: 20 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 (rmt:get-test
2eb0: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d -info-by-id run-
2ec0: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 20 20 20 id test-id)).
2ed0: 20 20 20 20 20 20 20 20 20 20 28 73 74 61 74 65 (state
2ee0: 20 20 20 20 20 20 20 28 64 62 3a 74 65 73 74 2d (db:test-
2ef0: 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 2d 69 get-state test-i
2f00: 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 nfo)).
2f10: 20 20 20 28 73 74 61 74 75 73 20 20 20 20 20 20 (status
2f20: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
2f30: 74 75 73 20 74 65 73 74 2d 69 6e 66 6f 29 29 0a tus test-info)).
2f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6b 69 (ki
2f50: 6c 6c 2d 72 65 61 73 6f 6e 20 20 22 6e 6f 20 6b ll-reason "no k
2f60: 69 6c 6c 20 72 65 61 73 6f 6e 20 73 70 65 63 69 ill reason speci
2f70: 66 69 65 64 22 29 0a 20 20 20 20 20 20 20 20 20 fied").
2f80: 20 20 20 20 28 6b 69 6c 6c 2d 6a 6f 62 3f 20 20 (kill-job?
2f90: 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 23 #f)). #
2fa0: 3b 28 63 6f 6d 6d 6f 6e 3a 74 65 6c 65 6d 65 74 ;(common:telemet
2fb0: 72 79 2d 6c 6f 67 20 22 7a 6f 6d 62 69 65 22 20 ry-log "zombie"
2fc0: 28 63 6f 6e 63 20 22 6c 61 75 6e 63 68 3a 6d 6f (conc "launch:mo
2fd0: 6e 69 74 6f 72 2d 6a 6f 62 20 2d 20 64 65 63 69 nitor-job - deci
2fe0: 73 69 6f 6e 20 74 69 6d 65 20 65 6e 63 6f 75 6e sion time encoun
2ff0: 74 65 72 65 64 20 61 74 20 22 28 63 75 72 72 65 tered at "(curre
3000: 6e 74 2d 73 65 63 6f 6e 64 73 29 22 20 77 69 74 nt-seconds)" wit
3010: 68 20 6c 61 73 74 2d 73 79 6e 63 3d 22 6c 61 73 h last-sync="las
3020: 74 2d 73 79 6e 63 22 20 64 6f 2d 73 79 6e 63 3d t-sync" do-sync=
3030: 22 64 6f 2d 73 79 6e 63 22 20 6f 76 65 72 2d 74 "do-sync" over-t
3040: 69 6d 65 3d 22 6f 76 65 72 2d 74 69 6d 65 22 20 ime="over-time"
3050: 75 70 64 61 74 65 2d 70 65 72 69 6f 64 3d 22 75 update-period="u
3060: 70 64 61 74 65 2d 70 65 72 69 6f 64 29 29 0a 20 pdate-period)).
3070: 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 (cond.
3080: 20 20 20 20 20 20 28 28 74 65 73 74 2d 67 65 74 ((test-get
3090: 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 72 75 -kill-request ru
30a0: 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 n-id test-id).
30b0: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 6b 69 (set! ki
30c0: 6c 6c 2d 72 65 61 73 6f 6e 20 22 4b 49 4c 4c 49 ll-reason "KILLI
30d0: 4e 47 20 54 45 53 54 20 73 69 6e 63 65 20 72 65 NG TEST since re
30e0: 63 65 69 76 65 64 20 6b 69 6c 6c 20 72 65 71 75 ceived kill requ
30f0: 65 73 74 20 28 4b 49 4c 4c 52 45 51 29 22 29 0a est (KILLREQ)").
3100: 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 (set!
3110: 6b 69 6c 6c 2d 6a 6f 62 3f 20 23 74 29 29 0a 20 kill-job? #t)).
3120: 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 72 75 ((and ru
3130: 6e 74 6c 69 6d 20 28 3e 20 28 2d 20 28 63 75 72 ntlim (> (- (cur
3140: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 rent-seconds) st
3150: 61 72 74 2d 73 65 63 6f 6e 64 73 29 20 72 75 6e art-seconds) run
3160: 74 6c 69 6d 29 29 0a 20 20 20 20 20 20 20 20 20 tlim)).
3170: 20 28 73 65 74 21 20 6b 69 6c 6c 2d 72 65 61 73 (set! kill-reas
3180: 6f 6e 20 28 63 6f 6e 63 20 22 4b 49 4c 4c 49 4e on (conc "KILLIN
3190: 47 20 54 45 53 54 20 44 55 45 20 54 4f 20 54 49 G TEST DUE TO TI
31a0: 4d 45 20 4c 49 4d 49 54 20 45 58 43 45 45 44 45 ME LIMIT EXCEEDE
31b0: 44 21 20 52 75 6e 74 69 6d 65 3d 22 20 28 2d 20 D! Runtime=" (-
31c0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
31d0: 29 20 73 74 61 72 74 2d 73 65 63 6f 6e 64 73 29 ) start-seconds)
31e0: 20 22 20 73 65 63 6f 6e 64 73 2c 20 6c 69 6d 69 " seconds, limi
31f0: 74 3d 22 20 72 75 6e 74 6c 69 6d 29 29 0a 20 20 t=" runtlim)).
3200: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 6b 69 (set! ki
3210: 6c 6c 2d 6a 6f 62 3f 20 23 74 29 29 0a 20 20 20 ll-job? #t)).
3220: 20 20 20 20 20 20 28 28 65 71 75 61 6c 3f 20 73 ((equal? s
3230: 74 61 74 75 73 20 22 44 45 41 44 22 29 0a 20 20 tatus "DEAD").
3240: 20 20 20 20 20 20 20 20 28 74 65 73 74 73 3a 75 (tests:u
3250: 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 pdate-central-me
3260: 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 ta-info run-id t
3270: 65 73 74 2d 69 64 20 6e 65 77 2d 63 70 75 2d 6c est-id new-cpu-l
3280: 6f 61 64 20 6e 65 77 2d 64 69 73 6b 2d 66 72 65 oad new-disk-fre
3290: 65 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 e (calc-minutes)
32a0: 20 23 66 20 23 66 20 75 70 64 61 74 65 2d 64 62 #f #f update-db
32b0: 3a 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 : #t).
32c0: 28 72 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 (rmt:set-state-s
32d0: 74 61 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 tatus-and-roll-u
32e0: 70 2d 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 p-items run-id t
32f0: 65 73 74 2d 69 64 20 27 66 6f 6f 20 22 52 55 4e est-id 'foo "RUN
3300: 4e 49 4e 47 22 20 22 6e 2f 61 22 20 22 77 61 73 NING" "n/a" "was
3310: 20 6d 61 72 6b 65 64 20 64 65 61 64 3b 20 72 65 marked dead; re
3320: 61 6c 6c 79 20 73 74 69 6c 6c 20 72 75 6e 6e 69 ally still runni
3330: 6e 67 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 ng.").
3340: 3b 3b 28 73 65 74 21 20 6b 69 6c 6c 2d 72 65 61 ;;(set! kill-rea
3350: 73 6f 6e 20 22 4b 49 4c 4c 49 4e 47 20 54 45 53 son "KILLING TES
3360: 54 20 62 65 63 61 75 73 65 20 69 74 20 77 61 73 T because it was
3370: 20 6d 61 72 6b 65 64 20 61 73 20 44 45 41 44 20 marked as DEAD
3380: 62 79 20 6c 61 75 6e 63 68 3a 68 61 6e 64 6c 65 by launch:handle
3390: 2d 7a 6f 6d 62 69 65 2d 74 65 73 74 73 20 28 6d -zombie-tests (m
33a0: 69 67 68 74 20 69 6e 64 69 63 61 74 65 20 72 65 ight indicate re
33b0: 61 6c 6c 79 20 6f 76 65 72 6c 6f 61 64 65 64 20 ally overloaded
33c0: 73 65 72 76 65 72 20 6f 72 20 65 6c 73 65 20 6f server or else o
33d0: 76 65 72 7a 65 61 6c 6f 75 73 20 73 65 74 75 70 verzealous setup
33e0: 2e 64 65 61 64 74 69 6d 65 29 22 29 20 3b 3b 20 .deadtime)") ;;
33f0: 4d 41 52 4b 20 52 55 4e 4e 49 4e 47 0a 20 20 20 MARK RUNNING.
3400: 20 20 20 20 20 20 20 28 73 65 74 21 20 6b 69 6c (set! kil
3410: 6c 2d 6a 6f 62 3f 20 23 66 29 29 29 0a 0a 20 20 l-job? #f)))..
3420: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3430: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
3440: 67 2d 70 6f 72 74 2a 20 22 63 70 75 3a 20 22 20 g-port* "cpu: "
3450: 6e 65 77 2d 63 70 75 2d 6c 6f 61 64 20 22 20 64 new-cpu-load " d
3460: 69 73 6b 3a 20 22 20 6e 65 77 2d 64 69 73 6b 2d isk: " new-disk-
3470: 66 72 65 65 20 22 20 6c 61 73 74 2d 73 79 6e 63 free " last-sync
3480: 3a 20 22 20 6c 61 73 74 2d 73 79 6e 63 20 22 20 : " last-sync "
3490: 64 6f 2d 73 79 6e 63 3a 20 22 20 64 6f 2d 73 79 do-sync: " do-sy
34a0: 6e 63 29 0a 20 20 20 20 20 20 20 20 28 6c 61 75 nc). (lau
34b0: 6e 63 68 3a 68 61 6e 64 6c 65 2d 7a 6f 6d 62 69 nch:handle-zombi
34c0: 65 2d 74 65 73 74 73 20 72 75 6e 2d 69 64 29 0a e-tests run-id).
34d0: 20 20 20 20 20 20 20 20 28 69 66 20 64 6f 2d 73 (if do-s
34e0: 79 6e 63 20 3b 3b 20 73 61 76 65 20 6d 65 74 61 ync ;; save meta
34f0: 20 64 61 74 61 20 61 62 6f 75 74 20 74 68 65 20 data about the
3500: 72 75 6e 6e 69 6e 67 20 6f 66 20 74 68 69 73 20 running of this
3510: 74 65 73 74 0a 09 20 20 20 20 28 74 65 73 74 73 test.. (tests
3520: 3a 75 70 64 61 74 65 2d 63 65 6e 74 72 61 6c 2d :update-central-
3530: 6d 65 74 61 2d 69 6e 66 6f 20 72 75 6e 2d 69 64 meta-info run-id
3540: 20 74 65 73 74 2d 69 64 20 6e 65 77 2d 63 70 75 test-id new-cpu
3550: 2d 6c 6f 61 64 20 6e 65 77 2d 64 69 73 6b 2d 66 -load new-disk-f
3560: 72 65 65 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 ree (calc-minute
3570: 73 29 20 23 66 20 23 66 29 29 0a 09 28 69 66 20 s) #f #f))..(if
3580: 6b 69 6c 6c 2d 6a 6f 62 3f 20 0a 09 20 20 20 20 kill-job? ..
3590: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
35a0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
35b0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
35c0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 72 6f t-log-port* "pro
35d0: 63 65 65 64 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 ceeding to kill
35e0: 74 65 73 74 3a 20 22 6b 69 6c 6c 2d 72 65 61 73 test: "kill-reas
35f0: 6f 6e 29 0a 09 20 20 20 20 20 20 28 6d 75 74 65 on).. (mute
3600: 78 2d 6c 6f 63 6b 21 20 6d 29 0a 09 20 20 20 20 x-lock! m)..
3610: 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 65 20 70 ;; NOTE: The p
3620: 69 64 20 63 61 6e 20 63 68 61 6e 67 65 20 61 73 id can change as
3630: 20 64 69 66 66 65 72 65 6e 74 20 73 74 65 70 73 different steps
3640: 20 61 72 65 20 72 75 6e 2e 20 44 6f 20 77 65 20 are run. Do we
3650: 6e 65 65 64 20 68 61 6e 64 73 68 61 6b 69 6e 67 need handshaking
3660: 20 62 65 74 77 65 65 6e 20 74 68 69 73 0a 09 20 between this..
3670: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 73 65 ;; se
3680: 63 74 69 6f 6e 20 61 6e 64 20 74 68 65 20 72 75 ction and the ru
3690: 6e 69 74 20 73 65 63 74 69 6f 6e 3f 20 4f 72 20 nit section? Or
36a0: 61 64 64 20 61 20 6c 6f 6f 70 20 74 68 61 74 20 add a loop that
36b0: 74 72 69 65 73 20 74 68 72 65 65 20 74 69 6d 65 tries three time
36c0: 73 20 77 69 74 68 20 61 20 31 2f 34 20 73 65 63 s with a 1/4 sec
36d0: 6f 6e 64 0a 09 20 20 20 20 20 20 3b 3b 20 20 20 ond.. ;;
36e0: 20 20 20 20 62 65 74 77 65 65 6e 20 74 72 69 65 between trie
36f0: 73 3f 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 s?.. (let*
3700: 28 28 70 69 64 31 20 28 6c 61 75 6e 63 68 3a 65 ((pid1 (launch:e
3710: 69 6e 66 2d 70 69 64 20 65 78 69 74 2d 69 6e 66 inf-pid exit-inf
3720: 6f 29 29 20 3b 3b 20 28 76 65 63 74 6f 72 2d 72 o)) ;; (vector-r
3730: 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 30 29 29 ef exit-info 0))
3740: 0a 09 09 20 20 20 20 20 28 70 69 64 32 20 28 72 ... (pid2 (r
3750: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d mt:test-get-top-
3760: 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d process-pid run-
3770: 69 64 20 74 65 73 74 2d 69 64 29 29 0a 09 09 20 id test-id))...
3780: 20 20 20 20 28 70 69 64 73 20 28 64 65 6c 65 74 (pids (delet
3790: 65 2d 64 75 70 6c 69 63 61 74 65 73 20 28 66 69 e-duplicates (fi
37a0: 6c 74 65 72 20 6e 75 6d 62 65 72 3f 20 28 6c 69 lter number? (li
37b0: 73 74 20 70 69 64 31 20 70 69 64 32 29 29 29 29 st pid1 pid2))))
37c0: 29 0a 09 09 28 69 66 20 28 6e 6f 74 20 28 6e 75 )...(if (not (nu
37d0: 6c 6c 3f 20 70 69 64 73 29 29 0a 09 09 20 20 20 ll? pids))...
37e0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 20 (begin...
37f0: 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 20 20 (for-each...
3800: 20 20 20 28 6c 61 6d 62 64 61 20 28 70 69 64 29 (lambda (pid)
3810: 0a 09 09 09 20 28 68 61 6e 64 6c 65 2d 65 78 63 .... (handle-exc
3820: 65 70 74 69 6f 6e 73 0a 09 09 09 20 20 65 78 6e eptions.... exn
3830: 0a 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 .... (begin....
3840: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3850: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
3860: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 55 6e 61 62 -log-port* "Unab
3870: 6c 65 20 74 6f 20 6b 69 6c 6c 20 70 72 6f 63 65 le to kill proce
3880: 73 73 20 77 69 74 68 20 70 69 64 20 22 20 70 69 ss with pid " pi
3890: 64 20 22 2c 20 70 6f 73 73 69 62 6c 79 20 61 6c d ", possibly al
38a0: 72 65 61 64 79 20 6b 69 6c 6c 65 64 2e 22 29 0a ready killed.").
38b0: 09 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
38c0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
38d0: 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 og-port* " messa
38e0: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
38f0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
3900: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
3910: 65 29 20 65 78 6e 29 20 22 2c 20 65 78 6e 3d 22 e) exn) ", exn="
3920: 20 65 78 6e 29 29 0a 09 09 09 20 20 28 64 65 62 exn)).... (deb
3930: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
3940: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
3950: 41 52 4e 49 4e 47 3a 20 52 65 71 75 65 73 74 20 ARNING: Request
3960: 72 65 63 65 69 76 65 64 20 74 6f 20 6b 69 6c 6c received to kill
3970: 20 6a 6f 62 20 22 20 70 69 64 29 20 3b 3b 20 20 job " pid) ;;
3980: 22 20 28 61 74 74 65 6d 70 74 20 23 20 22 20 6b " (attempt # " k
3990: 69 6c 6c 2d 74 72 69 65 73 20 22 29 22 29 0a 09 ill-tries ")")..
39a0: 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
39b0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
39c0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 69 67 6e -log-port* "Sign
39d0: 61 6c 20 6d 61 73 6b 3d 22 20 28 73 69 67 6e 61 al mask=" (signa
39e0: 6c 2d 6d 61 73 6b 29 29 0a 09 09 09 20 20 3b 3b l-mask)).... ;;
39f0: 20 28 69 66 20 28 70 72 6f 63 65 73 73 3a 61 6c (if (process:al
3a00: 69 76 65 3f 20 70 69 64 29 0a 09 09 09 20 20 3b ive? pid).... ;
3a10: 3b 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 ; (begin....
3a20: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
3a30: 70 69 64 2d 6e 75 6d 29 0a 09 09 09 09 20 28 70 pid-num)..... (p
3a40: 72 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 70 69 rocess-signal pi
3a50: 64 2d 6e 75 6d 20 73 69 67 6e 61 6c 2f 74 65 72 d-num signal/ter
3a60: 6d 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 70 m)).... (p
3a70: 72 6f 63 65 73 73 3a 67 65 74 2d 73 75 62 2d 70 rocess:get-sub-p
3a80: 69 64 73 20 70 69 64 29 29 0a 09 09 09 20 20 28 ids pid)).... (
3a90: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 thread-sleep! 5)
3aa0: 0a 09 09 09 20 20 3b 3b 20 28 69 66 20 28 70 72 .... ;; (if (pr
3ab0: 6f 63 65 73 73 3a 70 72 6f 63 65 73 73 2d 61 6c ocess:process-al
3ac0: 69 76 65 3f 20 70 69 64 29 0a 09 09 09 20 20 28 ive? pid).... (
3ad0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 69 64 map (lambda (pid
3ae0: 2d 6e 75 6d 29 0a 09 09 09 09 20 28 68 61 6e 64 -num)..... (hand
3af0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
3b00: 09 09 20 20 20 20 20 65 78 6e 0a 09 09 09 09 20 .. exn.....
3b10: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
3b20: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3b30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3b40: 72 74 2a 20 22 20 2e 2e 2e 2e 20 68 61 64 20 74 rt* " .... had t
3b50: 72 6f 75 62 6c 65 20 73 65 6e 64 69 6e 67 20 6b rouble sending k
3b60: 69 6c 6c 20 74 6f 20 22 20 70 69 64 2d 6e 75 6d ill to " pid-num
3b70: 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 ", exn=" exn)..
3b80: 09 09 09 20 20 20 20 20 23 66 29 0a 09 09 09 09 ... #f).....
3b90: 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e (process-sign
3ba0: 61 6c 20 70 69 64 2d 6e 75 6d 20 73 69 67 6e 61 al pid-num signa
3bb0: 6c 2f 6b 69 6c 6c 29 29 29 0a 09 09 09 20 20 20 l/kill)))....
3bc0: 20 20 20 20 28 70 72 6f 63 65 73 73 3a 67 65 74 (process:get
3bd0: 2d 73 75 62 2d 70 69 64 73 20 70 69 64 29 29 29 -sub-pids pid)))
3be0: 29 0a 09 09 20 20 20 20 20 20 20 3b 3b 20 20 20 )... ;;
3bf0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3c00: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
3c10: 67 2d 70 6f 72 74 2a 20 22 6e 6f 74 20 6b 69 6c g-port* "not kil
3c20: 6c 69 6e 67 20 70 72 6f 63 65 73 73 20 22 20 70 ling process " p
3c30: 69 64 20 22 20 61 73 20 69 74 20 69 73 20 6e 6f id " as it is no
3c40: 74 20 61 6c 69 76 65 22 29 29 29 29 0a 09 09 20 t alive"))))...
3c50: 20 20 20 20 20 20 70 69 64 73 29 0a 20 20 20 20 pids).
3c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3c70: 20 20 3b 3b 20 42 42 3a 20 71 75 65 73 74 69 6f ;; BB: questio
3c80: 6e 20 74 6f 20 4d 61 74 74 20 2d 2d 20 64 6f 65 n to Matt -- doe
3c90: 73 20 74 68 65 20 74 65 73 74 73 3a 74 65 73 74 s the tests:test
3ca0: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 21 20 65 -state-status! e
3cb0: 6e 63 6f 6d 70 61 73 73 20 72 6f 6c 6c 75 70 20 ncompass rollup
3cc0: 74 6f 20 74 6f 70 6c 65 76 65 6c 3f 20 20 49 66 to toplevel? If
3cd0: 20 6e 6f 74 2c 20 73 68 6f 75 6c 64 20 69 74 3f not, should it?
3ce0: 0a 09 09 20 20 20 20 20 20 28 74 65 73 74 73 3a ... (tests:
3cf0: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
3d00: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
3d10: 22 4b 49 4c 4c 45 44 22 20 20 22 4b 49 4c 4c 45 "KILLED" "KILLE
3d20: 44 22 20 28 63 6f 6e 63 20 28 61 72 67 73 3a 67 D" (conc (args:g
3d30: 65 74 2d 61 72 67 20 22 2d 6d 22 29 22 20 22 6b et-arg "-m")" "k
3d40: 69 6c 6c 2d 72 65 61 73 6f 6e 29 20 23 66 29 29 ill-reason) #f))
3d50: 20 3b 3b 20 42 42 20 41 44 44 45 44 20 6b 69 6c ;; BB ADDED kil
3d60: 6c 2d 72 65 61 73 6f 6e 20 2d 2d 20 63 6f 6e 66 l-reason -- conf
3d70: 69 72 6d 20 4f 4b 20 77 69 74 68 20 4d 61 74 74 irm OK with Matt
3d80: 0a 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 09 ... (begin...
3d90: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3da0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
3db0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e ult-log-port* "N
3dc0: 6f 74 68 69 6e 67 20 74 6f 20 6b 69 6c 6c 2c 20 othing to kill,
3dd0: 70 69 64 31 3d 22 20 70 69 64 31 20 22 2c 20 70 pid1=" pid1 ", p
3de0: 69 64 32 3d 22 20 70 69 64 32 29 0a 09 09 20 20 id2=" pid2)...
3df0: 20 20 20 20 28 74 65 73 74 73 3a 74 65 73 74 2d (tests:test-
3e00: 73 65 74 2d 73 74 61 74 75 73 21 20 72 75 6e 2d set-status! run-
3e10: 69 64 20 74 65 73 74 2d 69 64 20 22 4b 49 4c 4c id test-id "KILL
3e20: 45 44 22 20 20 22 46 41 49 4c 45 44 20 54 4f 20 ED" "FAILED TO
3e30: 4b 49 4c 4c 22 20 28 63 6f 6e 63 20 28 61 72 67 KILL" (conc (arg
3e40: 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 22 s:get-arg "-m")"
3e50: 20 22 6b 69 6c 6c 2d 72 65 61 73 6f 6e 29 20 23 "kill-reason) #
3e60: 66 29 20 3b 3b 20 42 42 20 41 44 44 45 44 20 6b f) ;; BB ADDED k
3e70: 69 6c 6c 2d 72 65 61 73 6f 6e 20 2d 2d 20 63 6f ill-reason -- co
3e80: 6e 66 69 72 6d 20 4f 4b 20 77 69 74 68 20 4d 61 nfirm OK with Ma
3e90: 74 74 0a 09 09 20 20 20 20 20 20 29 29 29 0a 09 tt... )))..
3ea0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
3eb0: 6f 63 6b 21 20 6d 29 0a 09 20 20 20 20 20 20 3b ock! m).. ;
3ec0: 3b 20 6e 6f 20 70 6f 69 6e 74 20 69 6e 20 73 74 ; no point in st
3ed0: 69 63 6b 69 6e 67 20 61 72 6f 75 6e 64 2e 20 45 icking around. E
3ee0: 78 69 74 20 6e 6f 77 2e 20 42 75 74 20 72 75 6e xit now. But run
3ef0: 20 65 6e 64 20 6f 66 20 72 75 6e 20 62 65 66 6f end of run befo
3f00: 72 65 20 65 78 69 74 69 6e 67 3f 0a 20 20 20 20 re exiting?.
3f10: 20 20 20 20 28 6c 61 75 6e 63 68 3a 65 6e 64 2d (launch:end-
3f20: 6f 66 2d 72 75 6e 2d 63 68 65 63 6b 20 72 75 6e of-run-check run
3f30: 2d 69 64 29 0a 09 20 20 20 20 20 20 28 65 78 69 -id).. (exi
3f40: 74 29 29 29 0a 09 28 69 66 20 28 68 61 73 68 2d t)))..(if (hash-
3f50: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
3f60: 74 20 6d 69 73 63 2d 66 6c 61 67 73 20 27 6b 65 t misc-flags 'ke
3f70: 65 70 2d 67 6f 69 6e 67 20 23 66 29 0a 09 20 20 ep-going #f)..
3f80: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
3f90: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 33 (thread-sleep! 3
3fa0: 29 20 3b 3b 20 28 2b 20 33 20 28 72 61 6e 64 6f ) ;; (+ 3 (rando
3fb0: 6d 20 36 29 29 29 20 3b 3b 20 61 64 64 20 73 6f m 6))) ;; add so
3fc0: 6d 65 20 6a 69 74 74 65 72 20 74 6f 20 74 68 65 me jitter to the
3fd0: 20 63 61 6c 6c 20 68 6f 6d 65 20 74 69 6d 65 20 call home time
3fe0: 74 6f 20 73 70 72 65 61 64 20 6f 75 74 20 74 68 to spread out th
3ff0: 65 20 64 62 20 61 63 63 65 73 73 65 73 0a 09 20 e db accesses..
4000: 20 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 (if (hash-t
4010: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4020: 20 6d 69 73 63 2d 66 6c 61 67 73 20 27 6b 65 65 misc-flags 'kee
4030: 70 2d 67 6f 69 6e 67 20 23 66 29 20 20 3b 3b 20 p-going #f) ;;
4040: 6b 65 65 70 20 6f 72 69 67 69 6e 61 6c 73 20 66 keep originals f
4050: 6f 72 20 63 70 75 2d 6c 6f 61 64 20 61 6e 64 20 or cpu-load and
4060: 64 69 73 6b 2d 66 72 65 65 20 75 6e 6c 65 73 73 disk-free unless
4070: 20 74 68 65 79 20 63 68 61 6e 67 65 20 6d 6f 72 they change mor
4080: 65 20 74 68 61 6e 20 74 68 65 20 61 6c 6c 6f 77 e than the allow
4090: 65 64 20 64 65 6c 74 61 0a 09 09 20 20 28 6c 6f ed delta... (lo
40a0: 6f 70 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 op (calc-minutes
40b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
40c0: 20 20 20 20 20 20 20 20 20 20 28 6f 72 20 6e 65 (or ne
40d0: 77 2d 63 70 75 2d 6c 6f 61 64 20 63 70 75 2d 6c w-cpu-load cpu-l
40e0: 6f 61 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 oad).
40f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6f 72 (or
4100: 20 6e 65 77 2d 64 69 73 6b 2d 66 72 65 65 20 64 new-disk-free d
4110: 69 73 6b 2d 66 72 65 65 29 0a 20 20 20 20 20 20 isk-free).
4120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4130: 20 20 28 69 66 20 64 6f 2d 73 79 6e 63 20 28 63 (if do-sync (c
4140: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
4150: 6c 61 73 74 2d 73 79 6e 63 29 29 29 29 29 29 29 last-sync)))))))
4160: 0a 20 20 20 20 28 74 65 73 74 73 3a 75 70 64 61 . (tests:upda
4170: 74 65 2d 63 65 6e 74 72 61 6c 2d 6d 65 74 61 2d te-central-meta-
4180: 69 6e 66 6f 20 72 75 6e 2d 69 64 20 74 65 73 74 info run-id test
4190: 2d 69 64 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 -id (get-cpu-loa
41a0: 64 29 20 28 67 65 74 2d 64 66 20 28 63 75 72 72 d) (get-df (curr
41b0: 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 28 ent-directory))(
41c0: 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 20 23 66 calc-minutes) #f
41d0: 20 23 66 20 75 70 64 61 74 65 2d 64 62 3a 20 23 #f update-db: #
41e0: 74 29 29 29 20 3b 3b 20 4e 4f 54 45 3a 20 43 68 t))) ;; NOTE: Ch
41f0: 65 63 6b 69 6e 67 20 74 77 69 63 65 20 66 6f 72 ecking twice for
4200: 20 6b 65 65 70 2d 67 6f 69 6e 67 20 69 73 20 69 keep-going is i
4210: 6e 74 65 6e 74 69 6f 6e 61 6c 0a 0a 0a 28 64 65 ntentional...(de
4220: 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 65 78 65 fine (launch:exe
4230: 63 75 74 65 20 65 6e 63 6f 64 65 64 2d 63 6d 64 cute encoded-cmd
4240: 29 0a 20 20 28 6c 65 74 2a 20 28 28 63 6d 64 69 ). (let* ((cmdi
4250: 6e 66 6f 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 72 nfo (common:r
4260: 65 61 64 2d 65 6e 63 6f 64 65 64 2d 73 74 72 69 ead-encoded-stri
4270: 6e 67 20 65 6e 63 6f 64 65 64 2d 63 6d 64 29 29 ng encoded-cmd))
4280: 0a 09 20 28 74 63 6f 6e 66 69 67 72 65 67 20 23 .. (tconfigreg #
4290: 66 29 29 0a 20 20 20 20 28 73 65 74 65 6e 76 20 f)). (setenv
42a0: 22 4d 54 5f 43 4d 44 49 4e 46 4f 22 20 65 6e 63 "MT_CMDINFO" enc
42b0: 6f 64 65 64 2d 63 6d 64 29 0a 20 20 20 20 3b 3b oded-cmd). ;;
42c0: 28 62 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 6d (bb-check-path m
42d0: 73 67 3a 20 22 6c 61 75 6e 63 68 3a 65 78 65 63 sg: "launch:exec
42e0: 75 74 65 20 69 6e 63 6f 6d 69 6e 67 22 29 0a 20 ute incoming").
42f0: 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 63 6d (if (list? cm
4300: 64 69 6e 66 6f 29 20 3b 3b 20 28 28 74 65 73 74 dinfo) ;; ((test
4310: 70 61 74 68 20 2f 74 6d 70 2f 6d 72 77 65 6c 6c path /tmp/mrwell
4320: 61 6e 2f 6a 61 7a 7a 6d 69 6e 64 2f 73 72 63 2f an/jazzmind/src/
4330: 65 78 61 6d 70 6c 65 5f 72 75 6e 2f 74 65 73 74 example_run/test
4340: 73 2f 73 71 6c 69 74 65 73 70 65 65 64 29 0a 09 s/sqlitespeed)..
4350: 3b 3b 20 28 74 65 73 74 2d 6e 61 6d 65 20 73 71 ;; (test-name sq
4360: 6c 69 74 65 73 70 65 65 64 29 20 28 72 75 6e 73 litespeed) (runs
4370: 63 72 69 70 74 20 72 75 6e 73 63 72 69 70 74 2e cript runscript.
4380: 72 62 29 20 28 64 62 2d 68 6f 73 74 20 6c 6f 63 rb) (db-host loc
4390: 61 6c 68 6f 73 74 29 20 28 72 75 6e 2d 69 64 20 alhost) (run-id
43a0: 31 29 29 0a 09 28 6c 65 74 2a 20 28 28 74 65 73 1))..(let* ((tes
43b0: 74 70 61 74 68 20 20 28 61 73 73 6f 63 2f 64 65 tpath (assoc/de
43c0: 66 61 75 6c 74 20 27 74 65 73 74 70 61 74 68 20 fault 'testpath
43d0: 20 63 6d 64 69 6e 66 6f 29 29 20 20 3b 3b 20 74 cmdinfo)) ;; t
43e0: 65 73 74 70 61 74 68 20 69 73 20 74 68 65 20 74 estpath is the t
43f0: 65 73 74 20 73 70 65 63 20 61 72 65 61 0a 09 20 est spec area..
4400: 20 20 20 20 20 20 28 74 6f 70 2d 70 61 74 68 20 (top-path
4410: 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 (assoc/default
4420: 27 74 6f 70 70 61 74 68 20 20 20 63 6d 64 69 6e 'toppath cmdin
4430: 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 77 6f fo)).. (wo
4440: 72 6b 2d 61 72 65 61 20 28 61 73 73 6f 63 2f 64 rk-area (assoc/d
4450: 65 66 61 75 6c 74 20 27 77 6f 72 6b 2d 61 72 65 efault 'work-are
4460: 61 20 63 6d 64 69 6e 66 6f 29 29 20 20 3b 3b 20 a cmdinfo)) ;;
4470: 77 6f 72 6b 2d 61 72 65 61 20 69 73 20 74 68 65 work-area is the
4480: 20 74 65 73 74 20 72 75 6e 20 61 72 65 61 0a 09 test run area..
4490: 20 20 20 20 20 20 20 28 74 65 73 74 2d 6e 61 6d (test-nam
44a0: 65 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 e (assoc/default
44b0: 20 27 74 65 73 74 2d 6e 61 6d 65 20 63 6d 64 69 'test-name cmdi
44c0: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 72 nfo)).. (r
44d0: 75 6e 73 63 72 69 70 74 20 28 61 73 73 6f 63 2f unscript (assoc/
44e0: 64 65 66 61 75 6c 74 20 27 72 75 6e 73 63 72 69 default 'runscri
44f0: 70 74 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 pt cmdinfo))..
4500: 20 20 20 20 20 28 65 7a 73 74 65 70 73 20 20 20 (ezsteps
4510: 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 (assoc/default '
4520: 65 7a 73 74 65 70 73 20 20 20 63 6d 64 69 6e 66 ezsteps cmdinf
4530: 6f 29 29 0a 09 20 20 20 20 20 20 20 28 73 75 62 o)).. (sub
4540: 72 75 6e 20 20 20 20 28 61 73 73 6f 63 2f 64 65 run (assoc/de
4550: 66 61 75 6c 74 20 27 73 75 62 72 75 6e 20 20 20 fault 'subrun
4560: 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 cmdinfo))..
4570: 20 20 20 3b 3b 20 28 72 75 6e 72 65 6d 6f 74 65 ;; (runremote
4580: 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 (assoc/default
4590: 27 72 75 6e 72 65 6d 6f 74 65 20 63 6d 64 69 6e 'runremote cmdin
45a0: 66 6f 29 29 0a 09 20 20 20 20 20 20 20 3b 3b 20 fo)).. ;;
45b0: 28 74 72 61 6e 73 70 6f 72 74 20 28 61 73 73 6f (transport (asso
45c0: 63 2f 64 65 66 61 75 6c 74 20 27 74 72 61 6e 73 c/default 'trans
45d0: 70 6f 72 74 20 63 6d 64 69 6e 66 6f 29 29 20 20 port cmdinfo))
45e0: 3b 3b 20 6e 6f 74 20 75 73 65 64 0a 09 20 20 20 ;; not used..
45f0: 20 20 20 20 3b 3b 20 28 73 65 72 76 65 72 69 6e ;; (serverin
4600: 66 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 f (assoc/default
4610: 20 27 73 65 72 76 65 72 69 6e 66 20 63 6d 64 69 'serverinf cmdi
4620: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 3b 3b nfo)).. ;;
4630: 20 28 70 6f 72 74 20 20 20 20 20 20 28 61 73 73 (port (ass
4640: 6f 63 2f 64 65 66 61 75 6c 74 20 27 70 6f 72 74 oc/default 'port
4650: 20 20 20 20 20 20 63 6d 64 69 6e 66 6f 29 29 0a cmdinfo)).
4660: 09 20 20 20 20 20 20 20 28 73 65 72 76 65 72 75 . (serveru
4670: 72 6c 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c rl (assoc/defaul
4680: 74 20 27 73 65 72 76 65 72 75 72 6c 20 63 6d 64 t 'serverurl cmd
4690: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 info)).. (
46a0: 68 6f 6d 65 68 6f 73 74 20 20 28 61 73 73 6f 63 homehost (assoc
46b0: 2f 64 65 66 61 75 6c 74 20 27 68 6f 6d 65 68 6f /default 'homeho
46c0: 73 74 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 st cmdinfo))..
46d0: 20 20 20 20 20 20 28 72 75 6e 2d 69 64 20 20 20 (run-id
46e0: 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 (assoc/default
46f0: 27 72 75 6e 2d 69 64 20 20 20 20 63 6d 64 69 6e 'run-id cmdin
4700: 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 74 65 fo)).. (te
4710: 73 74 2d 69 64 20 20 20 28 61 73 73 6f 63 2f 64 st-id (assoc/d
4720: 65 66 61 75 6c 74 20 27 74 65 73 74 2d 69 64 20 efault 'test-id
4730: 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 cmdinfo))..
4740: 20 20 20 20 28 74 61 72 67 65 74 20 20 20 20 28 (target (
4750: 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 74 assoc/default 't
4760: 61 72 67 65 74 20 20 20 20 63 6d 64 69 6e 66 6f arget cmdinfo
4770: 29 29 0a 09 20 20 20 20 20 20 20 28 61 72 65 61 )).. (area
4780: 6e 61 6d 65 20 20 28 61 73 73 6f 63 2f 64 65 66 name (assoc/def
4790: 61 75 6c 74 20 27 61 72 65 61 6e 61 6d 65 20 20 ault 'areaname
47a0: 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 cmdinfo))..
47b0: 20 20 28 69 74 65 6d 64 61 74 20 20 20 28 61 73 (itemdat (as
47c0: 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 69 74 65 soc/default 'ite
47d0: 6d 64 61 74 20 20 20 63 6d 64 69 6e 66 6f 29 29 mdat cmdinfo))
47e0: 0a 09 20 20 20 20 20 20 20 28 65 6e 76 2d 6f 76 .. (env-ov
47f0: 72 64 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 rd (assoc/defau
4800: 6c 74 20 27 65 6e 76 2d 6f 76 72 64 20 20 63 6d lt 'env-ovrd cm
4810: 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 dinfo))..
4820: 28 73 65 74 2d 76 61 72 73 20 20 28 61 73 73 6f (set-vars (asso
4830: 63 2f 64 65 66 61 75 6c 74 20 27 73 65 74 2d 76 c/default 'set-v
4840: 61 72 73 20 20 63 6d 64 69 6e 66 6f 29 29 20 3b ars cmdinfo)) ;
4850: 3b 20 70 72 65 2d 6f 76 65 72 72 69 64 65 73 20 ; pre-overrides
4860: 66 72 6f 6d 20 2d 73 65 74 76 61 72 0a 09 20 20 from -setvar..
4870: 20 20 20 20 20 28 72 75 6e 6e 61 6d 65 20 20 20 (runname
4880: 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 (assoc/default '
4890: 72 75 6e 6e 61 6d 65 20 20 20 63 6d 64 69 6e 66 runname cmdinf
48a0: 6f 29 29 0a 09 20 20 20 20 20 20 20 28 6d 65 67 o)).. (meg
48b0: 61 74 65 73 74 20 20 28 61 73 73 6f 63 2f 64 65 atest (assoc/de
48c0: 66 61 75 6c 74 20 27 6d 65 67 61 74 65 73 74 20 fault 'megatest
48d0: 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 cmdinfo))..
48e0: 20 20 20 28 72 75 6e 74 6c 69 6d 20 20 20 28 61 (runtlim (a
48f0: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 ssoc/default 'ru
4900: 6e 74 6c 69 6d 20 20 20 63 6d 64 69 6e 66 6f 29 ntlim cmdinfo)
4910: 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6e 74 6f ).. (conto
4920: 75 72 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 ur (assoc/defa
4930: 75 6c 74 20 27 63 6f 6e 74 6f 75 72 20 20 20 63 ult 'contour c
4940: 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 mdinfo))..
4950: 20 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 (item-path (ite
4960: 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 m-list->path ite
4970: 6d 64 61 74 29 29 0a 09 20 20 20 20 20 20 20 28 mdat)).. (
4980: 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 28 mt-bindir-path (
4990: 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 6d assoc/default 'm
49a0: 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 63 6d t-bindir-path cm
49b0: 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 dinfo))..
49c0: 28 6b 65 79 73 20 20 20 20 20 20 23 66 29 0a 09 (keys #f)..
49d0: 20 20 20 20 20 20 20 28 6b 65 79 76 61 6c 73 20 (keyvals
49e0: 20 20 23 66 29 0a 09 20 20 20 20 20 20 20 28 66 #f).. (f
49f0: 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 28 69 66 ullrunscript (if
4a00: 20 28 6e 6f 74 20 72 75 6e 73 63 72 69 70 74 29 (not runscript)
4a10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a30: 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 #f.
4a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a50: 20 20 20 20 20 20 20 20 28 69 66 20 28 73 75 62 (if (sub
4a60: 73 74 72 69 6e 67 2d 69 6e 64 65 78 20 22 2f 22 string-index "/"
4a70: 20 72 75 6e 73 63 72 69 70 74 29 0a 20 20 20 20 runscript).
4a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4aa0: 20 20 72 75 6e 73 63 72 69 70 74 20 3b 3b 20 75 runscript ;; u
4ab0: 73 65 20 75 6e 61 64 75 6c 74 65 72 65 64 20 69 se unadultered i
4ac0: 66 20 63 6f 6e 74 61 69 6e 73 20 73 6c 61 73 68 f contains slash
4ad0: 65 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 es.
4ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4af0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
4b00: 66 75 6c 6c 6e 20 28 63 6f 6e 63 20 77 6f 72 6b fulln (conc work
4b10: 2d 61 72 65 61 20 22 2f 22 20 72 75 6e 73 63 72 -area "/" runscr
4b20: 69 70 74 29 29 29 0a 09 20 20 20 20 20 20 20 20 ipt)))..
4b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b40: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
4b50: 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d nd (common:file-
4b60: 65 78 69 73 74 73 3f 20 66 75 6c 6c 6e 29 0a 20 exists? fulln).
4b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ba0: 20 20 28 66 69 6c 65 2d 65 78 65 63 75 74 65 2d (file-execute-
4bb0: 61 63 63 65 73 73 3f 20 66 75 6c 6c 6e 29 29 0a access? fulln)).
4bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4be0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66 75 fu
4bf0: 6c 6c 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 lln.
4c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c20: 20 20 72 75 6e 73 63 72 69 70 74 29 29 29 29 29 runscript)))))
4c30: 20 3b 3b 20 61 73 73 75 6d 65 20 69 74 20 69 73 ;; assume it is
4c40: 20 6f 6e 20 74 68 65 20 70 61 74 68 0a 20 20 20 on the path.
4c50: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 68 65 (che
4c60: 63 6b 2d 77 6f 72 6b 2d 61 72 65 61 20 20 20 20 ck-work-area
4c70: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
4c80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
4cb0: 20 4e 46 53 20 6d 69 67 68 74 20 6e 6f 74 20 68 NFS might not h
4cc0: 61 76 65 20 70 72 6f 70 61 67 61 74 65 64 20 74 ave propagated t
4cd0: 68 65 20 64 69 72 65 63 74 6f 72 79 20 6d 65 74 he directory met
4ce0: 61 20 64 61 74 61 20 74 6f 20 74 68 65 20 72 75 a data to the ru
4cf0: 6e 20 68 6f 73 74 20 2d 20 67 69 76 65 20 69 74 n host - give it
4d00: 20 74 69 6d 65 20 69 66 20 6e 65 65 64 65 64 0a time if needed.
4d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d30: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
4d40: 20 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 29 loop ((count 0)
4d50: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d80: 28 69 66 20 28 6f 72 20 28 63 6f 6d 6d 6f 6e 3a (if (or (common:
4d90: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
4da0: 3f 20 77 6f 72 6b 2d 61 72 65 61 29 0a 20 20 20 ? work-area).
4db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4de0: 20 20 20 28 3e 20 63 6f 75 6e 74 20 31 30 29 29 (> count 10))
4df0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e20: 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 (change-direc
4e30: 74 6f 72 79 20 77 6f 72 6b 2d 61 72 65 61 29 0a tory work-area).
4e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e70: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
4e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
4eb0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
4ec0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4ed0: 49 4e 46 4f 3a 20 4e 6f 74 20 73 74 61 72 74 69 INFO: Not starti
4ee0: 6e 67 20 6a 6f 62 20 79 65 74 20 2d 20 64 69 72 ng job yet - dir
4ef0: 65 63 74 6f 72 79 20 22 20 77 6f 72 6b 2d 61 72 ectory " work-ar
4f00: 65 61 20 22 20 6e 6f 74 20 66 6f 75 6e 64 22 29 ea " not found")
4f10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f40: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
4f50: 65 70 21 20 31 30 29 0a 20 20 20 20 20 20 20 20 ep! 10).
4f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4f80: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f (loo
4f90: 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 29 p (+ count 1))))
4fa0: 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )..
4fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4fd0: 69 66 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 3d if (not (string=
4fe0: 3f 20 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d ? (common:real-
4ff0: 70 61 74 68 20 77 6f 72 6b 2d 61 72 65 61 29 28 path work-area)(
5000: 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 68 common:real-path
5010: 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
5020: 6f 72 79 29 29 29 29 0a 20 20 20 20 20 20 20 20 ory)))).
5030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5050: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
5060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5070: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5090: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
50a0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
50b0: 74 2a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t*.
50c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
50d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
50e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
50f0: 20 20 22 49 4e 46 4f 3a 20 77 65 20 61 72 65 20 "INFO: we are
5100: 65 78 70 65 63 74 69 6e 67 20 74 6f 20 62 65 20 expecting to be
5110: 69 6e 20 64 69 72 65 63 74 6f 72 79 20 22 20 77 in directory " w
5120: 6f 72 6b 2d 61 72 65 61 20 22 5c 6e 22 0a 20 20 ork-area "\n".
5130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 22 20 20 "
5170: 20 20 20 62 75 74 20 77 65 20 61 72 65 20 61 63 but we are ac
5180: 74 75 61 6c 6c 79 20 69 6e 20 74 68 65 20 64 69 tually in the di
5190: 72 65 63 74 6f 72 79 20 22 20 28 63 75 72 72 65 rectory " (curre
51a0: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 20 22 5c nt-directory) "\
51b0: 6e 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 n".
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 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
51f0: 20 20 22 20 20 20 20 20 64 6f 69 6e 67 20 61 6e " doing an
5200: 6f 74 68 65 72 20 63 68 61 6e 67 65 20 64 69 72 other change dir
5210: 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 .").
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 20 20 20 20 20 20 20 20
5240: 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 (change-di
5250: 72 65 63 74 6f 72 79 20 77 6f 72 6b 2d 61 72 65 rectory work-are
5260: 61 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 a))).
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 20 20 20 20 20 20 20 20
5290: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
52a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
52c0: 20 73 70 6f 74 20 63 68 65 63 6b 20 74 68 61 74 spot check that
52d0: 20 74 68 65 20 66 69 6c 65 73 20 69 6e 20 74 65 the files in te
52e0: 73 74 70 61 74 68 20 61 72 65 20 61 76 61 69 6c stpath are avail
52f0: 61 62 6c 65 2e 20 54 6f 6f 20 6f 66 74 65 6e 20 able. Too often
5300: 4e 46 53 20 64 65 6c 61 79 73 20 63 61 75 73 65 NFS delays cause
5310: 20 70 72 6f 62 6c 65 6d 73 20 68 65 72 65 2e 0a problems here..
5320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 6c 65 74 (let
5350: 20 28 28 66 69 6c 65 73 20 20 20 20 20 20 28 67 ((files (g
5360: 6c 6f 62 20 28 63 6f 6e 63 20 74 65 73 74 70 61 lob (conc testpa
5370: 74 68 20 22 2f 2a 22 29 29 29 0a 20 20 20 20 20 th "/*"))).
5380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
53a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 61 (ba
53b0: 64 2d 66 69 6c 65 73 20 27 28 29 29 29 0a 20 20 d-files '())).
53c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
53d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
53e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 (for
53f0: 2d 65 61 63 68 0a 20 20 20 20 20 20 20 20 20 20 -each.
5400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5420: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 66 75 (lambda (fu
5430: 6c 6c 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 llname).
5440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5460: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
5470: 28 66 6e 61 6d 65 20 28 70 61 74 68 6e 61 6d 65 (fname (pathname
5480: 2d 73 74 72 69 70 2d 64 69 72 65 63 74 6f 72 79 -strip-directory
5490: 20 66 75 6c 6c 6e 61 6d 65 29 29 0a 20 20 20 20 fullname)).
54a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54d0: 20 20 20 20 28 74 61 72 67 6e 20 28 63 6f 6e 63 (targn (conc
54e0: 20 77 6f 72 6b 2d 61 72 65 61 20 22 2f 22 20 66 work-area "/" f
54f0: 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 name))).
5500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5510: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5520: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 (if (
5530: 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 not (file-exists
5540: 3f 20 74 61 72 67 6e 29 29 0a 20 20 20 20 20 20 ? targn)).
5550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5580: 20 28 73 65 74 21 20 62 61 64 2d 66 69 6c 65 73 (set! bad-files
5590: 20 28 63 6f 6e 73 20 66 6e 61 6d 65 20 62 61 64 (cons fname bad
55a0: 2d 66 69 6c 65 73 29 29 29 29 29 0a 20 20 20 20 -files))))).
55b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
55d0: 20 20 20 20 20 20 20 20 20 20 20 66 69 6c 65 73 files
55e0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
55f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5610: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
5620: 62 61 64 2d 66 69 6c 65 73 29 29 0a 20 20 20 20 bad-files)).
5630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
5660: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
5670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5690: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
56a0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
56b0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f -log-port* "INFO
56c0: 3a 20 74 65 73 74 20 64 61 74 61 20 66 72 6f 6d : test data from
56d0: 20 22 20 74 65 73 74 70 61 74 68 20 22 20 6e 6f " testpath " no
56e0: 74 20 63 6f 70 69 65 64 20 70 72 6f 70 65 72 6c t copied properl
56f0: 79 20 6f 72 20 66 69 6c 65 73 79 73 74 65 6d 20 y or filesystem
5700: 70 72 6f 62 6c 65 6d 73 20 63 61 75 73 69 6e 67 problems causing
5710: 20 64 61 74 61 20 74 6f 20 6e 6f 74 20 62 65 20 data to not be
5720: 66 6f 75 6e 64 2e 20 52 65 2d 72 75 6e 6e 69 6e found. Re-runnin
5730: 67 20 74 68 65 20 63 6f 70 79 20 63 6f 6d 6d 61 g the copy comma
5740: 6e 64 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 nd.").
5750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5770: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
5780: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
5790: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 4e 46 t-log-port* "INF
57a0: 4f 3a 20 6d 69 73 73 69 6e 67 20 66 69 6c 65 73 O: missing files
57b0: 20 66 72 6f 6d 20 22 20 77 6f 72 6b 2d 61 72 65 from " work-are
57c0: 61 20 22 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 a ": " (string-i
57d0: 6e 74 65 72 73 70 65 72 73 65 20 62 61 64 2d 66 ntersperse bad-f
57e0: 69 6c 65 73 20 22 2c 20 22 29 29 0a 20 20 20 20 iles ", ")).
57f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5820: 28 6c 61 75 6e 63 68 3a 74 65 73 74 2d 63 6f 70 (launch:test-cop
5830: 79 20 74 65 73 74 70 61 74 68 20 77 6f 72 6b 2d y testpath work-
5840: 61 72 65 61 29 29 29 29 0a 20 20 20 20 20 20 20 area)))).
5850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5870: 20 20 20 20 20 3b 3b 20 6f 6e 65 20 6d 6f 72 65 ;; one more
5880: 20 74 69 6d 65 2c 20 63 68 61 6e 67 65 20 74 6f time, change to
5890: 20 74 68 65 20 77 6f 72 6b 2d 61 72 65 61 20 64 the work-area d
58a0: 69 72 65 63 74 6f 72 79 0a 20 20 20 20 20 20 20 irectory.
58b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58d0: 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 (change-dir
58e0: 65 63 74 6f 72 79 20 77 6f 72 6b 2d 61 72 65 61 ectory work-area
58f0: 29 29 29 0a 09 20 20 20 20 20 20 20 29 20 3b 3b ))).. ) ;;
5900: 20 6c 65 74 2a 0a 0a 09 20 20 28 69 66 20 63 6f let*... (if co
5910: 6e 74 6f 75 72 20 28 73 65 74 65 6e 76 20 22 4d ntour (setenv "M
5920: 54 5f 43 4f 4e 54 4f 55 52 22 20 63 6f 6e 74 6f T_CONTOUR" conto
5930: 75 72 29 29 0a 09 20 20 3b 3b 20 69 6d 6d 65 64 ur)).. ;; immed
5940: 69 61 74 65 64 20 73 65 74 20 73 6f 6d 65 20 6b iated set some k
5950: 65 79 20 76 61 72 69 61 62 6c 65 73 20 66 72 6f ey variables fro
5960: 6d 20 43 4d 44 49 4e 46 4f 20 64 61 74 61 2c 20 m CMDINFO data,
5970: 79 65 73 2c 20 74 68 65 73 65 20 77 69 6c 6c 20 yes, these will
5980: 62 65 20 73 65 74 20 61 67 61 69 6e 20 62 65 6c be set again bel
5990: 6f 77 20 2e 2e 2e 0a 09 20 20 3b 3b 0a 09 20 20 ow ..... ;;..
59a0: 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 (setenv "MT_TEST
59b0: 53 55 49 54 45 4e 41 4d 45 22 20 61 72 65 61 6e SUITENAME" arean
59c0: 61 6d 65 29 0a 09 20 20 28 73 65 74 65 6e 76 20 ame).. (setenv
59d0: 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d "MT_RUN_AREA_HOM
59e0: 45 22 20 74 6f 70 2d 70 61 74 68 29 0a 09 20 20 E" top-path)..
59f0: 28 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 (set! *toppath*
5a00: 74 6f 70 2d 70 61 74 68 29 0a 20 20 20 20 20 20 top-path).
5a10: 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 (change-dire
5a20: 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 ctory *toppath*)
5a30: 20 3b 3b 20 74 65 6d 70 6f 72 61 72 69 6c 79 20 ;; temporarily
5a40: 73 77 69 74 63 68 20 74 6f 20 74 68 65 20 72 75 switch to the ru
5a50: 6e 20 61 72 65 61 20 68 6f 6d 65 0a 09 20 20 28 n area home.. (
5a60: 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f setenv "MT_TEST_
5a70: 52 55 4e 5f 44 49 52 22 20 20 77 6f 72 6b 2d 61 RUN_DIR" work-a
5a80: 72 65 61 29 0a 0a 09 20 20 28 6c 61 75 6e 63 68 rea)... (launch
5a90: 3a 73 65 74 75 70 29 20 3b 3b 20 73 68 6f 75 6c :setup) ;; shoul
5aa0: 64 20 62 65 20 70 72 6f 70 65 72 6c 79 20 69 6e d be properly in
5ab0: 20 74 68 65 20 72 75 6e 20 61 72 65 61 20 68 6f the run area ho
5ac0: 6d 65 20 6e 6f 77 0a 0a 09 20 20 28 69 66 20 63 me now... (if c
5ad0: 6f 6e 74 6f 75 72 20 28 73 65 74 65 6e 76 20 22 ontour (setenv "
5ae0: 4d 54 5f 43 4f 4e 54 4f 55 52 22 20 63 6f 6e 74 MT_CONTOUR" cont
5af0: 6f 75 72 29 29 0a 09 20 20 0a 09 20 20 3b 3b 20 our)).. .. ;;
5b00: 69 6d 6d 65 64 69 61 74 65 64 20 73 65 74 20 73 immediated set s
5b10: 6f 6d 65 20 6b 65 79 20 76 61 72 69 61 62 6c 65 ome key variable
5b20: 73 20 66 72 6f 6d 20 43 4d 44 49 4e 46 4f 20 64 s from CMDINFO d
5b30: 61 74 61 2c 20 79 65 73 2c 20 74 68 65 73 65 20 ata, yes, these
5b40: 77 69 6c 6c 20 62 65 20 73 65 74 20 61 67 61 69 will be set agai
5b50: 6e 20 62 65 6c 6f 77 20 2e 2e 2e 0a 09 20 20 3b n below ..... ;
5b60: 3b 0a 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 ;.. (setenv "MT
5b70: 5f 54 45 53 54 53 55 49 54 45 4e 41 4d 45 22 20 _TESTSUITENAME"
5b80: 61 72 65 61 6e 61 6d 65 29 0a 09 20 20 28 73 65 areaname).. (se
5b90: 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 tenv "MT_RUN_ARE
5ba0: 41 5f 48 4f 4d 45 22 20 74 6f 70 2d 70 61 74 68 A_HOME" top-path
5bb0: 29 0a 09 20 20 28 73 65 74 21 20 2a 74 6f 70 70 ).. (set! *topp
5bc0: 61 74 68 2a 20 74 6f 70 2d 70 61 74 68 29 0a 20 ath* top-path).
5bd0: 20 20 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 (change
5be0: 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 -directory *topp
5bf0: 61 74 68 2a 29 20 3b 3b 20 74 65 6d 70 6f 72 61 ath*) ;; tempora
5c00: 72 69 6c 79 20 73 77 69 74 63 68 20 74 6f 20 74 rily switch to t
5c10: 68 65 20 72 75 6e 20 61 72 65 61 20 68 6f 6d 65 he run area home
5c20: 0a 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 5f .. (setenv "MT_
5c30: 54 45 53 54 5f 52 55 4e 5f 44 49 52 22 20 20 77 TEST_RUN_DIR" w
5c40: 6f 72 6b 2d 61 72 65 61 29 0a 0a 09 20 20 28 6c ork-area)... (l
5c50: 61 75 6e 63 68 3a 73 65 74 75 70 29 20 3b 3b 20 aunch:setup) ;;
5c60: 73 68 6f 75 6c 64 20 62 65 20 70 72 6f 70 65 72 should be proper
5c70: 6c 79 20 69 6e 20 74 68 65 20 72 75 6e 20 61 72 ly in the run ar
5c80: 65 61 20 68 6f 6d 65 20 6e 6f 77 0a 20 20 20 20 ea home now.
5c90: 20 20 20 20 20 20 0a 09 20 20 28 73 65 74 21 20 .. (set!
5ca0: 74 63 6f 6e 66 69 67 72 65 67 20 28 74 65 73 74 tconfigreg (test
5cb0: 73 3a 67 65 74 2d 61 6c 6c 29 29 20 3b 3b 20 6d s:get-all)) ;; m
5cc0: 61 70 70 69 6e 67 20 6f 66 20 74 65 73 74 6e 61 apping of testna
5cd0: 6d 65 20 3d 3e 20 74 65 73 74 20 73 6f 75 72 63 me => test sourc
5ce0: 65 20 70 61 74 68 0a 09 20 20 28 6c 65 74 20 28 e path.. (let (
5cf0: 28 73 69 67 68 61 6e 64 20 28 6c 61 6d 62 64 61 (sighand (lambda
5d00: 20 28 73 69 67 6e 75 6d 29 0a 09 09 09 20 20 20 (signum)....
5d10: 3b 3b 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 ;; (signal-mask!
5d20: 20 73 69 67 6e 75 6d 29 20 3b 3b 20 74 6f 20 6d signum) ;; to m
5d30: 61 73 6b 20 6f 72 20 6e 6f 74 3f 20 73 65 65 6d ask or not? seem
5d40: 73 20 74 6f 20 63 61 75 73 65 20 69 73 73 75 65 s to cause issue
5d50: 73 20 69 6e 20 65 78 69 74 69 6e 67 0a 09 09 09 s in exiting....
5d60: 20 20 20 28 69 66 20 28 65 71 3f 20 73 69 67 6e (if (eq? sign
5d70: 75 6d 20 73 69 67 6e 61 6c 2f 73 74 6f 70 29 0a um signal/stop).
5d80: 09 09 09 20 20 20 20 20 20 20 28 64 65 62 75 67 ... (debug
5d90: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
5da0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5db0: 2a 20 22 61 74 74 65 6d 70 74 20 74 6f 20 53 54 * "attempt to ST
5dc0: 4f 50 20 70 72 6f 63 65 73 73 2e 20 45 78 69 74 OP process. Exit
5dd0: 69 6e 67 2e 22 29 29 0a 09 09 09 20 20 20 28 73 ing.")).... (s
5de0: 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 et! *time-to-exi
5df0: 74 2a 20 23 74 29 0a 09 09 09 20 20 20 28 70 72 t* #t).... (pr
5e00: 69 6e 74 20 22 52 65 63 65 69 76 65 64 20 73 69 int "Received si
5e10: 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 2c gnal " signum ",
5e20: 20 63 6c 65 61 6e 69 6e 67 20 75 70 20 62 65 66 cleaning up bef
5e30: 6f 72 65 20 65 78 69 74 20 28 73 65 74 20 74 68 ore exit (set th
5e40: 69 73 20 74 65 73 74 20 74 6f 20 43 4f 4d 50 4c is test to COMPL
5e50: 45 54 45 44 2f 41 42 4f 52 54 29 20 2e 20 50 6c ETED/ABORT) . Pl
5e60: 65 61 73 65 20 77 61 69 74 2e 2e 2e 22 29 0a 09 ease wait...")..
5e70: 09 09 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 .. (let ((th1
5e80: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
5e90: 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 mbda ().
5ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
5ed0: 69 6e 74 20 22 73 65 74 20 74 65 73 74 20 74 6f int "set test to
5ee0: 20 43 4f 4d 50 4c 45 54 45 44 2f 41 42 4f 52 54 COMPLETED/ABORT
5ef0: 20 62 65 67 69 6e 2e 22 29 0a 09 09 09 09 09 09 begin.").......
5f00: 20 20 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 73 (rmt:test-s
5f10: 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 et-state-status
5f20: 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 run-id test-id "
5f30: 43 4f 4d 50 4c 45 54 45 44 22 20 22 41 42 4f 52 COMPLETED" "ABOR
5f40: 54 22 20 22 72 65 63 65 69 76 65 64 20 6b 69 6c T" "received kil
5f50: 6c 20 73 69 67 6e 61 6c 22 29 0a 20 20 20 20 20 l signal").
5f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f90: 28 70 72 69 6e 74 20 22 73 65 74 20 74 65 73 74 (print "set test
5fa0: 20 74 6f 20 43 4f 4d 50 4c 45 54 45 44 2f 41 42 to COMPLETED/AB
5fb0: 4f 52 54 20 63 6f 6d 70 6c 65 74 65 2e 22 29 0a ORT complete.").
5fc0: 09 09 09 09 09 09 20 20 20 20 20 28 70 72 69 6e ...... (prin
5fd0: 74 20 22 4b 69 6c 6c 65 64 20 62 79 20 73 69 67 t "Killed by sig
5fe0: 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 2e 20 nal " signum ".
5ff0: 45 78 69 74 69 6e 67 22 29 0a 09 09 09 09 09 09 Exiting").......
6000: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 (exit 1))))
6010: 0a 09 09 09 09 20 28 74 68 32 20 28 6d 61 6b 65 ..... (th2 (make
6020: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
6030: 28 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 74 ()....... (t
6040: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 30 29 hread-sleep! 20)
6050: 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb
6060: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
6070: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 44 ult-log-port* "D
6080: 6f 6e 65 22 29 0a 09 09 09 09 09 09 20 20 20 20 one").......
6090: 20 28 65 78 69 74 20 34 29 29 29 29 29 0a 09 09 (exit 4)))))...
60a0: 09 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 . (thread-st
60b0: 61 72 74 21 20 74 68 32 29 0a 09 09 09 20 20 20 art! th2)....
60c0: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
60d0: 20 74 68 31 29 0a 09 09 09 20 20 20 20 20 28 74 th1).... (t
60e0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 hread-join! th2)
60f0: 29 29 29 29 0a 09 20 20 20 20 28 73 65 74 2d 73 )))).. (set-s
6100: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 ignal-handler! s
6110: 69 67 6e 61 6c 2f 69 6e 74 20 73 69 67 68 61 6e ignal/int sighan
6120: 64 29 0a 09 20 20 20 20 28 73 65 74 2d 73 69 67 d).. (set-sig
6130: 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 nal-handler! sig
6140: 6e 61 6c 2f 74 65 72 6d 20 73 69 67 68 61 6e 64 nal/term sighand
6150: 29 0a 09 20 20 20 20 29 20 3b 3b 20 28 73 65 74 ).. ) ;; (set
6160: 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 -signal-handler!
6170: 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 69 67 signal/stop sig
6180: 68 61 6e 64 29 0a 09 20 20 0a 09 20 20 3b 3b 20 hand).. .. ;;
6190: 44 6f 20 6e 6f 74 20 72 75 6e 20 74 68 65 20 74 Do not run the t
61a0: 65 73 74 20 69 66 20 69 74 20 69 73 20 52 45 4d est if it is REM
61b0: 4f 56 49 4e 47 2c 20 52 55 4e 4e 49 4e 47 2c 20 OVING, RUNNING,
61c0: 4b 49 4c 4c 52 45 51 20 6f 72 20 52 45 4d 4f 54 KILLREQ or REMOT
61d0: 45 48 4f 53 54 53 54 41 52 54 2c 0a 09 20 20 3b EHOSTSTART,.. ;
61e0: 3b 20 4d 61 72 6b 20 74 68 65 20 74 65 73 74 20 ; Mark the test
61f0: 61 73 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 as REMOTEHOSTSTA
6200: 52 54 20 2a 49 4d 4d 45 44 49 41 54 45 4c 59 2a RT *IMMEDIATELY*
6210: 0a 09 20 20 3b 3b 0a 09 20 20 28 6c 65 74 2a 20 .. ;;.. (let*
6220: 28 28 74 65 73 74 2d 69 6e 66 6f 20 28 6c 65 74 ((test-info (let
6230: 20 6c 6f 6f 70 20 28 28 74 72 69 65 73 20 30 29 loop ((tries 0)
6240: 29 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 20 ).... (let
6250: 28 28 74 69 6e 66 6f 20 28 72 6d 74 3a 67 65 74 ((tinfo (rmt:get
6260: 2d 74 65 73 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 -test-info-by-id
6270: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 29 run-id test-id)
6280: 29 29 0a 09 09 09 09 28 69 66 20 74 69 6e 66 6f )).....(if tinfo
6290: 0a 09 09 09 09 20 20 20 20 74 69 6e 66 6f 0a 09 ..... tinfo..
62a0: 09 09 09 20 20 20 20 28 69 66 20 28 3e 20 74 72 ... (if (> tr
62b0: 69 65 73 20 35 29 0a 09 09 09 09 09 23 66 0a 09 ies 5)......#f..
62c0: 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 09 09 ....(begin......
62d0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
62e0: 20 28 2b 20 31 20 28 2a 20 74 72 69 65 73 20 31 (+ 1 (* tries 1
62f0: 30 29 29 29 0a 09 09 09 09 09 20 20 28 6c 6f 6f 0)))...... (loo
6300: 70 20 28 2b 20 74 72 69 65 73 20 31 29 29 29 29 p (+ tries 1))))
6310: 29 29 29 29 0a 09 09 20 28 74 65 73 74 2d 68 6f ))))... (test-ho
6320: 73 74 20 28 69 66 20 74 65 73 74 2d 69 6e 66 6f st (if test-info
6330: 0a 09 09 09 09 28 64 62 3a 74 65 73 74 2d 67 65 .....(db:test-ge
6340: 74 2d 68 6f 73 74 20 20 20 20 20 20 20 20 74 65 t-host te
6350: 73 74 2d 69 6e 66 6f 29 0a 09 09 09 09 28 62 65 st-info).....(be
6360: 67 69 6e 0a 09 09 09 09 20 20 28 64 65 62 75 67 gin..... (debug
6370: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
6380: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 t-log-port* "ERR
6390: 4f 52 3a 20 66 61 69 6c 65 64 20 74 6f 20 66 69 OR: failed to fi
63a0: 6e 64 20 61 20 72 65 63 6f 72 64 20 66 6f 72 20 nd a record for
63b0: 74 65 73 74 2d 69 64 20 22 20 74 65 73 74 2d 69 test-id " test-i
63c0: 64 20 22 2c 20 65 78 69 74 69 6e 67 2e 22 29 0a d ", exiting.").
63d0: 09 09 09 09 20 20 28 65 78 69 74 29 29 29 29 0a .... (exit)))).
63e0: 09 09 20 28 74 65 73 74 2d 70 69 64 20 20 28 64 .. (test-pid (d
63f0: 62 3a 74 65 73 74 2d 67 65 74 2d 70 72 6f 63 65 b:test-get-proce
6400: 73 73 5f 69 64 20 20 74 65 73 74 2d 69 6e 66 6f ss_id test-info
6410: 29 29 29 0a 09 20 20 20 20 28 63 6f 6e 64 0a 20 ))).. (cond.
6420: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 2d ;; -
6430: 6d 72 77 2d 20 49 27 6d 20 72 65 6d 6f 76 69 6e mrw- I'm removin
6440: 67 20 4b 49 4c 4c 52 45 51 20 66 72 6f 6d 20 74 g KILLREQ from t
6450: 68 69 73 20 6c 69 73 74 20 73 6f 20 74 68 61 74 his list so that
6460: 20 61 20 74 65 73 74 20 69 6e 20 4b 49 4c 4c 52 a test in KILLR
6470: 45 51 20 73 74 61 74 65 20 69 73 20 74 72 65 61 EQ state is trea
6480: 74 65 64 20 61 73 20 61 20 22 64 6f 20 6e 6f 74 ted as a "do not
6490: 20 72 75 6e 22 20 66 6c 61 67 2e 0a 09 20 20 20 run" flag...
64a0: 20 20 3b 3b 28 28 6f 72 20 28 6d 65 6d 62 65 72 ;;((or (member
64b0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
64c0: 61 74 65 20 74 65 73 74 2d 69 6e 66 6f 29 20 27 ate test-info) '
64d0: 28 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 4b ("INCOMPLETE" "K
64e0: 49 4c 4c 45 44 22 20 22 55 4e 4b 4e 4f 57 4e 22 ILLED" "UNKNOWN"
64f0: 20 22 53 54 55 43 4b 22 29 29 20 3b 3b 20 70 72 "STUCK")) ;; pr
6500: 69 6f 72 20 72 75 6e 20 6f 66 20 74 68 69 73 20 ior run of this
6510: 74 65 73 74 20 64 69 64 6e 27 74 20 63 6f 6d 70 test didn't comp
6520: 6c 65 74 65 2c 20 67 6f 20 61 68 65 61 64 20 61 lete, go ahead a
6530: 6e 64 20 74 72 79 20 74 6f 20 72 65 72 75 6e 0a nd try to rerun.
6540: 09 20 20 20 20 20 3b 3b 09 20 20 28 61 6e 64 20 . ;;. (and
6550: 28 65 71 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 (equal? (db:test
6560: 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 2d -get-state test-
6570: 69 6e 66 6f 29 20 22 43 4f 4d 50 4c 45 54 45 44 info) "COMPLETED
6580: 22 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ")
6590: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
65a0: 63 6f 6d 70 6c 65 74 65 64 2f 61 62 6f 72 74 20 completed/abort
65b0: 3d 3e 20 72 65 72 75 6e 20 69 66 20 61 73 6b 65 => rerun if aske
65c0: 64 0a 09 20 20 20 20 20 3b 3b 09 20 20 20 20 20 d.. ;;.
65d0: 20 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 (member (db:te
65e0: 73 74 2d 67 65 74 2d 73 74 61 74 75 73 20 74 65 st-get-status te
65f0: 73 74 2d 69 6e 66 6f 29 20 27 28 22 41 42 4f 52 st-info) '("ABOR
6600: 54 22 29 29 29 29 0a 09 20 20 20 20 20 28 28 6d T")))).. ((m
6610: 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 ember (db:test-g
6620: 65 74 2d 73 74 61 74 65 20 74 65 73 74 2d 69 6e et-state test-in
6630: 66 6f 29 20 27 28 22 49 4e 43 4f 4d 50 4c 45 54 fo) '("INCOMPLET
6640: 45 22 20 22 4b 49 4c 4c 45 44 22 20 22 55 4e 4b E" "KILLED" "UNK
6650: 4e 4f 57 4e 22 20 22 53 54 55 43 4b 22 29 29 20 NOWN" "STUCK"))
6660: 3b 3b 20 70 72 69 6f 72 20 72 75 6e 20 6f 66 20 ;; prior run of
6670: 74 68 69 73 20 74 65 73 74 20 64 69 64 6e 27 74 this test didn't
6680: 20 63 6f 6d 70 6c 65 74 65 2c 20 67 6f 20 61 68 complete, go ah
6690: 65 61 64 20 61 6e 64 20 74 72 79 20 74 6f 20 72 ead and try to r
66a0: 65 72 75 6e 0a 09 20 20 20 20 20 20 28 64 65 62 erun.. (deb
66b0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
66c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
66d0: 4e 46 4f 3a 20 74 65 73 74 20 69 73 20 49 4e 43 NFO: test is INC
66e0: 4f 4d 50 4c 45 54 45 20 6f 72 20 4b 49 4c 4c 45 OMPLETE or KILLE
66f0: 44 2c 20 74 72 65 61 74 20 74 68 69 73 20 65 78 D, treat this ex
6700: 65 63 75 74 65 20 63 61 6c 6c 20 61 73 20 61 20 ecute call as a
6710: 72 65 72 75 6e 20 72 65 71 75 65 73 74 22 29 0a rerun request").
6720: 09 20 20 20 20 20 20 3b 3b 20 28 74 65 73 74 73 . ;; (tests
6730: 3a 74 65 73 74 2d 66 6f 72 63 65 2d 73 74 61 74 :test-force-stat
6740: 65 2d 73 74 61 74 75 73 21 20 72 75 6e 2d 69 64 e-status! run-id
6750: 20 74 65 73 74 2d 69 64 20 22 52 45 4d 4f 54 45 test-id "REMOTE
6760: 48 4f 53 54 53 54 41 52 54 22 20 22 6e 2f 61 22 HOSTSTART" "n/a"
6770: 29 0a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )..
6780: 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 (rmt:general-ca
6790: 6c 6c 20 27 73 65 74 2d 74 65 73 74 2d 73 74 61 ll 'set-test-sta
67a0: 72 74 2d 74 69 6d 65 20 23 66 20 74 65 73 74 2d rt-time #f test-
67b0: 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 id).
67c0: 20 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 2d (rmt:test-set-
67d0: 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 6e state-status run
67e0: 2d 69 64 20 74 65 73 74 2d 69 64 20 22 52 45 4d -id test-id "REM
67f0: 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 6e OTEHOSTSTART" "n
6800: 2f 61 22 20 23 66 29 0a 09 20 20 20 20 20 20 29 /a" #f).. )
6810: 20 3b 3b 20 70 72 69 6d 65 20 69 74 20 66 6f 72 ;; prime it for
6820: 20 72 75 6e 6e 69 6e 67 0a 09 20 20 20 20 20 28 running.. (
6830: 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 74 (member (db:test
6840: 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 2d -get-state test-
6850: 69 6e 66 6f 29 20 27 28 22 52 55 4e 4e 49 4e 47 info) '("RUNNING
6860: 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 " "REMOTEHOSTSTA
6870: 52 54 22 29 29 0a 09 20 20 20 20 20 20 28 69 66 RT")).. (if
6880: 20 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 2d (process:alive-
6890: 6f 6e 2d 68 6f 73 74 3f 20 74 65 73 74 2d 68 6f on-host? test-ho
68a0: 73 74 20 74 65 73 74 2d 70 69 64 29 0a 09 09 20 st test-pid)...
68b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
68c0: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
68d0: 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 73 og-port* "test s
68e0: 74 61 74 65 20 69 73 20 22 20 20 28 64 62 3a 74 tate is " (db:t
68f0: 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 est-get-state te
6900: 73 74 2d 69 6e 66 6f 29 20 22 20 61 6e 64 20 70 st-info) " and p
6910: 72 6f 63 65 73 73 20 22 20 74 65 73 74 2d 70 69 rocess " test-pi
6920: 64 20 22 20 69 73 20 73 74 69 6c 6c 20 72 75 6e d " is still run
6930: 6e 69 6e 67 20 6f 6e 20 68 6f 73 74 20 22 20 74 ning on host " t
6940: 65 73 74 2d 68 6f 73 74 20 22 2c 20 63 61 6e 6e est-host ", cann
6950: 6f 74 20 70 72 6f 63 65 65 64 22 29 0a 09 09 20 ot proceed")...
6960: 20 28 65 78 69 74 29 29 29 0a 09 20 20 20 20 20 (exit)))..
6970: 28 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 ((member (db:tes
6980: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t-get-state test
6990: 2d 69 6e 66 6f 29 20 27 28 22 43 4f 4d 50 4c 45 -info) '("COMPLE
69a0: 54 45 44 22 29 29 20 20 3b 3b 20 77 65 20 64 6f TED")) ;; we do
69b0: 20 4e 4f 54 20 77 61 6e 74 20 74 6f 20 72 65 2d NOT want to re-
69c0: 72 75 6e 20 43 4f 4d 50 4c 45 54 45 44 20 6a 6f run COMPLETED jo
69d0: 62 73 2e 20 4d 61 72 6b 20 61 73 20 4e 4f 54 5f bs. Mark as NOT_
69e0: 53 54 41 52 54 45 44 20 74 6f 20 72 75 6e 21 0a STARTED to run!.
69f0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
6a00: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
6a10: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6a20: 74 65 73 74 20 73 74 61 74 65 20 69 73 20 22 20 test state is "
6a30: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
6a40: 74 65 20 74 65 73 74 2d 69 6e 66 6f 29 20 22 2c te test-info) ",
6a50: 20 63 61 6e 6e 6f 74 20 70 72 6f 63 65 65 64 22 cannot proceed"
6a60: 29 0a 09 20 20 20 20 20 20 28 65 78 69 74 29 29 ).. (exit))
6a70: 0a 09 20 20 20 20 20 28 28 6e 6f 74 20 28 6d 65 .. ((not (me
6a80: 6d 62 65 72 20 28 64 62 3a 74 65 73 74 2d 67 65 mber (db:test-ge
6a90: 74 2d 73 74 61 74 65 20 74 65 73 74 2d 69 6e 66 t-state test-inf
6aa0: 6f 29 20 27 28 22 52 45 4d 4f 56 49 4e 47 22 20 o) '("REMOVING"
6ab0: 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 "REMOTEHOSTSTART
6ac0: 22 20 22 52 55 4e 4e 49 4e 47 22 20 22 4b 49 4c " "RUNNING" "KIL
6ad0: 4c 52 45 51 22 29 29 29 0a 09 20 20 20 20 20 20 LREQ")))..
6ae0: 3b 3b 20 28 74 65 73 74 73 3a 74 65 73 74 2d 66 ;; (tests:test-f
6af0: 6f 72 63 65 2d 73 74 61 74 65 2d 73 74 61 74 75 orce-state-statu
6b00: 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 s! run-id test-i
6b10: 64 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 d "REMOTEHOSTSTA
6b20: 52 54 22 20 22 6e 2f 61 22 29 0a 20 20 20 20 20 RT" "n/a").
6b30: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 67 65 (rmt:ge
6b40: 6e 65 72 61 6c 2d 63 61 6c 6c 20 27 73 65 74 2d neral-call 'set-
6b50: 74 65 73 74 2d 73 74 61 72 74 2d 74 69 6d 65 20 test-start-time
6b60: 23 66 20 74 65 73 74 2d 69 64 29 0a 09 20 20 20 #f test-id)..
6b70: 20 20 20 28 72 6d 74 3a 74 65 73 74 2d 73 65 74 (rmt:test-set
6b80: 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 72 75 -state-status ru
6b90: 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 22 52 45 n-id test-id "RE
6ba0: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 MOTEHOSTSTART" "
6bb0: 6e 2f 61 22 20 23 66 29 29 0a 09 20 20 20 20 20 n/a" #f))..
6bc0: 28 65 6c 73 65 20 3b 3b 20 28 6d 65 6d 62 65 72 (else ;; (member
6bd0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
6be0: 61 74 65 20 74 65 73 74 2d 69 6e 66 6f 29 20 27 ate test-info) '
6bf0: 28 22 52 45 4d 4f 56 49 4e 47 22 20 22 52 45 4d ("REMOVING" "REM
6c00: 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 52 OTEHOSTSTART" "R
6c10: 55 4e 4e 49 4e 47 22 20 22 4b 49 4c 4c 52 45 51 UNNING" "KILLREQ
6c20: 22 29 29 0a 09 20 20 20 20 20 20 28 64 65 62 75 ")).. (debu
6c30: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
6c40: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6c50: 74 2a 20 22 74 65 73 74 20 73 74 61 74 65 20 69 t* "test state i
6c60: 73 20 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 s " (db:test-get
6c70: 2d 73 74 61 74 65 20 74 65 73 74 2d 69 6e 66 6f -state test-info
6c80: 29 20 22 2c 20 63 61 6e 6e 6f 74 20 70 72 6f 63 ) ", cannot proc
6c90: 65 65 64 22 29 0a 09 20 20 20 20 20 20 28 65 78 eed").. (ex
6ca0: 69 74 29 29 29 29 0a 0a 20 20 20 20 20 20 20 20 it))))..
6cb0: 20 20 3b 3b 20 63 6c 65 61 6e 75 70 20 70 72 69 ;; cleanup pri
6cc0: 6f 72 20 65 78 65 63 75 74 69 6f 6e 27 73 20 73 or execution's s
6cd0: 74 65 70 73 0a 20 20 20 20 20 20 20 20 20 20 28 teps. (
6ce0: 72 6d 74 3a 64 65 6c 65 74 65 2d 73 74 65 70 73 rmt:delete-steps
6cf0: 2d 66 6f 72 2d 74 65 73 74 21 20 72 75 6e 2d 69 -for-test! run-i
6d00: 64 20 74 65 73 74 2d 69 64 29 0a 20 20 20 20 20 d test-id).
6d10: 20 20 20 20 20 0a 09 20 20 28 64 65 62 75 67 3a .. (debug:
6d20: 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 print 2 *default
6d30: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 78 65 63 -log-port* "Exec
6d40: 75 74 69 6e 67 20 22 20 74 65 73 74 2d 6e 61 6d uting " test-nam
6d50: 65 20 22 20 28 69 64 3a 20 22 20 74 65 73 74 2d e " (id: " test-
6d60: 69 64 20 22 29 20 6f 6e 20 22 20 28 67 65 74 2d id ") on " (get-
6d70: 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 28 host-name)).. (
6d80: 73 65 74 21 20 6b 65 79 73 20 20 20 20 20 20 20 set! keys
6d90: 28 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 29 0a (rmt:get-keys)).
6da0: 09 20 20 3b 3b 20 28 72 75 6e 73 3a 73 65 74 2d . ;; (runs:set-
6db0: 6d 65 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 megatest-env-var
6dc0: 73 20 72 75 6e 2d 69 64 20 69 6e 6b 65 79 73 3a s run-id inkeys:
6dd0: 20 6b 65 79 73 20 69 6e 6b 65 79 76 61 6c 73 3a keys inkeyvals:
6de0: 20 6b 65 79 76 61 6c 73 29 20 3b 3b 20 74 68 65 keyvals) ;; the
6df0: 73 65 20 6d 61 79 20 62 65 20 6e 65 65 64 65 64 se may be needed
6e00: 20 62 79 20 74 68 65 20 6c 61 75 6e 63 68 69 6e by the launchin
6e10: 67 20 70 72 6f 63 65 73 73 0a 09 20 20 3b 3b 20 g process.. ;;
6e20: 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 69 73 20 one of these is
6e30: 64 65 66 75 6e 63 74 2f 72 65 64 75 6e 64 61 6e defunct/redundan
6e40: 74 20 2e 2e 2e 0a 09 20 20 28 69 66 20 28 6e 6f t ..... (if (no
6e50: 74 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 20 t (launch:setup
6e60: 66 6f 72 63 65 2d 72 65 72 65 61 64 3a 20 23 74 force-reread: #t
6e70: 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e )).. (begin
6e80: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
6e90: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
6ea0: 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 ort* "Failed to
6eb0: 73 65 74 75 70 2c 20 65 78 69 74 69 6e 67 22 29 setup, exiting")
6ec0: 20 0a 09 09 3b 3b 20 28 73 71 6c 69 74 65 33 3a ...;; (sqlite3:
6ed0: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 09 finalize! db)...
6ee0: 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 ;; (sqlite3:fina
6ef0: 6c 69 7a 65 21 20 74 64 62 29 0a 09 09 28 65 78 lize! tdb)...(ex
6f00: 69 74 20 31 29 29 29 0a 20 20 20 20 20 20 20 20 it 1))).
6f10: 20 20 3b 3b 20 76 61 6c 69 64 61 74 65 20 74 68 ;; validate th
6f20: 61 74 20 74 68 65 20 74 65 73 74 20 72 75 6e 20 at the test run
6f30: 61 72 65 61 20 69 73 20 61 76 61 69 6c 61 62 6c area is availabl
6f40: 65 0a 20 20 20 20 20 20 20 20 20 20 28 63 68 65 e. (che
6f50: 63 6b 2d 77 6f 72 6b 2d 61 72 65 61 29 0a 20 20 ck-work-area).
6f60: 20 20 20 20 20 20 20 20 0a 20 20 20 20 20 20 20 .
6f70: 20 20 20 3b 3b 20 73 74 69 6c 6c 20 6e 65 65 64 ;; still need
6f80: 20 74 6f 20 67 6f 20 62 61 63 6b 20 74 6f 20 72 to go back to r
6f90: 75 6e 20 61 72 65 61 20 68 6f 6d 65 20 66 6f 72 un area home for
6fa0: 20 6e 65 78 74 20 63 6f 75 70 6c 65 20 73 74 65 next couple ste
6fb0: 70 73 0a 09 20 20 28 63 68 61 6e 67 65 2d 64 69 ps.. (change-di
6fc0: 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 rectory *toppath
6fd0: 2a 29 20 0a 0a 09 20 20 3b 3b 20 4e 4f 54 45 3a *) ... ;; NOTE:
6fe0: 20 43 75 72 72 65 6e 74 20 6f 72 64 65 72 20 69 Current order i
6ff0: 73 20 74 6f 20 70 72 6f 63 65 73 73 20 72 75 6e s to process run
7000: 63 6f 6e 66 69 67 73 20 2a 62 65 66 6f 72 65 2a configs *before*
7010: 20 73 65 74 74 69 6e 67 20 74 68 65 20 4d 54 5f setting the MT_
7020: 20 76 61 72 73 2e 20 54 68 69 73 20 0a 09 20 20 vars. This ..
7030: 3b 3b 20 20 20 20 20 20 20 73 65 65 6d 73 20 6e ;; seems n
7040: 6f 6e 2d 69 64 65 61 6c 20 62 75 74 20 63 6f 75 on-ideal but cou
7050: 6c 64 20 77 65 6c 6c 20 62 72 65 61 6b 20 73 74 ld well break st
7060: 75 66 66 0a 09 20 20 3b 3b 20 20 20 20 42 55 47 uff.. ;; BUG
7070: 3f 20 42 55 47 3f 20 42 55 47 3f 0a 09 20 20 0a ? BUG? BUG?.. .
7080: 09 20 20 28 6c 65 74 20 28 28 72 63 6f 6e 66 69 . (let ((rconfi
7090: 67 20 28 66 75 6c 6c 2d 72 75 6e 63 6f 6e 66 69 g (full-runconfi
70a0: 67 73 2d 72 65 61 64 29 29 20 3b 3b 20 28 72 65 gs-read)) ;; (re
70b0: 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 ad-config (conc
70c0: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
70d0: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
70e0: 20 23 66 20 23 74 20 73 65 63 74 69 6f 6e 73 3a #f #t sections:
70f0: 20 28 6c 69 73 74 20 22 64 65 66 61 75 6c 74 22 (list "default"
7100: 20 74 61 72 67 65 74 29 29 29 29 0a 09 09 28 77 target))))...(w
7110: 63 6f 6e 66 69 67 20 28 72 65 61 64 2d 63 6f 6e config (read-con
7120: 66 69 67 20 22 77 61 69 76 65 72 73 2e 63 6f 6e fig "waivers.con
7130: 66 69 67 22 20 23 66 20 23 74 20 73 65 63 74 69 fig" #f #t secti
7140: 6f 6e 73 3a 20 60 28 20 22 64 65 66 61 75 6c 74 ons: `( "default
7150: 22 20 2c 74 61 72 67 65 74 20 29 29 29 29 20 3b " ,target )))) ;
7160: 3b 20 72 65 61 64 20 74 68 65 20 77 61 69 76 65 ; read the waive
7170: 72 73 20 63 6f 6e 66 69 67 20 69 66 20 69 74 20 rs config if it
7180: 65 78 69 73 74 73 0a 09 20 20 20 20 3b 3b 20 28 exists.. ;; (
7190: 73 65 74 75 70 2d 65 6e 76 2d 64 65 66 61 75 6c setup-env-defaul
71a0: 74 73 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 ts (conc *toppat
71b0: 68 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e h* "/runconfigs.
71c0: 63 6f 6e 66 69 67 22 29 20 72 75 6e 2d 69 64 20 config") run-id
71d0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
71e0: 29 20 6b 65 79 76 61 6c 73 20 74 61 72 67 65 74 ) keyvals target
71f0: 29 0a 09 20 20 20 20 3b 3b 20 28 73 65 74 2d 72 ).. ;; (set-r
7200: 75 6e 2d 63 6f 6e 66 69 67 2d 76 61 72 73 20 72 un-config-vars r
7210: 75 6e 2d 69 64 20 6b 65 79 76 61 6c 73 20 74 61 un-id keyvals ta
7220: 72 67 65 74 29 20 3b 3b 20 28 64 62 3a 67 65 74 rget) ;; (db:get
7230: 2d 74 61 72 67 65 74 20 64 62 20 72 75 6e 2d 69 -target db run-i
7240: 64 29 29 0a 09 20 20 20 20 3b 3b 20 4e 6f 77 20 d)).. ;; Now
7250: 68 61 76 65 20 72 75 6e 63 6f 6e 66 69 67 73 20 have runconfigs
7260: 64 61 74 61 20 6c 6f 61 64 65 64 2c 20 73 65 74 data loaded, set
7270: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 environment var
7280: 73 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s.. (for-each
7290: 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
72a0: 73 65 63 74 69 6f 6e 29 0a 09 20 20 20 20 20 20 section)..
72b0: 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 28 6c 61 (for-each...(la
72c0: 6d 62 64 61 20 28 76 61 72 76 61 6c 29 0a 09 09 mbda (varval)...
72d0: 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 61 (let ((var (ca
72e0: 72 20 76 61 72 76 61 6c 29 29 0a 09 09 09 28 76 r varval))....(v
72f0: 61 6c 20 28 63 61 64 72 20 76 61 72 76 61 6c 29 al (cadr varval)
7300: 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 61 6e ))... (if (an
7310: 64 20 28 73 74 72 69 6e 67 3f 20 76 61 72 29 28 d (string? var)(
7320: 73 74 72 69 6e 67 3f 20 76 61 6c 29 29 0a 09 09 string? val))...
7330: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 73 61 .(begin.... (sa
7340: 66 65 2d 73 65 74 65 6e 76 20 76 61 72 20 28 63 fe-setenv var (c
7350: 6f 6e 66 69 67 3a 65 76 61 6c 2d 73 74 72 69 6e onfig:eval-strin
7360: 67 2d 69 6e 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 g-in-environment
7370: 20 76 61 6c 29 29 29 20 3b 3b 20 76 61 6c 29 0a val))) ;; val).
7380: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
7390: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
73a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 -log-port* "bad
73b0: 76 61 72 69 61 62 6c 65 20 73 70 65 63 2c 20 22 variable spec, "
73c0: 20 76 61 72 20 22 3d 22 20 76 61 6c 29 29 29 29 var "=" val))))
73d0: 0a 09 09 28 63 6f 6e 66 69 67 66 3a 67 65 74 2d ...(configf:get-
73e0: 73 65 63 74 69 6f 6e 20 72 63 6f 6e 66 69 67 20 section rconfig
73f0: 73 65 63 74 69 6f 6e 29 29 29 0a 09 20 20 20 20 section)))..
7400: 20 28 6c 69 73 74 20 22 64 65 66 61 75 6c 74 22 (list "default"
7410: 20 74 61 72 67 65 74 29 29 29 0a 20 20 20 20 20 target))).
7420: 20 20 20 20 20 3b 3b 28 62 62 2d 63 68 65 63 6b ;;(bb-check
7430: 2d 70 61 74 68 20 6d 73 67 3a 20 22 6c 61 75 6e -path msg: "laun
7440: 63 68 3a 65 78 65 63 75 74 65 20 70 6f 73 74 20 ch:execute post
7450: 62 6c 6f 63 6b 20 31 22 29 0a 0a 09 20 20 3b 3b block 1")... ;;
7460: 20 4e 46 53 20 6d 69 67 68 74 20 6e 6f 74 20 68 NFS might not h
7470: 61 76 65 20 70 72 6f 70 61 67 61 74 65 64 20 74 ave propagated t
7480: 68 65 20 64 69 72 65 63 74 6f 72 79 20 6d 65 74 he directory met
7490: 61 20 64 61 74 61 20 74 6f 20 74 68 65 20 72 75 a data to the ru
74a0: 6e 20 68 6f 73 74 20 2d 20 67 69 76 65 20 69 74 n host - give it
74b0: 20 74 69 6d 65 20 69 66 20 6e 65 65 64 65 64 0a time if needed.
74c0: 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 . (let loop ((c
74d0: 6f 75 6e 74 20 30 29 29 0a 09 20 20 20 20 28 69 ount 0)).. (i
74e0: 66 20 28 6f 72 20 28 63 6f 6d 6d 6f 6e 3a 66 69 f (or (common:fi
74f0: 6c 65 2d 65 78 69 73 74 73 3f 20 77 6f 72 6b 2d le-exists? work-
7500: 61 72 65 61 29 0a 09 09 20 20 20 20 28 3e 20 63 area)... (> c
7510: 6f 75 6e 74 20 31 30 29 29 0a 09 09 28 63 68 61 ount 10))...(cha
7520: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 77 6f nge-directory wo
7530: 72 6b 2d 61 72 65 61 29 0a 09 09 28 62 65 67 69 rk-area)...(begi
7540: 6e 0a 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 n... (debug:pri
7550: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
7560: 67 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 4e g-port* "INFO: N
7570: 6f 74 20 73 74 61 72 74 69 6e 67 20 6a 6f 62 20 ot starting job
7580: 79 65 74 20 2d 20 64 69 72 65 63 74 6f 72 79 20 yet - directory
7590: 22 20 77 6f 72 6b 2d 61 72 65 61 20 22 20 6e 6f " work-area " no
75a0: 74 20 66 6f 75 6e 64 22 29 0a 09 09 20 20 28 74 t found")... (t
75b0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 30 29 hread-sleep! 10)
75c0: 0a 09 09 20 20 28 6c 6f 6f 70 20 28 2b 20 63 6f ... (loop (+ co
75d0: 75 6e 74 20 31 29 29 29 29 29 0a 0a 20 20 20 20 unt 1)))))..
75e0: 20 20 20 20 20 20 3b 3b 20 6e 6f 77 20 77 65 20 ;; now we
75f0: 63 61 6e 20 73 77 69 74 63 68 20 74 6f 20 74 68 can switch to th
7600: 65 20 77 6f 72 6b 2d 61 72 65 61 3f 0a 20 20 20 e work-area?.
7610: 20 20 20 20 20 20 20 28 63 68 61 6e 67 65 2d 64 (change-d
7620: 69 72 65 63 74 6f 72 79 20 77 6f 72 6b 2d 61 72 irectory work-ar
7630: 65 61 29 0a 20 20 20 20 20 20 20 20 20 20 3b 3b ea). ;;
7640: 28 62 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 6d (bb-check-path m
7650: 73 67 3a 20 22 6c 61 75 6e 63 68 3a 65 78 65 63 sg: "launch:exec
7660: 75 74 65 20 70 6f 73 74 20 62 6c 6f 63 6b 20 31 ute post block 1
7670: 2e 35 22 29 0a 09 20 20 3b 3b 20 28 63 68 61 6e .5").. ;; (chan
7680: 67 65 2d 64 69 72 65 63 74 6f 72 79 20 77 6f 72 ge-directory wor
7690: 6b 2d 61 72 65 61 29 20 0a 09 20 20 28 73 65 74 k-area) .. (set
76a0: 21 20 6b 65 79 76 61 6c 73 20 20 20 20 28 6b 65 ! keyvals (ke
76b0: 79 73 3a 74 61 72 67 65 74 2d 3e 6b 65 79 76 61 ys:target->keyva
76c0: 6c 20 6b 65 79 73 20 74 61 72 67 65 74 29 29 0a l keys target)).
76d0: 09 20 20 3b 3b 20 61 70 70 6c 79 20 70 72 65 2d . ;; apply pre-
76e0: 6f 76 65 72 72 69 64 65 73 20 62 65 66 6f 72 65 overrides before
76f0: 20 6f 74 68 65 72 20 76 61 72 69 61 62 6c 65 73 other variables
7700: 2e 20 54 68 65 20 70 72 65 2d 6f 76 65 72 72 69 . The pre-overri
7710: 64 65 20 76 61 72 73 20 6d 75 73 74 20 6e 6f 74 de vars must not
7720: 0a 09 20 20 3b 3b 20 63 6c 6f 62 62 65 72 73 20 .. ;; clobbers
7730: 74 68 69 6e 67 73 20 66 72 6f 6d 20 74 68 65 20 things from the
7740: 6f 66 66 69 63 69 61 6c 20 73 6f 75 72 63 65 73 official sources
7750: 20 73 75 63 68 20 61 73 20 6d 65 67 61 74 65 73 such as megates
7760: 74 2e 63 6f 6e 66 69 67 20 61 6e 64 20 72 75 6e t.config and run
7770: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 0a 09 configs.config..
7780: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 73 (if (string? s
7790: 65 74 2d 76 61 72 73 29 0a 09 20 20 20 20 20 20 et-vars)..
77a0: 28 6c 65 74 20 28 28 76 61 72 70 61 69 72 73 20 (let ((varpairs
77b0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 73 65 (string-split se
77c0: 74 2d 76 61 72 73 20 22 2c 22 29 29 29 0a 09 09 t-vars ",")))...
77d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a (debug:print 4 *
77e0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
77f0: 2a 20 22 76 61 72 70 61 69 72 73 3a 20 22 20 76 * "varpairs: " v
7800: 61 72 70 61 69 72 73 29 0a 09 09 28 6d 61 70 20 arpairs)...(map
7810: 28 6c 61 6d 62 64 61 20 28 76 61 72 70 61 69 72 (lambda (varpair
7820: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 20 )... (let
7830: 28 28 76 61 72 76 61 6c 20 28 73 74 72 69 6e 67 ((varval (string
7840: 2d 73 70 6c 69 74 20 76 61 72 70 61 69 72 20 22 -split varpair "
7850: 3d 22 29 29 29 0a 09 09 09 20 28 69 66 20 28 65 ="))).... (if (e
7860: 71 3f 20 28 6c 65 6e 67 74 68 20 76 61 72 76 61 q? (length varva
7870: 6c 29 20 32 29 0a 09 09 09 20 20 20 20 20 28 6c l) 2).... (l
7880: 65 74 20 28 28 76 61 72 20 28 63 61 72 20 76 61 et ((var (car va
7890: 72 76 61 6c 29 29 0a 09 09 09 09 20 20 20 28 76 rval))..... (v
78a0: 61 6c 20 28 63 61 64 72 20 76 61 72 76 61 6c 29 al (cadr varval)
78b0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 64 65 )).... (de
78c0: 62 75 67 3a 70 72 69 6e 74 20 31 20 2a 64 65 66 bug:print 1 *def
78d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
78e0: 41 64 64 69 6e 67 20 70 72 65 2d 76 61 72 2f 76 Adding pre-var/v
78f0: 61 6c 20 22 20 76 61 72 20 22 20 3d 20 22 20 76 al " var " = " v
7900: 61 6c 20 22 20 74 6f 20 74 68 65 20 65 6e 76 69 al " to the envi
7910: 72 6f 6e 6d 65 6e 74 22 29 0a 09 09 09 20 20 20 ronment")....
7920: 20 20 20 20 28 73 65 74 65 6e 76 20 76 61 72 20 (setenv var
7930: 76 61 6c 29 29 29 29 29 0a 09 09 20 20 20 20 20 val)))))...
7940: 76 61 72 70 61 69 72 73 29 29 29 0a 20 20 20 20 varpairs))).
7950: 20 20 20 20 20 20 3b 3b 28 62 62 2d 63 68 65 63 ;;(bb-chec
7960: 6b 2d 70 61 74 68 20 6d 73 67 3a 20 22 6c 61 75 k-path msg: "lau
7970: 6e 63 68 3a 65 78 65 63 75 74 65 20 70 6f 73 74 nch:execute post
7980: 20 62 6c 6f 63 6b 20 32 22 29 0a 09 20 20 28 66 block 2").. (f
7990: 6f 72 2d 65 61 63 68 0a 09 20 20 20 28 6c 61 6d or-each.. (lam
79a0: 62 64 61 20 28 76 61 72 76 61 6c 29 0a 09 20 20 bda (varval)..
79b0: 20 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 (let ((var (c
79c0: 61 72 20 76 61 72 76 61 6c 29 29 0a 09 09 20 20 ar varval))...
79d0: 20 28 76 61 6c 20 28 63 61 64 72 20 76 61 72 76 (val (cadr varv
79e0: 61 6c 29 29 29 0a 09 20 20 20 20 20 20 20 28 69 al))).. (i
79f0: 66 20 76 61 6c 0a 09 09 20 20 20 28 73 65 74 65 f val... (sete
7a00: 6e 76 20 76 61 72 20 76 61 6c 29 0a 09 09 20 20 nv var val)...
7a10: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 20 28 (begin... (
7a20: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
7a30: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
7a40: 2d 70 6f 72 74 2a 20 22 72 65 71 75 69 72 65 64 -port* "required
7a50: 20 76 61 72 69 61 62 6c 65 20 22 20 76 61 72 20 variable " var
7a60: 22 20 64 6f 65 73 20 6e 6f 74 20 68 61 76 65 20 " does not have
7a70: 61 20 76 61 6c 69 64 20 76 61 6c 75 65 2e 20 45 a valid value. E
7a80: 78 69 74 69 6e 67 22 29 0a 09 09 20 20 20 20 20 xiting")...
7a90: 28 65 78 69 74 29 29 29 29 29 0a 09 20 20 20 20 (exit)))))..
7aa0: 20 28 6c 69 73 74 20 0a 09 20 20 20 20 20 20 28 (list .. (
7ab0: 6c 69 73 74 20 20 22 4d 54 5f 54 45 53 54 5f 52 list "MT_TEST_R
7ac0: 55 4e 5f 44 49 52 22 20 77 6f 72 6b 2d 61 72 65 UN_DIR" work-are
7ad0: 61 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 a).. (list
7ae0: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
7af0: 74 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 20 20 test-name)..
7b00: 20 20 28 6c 69 73 74 20 20 22 4d 54 5f 49 54 45 (list "MT_ITE
7b10: 4d 5f 49 4e 46 4f 22 20 28 63 6f 6e 63 20 69 74 M_INFO" (conc it
7b20: 65 6d 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 emdat)).. (
7b30: 6c 69 73 74 20 20 22 4d 54 5f 49 54 45 4d 50 41 list "MT_ITEMPA
7b40: 54 48 22 20 20 69 74 65 6d 2d 70 61 74 68 29 0a TH" item-path).
7b50: 09 20 20 20 20 20 20 28 6c 69 73 74 20 20 22 4d . (list "M
7b60: 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e T_RUNNAME" run
7b70: 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 28 6c 69 name).. (li
7b80: 73 74 20 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 st "MT_MEGATEST
7b90: 22 20 20 6d 65 67 61 74 65 73 74 29 0a 09 20 20 " megatest)..
7ba0: 20 20 20 20 28 6c 69 73 74 20 20 22 4d 54 5f 54 (list "MT_T
7bb0: 41 52 47 45 54 22 20 20 20 20 74 61 72 67 65 74 ARGET" target
7bc0: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 20 ).. (list
7bd0: 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 20 20 28 "MT_LINKTREE" (
7be0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 common:get-linkt
7bf0: 72 65 65 29 29 20 3b 3b 20 28 63 6f 6e 66 69 67 ree)) ;; (config
7c00: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
7c10: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 69 dat* "setup" "li
7c20: 6e 6b 74 72 65 65 22 29 29 0a 09 20 20 20 20 20 nktree"))..
7c30: 20 28 6c 69 73 74 20 20 22 4d 54 5f 54 45 53 54 (list "MT_TEST
7c40: 53 55 49 54 45 4e 41 4d 45 22 20 28 63 6f 6d 6d SUITENAME" (comm
7c50: 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 on:get-testsuite
7c60: 2d 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 20 20 -name)))).
7c70: 20 20 20 20 3b 3b 28 62 62 2d 63 68 65 63 6b 2d ;;(bb-check-
7c80: 70 61 74 68 20 6d 73 67 3a 20 22 6c 61 75 6e 63 path msg: "launc
7c90: 68 3a 65 78 65 63 75 74 65 20 70 6f 73 74 20 62 h:execute post b
7ca0: 6c 6f 63 6b 20 33 22 29 0a 0a 09 20 20 28 69 66 lock 3")... (if
7cb0: 20 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 mt-bindir-path
7cc0: 28 73 65 74 65 6e 76 20 22 50 41 54 48 22 20 28 (setenv "PATH" (
7cd0: 63 6f 6e 63 20 28 67 65 74 65 6e 76 20 22 50 41 conc (getenv "PA
7ce0: 54 48 22 29 20 22 3a 22 20 6d 74 2d 62 69 6e 64 TH") ":" mt-bind
7cf0: 69 72 2d 70 61 74 68 29 29 29 0a 20 20 20 20 20 ir-path))).
7d00: 20 20 20 20 20 3b 3b 28 62 62 2d 63 68 65 63 6b ;;(bb-check
7d10: 2d 70 61 74 68 20 6d 73 67 3a 20 22 6c 61 75 6e -path msg: "laun
7d20: 63 68 3a 65 78 65 63 75 74 65 20 70 6f 73 74 20 ch:execute post
7d30: 62 6c 6f 63 6b 20 34 22 29 0a 09 20 20 3b 3b 20 block 4").. ;;
7d40: 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 (change-director
7d50: 79 20 74 6f 70 2d 70 61 74 68 29 0a 09 20 20 3b y top-path).. ;
7d60: 3b 20 43 61 6e 20 73 65 74 75 70 20 61 73 20 63 ; Can setup as c
7d70: 6c 69 65 6e 74 20 66 6f 72 20 73 65 72 76 65 72 lient for server
7d80: 20 6d 6f 64 65 20 6e 6f 77 0a 09 20 20 3b 3b 20 mode now.. ;;
7d90: 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 29 0a 0a (client:setup)..
7da0: 09 20 20 0a 09 20 20 3b 3b 20 65 6e 76 69 72 6f . .. ;; enviro
7db0: 6e 6d 65 6e 74 20 6f 76 65 72 72 69 64 65 73 20 nment overrides
7dc0: 61 72 65 20 64 6f 6e 65 20 2a 62 65 66 6f 72 65 are done *before
7dd0: 2a 20 74 68 65 20 72 65 6d 61 69 6e 69 6e 67 20 * the remaining
7de0: 63 72 69 74 69 63 61 6c 20 65 6e 76 61 72 73 2e critical envars.
7df0: 0a 09 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d .. (alist->env-
7e00: 76 61 72 73 20 65 6e 76 2d 6f 76 72 64 29 0a 20 vars env-ovrd).
7e10: 20 20 20 20 20 20 20 20 20 3b 3b 28 62 62 2d 63 ;;(bb-c
7e20: 68 65 63 6b 2d 70 61 74 68 20 6d 73 67 3a 20 22 heck-path msg: "
7e30: 6c 61 75 6e 63 68 3a 65 78 65 63 75 74 65 20 70 launch:execute p
7e40: 6f 73 74 20 62 6c 6f 63 6b 20 34 31 22 29 0a 09 ost block 41")..
7e50: 20 20 28 72 75 6e 73 3a 73 65 74 2d 6d 65 67 61 (runs:set-mega
7e60: 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 test-env-vars ru
7e70: 6e 2d 69 64 20 69 6e 6b 65 79 73 3a 20 6b 65 79 n-id inkeys: key
7e80: 73 20 69 6e 6b 65 79 76 61 6c 73 3a 20 6b 65 79 s inkeyvals: key
7e90: 76 61 6c 73 29 0a 20 20 20 20 20 20 20 20 20 20 vals).
7ea0: 3b 3b 28 62 62 2d 63 68 65 63 6b 2d 70 61 74 68 ;;(bb-check-path
7eb0: 20 6d 73 67 3a 20 22 6c 61 75 6e 63 68 3a 65 78 msg: "launch:ex
7ec0: 65 63 75 74 65 20 70 6f 73 74 20 62 6c 6f 63 6b ecute post block
7ed0: 20 34 32 22 29 0a 09 20 20 28 73 65 74 2d 69 74 42").. (set-it
7ee0: 65 6d 2d 65 6e 76 2d 76 61 72 73 20 69 74 65 6d em-env-vars item
7ef0: 64 61 74 29 0a 20 20 20 20 20 20 20 20 20 20 3b dat). ;
7f00: 3b 28 62 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 ;(bb-check-path
7f10: 6d 73 67 3a 20 22 6c 61 75 6e 63 68 3a 65 78 65 msg: "launch:exe
7f20: 63 75 74 65 20 70 6f 73 74 20 62 6c 6f 63 6b 20 cute post block
7f30: 34 33 22 29 0a 20 20 20 20 20 20 20 20 20 20 28 43"). (
7f40: 6c 65 74 20 28 28 62 6c 61 63 6b 6c 69 73 74 20 let ((blacklist
7f50: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
7f60: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
7f70: 75 70 22 20 22 62 6c 61 63 6b 6c 69 73 74 76 61 up" "blacklistva
7f80: 72 73 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 rs"))).
7f90: 20 20 20 28 69 66 20 62 6c 61 63 6b 6c 69 73 74 (if blacklist
7fa0: 0a 09 09 28 6c 65 74 20 28 28 76 61 72 73 20 28 ...(let ((vars (
7fb0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 62 6c 61 string-split bla
7fc0: 63 6b 6c 69 73 74 29 29 29 0a 09 09 20 20 28 73 cklist)))... (s
7fd0: 61 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d ave-environment-
7fe0: 61 73 2d 66 69 6c 65 73 20 22 6d 65 67 61 74 65 as-files "megate
7ff0: 73 74 22 20 69 67 6e 6f 72 65 76 61 72 73 3a 20 st" ignorevars:
8000: 76 61 72 73 29 0a 09 09 20 20 28 66 6f 72 2d 65 vars)... (for-e
8010: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 76 61 72 ach (lambda (var
8020: 29 0a 09 09 09 20 20 20 20 20 20 28 75 6e 73 65 ).... (unse
8030: 74 65 6e 76 20 76 61 72 29 29 0a 09 09 09 20 20 tenv var))....
8040: 20 20 76 61 72 73 29 29 0a 20 20 20 20 20 20 20 vars)).
8050: 20 20 20 20 20 20 20 20 20 28 73 61 76 65 2d 65 (save-e
8060: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 nvironment-as-fi
8070: 6c 65 73 20 22 6d 65 67 61 74 65 73 74 22 29 29 les "megatest"))
8080: 29 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 28 62 ). ;;(b
8090: 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 6d 73 67 b-check-path msg
80a0: 3a 20 22 6c 61 75 6e 63 68 3a 65 78 65 63 75 74 : "launch:execut
80b0: 65 20 70 6f 73 74 20 62 6c 6f 63 6b 20 34 34 22 e post block 44"
80c0: 29 0a 09 20 20 3b 3b 20 6f 70 65 6e 2d 72 75 6e ).. ;; open-run
80d0: 2d 63 6c 6f 73 65 20 6e 6f 74 20 6e 65 65 64 65 -close not neede
80e0: 64 20 66 6f 72 20 74 65 73 74 2d 73 65 74 2d 6d d for test-set-m
80f0: 65 74 61 2d 69 6e 66 6f 0a 09 20 20 3b 3b 20 28 eta-info.. ;; (
8100: 74 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d tests:set-full-m
8110: 65 74 61 2d 69 6e 66 6f 20 23 66 20 74 65 73 74 eta-info #f test
8120: 2d 69 64 20 72 75 6e 2d 69 64 20 30 20 77 6f 72 -id run-id 0 wor
8130: 6b 2d 61 72 65 61 29 0a 09 20 20 3b 3b 20 28 74 k-area).. ;; (t
8140: 65 73 74 73 3a 73 65 74 2d 66 75 6c 6c 2d 6d 65 ests:set-full-me
8150: 74 61 2d 69 6e 66 6f 20 74 65 73 74 2d 69 64 20 ta-info test-id
8160: 72 75 6e 2d 69 64 20 30 20 77 6f 72 6b 2d 61 72 run-id 0 work-ar
8170: 65 61 29 0a 09 20 20 28 74 65 73 74 73 3a 73 65 ea).. (tests:se
8180: 74 2d 66 75 6c 6c 2d 6d 65 74 61 2d 69 6e 66 6f t-full-meta-info
8190: 20 23 66 20 74 65 73 74 2d 69 64 20 72 75 6e 2d #f test-id run-
81a0: 69 64 20 30 20 77 6f 72 6b 2d 61 72 65 61 20 31 id 0 work-area 1
81b0: 30 29 0a 0a 09 20 20 3b 3b 20 28 74 68 72 65 61 0)... ;; (threa
81c0: 64 2d 73 6c 65 65 70 21 20 30 2e 33 29 20 3b 3b d-sleep! 0.3) ;;
81d0: 20 4e 46 53 20 73 6c 6f 77 6e 65 73 73 20 68 61 NFS slowness ha
81e0: 73 20 63 61 75 73 65 64 20 67 72 69 65 66 20 68 s caused grief h
81f0: 65 72 65 0a 0a 09 20 20 28 69 66 20 28 61 72 67 ere... (if (arg
8200: 73 3a 67 65 74 2d 61 72 67 20 22 2d 78 74 65 72 s:get-arg "-xter
8210: 6d 22 29 0a 09 20 20 20 20 20 20 28 73 65 74 21 m").. (set!
8220: 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 22 fullrunscript "
8230: 78 74 65 72 6d 22 29 0a 09 20 20 20 20 20 20 28 xterm").. (
8240: 69 66 20 28 61 6e 64 20 66 75 6c 6c 72 75 6e 73 if (and fullruns
8250: 63 72 69 70 74 20 0a 09 09 20 20 20 20 20 20 20 cript ...
8260: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
8270: 73 74 73 3f 20 66 75 6c 6c 72 75 6e 73 63 72 69 sts? fullrunscri
8280: 70 74 29 0a 09 09 20 20 20 20 20 20 20 28 6e 6f pt)... (no
8290: 74 20 28 66 69 6c 65 2d 65 78 65 63 75 74 65 2d t (file-execute-
82a0: 61 63 63 65 73 73 3f 20 66 75 6c 6c 72 75 6e 73 access? fullruns
82b0: 63 72 69 70 74 29 29 29 0a 09 09 20 20 28 73 79 cript)))... (sy
82c0: 73 74 65 6d 20 28 63 6f 6e 63 20 22 63 68 6d 6f stem (conc "chmo
82d0: 64 20 75 67 2b 78 20 22 20 66 75 6c 6c 72 75 6e d ug+x " fullrun
82e0: 73 63 72 69 70 74 29 29 29 29 0a 0a 09 20 20 3b script))))... ;
82f0: 3b 20 57 65 20 61 72 65 20 61 62 6f 75 74 20 74 ; We are about t
8300: 6f 20 61 63 74 75 61 6c 6c 79 20 6b 69 63 6b 20 o actually kick
8310: 6f 66 66 20 74 68 65 20 74 65 73 74 0a 09 20 20 off the test..
8320: 3b 3b 20 73 6f 20 74 68 69 73 20 69 73 20 61 20 ;; so this is a
8330: 67 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 72 65 good place to re
8340: 6d 6f 76 65 20 74 68 65 20 72 65 63 6f 72 64 73 move the records
8350: 20 66 6f 72 20 0a 09 20 20 3b 3b 20 61 6e 79 20 for .. ;; any
8360: 70 72 65 76 69 6f 75 73 20 72 75 6e 73 0a 09 20 previous runs..
8370: 20 3b 3b 20 28 64 62 3a 74 65 73 74 2d 72 65 6d ;; (db:test-rem
8380: 6f 76 65 2d 73 74 65 70 73 20 64 62 20 72 75 6e ove-steps db run
8390: 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 -id testname ite
83a0: 6d 64 61 74 29 0a 09 20 20 3b 3b 20 6e 6f 77 20 mdat).. ;; now
83b0: 69 73 20 61 6c 73 6f 20 61 20 67 6f 6f 64 20 74 is also a good t
83c0: 69 6d 65 20 74 6f 20 77 72 69 74 65 20 74 68 65 ime to write the
83d0: 20 2e 74 65 73 74 63 6f 6e 66 69 67 20 66 69 6c .testconfig fil
83e0: 65 0a 09 20 20 28 6c 65 74 2a 20 28 28 74 63 6f e.. (let* ((tco
83f0: 6e 66 69 67 2d 66 6e 61 6d 65 20 20 20 28 63 6f nfig-fname (co
8400: 6e 63 20 77 6f 72 6b 2d 61 72 65 61 20 22 2f 2e nc work-area "/.
8410: 74 65 73 74 63 6f 6e 66 69 67 22 29 29 0a 09 09 testconfig"))...
8420: 20 28 74 63 6f 6e 66 69 67 2d 74 6d 70 66 69 6c (tconfig-tmpfil
8430: 65 20 28 63 6f 6e 63 20 74 63 6f 6e 66 69 67 2d e (conc tconfig-
8440: 66 6e 61 6d 65 20 22 2e 74 6d 70 22 29 29 0a 09 fname ".tmp"))..
8450: 09 20 28 74 63 6f 6e 66 69 67 20 20 20 20 20 20 . (tconfig
8460: 20 20 20 28 74 65 73 74 73 3a 67 65 74 2d 74 65 (tests:get-te
8470: 73 74 63 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 stconfig test-na
8480: 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 74 63 6f me item-path tco
8490: 6e 66 69 67 72 65 67 20 23 74 20 66 6f 72 63 65 nfigreg #t force
84a0: 2d 63 72 65 61 74 65 3a 20 23 74 29 29 20 3b 3b -create: #t)) ;;
84b0: 20 27 72 65 74 75 72 6e 2d 70 72 6f 63 73 29 29 'return-procs))
84c0: 29 0a 09 09 20 28 73 63 72 69 70 74 73 20 28 63 )... (scripts (c
84d0: 6f 6e 66 69 67 66 3a 67 65 74 2d 73 65 63 74 69 onfigf:get-secti
84e0: 6f 6e 20 74 63 6f 6e 66 69 67 20 22 73 63 72 69 on tconfig "scri
84f0: 70 74 73 22 29 29 29 0a 09 20 20 20 20 3b 3b 20 pts"))).. ;;
8500: 63 72 65 61 74 65 20 2e 74 65 73 74 63 6f 6e 66 create .testconf
8510: 69 67 20 66 69 6c 65 0a 09 20 20 20 20 28 63 6f ig file.. (co
8520: 6e 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 nfigf:write-alis
8530: 74 20 74 63 6f 6e 66 69 67 20 74 63 6f 6e 66 69 t tconfig tconfi
8540: 67 2d 74 6d 70 66 69 6c 65 29 0a 09 20 20 20 20 g-tmpfile)..
8550: 28 66 69 6c 65 2d 6d 6f 76 65 20 74 63 6f 6e 66 (file-move tconf
8560: 69 67 2d 74 6d 70 66 69 6c 65 20 74 63 6f 6e 66 ig-tmpfile tconf
8570: 69 67 2d 66 6e 61 6d 65 20 23 74 29 0a 09 20 20 ig-fname #t)..
8580: 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 (delete-file*
8590: 22 2e 66 69 6e 61 6c 2d 73 74 61 74 75 73 22 29 ".final-status")
85a0: 0a 0a 09 20 20 20 20 3b 3b 20 65 78 74 72 61 63 ... ;; extrac
85b0: 74 20 73 63 72 69 70 74 73 20 66 72 6f 6d 20 74 t scripts from t
85c0: 65 73 74 63 6f 6e 66 69 67 20 61 6e 64 20 77 72 estconfig and wr
85d0: 69 74 65 20 74 68 65 6d 20 74 6f 20 66 69 6c 65 ite them to file
85e0: 73 20 69 6e 20 74 65 73 74 20 72 75 6e 20 64 69 s in test run di
85f0: 72 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 68 r.. (for-each
8600: 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 .. (lambda (
8610: 73 63 72 69 70 74 64 61 74 29 0a 09 20 20 20 20 scriptdat)..
8620: 20 20 20 28 6d 61 74 63 68 20 73 63 72 69 70 74 (match script
8630: 64 61 74 0a 09 09 20 20 20 20 20 20 28 28 6e 61 dat... ((na
8640: 6d 65 20 63 6f 6e 74 65 6e 74 29 0a 09 09 20 20 me content)...
8650: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
8660: 74 2d 74 6f 2d 66 69 6c 65 20 6e 61 6d 65 0a 09 t-to-file name..
8670: 09 09 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 .. (lambda ()...
8680: 09 20 20 20 28 70 72 69 6e 74 20 63 6f 6e 74 65 . (print conte
8690: 6e 74 29 0a 09 09 09 20 20 20 28 63 68 61 6e 67 nt).... (chang
86a0: 65 2d 66 69 6c 65 2d 6d 6f 64 65 20 6e 61 6d 65 e-file-mode name
86b0: 20 28 62 69 74 77 69 73 65 2d 69 6f 72 20 70 65 (bitwise-ior pe
86c0: 72 6d 2f 69 72 77 78 67 20 70 65 72 6d 2f 69 72 rm/irwxg perm/ir
86d0: 77 78 75 29 29 29 29 29 0a 09 09 20 20 20 20 20 wxu)))))...
86e0: 20 28 65 6c 73 65 0a 09 09 20 20 20 20 20 20 20 (else...
86f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
8700: 6f 20 30 20 22 49 6e 76 61 6c 69 64 20 73 63 72 o 0 "Invalid scr
8710: 69 70 74 20 64 65 66 69 6e 69 74 6f 6e 20 66 6f ipt definiton fo
8720: 75 6e 64 20 69 6e 20 5b 73 63 72 69 70 74 73 5d und in [scripts]
8730: 20 73 65 63 74 69 6f 6e 20 6f 66 20 74 65 73 74 section of test
8740: 63 6f 6e 66 69 67 2e 20 5c 22 22 20 73 63 72 69 config. \"" scri
8750: 70 74 64 61 74 20 22 5c 22 22 29 29 29 29 0a 09 ptdat "\""))))..
8760: 20 20 20 20 20 73 63 72 69 70 74 73 29 29 0a 09 scripts))..
8770: 20 20 3b 3b 20 0a 09 20 20 28 6c 65 74 2a 20 28 ;; .. (let* (
8780: 28 6d 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m (m
8790: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 09 09 20 28 ake-mutex))... (
87a0: 6b 69 6c 6c 2d 6a 6f 62 3f 20 20 20 20 23 66 29 kill-job? #f)
87b0: 0a 09 09 20 28 65 78 69 74 2d 69 6e 66 6f 20 20 ... (exit-info
87c0: 20 20 28 6d 61 6b 65 2d 6c 61 75 6e 63 68 3a 65 (make-launch:e
87d0: 69 6e 66 20 70 69 64 3a 20 23 74 20 65 78 69 74 inf pid: #t exit
87e0: 2d 73 74 61 74 75 73 3a 20 23 74 20 65 78 69 74 -status: #t exit
87f0: 2d 63 6f 64 65 3a 20 23 74 20 72 6f 6c 6c 75 70 -code: #t rollup
8800: 2d 73 74 61 74 75 73 3a 20 30 29 29 20 3b 3b 20 -status: 0)) ;;
8810: 70 69 64 20 65 78 69 74 2d 73 74 61 74 75 73 20 pid exit-status
8820: 65 78 69 74 2d 63 6f 64 65 20 28 69 2e 65 2e 20 exit-code (i.e.
8830: 70 72 6f 63 65 73 73 20 77 61 73 20 73 75 63 63 process was succ
8840: 65 73 73 66 75 6c 6c 79 20 72 75 6e 29 20 72 6f essfully run) ro
8850: 6c 6c 75 70 2d 73 74 61 74 75 73 0a 09 09 20 28 llup-status... (
8860: 6a 6f 62 2d 74 68 72 65 61 64 20 20 20 23 66 29 job-thread #f)
8870: 0a 09 09 20 3b 3b 20 28 6b 65 65 70 2d 67 6f 69 ... ;; (keep-goi
8880: 6e 67 20 20 20 23 74 29 0a 09 09 20 28 6d 69 73 ng #t)... (mis
8890: 63 2d 66 6c 61 67 73 20 20 20 28 6c 65 74 20 28 c-flags (let (
88a0: 28 68 74 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (ht (make-hash-t
88b0: 61 62 6c 65 29 29 29 0a 09 09 09 09 20 28 68 61 able)))..... (ha
88c0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 sh-table-set! ht
88d0: 20 27 6b 65 65 70 2d 67 6f 69 6e 67 20 23 74 29 'keep-going #t)
88e0: 0a 09 09 09 09 20 68 74 29 29 0a 09 09 20 28 72 ..... ht))... (r
88f0: 75 6e 69 74 20 20 20 20 20 20 20 20 28 6c 61 6d unit (lam
8900: 62 64 61 20 28 29 0a 09 09 09 09 20 28 6c 61 75 bda ()..... (lau
8910: 6e 63 68 3a 6d 61 6e 61 67 65 2d 73 74 65 70 73 nch:manage-steps
8920: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
8930: 69 74 65 6d 2d 70 61 74 68 20 66 75 6c 6c 72 75 item-path fullru
8940: 6e 73 63 72 69 70 74 20 65 7a 73 74 65 70 73 20 nscript ezsteps
8950: 73 75 62 72 75 6e 20 74 65 73 74 2d 6e 61 6d 65 subrun test-name
8960: 20 74 63 6f 6e 66 69 67 72 65 67 20 65 78 69 74 tconfigreg exit
8970: 2d 69 6e 66 6f 20 6d 29 29 29 0a 09 09 20 28 6d -info m)))... (m
8980: 6f 6e 69 74 6f 72 6a 6f 62 20 20 20 28 6c 61 6d onitorjob (lam
8990: 62 64 61 20 28 29 0a 09 09 09 09 20 28 6c 61 75 bda ()..... (lau
89a0: 6e 63 68 3a 6d 6f 6e 69 74 6f 72 2d 6a 6f 62 20 nch:monitor-job
89b0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
89c0: 69 74 65 6d 2d 70 61 74 68 20 66 75 6c 6c 72 75 item-path fullru
89d0: 6e 73 63 72 69 70 74 20 65 7a 73 74 65 70 73 20 nscript ezsteps
89e0: 74 65 73 74 2d 6e 61 6d 65 20 74 63 6f 6e 66 69 test-name tconfi
89f0: 67 72 65 67 20 65 78 69 74 2d 69 6e 66 6f 20 6d greg exit-info m
8a00: 20 77 6f 72 6b 2d 61 72 65 61 20 72 75 6e 74 6c work-area runtl
8a10: 69 6d 20 6d 69 73 63 2d 66 6c 61 67 73 29 29 29 im misc-flags)))
8a20: 0a 09 09 20 28 74 68 31 20 20 20 20 20 20 20 20 ... (th1
8a30: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 6d (make-thread m
8a40: 6f 6e 69 74 6f 72 6a 6f 62 20 22 6d 6f 6e 69 74 onitorjob "monit
8a50: 6f 72 20 6a 6f 62 22 29 29 0a 09 09 20 28 74 68 or job"))... (th
8a60: 32 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2 (make
8a70: 2d 74 68 72 65 61 64 20 72 75 6e 69 74 20 22 72 -thread runit "r
8a80: 75 6e 20 6a 6f 62 22 29 29 29 0a 09 20 20 20 20 un job")))..
8a90: 28 73 65 74 21 20 6a 6f 62 2d 74 68 72 65 61 64 (set! job-thread
8aa0: 20 74 68 32 29 0a 09 20 20 20 20 28 74 68 72 65 th2).. (thre
8ab0: 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 09 ad-start! th1)..
8ac0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
8ad0: 74 21 20 74 68 32 29 0a 09 20 20 20 20 28 74 68 t! th2).. (th
8ae0: 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 32 29 0a read-join! th2).
8af0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
8b00: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
8b10: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4d 65 67 t-log-port* "Meg
8b20: 61 74 65 73 74 20 65 78 65 63 74 75 74 65 20 6f atest exectute o
8b30: 66 20 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 f test " test-na
8b40: 6d 65 20 22 2c 20 69 74 65 6d 20 70 61 74 68 20 me ", item path
8b50: 22 20 69 74 65 6d 2d 70 61 74 68 20 22 20 63 6f " item-path " co
8b60: 6d 70 6c 65 74 65 2e 20 4e 6f 74 69 66 79 69 6e mplete. Notifyin
8b70: 67 20 74 68 65 20 64 62 20 2e 2e 2e 22 29 0a 09 g the db ...")..
8b80: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
8b90: 73 65 74 21 20 6d 69 73 63 2d 66 6c 61 67 73 20 set! misc-flags
8ba0: 27 6b 65 65 70 2d 67 6f 69 6e 67 20 23 66 29 0a 'keep-going #f).
8bb0: 09 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 . (thread-joi
8bc0: 6e 21 20 74 68 31 29 0a 09 20 20 20 20 28 74 68 n! th1).. (th
8bd0: 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 20 20 read-sleep! 1)
8be0: 20 20 20 20 20 3b 3b 20 67 69 76 62 65 20 74 68 ;; givbe th
8bf0: 72 65 61 64 20 74 68 31 20 61 20 63 68 61 6e 63 read th1 a chanc
8c00: 65 20 74 6f 20 62 65 20 64 6f 6e 65 20 54 4f 44 e to be done TOD
8c10: 4f 3a 20 56 65 72 69 66 79 20 74 68 69 73 20 69 O: Verify this i
8c20: 73 20 6e 65 65 64 65 64 2e 20 41 74 20 30 2e 31 s needed. At 0.1
8c30: 20 49 20 77 61 73 20 67 65 74 74 69 6e 67 20 66 I was getting f
8c40: 61 69 6c 20 74 6f 20 73 74 6f 70 2c 20 69 6e 63 ail to stop, inc
8c50: 72 65 61 73 65 64 20 74 6f 20 74 6f 74 61 6c 20 reased to total
8c60: 6f 66 20 31 2e 31 20 73 65 63 2e 0a 09 20 20 20 of 1.1 sec...
8c70: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d 29 (mutex-lock! m)
8c80: 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 74 .. (let* ((it
8c90: 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 em-path (item-li
8ca0: 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 st->path itemdat
8cb0: 29 29 0a 09 09 20 20 20 3b 3b 20 6f 6e 6c 79 20 ))... ;; only
8cc0: 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 state and status
8cd0: 20 6e 65 65 64 65 64 20 2d 20 75 73 65 20 6c 61 needed - use la
8ce0: 7a 79 20 72 6f 75 74 69 6e 65 0a 09 09 20 20 20 zy routine...
8cf0: 28 74 65 73 74 69 6e 66 6f 20 20 28 72 6d 74 3a (testinfo (rmt:
8d00: 67 65 74 2d 74 65 73 74 69 6e 66 6f 2d 73 74 61 get-testinfo-sta
8d10: 74 65 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 te-status run-id
8d20: 20 74 65 73 74 2d 69 64 29 29 29 0a 09 20 20 20 test-id)))..
8d30: 20 20 20 3b 3b 20 41 6d 20 49 20 63 6f 6d 70 6c ;; Am I compl
8d40: 65 74 65 64 3f 0a 09 20 20 20 20 20 20 28 69 66 eted?.. (if
8d50: 20 28 6d 65 6d 62 65 72 20 28 64 62 3a 74 65 73 (member (db:tes
8d60: 74 2d 67 65 74 2d 73 74 61 74 65 20 74 65 73 74 t-get-state test
8d70: 69 6e 66 6f 29 20 27 28 22 52 45 4d 4f 54 45 48 info) '("REMOTEH
8d80: 4f 53 54 53 54 41 52 54 22 20 22 52 55 4e 4e 49 OSTSTART" "RUNNI
8d90: 4e 47 22 29 29 20 3b 3b 20 4e 4f 54 45 3a 20 49 NG")) ;; NOTE: I
8da0: 74 20 73 68 6f 75 6c 64 20 2a 6e 6f 74 2a 20 62 t should *not* b
8db0: 65 20 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 e REMOTEHOSTSTAR
8dc0: 54 20 62 75 74 20 66 6f 72 20 72 65 61 73 6f 6e T but for reason
8dd0: 73 20 49 20 64 6f 6e 27 74 20 79 65 74 20 75 6e s I don't yet un
8de0: 64 65 72 73 74 61 6e 64 20 69 74 20 73 6f 6d 65 derstand it some
8df0: 74 69 6d 65 73 20 67 65 74 73 20 73 74 75 63 6b times gets stuck
8e00: 20 69 6e 20 74 68 61 74 20 73 74 61 74 65 20 3b in that state ;
8e10: 3b 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 ; (not (equal? (
8e20: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
8e30: 65 20 74 65 73 74 69 6e 66 6f 29 20 22 43 4f 4d e testinfo) "COM
8e40: 50 4c 45 54 45 44 22 29 29 0a 09 09 20 20 28 6c PLETED"))... (l
8e50: 65 74 20 28 28 6e 65 77 2d 73 74 61 74 65 20 20 et ((new-state
8e60: 28 69 66 20 6b 69 6c 6c 2d 6a 6f 62 3f 20 22 4b (if kill-job? "K
8e70: 49 4c 4c 45 44 22 20 22 43 4f 4d 50 4c 45 54 45 ILLED" "COMPLETE
8e80: 44 22 29 20 3b 3b 20 28 69 66 20 28 65 71 3f 20 D") ;; (if (eq?
8e90: 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 (vector-ref exit
8ea0: 2d 69 6e 66 6f 20 32 29 20 30 29 20 3b 3b 20 65 -info 2) 0) ;; e
8eb0: 78 69 74 65 64 20 77 69 74 68 20 22 67 6f 6f 64 xited with "good
8ec0: 22 20 73 74 61 74 75 73 0a 09 09 09 09 20 20 20 " status.....
8ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8ef0: 20 20 20 20 20 3b 3b 20 22 43 4f 4d 50 4c 45 54 ;; "COMPLET
8f00: 45 44 22 09 09 09 09 09 09 09 20 20 20 20 20 20 ED".......
8f10: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 64 62 ;; (db
8f20: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
8f30: 74 65 73 74 69 6e 66 6f 29 29 29 20 20 20 3b 3b testinfo))) ;;
8f40: 20 65 6c 73 65 20 70 72 65 73 65 76 65 20 74 68 else preseve th
8f50: 65 20 73 74 61 74 65 20 61 73 20 73 65 74 20 77 e state as set w
8f60: 69 74 68 69 6e 20 74 68 65 20 74 65 73 74 0a 09 ithin the test..
8f70: 09 09 09 20 20 20 20 29 0a 09 09 09 28 6e 65 77 ... )....(new
8f80: 2d 73 74 61 74 75 73 20 28 63 6f 6e 64 0a 09 09 -status (cond...
8f90: 09 09 20 20 20 20 20 28 28 6e 6f 74 20 28 6c 61 .. ((not (la
8fa0: 75 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 73 unch:einf-exit-s
8fb0: 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 tatus exit-info)
8fc0: 29 20 22 46 41 49 4c 22 29 20 3b 3b 20 6a 6f 62 ) "FAIL") ;; job
8fd0: 20 66 61 69 6c 65 64 20 74 6f 20 72 75 6e 20 2e failed to run .
8fe0: 2e 2e 20 28 76 65 63 74 6f 72 2d 72 65 66 20 65 .. (vector-ref e
8ff0: 78 69 74 2d 69 6e 66 6f 20 31 29 0a 09 09 09 09 xit-info 1).....
9000: 20 20 20 20 20 28 28 65 71 3f 20 28 6c 61 75 6e ((eq? (laun
9010: 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c 75 70 2d 73 ch:einf-rollup-s
9020: 74 61 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 tatus exit-info)
9030: 20 30 29 20 20 20 20 20 3b 3b 20 28 76 65 63 74 0) ;; (vect
9040: 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f or-ref exit-info
9050: 20 33 29 0a 09 09 09 09 20 20 20 20 20 20 3b 3b 3)..... ;;
9060: 20 69 66 20 74 68 65 20 63 75 72 72 65 6e 74 20 if the current
9070: 73 74 61 74 75 73 20 69 73 20 41 55 54 4f 20 74 status is AUTO t
9080: 68 65 6e 20 64 65 66 65 72 20 74 6f 20 74 68 65 hen defer to the
9090: 20 63 61 6c 63 75 6c 61 74 65 64 20 76 61 6c 75 calculated valu
90a0: 65 20 28 69 2e 65 2e 20 6c 65 61 76 65 20 74 68 e (i.e. leave th
90b0: 69 73 20 41 55 54 4f 29 0a 09 09 09 09 20 20 20 is AUTO).....
90c0: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 (if (equal? (
90d0: 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 db:test-get-stat
90e0: 75 73 20 74 65 73 74 69 6e 66 6f 29 20 22 41 55 us testinfo) "AU
90f0: 54 4f 22 29 20 22 41 55 54 4f 22 20 22 50 41 53 TO") "AUTO" "PAS
9100: 53 22 29 29 0a 09 09 09 09 20 20 20 20 20 28 28 S"))..... ((
9110: 65 71 3f 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 eq? (launch:einf
9120: 2d 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 -rollup-status e
9130: 78 69 74 2d 69 6e 66 6f 29 20 31 29 20 22 46 41 xit-info) 1) "FA
9140: 49 4c 22 29 20 20 3b 3b 20 28 76 65 63 74 6f 72 IL") ;; (vector
9150: 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 33 -ref exit-info 3
9160: 29 0a 09 09 09 09 20 20 20 20 20 28 28 65 71 3f )..... ((eq?
9170: 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f (launch:einf-ro
9180: 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 llup-status exit
9190: 2d 69 6e 66 6f 29 20 32 29 09 20 20 20 20 20 3b -info) 2). ;
91a0: 3b 09 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 ;.(vector-ref ex
91b0: 69 74 2d 69 6e 66 6f 20 33 29 0a 09 09 09 09 20 it-info 3).....
91c0: 20 20 20 20 20 3b 3b 20 69 66 20 74 68 65 20 63 ;; if the c
91d0: 75 72 72 65 6e 74 20 73 74 61 74 75 73 20 69 73 urrent status is
91e0: 20 41 55 54 4f 20 74 68 65 20 64 65 66 65 72 20 AUTO the defer
91f0: 74 6f 20 74 68 65 20 63 61 6c 63 75 6c 61 74 65 to the calculate
9200: 64 20 76 61 6c 75 65 20 62 75 74 20 71 75 61 6c d value but qual
9210: 69 66 79 20 28 69 2e 65 2e 20 6d 61 6b 65 20 74 ify (i.e. make t
9220: 68 69 73 20 41 55 54 4f 2d 57 41 52 4e 29 0a 09 his AUTO-WARN)..
9230: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 ... (if (eq
9240: 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 ual? (db:test-ge
9250: 74 2d 73 74 61 74 75 73 20 74 65 73 74 69 6e 66 t-status testinf
9260: 6f 29 20 22 41 55 54 4f 22 29 20 22 41 55 54 4f o) "AUTO") "AUTO
9270: 2d 57 41 52 4e 22 20 22 57 41 52 4e 22 29 29 0a -WARN" "WARN")).
9280: 09 09 09 09 20 20 20 20 20 28 28 65 71 3f 20 28 .... ((eq? (
9290: 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c 6c launch:einf-roll
92a0: 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d 69 up-status exit-i
92b0: 6e 66 6f 29 20 33 29 20 22 43 48 45 43 4b 22 29 nfo) 3) "CHECK")
92c0: 0a 09 09 09 09 20 20 20 20 20 28 28 65 71 3f 20 ..... ((eq?
92d0: 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c (launch:einf-rol
92e0: 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d lup-status exit-
92f0: 69 6e 66 6f 29 20 34 29 20 22 57 41 49 56 45 44 info) 4) "WAIVED
9300: 22 29 0a 09 09 09 09 20 20 20 20 20 28 28 65 71 ")..... ((eq
9310: 3f 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 ? (launch:einf-r
9320: 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 ollup-status exi
9330: 74 2d 69 6e 66 6f 29 20 35 29 20 22 41 42 4f 52 t-info) 5) "ABOR
9340: 54 22 29 0a 09 09 09 09 20 20 20 20 20 28 28 65 T")..... ((e
9350: 71 3f 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d q? (launch:einf-
9360: 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 78 rollup-status ex
9370: 69 74 2d 69 6e 66 6f 29 20 36 29 20 22 53 4b 49 it-info) 6) "SKI
9380: 50 22 29 0a 09 09 09 09 20 20 20 20 20 28 65 6c P")..... (el
9390: 73 65 20 22 46 41 49 4c 22 29 29 29 29 20 3b 3b se "FAIL")))) ;;
93a0: 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 (db:test-get-st
93b0: 61 74 75 73 20 74 65 73 74 69 6e 66 6f 29 29 29 atus testinfo)))
93c0: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
93d0: 69 6e 74 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 int-info 1 *defa
93e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 ult-log-port* "T
93f0: 65 73 74 20 65 78 69 74 65 64 20 69 6e 20 73 74 est exited in st
9400: 61 74 65 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 ate=" (db:test-g
9410: 65 74 2d 73 74 61 74 65 20 74 65 73 74 69 6e 66 et-state testinf
9420: 6f 29 20 22 2c 20 73 65 74 74 69 6e 67 20 73 74 o) ", setting st
9430: 61 74 65 2f 73 74 61 74 75 73 20 62 61 73 65 64 ate/status based
9440: 20 6f 6e 20 65 78 69 74 20 63 6f 64 65 20 6f 66 on exit code of
9450: 20 22 20 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d " (launch:einf-
9460: 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 74 exit-status exit
9470: 2d 69 6e 66 6f 29 20 22 20 61 6e 64 20 72 6f 6c -info) " and rol
9480: 6c 75 70 2d 73 74 61 74 75 73 20 6f 66 20 22 20 lup-status of "
9490: 28 6c 61 75 6e 63 68 3a 65 69 6e 66 2d 72 6f 6c (launch:einf-rol
94a0: 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 2d lup-status exit-
94b0: 69 6e 66 6f 29 29 0a 20 20 20 0a 20 20 20 20 20 info)). .
94c0: 20 20 20 3b 3b 20 4c 65 61 76 65 20 61 20 2e 66 ;; Leave a .f
94d0: 69 6e 61 6c 2d 73 74 61 74 75 73 20 66 69 6c 65 inal-status file
94e0: 20 66 6f 72 20 65 61 63 68 20 73 75 62 2d 74 65 for each sub-te
94f0: 73 74 0a 20 20 20 20 20 20 20 20 28 74 65 73 74 st. (test
9500: 73 3a 73 61 76 65 2d 66 69 6e 61 6c 2d 73 74 61 s:save-final-sta
9510: 74 75 73 20 72 75 6e 2d 69 64 20 74 65 73 74 2d tus run-id test-
9520: 69 64 29 0a 0a 09 09 20 20 20 20 28 74 65 73 74 id).... (test
9530: 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 s:test-set-statu
9540: 73 21 20 72 75 6e 2d 69 64 20 0a 09 09 09 09 09 s! run-id ......
9550: 20 20 20 20 74 65 73 74 2d 69 64 20 0a 09 09 09 test-id ....
9560: 09 09 20 20 20 20 6e 65 77 2d 73 74 61 74 65 0a .. new-state.
9570: 09 09 09 09 09 20 20 20 20 6e 65 77 2d 73 74 61 ..... new-sta
9580: 74 75 73 0a 09 09 09 09 09 20 20 20 20 28 61 72 tus...... (ar
9590: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 gs:get-arg "-m")
95a0: 20 23 66 29 0a 09 09 20 20 20 20 3b 3b 20 6e 65 #f)... ;; ne
95b0: 65 64 20 74 6f 20 75 70 64 61 74 65 20 74 68 65 ed to update the
95c0: 20 74 6f 70 20 74 65 73 74 20 72 65 63 6f 72 64 top test record
95d0: 20 69 66 20 50 41 53 53 20 6f 72 20 46 41 49 4c if PASS or FAIL
95e0: 20 61 6e 64 20 74 68 69 73 20 69 73 20 61 20 73 and this is a s
95f0: 75 62 74 65 73 74 0a 09 09 20 20 20 20 3b 3b 20 ubtest... ;;
9600: 4e 4f 20 4e 45 45 44 20 54 4f 20 43 41 4c 4c 20 NO NEED TO CALL
9610: 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 set-state-status
9620: 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 -and-roll-up-ite
9630: 6d 73 20 48 45 52 45 2c 20 54 48 49 53 20 49 53 ms HERE, THIS IS
9640: 20 44 4f 4e 45 20 49 4e 20 73 65 74 2d 73 74 61 DONE IN set-sta
9650: 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 2d 72 6f te-status-and-ro
9660: 6c 6c 2d 75 70 2d 69 74 65 6d 73 20 63 61 6c 6c ll-up-items call
9670: 65 64 20 62 79 20 74 65 73 74 73 3a 74 65 73 74 ed by tests:test
9680: 2d 73 65 74 2d 73 74 61 74 75 73 21 0a 09 09 20 -set-status!...
9690: 20 20 20 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 )).. ;;
96a0: 66 6f 72 20 61 75 74 6f 6d 61 74 65 64 20 63 72 for automated cr
96b0: 65 61 74 69 6f 6e 20 6f 66 20 74 68 65 20 72 6f eation of the ro
96c0: 6c 6c 75 70 20 68 74 6d 6c 20 66 69 6c 65 20 74 llup html file t
96d0: 68 69 73 20 69 73 20 61 20 67 6f 6f 64 20 70 6c his is a good pl
96e0: 61 63 65 2e 2e 2e 0a 09 20 20 20 20 20 20 28 69 ace..... (i
96f0: 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 69 f (not (equal? i
9700: 74 65 6d 2d 70 61 74 68 20 22 22 29 29 0a 09 09 tem-path ""))...
9710: 20 20 20 20 20 20 28 74 65 73 74 73 3a 73 75 6d (tests:sum
9720: 6d 61 72 69 7a 65 2d 69 74 65 6d 73 20 72 75 6e marize-items run
9730: 2d 69 64 20 74 65 73 74 2d 69 64 20 74 65 73 74 -id test-id test
9740: 2d 6e 61 6d 65 20 23 66 29 29 0a 09 20 20 20 20 -name #f))..
9750: 20 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 69 (tests:summari
9760: 7a 65 2d 74 65 73 74 20 72 75 6e 2d 69 64 20 74 ze-test run-id t
9770: 65 73 74 2d 69 64 29 20 20 3b 3b 20 64 6f 6e 27 est-id) ;; don'
9780: 74 20 66 6f 72 63 65 20 2d 20 6a 75 73 74 20 75 t force - just u
9790: 70 64 61 74 65 20 69 66 20 6e 6f 0a 20 20 20 20 pdate if no.
97a0: 20 20 20 20 3b 3b 20 4c 65 61 76 65 20 61 20 2e ;; Leave a .
97b0: 66 69 6e 61 6c 2d 73 74 61 74 75 73 20 66 69 6c final-status fil
97c0: 65 20 66 6f 72 20 74 68 65 20 74 6f 70 20 6c 65 e for the top le
97d0: 76 65 6c 20 74 65 73 74 0a 20 20 20 20 20 20 20 vel test.
97e0: 20 28 74 65 73 74 73 3a 73 61 76 65 2d 66 69 6e (tests:save-fin
97f0: 61 6c 2d 73 74 61 74 75 73 20 72 75 6e 2d 69 64 al-status run-id
9800: 20 74 65 73 74 2d 69 64 29 0a 09 20 20 20 20 20 test-id)..
9810: 20 28 72 6d 74 3a 75 70 64 61 74 65 2d 72 75 6e (rmt:update-run
9820: 2d 73 74 61 74 73 20 72 75 6e 2d 69 64 20 28 72 -stats run-id (r
9830: 6d 74 3a 67 65 74 2d 72 61 77 2d 72 75 6e 2d 73 mt:get-raw-run-s
9840: 74 61 74 73 20 72 75 6e 2d 69 64 29 29 29 0a 09 tats run-id)))..
9850: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
9860: 6b 21 20 6d 29 0a 20 20 20 20 20 20 20 20 20 20 k! m).
9870: 20 20 28 6c 61 75 6e 63 68 3a 65 6e 64 2d 6f 66 (launch:end-of
9880: 2d 72 75 6e 2d 63 68 65 63 6b 20 72 75 6e 2d 69 -run-check run-i
9890: 64 20 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a d ).. (debug:
98a0: 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 print 2 *default
98b0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4f 75 74 70 -log-port* "Outp
98c0: 75 74 20 66 72 6f 6d 20 72 75 6e 6e 69 6e 67 20 ut from running
98d0: 22 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 " fullrunscript
98e0: 22 2c 20 70 69 64 20 22 20 28 6c 61 75 6e 63 68 ", pid " (launch
98f0: 3a 65 69 6e 66 2d 70 69 64 20 65 78 69 74 2d 69 :einf-pid exit-i
9900: 6e 66 6f 29 20 22 20 69 6e 20 77 6f 72 6b 20 61 nfo) " in work a
9910: 72 65 61 20 22 20 0a 09 09 09 20 77 6f 72 6b 2d rea " .... work-
9920: 61 72 65 61 20 22 3a 5c 6e 3d 3d 3d 3d 5c 6e 20 area ":\n====\n
9930: 65 78 69 74 20 63 6f 64 65 20 22 20 28 6c 61 75 exit code " (lau
9940: 6e 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 63 6f nch:einf-exit-co
9950: 64 65 20 65 78 69 74 2d 69 6e 66 6f 29 20 22 5c de exit-info) "\
9960: 6e 22 20 22 3d 3d 3d 3d 5c 6e 22 29 0a 09 20 20 n" "====\n")..
9970: 20 20 28 69 66 20 28 6e 6f 74 20 28 6c 61 75 6e (if (not (laun
9980: 63 68 3a 65 69 6e 66 2d 65 78 69 74 2d 73 74 61 ch:einf-exit-sta
9990: 74 75 73 20 65 78 69 74 2d 69 6e 66 6f 29 29 0a tus exit-info)).
99a0: 09 09 28 65 78 69 74 20 34 29 29 29 29 0a 20 20 ..(exit 4)))).
99b0: 20 20 20 20 20 20 29 29 29 0a 0a 3b 3b 20 53 70 )))..;; Sp
99c0: 65 63 20 66 6f 72 20 45 6e 64 20 6f 66 20 74 65 ec for End of te
99d0: 73 74 0a 3b 3b 20 41 74 20 65 6e 64 20 6f 66 20 st.;; At end of
99e0: 65 61 63 68 20 74 65 73 74 20 63 61 6c 6c 2c 20 each test call,
99f0: 61 66 74 65 72 20 6d 61 72 6b 69 6e 67 20 73 65 after marking se
9a00: 6c 66 20 61 73 20 43 4f 4d 50 4c 45 54 45 44 20 lf as COMPLETED
9a10: 64 6f 20 72 75 6e 2d 73 74 61 74 65 2d 73 74 61 do run-state-sta
9a20: 74 75 73 2d 72 6f 6c 6c 75 70 0a 3b 3b 20 41 74 tus-rollup.;; At
9a30: 20 74 72 61 6e 73 69 74 69 6f 6e 20 74 6f 20 72 transition to r
9a40: 75 6e 20 43 4f 4d 50 4c 45 54 45 44 2f 58 20 64 un COMPLETED/X d
9a50: 6f 20 68 6f 6f 6b 73 0a 3b 3b 20 44 65 66 69 6e o hooks.;; Defin
9a60: 69 74 69 6f 6e 3a 20 74 65 73 74 5f 64 65 61 64 ition: test_dead
9a70: 20 69 66 20 65 76 65 6e 74 5f 74 69 6d 65 20 2b if event_time +
9a80: 20 64 75 72 61 74 69 6f 6e 20 2b 20 31 20 6d 69 duration + 1 mi
9a90: 6e 75 74 65 3f 20 3c 20 63 75 72 72 65 6e 74 5f nute? < current_
9aa0: 74 69 6d 65 20 41 4e 44 0a 3b 3b 20 77 65 20 63 time AND.;; we c
9ab0: 61 6e 20 70 72 6f 76 65 20 74 68 65 20 70 72 6f an prove the pro
9ac0: 63 65 73 73 20 69 73 20 6e 6f 74 20 61 6c 69 76 cess is not aliv
9ad0: 65 20 28 73 73 68 20 68 6f 73 74 20 70 73 74 72 e (ssh host pstr
9ae0: 65 65 20 2d 41 20 70 69 64 29 0a 3b 3b 20 69 66 ee -A pid).;; if
9af0: 20 64 65 61 64 20 73 61 66 65 20 74 6f 20 6d 61 dead safe to ma
9b00: 72 6b 20 74 68 65 20 74 65 73 74 20 61 73 20 6b rk the test as k
9b10: 69 6c 6c 65 64 20 69 6e 20 74 68 65 20 64 62 0a illed in the db.
9b20: 3b 3b 20 53 74 61 74 65 2f 73 74 61 74 75 73 20 ;; State/status
9b30: 74 61 62 6c 65 0a 3b 3b 20 6e 65 77 0a 3b 3b 20 table.;; new.;;
9b40: 31 30 30 25 20 43 4f 4d 50 4c 45 54 45 44 2f 20 100% COMPLETED/
9b50: 28 50 41 53 53 2c 46 41 49 4c 2c 41 42 4f 52 54 (PASS,FAIL,ABORT
9b60: 20 65 74 63 2e 29 20 3d 3d 3e 20 43 4f 4d 50 4c etc.) ==> COMPL
9b70: 45 54 45 44 20 2f 20 58 20 77 68 65 72 65 20 58 ETED / X where X
9b80: 20 69 73 20 73 61 6d 65 20 61 73 20 69 74 65 6d is same as item
9b90: 69 7a 65 64 20 72 6f 6c 6c 75 70 0a 3b 3b 20 3e ized rollup.;; >
9ba0: 20 33 20 52 55 4e 4e 49 4e 47 20 77 69 74 68 20 3 RUNNING with
9bb0: 6e 6f 74 20 74 65 73 74 5f 64 65 61 64 20 64 6f not test_dead do
9bc0: 20 6e 6f 74 68 69 6e 67 20 28 72 75 6e 20 73 68 nothing (run sh
9bd0: 6f 75 6c 64 20 61 6c 72 65 61 64 79 20 62 65 20 ould already be
9be0: 52 55 4e 4e 49 4e 47 2f 20 6e 61 0a 3b 3b 20 3e RUNNING/ na.;; >
9bf0: 20 30 20 52 55 4e 4e 49 4e 47 20 61 6e 64 20 74 0 RUNNING and t
9c00: 65 73 74 5f 64 65 61 64 20 74 68 65 6e 20 73 65 est_dead then se
9c10: 6e 64 20 4b 49 4c 4c 52 45 51 20 3d 3d 3e 20 43 nd KILLREQ ==> C
9c20: 4f 4d 50 4c 45 54 45 44 0a 3b 3b 20 30 20 52 55 OMPLETED.;; 0 RU
9c30: 4e 4e 49 4e 47 20 3d 3d 3e 20 74 68 69 73 20 69 NNING ==> this i
9c40: 73 20 61 63 74 75 61 6c 6c 79 20 74 68 65 20 66 s actually the f
9c50: 69 72 73 74 20 63 6f 6e 64 69 74 69 6f 6e 2c 20 irst condition,
9c60: 73 68 6f 75 6c 64 20 6e 6f 74 20 67 65 74 20 68 should not get h
9c70: 65 72 65 0a 0a 28 64 65 66 69 6e 65 20 28 6c 61 ere..(define (la
9c80: 75 6e 63 68 3a 65 6e 64 2d 6f 66 2d 72 75 6e 2d unch:end-of-run-
9c90: 63 68 65 63 6b 20 72 75 6e 2d 69 64 20 29 0a 20 check run-id ).
9ca0: 20 20 20 28 6c 65 74 2a 20 28 28 6e 6f 74 2d 63 (let* ((not-c
9cb0: 6f 6d 70 6c 65 74 65 64 2d 63 6e 74 20 28 72 6d ompleted-cnt (rm
9cc0: 74 3a 67 65 74 2d 6e 6f 74 2d 63 6f 6d 70 6c 65 t:get-not-comple
9cd0: 74 65 64 2d 63 6e 74 20 72 75 6e 2d 69 64 29 29 ted-cnt run-id))
9ce0: 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 72 . (r
9cf0: 75 6e 6e 69 6e 67 2d 63 6e 74 20 28 72 6d 74 3a unning-cnt (rmt:
9d00: 67 65 74 2d 63 6f 75 6e 74 2d 74 65 73 74 73 2d get-count-tests-
9d10: 72 75 6e 6e 69 6e 67 2d 66 6f 72 2d 72 75 6e 2d running-for-run-
9d20: 69 64 20 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 id run-id)).
9d30: 20 20 20 20 20 20 20 28 61 6c 6c 2d 74 65 73 74 (all-test
9d40: 2d 6c 61 75 6e 63 68 65 64 20 28 72 6d 74 3a 67 -launched (rmt:g
9d50: 65 74 2d 76 61 72 20 28 63 6f 6e 63 20 22 6c 75 et-var (conc "lu
9d60: 6e 63 68 2d 63 6f 6d 70 6c 65 74 65 2d 22 20 72 nch-complete-" r
9d70: 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 20 20 20 un-id))).
9d80: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 74 61 (current-sta
9d90: 74 65 20 28 72 6d 74 3a 67 65 74 2d 72 75 6e 2d te (rmt:get-run-
9da0: 73 74 61 74 65 20 72 75 6e 2d 69 64 29 29 0a 20 state run-id)).
9db0: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
9dc0: 6e 74 2d 73 74 61 74 75 73 20 28 72 6d 74 3a 67 nt-status (rmt:g
9dd0: 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 20 72 75 et-run-status ru
9de0: 6e 2d 69 64 29 29 29 0a 20 20 20 20 20 3b 3b 67 n-id))). ;;g
9df0: 65 74 2d 76 61 72 73 20 72 75 6e 2d 69 64 20 74 et-vars run-id t
9e00: 6f 20 71 75 65 72 79 20 6d 65 74 61 64 61 74 61 o query metadata
9e10: 20 74 61 62 6c 65 20 74 6f 20 63 68 65 63 6b 20 table to check
9e20: 69 66 20 61 6c 6c 20 63 6f 6d 70 6c 65 74 65 64 if all completed
9e30: 2e 20 69 66 20 61 6c 6c 2d 74 65 73 74 2d 6c 61 . if all-test-la
9e40: 75 6e 63 68 65 64 20 3d 20 79 65 73 20 74 68 65 unched = yes the
9e50: 6e 20 6f 6e 6c 79 20 6e 6f 74 2d 63 6f 6d 70 6c n only not-compl
9e60: 65 74 65 64 2d 63 6e 74 20 3d 20 30 20 6d 65 61 eted-cnt = 0 mea
9e70: 6e 73 20 65 76 65 72 79 74 69 6e 67 20 69 73 20 ns everyting is
9e80: 63 6f 6d 70 6c 65 74 65 64 20 69 66 20 6e 6f 20 completed if no
9e90: 65 6e 74 72 79 20 66 6f 75 6e 64 20 69 6e 20 74 entry found in t
9ea0: 68 65 20 74 61 62 6c 65 20 64 6f 20 6e 6f 74 68 he table do noth
9eb0: 69 6e 67 20 0a 20 20 20 20 20 28 64 65 62 75 67 ing . (debug
9ec0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
9ed0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 75 6e t-log-port* "Run
9ee0: 6e 69 6e 67 20 74 65 73 74 20 63 6e 74 20 3a 22 ning test cnt :"
9ef0: 20 72 75 6e 6e 69 6e 67 2d 63 6e 74 29 20 20 20 running-cnt)
9f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9f10: 20 20 20 0a 20 20 20 20 20 28 72 6d 74 3a 73 65 . (rmt:se
9f20: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 t-state-status-a
9f30: 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 72 75 6e 20 20 nd-roll-up-run
9f40: 72 75 6e 2d 69 64 20 63 75 72 72 65 6e 74 2d 73 run-id current-s
9f50: 74 61 74 65 20 63 75 72 72 65 6e 74 2d 73 74 61 tate current-sta
9f60: 74 75 73 29 0a 20 20 20 20 20 28 72 75 6e 73 3a tus). (runs:
9f70: 75 70 64 61 74 65 2d 6a 75 6e 69 74 2d 74 65 73 update-junit-tes
9f80: 74 2d 72 65 70 6f 72 74 65 72 2d 78 6d 6c 20 72 t-reporter-xml r
9f90: 75 6e 2d 69 64 29 20 0a 20 20 20 20 20 28 63 6f un-id) . (co
9fa0: 6e 64 20 0a 20 20 20 20 20 20 20 28 28 61 6e 64 nd . ((and
9fb0: 20 61 6c 6c 2d 74 65 73 74 2d 6c 61 75 6e 63 68 all-test-launch
9fc0: 65 64 20 28 65 71 3f 20 6e 6f 74 2d 63 6f 6d 70 ed (eq? not-comp
9fd0: 6c 65 74 65 64 2d 63 6e 74 20 30 29 20 28 65 71 leted-cnt 0) (eq
9fe0: 75 61 6c 3f 20 61 6c 6c 2d 74 65 73 74 2d 6c 61 ual? all-test-la
9ff0: 75 6e 63 68 65 64 20 22 79 65 73 22 20 29 29 0a unched "yes" )).
a000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a010: 28 69 66 20 28 61 6e 64 20 28 65 71 75 61 6c 3f (if (and (equal?
a020: 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 28 63 (rmt:get-var (c
a030: 6f 6e 63 20 22 65 6e 64 2d 6f 66 2d 72 75 6e 2d onc "end-of-run-
a040: 22 20 72 75 6e 2d 69 64 29 29 20 22 6e 6f 22 29 " run-id)) "no")
a050: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
a060: 6c 6f 63 6b 20 28 63 6f 6e 63 20 22 65 6e 64 4f lock (conc "endO
a070: 66 52 75 6e 22 20 72 75 6e 2d 69 64 29 29 29 0a fRun" run-id))).
a080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a090: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
a0a0: 20 20 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .(debug:print
a0b0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
a0c0: 6f 72 74 2a 20 22 6c 6f 6f 6b 20 66 6f 72 20 20 ort* "look for
a0d0: 70 6f 73 74 20 68 6f 6f 6b 2e 20 63 75 72 72 73 post hook. currs
a0e0: 65 63 6f 6e 64 73 3a 20 22 20 28 63 75 72 72 65 econds: " (curre
a0f0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 22 20 45 4f nt-seconds) " EO
a100: 52 20 22 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 R " (rmt:get-var
a110: 20 28 63 6f 6e 63 20 22 65 6e 64 2d 6f 66 2d 72 (conc "end-of-r
a120: 75 6e 2d 22 20 72 75 6e 2d 69 64 29 29 29 0a 20 un-" run-id))).
a130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a140: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
a150: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
a160: 20 22 45 6e 64 20 6f 66 20 52 75 6e 20 44 65 74 "End of Run Det
a170: 65 63 74 65 64 2e 22 29 0a 20 20 20 20 20 20 20 ected.").
a180: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 73 65 (rmt:se
a190: 74 2d 76 61 72 20 28 63 6f 6e 63 20 22 65 6e 64 t-var (conc "end
a1a0: 2d 6f 66 2d 72 75 6e 2d 22 20 72 75 6e 2d 69 64 -of-run-" run-id
a1b0: 29 20 22 79 65 73 22 29 0a 20 20 20 20 20 20 20 ) "yes").
a1c0: 20 20 20 20 20 20 20 20 20 3b 28 74 68 72 65 61 ;(threa
a1d0: 64 2d 73 6c 65 65 70 21 20 31 30 29 0a 20 20 20 d-sleep! 10).
a1e0: 20 20 20 20 20 20 20 09 28 72 75 6e 73 3a 72 75 .(runs:ru
a1f0: 6e 2d 70 6f 73 74 2d 68 6f 6f 6b 20 72 75 6e 2d n-post-hook run-
a200: 69 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 id).
a210: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
a220: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
a230: 70 6f 72 74 2a 20 22 63 75 72 72 73 65 63 6f 6e port* "currsecon
a240: 64 73 3a 20 22 20 28 63 75 72 72 65 6e 74 2d 73 ds: " (current-s
a250: 65 63 6f 6e 64 73 29 22 20 65 6f 72 3a 20 22 20 econds)" eor: "
a260: 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 28 63 6f (rmt:get-var (co
a270: 6e 63 20 22 65 6e 64 2d 6f 66 2d 72 75 6e 2d 22 nc "end-of-run-"
a280: 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 20 run-id))).
a290: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d (comm
a2a0: 6f 6e 3a 73 69 6d 70 6c 65 2d 75 6e 6c 6f 63 6b on:simple-unlock
a2b0: 20 28 63 6f 6e 63 20 22 65 6e 64 4f 66 52 75 6e (conc "endOfRun
a2c0: 22 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 " run-id))).
a2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
a2e0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
a2f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a300: 45 6e 64 20 6f 66 20 52 75 6e 20 44 65 74 65 63 End of Run Detec
a310: 74 65 64 20 62 75 74 20 6e 6f 74 20 72 75 6e 6e ted but not runn
a320: 69 6e 67 20 70 6f 73 74 20 68 6f 6f 6b 2e 20 54 ing post hook. T
a330: 68 69 73 20 73 68 6f 75 6c 64 20 68 61 70 70 65 his should happe
a340: 6e 20 77 68 65 6e 20 65 6f 72 20 69 73 20 73 65 n when eor is se
a350: 74 20 74 6f 20 79 65 73 2e 20 54 68 69 73 20 77 t to yes. This w
a360: 69 6c 6c 20 68 61 70 70 65 6e 20 6f 6e 6c 79 20 ill happen only
a370: 77 68 65 6e 20 32 20 74 65 73 74 73 20 65 78 69 when 2 tests exi
a380: 74 20 61 74 20 73 6d 61 65 20 74 69 6d 65 2e 20 t at smae time.
a390: 65 6f 72 3d 20 22 20 28 72 6d 74 3a 67 65 74 2d eor= " (rmt:get-
a3a0: 76 61 72 20 28 63 6f 6e 63 20 22 65 6e 64 2d 6f var (conc "end-o
a3b0: 66 2d 72 75 6e 2d 22 20 72 75 6e 2d 69 64 29 29 f-run-" run-id))
a3c0: 29 29 29 0a 20 20 20 20 20 20 20 20 28 28 3e 20 ))). ((>
a3d0: 72 75 6e 6e 69 6e 67 2d 63 6e 74 20 33 29 20 0a running-cnt 3) .
a3e0: 20 20 20 20 20 20 20 20 09 20 20 28 64 65 62 75 . (debu
a3f0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
a400: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 68 lt-log-port* "Th
a410: 65 72 65 20 61 72 65 20 22 20 72 75 6e 6e 69 6e ere are " runnin
a420: 67 2d 63 6e 74 20 22 20 74 65 73 74 73 20 72 75 g-cnt " tests ru
a430: 6e 6e 69 6e 67 2e 22 20 29 29 0a 20 20 20 20 20 nning." )).
a440: 20 20 20 28 28 3e 20 72 75 6e 6e 69 6e 67 2d 63 ((> running-c
a450: 6e 74 20 30 29 0a 20 20 20 20 20 20 20 20 20 20 nt 0).
a460: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
a470: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
a480: 72 74 2a 20 22 72 75 6e 6e 69 6e 67 20 63 6e 74 rt* "running cnt
a490: 20 3e 20 30 20 62 75 74 20 3c 3d 20 33 20 6b 69 > 0 but <= 3 ki
a4a0: 6c 6c 2d 72 75 6e 6e 69 6e 67 2d 74 65 73 74 73 ll-running-tests
a4b0: 2d 69 66 2d 64 65 61 64 22 20 29 0a 20 20 20 09 -if-dead" ). .
a4c0: 09 09 09 20 20 28 6c 65 74 20 28 28 6b 69 6c 6c ... (let ((kill
a4d0: 2d 63 6e 74 20 28 6c 61 75 6e 63 68 3a 6b 69 6c -cnt (launch:kil
a4e0: 6c 2d 74 65 73 74 73 2d 69 66 2d 64 65 61 64 20 l-tests-if-dead
a4f0: 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 20 20 20 run-id))).
a500: 20 20 20 20 20 09 09 09 28 69 66 20 28 61 6e 64 ...(if (and
a510: 20 61 6c 6c 2d 74 65 73 74 2d 6c 61 75 6e 63 68 all-test-launch
a520: 65 64 20 20 28 65 71 75 61 6c 3f 20 61 6c 6c 2d ed (equal? all-
a530: 74 65 73 74 2d 6c 61 75 6e 63 68 65 64 20 22 79 test-launched "y
a540: 65 73 22 29 20 28 65 71 3f 20 6b 69 6c 6c 2d 63 es") (eq? kill-c
a550: 6e 74 20 72 75 6e 6e 69 6e 67 2d 63 6e 74 29 29 nt running-cnt))
a560: 0a 20 20 20 20 20 20 20 20 20 20 20 09 09 09 09 . ....
a570: 09 28 6c 61 75 6e 63 68 3a 65 6e 64 2d 6f 66 2d .(launch:end-of-
a580: 72 75 6e 2d 63 68 65 63 6b 20 72 75 6e 2d 69 64 run-check run-id
a590: 29 29 29 29 20 3b 3b 74 6f 64 6f 0a 20 20 20 20 )))) ;;todo.
a5a0: 20 20 20 20 28 65 6c 73 65 20 20 28 64 65 62 75 (else (debu
a5b0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
a5c0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 68 lt-log-port* "Sh
a5d0: 6f 75 6c 64 20 69 74 20 67 65 74 20 68 65 72 65 ould it get here
a5e0: 3f 3f 20 4d 61 79 20 62 65 20 65 76 65 72 79 74 ?? May be everyt
a5f0: 68 69 6e 67 20 69 73 20 6e 6f 74 20 6c 61 75 6e hing is not laun
a600: 63 68 65 64 20 79 65 74 2e 20 52 75 6e 6e 69 6e ched yet. Runnin
a610: 67 20 74 65 73 74 20 63 6e 74 3a 22 20 72 75 6e g test cnt:" run
a620: 6e 69 6e 67 2d 63 6e 74 20 22 20 4e 6f 74 20 63 ning-cnt " Not c
a630: 6f 6d 70 6c 65 74 65 64 20 74 65 73 74 20 63 6e ompleted test cn
a640: 74 3a 22 20 6e 6f 74 2d 63 6f 6d 70 6c 65 74 65 t:" not-complete
a650: 64 2d 63 6e 74 29 0a 20 20 20 20 20 20 20 20 20 d-cnt).
a660: 28 6c 65 74 2a 20 28 28 6e 6f 74 2d 63 6f 6d 70 (let* ((not-comp
a670: 6c 65 74 65 64 2d 74 65 73 74 73 20 28 72 6d 74 leted-tests (rmt
a680: 3a 67 65 74 2d 74 65 73 74 73 2d 66 6f 72 2d 72 :get-tests-for-r
a690: 75 6e 20 72 75 6e 2d 69 64 20 22 25 22 20 60 28 un run-id "%" `(
a6a0: 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 20 22 52 "NOT_STARTED" "R
a6b0: 55 4e 4e 49 4e 47 22 20 22 4c 41 55 4e 43 48 45 UNNING" "LAUNCHE
a6c0: 44 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 D" "REMOTEHOSTST
a6d0: 41 52 54 22 29 20 60 28 29 20 23 66 20 23 66 20 ART") `() #f #f
a6e0: 23 66 20 23 66 20 23 66 20 23 66 20 23 66 20 23 #f #f #f #f #f #
a6f0: 66 29 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 f))). (if
a700: 28 3e 20 28 6c 65 6e 67 74 68 20 6e 6f 74 2d 63 (> (length not-c
a710: 6f 6d 70 6c 65 74 65 64 2d 74 65 73 74 73 29 20 ompleted-tests)
a720: 30 29 20 0a 20 20 20 20 20 20 20 20 20 20 20 28 0) . (
a730: 6c 65 74 20 6c 6f 6f 70 20 28 28 72 75 6e 6e 69 let loop ((runni
a740: 6e 67 2d 74 65 73 74 20 28 63 61 72 20 6e 6f 74 ng-test (car not
a750: 2d 63 6f 6d 70 6c 65 74 65 64 2d 74 65 73 74 73 -completed-tests
a760: 29 29 0a 09 09 09 20 20 20 20 20 28 74 61 6c 20 )).... (tal
a770: 20 20 20 28 63 64 72 20 6e 6f 74 2d 63 6f 6d 70 (cdr not-comp
a780: 6c 65 74 65 64 2d 74 65 73 74 73 29 29 29 0a 09 leted-tests)))..
a790: 09 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
a7a0: 74 65 73 74 2d 6e 61 6d 65 20 28 76 65 63 74 6f test-name (vecto
a7b0: 72 2d 72 65 66 20 72 75 6e 6e 69 6e 67 2d 74 65 r-ref running-te
a7c0: 73 74 20 32 29 29 0a 20 20 20 20 20 20 20 20 20 st 2)).
a7d0: 20 20 20 20 20 20 20 20 28 69 74 65 6d 2d 70 61 (item-pa
a7e0: 74 68 20 28 76 65 63 74 6f 72 2d 72 65 66 20 72 th (vector-ref r
a7f0: 75 6e 6e 69 6e 67 2d 74 65 73 74 20 31 31 29 29 unning-test 11))
a800: 29 0a 09 09 09 20 20 20 20 20 20 20 09 28 64 65 ).... .(de
a810: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
a820: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a830: 74 65 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 test " test-name
a840: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 20 22 "/" item-path "
a850: 20 6e 6f 74 20 63 6f 6d 70 6c 65 74 65 64 22 29 not completed")
a860: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
a870: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
a880: 61 6c 29 29 0a 09 09 09 09 20 20 28 6c 6f 6f 70 al))..... (loop
a890: 20 28 63 61 72 20 74 61 6c 29 20 28 63 64 72 20 (car tal) (cdr
a8a0: 74 61 6c 29 29 29 29 29 29 29 29 29 29 29 20 20 tal)))))))))))
a8b0: 20 20 20 20 20 20 0a 20 0a 28 64 65 66 69 6e 65 . .(define
a8c0: 20 28 6c 61 75 6e 63 68 3a 69 73 2d 74 65 73 74 (launch:is-test
a8d0: 2d 61 6c 69 76 65 20 68 6f 73 74 20 70 69 64 29 -alive host pid)
a8e0: 0a 20 20 28 69 66 20 28 61 6e 64 20 68 6f 73 74 . (if (and host
a8f0: 20 70 69 64 20 28 6e 6f 74 20 28 65 71 75 61 6c pid (not (equal
a900: 3f 20 68 6f 73 74 20 22 6e 2f 61 22 29 29 29 0a ? host "n/a"))).
a910: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 69 73 (let* ((is
a920: 2d 6c 6f 63 61 6c 20 28 65 71 75 61 6c 3f 20 68 -local (equal? h
a930: 6f 73 74 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 ost (get-host-na
a940: 6d 65 29 29 29 0a 09 20 20 20 20 20 28 73 73 68 me))).. (ssh
a950: 2d 63 6d 64 20 20 20 28 69 66 20 69 73 2d 6c 6f -cmd (if is-lo
a960: 63 61 6c 20 22 20 22 20 28 63 6f 6e 63 20 22 73 cal " " (conc "s
a970: 73 68 20 22 20 68 6f 73 74 20 22 20 22 29 29 29 sh " host " ")))
a980: 0a 09 20 20 20 20 20 28 63 6d 64 20 28 63 6f 6e .. (cmd (con
a990: 63 20 73 73 68 2d 63 6d 64 20 22 70 73 74 72 65 c ssh-cmd "pstre
a9a0: 65 20 2d 41 20 22 20 70 69 64 29 29 0a 09 20 20 e -A " pid))..
a9b0: 20 20 20 28 6f 75 74 70 75 74 20 28 77 69 74 68 (output (with
a9c0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
a9d0: 20 63 6d 64 20 72 65 61 64 2d 6c 69 6e 65 73 29 cmd read-lines)
a9e0: 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ))..(debug:print
a9f0: 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 2 *default-log-
aa00: 70 6f 72 74 2a 20 22 52 75 6e 6e 69 6e 67 20 22 port* "Running "
aa10: 20 63 6d 64 20 22 20 72 65 63 65 69 76 65 64 20 cmd " received
aa20: 22 20 6f 75 74 70 75 74 29 0a 09 28 69 66 20 28 " output)..(if (
aa30: 65 71 3f 20 28 6c 65 6e 67 74 68 20 6f 75 74 70 eq? (length outp
aa40: 75 74 29 20 30 29 0a 09 20 20 20 23 66 0a 09 20 ut) 0).. #f..
aa50: 20 20 23 74 29 29 0a 20 20 20 20 20 20 23 74 29 #t)). #t)
aa60: 29 0a 20 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 ). .(define (lau
aa70: 6e 63 68 3a 6b 69 6c 6c 2d 74 65 73 74 73 2d 69 nch:kill-tests-i
aa80: 66 2d 64 65 61 64 20 72 75 6e 2d 69 64 29 0a 20 f-dead run-id).
aa90: 20 28 6c 65 74 2a 20 28 28 72 75 6e 6e 69 6e 67 (let* ((running
aaa0: 2d 74 65 73 74 73 20 28 72 6d 74 3a 67 65 74 2d -tests (rmt:get-
aab0: 74 65 73 74 73 2d 66 6f 72 2d 72 75 6e 20 72 75 tests-for-run ru
aac0: 6e 2d 69 64 20 22 25 22 20 60 28 22 52 55 4e 4e n-id "%" `("RUNN
aad0: 49 4e 47 22 20 22 4c 41 55 4e 43 48 45 44 22 20 ING" "LAUNCHED"
aae0: 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 "REMOTEHOSTSTART
aaf0: 22 29 20 60 28 29 20 23 66 20 23 66 20 23 66 20 ") `() #f #f #f
ab00: 23 66 20 23 66 20 23 66 20 23 66 20 23 66 29 29 #f #f #f #f #f))
ab10: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ). (let lo
ab20: 6f 70 20 28 28 72 75 6e 6e 69 6e 67 2d 74 65 73 op ((running-tes
ab30: 74 20 28 63 61 72 20 72 75 6e 6e 69 6e 67 2d 74 t (car running-t
ab40: 65 73 74 73 29 29 0a 09 09 09 20 20 20 20 20 28 ests)).... (
ab50: 74 61 6c 20 20 20 20 28 63 64 72 20 72 75 6e 6e tal (cdr runn
ab60: 69 6e 67 2d 74 65 73 74 73 29 29 0a 09 09 09 20 ing-tests))....
ab70: 20 20 20 20 28 6b 69 6c 6c 2d 63 6e 74 20 30 29 (kill-cnt 0)
ab80: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 74 2a )... (let*
ab90: 20 28 28 74 65 73 74 2d 6e 61 6d 65 20 28 76 65 ((test-name (ve
aba0: 63 74 6f 72 2d 72 65 66 20 72 75 6e 6e 69 6e 67 ctor-ref running
abb0: 2d 74 65 73 74 20 32 29 29 0a 20 20 20 20 20 20 -test 2)).
abc0: 20 20 20 20 20 20 20 20 20 20 20 28 69 74 65 6d (item
abd0: 2d 70 61 74 68 20 28 76 65 63 74 6f 72 2d 72 65 -path (vector-re
abe0: 66 20 72 75 6e 6e 69 6e 67 2d 74 65 73 74 20 31 f running-test 1
abf0: 31 29 29 0a 09 09 09 09 09 09 09 09 20 28 74 65 1))......... (te
ac00: 73 74 2d 69 64 20 28 76 65 63 74 6f 72 2d 72 65 st-id (vector-re
ac10: 66 20 72 75 6e 6e 69 6e 67 2d 74 65 73 74 20 30 f running-test 0
ac20: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ac30: 20 20 20 20 28 68 6f 73 74 20 28 76 65 63 74 6f (host (vecto
ac40: 72 2d 72 65 66 20 72 75 6e 6e 69 6e 67 2d 74 65 r-ref running-te
ac50: 73 74 20 36 29 29 0a 20 20 20 20 20 20 20 20 20 st 6)).
ac60: 20 20 20 20 20 20 20 20 28 70 69 64 20 20 28 72 (pid (r
ac70: 6d 74 3a 74 65 73 74 2d 67 65 74 2d 74 6f 70 2d mt:test-get-top-
ac80: 70 72 6f 63 65 73 73 2d 70 69 64 20 72 75 6e 2d process-pid run-
ac90: 69 64 20 74 65 73 74 2d 69 64 29 29 20 20 20 0a id test-id)) .
aca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
acb0: 20 28 65 76 65 6e 74 2d 74 69 6d 65 20 28 76 65 (event-time (ve
acc0: 63 74 6f 72 2d 72 65 66 20 72 75 6e 6e 69 6e 67 ctor-ref running
acd0: 2d 74 65 73 74 20 35 29 29 0a 20 20 20 20 20 20 -test 5)).
ace0: 20 20 20 20 20 20 20 20 20 20 20 28 64 75 72 61 (dura
acf0: 74 69 6f 6e 20 28 76 65 63 74 6f 72 2d 72 65 66 tion (vector-ref
ad00: 20 72 75 6e 6e 69 6e 67 2d 74 65 73 74 20 31 32 running-test 12
ad10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ad20: 20 20 20 20 28 66 6c 61 67 20 30 29 20 20 20 0a (flag 0) .
ad30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad40: 20 28 63 75 72 72 2d 74 69 6d 65 20 28 63 75 72 (curr-time (cur
ad50: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
ad60: 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 (if (and
ad70: 28 3c 20 28 2b 20 65 76 65 6e 74 2d 74 69 6d 65 (< (+ event-time
ad80: 20 64 75 72 61 74 69 6f 6e 20 36 30 30 29 20 63 duration 600) c
ad90: 75 72 72 2d 74 69 6d 65 29 20 28 6e 6f 74 20 28 urr-time) (not (
ada0: 6c 61 75 6e 63 68 3a 69 73 2d 74 65 73 74 2d 61 launch:is-test-a
adb0: 6c 69 76 65 20 68 6f 73 74 20 70 69 64 29 29 29 live host pid)))
adc0: 20 3b 3b 74 65 73 74 20 68 61 73 20 6e 6f 74 20 ;;test has not
add0: 75 70 64 61 74 65 64 20 64 75 72 61 74 69 6f 6e updated duration
ade0: 20 69 6e 20 6c 61 73 74 20 31 30 20 6d 69 6e 20 in last 10 min
adf0: 74 68 65 6e 20 6c 69 6b 65 6c 79 20 69 74 73 20 then likely its
ae00: 6e 6f 74 20 72 75 6e 6e 69 6e 67 20 62 75 74 20 not running but
ae10: 63 6f 6e 66 69 72 6d 20 62 65 66 6f 72 65 20 6d confirm before m
ae20: 61 72 6b 69 6e 67 20 69 74 20 61 73 20 6b 69 6c arking it as kil
ae30: 6c 65 64 0a 20 20 20 20 20 20 20 20 20 20 20 28 led. (
ae40: 62 65 67 69 6e 20 20 20 20 0a 09 09 09 20 20 20 begin ....
ae50: 20 20 20 20 09 28 64 65 62 75 67 3a 70 72 69 6e .(debug:prin
ae60: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
ae70: 2d 70 6f 72 74 2a 20 22 74 65 73 74 20 22 20 74 -port* "test " t
ae80: 65 73 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 est-name "/" ite
ae90: 6d 2d 70 61 74 68 20 22 20 6e 65 65 64 73 20 74 m-path " needs t
aea0: 6f 20 62 65 20 6b 69 6c 6c 65 64 22 29 0a 20 20 o be killed").
aeb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 (set
aec0: 21 20 66 6c 61 67 20 31 29 20 0a 20 20 20 20 20 ! flag 1) .
aed0: 20 20 20 20 20 20 20 20 20 28 72 6d 74 3a 73 65 (rmt:se
aee0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 t-state-status-a
aef0: 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 nd-roll-up-items
af00: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
af10: 65 20 69 74 65 6d 2d 70 61 74 68 20 22 4b 49 4c e item-path "KIL
af20: 4c 52 45 51 22 20 22 6e 2f 61 22 20 23 66 29 29 LREQ" "n/a" #f))
af30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
af40: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
af50: 20 74 61 6c 29 29 0a 09 09 09 09 20 20 28 6c 6f tal))..... (lo
af60: 6f 70 20 28 63 61 72 20 74 61 6c 29 20 28 63 64 op (car tal) (cd
af70: 72 20 74 61 6c 29 20 28 2b 20 6b 69 6c 6c 2d 63 r tal) (+ kill-c
af80: 6e 74 20 66 6c 61 67 29 29 0a 20 20 20 20 20 20 nt flag)).
af90: 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 6b 69 (+ ki
afa0: 6c 6c 2d 63 6e 74 20 66 6c 61 67 29 29 29 29 29 ll-cnt flag)))))
afb0: 29 0a 0a 3b 3b 20 44 4f 20 4e 4f 54 20 55 53 45 )..;; DO NOT USE
afc0: 20 2d 20 63 61 63 68 69 6e 67 20 6f 66 20 63 6f - caching of co
afd0: 6e 66 69 67 73 20 69 73 20 68 61 6e 64 6c 65 64 nfigs is handled
afe0: 20 69 6e 20 6c 61 75 6e 63 68 3a 73 65 74 75 70 in launch:setup
aff0: 20 6e 6f 77 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 now..;;.(define
b000: 20 28 6c 61 75 6e 63 68 3a 63 61 63 68 65 2d 63 (launch:cache-c
b010: 6f 6e 66 69 67 29 0a 20 20 3b 3b 20 69 66 20 77 onfig). ;; if w
b020: 65 20 68 61 76 65 20 61 20 6c 69 6e 6b 74 72 65 e have a linktre
b030: 65 20 61 6e 64 20 2d 72 75 6e 74 65 73 74 73 20 e and -runtests
b040: 61 6e 64 20 2d 74 61 72 67 65 74 20 61 6e 64 20 and -target and
b050: 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 65 78 the directory ex
b060: 69 73 74 73 20 64 75 6d 70 20 74 68 65 20 63 6f ists dump the co
b070: 6e 66 69 67 0a 20 20 3b 3b 20 74 6f 20 6d 65 67 nfig. ;; to meg
b080: 61 74 65 73 74 2d 28 63 75 72 72 65 6e 74 2d 73 atest-(current-s
b090: 65 63 6f 6e 64 73 29 2e 63 66 67 20 61 6e 64 20 econds).cfg and
b0a0: 73 79 6d 6c 69 6e 6b 20 69 74 20 74 6f 20 6d 65 symlink it to me
b0b0: 67 61 74 65 73 74 2e 63 66 67 0a 20 20 28 69 66 gatest.cfg. (if
b0c0: 20 28 61 6e 64 20 2a 63 6f 6e 66 69 67 64 61 74 (and *configdat
b0d0: 2a 20 0a 09 20 20 20 28 6f 72 20 28 61 72 67 73 * .. (or (args
b0e0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 22 29 :get-arg "-run")
b0f0: 0a 09 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 .. (args:g
b100: 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 et-arg "-runtest
b110: 73 22 29 0a 09 20 20 20 20 20 20 20 28 61 72 67 s").. (arg
b120: 73 3a 67 65 74 2d 61 72 67 20 22 2d 65 78 65 63 s:get-arg "-exec
b130: 75 74 65 22 29 29 29 0a 20 20 20 20 20 20 28 6c ute"))). (l
b140: 65 74 2a 20 28 28 6c 69 6e 6b 74 72 65 65 20 28 et* ((linktree (
b150: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 common:get-linkt
b160: 72 65 65 29 29 20 3b 3b 20 28 67 65 74 2d 65 6e ree)) ;; (get-en
b170: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
b180: 6c 65 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 le "MT_LINKTREE"
b190: 29 29 0a 09 20 20 20 20 20 28 74 61 72 67 65 74 )).. (target
b1a0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d (common:args-
b1b0: 67 65 74 2d 74 61 72 67 65 74 20 65 78 69 74 2d get-target exit-
b1c0: 69 66 2d 62 61 64 3a 20 23 74 29 29 0a 09 20 20 if-bad: #t))..
b1d0: 20 20 20 28 72 75 6e 6e 61 6d 65 20 20 28 6f 72 (runname (or
b1e0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
b1f0: 2d 72 75 6e 6e 61 6d 65 22 29 0a 09 09 09 20 20 -runname")....
b200: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
b210: 3a 72 75 6e 6e 61 6d 65 22 29 0a 09 09 09 20 20 :runname")....
b220: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e (getenv "MT_RUN
b230: 4e 41 4d 45 22 29 29 29 0a 09 20 20 20 20 20 28 NAME"))).. (
b240: 66 75 6c 6c 64 69 72 20 20 28 63 6f 6e 63 20 6c fulldir (conc l
b250: 69 6e 6b 74 72 65 65 20 22 2f 22 0a 09 09 09 20 inktree "/"....
b260: 20 20 20 20 74 61 72 67 65 74 20 22 2f 22 0a 09 target "/"..
b270: 09 09 20 20 20 20 20 72 75 6e 6e 61 6d 65 29 29 .. runname))
b280: 29 0a 09 28 69 66 20 28 61 6e 64 20 6c 69 6e 6b )..(if (and link
b290: 74 72 65 65 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c tree (common:fil
b2a0: 65 2d 65 78 69 73 74 73 3f 20 6c 69 6e 6b 74 72 e-exists? linktr
b2b0: 65 65 29 29 20 3b 3b 20 63 61 6e 27 74 20 70 72 ee)) ;; can't pr
b2c0: 6f 63 65 65 64 20 77 69 74 68 6f 75 74 20 6c 69 oceed without li
b2d0: 6e 6b 74 72 65 65 0a 09 20 20 20 20 28 62 65 67 nktree.. (beg
b2e0: 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 in.. (debug
b2f0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
b300: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
b310: 20 22 48 61 76 65 20 2d 72 75 6e 20 77 69 74 68 "Have -run with
b320: 20 74 61 72 67 65 74 3d 22 20 74 61 72 67 65 74 target=" target
b330: 20 22 2c 20 72 75 6e 6e 61 6d 65 3d 22 20 72 75 ", runname=" ru
b340: 6e 6e 61 6d 65 20 22 2c 20 66 75 6c 6c 64 69 72 nname ", fulldir
b350: 3d 22 20 66 75 6c 6c 64 69 72 20 22 2c 20 74 65 =" fulldir ", te
b360: 73 74 70 61 74 74 3d 22 20 28 6f 72 20 28 61 72 stpatt=" (or (ar
b370: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 gs:get-arg "-tes
b380: 74 70 61 74 74 22 29 20 22 25 22 29 29 0a 09 20 tpatt") "%"))..
b390: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 63 (if (not (c
b3a0: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
b3b0: 73 3f 20 66 75 6c 6c 64 69 72 29 29 0a 09 09 20 s? fulldir))...
b3c0: 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f (create-directo
b3d0: 72 79 20 66 75 6c 6c 64 69 72 20 23 74 29 29 20 ry fulldir #t))
b3e0: 3b 3b 20 6e 65 65 64 20 74 6f 20 70 72 6f 74 65 ;; need to prote
b3f0: 63 74 20 77 69 74 68 20 65 78 63 65 70 74 69 6f ct with exceptio
b400: 6e 20 68 61 6e 64 6c 65 72 20 0a 09 20 20 20 20 n handler ..
b410: 20 20 28 69 66 20 28 61 6e 64 20 74 61 72 67 65 (if (and targe
b420: 74 0a 09 09 20 20 20 20 20 20 20 72 75 6e 6e 61 t... runna
b430: 6d 65 0a 09 09 20 20 20 20 20 20 20 28 63 6f 6d me... (com
b440: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
b450: 20 66 75 6c 6c 64 69 72 29 29 0a 09 09 20 20 28 fulldir))... (
b460: 6c 65 74 20 28 28 74 6d 70 66 69 6c 65 20 20 28 let ((tmpfile (
b470: 63 6f 6e 63 20 66 75 6c 6c 64 69 72 20 22 2f 2e conc fulldir "/.
b480: 6d 65 67 61 74 65 73 74 2e 63 66 67 2e 22 20 28 megatest.cfg." (
b490: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
b4a0: 29 29 0a 09 09 09 28 74 61 72 67 66 69 6c 65 20 ))....(targfile
b4b0: 28 63 6f 6e 63 20 66 75 6c 6c 64 69 72 20 22 2f (conc fulldir "/
b4c0: 2e 6d 65 67 61 74 65 73 74 2e 63 66 67 2d 22 20 .megatest.cfg-"
b4d0: 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f megatest-versio
b4e0: 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 74 2d 66 n "-" megatest-f
b4f0: 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a 09 09 09 ossil-hash))....
b500: 28 72 63 6f 6e 66 69 67 20 20 28 63 6f 6e 63 20 (rconfig (conc
b510: 66 75 6c 6c 64 69 72 20 22 2f 2e 72 75 6e 63 6f fulldir "/.runco
b520: 6e 66 69 67 2e 22 20 6d 65 67 61 74 65 73 74 2d nfig." megatest-
b530: 76 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 version "-" mega
b540: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
b550: 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 28 63 )))... (if (c
b560: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
b570: 73 3f 20 72 63 6f 6e 66 69 67 29 20 3b 3b 20 6f s? rconfig) ;; o
b580: 6e 6c 79 20 63 61 63 68 65 20 6d 65 67 61 74 65 nly cache megate
b590: 73 74 2e 63 6f 6e 66 69 67 20 41 46 54 45 52 20 st.config AFTER
b5a0: 72 75 6e 63 6f 6e 66 69 67 73 20 68 61 73 20 62 runconfigs has b
b5b0: 65 65 6e 20 63 61 63 68 65 64 0a 09 09 09 28 62 een cached....(b
b5c0: 65 67 69 6e 0a 09 09 09 20 20 28 64 65 62 75 67 egin.... (debug
b5d0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
b5e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
b5f0: 20 22 43 61 63 68 69 6e 67 20 6d 65 67 61 74 65 "Caching megate
b600: 73 74 2e 63 6f 6e 66 69 67 20 69 6e 20 22 20 74 st.config in " t
b610: 6d 70 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 mpfile).
b620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b630: 20 20 28 69 66 20 28 6e 6f 74 20 28 63 6f 6d 6d (if (not (comm
b640: 6f 6e 3a 69 6e 2d 72 75 6e 6e 69 6e 67 2d 74 65 on:in-running-te
b650: 73 74 3f 29 29 0a 20 20 20 20 20 20 20 20 20 20 st?)).
b660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b670: 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 77 72 69 (configf:wri
b680: 74 65 2d 61 6c 69 73 74 20 2a 63 6f 6e 66 69 67 te-alist *config
b690: 64 61 74 2a 20 74 6d 70 66 69 6c 65 29 29 0a 09 dat* tmpfile))..
b6a0: 09 09 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e .. (system (con
b6b0: 63 20 22 6c 6e 20 2d 73 66 20 22 20 74 6d 70 66 c "ln -sf " tmpf
b6c0: 69 6c 65 20 22 20 22 20 74 61 72 67 66 69 6c 65 ile " " targfile
b6d0: 29 29 29 29 0a 09 09 20 20 20 20 29 29 29 0a 09 ))))... )))..
b6e0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
b6f0: 2d 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 -info 1 *default
b700: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 6f 20 6c -log-port* "No l
b710: 69 6e 6b 74 72 65 65 20 79 65 74 2c 20 6e 6f 20 inktree yet, no
b720: 63 61 63 68 69 6e 67 20 63 6f 6e 66 69 67 73 2e caching configs.
b730: 22 29 29 29 29 29 0a 0a 0a 3b 3b 20 67 61 74 68 ")))))...;; gath
b740: 65 72 20 61 76 61 69 6c 61 62 6c 65 20 69 6e 66 er available inf
b750: 6f 72 6d 61 74 69 6f 6e 2c 20 69 66 20 6c 65 67 ormation, if leg
b760: 69 74 20 72 65 61 64 20 63 6f 6e 66 69 67 73 20 it read configs
b770: 69 6e 20 74 68 69 73 20 6f 72 64 65 72 3a 0a 3b in this order:.;
b780: 3b 0a 3b 3b 20 20 20 69 66 20 68 61 76 65 20 63 ;.;; if have c
b790: 61 63 68 65 3b 0a 3b 3b 20 20 20 20 20 20 72 65 ache;.;; re
b7a0: 61 64 20 69 74 20 61 20 72 65 74 75 72 6e 20 69 ad it a return i
b7b0: 74 0a 3b 3b 20 20 20 65 6c 73 65 0a 3b 3b 20 20 t.;; else.;;
b7c0: 20 20 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 megatest.conf
b7d0: 69 67 20 20 20 20 20 28 64 6f 20 6e 6f 74 20 63 ig (do not c
b7e0: 61 63 68 65 29 0a 3b 3b 20 20 20 20 20 72 75 6e ache).;; run
b7f0: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 20 20 configs.config
b800: 20 28 63 61 63 68 65 20 69 66 20 61 6c 6c 20 76 (cache if all v
b810: 61 72 73 20 61 76 61 69 6c 29 0a 3b 3b 20 20 20 ars avail).;;
b820: 20 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 megatest.confi
b830: 67 20 20 20 20 20 28 63 61 63 68 65 20 69 66 20 g (cache if
b840: 61 6c 6c 20 76 61 72 73 20 61 76 61 69 6c 29 0a all vars avail).
b850: 3b 3b 20 20 20 72 65 74 75 72 6e 73 3a 0a 3b 3b ;; returns:.;;
b860: 20 20 20 20 20 2a 74 6f 70 70 61 74 68 2a 0a 3b *toppath*.;
b870: 3b 20 20 20 73 69 64 65 20 65 66 66 65 63 74 73 ; side effects
b880: 3a 0a 3b 3b 20 20 20 20 20 73 65 74 73 3b 20 2a :.;; sets; *
b890: 63 6f 6e 66 69 67 64 61 74 2a 20 20 20 20 28 6d configdat* (m
b8a0: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 69 egatest.config i
b8b0: 6e 66 6f 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 nfo).;;
b8c0: 20 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a *runconfigdat*
b8d0: 20 28 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e (runconfigs.con
b8e0: 66 69 67 20 69 6e 66 6f 29 0a 3b 3b 20 20 20 20 fig info).;;
b8f0: 20 20 20 20 20 20 20 2a 63 6f 6e 66 69 67 73 74 *configst
b900: 61 74 75 73 2a 20 28 73 74 61 74 75 73 20 6f 66 atus* (status of
b910: 20 74 68 65 20 72 65 61 64 20 64 61 74 61 29 0a the read data).
b920: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 6e ;;.(define (laun
b930: 63 68 3a 73 65 74 75 70 20 23 21 6b 65 79 20 28 ch:setup #!key (
b940: 66 6f 72 63 65 2d 72 65 72 65 61 64 20 23 66 29 force-reread #f)
b950: 20 28 61 72 65 61 70 61 74 68 20 23 66 29 29 0a (areapath #f)).
b960: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
b970: 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 74 launch-setup-mut
b980: 65 78 2a 29 0a 20 20 28 69 66 20 28 61 6e 64 20 ex*). (if (and
b990: 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 20 28 65 *toppath*.. (e
b9a0: 71 3f 20 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 q? *configstatus
b9b0: 2a 20 27 66 75 6c 6c 64 61 74 61 29 20 28 6e 6f * 'fulldata) (no
b9c0: 74 20 66 6f 72 63 65 2d 72 65 72 65 61 64 29 29 t force-reread))
b9d0: 20 3b 3b 20 67 6f 74 20 69 74 20 61 6c 6c 0a 20 ;; got it all.
b9e0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 (begin..(de
b9f0: 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 bug:print 2 *def
ba00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
ba10: 4e 4f 54 45 3a 20 73 6b 69 70 70 69 6e 67 20 6c NOTE: skipping l
ba20: 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 79 aunch:setup-body
ba30: 20 63 61 6c 6c 20 73 69 6e 63 65 20 77 65 20 68 call since we h
ba40: 61 76 65 20 66 75 6c 6c 64 61 74 61 22 29 0a 09 ave fulldata")..
ba50: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
ba60: 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 74 launch-setup-mut
ba70: 65 78 2a 29 0a 09 2a 74 6f 70 70 61 74 68 2a 29 ex*)..*toppath*)
ba80: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
ba90: 73 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d s (launch:setup-
baa0: 62 6f 64 79 20 66 6f 72 63 65 2d 72 65 72 65 61 body force-rerea
bab0: 64 3a 20 66 6f 72 63 65 2d 72 65 72 65 61 64 20 d: force-reread
bac0: 61 72 65 61 70 61 74 68 3a 20 61 72 65 61 70 61 areapath: areapa
bad0: 74 68 29 29 29 0a 09 28 6d 75 74 65 78 2d 75 6e th)))..(mutex-un
bae0: 6c 6f 63 6b 21 20 2a 6c 61 75 6e 63 68 2d 73 65 lock! *launch-se
baf0: 74 75 70 2d 6d 75 74 65 78 2a 29 0a 09 72 65 73 tup-mutex*)..res
bb00: 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 70 )))..;; return p
bb10: 61 74 68 73 20 64 65 70 65 6e 64 69 6e 67 20 6f aths depending o
bb20: 6e 20 77 68 61 74 20 69 6e 66 6f 20 69 73 20 61 n what info is a
bb30: 76 61 69 6c 61 62 6c 65 2e 0a 3b 3b 0a 28 64 65 vailable..;;.(de
bb40: 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 67 65 74 fine (launch:get
bb50: 2d 63 61 63 68 65 2d 66 69 6c 65 2d 70 61 74 68 -cache-file-path
bb60: 73 20 61 72 65 61 70 61 74 68 20 74 6f 70 70 61 s areapath toppa
bb70: 74 68 20 74 61 72 67 65 74 20 6d 74 63 6f 6e 66 th target mtconf
bb80: 69 67 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 73 ig). (let* ((us
bb90: 65 2d 63 61 63 68 65 20 28 63 6f 6d 6d 6f 6e 3a e-cache (common:
bba0: 75 73 65 2d 63 61 63 68 65 3f 29 29 0a 20 20 20 use-cache?)).
bbb0: 20 20 20 20 20 20 28 72 75 6e 6e 61 6d 65 20 20 (runname
bbc0: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
bbd0: 2d 72 75 6e 6e 61 6d 65 29 29 0a 20 20 20 20 20 -runname)).
bbe0: 20 20 20 20 28 6c 69 6e 6b 74 72 65 65 20 28 63 (linktree (c
bbf0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 ommon:get-linktr
bc00: 65 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 ee)). (t
bc10: 65 73 74 6e 61 6d 65 20 28 63 6f 6d 6d 6f 6e 3a estname (common:
bc20: 67 65 74 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e 61 get-full-test-na
bc30: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 me)). (r
bc40: 75 6e 64 69 72 20 20 20 28 69 66 20 28 61 6e 64 undir (if (and
bc50: 20 72 75 6e 6e 61 6d 65 20 74 61 72 67 65 74 20 runname target
bc60: 6c 69 6e 6b 74 72 65 65 29 0a 20 20 20 20 20 20 linktree).
bc70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bc80: 20 28 63 6f 6d 6d 6f 6e 3a 64 69 72 65 63 74 6f (common:directo
bc90: 72 79 2d 77 72 69 74 61 62 6c 65 3f 20 28 63 6f ry-writable? (co
bca0: 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 20 nc linktree "/"
bcb0: 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 6e 61 target "/" runna
bcc0: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 me)).
bcd0: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 29 #f))
bce0: 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 74 64 . (testd
bcf0: 69 72 20 20 28 69 66 20 28 61 6e 64 20 72 75 6e ir (if (and run
bd00: 64 69 72 20 74 65 73 74 6e 61 6d 65 29 0a 20 20 dir testname).
bd10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd20: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 64 69 72 (common:dir
bd30: 65 63 74 6f 72 79 2d 77 72 69 74 61 62 6c 65 3f ectory-writable?
bd40: 20 28 63 6f 6e 63 20 72 75 6e 64 69 72 20 22 2f (conc rundir "/
bd50: 22 20 74 65 73 74 6e 61 6d 65 29 29 0a 20 20 20 " testname)).
bd60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd70: 20 20 20 20 23 66 29 29 0a 20 20 20 20 20 20 20 #f)).
bd80: 20 20 28 63 61 63 68 65 64 69 72 20 28 6f 72 20 (cachedir (or
bd90: 74 65 73 74 64 69 72 20 72 75 6e 64 69 72 29 29 testdir rundir))
bda0: 0a 20 20 20 20 20 20 20 20 20 28 6d 74 63 61 63 . (mtcac
bdb0: 68 65 66 20 28 61 6e 64 20 63 61 63 68 65 64 69 hef (and cachedi
bdc0: 72 20 28 63 6f 6e 63 20 63 61 63 68 65 64 69 72 r (conc cachedir
bdd0: 20 22 2f 22 20 22 2e 6d 65 67 61 74 65 73 74 2e "/" ".megatest.
bde0: 63 66 67 2d 22 20 20 6d 65 67 61 74 65 73 74 2d cfg-" megatest-
bdf0: 76 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 version "-" mega
be00: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
be10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 63 ))). (rc
be20: 63 61 63 68 65 66 20 28 61 6e 64 20 63 61 63 68 cachef (and cach
be30: 65 64 69 72 20 28 63 6f 6e 63 20 63 61 63 68 65 edir (conc cache
be40: 64 69 72 20 22 2f 22 20 22 2e 72 75 6e 63 6f 6e dir "/" ".runcon
be50: 66 69 67 73 2e 63 66 67 2d 22 20 20 6d 65 67 61 figs.cfg-" mega
be60: 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 test-version "-"
be70: 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c megatest-fossil
be80: 2d 68 61 73 68 29 29 29 29 0a 20 20 20 20 28 64 -hash)))). (d
be90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
bea0: 36 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6 *default-log-p
beb0: 6f 72 74 2a 20 0a 20 20 20 20 20 20 20 20 20 20 ort* .
bec0: 20 20 20 20 20 20 20 20 20 20 20 20 22 72 75 6e "run
bed0: 6e 61 6d 65 3d 22 20 72 75 6e 6e 61 6d 65 20 0a name=" runname .
bee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bef0: 20 20 20 20 20 20 22 5c 6e 20 20 6c 69 6e 6b 74 "\n linkt
bf00: 72 65 65 3d 22 20 6c 69 6e 6b 74 72 65 65 0a 20 ree=" linktree.
bf10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf20: 20 20 20 20 20 22 5c 6e 20 20 74 65 73 74 6e 61 "\n testna
bf30: 6d 65 3d 22 20 74 65 73 74 6e 61 6d 65 0a 20 20 me=" testname.
bf40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf50: 20 20 20 20 22 5c 6e 20 20 72 75 6e 64 69 72 3d "\n rundir=
bf60: 22 20 72 75 6e 64 69 72 20 0a 20 20 20 20 20 20 " rundir .
bf70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bf80: 22 5c 6e 20 20 74 65 73 74 64 69 72 3d 22 20 74 "\n testdir=" t
bf90: 65 73 74 64 69 72 20 0a 20 20 20 20 20 20 20 20 estdir .
bfa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 5c "\
bfb0: 6e 20 20 63 61 63 68 65 64 69 72 3d 22 20 63 61 n cachedir=" ca
bfc0: 63 68 65 64 69 72 0a 20 20 20 20 20 20 20 20 20 chedir.
bfd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 5c 6e "\n
bfe0: 20 20 6d 74 63 61 63 68 65 66 3d 22 20 6d 74 63 mtcachef=" mtc
bff0: 61 63 68 65 66 0a 20 20 20 20 20 20 20 20 20 20 achef.
c000: 20 20 20 20 20 20 20 20 20 20 20 20 22 5c 6e 20 "\n
c010: 20 72 63 63 61 63 68 65 66 3d 22 20 72 63 63 61 rccachef=" rcca
c020: 63 68 65 66 29 0a 20 20 20 20 28 63 6f 6e 73 20 chef). (cons
c030: 6d 74 63 61 63 68 65 66 20 72 63 63 61 63 68 65 mtcachef rccache
c040: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 6c f)))..(define (l
c050: 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 79 aunch:setup-body
c060: 20 23 21 6b 65 79 20 28 66 6f 72 63 65 2d 72 65 #!key (force-re
c070: 72 65 61 64 20 23 66 29 20 28 61 72 65 61 70 61 read #f) (areapa
c080: 74 68 20 23 66 29 29 0a 20 20 28 69 66 20 28 61 th #f)). (if (a
c090: 6e 64 20 28 65 71 3f 20 2a 63 6f 6e 66 69 67 73 nd (eq? *configs
c0a0: 74 61 74 75 73 2a 20 27 66 75 6c 6c 64 61 74 61 tatus* 'fulldata
c0b0: 29 0a 09 20 20 20 2a 74 6f 70 70 61 74 68 2a 0a ).. *toppath*.
c0c0: 09 20 20 20 28 6e 6f 74 20 66 6f 72 63 65 2d 72 . (not force-r
c0d0: 65 72 65 61 64 29 29 20 3b 3b 20 6e 6f 20 6e 65 eread)) ;; no ne
c0e0: 65 64 20 74 6f 20 72 65 70 72 6f 63 65 73 73 0a ed to reprocess.
c0f0: 20 20 20 20 20 20 2a 74 6f 70 70 61 74 68 2a 20 *toppath*
c100: 20 20 3b 3b 20 72 65 74 75 72 6e 20 74 6f 70 70 ;; return topp
c110: 61 74 68 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 ath. (let*
c120: 28 28 75 73 65 2d 63 61 63 68 65 20 28 63 6f 6d ((use-cache (com
c130: 6d 6f 6e 3a 75 73 65 2d 63 61 63 68 65 3f 29 29 mon:use-cache?))
c140: 20 3b 3b 20 42 42 2d 20 75 73 65 2d 63 61 63 68 ;; BB- use-cach
c150: 65 20 63 68 65 63 6b 73 20 2a 63 6f 6e 66 69 67 e checks *config
c160: 64 61 74 2a 20 66 6f 72 20 75 73 65 2d 63 61 63 dat* for use-cac
c170: 68 65 20 73 65 74 74 69 6e 67 2e 20 20 57 65 20 he setting. We
c180: 64 6f 20 6e 6f 74 20 68 61 76 65 20 2a 63 6f 6e do not have *con
c190: 66 69 67 64 61 74 2a 2e 20 20 42 6f 6f 74 73 74 figdat*. Bootst
c1a0: 72 61 70 70 69 6e 67 20 70 72 6f 62 6c 65 6d 20 rapping problem
c1b0: 68 65 72 65 2e 0a 09 20 20 20 20 20 28 74 6f 70 here... (top
c1c0: 70 61 74 68 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 path (common:ge
c1d0: 74 2d 74 6f 70 70 61 74 68 20 61 72 65 61 70 61 t-toppath areapa
c1e0: 74 68 29 29 0a 09 20 20 20 20 20 28 74 61 72 67 th)).. (targ
c1f0: 65 74 20 20 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 et (common:arg
c200: 73 2d 67 65 74 2d 74 61 72 67 65 74 29 29 0a 09 s-get-target))..
c210: 20 20 20 20 20 28 73 65 63 74 69 6f 6e 73 20 28 (sections (
c220: 69 66 20 74 61 72 67 65 74 20 28 6c 69 73 74 20 if target (list
c230: 22 64 65 66 61 75 6c 74 22 20 74 61 72 67 65 74 "default" target
c240: 29 20 23 66 29 29 20 3b 3b 20 66 6f 72 20 72 75 ) #f)) ;; for ru
c250: 6e 63 6f 6e 66 69 67 73 0a 09 20 20 20 20 20 28 nconfigs.. (
c260: 6d 74 63 6f 6e 66 69 67 20 28 6f 72 20 28 61 72 mtconfig (or (ar
c270: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 63 6f 6e gs:get-arg "-con
c280: 66 69 67 22 29 20 22 6d 65 67 61 74 65 73 74 2e fig") "megatest.
c290: 63 6f 6e 66 69 67 22 29 29 20 3b 3b 20 61 6c 6c config")) ;; all
c2a0: 6f 77 20 6f 76 65 72 72 69 64 69 6e 67 20 6d 65 ow overriding me
c2b0: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 0a 20 gatest.config .
c2c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 63 (cac
c2d0: 68 65 66 69 6c 65 73 20 28 6c 61 75 6e 63 68 3a hefiles (launch:
c2e0: 67 65 74 2d 63 61 63 68 65 2d 66 69 6c 65 2d 70 get-cache-file-p
c2f0: 61 74 68 73 20 61 72 65 61 70 61 74 68 20 74 6f aths areapath to
c300: 70 70 61 74 68 20 74 61 72 67 65 74 20 6d 74 63 ppath target mtc
c310: 6f 6e 66 69 67 29 29 0a 09 20 20 20 20 20 3b 3b onfig)).. ;;
c320: 20 63 68 65 63 6b 69 6e 67 20 66 6f 72 20 6e 75 checking for nu
c330: 6c 6c 20 63 61 63 68 65 66 69 6c 65 73 20 73 68 ll cachefiles sh
c340: 6f 75 6c 64 20 6e 6f 74 20 62 65 20 6e 65 63 65 ould not be nece
c350: 73 73 61 72 79 2c 20 49 20 77 61 73 20 73 65 65 ssary, I was see
c360: 69 6e 67 20 65 72 72 6f 72 20 63 61 72 20 6f 66 ing error car of
c370: 20 27 28 29 2c 20 6d 69 67 68 74 20 62 65 20 61 '(), might be a
c380: 20 63 68 69 63 6b 65 6e 20 62 75 67 20 6f 72 20 chicken bug or
c390: 61 20 72 65 64 20 68 65 72 72 69 6e 67 20 2e 2e a red herring ..
c3a0: 2e 0a 09 20 20 20 20 20 28 6d 74 63 61 63 68 65 ... (mtcache
c3b0: 66 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 f (if (null? c
c3c0: 61 63 68 65 66 69 6c 65 73 29 0a 09 09 09 20 20 achefiles)....
c3d0: 20 20 20 23 66 0a 09 09 09 20 20 20 20 20 28 63 #f.... (c
c3e0: 61 72 20 63 61 63 68 65 66 69 6c 65 73 29 29 29 ar cachefiles)))
c3f0: 20 3b 3b 20 28 61 6e 64 20 63 61 63 68 65 64 69 ;; (and cachedi
c400: 72 20 28 63 6f 6e 63 20 63 61 63 68 65 64 69 72 r (conc cachedir
c410: 20 22 2f 22 20 22 2e 6d 65 67 61 74 65 73 74 2e "/" ".megatest.
c420: 63 66 67 2d 22 20 20 6d 65 67 61 74 65 73 74 2d cfg-" megatest-
c430: 76 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 version "-" mega
c440: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
c450: 29 29 29 0a 09 20 20 20 20 20 28 72 63 63 61 63 ))).. (rccac
c460: 68 65 66 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f hef (if (null?
c470: 20 63 61 63 68 65 66 69 6c 65 73 29 0a 09 09 09 cachefiles)....
c480: 20 20 20 20 20 23 66 0a 09 09 09 20 20 20 20 20 #f....
c490: 28 63 64 72 20 63 61 63 68 65 66 69 6c 65 73 29 (cdr cachefiles)
c4a0: 29 29 29 20 3b 3b 20 28 61 6e 64 20 63 61 63 68 ))) ;; (and cach
c4b0: 65 64 69 72 20 28 63 6f 6e 63 20 63 61 63 68 65 edir (conc cache
c4c0: 64 69 72 20 22 2f 22 20 22 2e 72 75 6e 63 6f 6e dir "/" ".runcon
c4d0: 66 69 67 73 2e 63 66 67 2d 22 20 20 6d 65 67 61 figs.cfg-" mega
c4e0: 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 test-version "-"
c4f0: 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c megatest-fossil
c500: 2d 68 61 73 68 29 29 29 0a 09 20 20 20 20 20 20 -hash)))..
c510: 3b 3b 20 28 63 61 6e 63 72 65 61 74 65 20 28 61 ;; (cancreate (a
c520: 6e 64 20 63 61 63 68 65 64 69 72 20 28 63 6f 6d nd cachedir (com
c530: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
c540: 20 63 61 63 68 65 64 69 72 29 28 66 69 6c 65 2d cachedir)(file-
c550: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 63 61 write-access? ca
c560: 63 68 65 64 69 72 29 20 28 6e 6f 74 20 28 63 6f chedir) (not (co
c570: 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e 6e 69 6e 67 2d mmon:in-running-
c580: 74 65 73 74 3f 29 29 29 29 29 0a 09 28 73 65 74 test?)))))..(set
c590: 21 20 2a 74 6f 70 70 61 74 68 2a 20 74 6f 70 70 ! *toppath* topp
c5a0: 61 74 68 29 20 3b 3b 20 54 68 69 73 20 69 73 20 ath) ;; This is
c5b0: 6e 65 65 64 65 64 20 77 68 65 6e 20 77 65 20 61 needed when we a
c5c0: 72 65 20 72 75 6e 6e 69 6e 67 20 61 73 20 61 20 re running as a
c5d0: 74 65 73 74 20 75 73 69 6e 67 20 43 4d 44 49 4e test using CMDIN
c5e0: 46 4f 20 61 73 20 61 20 64 61 74 61 73 6f 75 72 FO as a datasour
c5f0: 63 65 0a 20 20 20 20 20 20 20 20 3b 3b 28 42 42 ce. ;;(BB
c600: 3e 20 22 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d > "launch:setup-
c610: 62 6f 64 79 20 2d 2d 20 63 61 63 68 65 66 69 6c body -- cachefil
c620: 65 73 3d 22 63 61 63 68 65 66 69 6c 65 73 29 0a es="cachefiles).
c630: 09 28 63 6f 6e 64 0a 09 20 3b 3b 20 69 66 20 6d .(cond.. ;; if m
c640: 74 63 61 63 68 65 66 20 65 78 69 73 74 73 20 6a tcachef exists j
c650: 75 73 74 20 72 65 61 64 20 69 74 2c 20 68 6f 77 ust read it, how
c660: 65 76 65 72 20 77 65 20 6e 65 65 64 20 74 6f 20 ever we need to
c670: 61 73 73 75 6d 65 20 74 6f 70 70 61 74 68 20 69 assume toppath i
c680: 73 20 61 76 61 69 6c 61 62 6c 65 20 69 6e 20 24 s available in $
c690: 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 MT_RUN_AREA_HOME
c6a0: 0a 09 20 28 28 61 6e 64 20 28 6e 6f 74 20 66 6f .. ((and (not fo
c6b0: 72 63 65 2d 72 65 72 65 61 64 29 0a 09 20 20 20 rce-reread)..
c6c0: 20 20 20 20 6d 74 63 61 63 68 65 66 20 20 72 63 mtcachef rc
c6d0: 63 61 63 68 65 66 0a 09 20 20 20 20 20 20 20 75 cachef.. u
c6e0: 73 65 2d 63 61 63 68 65 0a 09 20 20 20 20 20 20 se-cache..
c6f0: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
c700: 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 t-variable "MT_R
c710: 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 0a 09 UN_AREA_HOME")..
c720: 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 (common:f
c730: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 63 61 ile-exists? mtca
c740: 63 68 65 66 29 0a 09 20 20 20 20 20 20 20 28 63 chef).. (c
c750: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
c760: 73 3f 20 72 63 63 61 63 68 65 66 29 29 0a 20 20 s? rccachef)).
c770: 20 20 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 ;;(BB> "
c780: 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 launch:setup-bod
c790: 79 20 2d 2d 20 63 6f 6e 64 20 62 72 61 6e 63 68 y -- cond branch
c7a0: 20 31 20 2d 20 75 73 65 2d 63 61 63 68 65 22 29 1 - use-cache")
c7b0: 0a 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 . (set!
c7c0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 20 20 20 *configdat*
c7d0: 28 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c (configf:read-al
c7e0: 69 73 74 20 6d 74 63 61 63 68 65 66 29 29 0a 20 ist mtcachef)).
c7f0: 20 20 20 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 ;;(BB>
c800: 22 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f "launch:setup-bo
c810: 64 79 20 2d 2d 20 31 20 73 65 74 21 20 2a 63 6f dy -- 1 set! *co
c820: 6e 66 69 67 64 61 74 2a 3d 22 2a 63 6f 6e 66 69 nfigdat*="*confi
c830: 67 64 61 74 2a 29 0a 09 20 20 28 73 65 74 21 20 gdat*).. (set!
c840: 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 28 *runconfigdat* (
c850: 63 6f 6e 66 69 67 66 3a 72 65 61 64 2d 61 6c 69 configf:read-ali
c860: 73 74 20 72 63 63 61 63 68 65 66 29 29 0a 09 20 st rccachef))..
c870: 20 28 73 65 74 21 20 2a 63 6f 6e 66 69 67 69 6e (set! *configin
c880: 66 6f 2a 20 20 20 28 6c 69 73 74 20 2a 63 6f 6e fo* (list *con
c890: 66 69 67 64 61 74 2a 20 20 28 67 65 74 2d 65 6e figdat* (get-en
c8a0: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
c8b0: 6c 65 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f le "MT_RUN_AREA_
c8c0: 48 4f 4d 45 22 29 29 29 0a 09 20 20 28 73 65 74 HOME"))).. (set
c8d0: 21 20 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a ! *configstatus*
c8e0: 20 27 66 75 6c 6c 64 61 74 61 29 0a 09 20 20 28 'fulldata).. (
c8f0: 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 20 set! *toppath*
c900: 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (get-environ
c910: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
c920: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
c930: 29 29 0a 09 20 20 2a 74 6f 70 70 61 74 68 2a 29 )).. *toppath*)
c940: 0a 09 20 3b 3b 20 74 68 65 72 65 20 61 72 65 20 .. ;; there are
c950: 6e 6f 20 65 78 69 73 74 69 6e 67 20 63 61 63 68 no existing cach
c960: 65 64 20 63 6f 6e 66 69 67 73 2c 20 64 6f 20 66 ed configs, do f
c970: 75 6c 6c 20 72 65 61 64 73 20 6f 66 20 74 68 65 ull reads of the
c980: 20 63 6f 6e 66 69 67 73 20 61 6e 64 20 63 61 63 configs and cac
c990: 68 65 20 74 68 65 6d 0a 09 20 3b 3b 20 77 65 20 he them.. ;; we
c9a0: 68 61 76 65 20 61 6c 6c 20 74 68 65 20 69 6e 66 have all the inf
c9b0: 6f 20 6e 65 65 64 65 64 20 74 6f 20 66 75 6c 6c o needed to full
c9c0: 79 20 70 72 6f 63 65 73 73 20 72 75 6e 63 6f 6e y process runcon
c9d0: 66 69 67 73 20 61 6e 64 20 6d 65 67 61 74 65 73 figs and megates
c9e0: 74 2e 63 6f 6e 66 69 67 0a 09 20 28 28 61 6e 64 t.config.. ((and
c9f0: 20 3b 3b 20 28 6e 6f 74 20 66 6f 72 63 65 2d 72 ;; (not force-r
ca00: 65 72 65 61 64 29 20 3b 3b 20 66 6f 72 63 65 2d eread) ;; force-
ca10: 72 65 72 65 61 64 20 69 73 20 69 72 72 65 6c 65 reread is irrele
ca20: 76 61 6e 74 20 69 6e 20 74 68 65 20 41 4e 44 2c vant in the AND,
ca30: 20 63 6f 75 6c 64 20 68 6f 77 65 76 65 72 20 4f could however O
ca40: 52 20 69 74 3f 0a 09 20 20 20 20 20 20 20 6d 74 R it?.. mt
ca50: 63 61 63 68 65 66 0a 09 20 20 20 20 20 20 20 72 cachef.. r
ca60: 63 63 61 63 68 65 66 29 20 3b 3b 20 42 42 2d 20 ccachef) ;; BB-
ca70: 77 68 79 20 61 72 65 20 77 65 20 64 6f 69 6e 67 why are we doing
ca80: 20 74 68 69 73 20 77 69 74 68 6f 75 74 20 61 73 this without as
ca90: 6b 69 6e 67 20 69 66 20 63 61 63 68 69 6e 67 20 king if caching
caa0: 69 73 20 64 65 73 69 72 65 64 3f 0a 20 20 20 20 is desired?.
cab0: 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 6c 61 ;;(BB> "la
cac0: 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 79 20 unch:setup-body
cad0: 2d 2d 20 63 6f 6e 64 20 62 72 61 6e 63 68 20 32 -- cond branch 2
cae0: 22 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 66 69 ").. (let* ((fi
caf0: 72 73 74 2d 70 61 73 73 20 20 20 20 28 66 69 6e rst-pass (fin
cb00: 64 2d 61 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 d-and-read-confi
cb10: 67 20 20 20 20 20 20 20 20 3b 3b 20 4e 42 2f 2f g ;; NB//
cb20: 20 73 65 74 73 20 4d 54 5f 52 55 4e 5f 41 52 45 sets MT_RUN_ARE
cb30: 41 5f 48 4f 4d 45 20 61 73 20 73 69 64 65 20 65 A_HOME as side e
cb40: 66 66 65 63 74 0a 09 09 09 09 20 6d 74 63 6f 6e ffect..... mtcon
cb50: 66 69 67 0a 09 09 09 09 20 65 6e 76 69 72 6f 6e fig..... environ
cb60: 2d 70 61 74 74 3a 20 22 65 6e 76 2d 6f 76 65 72 -patt: "env-over
cb70: 72 69 64 65 22 0a 09 09 09 09 20 67 69 76 65 6e ride"..... given
cb80: 2d 74 6f 70 70 61 74 68 3a 20 74 6f 70 70 61 74 -toppath: toppat
cb90: 68 0a 09 09 09 09 20 70 61 74 68 65 6e 76 76 61 h..... pathenvva
cba0: 72 3a 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f r: "MT_RUN_AREA_
cbb0: 48 4f 4d 45 22 29 29 0a 09 09 20 28 66 69 72 73 HOME"))... (firs
cbc0: 74 2d 72 75 6e 64 61 74 20 20 28 6c 65 74 20 28 t-rundat (let (
cbd0: 28 74 6f 70 70 61 74 68 20 28 69 66 20 74 6f 70 (toppath (if top
cbe0: 70 61 74 68 20 0a 09 09 09 09 09 09 20 20 20 74 path ....... t
cbf0: 6f 70 70 61 74 68 0a 09 09 09 09 09 09 20 20 20 oppath.......
cc00: 28 63 61 72 20 66 69 72 73 74 2d 70 61 73 73 29 (car first-pass)
cc10: 29 29 29 0a 09 09 09 09 20 20 28 72 65 61 64 2d )))..... (read-
cc20: 63 6f 6e 66 69 67 20 3b 3b 20 28 63 6f 6e 63 20 config ;; (conc
cc30: 74 6f 70 70 61 74 68 20 22 2f 72 75 6e 63 6f 6e toppath "/runcon
cc40: 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 20 3b 3b figs.config") ;;
cc50: 20 74 68 69 73 20 73 68 6f 75 6c 64 20 62 65 20 this should be
cc60: 63 6f 6e 76 65 72 74 65 64 20 74 6f 20 72 75 6e converted to run
cc70: 63 6f 6e 66 69 67 3a 72 65 61 64 20 62 75 74 20 config:read but
cc80: 69 74 20 69 73 20 6e 6f 6e 2d 74 72 69 76 69 61 it is non-trivia
cc90: 6c 2c 20 6c 65 61 76 69 6e 67 20 69 74 20 66 6f l, leaving it fo
cca0: 72 20 6e 6f 77 2e 0a 09 09 09 09 20 20 20 28 63 r now...... (c
ccb0: 6f 6e 63 20 28 69 66 20 28 73 74 72 69 6e 67 3f onc (if (string?
ccc0: 20 74 6f 70 70 61 74 68 29 0a 09 09 09 09 09 20 toppath)......
ccd0: 20 20 20 20 74 6f 70 70 61 74 68 0a 09 09 09 09 toppath.....
cce0: 09 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 . (get-envir
ccf0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
cd00: 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d "MT_RUN_AREA_HOM
cd10: 45 22 29 29 0a 09 09 09 09 09 20 22 2f 72 75 6e E"))...... "/run
cd20: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
cd30: 0a 09 09 09 09 20 20 20 2a 72 75 6e 63 6f 6e 66 ..... *runconf
cd40: 69 67 64 61 74 2a 20 23 74 20 0a 09 09 09 09 20 igdat* #t .....
cd50: 20 20 73 65 63 74 69 6f 6e 73 3a 20 73 65 63 74 sections: sect
cd60: 69 6f 6e 73 29 29 29 29 0a 09 20 20 20 20 28 73 ions)))).. (s
cd70: 65 74 21 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 et! *runconfigda
cd80: 74 2a 20 66 69 72 73 74 2d 72 75 6e 64 61 74 29 t* first-rundat)
cd90: 0a 09 20 20 20 20 28 69 66 20 66 69 72 73 74 2d .. (if first-
cda0: 70 61 73 73 20 20 3b 3b 20 0a 09 09 28 62 65 67 pass ;; ...(beg
cdb0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
cdc0: 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 6c 61 75 ;;(BB> "lau
cdd0: 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 79 20 2d nch:setup-body -
cde0: 2d 20 5c 22 66 69 72 73 74 2d 70 61 73 73 5c 22 - \"first-pass\"
cdf0: 3d 66 69 72 73 74 2d 70 61 73 73 22 29 0a 09 09 =first-pass")...
ce00: 20 20 28 73 65 74 21 20 2a 63 6f 6e 66 69 67 64 (set! *configd
ce10: 61 74 2a 20 20 28 63 61 72 20 66 69 72 73 74 2d at* (car first-
ce20: 70 61 73 73 29 29 0a 20 20 20 20 20 20 20 20 20 pass)).
ce30: 20 20 20 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 ;;(BB>
ce40: 22 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f "launch:setup-bo
ce50: 64 79 20 2d 2d 20 32 20 73 65 74 21 20 2a 63 6f dy -- 2 set! *co
ce60: 6e 66 69 67 64 61 74 2a 3d 22 2a 63 6f 6e 66 69 nfigdat*="*confi
ce70: 67 64 61 74 2a 29 0a 09 09 20 20 28 73 65 74 21 gdat*)... (set!
ce80: 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 20 66 69 *configinfo* fi
ce90: 72 73 74 2d 70 61 73 73 29 0a 09 09 20 20 28 73 rst-pass)... (s
cea0: 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 20 20 et! *toppath*
ceb0: 20 28 6f 72 20 74 6f 70 70 61 74 68 20 28 63 61 (or toppath (ca
cec0: 64 72 20 66 69 72 73 74 2d 70 61 73 73 29 29 29 dr first-pass)))
ced0: 20 3b 3b 20 75 73 65 20 74 68 65 20 67 61 74 68 ;; use the gath
cee0: 65 72 65 64 20 64 61 74 61 20 75 6e 6c 65 73 73 ered data unless
cef0: 20 61 6c 72 65 61 64 79 20 68 61 76 65 20 69 74 already have it
cf00: 0a 09 09 20 20 28 73 65 74 21 20 74 6f 70 70 61 ... (set! toppa
cf10: 74 68 20 20 20 20 20 20 2a 74 6f 70 70 61 74 68 th *toppath
cf20: 2a 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 *)... (if (not
cf30: 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 20 20 20 *toppath*)...
cf40: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 65 (begin....(de
cf50: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
cf60: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
cf70: 6f 72 74 2a 20 22 79 6f 75 20 61 72 65 20 6e 6f ort* "you are no
cf80: 74 20 69 6e 20 61 20 6d 65 67 61 74 65 73 74 20 t in a megatest
cf90: 61 72 65 61 21 22 29 0a 09 09 09 28 65 78 69 74 area!")....(exit
cfa0: 20 31 29 29 29 0a 09 09 20 20 28 73 65 74 65 6e 1)))... (seten
cfb0: 76 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 v "MT_RUN_AREA_H
cfc0: 4f 4d 45 22 20 2a 74 6f 70 70 61 74 68 2a 29 0a OME" *toppath*).
cfd0: 09 09 20 20 3b 3b 20 74 68 65 20 73 65 65 64 20 .. ;; the seed
cfe0: 72 65 61 64 20 69 73 20 64 6f 6e 65 2c 20 6e 6f read is done, no
cff0: 77 20 72 65 61 64 20 72 75 6e 63 6f 6e 66 69 67 w read runconfig
d000: 73 2c 20 63 61 63 68 65 20 69 74 20 74 68 65 6e s, cache it then
d010: 20 72 65 61 64 20 6d 65 67 61 74 65 73 74 2e 63 read megatest.c
d020: 6f 6e 66 69 67 20 6f 6e 65 20 6d 6f 72 65 20 74 onfig one more t
d030: 69 6d 65 20 61 6e 64 20 63 61 63 68 65 20 69 74 ime and cache it
d040: 0a 09 09 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 ... (let* ((key
d050: 73 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f s (commo
d060: 6e 3a 6c 69 73 74 2d 6f 72 2d 6e 75 6c 6c 20 28 n:list-or-null (
d070: 72 6d 74 3a 67 65 74 2d 6b 65 79 73 29 0a 09 09 rmt:get-keys)...
d080: 09 09 09 09 09 20 20 20 20 6d 65 73 73 61 67 65 ..... message
d090: 3a 20 22 46 61 69 6c 65 64 20 74 6f 20 72 65 74 : "Failed to ret
d0a0: 72 69 65 76 65 20 6b 65 79 73 20 69 6e 20 6c 61 rieve keys in la
d0b0: 75 6e 63 68 2e 73 63 6d 2e 20 50 6c 65 61 73 65 unch.scm. Please
d0c0: 20 72 65 70 6f 72 74 20 74 68 69 73 20 74 6f 20 report this to
d0d0: 74 68 65 20 64 65 76 65 6c 6f 70 65 72 73 2e 22 the developers."
d0e0: 29 29 0a 09 09 09 20 28 6b 65 79 2d 76 61 6c 73 )).... (key-vals
d0f0: 20 20 20 20 20 28 6b 65 79 73 3a 74 61 72 67 65 (keys:targe
d100: 74 2d 3e 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 t->keyval keys t
d110: 61 72 67 65 74 29 29 0a 09 09 09 20 28 6c 69 6e arget)).... (lin
d120: 6b 74 72 65 65 20 20 20 20 20 28 63 6f 6d 6d 6f ktree (commo
d130: 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 n:get-linktree))
d140: 20 3b 3b 20 28 6f 72 20 28 67 65 74 65 6e 76 20 ;; (or (getenv
d150: 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 28 69 "MT_LINKTREE")(i
d160: 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 28 63 f *configdat* (c
d170: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
d180: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
d190: 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 20 23 66 " "linktree") #f
d1a0: 29 29 29 0a 09 09 09 09 09 3b 20 20 20 20 20 28 )))......; (
d1b0: 69 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 if *configdat*..
d1c0: 09 09 09 09 3b 20 09 20 20 20 28 63 6f 6e 66 69 ....; . (confi
d1d0: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
d1e0: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c gdat* "setup" "l
d1f0: 69 6e 6b 74 72 65 65 22 29 0a 09 09 09 09 09 3b inktree")......;
d200: 20 09 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 . (conc *topp
d210: 61 74 68 2a 20 22 2f 6c 74 22 29 29 29 29 0a 09 ath* "/lt"))))..
d220: 09 09 20 28 73 65 63 6f 6e 64 2d 70 61 73 73 20 .. (second-pass
d230: 20 28 66 69 6e 64 2d 61 6e 64 2d 72 65 61 64 2d (find-and-read-
d240: 63 6f 6e 66 69 67 0a 09 09 09 09 09 6d 74 63 6f config......mtco
d250: 6e 66 69 67 0a 09 09 09 09 09 65 6e 76 69 72 6f nfig......enviro
d260: 6e 2d 70 61 74 74 3a 20 22 65 6e 76 2d 6f 76 65 n-patt: "env-ove
d270: 72 72 69 64 65 22 0a 09 09 09 09 09 67 69 76 65 rride"......give
d280: 6e 2d 74 6f 70 70 61 74 68 3a 20 74 6f 70 70 61 n-toppath: toppa
d290: 74 68 0a 09 09 09 09 09 70 61 74 68 65 6e 76 76 th......pathenvv
d2a0: 61 72 3a 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 ar: "MT_RUN_AREA
d2b0: 5f 48 4f 4d 45 22 29 29 0a 09 09 09 20 28 72 75 _HOME")).... (ru
d2c0: 6e 63 6f 6e 66 69 67 64 61 74 20 28 62 65 67 69 nconfigdat (begi
d2d0: 6e 20 20 20 20 20 3b 3b 20 74 68 69 73 20 72 65 n ;; this re
d2e0: 61 64 20 6f 66 20 74 68 65 20 72 75 6e 63 6f 6e ad of the runcon
d2f0: 66 69 67 73 20 77 69 6c 6c 20 73 65 65 20 61 6e figs will see an
d300: 79 20 61 64 6a 75 73 74 6d 65 6e 74 73 20 6d 61 y adjustments ma
d310: 64 65 20 62 79 20 72 65 2d 72 65 61 64 69 6e 67 de by re-reading
d320: 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 megatest.config
d330: 0a 09 09 09 09 09 20 28 66 6f 72 2d 65 61 63 68 ...... (for-each
d340: 20 28 6c 61 6d 62 64 61 20 28 6b 74 29 0a 09 09 (lambda (kt)...
d350: 09 09 09 09 20 20 20 20 20 28 73 65 74 65 6e 76 .... (setenv
d360: 20 28 63 61 72 20 6b 74 29 20 28 63 61 64 72 20 (car kt) (cadr
d370: 6b 74 29 29 29 0a 09 09 09 09 09 09 20 20 20 6b kt)))....... k
d380: 65 79 2d 76 61 6c 73 29 0a 09 09 09 09 09 20 28 ey-vals)...... (
d390: 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e read-config (con
d3a0: 63 20 74 6f 70 70 61 74 68 20 22 2f 72 75 6e 63 c toppath "/runc
d3b0: 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 20 onfigs.config")
d3c0: 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 23 *runconfigdat* #
d3d0: 74 20 3b 3b 20 63 6f 6e 73 69 64 65 72 20 75 73 t ;; consider us
d3e0: 69 6e 67 20 72 75 6e 63 6f 6e 66 69 67 3a 72 65 ing runconfig:re
d3f0: 61 64 20 73 6f 6d 65 20 64 61 79 20 2e 2e 2e 0a ad some day ....
d400: 09 09 09 09 09 09 20 20 20 20 20 20 73 65 63 74 ...... sect
d410: 69 6f 6e 73 3a 20 73 65 63 74 69 6f 6e 73 29 29 ions: sections))
d420: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d430: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 63 68 (cach
d440: 65 66 69 6c 65 73 20 20 20 28 6c 61 75 6e 63 68 efiles (launch
d450: 3a 67 65 74 2d 63 61 63 68 65 2d 66 69 6c 65 2d :get-cache-file-
d460: 70 61 74 68 73 20 61 72 65 61 70 61 74 68 20 74 paths areapath t
d470: 6f 70 70 61 74 68 20 74 61 72 67 65 74 20 6d 74 oppath target mt
d480: 63 6f 6e 66 69 67 29 29 0a 20 20 20 20 20 20 20 config)).
d490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4a0: 20 20 28 6d 74 63 61 63 68 65 66 20 20 20 20 20 (mtcachef
d4b0: 28 63 61 72 20 63 61 63 68 65 66 69 6c 65 73 29 (car cachefiles)
d4c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d4d0: 20 20 20 20 20 20 20 20 20 20 20 28 72 63 63 61 (rcca
d4e0: 63 68 65 66 20 20 20 20 20 28 63 64 72 20 63 61 chef (cdr ca
d4f0: 63 68 65 66 69 6c 65 73 29 29 29 0a 20 20 20 20 chefiles))).
d500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d510: 3b 3b 20 20 74 72 61 70 20 65 78 63 65 70 74 69 ;; trap excepti
d520: 6f 6e 20 64 75 65 20 74 6f 20 73 74 61 6c 65 20 on due to stale
d530: 4e 46 53 20 68 61 6e 64 6c 65 20 2d 2d 20 45 72 NFS handle -- Er
d540: 72 6f 72 3a 20 28 6f 70 65 6e 2d 6f 75 74 70 75 ror: (open-outpu
d550: 74 2d 66 69 6c 65 29 20 63 61 6e 6e 6f 74 20 6f t-file) cannot o
d560: 70 65 6e 20 66 69 6c 65 20 2d 20 53 74 61 6c 65 pen file - Stale
d570: 20 4e 46 53 20 66 69 6c 65 20 68 61 6e 64 6c 65 NFS file handle
d580: 3a 20 22 2f 70 2f 66 64 6b 2f 67 77 61 2f 6c 65 : "/p/fdk/gwa/le
d590: 66 6b 6f 77 69 74 2f 6d 74 54 65 73 74 69 6e 67 fkowit/mtTesting
d5a0: 2f 71 61 2f 70 72 69 6d 62 65 71 61 2f 6c 69 6e /qa/primbeqa/lin
d5b0: 6b 73 2f 70 31 32 32 32 2f 31 31 2f 50 44 4b 5f ks/p1222/11/PDK_
d5c0: 72 31 2e 31 2e 31 2f 70 72 69 6d 2f 63 6c 65 61 r1.1.1/prim/clea
d5d0: 6e 2f 70 63 65 6c 6c 5f 74 65 73 74 67 65 6e 2f n/pcell_testgen/
d5e0: 2e 72 75 6e 63 6f 6e 66 69 67 73 2e 63 66 67 2d .runconfigs.cfg-
d5f0: 31 2e 36 34 32 37 2d 37 64 31 65 37 38 39 63 62 1.6427-7d1e789cb
d600: 33 66 36 32 66 39 63 64 65 37 31 39 61 34 38 36 3f62f9cde719a486
d610: 35 62 62 35 31 62 33 63 31 37 65 61 38 35 33 22 5bb51b3c17ea853"
d620: 20 2d 20 74 69 63 6b 65 74 20 32 32 30 35 34 36 - ticket 220546
d630: 33 34 32 0a 20 20 20 20 20 20 20 20 20 20 20 20 342.
d640: 20 20 20 20 20 20 20 20 3b 3b 20 54 4f 44 4f 20 ;; TODO
d650: 2d 20 63 6f 6e 73 69 64 65 72 20 31 29 20 75 73 - consider 1) us
d660: 69 6e 67 20 73 69 6d 70 6c 65 2d 6c 6f 63 6b 20 ing simple-lock
d670: 74 6f 20 62 72 61 63 6b 65 74 20 63 61 63 68 65 to bracket cache
d680: 20 77 72 69 74 65 0a 20 20 20 20 20 20 20 20 20 write.
d690: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 ;;
d6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 32 29 2)
d6b0: 20 63 61 63 68 65 20 69 6e 20 68 61 73 68 20 6f cache in hash o
d6c0: 6e 20 73 65 72 76 65 72 2c 20 73 69 6e 63 65 20 n server, since
d6d0: 6e 65 65 64 20 74 6f 20 64 6f 20 72 6d 74 3a 20 need to do rmt:
d6e0: 61 6e 79 77 61 79 20 74 6f 20 6c 6f 63 6b 2e 0a anyway to lock..
d6f0: 0a 09 09 20 20 20 20 28 69 66 20 72 63 63 61 63 ... (if rccac
d700: 68 65 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 hef.
d710: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
d720: 6d 6f 6e 3a 66 61 69 6c 2d 73 61 66 65 0a 20 20 mon:fail-safe.
d730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d740: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
d750: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d760: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
d770: 6e 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 nfigf:write-alis
d780: 74 20 72 75 6e 63 6f 6e 66 69 67 64 61 74 20 72 t runconfigdat r
d790: 63 63 61 63 68 65 66 29 29 0a 20 20 20 20 20 20 ccachef)).
d7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7b0: 20 20 20 28 63 6f 6e 63 20 22 43 6f 75 6c 64 20 (conc "Could
d7c0: 6e 6f 74 20 77 72 69 74 65 20 63 61 63 68 65 20 not write cache
d7d0: 66 69 6c 65 20 2d 20 22 72 63 63 61 63 68 65 66 file - "rccachef
d7e0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
d7f0: 20 20 20 20 20 20 20 20 28 69 66 20 6d 74 63 61 (if mtca
d800: 63 68 65 66 0a 20 20 20 20 20 20 20 20 20 20 20 chef.
d810: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
d820: 6d 6d 6f 6e 3a 66 61 69 6c 2d 73 61 66 65 0a 20 mmon:fail-safe.
d830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d840: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
d850: 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ().
d860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
d870: 6f 6e 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 onfigf:write-ali
d880: 73 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 6d st *configdat* m
d890: 74 63 61 63 68 65 66 29 29 0a 20 20 20 20 20 20 tcachef)).
d8a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8b0: 20 20 20 28 63 6f 6e 63 20 22 43 6f 75 6c 64 20 (conc "Could
d8c0: 6e 6f 74 20 77 72 69 74 65 20 63 61 63 68 65 20 not write cache
d8d0: 66 69 6c 65 20 2d 20 22 6d 74 63 61 63 68 65 66 file - "mtcachef
d8e0: 29 29 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 )))... (set!
d8f0: 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 72 *runconfigdat* r
d900: 75 6e 63 6f 6e 66 69 67 64 61 74 29 0a 09 09 20 unconfigdat)...
d910: 20 20 20 28 69 66 20 28 61 6e 64 20 72 63 63 61 (if (and rcca
d920: 63 68 65 66 20 6d 74 63 61 63 68 65 66 29 20 28 chef mtcachef) (
d930: 73 65 74 21 20 2a 63 6f 6e 66 69 67 73 74 61 74 set! *configstat
d940: 75 73 2a 20 27 66 75 6c 6c 64 61 74 61 29 29 29 us* 'fulldata)))
d950: 29 0a 09 09 3b 3b 20 6e 6f 20 63 6f 6e 66 69 67 )...;; no config
d960: 73 20 66 6f 75 6e 64 3f 20 73 68 6f 75 6c 64 20 s found? should
d970: 6e 6f 74 20 68 61 70 70 65 6e 20 62 75 74 20 6c not happen but l
d980: 65 74 27 73 20 74 72 79 20 74 6f 20 72 65 63 6f et's try to reco
d990: 76 65 72 20 67 72 61 63 65 66 75 6c 6c 79 2c 20 ver gracefully,
d9a0: 72 65 74 75 72 6e 20 61 6e 20 65 6d 70 74 79 20 return an empty
d9b0: 68 61 73 68 2d 74 61 62 6c 65 0a 09 09 28 73 65 hash-table...(se
d9c0: 74 21 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 28 t! *configdat* (
d9d0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
d9e0: 29 0a 09 09 29 29 29 0a 0a 09 20 3b 3b 20 65 6c )...)))... ;; el
d9f0: 73 65 20 72 65 61 64 20 77 68 61 74 20 79 6f 75 se read what you
da00: 20 63 61 6e 20 61 6e 64 20 73 65 74 20 74 68 65 can and set the
da10: 20 66 6c 61 67 20 61 63 63 6f 72 64 69 6e 67 6c flag accordingl
da20: 79 0a 09 20 3b 3b 20 68 65 72 65 20 77 65 20 64 y.. ;; here we d
da30: 6f 6e 27 74 20 68 61 76 65 20 65 69 74 68 65 72 on't have either
da40: 20 6d 74 63 6f 6e 66 69 67 20 6f 72 20 72 63 63 mtconfig or rcc
da50: 61 63 68 65 66 0a 09 20 28 65 6c 73 65 0a 20 20 achef.. (else.
da60: 20 20 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 ;;(BB> "
da70: 6c 61 75 6e 63 68 3a 73 65 74 75 70 2d 62 6f 64 launch:setup-bod
da80: 79 20 2d 2d 20 63 6f 6e 64 20 62 72 61 6e 63 68 y -- cond branch
da90: 20 33 20 2d 20 65 6c 73 65 22 29 0a 09 20 20 28 3 - else").. (
daa0: 6c 65 74 2a 20 28 28 63 66 67 64 61 74 20 20 20 let* ((cfgdat
dab0: 28 66 69 6e 64 2d 61 6e 64 2d 72 65 61 64 2d 63 (find-and-read-c
dac0: 6f 6e 66 69 67 20 0a 09 09 09 20 20 20 20 28 6f onfig .... (o
dad0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
dae0: 22 2d 63 6f 6e 66 69 67 22 29 20 22 6d 65 67 61 "-config") "mega
daf0: 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 0a 09 09 test.config")...
db00: 09 20 20 20 20 65 6e 76 69 72 6f 6e 2d 70 61 74 . environ-pat
db10: 74 3a 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 65 t: "env-override
db20: 22 0a 09 09 09 20 20 20 20 67 69 76 65 6e 2d 74 ".... given-t
db30: 6f 70 70 61 74 68 3a 20 28 67 65 74 2d 65 6e 76 oppath: (get-env
db40: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
db50: 65 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 e "MT_RUN_AREA_H
db60: 4f 4d 45 22 29 0a 09 09 09 20 20 20 20 70 61 74 OME").... pat
db70: 68 65 6e 76 76 61 72 3a 20 22 4d 54 5f 52 55 4e henvvar: "MT_RUN
db80: 5f 41 52 45 41 5f 48 4f 4d 45 22 29 29 29 0a 0a _AREA_HOME")))..
db90: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
dba0: 28 61 6e 64 20 63 66 67 64 61 74 20 28 6c 69 73 (and cfgdat (lis
dbb0: 74 3f 20 63 66 67 64 61 74 29 20 28 3e 20 28 6c t? cfgdat) (> (l
dbc0: 65 6e 67 74 68 20 63 66 67 64 61 74 29 20 30 29 ength cfgdat) 0)
dbd0: 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 28 63 (hash-table? (c
dbe0: 61 72 20 63 66 67 64 61 74 29 29 29 0a 09 09 28 ar cfgdat)))...(
dbf0: 6c 65 74 2a 20 28 28 74 6f 70 70 61 74 68 20 20 let* ((toppath
dc00: 28 6f 72 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (or (get-environ
dc10: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
dc20: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
dc30: 29 28 63 61 64 72 20 63 66 67 64 61 74 29 29 29 )(cadr cfgdat)))
dc40: 0a 09 09 20 20 20 20 20 20 20 28 72 64 61 74 20 ... (rdat
dc50: 20 20 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 (read-config
dc60: 20 28 63 6f 6e 63 20 74 6f 70 70 61 74 68 20 20 (conc toppath
dc70: 3b 3b 20 63 6f 6e 76 65 72 74 20 74 68 69 73 20 ;; convert this
dc80: 74 6f 20 75 73 65 20 72 75 6e 63 6f 6e 66 69 67 to use runconfig
dc90: 3a 72 65 61 64 21 0a 09 09 09 09 09 09 20 20 20 :read!.......
dca0: 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f "/runconfigs.co
dcb0: 6e 66 69 67 22 29 20 2a 72 75 6e 63 6f 6e 66 69 nfig") *runconfi
dcc0: 67 64 61 74 2a 20 23 74 20 73 65 63 74 69 6f 6e gdat* #t section
dcd0: 73 3a 20 73 65 63 74 69 6f 6e 73 29 29 29 0a 09 s: sections)))..
dce0: 09 20 20 28 73 65 74 21 20 2a 63 6f 6e 66 69 67 . (set! *config
dcf0: 69 6e 66 6f 2a 20 20 20 63 66 67 64 61 74 29 0a info* cfgdat).
dd00: 09 09 20 20 28 73 65 74 21 20 2a 63 6f 6e 66 69 .. (set! *confi
dd10: 67 64 61 74 2a 20 20 20 20 28 63 61 72 20 63 66 gdat* (car cf
dd20: 67 64 61 74 29 29 0a 09 09 20 20 28 73 65 74 21 gdat))... (set!
dd30: 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 *runconfigdat*
dd40: 72 64 61 74 29 0a 09 09 20 20 28 73 65 74 21 20 rdat)... (set!
dd50: 2a 74 6f 70 70 61 74 68 2a 20 20 20 20 20 20 74 *toppath* t
dd60: 6f 70 70 61 74 68 29 0a 09 09 20 20 28 73 65 74 oppath)... (set
dd70: 21 20 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a ! *configstatus*
dd80: 20 27 70 61 72 74 69 61 6c 29 29 0a 09 09 28 62 'partial))...(b
dd90: 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 67 3a egin... (debug:
dda0: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
ddb0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
ddc0: 20 22 4e 6f 20 22 20 6d 74 63 6f 6e 66 69 67 20 "No " mtconfig
ddd0: 22 20 66 69 6c 65 20 66 6f 75 6e 64 2e 20 47 69 " file found. Gi
dde0: 76 69 6e 67 20 75 70 2e 22 29 0a 09 09 20 20 28 ving up.")... (
ddf0: 65 78 69 74 20 32 29 29 29 29 29 29 0a 09 3b 3b exit 2))))))..;;
de00: 20 43 4f 4e 44 20 65 6e 64 73 20 68 65 72 65 2e COND ends here.
de10: 0a 09 0a 09 3b 3b 20 61 64 64 69 74 69 6f 6e 61 ....;; additiona
de20: 6c 20 68 6f 75 73 65 20 6b 65 65 70 69 6e 67 0a l house keeping.
de30: 09 28 6c 65 74 2a 20 28 28 6c 69 6e 6b 74 72 65 .(let* ((linktre
de40: 65 20 28 6f 72 20 28 63 6f 6d 6d 6f 6e 3a 67 65 e (or (common:ge
de50: 74 2d 6c 69 6e 6b 74 72 65 65 29 0a 09 09 09 20 t-linktree)....
de60: 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 (conc *toppa
de70: 74 68 2a 20 22 2f 6c 74 22 29 29 29 29 0a 09 20 th* "/lt"))))..
de80: 20 28 69 66 20 6c 69 6e 6b 74 72 65 65 0a 09 20 (if linktree..
de90: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 69 (begin...(i
dea0: 66 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 f (not (common:f
deb0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c 69 6e 6b ile-exists? link
dec0: 74 72 65 65 29 29 0a 09 09 20 20 20 20 28 62 65 tree))... (be
ded0: 67 69 6e 0a 09 09 20 20 20 20 20 20 28 68 61 6e gin... (han
dee0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
def0: 09 09 20 20 65 78 6e 0a 09 09 09 20 20 28 62 65 .. exn.... (be
df00: 67 69 6e 0a 09 09 09 20 20 20 20 28 64 65 62 75 gin.... (debu
df10: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
df20: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
df30: 74 2a 20 22 53 6f 6d 65 74 68 69 6e 67 20 77 65 t* "Something we
df40: 6e 74 20 77 72 6f 6e 67 20 77 68 65 6e 20 74 72 nt wrong when tr
df50: 79 69 6e 67 20 74 6f 20 63 72 65 61 74 65 20 6c ying to create l
df60: 69 6e 6b 74 72 65 65 20 64 69 72 20 61 74 20 22 inktree dir at "
df70: 20 6c 69 6e 6b 74 72 65 65 29 0a 09 09 09 20 20 linktree)....
df80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
df90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
dfa0: 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 rt* " message: "
dfb0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
dfc0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
dfd0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
dfe0: 6e 29 20 22 2c 20 65 78 6e 3d 22 20 65 78 6e 29 n) ", exn=" exn)
dff0: 0a 09 09 09 20 20 20 20 28 65 78 69 74 20 31 29 .... (exit 1)
e000: 29 0a 09 09 09 28 63 72 65 61 74 65 2d 64 69 72 )....(create-dir
e010: 65 63 74 6f 72 79 20 6c 69 6e 6b 74 72 65 65 20 ectory linktree
e020: 23 74 29 29 29 29 0a 09 09 28 68 61 6e 64 6c 65 #t))))...(handle
e030: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 -exceptions...
e040: 20 20 65 78 6e 0a 09 09 20 20 20 20 28 62 65 67 exn... (beg
e050: 69 6e 0a 09 09 20 20 20 20 20 20 28 64 65 62 75 in... (debu
e060: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
e070: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
e080: 74 2a 20 22 53 6f 6d 65 74 68 69 6e 67 20 77 65 t* "Something we
e090: 6e 74 20 77 72 6f 6e 67 20 77 68 65 6e 20 74 72 nt wrong when tr
e0a0: 79 69 6e 67 20 74 6f 20 63 72 65 61 74 65 20 6c ying to create l
e0b0: 69 6e 6b 20 74 6f 20 6c 69 6e 6b 74 72 65 65 20 ink to linktree
e0c0: 61 74 20 22 20 2a 74 6f 70 70 61 74 68 2a 29 0a at " *toppath*).
e0d0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
e0e0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
e0f0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
e100: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
e110: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
e120: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
e130: 67 65 29 20 65 78 6e 29 20 22 2c 20 65 78 6e 3d ge) exn) ", exn=
e140: 22 20 65 78 6e 29 29 0a 09 09 20 20 28 6c 65 74 " exn))... (let
e150: 20 28 28 74 6c 69 6e 6b 20 28 63 6f 6e 63 20 2a ((tlink (conc *
e160: 74 6f 70 70 61 74 68 2a 20 22 2f 6c 74 22 29 29 toppath* "/lt"))
e170: 29 0a 09 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )... (if (not
e180: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
e190: 69 73 74 73 3f 20 74 6c 69 6e 6b 29 29 0a 09 09 ists? tlink))...
e1a0: 09 28 63 72 65 61 74 65 2d 73 79 6d 62 6f 6c 69 .(create-symboli
e1b0: 63 2d 6c 69 6e 6b 20 6c 69 6e 6b 74 72 65 65 20 c-link linktree
e1c0: 74 6c 69 6e 6b 29 29 29 29 29 0a 09 20 20 20 20 tlink)))))..
e1d0: 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 (begin...(debu
e1e0: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
e1f0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
e200: 74 2a 20 22 6c 69 6e 6b 74 72 65 65 20 6e 6f 74 t* "linktree not
e210: 20 64 65 66 69 6e 65 64 20 69 6e 20 5b 73 65 74 defined in [set
e220: 75 70 5d 20 73 65 63 74 69 6f 6e 20 6f 66 20 6d up] section of m
e230: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 egatest.config")
e240: 0a 09 09 29 29 29 0a 09 28 69 66 20 28 61 6e 64 ...)))..(if (and
e250: 20 2a 74 6f 70 70 61 74 68 2a 0a 09 09 20 28 64 *toppath*... (d
e260: 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f irectory-exists?
e270: 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 20 *toppath*))..
e280: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
e290: 28 73 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 5f (setenv "MT_RUN_
e2a0: 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f 70 70 AREA_HOME" *topp
e2b0: 61 74 68 2a 29 0a 09 20 20 20 20 20 20 28 73 65 ath*).. (se
e2c0: 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 53 55 49 tenv "MT_TESTSUI
e2d0: 54 45 4e 41 4d 45 22 20 28 63 6f 6d 6d 6f 6e 3a TENAME" (common:
e2e0: 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 get-testsuite-na
e2f0: 6d 65 29 29 29 0a 09 20 20 20 20 28 62 65 67 69 me))).. (begi
e300: 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a n.. (debug:
e310: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
e320: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
e330: 20 22 66 61 69 6c 65 64 20 74 6f 20 66 69 6e 64 "failed to find
e340: 20 74 68 65 20 74 6f 70 20 70 61 74 68 20 74 6f the top path to
e350: 20 79 6f 75 72 20 4d 65 67 61 74 65 73 74 20 61 your Megatest a
e360: 72 65 61 2e 22 29 0a 09 20 20 20 20 20 20 28 73 rea.").. (s
e370: 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 23 66 et! *toppath* #f
e380: 29 20 3b 3b 20 66 6f 72 63 65 20 69 74 20 74 6f ) ;; force it to
e390: 20 62 65 20 66 61 6c 73 65 20 73 6f 20 77 65 20 be false so we
e3a0: 72 65 74 75 72 6e 20 23 66 0a 09 20 20 20 20 20 return #f..
e3b0: 20 23 66 29 29 0a 09 0a 20 20 20 20 20 20 20 20 #f))...
e3c0: 3b 3b 20 6f 6e 65 20 6d 6f 72 65 20 61 74 74 65 ;; one more atte
e3d0: 6d 70 74 20 74 6f 20 63 61 63 68 65 20 74 68 65 mpt to cache the
e3e0: 20 63 6f 6e 66 69 67 73 20 66 6f 72 20 66 75 74 configs for fut
e3f0: 75 72 65 20 72 65 61 64 69 6e 67 0a 20 20 20 20 ure reading.
e400: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 61 63 68 (let* ((cach
e410: 65 66 69 6c 65 73 20 20 20 28 6c 61 75 6e 63 68 efiles (launch
e420: 3a 67 65 74 2d 63 61 63 68 65 2d 66 69 6c 65 2d :get-cache-file-
e430: 70 61 74 68 73 20 61 72 65 61 70 61 74 68 20 74 paths areapath t
e440: 6f 70 70 61 74 68 20 74 61 72 67 65 74 20 6d 74 oppath target mt
e450: 63 6f 6e 66 69 67 29 29 0a 20 20 20 20 20 20 20 config)).
e460: 20 20 20 20 20 20 20 20 28 6d 74 63 61 63 68 65 (mtcache
e470: 66 20 20 20 20 20 28 63 61 72 20 63 61 63 68 65 f (car cache
e480: 66 69 6c 65 73 29 29 0a 20 20 20 20 20 20 20 20 files)).
e490: 20 20 20 20 20 20 20 28 72 63 63 61 63 68 65 66 (rccachef
e4a0: 20 20 20 20 20 28 63 64 72 20 63 61 63 68 65 66 (cdr cachef
e4b0: 69 6c 65 73 29 29 29 0a 0a 20 20 20 20 20 20 20 iles)))..
e4c0: 20 20 20 3b 3b 20 74 72 61 70 20 65 78 63 65 70 ;; trap excep
e4d0: 74 69 6f 6e 20 64 75 65 20 74 6f 20 73 74 61 6c tion due to stal
e4e0: 65 20 4e 46 53 20 68 61 6e 64 6c 65 20 2d 2d 20 e NFS handle --
e4f0: 45 72 72 6f 72 3a 20 28 6f 70 65 6e 2d 6f 75 74 Error: (open-out
e500: 70 75 74 2d 66 69 6c 65 29 20 63 61 6e 6e 6f 74 put-file) cannot
e510: 20 6f 70 65 6e 20 66 69 6c 65 20 2d 20 53 74 61 open file - Sta
e520: 6c 65 20 4e 46 53 20 66 69 6c 65 20 68 61 6e 64 le NFS file hand
e530: 6c 65 3a 20 22 2e 2e 2e 73 6f 6d 65 70 61 74 68 le: "...somepath
e540: 2e 2e 2e 2f 2e 72 75 6e 63 6f 6e 66 69 67 73 2e .../.runconfigs.
e550: 63 66 67 2d 31 2e 36 34 32 37 2d 37 64 31 65 37 cfg-1.6427-7d1e7
e560: 38 39 63 62 33 66 36 32 66 39 63 64 65 37 31 39 89cb3f62f9cde719
e570: 61 34 38 36 35 62 62 35 31 62 33 63 31 37 65 61 a4865bb51b3c17ea
e580: 38 35 33 22 20 2d 20 74 69 63 6b 65 74 20 32 32 853" - ticket 22
e590: 30 35 34 36 33 34 32 0a 20 20 20 20 20 20 20 20 0546342.
e5a0: 20 20 3b 3b 20 54 4f 44 4f 20 2d 20 63 6f 6e 73 ;; TODO - cons
e5b0: 69 64 65 72 20 31 29 20 75 73 69 6e 67 20 73 69 ider 1) using si
e5c0: 6d 70 6c 65 2d 6c 6f 63 6b 20 74 6f 20 62 72 61 mple-lock to bra
e5d0: 63 6b 65 74 20 63 61 63 68 65 20 77 72 69 74 65 cket cache write
e5e0: 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 . ;;
e5f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 32 29 2)
e600: 20 63 61 63 68 65 20 69 6e 20 68 61 73 68 20 6f cache in hash o
e610: 6e 20 73 65 72 76 65 72 2c 20 73 69 6e 63 65 20 n server, since
e620: 6e 65 65 64 20 74 6f 20 64 6f 20 72 6d 74 3a 20 need to do rmt:
e630: 61 6e 79 77 61 79 20 74 6f 20 6c 6f 63 6b 2e 0a anyway to lock..
e640: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
e650: 6e 64 20 72 63 63 61 63 68 65 66 20 2a 72 75 6e nd rccachef *run
e660: 63 6f 6e 66 69 67 64 61 74 2a 20 28 6e 6f 74 20 configdat* (not
e670: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
e680: 73 74 73 3f 20 72 63 63 61 63 68 65 66 29 29 29 sts? rccachef)))
e690: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
e6a0: 63 6f 6d 6d 6f 6e 3a 66 61 69 6c 2d 73 61 66 65 common:fail-safe
e6b0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
e6c0: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
e6d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
e6e0: 66 69 67 66 3a 77 72 69 74 65 2d 61 6c 69 73 74 figf:write-alist
e6f0: 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 *runconfigdat*
e700: 72 63 63 61 63 68 65 66 29 29 0a 20 20 20 20 20 rccachef)).
e710: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 (conc
e720: 22 43 6f 75 6c 64 20 6e 6f 74 20 77 72 69 74 65 "Could not write
e730: 20 63 61 63 68 65 20 66 69 6c 65 20 2d 20 22 72 cache file - "r
e740: 63 63 61 63 68 65 66 29 29 0a 20 20 20 20 20 20 ccachef)).
e750: 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 20 20 ).
e760: 20 20 20 20 28 69 66 20 28 61 6e 64 20 6d 74 63 (if (and mtc
e770: 61 63 68 65 66 20 2a 63 6f 6e 66 69 67 64 61 74 achef *configdat
e780: 2a 20 20 20 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f * (not (commo
e790: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d n:file-exists? m
e7a0: 74 63 61 63 68 65 66 29 29 29 0a 20 20 20 20 20 tcachef))).
e7b0: 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e (common
e7c0: 3a 66 61 69 6c 2d 73 61 66 65 0a 20 20 20 20 20 :fail-safe.
e7d0: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
e7e0: 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 a ().
e7f0: 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 77 (configf:w
e800: 72 69 74 65 2d 61 6c 69 73 74 20 2a 63 6f 6e 66 rite-alist *conf
e810: 69 67 64 61 74 2a 20 6d 74 63 61 63 68 65 66 29 igdat* mtcachef)
e820: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
e830: 20 28 63 6f 6e 63 20 22 43 6f 75 6c 64 20 6e 6f (conc "Could no
e840: 74 20 77 72 69 74 65 20 63 61 63 68 65 20 66 69 t write cache fi
e850: 6c 65 20 2d 20 22 6d 74 63 61 63 68 65 66 29 29 le - "mtcachef))
e860: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 29 . )
e870: 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 . (if (
e880: 61 6e 64 20 72 63 63 61 63 68 65 66 20 6d 74 63 and rccachef mtc
e890: 61 63 68 65 66 20 2a 72 75 6e 63 6f 6e 66 69 67 achef *runconfig
e8a0: 64 61 74 2a 20 2a 63 6f 6e 66 69 67 64 61 74 2a dat* *configdat*
e8b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
e8c0: 28 73 65 74 21 20 2a 63 6f 6e 66 69 67 73 74 61 (set! *configsta
e8d0: 74 75 73 2a 20 27 66 75 6c 6c 64 61 74 61 29 29 tus* 'fulldata))
e8e0: 29 0a 0a 09 3b 3b 20 69 66 20 68 61 76 65 20 2d )...;; if have -
e8f0: 61 70 70 65 6e 64 2d 63 6f 6e 66 69 67 20 74 68 append-config th
e900: 65 6e 20 72 65 61 64 20 61 6e 64 20 61 70 70 65 en read and appe
e910: 6e 64 20 68 65 72 65 0a 09 28 6c 65 74 20 28 28 nd here..(let ((
e920: 63 66 6e 61 6d 65 20 28 61 72 67 73 3a 67 65 74 cfname (args:get
e930: 2d 61 72 67 20 22 2d 61 70 70 65 6e 64 2d 63 6f -arg "-append-co
e940: 6e 66 69 67 22 29 29 29 0a 09 20 20 28 69 66 20 nfig"))).. (if
e950: 28 61 6e 64 20 63 66 6e 61 6d 65 0a 09 09 20 20 (and cfname...
e960: 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 63 63 65 (file-read-acce
e970: 73 73 3f 20 63 66 6e 61 6d 65 29 29 0a 09 20 20 ss? cfname))..
e980: 20 20 20 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 (read-config
e990: 20 63 66 6e 61 6d 65 20 2a 63 6f 6e 66 69 67 64 cfname *configd
e9a0: 61 74 2a 20 23 74 29 29 29 20 3b 3b 20 76 61 6c at* #t))) ;; val
e9b0: 75 65 73 20 61 72 65 20 61 64 64 65 64 20 74 6f ues are added to
e9c0: 20 74 68 65 20 68 61 73 68 2c 20 6e 6f 20 6e 65 the hash, no ne
e9d0: 65 64 20 74 6f 20 64 6f 20 61 6e 79 74 68 69 6e ed to do anythin
e9e0: 67 20 73 70 65 63 69 61 6c 2e 0a 09 2a 74 6f 70 g special...*top
e9f0: 70 61 74 68 2a 29 29 29 0a 0a 0a 28 64 65 66 69 path*)))...(defi
ea00: 6e 65 20 28 67 65 74 2d 62 65 73 74 2d 64 69 73 ne (get-best-dis
ea10: 6b 20 63 6f 6e 66 64 61 74 20 74 65 73 74 63 6f k confdat testco
ea20: 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 28 28 nfig). (let* ((
ea30: 64 69 73 6b 73 20 20 20 28 6f 72 20 28 61 6e 64 disks (or (and
ea40: 20 74 65 73 74 63 6f 6e 66 69 67 20 28 68 61 73 testconfig (has
ea50: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
ea60: 75 6c 74 20 74 65 73 74 63 6f 6e 66 69 67 20 22 ult testconfig "
ea70: 64 69 73 6b 73 22 20 23 66 29 29 0a 09 09 20 20 disks" #f))...
ea80: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
ea90: 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 ref/default conf
eaa0: 64 61 74 20 22 64 69 73 6b 73 22 20 23 66 29 29 dat "disks" #f))
eab0: 29 0a 09 20 28 6d 69 6e 73 70 61 63 65 20 28 6c ).. (minspace (l
eac0: 65 74 20 28 28 6d 20 28 63 6f 6e 66 69 67 66 3a et ((m (configf:
ead0: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 64 61 74 20 22 lookup confdat "
eae0: 73 65 74 75 70 22 20 22 6d 69 6e 73 70 61 63 65 setup" "minspace
eaf0: 22 29 29 29 0a 09 09 20 20 20 20 20 28 73 74 72 ")))... (str
eb00: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 ing->number (or
eb10: 6d 20 22 31 30 30 30 30 22 29 29 29 29 29 0a 20 m "10000"))))).
eb20: 20 20 20 28 69 66 20 64 69 73 6b 73 20 0a 09 28 (if disks ..(
eb30: 6c 65 74 20 28 28 72 65 73 20 28 63 6f 6d 6d 6f let ((res (commo
eb40: 6e 3a 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d n:get-disk-with-
eb50: 6d 6f 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 most-free-space
eb60: 64 69 73 6b 73 20 6d 69 6e 73 70 61 63 65 29 29 disks minspace))
eb70: 29 20 3b 3b 20 6d 69 6e 20 73 69 7a 65 20 6f 66 ) ;; min size of
eb80: 20 31 30 30 30 2c 20 73 65 65 6d 73 20 74 61 64 1000, seems tad
eb90: 20 64 75 6d 62 0a 09 20 20 28 69 66 20 72 65 73 dumb.. (if res
eba0: 0a 09 20 20 20 20 20 20 28 63 64 72 20 72 65 73 .. (cdr res
ebb0: 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 6e 20 ).. (begin
ebc0: 3b 3b 20 44 45 41 44 20 43 4f 44 45 20 50 41 54 ;; DEAD CODE PAT
ebd0: 48 20 2d 20 52 45 56 49 53 49 54 21 0a 3b 3b 09 H - REVISIT!.;;.
ebe0: 09 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 .(if (common:low
ebf0: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 32 30 20 -noise-print 20
ec00: 22 4e 6f 20 76 61 6c 69 64 20 64 69 73 6b 73 20 "No valid disks
ec10: 6f 72 20 6e 6f 20 64 69 73 6b 20 77 69 74 68 20 or no disk with
ec20: 65 6e 6f 75 67 68 20 73 70 61 63 65 22 29 0a 3b enough space").;
ec30: 3b 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ;.. (debug:pr
ec40: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
ec50: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
ec60: 4e 6f 20 76 61 6c 69 64 20 64 69 73 6b 73 20 66 No valid disks f
ec70: 6f 75 6e 64 20 69 6e 20 6d 65 67 61 74 65 73 74 ound in megatest
ec80: 2e 63 6f 6e 66 69 67 2e 20 50 6c 65 61 73 65 20 .config. Please
ec90: 61 64 64 20 73 6f 6d 65 20 74 6f 20 79 6f 75 72 add some to your
eca0: 20 5b 64 69 73 6b 73 5d 20 73 65 63 74 69 6f 6e [disks] section
ecb0: 20 61 6e 64 20 65 6e 73 75 72 65 20 74 68 65 20 and ensure the
ecc0: 64 69 72 65 63 74 6f 72 79 20 65 78 69 73 74 73 directory exists
ecd0: 20 61 6e 64 20 68 61 73 20 65 6e 6f 75 67 68 20 and has enough
ece0: 73 70 61 63 65 21 5c 6e 20 20 20 20 59 6f 75 20 space!\n You
ecf0: 63 61 6e 20 63 68 61 6e 67 65 20 6d 69 6e 73 70 can change minsp
ed00: 61 63 65 20 69 6e 20 74 68 65 20 5b 73 65 74 75 ace in the [setu
ed10: 70 5d 20 73 65 63 74 69 6f 6e 20 6f 66 20 6d 65 p] section of me
ed20: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 2e 20 43 gatest.config. C
ed30: 75 72 72 65 6e 74 20 73 65 74 74 69 6e 67 20 69 urrent setting i
ed40: 73 3a 20 22 20 6d 69 6e 73 70 61 63 65 29 29 0a s: " minspace)).
ed50: 09 09 3b 3b 28 65 78 69 74 20 31 29 0a 20 20 20 ..;;(exit 1).
ed60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
ed70: 66 20 28 6e 75 6c 6c 3f 20 64 69 73 6b 73 29 0a f (null? disks).
ed80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ed90: 20 20 20 20 20 28 63 6f 6e 73 20 31 20 28 63 6f (cons 1 (co
eda0: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 nc *toppath* "/r
edb0: 75 6e 73 22 29 29 0a 20 20 20 20 20 20 20 20 20 uns")).
edc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
edd0: 20 28 28 70 61 74 68 73 20 28 73 6f 72 74 20 64 ((paths (sort d
ede0: 69 73 6b 73 20 28 6c 61 6d 62 64 61 20 28 78 20 isks (lambda (x
edf0: 79 29 20 28 3e 20 28 73 74 72 69 6e 67 2d 6c 65 y) (> (string-le
ee00: 6e 67 74 68 20 28 63 61 64 72 20 78 29 29 20 28 ngth (cadr x)) (
ee10: 73 74 72 69 6e 67 2d 6c 65 6e 67 74 68 20 28 63 string-length (c
ee20: 61 64 72 20 79 29 29 29 29 29 29 29 0a 20 20 20 adr y))))))).
ee30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ee40: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
ee50: 68 65 61 64 20 28 63 61 72 20 70 61 74 68 73 29 head (car paths)
ee60: 29 20 28 74 61 69 6c 20 28 63 64 72 20 70 61 74 ) (tail (cdr pat
ee70: 68 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 hs))).
ee80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ee90: 6c 65 74 20 28 28 72 65 73 75 6c 74 20 28 68 61 let ((result (ha
eea0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 ndle-exceptions
eeb0: 65 78 6e 0a 09 09 09 09 09 20 28 62 65 67 69 6e exn...... (begin
eec0: 0a 09 09 09 09 09 20 20 20 28 64 65 62 75 67 3a ...... (debug:
eed0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
eee0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 69 6c -log-port* "fail
eef0: 65 64 20 74 6f 20 63 72 65 61 74 65 20 64 69 72 ed to create dir
ef00: 20 22 20 28 63 61 64 72 20 68 65 61 64 29 20 22 " (cadr head) "
ef10: 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 , exn=" exn)....
ef20: 09 09 20 20 20 23 66 29 0a 09 09 09 09 09 20 28 .. #f)...... (
ef30: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
ef40: 20 28 63 61 64 72 20 68 65 61 64 29 20 23 74 29 (cadr head) #t)
ef50: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
ef60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ef70: 69 66 20 72 65 73 75 6c 74 0a 20 20 20 20 20 20 if result.
ef80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ef90: 20 20 20 20 20 20 20 20 20 72 65 73 75 6c 74 0a result.
efa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
efb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
efc0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 69 6c 29 0a if (null? tail).
efd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
efe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
eff0: 20 20 20 28 63 6f 6e 73 20 31 20 28 63 6f 6e 63 (cons 1 (conc
f000: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
f010: 73 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s")).
f020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f030: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 (loop (c
f040: 61 72 20 74 61 69 6c 29 20 28 63 64 72 20 74 61 ar tail) (cdr ta
f050: 69 6c 29 29 29 29 29 29 29 29 29 29 29 0a 09 3b il)))))))))))..;
f060: 3b 20 6e 6f 20 64 69 73 6b 73 20 64 65 66 69 6e ; no disks defin
f070: 69 74 69 6f 6e 20 2d 20 75 73 65 20 6d 74 72 61 ition - use mtra
f080: 68 2f 72 75 6e 73 2c 20 66 61 6c 6c 20 62 61 63 h/runs, fall bac
f090: 6b 20 74 6f 20 63 75 72 72 64 69 72 2f 72 75 6e k to currdir/run
f0a0: 73 0a 09 28 6c 65 74 2a 20 28 28 74 6f 70 70 61 s..(let* ((toppa
f0b0: 74 68 20 28 6f 72 20 2a 74 6f 70 70 61 74 68 2a th (or *toppath*
f0c0: 0a 09 09 09 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a .... (common:
f0d0: 67 65 74 2d 74 6f 70 70 61 74 68 20 2a 74 6f 70 get-toppath *top
f0e0: 70 61 74 68 2a 29 0a 09 09 09 20 20 20 20 28 62 path*).... (b
f0f0: 65 67 69 6e 0a 09 09 09 20 20 20 20 20 20 28 64 egin.... (d
f100: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
f110: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
f120: 70 6f 72 74 2a 20 22 43 72 65 61 74 69 6e 67 20 port* "Creating
f130: 72 75 6e 73 20 64 69 72 20 69 6e 20 63 75 72 72 runs dir in curr
f140: 65 6e 74 20 64 69 72 65 63 74 6f 72 79 2c 20 74 ent directory, t
f150: 68 69 73 20 69 73 20 70 72 6f 62 61 62 6c 79 20 his is probably
f160: 6e 6f 74 20 77 68 61 74 20 79 6f 75 20 77 61 6e not what you wan
f170: 74 65 64 2e 20 50 6c 65 61 73 65 20 63 68 65 63 ted. Please chec
f180: 6b 20 79 6f 75 72 20 73 65 74 75 70 2e 22 29 0a k your setup.").
f190: 09 09 09 20 20 20 20 20 20 28 63 75 72 72 65 6e ... (curren
f1a0: 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 29 0a t-directory)))).
f1b0: 09 20 20 20 20 20 20 20 28 72 75 6e 73 64 69 72 . (runsdir
f1c0: 20 28 63 6f 6e 63 20 74 6f 70 70 61 74 68 20 22 (conc toppath "
f1d0: 2f 72 75 6e 73 22 29 29 29 0a 09 20 20 28 69 66 /runs"))).. (if
f1e0: 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 69 73 (not (file-exis
f1f0: 74 73 3f 20 72 75 6e 73 64 69 72 29 29 28 63 72 ts? runsdir))(cr
f200: 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 72 eate-directory r
f210: 75 6e 73 64 69 72 29 29 0a 09 20 20 72 75 6e 73 unsdir)).. runs
f220: 64 69 72 29 0a 09 29 29 29 20 3b 3b 20 74 68 65 dir)..))) ;; the
f230: 20 63 6f 64 65 20 63 72 65 61 74 65 73 20 74 68 code creates th
f240: 65 20 6e 65 63 65 73 73 61 72 79 20 64 69 72 65 e necessary dire
f250: 63 74 6f 72 69 65 73 20 69 66 20 69 74 20 64 6f ctories if it do
f260: 65 73 20 6e 6f 74 20 65 78 69 73 74 20 61 6e 64 es not exist and
f270: 20 72 65 74 75 72 6e 73 20 74 68 65 20 70 61 74 returns the pat
f280: 68 2e 0a 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 h...(define (lau
f290: 6e 63 68 3a 74 65 73 74 2d 63 6f 70 79 20 74 65 nch:test-copy te
f2a0: 73 74 2d 73 72 63 2d 70 61 74 68 20 74 65 73 74 st-src-path test
f2b0: 2d 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 -path). (let* (
f2c0: 28 6f 76 72 63 6d 64 20 28 6c 65 74 20 28 28 63 (ovrcmd (let ((c
f2d0: 6d 64 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b md (configf:look
f2e0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
f2f0: 73 65 74 75 70 22 20 22 74 65 73 74 63 6f 70 79 setup" "testcopy
f300: 63 6d 64 22 29 29 29 0a 09 09 20 20 20 28 69 66 cmd")))... (if
f310: 20 63 6d 64 0a 09 09 20 20 20 20 20 20 20 3b 3b cmd... ;;
f320: 20 73 75 62 73 74 69 74 75 74 65 20 74 68 65 20 substitute the
f330: 54 45 53 54 5f 53 52 43 5f 50 41 54 48 20 61 6e TEST_SRC_PATH an
f340: 64 20 54 45 53 54 5f 54 41 52 47 5f 50 41 54 48 d TEST_TARG_PATH
f350: 0a 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e ... (strin
f360: 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 54 45 g-substitute "TE
f370: 53 54 5f 54 41 52 47 5f 50 41 54 48 22 20 74 65 ST_TARG_PATH" te
f380: 73 74 2d 70 61 74 68 0a 09 09 09 09 09 20 20 28 st-path...... (
f390: 73 74 72 69 6e 67 2d 73 75 62 73 74 69 74 75 74 string-substitut
f3a0: 65 20 22 54 45 53 54 5f 53 52 43 5f 50 41 54 48 e "TEST_SRC_PATH
f3b0: 22 20 74 65 73 74 2d 73 72 63 2d 70 61 74 68 20 " test-src-path
f3c0: 63 6d 64 20 23 74 29 20 23 74 29 0a 09 09 20 20 cmd #t) #t)...
f3d0: 20 20 20 20 20 23 66 29 29 29 0a 09 20 28 63 6d #f))).. (cm
f3e0: 64 20 20 20 20 28 69 66 20 6f 76 72 63 6d 64 20 d (if ovrcmd
f3f0: 0a 09 09 20 20 20 20 20 6f 76 72 63 6d 64 0a 09 ... ovrcmd..
f400: 09 20 20 20 20 20 28 63 6f 6e 63 20 22 72 73 79 . (conc "rsy
f410: 6e 63 20 2d 61 76 22 20 28 69 66 20 28 64 65 62 nc -av" (if (deb
f420: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 ug:debug-mode 1)
f430: 20 22 22 20 22 71 22 29 20 22 20 22 20 74 65 73 "" "q") " " tes
f440: 74 2d 73 72 63 2d 70 61 74 68 20 22 2f 20 22 20 t-src-path "/ "
f450: 74 65 73 74 2d 70 61 74 68 20 22 2f 22 0a 09 09 test-path "/"...
f460: 09 20 20 20 22 20 3e 3e 20 22 20 74 65 73 74 2d . " >> " test-
f470: 70 61 74 68 20 22 2f 6d 74 5f 6c 61 75 6e 63 68 path "/mt_launch
f480: 2e 6c 6f 67 20 32 3e 3e 20 22 20 74 65 73 74 2d .log 2>> " test-
f490: 70 61 74 68 20 22 2f 6d 74 5f 6c 61 75 6e 63 68 path "/mt_launch
f4a0: 2e 6c 6f 67 22 29 29 29 0a 09 20 28 73 74 61 74 .log"))).. (stat
f4b0: 75 73 20 28 73 79 73 74 65 6d 20 63 6d 64 29 29 us (system cmd))
f4c0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 ). (if (not (
f4d0: 65 71 3f 20 73 74 61 74 75 73 20 30 29 29 0a 09 eq? status 0))..
f4e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 2a (debug:print 2 *
f4f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
f500: 2a 20 22 45 52 52 4f 52 3a 20 70 72 6f 62 6c 65 * "ERROR: proble
f510: 6d 20 77 69 74 68 20 72 75 6e 6e 69 6e 67 20 5c m with running \
f520: 22 22 20 63 6d 64 20 22 5c 22 22 29 29 29 29 0a "" cmd "\"")))).
f530: 0a 0a 3b 3b 20 44 65 73 69 72 65 64 20 64 69 72 ..;; Desired dir
f540: 65 63 74 6f 72 79 20 73 74 72 75 63 74 75 72 65 ectory structure
f550: 3a 0a 3b 3b 0a 3b 3b 20 20 3c 6c 69 6e 6b 64 69 :.;;.;; <linkdi
f560: 72 3e 20 2d 20 3c 74 61 72 67 65 74 3e 20 2d 20 r> - <target> -
f570: 3c 74 65 73 74 6e 61 6d 65 3e 20 2d 2e 0a 3b 3b <testname> -..;;
f580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f5a0: 20 20 20 20 20 7c 0a 3b 3b 20 20 20 20 20 20 20 |.;;
f5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
f5c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 76 0a v.
f5d0: 3b 3b 20 20 3c 72 75 6e 64 69 72 3e 20 20 2d 20 ;; <rundir> -
f5e0: 20 3c 74 61 72 67 65 74 3e 20 20 2d 20 20 20 20 <target> -
f5f0: 3c 74 65 73 74 6e 61 6d 65 3e 20 2d 7c 2d 20 3c <testname> -|- <
f600: 69 74 65 6d 70 61 74 68 28 73 29 3e 0a 3b 3b 0a itempath(s)>.;;.
f610: 3b 3b 20 20 64 69 72 20 73 74 6f 72 65 64 20 69 ;; dir stored i
f620: 6e 20 74 65 73 74 20 69 73 3a 0a 3b 3b 20 0a 3b n test is:.;; .;
f630: 3b 20 20 3c 6c 69 6e 6b 64 69 72 3e 20 2d 20 3c ; <linkdir> - <
f640: 74 61 72 67 65 74 3e 20 2d 20 3c 74 65 73 74 6e target> - <testn
f650: 61 6d 65 3e 20 5b 20 2d 20 3c 69 74 65 6d 70 61 ame> [ - <itempa
f660: 74 68 3e 20 5d 0a 3b 3b 20 0a 3b 3b 20 41 6c 6c th> ].;; .;; All
f670: 20 6c 6f 67 20 66 69 6c 65 20 6c 69 6e 6b 73 20 log file links
f680: 73 68 6f 75 6c 64 20 62 65 20 73 74 6f 72 65 64 should be stored
f690: 20 72 65 6c 61 74 69 76 65 20 74 6f 20 74 68 65 relative to the
f6a0: 20 74 6f 70 20 6f 66 20 6c 69 6e 6b 20 70 61 74 top of link pat
f6b0: 68 0a 3b 3b 20 20 0a 3b 3b 20 3c 74 61 72 67 65 h.;; .;; <targe
f6c0: 74 3e 20 2d 20 3c 74 65 73 74 6e 61 6d 65 3e 20 t> - <testname>
f6d0: 5b 20 2d 20 3c 69 74 65 6d 70 61 74 68 3e 20 5d [ - <itempath> ]
f6e0: 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 72 .;;.(define (cr
f6f0: 65 61 74 65 2d 77 6f 72 6b 2d 61 72 65 61 20 72 eate-work-area r
f700: 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b un-id run-info k
f710: 65 79 76 61 6c 73 20 74 65 73 74 2d 69 64 20 74 eyvals test-id t
f720: 65 73 74 2d 73 72 63 2d 70 61 74 68 20 64 69 73 est-src-path dis
f730: 6b 2d 70 61 74 68 20 74 65 73 74 6e 61 6d 65 20 k-path testname
f740: 69 74 65 6d 64 61 74 20 23 21 6b 65 79 20 28 72 itemdat #!key (r
f750: 65 6d 74 72 69 65 73 20 32 29 29 0a 20 20 28 6c emtries 2)). (l
f760: 65 74 2a 20 28 28 69 74 65 6d 2d 70 61 74 68 20 et* ((item-path
f770: 28 69 66 20 28 73 74 72 69 6e 67 3f 20 69 74 65 (if (string? ite
f780: 6d 64 61 74 29 20 69 74 65 6d 64 61 74 20 28 69 mdat) itemdat (i
f790: 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 tem-list->path i
f7a0: 74 65 6d 64 61 74 29 29 29 20 3b 3b 20 69 66 20 temdat))) ;; if
f7b0: 70 61 73 73 20 69 6e 20 73 74 72 69 6e 67 20 2d pass in string -
f7c0: 20 6a 75 73 74 20 75 73 65 20 69 74 0a 09 20 28 just use it.. (
f7d0: 72 75 6e 6e 61 6d 65 20 20 20 28 69 66 20 28 73 runname (if (s
f7e0: 74 72 69 6e 67 3f 20 72 75 6e 2d 69 6e 66 6f 29 tring? run-info)
f7f0: 20 3b 3b 20 69 66 20 77 65 20 70 61 73 73 20 69 ;; if we pass i
f800: 6e 20 61 20 73 74 72 69 6e 67 20 61 73 20 72 75 n a string as ru
f810: 6e 2d 69 6e 66 6f 20 75 73 65 20 69 74 20 61 73 n-info use it as
f820: 20 72 75 6e 2d 6e 61 6d 65 2e 0a 09 09 09 72 75 run-name.....ru
f830: 6e 2d 69 6e 66 6f 0a 09 09 09 28 64 62 3a 67 65 n-info....(db:ge
f840: 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 64 65 t-value-by-heade
f850: 72 20 28 64 62 3a 67 65 74 2d 72 6f 77 73 20 72 r (db:get-rows r
f860: 75 6e 2d 69 6e 66 6f 29 0a 09 09 09 09 09 09 28 un-info).......(
f870: 64 62 3a 67 65 74 2d 68 65 61 64 65 72 20 72 75 db:get-header ru
f880: 6e 2d 69 6e 66 6f 29 0a 09 09 09 09 09 09 22 72 n-info)......."r
f890: 75 6e 6e 61 6d 65 22 29 29 29 0a 09 20 28 63 6f unname"))).. (co
f8a0: 6e 74 6f 75 72 20 20 20 23 66 29 20 3b 3b 20 4e ntour #f) ;; N
f8b0: 4f 54 20 52 45 41 44 59 20 46 4f 52 20 54 48 49 OT READY FOR THI
f8c0: 53 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 S (args:get-arg
f8d0: 22 2d 63 6f 6e 74 6f 75 72 22 29 29 0a 09 20 3b "-contour")).. ;
f8e0: 3b 20 63 6f 6e 76 65 72 74 20 62 61 63 6b 20 74 ; convert back t
f8f0: 6f 20 64 62 3a 20 66 72 6f 6d 20 72 64 62 3a 20 o db: from rdb:
f900: 2d 20 74 68 69 73 20 69 73 20 61 6c 77 61 79 73 - this is always
f910: 20 72 75 6e 20 61 74 20 73 65 72 76 65 72 20 65 run at server e
f920: 6e 64 0a 09 20 28 74 61 72 67 65 74 20 20 20 28 nd.. (target (
f930: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
f940: 73 65 20 28 6d 61 70 20 63 61 64 72 20 6b 65 79 se (map cadr key
f950: 76 61 6c 73 29 20 22 2f 22 29 29 0a 0a 09 20 28 vals) "/"))... (
f960: 6e 6f 74 2d 69 74 65 72 61 74 65 64 20 20 28 65 not-iterated (e
f970: 71 75 61 6c 3f 20 22 22 20 69 74 65 6d 2d 70 61 qual? "" item-pa
f980: 74 68 29 29 0a 0a 09 20 3b 3b 20 61 6c 6c 20 74 th))... ;; all t
f990: 65 73 74 73 20 61 72 65 20 66 6f 75 6e 64 20 61 ests are found a
f9a0: 74 20 3c 72 75 6e 64 69 72 3e 2f 74 65 73 74 2d t <rundir>/test-
f9b0: 62 61 73 65 20 6f 72 20 3c 6c 69 6e 6b 64 69 72 base or <linkdir
f9c0: 3e 2f 74 65 73 74 2d 62 61 73 65 0a 09 20 28 74 >/test-base.. (t
f9d0: 65 73 74 74 6f 70 2d 62 61 73 65 20 28 63 6f 6e esttop-base (con
f9e0: 63 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e c target "/" run
f9f0: 6e 61 6d 65 20 22 2f 22 20 74 65 73 74 6e 61 6d name "/" testnam
fa00: 65 29 29 0a 09 20 28 74 65 73 74 2d 62 61 73 65 e)).. (test-base
fa10: 20 20 20 20 28 63 6f 6e 63 20 74 65 73 74 74 6f (conc testto
fa20: 70 2d 62 61 73 65 20 28 69 66 20 6e 6f 74 2d 69 p-base (if not-i
fa30: 74 65 72 61 74 65 64 20 22 22 20 22 2f 22 29 20 terated "" "/")
fa40: 69 74 65 6d 2d 70 61 74 68 29 29 0a 0a 09 20 3b item-path))... ;
fa50: 3b 20 6e 62 2f 2f 20 69 66 20 69 74 65 6d 70 61 ; nb// if itempa
fa60: 74 68 20 69 73 20 6e 6f 74 20 22 22 20 74 68 65 th is not "" the
fa70: 6e 20 69 74 20 69 73 20 70 72 65 66 69 78 65 64 n it is prefixed
fa80: 20 77 69 74 68 20 22 2f 22 0a 09 20 28 74 6f 70 with "/".. (top
fa90: 74 65 73 74 2d 70 61 74 68 20 28 63 6f 6e 63 20 test-path (conc
faa0: 64 69 73 6b 2d 70 61 74 68 20 28 69 66 20 63 6f disk-path (if co
fab0: 6e 74 6f 75 72 20 28 63 6f 6e 63 20 22 2f 22 20 ntour (conc "/"
fac0: 63 6f 6e 74 6f 75 72 29 20 22 22 29 20 22 2f 22 contour) "") "/"
fad0: 20 74 65 73 74 74 6f 70 2d 62 61 73 65 29 29 0a testtop-base)).
fae0: 09 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 20 . (test-path
faf0: 28 63 6f 6e 63 20 64 69 73 6b 2d 70 61 74 68 20 (conc disk-path
fb00: 28 69 66 20 63 6f 6e 74 6f 75 72 20 28 63 6f 6e (if contour (con
fb10: 63 20 22 2f 22 20 63 6f 6e 74 6f 75 72 29 20 22 c "/" contour) "
fb20: 22 29 20 22 2f 22 20 74 65 73 74 2d 62 61 73 65 ") "/" test-base
fb30: 29 29 0a 0a 09 20 3b 3b 20 65 6e 73 75 72 65 20 ))... ;; ensure
fb40: 74 68 69 73 20 65 78 69 73 74 73 20 66 69 72 73 this exists firs
fb50: 74 20 61 73 20 6c 69 6e 6b 73 20 74 6f 20 73 75 t as links to su
fb60: 62 74 65 73 74 73 20 6d 75 73 74 20 62 65 20 63 btests must be c
fb70: 72 65 61 74 65 64 20 74 68 65 72 65 0a 09 20 28 reated there.. (
fb80: 6c 69 6e 6b 74 72 65 65 20 20 28 63 6f 6d 6d 6f linktree (commo
fb90: 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 29 n:get-linktree))
fba0: 0a 09 20 3b 3b 20 57 41 53 3a 20 28 6c 65 74 20 .. ;; WAS: (let
fbb0: 28 28 72 64 20 28 63 6f 6e 66 69 67 66 3a 6c 6f ((rd (configf:lo
fbc0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
fbd0: 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 "setup" "linktr
fbe0: 65 65 22 29 29 29 0a 09 20 3b 3b 20 20 20 20 20 ee"))).. ;;
fbf0: 20 20 20 20 28 69 66 20 72 64 20 72 64 20 28 63 (if rd rd (c
fc00: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
fc10: 72 75 6e 73 22 29 29 29 29 0a 09 20 3b 3b 20 77 runs")))).. ;; w
fc20: 68 69 63 68 20 73 65 65 6d 73 20 77 72 6f 6e 67 hich seems wrong
fc30: 20 2e 2e 2e 0a 0a 09 20 28 6c 6e 6b 62 61 73 65 ...... (lnkbase
fc40: 20 20 20 28 63 6f 6e 63 20 6c 69 6e 6b 74 72 65 (conc linktre
fc50: 65 20 28 69 66 20 63 6f 6e 74 6f 75 72 20 28 63 e (if contour (c
fc60: 6f 6e 63 20 22 2f 22 20 63 6f 6e 74 6f 75 72 29 onc "/" contour)
fc70: 20 22 22 29 20 22 2f 22 20 74 61 72 67 65 74 20 "") "/" target
fc80: 22 2f 22 20 72 75 6e 6e 61 6d 65 29 29 0a 09 20 "/" runname))..
fc90: 28 6c 6e 6b 70 61 74 68 20 20 20 28 63 6f 6e 63 (lnkpath (conc
fca0: 20 6c 6e 6b 62 61 73 65 20 22 2f 22 20 74 65 73 lnkbase "/" tes
fcb0: 74 6e 61 6d 65 29 29 0a 09 20 28 6c 6e 6b 70 61 tname)).. (lnkpa
fcc0: 74 68 66 20 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 thf (conc lnkpa
fcd0: 74 68 20 28 69 66 20 6e 6f 74 2d 69 74 65 72 61 th (if not-itera
fce0: 74 65 64 20 22 22 20 22 2f 22 29 20 69 74 65 6d ted "" "/") item
fcf0: 2d 70 61 74 68 29 29 0a 09 20 28 6c 6e 6b 74 61 -path)).. (lnkta
fd00: 72 67 65 74 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 rget (conc lnkpa
fd10: 74 68 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 th "/" item-path
fd20: 29 29 29 0a 0a 20 20 20 20 3b 3b 20 55 70 64 61 ))).. ;; Upda
fd30: 74 65 20 74 68 65 20 72 75 6e 64 69 72 20 70 61 te the rundir pa
fd40: 74 68 20 69 6e 20 74 68 65 20 74 65 73 74 20 72 th in the test r
fd50: 65 63 6f 72 64 20 66 6f 72 20 61 6c 6c 2c 20 72 ecord for all, r
fd60: 75 6e 64 69 72 3d 70 68 79 73 69 63 61 6c 2c 20 undir=physical,
fd70: 73 68 6f 72 74 64 69 72 3d 6c 6f 67 69 63 61 6c shortdir=logical
fd80: 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
fd90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
fda0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
fdb0: 20 20 20 20 20 20 20 20 72 75 6e 64 69 72 20 20 rundir
fdc0: 20 73 68 6f 72 74 64 69 72 0a 20 20 20 20 28 72 shortdir. (r
fdd0: 6d 74 3a 67 65 6e 65 72 61 6c 2d 63 61 6c 6c 20 mt:general-call
fde0: 27 74 65 73 74 2d 73 65 74 2d 72 75 6e 64 69 72 'test-set-rundir
fdf0: 2d 73 68 6f 72 74 64 69 72 20 72 75 6e 2d 69 64 -shortdir run-id
fe00: 20 6c 6e 6b 70 61 74 68 66 20 74 65 73 74 2d 70 lnkpathf test-p
fe10: 61 74 68 20 74 65 73 74 6e 61 6d 65 20 69 74 65 ath testname ite
fe20: 6d 2d 70 61 74 68 20 72 75 6e 2d 69 64 29 0a 0a m-path run-id)..
fe30: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
fe40: 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 2 *default-log-
fe50: 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 5c 6e 20 20 port* "INFO:\n
fe60: 20 20 20 20 20 6c 6e 6b 62 61 73 65 3d 22 20 6c lnkbase=" l
fe70: 6e 6b 62 61 73 65 20 22 5c 6e 20 20 20 20 20 20 nkbase "\n
fe80: 20 6c 6e 6b 70 61 74 68 3d 22 20 6c 6e 6b 70 61 lnkpath=" lnkpa
fe90: 74 68 20 22 5c 6e 20 20 74 6f 70 74 65 73 74 2d th "\n toptest-
fea0: 70 61 74 68 3d 22 20 74 6f 70 74 65 73 74 2d 70 path=" toptest-p
feb0: 61 74 68 20 22 5c 6e 20 20 20 20 20 74 65 73 74 ath "\n test
fec0: 2d 70 61 74 68 3d 22 20 74 65 73 74 2d 70 61 74 -path=" test-pat
fed0: 68 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 h). (if (not
fee0: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
fef0: 73 74 73 3f 20 6c 69 6e 6b 74 72 65 65 29 29 0a sts? linktree)).
ff00: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
ff10: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
ff20: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
ff30: 52 4e 49 4e 47 3a 20 6c 69 6e 6b 74 72 65 65 20 RNING: linktree
ff40: 64 69 64 20 6e 6f 74 20 65 78 69 73 74 21 20 43 did not exist! C
ff50: 72 65 61 74 69 6e 67 20 69 74 20 6e 6f 77 20 61 reating it now a
ff60: 74 20 22 20 6c 69 6e 6b 74 72 65 65 29 0a 09 20 t " linktree)..
ff70: 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f (create-directo
ff80: 72 79 20 6c 69 6e 6b 74 72 65 65 20 23 74 29 29 ry linktree #t))
ff90: 29 20 3b 3b 20 28 73 79 73 74 65 6d 20 28 63 6f ) ;; (system (co
ffa0: 6e 63 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6c nc "mkdir -p " l
ffb0: 69 6e 6b 74 72 65 65 29 29 29 29 0a 20 20 20 20 inktree)))).
ffc0: 3b 3b 20 63 72 65 61 74 65 20 74 68 65 20 64 69 ;; create the di
ffd0: 72 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 20 rectory for the
ffe0: 74 65 73 74 73 20 64 69 72 20 6c 69 6e 6b 73 2c tests dir links,
fff0: 20 74 68 69 73 20 69 73 20 6e 65 65 64 65 64 20 this is needed
10000 6e 6f 20 6d 61 74 74 65 72 20 77 68 61 74 2e 2e no matter what..
10010 2e 20 74 72 79 20 75 70 20 74 6f 20 74 68 72 65 . try up to thre
10020 65 20 74 69 6d 65 73 0a 20 20 20 20 28 6c 65 74 e times. (let
10030 20 6c 6f 6f 70 20 28 28 64 6f 6e 65 20 33 29 29 loop ((done 3))
10040 20 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 73 . (let ((s
10050 75 63 63 65 73 73 20 28 69 66 20 28 61 6e 64 20 uccess (if (and
10060 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 64 69 72 (not (common:dir
10070 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 6c ectory-exists? l
10080 6e 6b 62 61 73 65 29 29 0a 09 09 09 20 20 20 20 nkbase))....
10090 20 20 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 (not (common:f
100a0 69 6c 65 2d 65 78 69 73 74 73 3f 20 6c 6e 6b 62 ile-exists? lnkb
100b0 61 73 65 29 29 29 0a 09 09 09 20 28 68 61 6e 64 ase))).... (hand
100c0 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
100d0 09 20 20 65 78 6e 0a 09 09 09 20 20 28 62 65 67 . exn.... (beg
100e0 69 6e 0a 09 09 09 20 20 20 20 28 64 65 62 75 67 in.... (debug
100f0 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
10100 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
10110 2a 20 22 50 72 6f 62 6c 65 6d 20 63 72 65 61 74 * "Problem creat
10120 69 6e 67 20 6c 69 6e 6b 74 72 65 65 20 62 61 73 ing linktree bas
10130 65 20 61 74 20 22 20 6c 6e 6b 62 61 73 65 20 22 e at " lnkbase "
10140 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 09 09 , exn=" exn)....
10150 20 20 20 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 (print-error
10160 2d 6d 65 73 73 61 67 65 20 65 78 6e 20 28 63 75 -message exn (cu
10170 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
10180 29 29 0a 09 09 09 20 20 20 20 23 74 29 0a 09 09 )).... #t)...
10190 09 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 . (create-direc
101a0 74 6f 72 79 20 6c 6e 6b 62 61 73 65 20 23 74 29 tory lnkbase #t)
101b0 0a 09 09 09 20 20 23 66 29 29 29 29 0a 09 28 69 .... #f))))..(i
101c0 66 20 28 61 6e 64 20 28 6e 6f 74 20 73 75 63 63 f (and (not succ
101d0 65 73 73 29 28 3e 20 64 6f 6e 65 20 30 29 29 0a ess)(> done 0)).
101e0 09 20 20 20 20 28 6c 6f 6f 70 20 28 2d 20 64 6f . (loop (- do
101f0 6e 65 20 31 29 29 29 29 29 0a 20 20 20 20 0a 20 ne 1))))). .
10200 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 65 ;; update the
10210 20 74 6f 70 74 65 73 74 20 72 65 63 6f 72 64 20 toptest record
10220 77 69 74 68 20 69 74 73 20 6c 6f 63 61 74 69 6f with its locatio
10230 6e 20 72 75 6e 64 69 72 2c 20 63 61 63 68 65 20 n rundir, cache
10240 74 68 65 20 70 61 74 68 0a 20 20 20 20 3b 3b 20 the path. ;;
10250 54 68 69 73 20 77 61 73 73 20 68 69 67 68 6c 79 This wass highly
10260 20 69 6e 65 66 66 69 63 69 65 6e 74 2c 20 6f 6e inefficient, on
10270 65 20 64 62 20 77 72 69 74 65 20 66 6f 72 20 65 e db write for e
10280 76 65 72 79 20 73 75 62 74 65 73 74 2c 20 70 6f very subtest, po
10290 74 65 6e 74 69 61 6c 6c 79 0a 20 20 20 20 3b 3b tentially. ;;
102a0 20 74 68 6f 75 73 61 6e 64 73 20 6f 66 20 75 6e thousands of un
102b0 6e 65 63 65 73 73 61 72 79 20 75 70 64 61 74 65 necessary update
102c0 73 2c 20 63 61 63 68 65 20 74 68 65 20 66 61 63 s, cache the fac
102d0 74 20 69 74 20 77 61 73 20 73 65 74 20 61 6e 64 t it was set and
102e0 20 64 6f 6e 27 74 20 73 65 74 20 69 74 20 0a 20 don't set it .
102f0 20 20 20 3b 3b 20 61 67 61 69 6e 2e 20 0a 0a 20 ;; again. ..
10300 20 20 20 3b 3b 20 4e 6f 77 20 63 72 65 61 74 65 ;; Now create
10310 20 74 68 65 20 6c 69 6e 6b 20 66 72 6f 6d 20 74 the link from t
10320 68 65 20 74 65 73 74 20 70 61 74 68 20 74 6f 20 he test path to
10330 74 68 65 20 6c 69 6e 6b 20 74 72 65 65 2c 20 68 the link tree, h
10340 6f 77 65 76 65 72 0a 20 20 20 20 3b 3b 20 69 66 owever. ;; if
10350 20 74 68 65 20 74 65 73 74 20 69 73 20 69 74 65 the test is ite
10360 72 61 74 65 64 20 69 74 20 69 73 20 6e 65 63 65 rated it is nece
10370 73 73 61 72 79 20 74 6f 20 63 72 65 61 74 65 20 ssary to create
10380 74 68 65 20 70 61 72 65 6e 74 20 70 61 74 68 0a the parent path.
10390 20 20 20 20 3b 3b 20 74 6f 20 74 68 65 20 69 74 ;; to the it
103a0 65 72 61 74 69 6f 6e 2e 20 75 73 65 20 70 61 74 eration. use pat
103b0 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 hname-directory
103c0 74 6f 20 74 72 69 6d 20 74 68 65 20 70 61 74 68 to trim the path
103d0 20 62 79 20 6f 6e 65 0a 20 20 20 20 3b 3b 20 6c by one. ;; l
103e0 65 76 65 6c 0a 20 20 20 20 28 69 66 20 28 6e 6f evel. (if (no
103f0 74 20 6e 6f 74 2d 69 74 65 72 61 74 65 64 29 20 t not-iterated)
10400 3b 3b 20 69 2e 65 2e 20 69 74 65 72 61 74 65 64 ;; i.e. iterated
10410 0a 09 28 6c 65 74 20 28 28 69 74 65 72 61 74 65 ..(let ((iterate
10420 64 2d 70 61 72 65 6e 74 20 20 28 70 61 74 68 6e d-parent (pathn
10430 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 28 63 ame-directory (c
10440 6f 6e 63 20 6c 6e 6b 70 61 74 68 20 22 2f 22 20 onc lnkpath "/"
10450 69 74 65 6d 2d 70 61 74 68 29 29 29 29 0a 09 20 item-path))))..
10460 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
10470 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
10480 67 2d 70 6f 72 74 2a 20 22 43 72 65 61 74 69 6e g-port* "Creatin
10490 67 20 69 74 65 72 61 74 65 64 20 70 61 72 65 6e g iterated paren
104a0 74 20 22 20 69 74 65 72 61 74 65 64 2d 70 61 72 t " iterated-par
104b0 65 6e 74 29 0a 09 20 20 28 68 61 6e 64 6c 65 2d ent).. (handle-
104c0 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 exceptions.. e
104d0 78 6e 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 xn.. (begin..
104e0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
104f0 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
10500 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 46 61 t-log-port* " Fa
10510 69 6c 65 64 20 74 6f 20 63 72 65 61 74 65 20 64 iled to create d
10520 69 72 65 63 74 6f 72 79 20 22 20 69 74 65 72 61 irectory " itera
10530 74 65 64 2d 70 61 72 65 6e 74 20 28 28 63 6f 6e ted-parent ((con
10540 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
10550 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
10560 65 73 73 61 67 65 29 20 65 78 6e 29 0a 09 09 09 essage) exn)....
10570 09 22 2c 20 63 6f 6e 74 69 6e 75 69 6e 67 20 62 .", continuing b
10580 75 74 20 6c 69 6e 6b 20 74 72 65 65 20 6d 61 79 ut link tree may
10590 20 62 65 20 63 6f 72 72 75 70 74 65 64 2c 20 65 be corrupted, e
105a0 78 6e 3d 22 20 65 78 6e 29 0a 09 20 20 20 20 20 xn=" exn)..
105b0 23 3b 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 #;(exit 1))..
105c0 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 (create-director
105d0 79 20 69 74 65 72 61 74 65 64 2d 70 61 72 65 6e y iterated-paren
105e0 74 20 23 74 29 29 29 29 0a 0a 20 20 20 20 28 69 t #t)))).. (i
105f0 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b f (symbolic-link
10600 3f 20 6c 6e 6b 70 61 74 68 29 20 0a 09 28 68 61 ? lnkpath) ..(ha
10610 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
10620 09 20 65 78 6e 0a 09 20 28 62 65 67 69 6e 0a 09 . exn.. (begin..
10630 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
10640 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
10650 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 46 61 69 -log-port* " Fai
10660 6c 65 64 20 74 6f 20 72 65 6d 6f 76 65 20 73 79 led to remove sy
10670 6d 6c 69 6e 6b 20 22 20 6c 6e 6b 70 61 74 68 20 mlink " lnkpath
10680 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
10690 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
106a0 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
106b0 29 0a 09 09 09 20 20 20 20 20 20 22 2c 20 63 6f ).... ", co
106c0 6e 74 69 6e 75 69 6e 67 20 62 75 74 20 6c 69 6e ntinuing but lin
106d0 6b 20 74 72 65 65 20 6d 61 79 20 62 65 20 63 6f k tree may be co
106e0 72 72 75 70 74 65 64 2e 20 65 78 6e 3d 22 20 65 rrupted. exn=" e
106f0 78 6e 29 0a 09 20 20 20 23 3b 28 65 78 69 74 20 xn).. #;(exit
10700 31 29 29 0a 09 20 28 64 65 6c 65 74 65 2d 66 69 1)).. (delete-fi
10710 6c 65 20 6c 6e 6b 70 61 74 68 29 29 29 0a 0a 20 le lnkpath)))..
10720 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6f 72 20 (if (not (or
10730 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
10740 73 74 73 3f 20 6c 6e 6b 70 61 74 68 29 0a 09 09 sts? lnkpath)...
10750 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f (symbolic-link?
10760 20 6c 6e 6b 70 61 74 68 29 29 29 0a 09 28 68 61 lnkpath)))..(ha
10770 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
10780 09 20 65 78 6e 0a 09 20 28 62 65 67 69 6e 0a 09 . exn.. (begin..
10790 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
107a0 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
107b0 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 46 61 69 -log-port* " Fai
107c0 6c 65 64 20 74 6f 20 63 72 65 61 74 65 20 73 79 led to create sy
107d0 6d 6c 69 6e 6b 20 22 20 6c 6e 6b 70 61 74 68 20 mlink " lnkpath
107e0 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
107f0 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
10800 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
10810 29 0a 09 09 09 20 20 20 20 20 20 22 2c 20 63 6f ).... ", co
10820 6e 74 69 6e 75 69 6e 67 20 62 75 74 20 6c 69 6e ntinuing but lin
10830 6b 20 74 72 65 65 20 6d 61 79 20 62 65 20 63 6f k tree may be co
10840 72 72 75 70 74 65 64 2e 20 65 78 6e 3d 22 20 65 rrupted. exn=" e
10850 78 6e 29 0a 09 20 20 20 23 3b 28 65 78 69 74 20 xn).. #;(exit
10860 31 29 29 0a 09 20 28 63 72 65 61 74 65 2d 73 79 1)).. (create-sy
10870 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 20 74 6f 70 74 mbolic-link topt
10880 65 73 74 2d 70 61 74 68 20 6c 6e 6b 70 61 74 68 est-path lnkpath
10890 29 29 29 0a 20 20 20 20 0a 20 20 20 20 3b 3b 20 ))). . ;;
108a0 4e 42 20 2d 20 54 68 69 73 20 77 61 73 20 6e 6f NB - This was no
108b0 74 20 77 6f 72 6b 69 6e 67 20 72 69 67 68 74 20 t working right
108c0 2d 20 73 6f 6d 65 20 74 6f 70 20 74 65 73 74 73 - some top tests
108d0 20 61 72 65 20 6e 6f 74 20 67 65 74 74 69 6e 67 are not getting
108e0 20 74 68 65 20 70 61 74 68 20 73 65 74 21 21 21 the path set!!!
108f0 0a 20 20 20 20 3b 3b 0a 20 20 20 20 3b 3b 20 44 . ;;. ;; D
10900 6f 20 74 68 65 20 73 65 74 74 69 6e 67 20 6f 66 o the setting of
10910 20 74 68 69 73 20 72 65 63 6f 72 64 20 61 66 74 this record aft
10920 65 72 20 74 68 65 20 70 61 74 68 73 20 61 72 65 er the paths are
10930 20 63 72 65 61 74 65 64 20 73 6f 20 74 68 61 74 created so that
10940 20 74 68 65 20 73 68 6f 72 74 64 69 72 20 63 61 the shortdir ca
10950 6e 20 0a 20 20 20 20 3b 3b 20 62 65 20 73 65 74 n . ;; be set
10960 20 74 6f 20 74 68 65 20 72 65 61 6c 20 64 69 72 to the real dir
10970 65 63 74 6f 72 79 20 6c 6f 63 61 74 69 6f 6e 2e ectory location.
10980 20 54 68 69 73 20 69 73 20 73 61 66 65 72 20 66 This is safer f
10990 6f 72 20 66 75 74 75 72 65 20 63 6c 65 61 6e 20 or future clean
109a0 75 70 20 69 66 20 74 68 65 20 6c 69 6e 6b 0a 20 up if the link.
109b0 20 20 20 3b 3b 20 74 72 65 65 20 69 73 20 64 61 ;; tree is da
109c0 6d 61 67 65 64 20 6f 72 20 6c 6f 73 74 2e 0a 20 maged or lost..
109d0 20 20 20 3b 3b 20 0a 20 20 20 20 28 69 66 20 28 ;; . (if (
109e0 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d not (hash-table-
109f0 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 6f 70 ref/default *top
10a00 74 65 73 74 2d 70 61 74 68 73 2a 20 74 65 73 74 test-paths* test
10a10 6e 61 6d 65 20 23 66 29 29 0a 09 28 6c 65 74 2a name #f))..(let*
10a20 20 28 28 74 65 73 74 69 6e 66 6f 20 20 20 20 20 ((testinfo
10a30 20 20 28 72 6d 74 3a 67 65 74 2d 74 65 73 74 2d (rmt:get-test-
10a40 69 6e 66 6f 2d 62 79 2d 69 64 20 72 75 6e 2d 69 info-by-id run-i
10a50 64 20 74 65 73 74 2d 69 64 29 29 20 3b 3b 20 20 d test-id)) ;;
10a60 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 run-id testname
10a70 69 74 65 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 item-path))..
10a80 20 20 20 20 28 63 75 72 72 2d 74 65 73 74 2d 70 (curr-test-p
10a90 61 74 68 20 28 69 66 20 74 65 73 74 69 6e 66 6f ath (if testinfo
10aa0 20 3b 3b 20 28 66 69 6c 65 64 62 3a 67 65 74 2d ;; (filedb:get-
10ab0 70 61 74 68 20 2a 66 64 62 2a 0a 09 09 09 09 09 path *fdb*......
10ac0 09 09 20 20 20 20 20 3b 3b 20 28 64 62 3a 67 65 .. ;; (db:ge
10ad0 74 2d 70 61 74 68 20 64 62 73 74 72 75 63 74 0a t-path dbstruct.
10ae0 09 09 09 09 20 20 20 3b 3b 20 28 72 6d 74 3a 73 .... ;; (rmt:s
10af0 64 62 2d 71 72 79 20 27 67 65 74 73 74 72 20 0a db-qry 'getstr .
10b00 09 09 09 09 20 20 20 28 64 62 3a 74 65 73 74 2d .... (db:test-
10b10 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 69 get-rundir testi
10b20 6e 66 6f 29 20 3b 3b 20 29 20 3b 3b 20 29 0a 09 nfo) ;; ) ;; )..
10b30 09 09 09 20 20 20 23 66 29 29 29 0a 09 20 20 28 ... #f))).. (
10b40 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
10b50 2a 74 6f 70 74 65 73 74 2d 70 61 74 68 73 2a 20 *toptest-paths*
10b60 74 65 73 74 6e 61 6d 65 20 63 75 72 72 2d 74 65 testname curr-te
10b70 73 74 2d 70 61 74 68 29 0a 09 20 20 3b 3b 20 4e st-path).. ;; N
10b80 42 2f 2f 20 57 61 73 20 74 68 69 73 20 66 6f 72 B// Was this for
10b90 20 74 68 65 20 74 65 73 74 20 6f 72 20 66 6f 72 the test or for
10ba0 20 74 68 65 20 70 61 72 65 6e 74 20 69 6e 20 61 the parent in a
10bb0 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 3f n iterated test?
10bc0 0a 09 20 20 28 72 6d 74 3a 67 65 6e 65 72 61 6c .. (rmt:general
10bd0 2d 63 61 6c 6c 20 27 74 65 73 74 2d 73 65 74 2d -call 'test-set-
10be0 72 75 6e 64 69 72 2d 73 68 6f 72 74 64 69 72 20 rundir-shortdir
10bf0 72 75 6e 2d 69 64 20 6c 6e 6b 70 61 74 68 20 0a run-id lnkpath .
10c00 09 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d ... (if (comm
10c10 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
10c20 6c 6e 6b 70 61 74 68 29 0a 09 09 09 09 3b 3b 20 lnkpath).....;;
10c30 28 72 65 73 6f 6c 76 65 2d 70 61 74 68 6e 61 6d (resolve-pathnam
10c40 65 20 6c 6e 6b 70 61 74 68 29 0a 09 09 09 09 28 e lnkpath).....(
10c50 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 common:nice-path
10c60 20 6c 6e 6b 70 61 74 68 29 0a 09 09 09 09 6c 6e lnkpath).....ln
10c70 6b 70 61 74 68 29 0a 09 09 09 20 20 20 20 74 65 kpath).... te
10c80 73 74 6e 61 6d 65 20 22 22 20 72 75 6e 2d 69 64 stname "" run-id
10c90 29 0a 09 20 20 3b 3b 20 28 72 6d 74 3a 67 65 6e ).. ;; (rmt:gen
10ca0 65 72 61 6c 2d 63 61 6c 6c 20 27 74 65 73 74 2d eral-call 'test-
10cb0 73 65 74 2d 72 75 6e 64 69 72 20 72 75 6e 2d 69 set-rundir run-i
10cc0 64 20 6c 6e 6b 70 61 74 68 20 74 65 73 74 6e 61 d lnkpath testna
10cd0 6d 65 20 22 22 29 20 3b 3b 20 74 6f 70 74 65 73 me "") ;; toptes
10ce0 74 2d 70 61 74 68 29 0a 09 20 20 28 69 66 20 28 t-path).. (if (
10cf0 6f 72 20 28 6e 6f 74 20 63 75 72 72 2d 74 65 73 or (not curr-tes
10d00 74 2d 70 61 74 68 29 0a 09 09 20 20 28 6e 6f 74 t-path)... (not
10d10 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 (directory-exis
10d20 74 73 3f 20 74 6f 70 74 65 73 74 2d 70 61 74 68 ts? toptest-path
10d30 29 29 29 0a 09 20 20 20 20 20 20 28 62 65 67 69 ))).. (begi
10d40 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 n...(debug:print
10d50 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 -info 2 *default
10d60 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 72 65 61 -log-port* "Crea
10d70 74 69 6e 67 20 22 20 74 6f 70 74 65 73 74 2d 70 ting " toptest-p
10d80 61 74 68 20 22 20 61 6e 64 20 6c 69 6e 6b 20 22 ath " and link "
10d90 20 6c 6e 6b 70 61 74 68 29 0a 09 09 28 68 61 6e lnkpath)...(han
10da0 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
10db0 09 20 20 20 20 65 78 6e 0a 09 09 20 20 28 62 65 . exn... (be
10dc0 67 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 gin... (debug
10dd0 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
10de0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 69 t-log-port* "fai
10df0 6c 65 64 20 74 6f 20 63 72 65 61 74 65 20 64 69 led to create di
10e00 72 65 63 74 6f 72 79 20 22 20 74 6f 70 74 65 73 rectory " toptes
10e10 74 2d 70 61 74 68 20 22 2c 20 65 78 6e 3d 22 20 t-path ", exn="
10e20 65 78 6e 29 0a 09 09 20 20 20 20 23 66 29 0a 09 exn)... #f)..
10e30 09 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 . (create-direct
10e40 6f 72 79 20 74 6f 70 74 65 73 74 2d 70 61 74 68 ory toptest-path
10e50 20 23 74 29 29 0a 09 09 28 68 61 73 68 2d 74 61 #t))...(hash-ta
10e60 62 6c 65 2d 73 65 74 21 20 2a 74 6f 70 74 65 73 ble-set! *toptes
10e70 74 2d 70 61 74 68 73 2a 20 74 65 73 74 6e 61 6d t-paths* testnam
10e80 65 20 74 6f 70 74 65 73 74 2d 70 61 74 68 29 29 e toptest-path))
10e90 29 29 29 0a 0a 20 20 20 20 3b 3b 20 54 68 65 20 ))).. ;; The
10ea0 74 6f 70 74 65 73 74 20 70 61 74 68 20 68 61 73 toptest path has
10eb0 20 62 65 65 6e 20 63 72 65 61 74 65 64 2c 20 74 been created, t
10ec0 68 65 20 6c 69 6e 6b 20 74 6f 20 74 68 65 20 74 he link to the t
10ed0 65 73 74 20 69 6e 20 74 68 65 20 6c 69 6e 6b 74 est in the linkt
10ee0 72 65 65 20 68 61 73 0a 20 20 20 20 3b 3b 20 62 ree has. ;; b
10ef0 65 65 6e 20 63 72 65 61 74 65 64 2e 20 4e 6f 77 een created. Now
10f00 2c 20 69 66 20 74 68 69 73 20 69 73 20 61 6e 20 , if this is an
10f10 69 74 65 72 61 74 65 64 20 74 65 73 74 20 74 68 iterated test th
10f20 65 20 72 65 61 6c 20 74 65 73 74 20 64 69 72 20 e real test dir
10f30 6d 75 73 74 20 62 65 20 63 72 65 61 74 65 64 0a must be created.
10f40 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6e 6f 74 (if (not not
10f50 2d 69 74 65 72 61 74 65 64 29 20 3b 3b 20 74 68 -iterated) ;; th
10f60 69 73 20 69 73 20 61 6e 20 69 74 65 72 61 74 65 is is an iterate
10f70 64 20 74 65 73 74 0a 09 28 62 65 67 69 6e 20 3b d test..(begin ;
10f80 3b 20 28 6c 65 74 20 28 28 6c 6e 6b 74 61 72 67 ; (let ((lnktarg
10f90 65 74 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 68 et (conc lnkpath
10fa0 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
10fb0 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
10fc0 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 2 *default-log
10fd0 2d 70 6f 72 74 2a 20 22 53 65 74 74 69 6e 67 20 -port* "Setting
10fe0 75 70 20 73 75 62 20 74 65 73 74 20 72 75 6e 20 up sub test run
10ff0 61 72 65 61 22 29 0a 09 20 20 28 64 65 62 75 67 area").. (debug
11000 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 61 75 6c :print 2 *defaul
11010 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2d 20 t-log-port* " -
11020 63 72 65 61 74 69 6e 67 20 72 75 6e 20 61 72 65 creating run are
11030 61 20 69 6e 20 22 20 74 65 73 74 2d 70 61 74 68 a in " test-path
11040 29 0a 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ).. (handle-exc
11050 65 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a eptions.. exn.
11060 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 . (begin..
11070 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
11080 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
11090 6f 67 2d 70 6f 72 74 2a 20 22 20 46 61 69 6c 65 og-port* " Faile
110a0 64 20 74 6f 20 63 72 65 61 74 65 20 64 69 72 65 d to create dire
110b0 63 74 6f 72 79 20 22 20 74 65 73 74 2d 70 61 74 ctory " test-pat
110c0 68 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 h ((condition-pr
110d0 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
110e0 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
110f0 78 6e 29 0a 09 09 09 09 22 2c 20 65 78 69 74 69 xn).....", exiti
11100 6e 67 2c 20 65 78 6e 3d 22 20 65 78 6e 29 0a 09 ng, exn=" exn)..
11110 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 (exit 1))..
11120 20 20 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 (create-direc
11130 74 6f 72 79 20 74 65 73 74 2d 70 61 74 68 20 23 tory test-path #
11140 74 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 t)).. (debug:pr
11150 69 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c int 2 *default-l
11160 6f 67 2d 70 6f 72 74 2a 20 0a 09 09 20 20 20 20 og-port* ...
11170 20 20 20 22 20 2d 20 63 72 65 61 74 69 6e 67 20 " - creating
11180 6c 69 6e 6b 20 66 72 6f 6d 3a 20 22 20 74 65 73 link from: " tes
11190 74 2d 70 61 74 68 20 22 5c 6e 22 0a 09 09 20 20 t-path "\n"...
111a0 20 20 20 20 20 22 20 20 20 20 20 20 20 20 20 20 "
111b0 20 20 20 20 20 20 20 20 20 74 6f 3a 20 22 20 6c to: " l
111c0 6e 6b 74 61 72 67 65 74 29 0a 0a 09 20 20 3b 3b nktarget)... ;;
111d0 20 49 66 20 74 68 65 72 65 20 69 73 20 61 6c 72 If there is alr
111e0 65 61 64 79 20 61 20 73 79 6d 6c 69 6e 6b 20 64 eady a symlink d
111f0 65 6c 65 74 65 20 69 74 20 61 6e 64 20 72 65 63 elete it and rec
11200 72 65 61 74 65 20 69 74 2e 0a 09 20 20 28 68 61 reate it... (ha
11210 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
11220 09 20 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 . exn.. (beg
11230 69 6e 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a in.. (debug:
11240 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
11250 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
11260 20 22 20 46 61 69 6c 65 64 20 74 6f 20 72 65 2d " Failed to re-
11270 63 72 65 61 74 65 20 6c 69 6e 6b 20 22 20 6c 6e create link " ln
11280 6b 74 61 72 67 65 74 20 28 28 63 6f 6e 64 69 74 ktarget ((condit
11290 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
112a0 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
112b0 61 67 65 29 20 65 78 6e 29 20 22 2c 20 65 78 69 age) exn) ", exi
112c0 74 69 6e 67 2c 20 65 78 6e 3d 22 20 65 78 6e 29 ting, exn=" exn)
112d0 0a 09 20 20 20 20 20 28 65 78 69 74 29 29 0a 09 .. (exit))..
112e0 20 20 20 28 69 66 20 28 73 79 6d 62 6f 6c 69 63 (if (symbolic
112f0 2d 6c 69 6e 6b 3f 20 6c 6e 6b 74 61 72 67 65 74 -link? lnktarget
11300 29 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 ) (delete-fi
11310 6c 65 20 6c 6e 6b 74 61 72 67 65 74 29 29 0a 09 le lnktarget))..
11320 20 20 20 28 69 66 20 28 6e 6f 74 20 28 63 6f 6d (if (not (com
11330 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
11340 20 6c 6e 6b 74 61 72 67 65 74 29 29 20 28 63 72 lnktarget)) (cr
11350 65 61 74 65 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 eate-symbolic-li
11360 6e 6b 20 74 65 73 74 2d 70 61 74 68 20 6c 6e 6b nk test-path lnk
11370 74 61 72 67 65 74 29 29 29 29 29 0a 0a 20 20 20 target)))))..
11380 20 28 69 66 20 28 6e 6f 74 20 28 64 69 72 65 63 (if (not (direc
11390 74 6f 72 79 3f 20 74 65 73 74 2d 70 61 74 68 29 tory? test-path)
113a0 29 0a 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 )..(create-direc
113b0 74 6f 72 79 20 74 65 73 74 2d 70 61 74 68 20 23 tory test-path #
113c0 74 29 29 20 3b 3b 20 74 68 69 73 20 69 73 20 61 t)) ;; this is a
113d0 20 68 61 63 6b 2c 20 49 20 64 6f 6e 27 74 20 6b hack, I don't k
113e0 6e 6f 77 20 77 68 79 20 6f 75 74 20 6f 66 20 74 now why out of t
113f0 68 65 20 62 6c 75 65 20 74 68 69 73 20 70 61 74 he blue this pat
11400 68 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 h does not exist
11410 20 73 6f 6d 65 74 69 6d 65 73 0a 0a 20 20 20 20 sometimes..
11420 28 69 66 20 28 61 6e 64 20 74 65 73 74 2d 73 72 (if (and test-sr
11430 63 2d 70 61 74 68 20 28 64 69 72 65 63 74 6f 72 c-path (director
11440 79 3f 20 74 65 73 74 2d 70 61 74 68 29 29 0a 09 y? test-path))..
11450 28 62 65 67 69 6e 0a 09 20 20 28 6c 61 75 6e 63 (begin.. (launc
11460 68 3a 74 65 73 74 2d 63 6f 70 79 20 74 65 73 74 h:test-copy test
11470 2d 73 72 63 2d 70 61 74 68 20 74 65 73 74 2d 70 -src-path test-p
11480 61 74 68 29 0a 09 20 20 28 6c 69 73 74 20 6c 6e ath).. (list ln
11490 6b 70 61 74 68 66 20 6c 6e 6b 70 61 74 68 20 29 kpathf lnkpath )
114a0 29 0a 09 28 69 66 20 28 61 6e 64 20 74 65 73 74 )..(if (and test
114b0 2d 73 72 63 2d 70 61 74 68 20 28 3e 20 72 65 6d -src-path (> rem
114c0 74 72 69 65 73 20 30 29 29 0a 09 20 20 20 20 28 tries 0)).. (
114d0 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
114e0 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
114f0 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
11500 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 ort* "Failed to
11510 63 72 65 61 74 65 20 77 6f 72 6b 20 61 72 65 61 create work area
11520 20 61 74 20 22 20 74 65 73 74 2d 70 61 74 68 20 at " test-path
11530 22 20 77 69 74 68 20 6c 69 6e 6b 20 61 74 20 22 " with link at "
11540 20 6c 6e 6b 74 61 72 67 65 74 20 22 2c 20 72 65 lnktarget ", re
11550 6d 61 69 6e 69 6e 67 20 61 74 74 65 6d 70 74 73 maining attempts
11560 20 22 20 72 65 6d 74 72 69 65 73 29 0a 09 20 20 " remtries)..
11570 20 20 20 20 3b 3b 20 0a 09 20 20 20 20 20 20 28 ;; .. (
11580 63 72 65 61 74 65 2d 77 6f 72 6b 2d 61 72 65 61 create-work-area
11590 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f run-id run-info
115a0 20 6b 65 79 76 61 6c 73 20 74 65 73 74 2d 69 64 keyvals test-id
115b0 20 74 65 73 74 2d 73 72 63 2d 70 61 74 68 20 64 test-src-path d
115c0 69 73 6b 2d 70 61 74 68 20 74 65 73 74 6e 61 6d isk-path testnam
115d0 65 20 69 74 65 6d 64 61 74 20 72 65 6d 74 72 69 e itemdat remtri
115e0 65 73 3a 20 28 2d 20 72 65 6d 74 72 69 65 73 20 es: (- remtries
115f0 31 29 29 29 0a 09 20 20 20 20 28 6c 69 73 74 20 1))).. (list
11600 23 66 20 23 66 29 29 29 29 29 0a 0a 0a 28 64 65 #f #f)))))...(de
11610 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 68 61 6e fine (launch:han
11620 64 6c 65 2d 7a 6f 6d 62 69 65 2d 74 65 73 74 73 dle-zombie-tests
11630 20 72 75 6e 2d 69 64 29 0a 20 20 28 6c 65 74 2a run-id). (let*
11640 20 28 28 6b 65 79 20 28 63 6f 6e 63 20 22 7a 6f ((key (conc "zo
11650 6d 62 69 65 73 63 61 6e 2d 72 75 6e 69 64 2d 22 mbiescan-runid-"
11660 72 75 6e 2d 69 64 29 29 0a 20 20 20 20 20 20 20 run-id)).
11670 20 20 28 6e 6f 77 20 28 63 75 72 72 65 6e 74 2d (now (current-
11680 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 seconds)).
11690 20 20 20 28 74 68 72 65 73 68 6f 6c 64 20 28 2d (threshold (-
116a0 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
116b0 73 29 20 20 28 2a 20 32 20 28 6f 72 20 28 63 6f s) (* 2 (or (co
116c0 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d nfigf:lookup-num
116d0 62 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 ber *configdat*
116e0 22 73 65 74 75 70 22 20 22 64 65 61 64 74 69 6d "setup" "deadtim
116f0 65 22 29 20 31 32 30 29 29 29 29 0a 20 20 20 20 e") 120)))).
11700 20 20 20 20 20 28 76 61 6c 20 28 72 6d 74 3a 67 (val (rmt:g
11710 65 74 2d 76 61 72 20 6b 65 79 29 29 0a 20 20 20 et-var key)).
11720 20 20 20 20 20 20 28 64 6f 2d 73 63 61 6e 3f 0a (do-scan?.
11730 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
11740 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f 74 ((not
11750 20 76 61 6c 29 0a 20 20 20 20 20 20 20 20 20 20 val).
11760 20 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 #t).
11770 20 28 28 3c 20 76 61 6c 20 74 68 72 65 73 68 6f ((< val thresho
11780 6c 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ld).
11790 23 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 #t). (
117a0 65 6c 73 65 20 23 66 29 29 29 29 0a 20 20 20 20 else #f)))).
117b0 28 77 68 65 6e 20 64 6f 2d 73 63 61 6e 3f 0a 20 (when do-scan?.
117c0 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
117d0 74 20 31 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 1 *default-log
117e0 2d 70 6f 72 74 2a 20 22 49 4e 46 4f 3a 20 73 65 -port* "INFO: se
117f0 61 72 63 68 20 61 6e 64 20 6d 61 72 6b 20 7a 6f arch and mark zo
11800 6d 62 69 65 20 74 65 73 74 73 22 29 0a 20 20 20 mbie tests").
11810 20 20 20 28 72 6d 74 3a 73 65 74 2d 76 61 72 20 (rmt:set-var
11820 6b 65 79 20 28 63 75 72 72 65 6e 74 2d 73 65 63 key (current-sec
11830 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 28 72 6d onds)). (rm
11840 74 3a 66 69 6e 64 2d 61 6e 64 2d 6d 61 72 6b 2d t:find-and-mark-
11850 69 6e 63 6f 6d 70 6c 65 74 65 20 72 75 6e 2d 69 incomplete run-i
11860 64 20 23 66 29 29 29 29 0a 0a 0a 28 64 65 66 73 d #f))))...(defs
11870 74 72 75 63 74 20 6c 61 75 6e 63 68 3a 61 6a 74 truct launch:ajt
11880 0a 20 20 28 76 61 72 73 20 27 28 29 29 0a 20 20 . (vars '()).
11890 28 65 78 65 6b 65 79 20 23 66 29 0a 20 20 28 68 (exekey #f). (h
118a0 6f 73 74 2d 74 79 70 65 20 23 66 29 0a 20 20 28 ost-type #f). (
118b0 74 65 73 74 2d 73 69 67 20 20 23 66 29 0a 20 20 test-sig #f).
118c0 28 63 6d 64 6c 69 6e 65 20 20 20 23 66 29 29 0a (cmdline #f)).
118d0 0a 3b 3b 20 61 70 70 65 6e 64 20 76 61 72 73 0a .;; append vars.
118e0 28 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a (define (launch:
118f0 61 6a 74 2d 61 64 64 2d 76 61 72 73 20 64 61 74 ajt-add-vars dat
11900 20 76 61 72 73 29 0a 20 20 28 6c 61 75 6e 63 68 vars). (launch
11910 3a 61 6a 74 2d 76 61 72 73 2d 73 65 74 21 20 64 :ajt-vars-set! d
11920 61 74 20 28 61 70 70 65 6e 64 20 28 6c 61 75 6e at (append (laun
11930 63 68 3a 61 6a 74 2d 76 61 72 73 20 64 61 74 29 ch:ajt-vars dat)
11940 20 76 61 72 73 29 29 29 0a 0a 3b 3b 20 31 2e 20 vars)))..;; 1.
11950 6c 6f 6f 6b 20 74 68 6f 75 67 68 20 64 69 73 6b look though disk
11960 73 20 6c 69 73 74 20 66 6f 72 20 64 69 73 6b 20 s list for disk
11970 77 69 74 68 20 6d 6f 73 74 20 73 70 61 63 65 0a with most space.
11980 3b 3b 20 32 2e 20 63 72 65 61 74 65 20 72 75 6e ;; 2. create run
11990 20 64 69 72 20 6f 6e 20 64 69 73 6b 2c 20 70 61 dir on disk, pa
119a0 74 68 20 6e 61 6d 65 20 69 73 20 6d 65 61 6e 69 th name is meani
119b0 6e 67 66 75 6c 0a 3b 3b 20 33 2e 20 63 72 65 61 ngful.;; 3. crea
119c0 74 65 20 6c 69 6e 6b 20 66 72 6f 6d 20 72 75 6e te link from run
119d0 20 64 69 72 20 74 6f 20 6d 65 67 61 74 65 73 74 dir to megatest
119e0 20 72 75 6e 73 20 61 72 65 61 20 0a 3b 3b 20 34 runs area .;; 4
119f0 2e 20 72 65 6d 6f 74 65 6c 79 20 72 75 6e 20 74 . remotely run t
11a00 68 65 20 74 65 73 74 20 6f 6e 20 61 6c 6c 6f 63 he test on alloc
11a10 61 74 65 64 20 68 6f 73 74 0a 3b 3b 20 20 20 20 ated host.;;
11a20 2d 20 63 6f 75 6c 64 20 62 65 20 73 73 68 20 74 - could be ssh t
11a30 6f 20 68 6f 73 74 20 66 72 6f 6d 20 68 6f 73 74 o host from host
11a40 73 20 74 61 62 6c 65 20 28 75 70 64 61 74 65 20 s table (update
11a50 72 65 67 75 6c 61 72 6c 79 20 77 69 74 68 20 6c regularly with l
11a60 6f 61 64 29 0a 3b 3b 20 20 20 20 2d 20 63 6f 75 oad).;; - cou
11a70 6c 64 20 62 65 20 6e 65 74 62 61 74 63 68 0a 3b ld be netbatch.;
11a80 3b 20 20 20 20 20 20 28 6c 61 75 6e 63 68 2d 74 ; (launch-t
11a90 65 73 74 20 64 62 20 28 63 61 64 72 20 73 74 61 est db (cadr sta
11aa0 74 75 73 29 20 74 65 73 74 2d 63 6f 6e 66 29 29 tus) test-conf))
11ab0 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 .(define (launch
11ac0 2d 74 65 73 74 20 74 65 73 74 2d 69 64 20 72 75 -test test-id ru
11ad0 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 n-id run-info ke
11ae0 79 76 61 6c 73 20 72 75 6e 6e 61 6d 65 20 74 65 yvals runname te
11af0 73 74 2d 63 6f 6e 66 20 74 65 73 74 2d 6e 61 6d st-conf test-nam
11b00 65 20 74 65 73 74 2d 70 61 74 68 20 69 74 65 6d e test-path item
11b10 64 61 74 20 70 61 72 61 6d 73 29 0a 20 20 28 6d dat params). (m
11b20 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 6c 61 75 6e utex-lock! *laun
11b30 63 68 2d 73 65 74 75 70 2d 6d 75 74 65 78 2a 29 ch-setup-mutex*)
11b40 20 3b 3b 20 73 65 74 74 69 6e 67 20 76 61 72 69 ;; setting vari
11b50 61 62 6c 65 73 20 61 6e 64 20 70 72 6f 63 65 73 ables and proces
11b60 73 69 6e 67 20 74 68 65 20 74 65 73 74 63 6f 6e sing the testcon
11b70 66 69 67 20 69 73 20 4e 4f 54 20 74 68 72 65 61 fig is NOT threa
11b80 64 2d 73 61 66 65 2c 20 72 65 75 73 65 20 74 68 d-safe, reuse th
11b90 65 20 6c 61 75 6e 63 68 2d 73 65 74 75 70 20 6d e launch-setup m
11ba0 75 74 65 78 0a 20 20 28 6c 65 74 2a 20 28 3b 3b utex. (let* (;;
11bb0 20 6c 6f 63 6b 69 6e 67 20 63 6f 64 65 20 72 65 locking code re
11bc0 6d 6f 76 65 64 20 66 72 6f 6d 20 68 65 72 65 20 moved from here
11bd0 63 6f 6d 6d 65 6e 74 65 64 20 6f 75 74 20 61 6e commented out an
11be0 64 20 70 61 73 74 65 64 20 61 74 20 65 6e 64 20 d pasted at end
11bf0 6f 66 20 66 69 6c 65 0a 09 20 28 69 74 65 6d 2d of file.. (item-
11c00 70 61 74 68 20 20 20 20 20 20 20 28 69 74 65 6d path (item
11c10 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d -list->path item
11c20 64 61 74 29 29 0a 09 20 28 63 6f 6e 74 6f 75 72 dat)).. (contour
11c30 20 20 20 20 20 20 20 20 20 23 66 29 20 20 20 20 #f)
11c40 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
11c50 20 20 20 20 20 3b 3b 20 4e 4f 54 20 52 45 41 44 ;; NOT READ
11c60 59 20 46 4f 52 20 54 48 49 53 20 28 61 72 67 73 Y FOR THIS (args
11c70 3a 67 65 74 2d 61 72 67 20 22 2d 63 6f 6e 74 6f :get-arg "-conto
11c80 75 72 22 29 29 29 0a 09 20 3b 3b 20 6c 61 75 6e ur"))).. ;; laun
11c90 63 68 65 72 2d 6d 6f 64 65 20 77 69 6c 6c 20 62 cher-mode will b
11ca0 65 20 27 61 64 6a 75 74 61 6e 74 20 6f 72 20 27 e 'adjutant or '
11cb0 6e 6f 72 6d 61 6c 0a 09 20 28 6c 61 75 6e 63 68 normal.. (launch
11cc0 65 72 2d 6d 6f 64 65 20 20 20 28 73 74 72 69 6e er-mode (strin
11cd0 67 2d 3e 73 79 6d 62 6f 6c 20 28 6f 72 20 28 63 g->symbol (or (c
11ce0 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
11cf0 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f onfigdat* "jobto
11d00 6f 6c 73 22 20 22 6d 6f 64 65 22 29 20 22 6e 6f ols" "mode") "no
11d10 72 6d 61 6c 22 29 29 29 0a 09 20 28 61 6a 74 64 rmal"))).. (ajtd
11d20 61 74 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b at (mak
11d30 65 2d 6c 61 75 6e 63 68 3a 61 6a 74 29 29 29 0a e-launch:ajt))).
11d40 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
11d50 64 65 6c 74 61 20 20 20 20 20 20 20 20 28 2d 20 delta (-
11d60 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
11d70 29 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a 29 ) *last-launch*)
11d80 29 0a 09 20 20 20 20 20 20 20 28 6c 61 75 6e 63 ).. (launc
11d90 68 2d 64 65 6c 61 79 20 28 63 6f 6e 66 69 67 66 h-delay (configf
11da0 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 65 72 20 2a :lookup-number *
11db0 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
11dc0 70 22 20 22 6c 61 75 6e 63 68 2d 64 65 6c 61 79 p" "launch-delay
11dd0 22 20 64 65 66 61 75 6c 74 3a 20 30 29 29 29 0a " default: 0))).
11de0 20 20 20 20 20 20 28 69 66 20 28 3e 20 6c 61 75 (if (> lau
11df0 6e 63 68 2d 64 65 6c 61 79 20 64 65 6c 74 61 29 nch-delay delta)
11e00 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 .. (begin..
11e10 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
11e20 6e 6f 69 73 65 2d 70 72 69 6e 74 20 31 32 30 30 noise-print 1200
11e30 20 22 74 65 73 74 20 6c 61 75 6e 63 68 20 64 65 "test launch de
11e40 6c 61 79 22 29 20 3b 3b 20 65 76 65 72 79 20 74 lay") ;; every t
11e50 77 6f 20 68 6f 75 72 73 20 6f 72 20 73 6f 20 72 wo hours or so r
11e60 65 6d 69 6e 64 20 74 68 65 20 75 73 65 72 20 61 emind the user a
11e70 62 6f 75 74 20 6c 61 75 6e 63 68 20 64 65 6c 61 bout launch dela
11e80 79 2e 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e y....(debug:prin
11e90 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
11ea0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4e 4f 54 t-log-port* "NOT
11eb0 45 3a 20 74 65 73 74 20 6c 61 75 6e 63 68 65 73 E: test launches
11ec0 20 61 72 65 20 64 65 6c 61 79 65 64 20 62 79 20 are delayed by
11ed0 22 20 6c 61 75 6e 63 68 2d 64 65 6c 61 79 20 22 " launch-delay "
11ee0 20 73 65 63 6f 6e 64 73 2e 20 53 65 65 20 6d 65 seconds. See me
11ef0 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 6c 61 gatest.config la
11f00 75 6e 63 68 2d 64 65 6c 61 79 20 73 65 74 74 69 unch-delay setti
11f10 6e 67 20 74 6f 20 61 64 6a 75 73 74 2e 22 29 29 ng to adjust."))
11f20 20 3b 3b 20 6c 61 75 6e 63 68 20 6f 66 20 22 20 ;; launch of "
11f30 74 65 73 74 2d 6e 61 6d 65 20 22 20 66 6f 72 20 test-name " for
11f40 22 20 28 2d 20 6c 61 75 6e 63 68 2d 64 65 6c 61 " (- launch-dela
11f50 79 20 64 65 6c 74 61 29 20 22 20 73 65 63 6f 6e y delta) " secon
11f60 64 73 22 29 29 0a 09 20 20 20 20 28 74 68 72 65 ds")).. (thre
11f70 61 64 2d 73 6c 65 65 70 21 20 28 2d 20 6c 61 75 ad-sleep! (- lau
11f80 6e 63 68 2d 64 65 6c 61 79 20 64 65 6c 74 61 29 nch-delay delta)
11f90 29 0a 09 20 20 20 20 28 6c 6f 6f 70 20 28 2d 20 ).. (loop (-
11fa0 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
11fb0 29 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a 29 ) *last-launch*)
11fc0 20 6c 61 75 6e 63 68 2d 64 65 6c 61 79 29 29 29 launch-delay)))
11fd0 29 0a 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 ). (change-di
11fe0 72 65 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 rectory *toppath
11ff0 2a 29 0a 20 20 20 20 28 6c 65 74 20 28 28 76 61 *). (let ((va
12000 72 2d 6c 69 73 74 20 28 61 70 70 65 6e 64 0a 09 r-list (append..
12010 09 20 20 20 20 20 28 6c 69 73 74 0a 09 09 20 20 . (list...
12020 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f 52 55 (list "MT_RU
12030 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 2a 74 6f N_AREA_HOME" *to
12040 70 70 61 74 68 2a 29 0a 09 09 20 20 20 20 20 20 ppath*)...
12050 28 6c 69 73 74 20 22 4d 54 5f 54 45 53 54 5f 4e (list "MT_TEST_N
12060 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 29 0a AME" test-name).
12070 09 09 20 20 20 20 20 20 28 6c 69 73 74 20 22 4d .. (list "M
12080 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e T_RUNNAME" run
12090 6e 61 6d 65 29 0a 09 09 20 20 20 20 20 20 28 6c name)... (l
120a0 69 73 74 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 ist "MT_ITEMPATH
120b0 22 20 20 69 74 65 6d 2d 70 61 74 68 29 0a 09 09 " item-path)...
120c0 20 20 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f (list "MT_
120d0 43 4f 4e 54 4f 55 52 22 20 20 20 63 6f 6e 74 6f CONTOUR" conto
120e0 75 72 29 0a 09 09 20 20 20 20 20 20 29 0a 09 09 ur)... )...
120f0 20 20 20 20 20 69 74 65 6d 64 61 74 29 29 29 0a itemdat))).
12100 20 20 20 20 20 20 20 3b 3b 20 63 6f 6e 73 6f 6c ;; consol
12110 69 64 61 74 65 20 74 68 69 73 20 63 6f 64 65 20 idate this code
12120 77 69 74 68 20 74 68 65 20 63 6f 64 65 20 69 6e with the code in
12130 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 20 66 6f megatest.scm fo
12140 72 0a 20 20 20 20 20 20 20 3b 3b 20 22 2d 65 78 r. ;; "-ex
12150 65 63 75 74 65 22 2c 20 2a 6d 61 79 62 65 2a 20 ecute", *maybe*
12160 2d 20 74 68 65 20 6c 6f 6e 67 65 72 20 74 68 65 - the longer the
12170 79 20 61 72 65 20 73 65 74 20 74 68 65 20 6c 6f y are set the lo
12180 6e 67 65 72 0a 20 20 20 20 20 20 20 3b 3b 20 65 nger. ;; e
12190 61 63 68 20 6c 61 75 6e 63 68 20 74 61 6b 65 73 ach launch takes
121a0 20 28 6d 75 73 74 20 62 65 20 6e 6f 6e 2d 6f 76 (must be non-ov
121b0 65 72 6c 61 70 70 69 6e 67 20 77 69 74 68 20 74 erlapping with t
121c0 68 65 20 76 61 72 73 29 0a 20 20 20 20 20 20 28 he vars). (
121d0 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 alist->env-vars
121e0 76 61 72 2d 6c 69 73 74 29 0a 20 20 20 20 20 20 var-list).
121f0 3b 3b 20 74 68 65 20 76 61 72 2d 6c 69 73 74 20 ;; the var-list
12200 69 6e 74 6f 20 74 68 65 20 61 6a 74 64 61 74 20 into the ajtdat
12210 61 64 6a 75 74 61 6e 74 20 72 65 63 6f 72 64 20 adjutant record
12220 77 68 65 74 68 65 72 20 69 74 20 69 73 20 6e 65 whether it is ne
12230 65 64 65 64 20 6f 72 20 6e 6f 74 2e 0a 20 20 20 eded or not..
12240 20 20 20 28 6c 61 75 6e 63 68 3a 61 6a 74 2d 61 (launch:ajt-a
12250 64 64 2d 76 61 72 73 20 61 6a 74 64 61 74 20 76 dd-vars ajtdat v
12260 61 72 2d 6c 69 73 74 29 29 0a 20 20 20 20 0a 20 ar-list)). .
12270 20 20 20 28 6c 65 74 2a 20 28 28 74 72 65 67 69 (let* ((tregi
12280 73 74 72 79 20 20 20 20 20 20 20 28 74 65 73 74 stry (test
12290 73 3a 67 65 74 2d 61 6c 6c 29 29 20 3b 3b 20 74 s:get-all)) ;; t
122a0 68 69 72 64 20 70 61 72 61 6d 20 28 62 65 6c 6f hird param (belo
122b0 77 29 20 69 73 20 73 79 73 74 65 6d 2d 61 6c 6c w) is system-all
122c0 6f 77 65 64 0a 20 20 20 20 20 20 20 20 20 20 20 owed.
122d0 3b 3b 20 66 6f 72 20 74 63 6f 6e 66 69 67 2c 20 ;; for tconfig,
122e0 77 68 79 20 64 6f 20 77 65 20 61 6c 6c 6f 77 20 why do we allow
122f0 66 61 6c 6c 62 61 63 6b 20 74 6f 20 74 65 73 74 fallback to test
12300 2d 63 6f 6e 66 3f 0a 09 20 20 20 28 74 63 6f 6e -conf?.. (tcon
12310 66 69 67 20 20 20 20 20 20 20 20 20 28 6f 72 20 fig (or
12320 28 74 65 73 74 73 3a 67 65 74 2d 74 65 73 74 63 (tests:get-testc
12330 6f 6e 66 69 67 20 74 65 73 74 2d 6e 61 6d 65 20 onfig test-name
12340 69 74 65 6d 2d 70 61 74 68 20 74 72 65 67 69 73 item-path tregis
12350 74 72 79 20 23 74 20 66 6f 72 63 65 2d 63 72 65 try #t force-cre
12360 61 74 65 3a 20 23 74 29 0a 09 09 09 09 28 62 65 ate: #t).....(be
12370 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
12380 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12390 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
123a0 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
123b0 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
123c0 3a 20 66 61 6c 6c 69 6e 67 20 62 61 63 6b 20 74 : falling back t
123d0 6f 20 70 72 65 2d 63 61 6c 63 75 6c 61 74 65 64 o pre-calculated
123e0 20 74 65 73 74 63 6f 6e 66 69 67 2e 20 54 68 69 testconfig. Thi
123f0 73 20 69 73 20 6c 69 6b 65 6c 79 20 6e 6f 74 20 s is likely not
12400 64 65 73 69 72 65 64 2e 22 29 0a 20 20 20 20 20 desired.").
12410 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
12420 20 20 20 20 20 20 20 20 20 20 20 20 20 74 65 73 tes
12430 74 2d 63 6f 6e 66 29 29 29 20 3b 3b 20 66 6f 72 t-conf))) ;; for
12440 63 65 20 72 65 2d 72 65 61 64 20 6e 6f 77 20 74 ce re-read now t
12450 68 61 74 20 61 6c 6c 20 76 61 72 73 20 61 72 65 hat all vars are
12460 20 73 65 74 0a 09 20 20 20 28 75 73 65 73 68 65 set.. (useshe
12470 6c 6c 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 ll (let (
12480 28 75 73 68 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (ush (configf:lo
12490 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
124a0 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 20 20 20 20 "jobtools"
124b0 22 75 73 65 73 68 65 6c 6c 22 29 29 29 0a 09 09 "useshell")))...
124c0 09 20 20 20 20 20 20 28 69 66 20 75 73 68 20 0a . (if ush .
124d0 09 09 09 09 20 20 28 69 66 20 28 65 71 75 61 6c .... (if (equal
124e0 3f 20 75 73 68 20 22 6e 6f 22 29 20 3b 3b 20 6d ? ush "no") ;; m
124f0 75 73 74 20 75 73 65 20 22 6e 6f 22 20 74 6f 20 ust use "no" to
12500 4e 4f 54 20 75 73 65 20 73 68 65 6c 6c 0a 09 09 NOT use shell...
12510 09 09 20 20 20 20 20 20 23 66 0a 09 09 09 09 20 .. #f.....
12520 20 20 20 20 20 75 73 68 29 0a 09 09 09 09 20 20 ush).....
12530 23 74 29 29 29 20 20 20 20 20 3b 3b 20 64 65 66 #t))) ;; def
12540 61 75 6c 74 20 69 73 20 79 65 73 0a 09 20 20 20 ault is yes..
12550 28 72 75 6e 73 63 72 69 70 74 20 20 20 20 20 20 (runscript
12560 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
12570 20 74 63 6f 6e 66 69 67 20 20 20 22 73 65 74 75 tconfig "setu
12580 70 22 20 20 20 20 20 20 20 20 22 72 75 6e 73 63 p" "runsc
12590 72 69 70 74 22 29 29 0a 09 20 20 20 28 65 7a 73 ript")).. (ezs
125a0 74 65 70 73 20 20 20 20 20 20 20 20 20 28 3e 20 teps (>
125b0 28 6c 65 6e 67 74 68 20 28 68 61 73 68 2d 74 61 (length (hash-ta
125c0 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
125d0 74 63 6f 6e 66 69 67 20 22 65 7a 73 74 65 70 73 tconfig "ezsteps
125e0 22 20 27 28 29 29 29 20 30 29 29 20 3b 3b 20 64 " '())) 0)) ;; d
125f0 6f 6e 27 74 20 73 65 6e 64 20 61 6c 6c 20 74 68 on't send all th
12600 65 20 73 74 65 70 73 2c 20 63 6f 75 6c 64 20 62 e steps, could b
12610 65 20 62 69 67 2c 20 6a 75 73 74 20 73 65 6e 64 e big, just send
12620 20 61 20 66 6c 61 67 0a 09 20 20 20 28 73 75 62 a flag.. (sub
12630 72 75 6e 20 20 20 20 20 20 20 20 20 20 28 3e 20 run (>
12640 28 6c 65 6e 67 74 68 20 28 68 61 73 68 2d 74 61 (length (hash-ta
12650 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
12660 74 63 6f 6e 66 69 67 20 22 73 75 62 72 75 6e 22 tconfig "subrun"
12670 20 20 27 28 29 29 29 20 30 29 29 20 3b 3b 20 73 '())) 0)) ;; s
12680 65 6e 64 20 61 20 66 6c 61 67 20 74 6f 20 70 72 end a flag to pr
12690 6f 63 65 73 73 20 61 20 73 75 62 72 75 6e 0a 09 ocess a subrun..
126a0 20 20 20 3b 3b 20 28 64 69 73 6b 73 70 61 63 65 ;; (diskspace
126b0 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a (configf:
126c0 6c 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 20 lookup tconfig
126d0 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 "requirements"
126e0 22 64 69 73 6b 73 70 61 63 65 22 29 29 0a 09 20 "diskspace"))..
126f0 20 20 3b 3b 20 28 6d 65 6d 6f 72 79 20 20 20 20 ;; (memory
12700 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c (configf:l
12710 6f 6f 6b 75 70 20 74 63 6f 6e 66 69 67 20 20 20 ookup tconfig
12720 22 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 "requirements" "
12730 6d 65 6d 6f 72 79 22 29 29 0a 09 20 20 20 3b 3b memory")).. ;;
12740 20 28 68 6f 73 74 73 20 20 20 20 20 20 20 20 20 (hosts
12750 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
12760 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a p *configdat* "j
12770 6f 62 74 6f 6f 6c 73 22 20 20 20 20 20 22 77 6f obtools" "wo
12780 72 6b 68 6f 73 74 73 22 29 29 20 3b 3b 20 49 27 rkhosts")) ;; I'
12790 6d 20 70 72 65 74 74 79 20 73 75 72 65 20 74 68 m pretty sure th
127a0 69 73 20 77 61 73 20 6e 65 76 65 72 20 63 6f 6d is was never com
127b0 70 6c 65 74 65 64 0a 09 20 20 20 28 72 65 6d 6f pleted.. (remo
127c0 74 65 2d 6d 65 67 61 74 65 73 74 20 28 63 6f 6e te-megatest (con
127d0 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
127e0 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
127f0 22 65 78 65 63 75 74 61 62 6c 65 22 29 29 0a 09 "executable"))..
12800 20 20 20 28 72 75 6e 2d 74 69 6d 65 2d 6c 69 6d (run-time-lim
12810 69 74 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 it (or (configf
12820 3a 6c 6f 6f 6b 75 70 20 20 74 63 6f 6e 66 69 67 :lookup tconfig
12830 20 20 20 22 72 65 71 75 69 72 65 6d 65 6e 74 73 "requirements
12840 22 20 22 72 75 6e 74 69 6d 65 6c 69 6d 22 29 0a " "runtimelim").
12850 09 09 09 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ....(configf:loo
12860 6b 75 70 20 20 2a 63 6f 6e 66 69 67 64 61 74 2a kup *configdat*
12870 20 22 73 65 74 75 70 22 20 22 72 75 6e 74 69 6d "setup" "runtim
12880 65 6c 69 6d 22 29 29 29 0a 09 20 20 20 28 6c 6f elim"))).. (lo
12890 63 61 6c 2d 6d 65 67 61 74 65 73 74 20 20 28 63 cal-megatest (c
128a0 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 6c 6f 63 61 6c ommon:find-local
128b0 2d 6d 65 67 61 74 65 73 74 29 29 0a 09 20 20 20 -megatest))..
128c0 28 6c 61 75 6e 63 68 65 72 20 20 20 20 20 20 20 (launcher
128d0 20 28 6c 65 74 20 28 28 6c 20 28 63 6f 6d 6d 6f (let ((l (commo
128e0 6e 3a 67 65 74 2d 6c 61 75 6e 63 68 65 72 20 2a n:get-launcher *
128f0 63 6f 6e 66 69 67 64 61 74 2a 20 74 65 73 74 2d configdat* test-
12900 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 20 6c name item-path l
12910 61 75 6e 63 68 65 72 2d 6d 6f 64 65 29 29 29 0a auncher-mode))).
12920 09 09 09 20 20 20 20 20 20 28 69 66 20 28 73 74 ... (if (st
12930 72 69 6e 67 3f 20 6c 29 0a 09 09 09 09 20 20 28 ring? l)..... (
12940 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 29 0a string-split l).
12950 09 09 09 09 20 20 6c 29 29 29 20 3b 3b 20 73 6f .... l))) ;; so
12960 6d 65 20 6e 6f 6e 68 6f 6d 6f 67 65 6e 75 69 74 me nonhomogenuit
12970 79 20 68 65 72 65 2e 20 27 28 63 6d 64 20 70 61 y here. '(cmd pa
12980 72 61 6d 31 20 70 61 72 61 6d 32 20 2e 2e 2e 29 ram1 param2 ...)
12990 20 4f 52 20 27 28 68 6f 73 74 2d 74 79 70 65 20 OR '(host-type
129a0 6c 61 75 6e 63 68 65 72 29 0a 09 20 20 20 20 3b launcher).. ;
129b0 3b 20 28 69 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 ; (item-list->pa
129c0 74 68 20 69 74 65 6d 64 61 74 29 29 29 20 3b 3b th itemdat))) ;;
129d0 20 74 65 73 74 2d 70 61 74 68 20 69 73 20 74 68 test-path is th
129e0 65 20 66 75 6c 6c 20 70 61 74 68 20 69 6e 63 6c e full path incl
129f0 75 64 69 6e 67 20 74 68 65 20 69 74 65 6d 2d 70 uding the item-p
12a00 61 74 68 0a 09 20 20 20 28 74 65 73 74 2d 73 69 ath.. (test-si
12a10 67 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 28 g (conc (
12a20 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 common:get-tests
12a30 75 69 74 65 2d 6e 61 6d 65 29 20 22 3a 22 20 74 uite-name) ":" t
12a40 65 73 74 2d 6e 61 6d 65 20 22 3a 22 20 69 74 65 est-name ":" ite
12a50 6d 2d 70 61 74 68 29 29 0a 09 20 20 20 28 77 6f m-path)).. (wo
12a60 72 6b 2d 61 72 65 61 20 20 20 20 20 20 20 23 66 rk-area #f
12a70 29 0a 09 20 20 20 28 74 6f 70 74 65 73 74 2d 77 ).. (toptest-w
12a80 6f 72 6b 2d 61 72 65 61 20 23 66 29 20 3b 3b 20 ork-area #f) ;;
12a90 66 6f 72 20 69 74 65 72 61 74 65 64 20 74 65 73 for iterated tes
12aa0 74 73 20 74 68 65 20 74 6f 70 20 74 65 73 74 20 ts the top test
12ab0 63 6f 6e 74 61 69 6e 73 20 64 61 74 61 20 72 65 contains data re
12ac0 6c 65 76 61 6e 74 20 66 6f 72 20 61 6c 6c 0a 09 levant for all..
12ad0 20 20 20 28 64 69 73 6b 70 61 74 68 20 20 20 23 (diskpath #
12ae0 66 29 0a 09 20 20 20 28 63 6d 64 70 61 72 6d 73 f).. (cmdparms
12af0 20 20 20 23 66 29 0a 09 20 20 20 28 66 75 6c 6c #f).. (full
12b00 63 6d 64 20 20 20 20 23 66 29 20 3b 3b 20 28 64 cmd #f) ;; (d
12b10 65 66 69 6e 65 20 61 20 28 77 69 74 68 2d 6f 75 efine a (with-ou
12b20 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 20 28 tput-to-string (
12b30 6c 61 6d 62 64 61 20 28 29 28 77 72 69 74 65 20 lambda ()(write
12b40 78 29 29 29 29 0a 09 20 20 20 28 6d 74 2d 62 69 x)))).. (mt-bi
12b50 6e 64 69 72 2d 70 61 74 68 20 23 66 29 0a 09 20 ndir-path #f)..
12b60 20 20 28 74 65 73 74 69 6e 66 6f 20 20 20 28 72 (testinfo (r
12b70 6d 74 3a 67 65 74 2d 74 65 73 74 2d 69 6e 66 6f mt:get-test-info
12b80 2d 62 79 2d 69 64 20 72 75 6e 2d 69 64 20 74 65 -by-id run-id te
12b90 73 74 2d 69 64 29 29 0a 09 20 20 20 28 6d 74 5f st-id)).. (mt_
12ba0 74 61 72 67 65 74 20 20 28 73 74 72 69 6e 67 2d target (string-
12bb0 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
12bc0 20 63 61 64 72 20 6b 65 79 76 61 6c 73 29 20 22 cadr keyvals) "
12bd0 2f 22 29 29 0a 09 20 20 20 28 64 65 62 75 67 2d /")).. (debug-
12be0 70 61 72 61 6d 20 28 61 70 70 65 6e 64 20 28 69 param (append (i
12bf0 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
12c00 22 2d 64 65 62 75 67 22 29 20 20 28 6c 69 73 74 "-debug") (list
12c10 20 22 2d 64 65 62 75 67 22 20 28 61 72 67 73 3a "-debug" (args:
12c20 67 65 74 2d 61 72 67 20 22 2d 64 65 62 75 67 22 get-arg "-debug"
12c30 29 29 20 27 28 29 29 0a 09 09 09 09 28 69 66 20 )) '()).....(if
12c40 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
12c50 6c 6f 67 67 69 6e 67 22 29 28 6c 69 73 74 20 22 logging")(list "
12c60 2d 6c 6f 67 67 69 6e 67 22 29 20 27 28 29 29 0a -logging") '()).
12c70 09 09 09 09 28 69 66 20 28 63 6f 6e 66 69 67 66 ....(if (configf
12c80 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
12c90 61 74 2a 20 22 6d 69 73 63 22 20 22 70 72 6f 66 at* "misc" "prof
12ca0 69 6c 65 73 77 22 29 0a 09 09 09 09 20 20 20 20 ilesw").....
12cb0 28 6c 69 73 74 20 28 63 6f 6e 66 69 67 66 3a 6c (list (configf:l
12cc0 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
12cd0 2a 20 22 6d 69 73 63 22 20 22 70 72 6f 66 69 6c * "misc" "profil
12ce0 65 73 77 22 29 29 0a 09 09 09 09 20 20 20 20 27 esw"))..... '
12cf0 28 29 29 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 ())))). ;;
12d00 73 61 76 65 20 74 68 65 20 74 65 73 74 2d 73 69 save the test-si
12d10 67 20 69 6e 20 74 68 65 20 61 6a 74 64 61 74 20 g in the ajtdat
12d20 72 65 63 6f 72 64 0a 20 20 20 20 20 20 28 6c 61 record. (la
12d30 75 6e 63 68 3a 61 6a 74 2d 74 65 73 74 2d 73 69 unch:ajt-test-si
12d40 67 2d 73 65 74 21 20 61 6a 74 64 61 74 20 74 65 g-set! ajtdat te
12d50 73 74 2d 73 69 67 29 0a 20 20 20 20 20 20 3b 3b st-sig). ;;
12d60 20 67 6f 20 61 68 65 61 64 20 61 6e 64 20 66 69 go ahead and fi
12d70 67 75 72 65 20 6f 75 74 20 69 66 20 77 65 20 68 gure out if we h
12d80 61 76 65 20 61 20 68 6f 73 74 2d 74 79 70 65 20 ave a host-type
12d90 66 72 6f 6d 20 74 68 65 0a 20 20 20 20 20 20 3b from the. ;
12da0 3b 20 6c 61 75 6e 63 68 65 72 20 63 61 6c 6c 20 ; launcher call
12db0 61 62 6f 76 65 20 61 6e 64 20 73 61 76 65 20 69 above and save i
12dc0 74 20 69 6e 20 74 68 65 20 61 6a 74 64 61 74 20 t in the ajtdat
12dd0 72 65 63 6f 72 64 0a 20 20 20 20 20 20 28 69 66 record. (if
12de0 20 28 61 6e 64 20 28 65 71 3f 20 6c 61 75 6e 63 (and (eq? launc
12df0 68 65 72 2d 6d 6f 64 65 20 27 61 64 6a 75 74 61 her-mode 'adjuta
12e00 6e 74 29 0a 09 20 20 20 20 20 20 20 28 6c 69 73 nt).. (lis
12e10 74 3f 20 6c 61 75 6e 63 68 65 72 29 0a 09 20 20 t? launcher)..
12e20 20 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 (> (length
12e30 6c 61 75 6e 63 68 65 72 29 20 31 29 29 0a 09 20 launcher) 1))..
12e40 20 28 6c 61 75 6e 63 68 3a 61 6a 74 2d 68 6f 73 (launch:ajt-hos
12e50 74 2d 74 79 70 65 2d 73 65 74 21 20 61 6a 74 64 t-type-set! ajtd
12e60 61 74 20 28 63 61 72 20 6c 61 75 6e 63 68 65 72 at (car launcher
12e70 29 29 29 0a 20 0a 20 20 20 20 20 20 3b 3b 20 28 ))). . ;; (
12e80 69 66 20 68 6f 73 74 73 20 28 73 65 74 21 20 68 if hosts (set! h
12e90 6f 73 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c osts (string-spl
12ea0 69 74 20 68 6f 73 74 73 29 29 29 0a 20 20 20 20 it hosts))).
12eb0 20 20 3b 3b 20 73 65 74 20 74 68 65 20 6d 65 67 ;; set the meg
12ec0 61 74 65 73 74 20 74 6f 20 62 65 20 63 61 6c 6c atest to be call
12ed0 65 64 20 6f 6e 20 74 68 65 20 72 65 6d 6f 74 65 ed on the remote
12ee0 20 68 6f 73 74 0a 20 20 20 20 20 20 28 69 66 20 host. (if
12ef0 28 6e 6f 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 (not remote-mega
12f00 74 65 73 74 29 28 73 65 74 21 20 72 65 6d 6f 74 test)(set! remot
12f10 65 2d 6d 65 67 61 74 65 73 74 20 6c 6f 63 61 6c e-megatest local
12f20 2d 6d 65 67 61 74 65 73 74 29 29 20 3b 3b 20 22 -megatest)) ;; "
12f30 6d 65 67 61 74 65 73 74 22 29 29 0a 20 20 20 20 megatest")).
12f40 20 20 28 73 65 74 21 20 6d 74 2d 62 69 6e 64 69 (set! mt-bindi
12f50 72 2d 70 61 74 68 20 28 70 61 74 68 6e 61 6d 65 r-path (pathname
12f60 2d 64 69 72 65 63 74 6f 72 79 20 72 65 6d 6f 74 -directory remot
12f70 65 2d 6d 65 67 61 74 65 73 74 29 29 0a 20 20 20 e-megatest)).
12f80 20 20 20 3b 3b 20 28 69 66 20 6c 61 75 6e 63 68 ;; (if launch
12f90 65 72 20 28 73 65 74 21 20 6c 61 75 6e 63 68 65 er (set! launche
12fa0 72 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 r (string-split
12fb0 6c 61 75 6e 63 68 65 72 29 29 29 20 20 20 20 20 launcher)))
12fc0 20 20 20 20 20 20 3b 3b 20 79 75 6b 21 0a 20 20 ;; yuk!.
12fd0 20 20 20 20 3b 3b 20 73 65 74 20 75 70 20 74 68 ;; set up th
12fe0 65 20 72 75 6e 20 77 6f 72 6b 20 61 72 65 61 20 e run work area
12ff0 66 6f 72 20 74 68 69 73 20 74 65 73 74 0a 20 20 for this test.
13000 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 61 72 (if (and (ar
13010 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 70 72 65 gs:get-arg "-pre
13020 63 6c 65 61 6e 22 29 20 3b 3b 20 75 73 65 72 20 clean") ;; user
13030 68 61 73 20 72 65 71 75 65 73 74 65 64 20 74 6f has requested to
13040 20 70 72 65 63 6c 65 61 6e 20 66 6f 72 20 74 68 preclean for th
13050 69 73 20 72 75 6e 0a 09 20 20 20 20 20 20 20 28 is run.. (
13060 6e 6f 74 20 28 6d 65 6d 62 65 72 20 28 64 62 3a not (member (db:
13070 74 65 73 74 2d 67 65 74 2d 72 75 6e 64 69 72 20 test-get-rundir
13080 74 65 73 74 69 6e 66 6f 29 28 6c 69 73 74 20 22 testinfo)(list "
13090 6e 2f 61 22 20 22 2f 74 6d 70 2f 62 61 64 6e 61 n/a" "/tmp/badna
130a0 6d 65 22 29 29 29 29 20 3b 3b 20 6e 2f 61 20 69 me")))) ;; n/a i
130b0 73 20 61 20 70 6c 61 63 65 68 6f 6c 64 65 72 20 s a placeholder
130c0 61 6e 64 20 74 68 75 73 20 6e 6f 74 20 61 20 72 and thus not a r
130d0 65 61 64 20 64 69 72 0a 09 20 20 28 62 65 67 69 ead dir.. (begi
130e0 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 n.. (debug:pr
130f0 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
13100 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 ult-log-port* "a
13110 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 70 72 65 ttempting to pre
13120 63 6c 65 61 6e 20 64 69 72 65 63 74 6f 72 79 20 clean directory
13130 22 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 72 " (db:test-get-r
13140 75 6e 64 69 72 20 74 65 73 74 69 6e 66 6f 29 20 undir testinfo)
13150 22 20 66 6f 72 20 74 65 73 74 20 22 20 74 65 73 " for test " tes
13160 74 2d 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 2d t-name "/" item-
13170 70 61 74 68 29 0a 09 20 20 20 20 28 72 75 6e 73 path).. (runs
13180 3a 72 65 6d 6f 76 65 2d 74 65 73 74 2d 64 69 72 :remove-test-dir
13190 65 63 74 6f 72 79 20 74 65 73 74 69 6e 66 6f 20 ectory testinfo
131a0 27 72 65 6d 6f 76 65 2d 64 61 74 61 2d 6f 6e 6c 'remove-data-onl
131b0 79 29 29 29 20 3b 3b 20 72 65 6d 6f 76 65 20 64 y))) ;; remove d
131c0 61 74 61 20 6f 6e 6c 79 2c 20 64 6f 20 6e 6f 74 ata only, do not
131d0 20 70 65 72 74 75 72 62 20 74 68 65 20 72 65 63 perturb the rec
131e0 6f 72 64 0a 20 20 20 20 20 20 0a 20 20 20 20 20 ord. .
131f0 20 3b 3b 20 70 72 65 76 65 6e 74 20 6f 76 65 72 ;; prevent over
13200 6c 61 70 70 69 6e 67 20 61 63 74 69 6f 6e 73 20 lapping actions
13210 2d 20 73 65 74 20 74 6f 20 4c 41 55 4e 43 48 45 - set to LAUNCHE
13220 44 20 61 73 20 65 61 72 6c 79 20 61 73 20 70 6f D as early as po
13230 73 73 69 62 6c 65 0a 20 20 20 20 20 20 3b 3b 0a ssible. ;;.
13240 20 20 20 20 20 20 3b 3b 20 74 68 65 20 66 6f 6c ;; the fol
13250 6c 6f 77 69 6e 67 20 63 61 6c 6c 20 68 61 6e 64 lowing call hand
13260 6c 65 73 20 77 61 69 76 65 72 20 70 72 6f 70 6f les waiver propo
13270 67 61 74 69 6f 6e 2e 20 63 61 6e 6e 6f 74 20 79 gation. cannot y
13280 65 74 20 63 6f 6e 64 65 6e 73 65 20 69 6e 74 6f et condense into
13290 20 72 6f 6c 6c 2d 75 70 2d 70 61 73 73 2d 66 61 roll-up-pass-fa
132a0 69 6c 0a 20 20 20 20 20 20 28 74 65 73 74 73 3a il. (tests:
132b0 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status!
132c0 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 69 64 20 run-id test-id
132d0 22 4c 41 55 4e 43 48 45 44 22 20 22 6e 2f 61 22 "LAUNCHED" "n/a"
132e0 20 23 66 20 23 66 29 20 3b 3b 20 28 69 66 20 6c #f #f) ;; (if l
132f0 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 20 6c 61 aunch-results la
13300 75 6e 63 68 2d 72 65 73 75 6c 74 73 20 22 46 41 unch-results "FA
13310 49 4c 45 44 22 29 29 0a 20 20 20 20 20 20 28 72 ILED")). (r
13320 6d 74 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 mt:set-state-sta
13330 74 75 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d tus-and-roll-up-
13340 69 74 65 6d 73 20 72 75 6e 2d 69 64 20 74 65 73 items run-id tes
13350 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 t-name item-path
13360 20 23 66 20 22 4c 41 55 4e 43 48 45 44 22 20 23 #f "LAUNCHED" #
13370 66 29 0a 20 20 20 20 20 20 3b 3b 20 28 70 70 20 f). ;; (pp
13380 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
13390 73 74 20 74 63 6f 6e 66 69 67 29 29 0a 20 20 20 st tconfig)).
133a0 20 20 20 28 73 65 74 21 20 64 69 73 6b 70 61 74 (set! diskpat
133b0 68 20 28 67 65 74 2d 62 65 73 74 2d 64 69 73 6b h (get-best-disk
133c0 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 74 63 6f *configdat* tco
133d0 6e 66 69 67 29 29 0a 20 20 20 20 20 20 28 69 66 nfig)). (if
133e0 20 64 69 73 6b 70 61 74 68 0a 09 20 20 28 6c 65 diskpath.. (le
133f0 74 20 28 28 64 61 74 20 20 28 63 72 65 61 74 65 t ((dat (create
13400 2d 77 6f 72 6b 2d 61 72 65 61 20 72 75 6e 2d 69 -work-area run-i
13410 64 20 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 d run-info keyva
13420 6c 73 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d ls test-id test-
13430 70 61 74 68 20 64 69 73 6b 70 61 74 68 20 74 65 path diskpath te
13440 73 74 2d 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 st-name itemdat)
13450 29 29 0a 09 20 20 20 20 28 73 65 74 21 20 77 6f )).. (set! wo
13460 72 6b 2d 61 72 65 61 20 28 63 61 72 20 64 61 74 rk-area (car dat
13470 29 29 0a 09 20 20 20 20 28 73 65 74 21 20 74 6f )).. (set! to
13480 70 74 65 73 74 2d 77 6f 72 6b 2d 61 72 65 61 20 ptest-work-area
13490 28 63 61 64 72 20 64 61 74 29 29 0a 09 20 20 20 (cadr dat))..
134a0 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
134b0 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
134c0 67 2d 70 6f 72 74 2a 20 22 55 73 69 6e 67 20 77 g-port* "Using w
134d0 6f 72 6b 20 61 72 65 61 20 22 20 77 6f 72 6b 2d ork area " work-
134e0 61 72 65 61 29 29 0a 09 20 20 28 62 65 67 69 6e area)).. (begin
134f0 0a 09 20 20 20 20 28 73 65 74 21 20 77 6f 72 6b .. (set! work
13500 2d 61 72 65 61 20 28 63 6f 6e 63 20 74 65 73 74 -area (conc test
13510 2d 70 61 74 68 20 22 2f 74 6d 70 5f 72 75 6e 22 -path "/tmp_run"
13520 29 29 0a 09 20 20 20 20 28 63 72 65 61 74 65 2d )).. (create-
13530 64 69 72 65 63 74 6f 72 79 20 77 6f 72 6b 2d 61 directory work-a
13540 72 65 61 20 23 74 29 0a 09 20 20 20 20 28 64 65 rea #t).. (de
13550 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
13560 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
13570 57 41 52 4e 49 4e 47 3a 20 4e 6f 20 64 69 73 6b WARNING: No disk
13580 20 77 6f 72 6b 20 61 72 65 61 20 73 70 65 63 69 work area speci
13590 66 69 65 64 20 2d 20 72 75 6e 6e 69 6e 67 20 69 fied - running i
135a0 6e 20 74 68 65 20 74 65 73 74 20 64 69 72 65 63 n the test direc
135b0 74 6f 72 79 20 75 6e 64 65 72 20 74 6d 70 5f 72 tory under tmp_r
135c0 75 6e 22 29 29 29 0a 20 20 20 20 20 20 28 73 65 un"))). (se
135d0 74 21 20 63 6d 64 70 61 72 6d 73 20 28 62 61 73 t! cmdparms (bas
135e0 65 36 34 3a 62 61 73 65 36 34 2d 65 6e 63 6f 64 e64:base64-encod
135f0 65 20 0a 09 09 20 20 20 20 20 20 28 7a 33 3a 65 e ... (z3:e
13600 6e 63 6f 64 65 2d 62 75 66 66 65 72 20 0a 09 09 ncode-buffer ...
13610 20 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 (with-out
13620 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 09 09 put-to-string...
13630 09 20 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b 20 . (lambda () ;;
13640 28 6c 69 73 74 20 27 68 6f 73 74 73 20 20 20 20 (list 'hosts
13650 20 68 6f 73 74 73 29 0a 09 09 09 20 20 20 28 77 hosts).... (w
13660 72 69 74 65 20 28 6c 69 73 74 20 28 6c 69 73 74 rite (list (list
13670 20 27 74 65 73 74 70 61 74 68 20 20 74 65 73 74 'testpath test
13680 2d 70 61 74 68 29 0a 09 09 09 09 09 3b 3b 20 28 -path)......;; (
13690 6c 69 73 74 20 27 74 72 61 6e 73 70 6f 72 74 20 list 'transport
136a0 28 63 6f 6e 63 20 2a 74 72 61 6e 73 70 6f 72 74 (conc *transport
136b0 2d 74 79 70 65 2a 29 29 0a 09 09 09 09 09 3b 3b -type*))......;;
136c0 20 28 6c 69 73 74 20 27 73 65 72 76 65 72 69 6e (list 'serverin
136d0 66 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 29 f *server-info*)
136e0 0a 09 09 09 09 09 28 6c 69 73 74 20 27 68 6f 6d ......(list 'hom
136f0 65 68 6f 73 74 20 20 28 6c 65 74 2a 20 28 28 68 ehost (let* ((h
13700 68 64 61 74 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 hdat (common:get
13710 2d 68 6f 6d 65 68 6f 73 74 29 29 29 0a 09 09 09 -homehost)))....
13720 09 09 09 09 20 20 20 28 69 66 20 68 68 64 61 74 .... (if hhdat
13730 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 ........ (
13740 63 61 72 20 68 68 64 61 74 29 0a 09 09 09 09 09 car hhdat)......
13750 09 09 20 20 20 20 20 20 20 23 66 29 29 29 0a 09 .. #f)))..
13760 09 09 09 09 28 6c 69 73 74 20 27 73 65 72 76 65 ....(list 'serve
13770 72 75 72 6c 20 28 69 66 20 2a 72 75 6e 72 65 6d rurl (if *runrem
13780 6f 74 65 2a 0a 09 09 09 09 09 09 09 20 20 20 20 ote*........
13790 20 28 72 65 6d 6f 74 65 2d 73 65 72 76 65 72 2d (remote-server-
137a0 75 72 6c 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 url *runremote*)
137b0 0a 09 09 09 09 09 09 09 20 20 20 20 20 23 66 29 ........ #f)
137c0 29 20 3b 3b 0a 09 09 09 09 09 28 6c 69 73 74 20 ) ;;......(list
137d0 27 61 72 65 61 6e 61 6d 65 20 20 28 63 6f 6d 6d 'areaname (comm
137e0 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 on:get-testsuite
137f0 2d 6e 61 6d 65 29 29 0a 09 09 09 09 09 28 6c 69 -name))......(li
13800 73 74 20 27 74 6f 70 70 61 74 68 20 20 20 2a 74 st 'toppath *t
13810 6f 70 70 61 74 68 2a 29 0a 09 09 09 09 09 28 6c oppath*)......(l
13820 69 73 74 20 27 77 6f 72 6b 2d 61 72 65 61 20 77 ist 'work-area w
13830 6f 72 6b 2d 61 72 65 61 29 0a 09 09 09 09 09 28 ork-area)......(
13840 6c 69 73 74 20 27 74 65 73 74 2d 6e 61 6d 65 20 list 'test-name
13850 74 65 73 74 2d 6e 61 6d 65 29 20 0a 09 09 09 09 test-name) .....
13860 09 28 6c 69 73 74 20 27 72 75 6e 73 63 72 69 70 .(list 'runscrip
13870 74 20 72 75 6e 73 63 72 69 70 74 29 20 0a 09 09 t runscript) ...
13880 09 09 09 28 6c 69 73 74 20 27 72 75 6e 2d 69 64 ...(list 'run-id
13890 20 20 20 20 72 75 6e 2d 69 64 20 20 20 29 0a 09 run-id )..
138a0 09 09 09 09 28 6c 69 73 74 20 27 74 65 73 74 2d ....(list 'test-
138b0 69 64 20 20 20 74 65 73 74 2d 69 64 20 20 29 0a id test-id ).
138c0 09 09 09 09 09 3b 3b 20 28 6c 69 73 74 20 27 69 .....;; (list 'i
138d0 74 65 6d 2d 70 61 74 68 20 69 74 65 6d 2d 70 61 tem-path item-pa
138e0 74 68 20 29 0a 09 09 09 09 09 28 6c 69 73 74 20 th )......(list
138f0 27 69 74 65 6d 64 61 74 20 20 20 69 74 65 6d 64 'itemdat itemd
13900 61 74 20 20 29 0a 09 09 09 09 09 28 6c 69 73 74 at )......(list
13910 20 27 6d 65 67 61 74 65 73 74 20 20 72 65 6d 6f 'megatest remo
13920 74 65 2d 6d 65 67 61 74 65 73 74 29 0a 09 09 09 te-megatest)....
13930 09 09 28 6c 69 73 74 20 27 65 7a 73 74 65 70 73 ..(list 'ezsteps
13940 20 20 20 65 7a 73 74 65 70 73 29 0a 09 09 09 09 ezsteps).....
13950 09 28 6c 69 73 74 20 27 73 75 62 72 75 6e 20 20 .(list 'subrun
13960 20 20 73 75 62 72 75 6e 29 0a 09 09 09 09 09 28 subrun)......(
13970 6c 69 73 74 20 27 74 61 72 67 65 74 20 20 20 20 list 'target
13980 6d 74 5f 74 61 72 67 65 74 29 0a 09 09 09 09 09 mt_target)......
13990 28 6c 69 73 74 20 27 63 6f 6e 74 6f 75 72 20 20 (list 'contour
139a0 20 63 6f 6e 74 6f 75 72 29 0a 09 09 09 09 09 28 contour)......(
139b0 6c 69 73 74 20 27 72 75 6e 74 6c 69 6d 20 20 20 list 'runtlim
139c0 28 69 66 20 72 75 6e 2d 74 69 6d 65 2d 6c 69 6d (if run-time-lim
139d0 69 74 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 it (common:hms-s
139e0 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 72 tring->seconds r
139f0 75 6e 2d 74 69 6d 65 2d 6c 69 6d 69 74 29 20 23 un-time-limit) #
13a00 66 29 29 0a 09 09 09 09 09 28 6c 69 73 74 20 27 f))......(list '
13a10 65 6e 76 2d 6f 76 72 64 20 20 28 68 61 73 68 2d env-ovrd (hash-
13a20 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
13a30 74 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 t *configdat* "e
13a40 6e 76 2d 6f 76 65 72 72 69 64 65 22 20 27 28 29 nv-override" '()
13a50 29 29 20 0a 09 09 09 09 09 28 6c 69 73 74 20 27 )) ......(list '
13a60 73 65 74 2d 76 61 72 73 20 20 28 69 66 20 70 61 set-vars (if pa
13a70 72 61 6d 73 20 28 68 61 73 68 2d 74 61 62 6c 65 rams (hash-table
13a80 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 70 61 72 -ref/default par
13a90 61 6d 73 20 22 2d 73 65 74 76 61 72 73 22 20 23 ams "-setvars" #
13aa0 66 29 29 29 0a 09 09 09 09 09 28 6c 69 73 74 20 f)))......(list
13ab0 27 72 75 6e 6e 61 6d 65 20 20 20 72 75 6e 6e 61 'runname runna
13ac0 6d 65 29 0a 09 09 09 09 09 28 6c 69 73 74 20 27 me)......(list '
13ad0 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 6d mt-bindir-path m
13ae0 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 29 29 29 t-bindir-path)))
13af0 29 29 29 29 29 0a 20 20 20 20 20 20 3b 3b 20 73 ))))). ;; s
13b00 61 76 65 20 74 68 65 20 63 6d 64 70 61 72 6d 73 ave the cmdparms
13b10 20 69 6e 20 74 68 65 20 61 6a 74 64 61 74 0a 20 in the ajtdat.
13b20 20 20 20 20 20 28 6c 61 75 6e 63 68 3a 61 6a 74 (launch:ajt
13b30 2d 65 78 65 6b 65 79 2d 73 65 74 21 20 61 6a 74 -exekey-set! ajt
13b40 64 61 74 20 63 6d 64 70 61 72 6d 73 29 0a 20 20 dat cmdparms).
13b50 20 20 20 20 0a 20 20 20 20 20 20 3b 3b 20 63 6c . ;; cl
13b60 65 61 6e 20 6f 75 74 20 73 74 65 70 20 72 65 63 ean out step rec
13b70 6f 72 64 73 20 66 72 6f 6d 20 70 72 65 76 69 6f ords from previo
13b80 75 73 20 72 75 6e 20 69 66 20 74 68 65 79 20 65 us run if they e
13b90 78 69 73 74 0a 20 20 20 20 20 20 3b 3b 20 28 72 xist. ;; (r
13ba0 6d 74 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 73 mt:delete-test-s
13bb0 74 65 70 2d 72 65 63 6f 72 64 73 20 72 75 6e 2d tep-records run-
13bc0 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 20 20 id test-id).
13bd0 20 20 3b 3b 20 69 66 20 74 68 65 20 64 69 72 20 ;; if the dir
13be0 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 20 77 does not exist w
13bf0 65 20 6d 61 79 20 68 61 76 65 20 61 20 69 74 65 e may have a ite
13c00 6d 70 61 74 68 20 77 68 65 72 65 20 69 6e 64 69 mpath where indi
13c10 76 69 64 75 61 6c 20 76 61 72 69 61 62 6c 65 73 vidual variables
13c20 20 61 72 65 20 61 20 70 61 74 68 2c 20 6c 61 75 are a path, lau
13c30 6e 63 68 20 61 6e 79 77 61 79 0a 20 20 20 20 20 nch anyway.
13c40 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (if (common:fil
13c50 65 2d 65 78 69 73 74 73 3f 20 77 6f 72 6b 2d 61 e-exists? work-a
13c60 72 65 61 29 0a 09 20 20 28 63 68 61 6e 67 65 2d rea).. (change-
13c70 64 69 72 65 63 74 6f 72 79 20 77 6f 72 6b 2d 61 directory work-a
13c80 72 65 61 29 29 20 3b 3b 20 73 6f 20 74 68 61 74 rea)) ;; so that
13c90 20 6c 6f 67 20 66 69 6c 65 73 20 66 72 6f 6d 20 log files from
13ca0 74 68 65 20 6c 61 75 6e 63 68 20 70 72 6f 63 65 the launch proce
13cb0 73 73 20 64 6f 6e 27 74 20 63 6c 75 74 74 65 72 ss don't clutter
13cc0 20 74 68 65 20 74 65 73 74 20 64 69 72 0a 0a 20 the test dir..
13cd0 20 20 20 20 20 3b 3b 20 73 61 76 65 20 74 68 65 ;; save the
13ce0 20 63 6f 6d 6d 61 6e 64 20 6c 69 6e 65 20 66 6f command line fo
13cf0 72 20 61 64 6a 75 74 61 6e 74 20 6d 6f 64 65 20 r adjutant mode
13d00 28 6d 69 67 68 74 20 6e 65 76 65 72 20 62 65 20 (might never be
13d10 6e 65 65 64 65 64 20 62 75 74 20 62 65 73 74 20 needed but best
13d20 74 6f 20 61 73 73 65 6d 62 6c 65 20 69 74 20 68 to assemble it h
13d30 65 72 65 29 0a 20 20 20 20 20 20 28 6c 61 75 6e ere). (laun
13d40 63 68 3a 61 6a 74 2d 63 6d 64 6c 69 6e 65 2d 73 ch:ajt-cmdline-s
13d50 65 74 21 20 61 6a 74 64 61 74 20 28 73 74 72 69 et! ajtdat (stri
13d60 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 0a 09 ng-intersperse..
13d70 09 09 09 20 20 20 20 20 20 20 28 61 70 70 65 6e ... (appen
13d80 64 20 28 6c 69 73 74 20 72 65 6d 6f 74 65 2d 6d d (list remote-m
13d90 65 67 61 74 65 73 74 20 22 2d 6d 22 20 74 65 73 egatest "-m" tes
13da0 74 2d 73 69 67 20 22 2d 65 78 65 63 75 74 65 22 t-sig "-execute"
13db0 20 63 6d 64 70 61 72 6d 73 29 20 64 65 62 75 67 cmdparms) debug
13dc0 2d 70 61 72 61 6d 29 29 29 0a 20 20 20 20 20 20 -param))).
13dd0 28 63 6f 6e 64 20 20 20 20 20 20 20 0a 20 20 20 (cond .
13de0 20 20 20 20 28 6c 61 75 6e 63 68 65 72 0a 09 28 (launcher..(
13df0 73 65 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 set! fullcmd (ap
13e00 70 65 6e 64 20 6c 61 75 6e 63 68 65 72 20 28 6c pend launcher (l
13e10 69 73 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 ist remote-megat
13e20 65 73 74 20 22 2d 6d 22 20 74 65 73 74 2d 73 69 est "-m" test-si
13e30 67 20 22 2d 65 78 65 63 75 74 65 22 20 63 6d 64 g "-execute" cmd
13e40 70 61 72 6d 73 29 20 64 65 62 75 67 2d 70 61 72 parms) debug-par
13e50 61 6d 29 29 29 0a 20 20 20 20 20 20 20 28 65 6c am))). (el
13e60 73 65 0a 09 28 69 66 20 28 6e 6f 74 20 75 73 65 se..(if (not use
13e70 73 68 65 6c 6c 29 28 64 65 62 75 67 3a 70 72 69 shell)(debug:pri
13e80 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
13e90 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
13ea0 3a 20 69 6e 74 65 72 6e 61 6c 20 6c 61 75 6e 63 : internal launc
13eb0 68 69 6e 67 20 77 69 6c 6c 20 6e 6f 74 20 77 6f hing will not wo
13ec0 72 6b 20 77 65 6c 6c 20 77 69 74 68 6f 75 74 20 rk well without
13ed0 5c 22 75 73 65 73 68 65 6c 6c 20 79 65 73 5c 22 \"useshell yes\"
13ee0 20 69 6e 20 79 6f 75 72 20 5b 6a 6f 62 74 6f 6f in your [jobtoo
13ef0 6c 73 5d 20 73 65 63 74 69 6f 6e 22 29 29 0a 09 ls] section"))..
13f00 28 73 65 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 (set! fullcmd (a
13f10 70 70 65 6e 64 20 28 6c 69 73 74 20 72 65 6d 6f ppend (list remo
13f20 74 65 2d 6d 65 67 61 74 65 73 74 20 22 2d 6d 22 te-megatest "-m"
13f30 20 74 65 73 74 2d 73 69 67 20 22 2d 65 78 65 63 test-sig "-exec
13f40 75 74 65 22 20 63 6d 64 70 61 72 6d 73 29 20 64 ute" cmdparms) d
13f50 65 62 75 67 2d 70 61 72 61 6d 20 28 6c 69 73 74 ebug-param (list
13f60 20 28 69 66 20 75 73 65 73 68 65 6c 6c 20 22 26 (if useshell "&
13f70 22 20 22 22 29 29 29 29 29 29 0a 20 20 20 20 20 " "")))))).
13f80 20 0a 20 20 20 20 20 20 28 69 66 20 28 61 72 67 . (if (arg
13f90 73 3a 67 65 74 2d 61 72 67 20 22 2d 78 74 65 72 s:get-arg "-xter
13fa0 6d 22 29 28 73 65 74 21 20 66 75 6c 6c 63 6d 64 m")(set! fullcmd
13fb0 20 28 61 70 70 65 6e 64 20 66 75 6c 6c 63 6d 64 (append fullcmd
13fc0 20 28 6c 69 73 74 20 22 2d 78 74 65 72 6d 22 29 (list "-xterm")
13fd0 29 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 ))). (debug
13fe0 3a 70 72 69 6e 74 20 31 20 2a 64 65 66 61 75 6c :print 1 *defaul
13ff0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 4c 61 75 t-log-port* "Lau
14000 6e 63 68 69 6e 67 20 22 20 77 6f 72 6b 2d 61 72 nching " work-ar
14010 65 61 29 0a 20 20 20 20 20 20 3b 3b 20 73 65 74 ea). ;; set
14020 20 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d pre-launch-env-
14030 76 61 72 73 20 62 65 66 6f 72 65 20 6c 61 75 6e vars before laun
14040 63 68 69 6e 67 2c 20 6b 65 65 70 20 74 68 65 20 ching, keep the
14050 76 61 72 73 20 69 6e 20 70 72 65 76 76 61 6c 73 vars in prevvals
14060 20 61 6e 64 20 70 75 74 20 74 68 65 20 65 6e 76 and put the env
14070 69 6f 6e 6d 65 6e 74 20 62 61 63 6b 20 77 68 65 ionment back whe
14080 6e 20 64 6f 6e 65 0a 20 20 20 20 20 20 28 64 65 n done. (de
14090 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
140a0 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
140b0 66 75 6c 6c 63 6d 64 3a 20 22 20 66 75 6c 6c 63 fullcmd: " fullc
140c0 6d 64 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 md). (set!
140d0 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a 20 28 63 *last-launch* (c
140e0 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
140f0 20 3b 3b 20 61 6c 6c 20 74 68 61 74 20 6a 75 6e ;; all that jun
14100 6b 20 61 62 6f 76 65 20 74 61 6b 65 73 20 74 69 k above takes ti
14110 6d 65 2c 20 73 65 74 20 74 68 69 73 20 61 73 20 me, set this as
14120 6c 61 74 65 20 61 73 20 70 6f 73 73 69 62 6c 65 late as possible
14130 2e 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
14140 65 6e 76 2d 6f 76 65 72 72 69 64 65 2d 76 61 72 env-override-var
14150 73 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 s (hash-table-r
14160 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 ef/default *conf
14170 69 67 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 igdat* "env-over
14180 72 69 64 65 22 20 27 28 29 29 29 0a 09 20 20 20 ride" '()))..
14190 20 20 28 63 6f 6d 6d 6f 6e 70 72 65 76 76 61 6c (commonprevval
141a0 73 20 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e s (alist->en
141b0 76 2d 76 61 72 73 20 65 6e 76 2d 6f 76 65 72 72 v-vars env-overr
141c0 69 64 65 2d 76 61 72 73 29 29 0a 09 20 20 20 20 ide-vars))..
141d0 20 28 6d 69 73 63 2d 76 61 72 73 20 20 20 20 20 (misc-vars
141e0 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 (append (li
141f0 73 74 20 28 6c 69 73 74 20 22 4d 54 5f 54 45 53 st (list "MT_TES
14200 54 5f 52 55 4e 5f 44 49 52 22 20 77 6f 72 6b 2d T_RUN_DIR" work-
14210 61 72 65 61 29 0a 09 09 09 09 09 20 20 20 20 20 area)......
14220 20 20 28 6c 69 73 74 20 22 4d 54 5f 54 45 53 54 (list "MT_TEST
14230 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d 65 _NAME" test-name
14240 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 6c )...... (l
14250 69 73 74 20 22 4d 54 5f 49 54 45 4d 5f 49 4e 46 ist "MT_ITEM_INF
14260 4f 22 20 28 63 6f 6e 63 20 69 74 65 6d 64 61 74 O" (conc itemdat
14270 29 29 20 0a 09 09 09 09 09 20 20 20 20 20 20 20 )) ......
14280 28 6c 69 73 74 20 22 4d 54 5f 52 55 4e 4e 41 4d (list "MT_RUNNAM
14290 45 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 09 E" runname)...
142a0 09 09 09 20 20 20 20 20 20 20 28 6c 69 73 74 20 ... (list
142b0 22 4d 54 5f 54 41 52 47 45 54 22 20 20 20 20 6d "MT_TARGET" m
142c0 74 5f 74 61 72 67 65 74 29 0a 09 09 09 09 09 20 t_target)......
142d0 20 20 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f (list "MT_
142e0 49 54 45 4d 50 41 54 48 22 20 20 69 74 65 6d 2d ITEMPATH" item-
142f0 70 61 74 68 29 29 0a 09 09 09 09 09 20 69 74 65 path))...... ite
14300 6d 64 61 74 29 29 0a 09 20 20 20 20 20 28 6d 69 mdat)).. (mi
14310 73 63 70 72 65 76 76 61 6c 73 20 20 20 28 61 6c scprevvals (al
14320 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 6d 69 ist->env-vars mi
14330 73 63 2d 76 61 72 73 29 29 3b 3b 20 63 6f 6e 73 sc-vars));; cons
14340 6f 6c 69 64 61 74 65 20 74 68 69 73 20 63 6f 64 olidate this cod
14350 65 20 77 69 74 68 20 74 68 65 20 63 6f 64 65 20 e with the code
14360 69 6e 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 20 in megatest.scm
14370 66 6f 72 20 22 2d 65 78 65 63 75 74 65 22 0a 09 for "-execute"..
14380 20 20 20 20 20 28 74 65 73 74 2d 76 61 72 73 20 (test-vars
14390 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
143a0 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 63 6f -ref/default tco
143b0 6e 66 69 67 20 22 70 72 65 2d 6c 61 75 6e 63 68 nfig "pre-launch
143c0 2d 65 6e 76 2d 6f 76 65 72 72 69 64 65 73 22 20 -env-overrides"
143d0 27 28 29 29 29 0a 09 20 20 20 20 20 28 74 65 73 '())).. (tes
143e0 74 70 72 65 76 76 61 6c 73 20 20 20 28 61 6c 69 tprevvals (ali
143f0 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 74 65 73 st->env-vars tes
14400 74 2d 76 61 72 73 29 29 0a 09 09 09 20 20 20 20 t-vars))....
14410 20 20 0a 09 20 20 20 20 20 3b 3b 20 4c 61 75 6e .. ;; Laun
14420 63 68 77 61 69 74 20 64 65 66 61 75 6c 74 73 20 chwait defaults
14430 74 6f 20 74 72 75 65 2c 20 6d 75 73 74 20 6f 76 to true, must ov
14440 65 72 72 69 64 65 20 69 74 20 74 6f 20 74 75 72 erride it to tur
14450 6e 20 6f 66 66 20 77 61 69 74 0a 09 20 20 20 20 n off wait..
14460 20 28 6c 61 75 6e 63 68 77 61 69 74 20 20 20 20 (launchwait
14470 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 6f (if (equal? (co
14480 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
14490 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
144a0 20 22 6c 61 75 6e 63 68 77 61 69 74 22 29 20 22 "launchwait") "
144b0 6e 6f 22 29 20 23 66 20 23 74 29 29 0a 09 20 20 no") #f #t))..
144c0 20 20 20 3b 3b 20 42 42 3a 20 54 4f 44 4f 3a 20 ;; BB: TODO:
144d0 72 65 66 61 63 74 6f 72 20 74 68 69 73 20 74 6f refactor this to
144e0 20 65 78 61 6d 69 6e 65 20 72 65 74 75 72 6e 20 examine return
144f0 63 6f 64 65 20 6f 66 20 6c 61 75 6e 63 68 65 72 code of launcher
14500 2c 20 69 66 20 6e 6f 6e 7a 65 72 6f 2c 20 73 65 , if nonzero, se
14510 74 20 73 74 61 74 65 20 74 6f 20 6c 61 75 6e 63 t state to launc
14520 68 20 66 61 69 6c 65 64 2e 0a 09 20 20 20 20 20 h failed...
14530 28 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 2d (launch-results-
14540 70 72 65 76 20 28 69 66 20 28 65 71 3f 20 6c 61 prev (if (eq? la
14550 75 6e 63 68 65 72 2d 6d 6f 64 65 20 27 61 64 6a uncher-mode 'adj
14560 75 74 61 6e 74 29 0a 09 09 09 09 20 20 20 20 20 utant).....
14570 20 27 28 23 74 20 30 29 20 3b 3b 20 6a 75 73 74 '(#t 0) ;; just
14580 20 73 6f 6d 65 20 66 61 6b 65 20 64 61 74 61 20 some fake data
14590 74 6f 20 66 6f 6f 6c 20 64 6f 77 6e 73 74 72 65 to fool downstre
145a0 61 6d 20 62 75 74 20 6e 6f 6e 2d 61 70 70 6c 69 am but non-appli
145b0 63 61 62 6c 65 20 63 6f 64 65 0a 09 09 09 09 20 cable code.....
145c0 20 20 20 20 20 28 61 70 70 6c 79 20 28 69 66 20 (apply (if
145d0 6c 61 75 6e 63 68 77 61 69 74 0a 09 09 09 09 09 launchwait......
145e0 09 20 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 . process:cmd-ru
145f0 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 2d 61 6e n-with-stderr-an
14600 64 2d 65 78 69 74 63 6f 64 65 2d 3e 6c 69 73 74 d-exitcode->list
14610 0a 09 09 09 09 09 09 20 70 72 6f 63 65 73 73 2d ....... process-
14620 72 75 6e 29 0a 09 09 09 09 09 20 20 20 20 20 28 run)...... (
14630 69 66 20 75 73 65 73 68 65 6c 6c 0a 09 09 09 09 if useshell.....
14640 09 09 20 28 6c 65 74 20 28 28 63 6d 64 73 74 72 .. (let ((cmdstr
14650 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
14660 65 72 73 65 20 66 75 6c 6c 63 6d 64 20 22 20 22 erse fullcmd " "
14670 29 29 29 0a 09 09 09 09 09 09 20 20 20 28 69 66 )))....... (if
14680 20 6c 61 75 6e 63 68 77 61 69 74 0a 09 09 09 09 launchwait.....
14690 09 09 20 20 20 20 20 20 20 63 6d 64 73 74 72 0a .. cmdstr.
146a0 09 09 09 09 09 09 20 20 20 20 20 20 20 28 63 6f ...... (co
146b0 6e 63 20 63 6d 64 73 74 72 20 22 20 3e 3e 20 6d nc cmdstr " >> m
146c0 74 5f 6c 61 75 6e 63 68 2e 6c 6f 67 20 32 3e 26 t_launch.log 2>&
146d0 31 20 26 22 29 29 29 0a 09 09 09 09 09 09 20 28 1 &")))....... (
146e0 63 61 72 20 66 75 6c 6c 63 6d 64 29 29 0a 09 09 car fullcmd))...
146f0 09 09 09 20 20 20 20 20 28 69 66 20 75 73 65 73 ... (if uses
14700 68 65 6c 6c 0a 09 09 09 09 09 09 20 27 28 29 0a hell....... '().
14710 09 09 09 09 09 09 20 28 63 64 72 20 66 75 6c 6c ...... (cdr full
14720 63 6d 64 29 29 29 29 29 0a 20 20 20 20 20 20 20 cmd))))).
14730 20 20 20 20 20 20 28 73 75 63 63 65 73 73 20 20 (success
14740 20 20 20 20 20 20 28 69 66 20 6c 61 75 6e 63 68 (if launch
14750 77 61 69 74 20 28 65 71 75 61 6c 3f 20 30 20 28 wait (equal? 0 (
14760 63 61 64 72 20 6c 61 75 6e 63 68 2d 72 65 73 75 cadr launch-resu
14770 6c 74 73 2d 70 72 65 76 29 29 20 23 74 29 29 0a lts-prev)) #t)).
14780 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
14790 75 6e 63 68 2d 72 65 73 75 6c 74 73 20 28 69 66 unch-results (if
147a0 20 6c 61 75 6e 63 68 77 61 69 74 20 28 63 61 72 launchwait (car
147b0 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 2d launch-results-
147c0 70 72 65 76 29 20 6c 61 75 6e 63 68 2d 72 65 73 prev) launch-res
147d0 75 6c 74 73 2d 70 72 65 76 29 29 29 0a 0a 09 28 ults-prev)))...(
147e0 6c 61 75 6e 63 68 3a 61 6a 74 2d 61 64 64 2d 76 launch:ajt-add-v
147f0 61 72 73 20 61 6a 74 64 61 74 20 65 6e 76 2d 6f ars ajtdat env-o
14800 76 65 72 72 69 64 65 2d 76 61 72 73 29 0a 09 28 verride-vars)..(
14810 6c 61 75 6e 63 68 3a 61 6a 74 2d 61 64 64 2d 76 launch:ajt-add-v
14820 61 72 73 20 61 6a 74 64 61 74 20 6d 69 73 63 2d ars ajtdat misc-
14830 76 61 72 73 29 0a 09 28 6c 61 75 6e 63 68 3a 61 vars)..(launch:a
14840 6a 74 2d 61 64 64 2d 76 61 72 73 20 61 6a 74 64 jt-add-vars ajtd
14850 61 74 20 74 65 73 74 2d 76 61 72 73 29 0a 0a 09 at test-vars)...
14860 3b 3b 20 69 66 20 69 6e 20 61 64 6a 75 74 61 6e ;; if in adjutan
14870 74 20 6d 6f 64 65 20 77 65 20 72 65 67 69 73 74 t mode we regist
14880 65 72 20 74 68 65 20 6a 6f 62 20 69 6e 20 74 68 er the job in th
14890 65 20 6a 6f 62 73 5f 71 75 65 75 65 0a 09 3b 3b e jobs_queue..;;
148a0 20 74 68 65 6e 20 66 69 72 65 20 6f 66 66 20 61 then fire off a
148b0 6e 20 61 64 6a 75 74 61 6e 74 20 72 75 6e 6e 65 n adjutant runne
148c0 72 0a 09 3b 3b 0a 09 28 69 66 20 28 65 71 3f 20 r..;;..(if (eq?
148d0 6c 61 75 6e 63 68 65 72 2d 6d 6f 64 65 20 27 61 launcher-mode 'a
148e0 64 6a 75 74 61 6e 74 29 0a 09 20 20 20 20 28 6c djutant).. (l
148f0 65 74 2a 20 28 28 61 64 6a 75 74 61 6e 74 2d 72 et* ((adjutant-r
14900 75 6e 6e 65 72 2d 63 6d 64 20 28 61 70 70 65 6e unner-cmd (appen
14910 64 20 28 63 64 72 20 6c 61 75 6e 63 68 65 72 29 d (cdr launcher)
14920 0a 09 09 09 09 09 09 28 6c 69 73 74 20 72 65 6d .......(list rem
14930 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 22 2d 61 ote-megatest "-a
14940 64 6a 75 74 61 6e 74 22 0a 09 09 09 09 09 09 20 djutant".......
14950 20 20 20 20 20 28 6c 61 75 6e 63 68 3a 61 6a 74 (launch:ajt
14960 2d 68 6f 73 74 2d 74 79 70 65 20 61 6a 74 64 61 -host-type ajtda
14970 74 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 22 t)....... "
14980 2d 73 74 61 72 74 2d 64 69 72 22 20 2a 74 6f 70 -start-dir" *top
14990 70 61 74 68 2a 29 29 29 0a 09 09 20 20 20 28 61 path*)))... (a
149a0 64 6a 2d 63 6d 64 20 20 20 20 20 28 63 6f 6e 63 dj-cmd (conc
149b0 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
149c0 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 61 erse (map conc a
149d0 64 6a 75 74 61 6e 74 2d 72 75 6e 6e 65 72 2d 63 djutant-runner-c
149e0 6d 64 29 20 22 20 22 29 0a 09 09 09 09 20 20 20 md) " ").....
149f0 20 20 20 22 26 22 29 29 29 20 20 20 20 20 20 20 "&")))
14a00 20 20 0a 09 20 20 20 20 20 20 28 72 6d 74 3a 6e .. (rmt:n
14a10 6f 2d 73 79 6e 63 2d 61 64 64 2d 6a 6f 62 0a 09 o-sync-add-job..
14a20 20 20 20 20 20 20 20 28 6c 61 75 6e 63 68 3a 61 (launch:a
14a30 6a 74 2d 68 6f 73 74 2d 74 79 70 65 20 20 61 6a jt-host-type aj
14a40 74 64 61 74 29 0a 09 20 20 20 20 20 20 20 28 6c tdat).. (l
14a50 61 75 6e 63 68 3a 61 6a 74 2d 76 61 72 73 20 61 aunch:ajt-vars a
14a60 6a 74 64 61 74 29 0a 09 20 20 20 20 20 20 20 28 jtdat).. (
14a70 6c 61 75 6e 63 68 3a 61 6a 74 2d 65 78 65 6b 65 launch:ajt-exeke
14a80 79 20 20 20 20 20 61 6a 74 64 61 74 29 0a 09 20 y ajtdat)..
14a90 20 20 20 20 20 20 28 6c 61 75 6e 63 68 3a 61 6a (launch:aj
14aa0 74 2d 63 6d 64 6c 69 6e 65 20 20 20 20 61 6a 74 t-cmdline ajt
14ab0 64 61 74 29 29 0a 09 20 20 20 20 20 20 28 70 72 dat)).. (pr
14ac0 69 6e 74 20 22 61 64 6a 2d 63 6d 64 3a 20 22 20 int "adj-cmd: "
14ad0 61 64 6a 2d 63 6d 64 29 0a 09 20 20 20 20 20 20 adj-cmd)..
14ae0 28 73 79 73 74 65 6d 20 61 64 6a 2d 63 6d 64 29 (system adj-cmd)
14af0 0a 09 20 20 20 20 20 20 29 29 0a 09 0a 09 28 69 .. ))....(i
14b00 66 20 28 6e 6f 74 20 73 75 63 63 65 73 73 29 0a f (not success).
14b10 20 20 20 20 20 20 20 20 20 20 20 20 28 74 65 73 (tes
14b20 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 ts:test-set-stat
14b30 75 73 21 20 72 75 6e 2d 69 64 20 74 65 73 74 2d us! run-id test-
14b40 69 64 20 22 43 4f 4d 50 4c 45 54 45 44 22 20 22 id "COMPLETED" "
14b50 44 45 41 44 22 20 22 6c 61 75 6e 63 68 65 72 20 DEAD" "launcher
14b60 66 61 69 6c 65 64 3b 20 65 78 69 74 65 64 20 6e failed; exited n
14b70 6f 6e 2d 7a 65 72 6f 3b 20 63 68 65 63 6b 20 6d on-zero; check m
14b80 74 5f 6c 61 75 6e 63 68 2e 6c 6f 67 22 20 23 66 t_launch.log" #f
14b90 29 29 20 3b 3b 20 28 69 66 20 6c 61 75 6e 63 68 )) ;; (if launch
14ba0 2d 72 65 73 75 6c 74 73 20 6c 61 75 6e 63 68 2d -results launch-
14bb0 72 65 73 75 6c 74 73 20 22 46 41 49 4c 45 44 22 results "FAILED"
14bc0 29 29 0a 09 3b 3b 20 28 72 6d 74 3a 6e 6f 2d 73 ))..;; (rmt:no-s
14bd0 79 6e 63 2d 64 65 6c 21 20 6c 6f 63 6b 2d 6b 65 ync-del! lock-ke
14be0 79 29 20 20 20 20 20 20 20 20 20 3b 3b 20 72 65 y) ;; re
14bf0 6c 65 61 73 65 20 74 68 65 20 6c 6f 63 6b 20 66 lease the lock f
14c00 6f 72 20 73 74 61 72 74 69 6e 67 20 74 68 69 73 or starting this
14c10 20 74 65 73 74 0a 09 28 69 66 20 28 6e 6f 74 20 test..(if (not
14c20 6c 61 75 6e 63 68 77 61 69 74 29 20 3b 3b 20 67 launchwait) ;; g
14c30 69 76 65 20 74 68 65 20 4f 53 20 61 20 6c 69 74 ive the OS a lit
14c40 74 6c 65 20 74 69 6d 65 20 74 6f 20 61 6c 6c 6f tle time to allo
14c50 77 20 74 68 65 20 70 72 6f 63 65 73 73 20 74 6f w the process to
14c60 20 73 74 61 72 74 0a 09 20 20 20 20 28 74 68 72 start.. (thr
14c70 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 31 29 ead-sleep! 0.01)
14c80 29 0a 09 28 77 69 74 68 2d 6f 75 74 70 75 74 2d )..(with-output-
14c90 74 6f 2d 66 69 6c 65 20 22 6d 74 5f 6c 61 75 6e to-file "mt_laun
14ca0 63 68 2e 6c 6f 67 22 0a 09 20 20 28 6c 61 6d 62 ch.log".. (lamb
14cb0 64 61 20 28 29 0a 09 20 20 20 20 28 70 72 69 6e da ().. (prin
14cc0 74 20 22 4c 41 55 4e 43 48 43 4d 44 3a 20 22 20 t "LAUNCHCMD: "
14cd0 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
14ce0 72 73 65 20 66 75 6c 6c 63 6d 64 20 22 20 22 29 rse fullcmd " ")
14cf0 29 0a 09 20 20 20 20 28 69 66 20 28 6c 69 73 74 ).. (if (list
14d00 3f 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 ? launch-results
14d10 29 0a 09 09 28 61 70 70 6c 79 20 70 72 69 6e 74 )...(apply print
14d20 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 29 launch-results)
14d30 0a 09 09 28 70 72 69 6e 74 20 22 4e 4f 54 45 3a ...(print "NOTE:
14d40 20 6c 61 75 6e 63 68 65 64 20 5c 22 22 20 66 75 launched \"" fu
14d50 6c 6c 63 6d 64 20 22 5c 22 5c 6e 20 20 62 75 74 llcmd "\"\n but
14d60 20 64 69 64 20 6e 6f 74 20 77 61 69 74 20 66 6f did not wait fo
14d70 72 20 69 74 20 74 6f 20 70 72 6f 63 65 65 64 2e r it to proceed.
14d80 20 41 64 64 20 74 68 65 20 66 6f 6c 6c 6f 77 69 Add the followi
14d90 6e 67 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 63 ng to megatest.c
14da0 6f 6e 66 69 67 20 5c 6e 5b 73 65 74 75 70 5d 5c onfig \n[setup]\
14db0 6e 6c 61 75 6e 63 68 77 61 69 74 20 79 65 73 5c nlaunchwait yes\
14dc0 6e 20 20 69 66 20 79 6f 75 20 68 61 76 65 20 70 n if you have p
14dd0 72 6f 62 6c 65 6d 73 20 77 69 74 68 20 74 68 69 roblems with thi
14de0 73 22 29 29 0a 09 20 20 20 20 23 3a 61 70 70 65 s")).. #:appe
14df0 6e 64 29 29 0a 09 28 64 65 62 75 67 3a 70 72 69 nd))..(debug:pri
14e00 6e 74 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 2 *default-lo
14e10 67 2d 70 6f 72 74 2a 20 22 4c 61 75 6e 63 68 69 g-port* "Launchi
14e20 6e 67 20 63 6f 6d 70 6c 65 74 65 64 2c 20 75 70 ng completed, up
14e30 64 61 74 69 6e 67 20 64 62 22 29 0a 09 28 64 65 dating db")..(de
14e40 62 75 67 3a 70 72 69 6e 74 20 32 20 2a 64 65 66 bug:print 2 *def
14e50 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
14e60 4c 61 75 6e 63 68 20 72 65 73 75 6c 74 73 3a 20 Launch results:
14e70 22 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 " launch-results
14e80 29 0a 09 28 69 66 20 28 6e 6f 74 20 6c 61 75 6e )..(if (not laun
14e90 63 68 2d 72 65 73 75 6c 74 73 29 0a 09 20 20 20 ch-results)..
14ea0 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
14eb0 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 46 61 print "ERROR: Fa
14ec0 69 6c 65 64 20 74 6f 20 72 75 6e 20 22 20 28 73 iled to run " (s
14ed0 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
14ee0 65 20 66 75 6c 6c 63 6d 64 20 22 20 22 29 20 22 e fullcmd " ") "
14ef0 2c 20 65 78 69 74 69 6e 67 20 6e 6f 77 22 29 0a , exiting now").
14f00 09 20 20 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 . ;; (sqlit
14f10 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 e3:finalize! db)
14f20 0a 09 20 20 20 20 20 20 3b 3b 20 67 6f 6f 64 20 .. ;; good
14f30 6f 6c 65 20 22 65 78 69 74 22 20 73 65 65 6d 73 ole "exit" seems
14f40 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 0a 09 20 20 not to work..
14f50 20 20 20 20 3b 3b 20 28 5f 65 78 69 74 20 39 29 ;; (_exit 9)
14f60 0a 09 20 20 20 20 20 20 3b 3b 20 62 75 74 20 74 .. ;; but t
14f70 68 69 73 20 68 61 63 6b 20 77 69 6c 6c 20 77 6f his hack will wo
14f80 72 6b 21 20 54 68 61 6e 6b 73 20 67 6f 20 74 6f rk! Thanks go to
14f90 20 41 6c 61 6e 20 50 6f 73 74 20 6f 66 20 74 68 Alan Post of th
14fa0 65 20 43 68 69 63 6b 65 6e 20 65 6d 61 69 6c 20 e Chicken email
14fb0 6c 69 73 74 0a 09 20 20 20 20 20 20 3b 3b 20 4e list.. ;; N
14fc0 42 2f 2f 20 49 73 20 74 68 69 73 20 73 74 69 6c B// Is this stil
14fd0 6c 20 6e 65 65 64 65 64 3f 20 53 68 6f 75 6c 64 l needed? Should
14fe0 20 62 65 20 73 61 66 65 20 74 6f 20 67 6f 20 62 be safe to go b
14ff0 61 63 6b 20 74 6f 20 22 65 78 69 74 22 20 6e 6f ack to "exit" no
15000 77 3f 0a 09 20 20 20 20 20 20 28 70 72 6f 63 65 w?.. (proce
15010 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 72 72 65 ss-signal (curre
15020 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 73 nt-process-id) s
15030 69 67 6e 61 6c 2f 6b 69 6c 6c 29 0a 09 20 20 20 ignal/kill)..
15040 20 20 20 29 29 0a 09 28 61 6c 69 73 74 2d 3e 65 ))..(alist->e
15050 6e 76 2d 76 61 72 73 20 6d 69 73 63 70 72 65 76 nv-vars miscprev
15060 76 61 6c 73 29 0a 09 28 61 6c 69 73 74 2d 3e 65 vals)..(alist->e
15070 6e 76 2d 76 61 72 73 20 74 65 73 74 70 72 65 76 nv-vars testprev
15080 76 61 6c 73 29 0a 09 28 61 6c 69 73 74 2d 3e 65 vals)..(alist->e
15090 6e 76 2d 76 61 72 73 20 63 6f 6d 6d 6f 6e 70 72 nv-vars commonpr
150a0 65 76 76 61 6c 73 29 0a 09 3b 3b 20 79 65 73 2c evvals)..;; yes,
150b0 20 72 65 61 6c 6c 79 20 73 68 6f 75 6c 64 20 6d really should m
150c0 75 74 65 78 20 61 6c 6c 20 74 68 65 20 77 61 79 utex all the way
150d0 20 74 6f 20 68 65 72 65 2e 20 4e 65 65 64 20 74 to here. Need t
150e0 6f 20 70 75 74 20 74 68 69 73 20 65 6e 74 69 72 o put this entir
150f0 65 20 70 72 6f 63 65 73 73 20 69 6e 74 6f 20 61 e process into a
15100 20 66 6f 72 6b 2e 0a 09 3b 3b 20 74 68 65 20 75 fork...;; the u
15110 6e 6c 6f 63 6b 20 70 72 65 76 69 6f 75 73 6c 79 nlock previously
15120 20 77 61 73 20 66 75 72 74 68 65 72 20 75 70 2e was further up.
15130 20 54 68 69 73 20 73 65 65 6d 65 64 20 77 72 6f This seemed wro
15140 6e 67 20 61 73 20 77 65 20 73 68 6f 75 6c 64 20 ng as we should
15150 6e 6f 74 20 70 72 6f 63 65 65 64 20 75 6e 74 69 not proceed unti
15160 6c 20 74 68 65 0a 09 3b 3b 20 76 61 72 73 20 68 l the..;; vars h
15170 61 76 65 20 62 65 65 6e 20 72 65 73 65 74 2e 0a ave been reset..
15180 09 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 .(mutex-unlock!
15190 2a 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 *launch-setup-mu
151a0 74 65 78 2a 29 0a 09 6c 61 75 6e 63 68 2d 72 65 tex*)..launch-re
151b0 73 75 6c 74 73 29 29 0a 20 20 20 20 28 63 68 61 sults)). (cha
151c0 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 nge-directory *t
151d0 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 28 74 68 oppath*). (th
151e0 72 65 61 64 2d 73 6c 65 65 70 21 20 28 63 6f 6e read-sleep! (con
151f0 66 69 67 66 3a 6c 6f 6f 6b 75 70 2d 6e 75 6d 62 figf:lookup-numb
15200 65 72 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 er *configdat* "
15210 73 65 74 75 70 22 20 22 69 6e 74 65 72 2d 74 65 setup" "inter-te
15220 73 74 2d 64 65 6c 61 79 22 20 64 65 66 61 75 6c st-delay" defaul
15230 74 3a 20 30 2e 30 29 29 29 29 0a 0a 3b 3b 20 72 t: 0.0))))..;; r
15240 65 63 6f 76 65 72 20 61 20 74 65 73 74 20 77 68 ecover a test wh
15250 65 72 65 20 74 68 65 20 74 6f 70 20 63 6f 6e 74 ere the top cont
15260 72 6f 6c 6c 69 6e 67 20 6d 74 65 73 74 20 6d 61 rolling mtest ma
15270 79 20 68 61 76 65 20 64 69 65 64 0a 3b 3b 0a 28 y have died.;;.(
15280 64 65 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 72 define (launch:r
15290 65 63 6f 76 65 72 2d 74 65 73 74 20 72 75 6e 2d ecover-test run-
152a0 69 64 20 74 65 73 74 2d 69 64 29 0a 20 20 3b 3b id test-id). ;;
152b0 20 74 68 69 73 20 66 75 6e 63 74 69 6f 6e 20 69 this function i
152c0 73 20 63 61 6c 6c 65 64 20 6f 6e 20 74 68 65 20 s called on the
152d0 74 65 73 74 20 72 75 6e 20 68 6f 73 74 20 76 69 test run host vi
152e0 61 20 73 73 68 0a 20 20 3b 3b 0a 20 20 3b 3b 20 a ssh. ;;. ;;
152f0 31 2e 20 6c 6f 6f 6b 20 61 74 20 74 68 65 20 70 1. look at the p
15300 72 6f 63 65 73 73 20 66 72 6f 6d 20 70 69 64 0a rocess from pid.
15310 20 20 3b 3b 20 20 20 20 2d 20 69 73 20 69 74 20 ;; - is it
15320 6f 77 6e 65 64 20 62 79 20 63 61 6c 6c 69 6e 67 owned by calling
15330 20 75 73 65 72 0a 20 20 3b 3b 20 20 20 20 2d 20 user. ;; -
15340 69 74 20 69 74 27 73 20 72 75 6e 20 64 69 72 65 it it's run dire
15350 63 74 6f 72 79 20 63 6f 72 72 65 63 74 20 66 6f ctory correct fo
15360 72 20 74 68 65 20 74 65 73 74 0a 20 20 3b 3b 20 r the test. ;;
15370 20 20 20 2d 20 69 73 20 74 68 65 72 65 20 61 20 - is there a
15380 63 6f 6e 74 72 6f 6c 6c 69 6e 67 20 6d 74 65 73 controlling mtes
15390 74 20 28 6d 61 79 62 65 20 73 74 75 63 6b 29 0a t (maybe stuck).
153a0 20 20 3b 3b 20 32 2e 20 69 66 20 72 65 63 6f 76 ;; 2. if recov
153b0 65 72 79 20 69 73 20 6e 65 65 64 65 64 20 77 61 ery is needed wa
153c0 74 63 68 20 70 69 64 0a 20 20 3b 3b 20 20 20 20 tch pid. ;;
153d0 2d 20 77 68 65 6e 20 69 74 20 65 78 69 74 73 20 - when it exits
153e0 74 61 6b 65 20 74 68 65 20 65 78 69 74 20 63 6f take the exit co
153f0 64 65 20 61 6e 64 20 64 6f 20 74 68 65 20 6e 65 de and do the ne
15400 65 64 66 75 6c 0a 20 20 3b 3b 0a 20 20 28 6c 65 edful. ;;. (le
15410 74 2a 20 28 28 70 69 64 20 28 72 6d 74 3a 74 65 t* ((pid (rmt:te
15420 73 74 2d 67 65 74 2d 74 6f 70 2d 70 72 6f 63 65 st-get-top-proce
15430 73 73 2d 70 69 64 20 72 75 6e 2d 69 64 20 74 65 ss-pid run-id te
15440 73 74 2d 69 64 29 29 0a 09 20 28 70 73 72 65 73 st-id)).. (psres
15450 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
15460 6d 2d 70 69 70 65 0a 09 09 20 28 63 6f 6e 63 20 m-pipe... (conc
15470 22 70 73 20 2d 46 20 2d 75 20 22 20 28 63 75 72 "ps -F -u " (cur
15480 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 20 rent-user-name)
15490 22 20 7c 20 67 72 65 70 20 2d 45 20 27 22 20 70 " | grep -E '" p
154a0 69 64 20 22 20 27 20 7c 20 67 72 65 70 20 2d 76 id " ' | grep -v
154b0 20 27 67 72 65 70 20 2d 45 20 22 20 70 69 64 20 'grep -E " pid
154c0 22 27 22 29 0a 09 09 20 28 6c 61 6d 62 64 61 20 "'")... (lambda
154d0 28 29 0a 09 09 20 20 20 28 72 65 61 64 2d 6c 69 ()... (read-li
154e0 6e 65 29 29 29 29 0a 09 20 28 72 75 6e 64 69 72 ne)))).. (rundir
154f0 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 70 73 (if (string? ps
15500 72 65 73 29 20 3b 3b 20 72 65 61 6c 20 70 72 6f res) ;; real pro
15510 63 65 73 73 20 6f 77 6e 65 64 20 62 79 20 75 73 cess owned by us
15520 65 72 0a 09 09 20 20 20 20 20 28 72 65 61 64 2d er... (read-
15530 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 20 28 63 symbolic-link (c
15540 6f 6e 63 20 22 2f 70 72 6f 63 2f 22 20 70 69 64 onc "/proc/" pid
15550 20 22 2f 63 77 64 22 29 29 0a 09 09 20 20 20 20 "/cwd"))...
15560 20 23 66 29 29 29 0a 20 20 20 20 3b 3b 20 6e 6f #f))). ;; no
15570 77 20 77 61 69 74 20 6f 6e 20 74 68 61 74 20 70 w wait on that p
15580 72 6f 63 65 73 73 20 69 66 20 61 6c 6c 20 69 73 rocess if all is
15590 20 63 6f 72 72 65 63 74 0a 20 20 20 20 3b 3b 20 correct. ;;
155a0 70 65 72 69 6f 64 69 63 61 6c 6c 79 20 75 70 64 periodically upd
155b0 61 74 65 20 74 68 65 20 64 62 20 77 69 74 68 20 ate the db with
155c0 72 75 6e 74 69 6d 65 0a 20 20 20 20 3b 3b 20 77 runtime. ;; w
155d0 68 65 6e 20 74 68 65 20 70 72 6f 63 65 73 73 20 hen the process
155e0 65 78 69 74 73 20 6c 6f 6f 6b 20 61 74 20 74 68 exits look at th
155f0 65 20 64 62 2c 20 69 66 20 73 74 69 6c 6c 20 52 e db, if still R
15600 55 4e 4e 49 4e 47 20 61 66 74 65 72 20 31 30 20 UNNING after 10
15610 73 65 63 6f 6e 64 73 20 73 65 74 0a 20 20 20 20 seconds set.
15620 3b 3b 20 73 74 61 74 65 2f 73 74 61 74 75 73 20 ;; state/status
15630 61 70 70 72 6f 70 72 69 61 74 65 6c 79 0a 20 20 appropriately.
15640 20 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 (process-wait
15650 70 69 64 29 29 29 0a 0a 0a 20 3b 3b 20 28 6c 6f pid)))... ;; (lo
15660 63 6b 2d 6b 65 79 20 20 20 20 20 20 20 20 28 63 ck-key (c
15670 6f 6e 63 20 22 74 65 73 74 2d 22 20 74 65 73 74 onc "test-" test
15680 2d 69 64 29 29 0a 09 3b 3b 20 28 67 6f 74 2d 6c -id))..;; (got-l
15690 6f 63 6b 20 20 20 20 20 20 20 20 28 6c 65 74 20 ock (let
156a0 6c 6f 6f 70 20 28 28 6c 6f 63 6b 20 20 20 20 20 loop ((lock
156b0 20 20 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d (rmt:no-sync-
156c0 67 65 74 2d 6c 6f 63 6b 20 6c 6f 63 6b 2d 6b 65 get-lock lock-ke
156d0 79 29 29 0a 09 3b 3b 20 09 09 09 20 20 20 20 20 y))..;; ...
156e0 28 65 78 70 69 72 65 2d 74 69 6d 65 20 28 2b 20 (expire-time (+
156f0 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
15700 29 20 31 35 29 29 29 20 3b 3b 20 67 69 76 65 20 ) 15))) ;; give
15710 75 70 20 6f 6e 20 67 65 74 74 69 6e 67 20 74 68 up on getting th
15720 65 20 6c 6f 63 6b 20 61 6e 64 20 73 74 65 61 6c e lock and steal
15730 20 69 74 20 61 66 74 65 72 20 31 35 20 73 65 63 it after 15 sec
15740 6f 6e 64 73 0a 09 3b 3b 20 09 09 20 20 20 20 28 onds..;; .. (
15750 69 66 20 28 63 61 72 20 6c 6f 63 6b 29 0a 09 3b if (car lock)..;
15760 3b 20 09 09 09 23 74 0a 09 3b 3b 20 09 09 09 28 ; ...#t..;; ...(
15770 69 66 20 28 3e 20 28 63 75 72 72 65 6e 74 2d 73 if (> (current-s
15780 65 63 6f 6e 64 73 29 20 65 78 70 69 72 65 2d 74 econds) expire-t
15790 69 6d 65 29 0a 09 3b 3b 20 09 09 09 20 20 20 20 ime)..;; ...
157a0 28 62 65 67 69 6e 0a 09 3b 3b 20 09 09 09 20 20 (begin..;; ...
157b0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
157c0 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
157d0 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 69 6d 65 -log-port* "Time
157e0 64 20 6f 75 74 20 77 61 69 74 69 6e 67 20 66 6f d out waiting fo
157f0 72 20 61 20 6c 6f 63 6b 20 74 6f 20 6c 61 75 6e r a lock to laun
15800 63 68 20 74 65 73 74 20 22 20 6b 65 79 76 61 6c ch test " keyval
15810 73 20 22 20 22 20 72 75 6e 6e 61 6d 65 20 22 20 s " " runname "
15820 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 22 20 " test-name " "
15830 74 65 73 74 2d 70 61 74 68 29 0a 09 3b 3b 20 09 test-path)..;; .
15840 09 09 20 20 20 20 20 20 28 72 6d 74 3a 6e 6f 2d .. (rmt:no-
15850 73 79 6e 63 2d 64 65 6c 21 20 6c 6f 63 6b 2d 6b sync-del! lock-k
15860 65 79 29 20 3b 3b 20 64 65 73 74 72 6f 79 20 74 ey) ;; destroy t
15870 68 65 20 6c 6f 63 6b 0a 09 3b 3b 20 09 09 09 20 he lock..;; ...
15880 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 6d 74 3a (loop (rmt:
15890 6e 6f 2d 73 79 6e 63 2d 67 65 74 2d 6c 6f 63 6b no-sync-get-lock
158a0 20 6c 6f 63 6b 2d 6b 65 79 29 20 65 78 70 69 72 lock-key) expir
158b0 65 2d 74 69 6d 65 29 29 20 3b 3b 20 0a 09 3b 3b e-time)) ;; ..;;
158c0 20 09 09 09 20 20 20 20 28 62 65 67 69 6e 0a 09 ... (begin..
158d0 3b 3b 20 09 09 09 20 20 20 20 20 20 28 74 68 72 ;; ... (thr
158e0 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 3b ead-sleep! 1)..;
158f0 3b 20 09 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 ; ... (loop
15900 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 (rmt:no-sync-ge
15910 74 2d 6c 6f 63 6b 20 6c 6f 63 6b 2d 6b 65 79 29 t-lock lock-key)
15920 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 29 29 expire-time))))
15930 29 29 0a 09 20 0a )).. .