Artifact
4b56b7ca383dcbd998a865f14915080411368bc6
File
launch.scm
— part of check-in
[47a5bbab30]
at
2013-05-07 00:16:52
on branch refactor
— Refactor complete. test4 and test5 pass 100%
(user:
matt
size: 32637)
[more...]
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 32 2c 20 4d 61 74 74 68 65 77 06-2012, Matthew
0020: 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 0a 3b 3b Welland..;; .;;
0030: 20 20 54 68 69 73 20 70 72 6f 67 72 61 6d 20 69 This program i
0040: 73 20 6d 61 64 65 20 61 76 61 69 6c 61 62 6c 65 s made available
0050: 20 75 6e 64 65 72 20 74 68 65 20 47 4e 55 20 47 under the GNU G
0060: 50 4c 20 76 65 72 73 69 6f 6e 20 32 2e 30 20 6f PL version 2.0 o
0070: 72 0a 3b 3b 20 20 67 72 65 61 74 65 72 2e 20 53 r.;; greater. S
0080: 65 65 20 74 68 65 20 61 63 63 6f 6d 70 61 6e 79 ee the accompany
0090: 69 6e 67 20 66 69 6c 65 20 43 4f 50 59 49 4e 47 ing file COPYING
00a0: 20 66 6f 72 20 64 65 74 61 69 6c 73 2e 0a 3b 3b for details..;;
00b0: 20 0a 3b 3b 20 20 54 68 69 73 20 70 72 6f 67 72 .;; This progr
00c0: 61 6d 20 69 73 20 64 69 73 74 72 69 62 75 74 65 am is distribute
00d0: 64 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 d WITHOUT ANY WA
00e0: 52 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 RRANTY; without
00f0: 65 76 65 6e 20 74 68 65 0a 3b 3b 20 20 69 6d 70 even the.;; imp
0100: 6c 69 65 64 20 77 61 72 72 61 6e 74 79 20 6f 66 lied warranty of
0110: 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 54 59 MERCHANTABILITY
0120: 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f 52 20 or FITNESS FOR
0130: 41 20 50 41 52 54 49 43 55 4c 41 52 0a 3b 3b 20 A PARTICULAR.;;
0140: 20 50 55 52 50 4f 53 45 2e 0a 0a 3b 3b 3d 3d 3d PURPOSE...;;===
0150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0190: 3d 3d 3d 0a 3b 3b 20 6c 61 75 6e 63 68 20 61 20 ===.;; launch a
01a0: 74 61 73 6b 20 2d 20 74 68 69 73 20 72 75 6e 73 task - this runs
01b0: 20 6f 6e 20 74 68 65 20 6f 72 69 67 69 6e 61 74 on the originat
01c0: 69 6e 67 20 68 6f 73 74 2c 20 74 65 73 74 73 20 ing host, tests
01d0: 74 68 65 6d 73 65 6c 76 65 73 0a 3b 3b 0a 3b 3b themselves.;;.;;
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 72 65 67 ======..(use reg
0230: 65 78 20 72 65 67 65 78 2d 63 61 73 65 20 62 61 ex regex-case ba
0240: 73 65 36 34 20 73 71 6c 69 74 65 33 20 73 72 66 se64 sqlite3 srf
0250: 69 2d 31 38 29 0a 28 69 6d 70 6f 72 74 20 28 70 i-18).(import (p
0260: 72 65 66 69 78 20 62 61 73 65 36 34 20 62 61 73 refix base64 bas
0270: 65 36 34 3a 29 29 0a 28 69 6d 70 6f 72 74 20 28 e64:)).(import (
0280: 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 prefix sqlite3 s
0290: 71 6c 69 74 65 33 3a 29 29 0a 0a 28 64 65 63 6c qlite3:))..(decl
02a0: 61 72 65 20 28 75 6e 69 74 20 6c 61 75 6e 63 68 are (unit launch
02b0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use
02c0: 73 20 63 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c s common)).(decl
02d0: 61 72 65 20 28 75 73 65 73 20 63 6f 6e 66 69 67 are (uses config
02e0: 66 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 f)).(declare (us
02f0: 65 73 20 64 62 29 29 0a 0a 28 69 6e 63 6c 75 64 es db))..(includ
0300: 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 e "common_record
0310: 73 2e 73 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 s.scm").(include
0320: 20 22 6b 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 "key_records.sc
0330: 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 m").(include "db
0340: 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a _records.scm")..
0350: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0390: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 65 7a 73 74 ========.;; ezst
03a0: 65 70 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d eps.;;==========
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
03e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
03f0: 20 65 7a 73 74 65 70 73 20 77 65 72 65 20 67 6f ezsteps were go
0400: 69 6e 67 20 74 6f 20 62 65 20 63 6f 64 65 64 20 ing to be coded
0410: 61 73 0a 3b 3b 20 73 74 65 70 6e 61 6d 65 5b 2c as.;; stepname[,
0420: 70 72 65 64 73 74 65 70 31 2c 70 72 65 64 73 74 predstep1,predst
0430: 65 70 32 20 2e 2e 2e 5d 20 5b 7b 56 41 52 31 3d ep2 ...] [{VAR1=
0440: 66 69 72 73 74 2c 73 65 63 6f 6e 64 2c 74 68 69 first,second,thi
0450: 72 64 7d 5d 20 63 6f 6d 6d 61 6e 64 20 74 6f 20 rd}] command to
0460: 65 78 65 63 75 74 65 0a 3b 3b 20 20 20 42 55 54 execute.;; BUT
0470: 0a 3b 3b 20 6e 6f 77 20 61 72 65 0a 3b 3b 20 73 .;; now are.;; s
0480: 74 65 70 6e 61 6d 65 20 7b 56 41 52 3d 66 69 72 tepname {VAR=fir
0490: 73 74 2c 73 65 63 6f 6e 64 2c 74 68 69 72 64 20 st,second,third
04a0: 2e 2e 2e 7d 20 63 6f 6d 6d 61 6e 64 20 2e 2e 2e ...} command ...
04b0: 0a 3b 3b 20 77 68 65 72 65 20 74 68 65 20 7b 56 .;; where the {V
04c0: 41 52 3d 66 69 72 73 74 2c 73 65 63 6f 6e 64 2c AR=first,second,
04d0: 74 68 69 72 64 20 2e 2e 2e 7d 20 69 73 20 6f 70 third ...} is op
04e0: 74 69 6f 6e 61 6c 2e 0a 0a 3b 3b 20 67 69 76 65 tional...;; give
04f0: 6e 20 61 6e 20 65 78 69 74 20 63 6f 64 65 20 61 n an exit code a
0500: 6e 64 20 77 68 65 74 68 65 72 20 6f 72 20 6e 6f nd whether or no
0510: 74 20 6c 6f 67 70 72 6f 20 77 61 73 20 75 73 65 t logpro was use
0520: 64 20 63 61 6c 63 75 6c 61 74 65 20 4f 4b 2f 42 d calculate OK/B
0530: 41 44 0a 3b 3b 20 72 65 74 75 72 6e 20 23 74 20 AD.;; return #t
0540: 69 66 20 77 65 20 61 72 65 20 6f 6b 2c 20 23 66 if we are ok, #f
0550: 20 6f 74 68 65 72 77 69 73 65 0a 28 64 65 66 69 otherwise.(defi
0560: 6e 65 20 28 73 74 65 70 72 75 6e 2d 67 6f 6f 64 ne (steprun-good
0570: 3f 20 6c 6f 67 70 72 6f 20 65 78 69 74 63 6f 64 ? logpro exitcod
0580: 65 29 0a 20 20 28 6f 72 20 28 65 71 3f 20 65 78 e). (or (eq? ex
0590: 69 74 63 6f 64 65 20 30 29 0a 20 20 20 20 20 20 itcode 0).
05a0: 28 61 6e 64 20 6c 6f 67 70 72 6f 20 28 65 71 3f (and logpro (eq?
05b0: 20 65 78 69 74 63 6f 64 65 20 32 29 29 29 29 0a exitcode 2)))).
05c0: 0a 3b 3b 20 69 66 20 68 61 6e 64 65 64 20 61 20 .;; if handed a
05d0: 73 74 72 69 6e 67 2c 20 70 72 6f 63 65 73 73 20 string, process
05e0: 69 74 2c 20 65 6c 73 65 20 6c 6f 6f 6b 20 66 6f it, else look fo
05f0: 72 20 4d 54 5f 43 4d 44 49 4e 46 4f 0a 28 64 65 r MT_CMDINFO.(de
0600: 66 69 6e 65 20 28 6c 61 75 6e 63 68 3a 67 65 74 fine (launch:get
0610: 2d 63 6d 64 69 6e 66 6f 2d 61 73 73 6f 63 2d 6c -cmdinfo-assoc-l
0620: 69 73 74 20 23 21 6b 65 79 20 28 65 6e 63 6f 64 ist #!key (encod
0630: 65 64 2d 63 6d 64 20 23 66 29 29 0a 20 20 28 6c ed-cmd #f)). (l
0640: 65 74 20 28 28 65 6e 63 63 6d 64 20 28 69 66 20 et ((enccmd (if
0650: 65 6e 63 6f 64 65 64 2d 63 6d 64 20 65 6e 63 6f encoded-cmd enco
0660: 64 65 64 2d 63 6d 64 20 28 67 65 74 65 6e 76 20 ded-cmd (getenv
0670: 22 4d 54 5f 43 4d 44 49 4e 46 4f 22 29 29 29 29 "MT_CMDINFO"))))
0680: 0a 20 20 20 20 28 69 66 20 65 6e 63 63 6d 64 0a . (if enccmd.
0690: 09 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 .(read (open-inp
06a0: 75 74 2d 73 74 72 69 6e 67 20 28 62 61 73 65 36 ut-string (base6
06b0: 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 4:base64-decode
06c0: 65 6e 63 63 6d 64 29 29 29 0a 09 27 28 29 29 29 enccmd)))..'()))
06d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 6c 61 75 6e )..(define (laun
06e0: 63 68 3a 65 78 65 63 75 74 65 20 65 6e 63 6f 64 ch:execute encod
06f0: 65 64 2d 63 6d 64 29 0a 20 20 28 6c 65 74 2a 20 ed-cmd). (let*
0700: 28 28 63 6d 64 69 6e 66 6f 20 20 20 28 72 65 61 ((cmdinfo (rea
0710: 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 d (open-input-st
0720: 72 69 6e 67 20 28 62 61 73 65 36 34 3a 62 61 73 ring (base64:bas
0730: 65 36 34 2d 64 65 63 6f 64 65 20 65 6e 63 6f 64 e64-decode encod
0740: 65 64 2d 63 6d 64 29 29 29 29 29 0a 20 20 20 20 ed-cmd))))).
0750: 28 73 65 74 65 6e 76 20 22 4d 54 5f 43 4d 44 49 (setenv "MT_CMDI
0760: 4e 46 4f 22 20 65 6e 63 6f 64 65 64 2d 63 6d 64 NFO" encoded-cmd
0770: 29 0a 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f ). (if (list?
0780: 20 63 6d 64 69 6e 66 6f 29 20 3b 3b 20 28 28 74 cmdinfo) ;; ((t
0790: 65 73 74 70 61 74 68 20 2f 74 6d 70 2f 6d 72 77 estpath /tmp/mrw
07a0: 65 6c 6c 61 6e 2f 6a 61 7a 7a 6d 69 6e 64 2f 73 ellan/jazzmind/s
07b0: 72 63 2f 65 78 61 6d 70 6c 65 5f 72 75 6e 2f 74 rc/example_run/t
07c0: 65 73 74 73 2f 73 71 6c 69 74 65 73 70 65 65 64 ests/sqlitespeed
07d0: 29 0a 09 3b 3b 20 28 74 65 73 74 2d 6e 61 6d 65 )..;; (test-name
07e0: 20 73 71 6c 69 74 65 73 70 65 65 64 29 20 28 72 sqlitespeed) (r
07f0: 75 6e 73 63 72 69 70 74 20 72 75 6e 73 63 72 69 unscript runscri
0800: 70 74 2e 72 62 29 20 28 64 62 2d 68 6f 73 74 20 pt.rb) (db-host
0810: 6c 6f 63 61 6c 68 6f 73 74 29 20 28 72 75 6e 2d localhost) (run-
0820: 69 64 20 31 29 29 0a 09 28 6c 65 74 2a 20 28 28 id 1))..(let* ((
0830: 74 65 73 74 70 61 74 68 20 20 28 61 73 73 6f 63 testpath (assoc
0840: 2f 64 65 66 61 75 6c 74 20 27 74 65 73 74 70 61 /default 'testpa
0850: 74 68 20 20 63 6d 64 69 6e 66 6f 29 29 20 20 3b th cmdinfo)) ;
0860: 3b 20 74 65 73 74 70 61 74 68 20 69 73 20 74 68 ; testpath is th
0870: 65 20 74 65 73 74 20 73 70 65 63 20 61 72 65 61 e test spec area
0880: 0a 09 20 20 20 20 20 20 20 28 74 6f 70 2d 70 61 .. (top-pa
0890: 74 68 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 th (assoc/defau
08a0: 6c 74 20 27 74 6f 70 70 61 74 68 20 20 20 63 6d lt 'toppath cm
08b0: 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 dinfo))..
08c0: 28 77 6f 72 6b 2d 61 72 65 61 20 28 61 73 73 6f (work-area (asso
08d0: 63 2f 64 65 66 61 75 6c 74 20 27 77 6f 72 6b 2d c/default 'work-
08e0: 61 72 65 61 20 63 6d 64 69 6e 66 6f 29 29 20 20 area cmdinfo))
08f0: 3b 3b 20 77 6f 72 6b 2d 61 72 65 61 20 69 73 20 ;; work-area is
0900: 74 68 65 20 74 65 73 74 20 72 75 6e 20 61 72 65 the test run are
0910: 61 0a 09 20 20 20 20 20 20 20 28 74 65 73 74 2d a.. (test-
0920: 6e 61 6d 65 20 28 61 73 73 6f 63 2f 64 65 66 61 name (assoc/defa
0930: 75 6c 74 20 27 74 65 73 74 2d 6e 61 6d 65 20 63 ult 'test-name c
0940: 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 mdinfo))..
0950: 20 28 72 75 6e 73 63 72 69 70 74 20 28 61 73 73 (runscript (ass
0960: 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 6e 73 oc/default 'runs
0970: 63 72 69 70 74 20 63 6d 64 69 6e 66 6f 29 29 0a cript cmdinfo)).
0980: 09 20 20 20 20 20 20 20 28 65 7a 73 74 65 70 73 . (ezsteps
0990: 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c (assoc/defaul
09a0: 74 20 27 65 7a 73 74 65 70 73 20 20 20 63 6d 64 t 'ezsteps cmd
09b0: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 3b info)).. ;
09c0: 3b 20 28 72 75 6e 72 65 6d 6f 74 65 20 28 61 73 ; (runremote (as
09d0: 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 6e soc/default 'run
09e0: 72 65 6d 6f 74 65 20 63 6d 64 69 6e 66 6f 29 29 remote cmdinfo))
09f0: 0a 09 20 20 20 20 20 20 20 28 74 72 61 6e 73 70 .. (transp
0a00: 6f 72 74 20 28 61 73 73 6f 63 2f 64 65 66 61 75 ort (assoc/defau
0a10: 6c 74 20 27 74 72 61 6e 73 70 6f 72 74 20 63 6d lt 'transport cm
0a20: 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 dinfo))..
0a30: 28 73 65 72 76 65 72 69 6e 66 20 28 61 73 73 6f (serverinf (asso
0a40: 63 2f 64 65 66 61 75 6c 74 20 27 73 65 72 76 65 c/default 'serve
0a50: 72 69 6e 66 20 63 6d 64 69 6e 66 6f 29 29 0a 09 rinf cmdinfo))..
0a60: 20 20 20 20 20 20 20 28 70 6f 72 74 20 20 20 20 (port
0a70: 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 (assoc/default
0a80: 20 27 70 6f 72 74 20 20 20 20 20 20 63 6d 64 69 'port cmdi
0a90: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 72 nfo)).. (r
0aa0: 75 6e 2d 69 64 20 20 20 20 28 61 73 73 6f 63 2f un-id (assoc/
0ab0: 64 65 66 61 75 6c 74 20 27 72 75 6e 2d 69 64 20 default 'run-id
0ac0: 20 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 cmdinfo))..
0ad0: 20 20 20 20 20 28 74 65 73 74 2d 69 64 20 20 20 (test-id
0ae0: 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 (assoc/default '
0af0: 74 65 73 74 2d 69 64 20 20 20 63 6d 64 69 6e 66 test-id cmdinf
0b00: 6f 29 29 0a 09 20 20 20 20 20 20 20 28 74 61 72 o)).. (tar
0b10: 67 65 74 20 20 20 20 28 61 73 73 6f 63 2f 64 65 get (assoc/de
0b20: 66 61 75 6c 74 20 27 74 61 72 67 65 74 20 20 20 fault 'target
0b30: 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 cmdinfo))..
0b40: 20 20 20 28 69 74 65 6d 64 61 74 20 20 20 28 61 (itemdat (a
0b50: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 69 74 ssoc/default 'it
0b60: 65 6d 64 61 74 20 20 20 63 6d 64 69 6e 66 6f 29 emdat cmdinfo)
0b70: 29 0a 09 20 20 20 20 20 20 20 28 65 6e 76 2d 6f ).. (env-o
0b80: 76 72 64 20 20 28 61 73 73 6f 63 2f 64 65 66 61 vrd (assoc/defa
0b90: 75 6c 74 20 27 65 6e 76 2d 6f 76 72 64 20 20 63 ult 'env-ovrd c
0ba0: 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 mdinfo))..
0bb0: 20 28 73 65 74 2d 76 61 72 73 20 20 28 61 73 73 (set-vars (ass
0bc0: 6f 63 2f 64 65 66 61 75 6c 74 20 27 73 65 74 2d oc/default 'set-
0bd0: 76 61 72 73 20 20 63 6d 64 69 6e 66 6f 29 29 20 vars cmdinfo))
0be0: 3b 3b 20 70 72 65 2d 6f 76 65 72 72 69 64 65 73 ;; pre-overrides
0bf0: 20 66 72 6f 6d 20 2d 73 65 74 76 61 72 0a 09 20 from -setvar..
0c00: 20 20 20 20 20 20 28 72 75 6e 6e 61 6d 65 20 20 (runname
0c10: 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 (assoc/default
0c20: 27 72 75 6e 6e 61 6d 65 20 20 20 63 6d 64 69 6e 'runname cmdin
0c30: 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 6d 65 fo)).. (me
0c40: 67 61 74 65 73 74 20 20 28 61 73 73 6f 63 2f 64 gatest (assoc/d
0c50: 65 66 61 75 6c 74 20 27 6d 65 67 61 74 65 73 74 efault 'megatest
0c60: 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 cmdinfo))..
0c70: 20 20 20 20 28 6d 74 2d 62 69 6e 64 69 72 2d 70 (mt-bindir-p
0c80: 61 74 68 20 28 61 73 73 6f 63 2f 64 65 66 61 75 ath (assoc/defau
0c90: 6c 74 20 27 6d 74 2d 62 69 6e 64 69 72 2d 70 61 lt 'mt-bindir-pa
0ca0: 74 68 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 th cmdinfo))..
0cb0: 20 20 20 20 20 28 6b 65 79 73 20 20 20 20 20 20 (keys
0cc0: 23 66 29 0a 09 20 20 20 20 20 20 20 28 6b 65 79 #f).. (key
0cd0: 76 61 6c 73 20 20 20 23 66 29 0a 09 20 20 20 20 vals #f)..
0ce0: 20 20 20 28 66 75 6c 6c 72 75 6e 73 63 72 69 70 (fullrunscrip
0cf0: 74 20 28 69 66 20 28 6e 6f 74 20 72 75 6e 73 63 t (if (not runsc
0d00: 72 69 70 74 29 0a 20 20 20 20 20 20 20 20 20 20 ript).
0d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d20: 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 #f.
0d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d40: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
0d50: 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 (substring-inde
0d60: 78 20 22 2f 22 20 72 75 6e 73 63 72 69 70 74 29 x "/" runscript)
0d70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d90: 20 20 20 20 20 20 20 72 75 6e 73 63 72 69 70 74 runscript
0da0: 20 3b 3b 20 75 73 65 20 75 6e 61 64 75 6c 74 65 ;; use unadulte
0db0: 72 65 64 20 69 66 20 63 6f 6e 74 61 69 6e 73 20 red if contains
0dc0: 73 6c 61 73 68 65 73 0a 20 20 20 20 20 20 20 20 slashes.
0dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
0df0: 65 74 20 28 28 66 75 6c 6c 6e 20 28 63 6f 6e 63 et ((fulln (conc
0e00: 20 74 65 73 74 70 61 74 68 20 22 2f 22 20 72 75 testpath "/" ru
0e10: 6e 73 63 72 69 70 74 29 29 29 0a 09 20 20 20 20 nscript)))..
0e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
0e40: 66 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 f (and (file-exi
0e50: 73 74 73 3f 20 66 75 6c 6c 6e 29 0a 20 20 20 20 sts? fulln).
0e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0e90: 66 69 6c 65 2d 65 78 65 63 75 74 65 2d 61 63 63 file-execute-acc
0ea0: 65 73 73 3f 20 66 75 6c 6c 6e 29 29 0a 20 20 20 ess? fulln)).
0eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ed0: 20 20 20 20 20 20 20 20 20 20 20 66 75 6c 6c 6e fulln
0ee0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0ef0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 r
0f10: 75 6e 73 63 72 69 70 74 29 29 29 29 29 20 3b 3b unscript))))) ;;
0f20: 20 61 73 73 75 6d 65 20 69 74 20 69 73 20 6f 6e assume it is on
0f30: 20 74 68 65 20 70 61 74 68 0a 09 20 20 20 20 20 the path..
0f40: 20 20 28 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 (rollup-status
0f50: 20 30 29 29 0a 09 20 20 28 63 68 61 6e 67 65 2d 0)).. (change-
0f60: 64 69 72 65 63 74 6f 72 79 20 74 6f 70 2d 70 61 directory top-pa
0f70: 74 68 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 th).. (debug:pr
0f80: 69 6e 74 20 32 20 22 45 78 65 63 74 75 69 6e 67 int 2 "Exectuing
0f90: 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 28 " test-name " (
0fa0: 69 64 3a 20 22 20 74 65 73 74 2d 69 64 20 22 29 id: " test-id ")
0fb0: 20 6f 6e 20 22 20 28 67 65 74 2d 68 6f 73 74 2d on " (get-host-
0fc0: 6e 61 6d 65 29 29 0a 09 20 20 3b 3b 20 53 65 74 name)).. ;; Set
0fd0: 75 70 20 74 68 65 20 2a 72 75 6e 72 65 6d 6f 74 up the *runremot
0fe0: 65 2a 20 67 6c 6f 62 61 6c 20 76 61 72 0a 09 20 e* global var..
0ff0: 20 28 69 66 20 2a 72 75 6e 72 65 6d 6f 74 65 2a (if *runremote*
1000: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
1010: 22 45 52 52 4f 52 3a 20 49 27 6d 20 6e 6f 74 20 "ERROR: I'm not
1020: 65 78 70 65 63 74 69 6e 67 20 2a 72 75 6e 72 65 expecting *runre
1030: 6d 6f 74 65 2a 20 74 6f 20 62 65 20 73 65 74 20 mote* to be set
1040: 61 74 20 74 68 69 73 20 74 69 6d 65 22 29 29 0a at this time")).
1050: 09 20 20 3b 3b 20 28 73 65 74 21 20 2a 72 75 6e . ;; (set! *run
1060: 72 65 6d 6f 74 65 2a 20 72 75 6e 72 65 6d 6f 74 remote* runremot
1070: 65 29 0a 09 20 20 28 73 65 74 21 20 2a 74 72 61 e).. (set! *tra
1080: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 28 73 74 nsport-type* (st
1090: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 74 72 61 ring->symbol tra
10a0: 6e 73 70 6f 72 74 29 29 0a 09 20 20 28 73 65 74 nsport)).. (set
10b0: 21 20 6b 65 79 73 20 20 20 20 20 20 20 28 63 64 ! keys (cd
10c0: 62 3a 72 65 6d 6f 74 65 2d 72 75 6e 20 64 62 3a b:remote-run db:
10d0: 67 65 74 2d 6b 65 79 73 20 23 66 29 29 0a 09 20 get-keys #f))..
10e0: 20 28 73 65 74 21 20 6b 65 79 76 61 6c 73 20 20 (set! keyvals
10f0: 20 20 28 6b 65 79 73 3a 74 61 72 67 65 74 2d 3e (keys:target->
1100: 6b 65 79 76 61 6c 20 6b 65 79 73 20 74 61 72 67 keyval keys targ
1110: 65 74 29 29 0a 09 20 20 3b 3b 20 61 70 70 6c 79 et)).. ;; apply
1120: 20 70 72 65 2d 6f 76 65 72 72 69 64 65 73 20 62 pre-overrides b
1130: 65 66 6f 72 65 20 6f 74 68 65 72 20 76 61 72 69 efore other vari
1140: 61 62 6c 65 73 2e 20 54 68 65 20 70 72 65 2d 6f ables. The pre-o
1150: 76 65 72 72 69 64 65 20 76 61 72 73 20 6d 75 73 verride vars mus
1160: 74 20 6e 6f 74 0a 09 20 20 3b 3b 20 63 6c 6f 62 t not.. ;; clob
1170: 62 65 72 73 20 74 68 69 6e 67 73 20 66 72 6f 6d bers things from
1180: 20 74 68 65 20 6f 66 66 69 63 69 61 6c 20 73 6f the official so
1190: 75 72 63 65 73 20 73 75 63 68 20 61 73 20 6d 65 urces such as me
11a0: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 61 6e gatest.config an
11b0: 64 20 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e d runconfigs.con
11c0: 66 69 67 0a 09 20 20 28 69 66 20 28 73 74 72 69 fig.. (if (stri
11d0: 6e 67 3f 20 73 65 74 2d 76 61 72 73 29 0a 09 20 ng? set-vars)..
11e0: 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 70 (let ((varp
11f0: 61 69 72 73 20 28 73 74 72 69 6e 67 2d 73 70 6c airs (string-spl
1200: 69 74 20 73 65 74 2d 76 61 72 73 20 22 2c 22 29 it set-vars ",")
1210: 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e ))...(debug:prin
1220: 74 20 34 20 22 76 61 72 70 61 69 72 73 3a 20 22 t 4 "varpairs: "
1230: 20 76 61 72 70 61 69 72 73 29 0a 09 09 28 6d 61 varpairs)...(ma
1240: 70 20 28 6c 61 6d 62 64 61 20 28 76 61 72 70 61 p (lambda (varpa
1250: 69 72 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 ir)... (le
1260: 74 20 28 28 76 61 72 76 61 6c 20 28 73 74 72 69 t ((varval (stri
1270: 6e 67 2d 73 70 6c 69 74 20 76 61 72 70 61 69 72 ng-split varpair
1280: 20 22 3d 22 29 29 29 0a 09 09 09 20 28 69 66 20 "="))).... (if
1290: 28 65 71 3f 20 28 6c 65 6e 67 74 68 20 76 61 72 (eq? (length var
12a0: 76 61 6c 29 20 32 29 0a 09 09 09 20 20 20 20 20 val) 2)....
12b0: 28 6c 65 74 20 28 28 76 61 72 20 28 63 61 72 20 (let ((var (car
12c0: 76 61 72 76 61 6c 29 29 0a 09 09 09 09 20 20 20 varval)).....
12d0: 28 76 61 6c 20 28 63 61 64 72 20 76 61 72 76 61 (val (cadr varva
12e0: 6c 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 l))).... (
12f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 31 20 22 41 debug:print 1 "A
1300: 64 64 69 6e 67 20 70 72 65 2d 76 61 72 2f 76 61 dding pre-var/va
1310: 6c 20 22 20 76 61 72 20 22 20 3d 20 22 20 76 61 l " var " = " va
1320: 6c 20 22 20 74 6f 20 74 68 65 20 65 6e 76 69 72 l " to the envir
1330: 6f 6e 6d 65 6e 74 22 29 0a 09 09 09 20 20 20 20 onment")....
1340: 20 20 20 28 73 65 74 65 6e 76 20 76 61 72 20 76 (setenv var v
1350: 61 6c 29 29 29 29 29 0a 09 09 20 20 20 20 20 76 al)))))... v
1360: 61 72 70 61 69 72 73 29 29 29 0a 09 20 20 28 73 arpairs))).. (s
1370: 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 52 etenv "MT_TEST_R
1380: 55 4e 5f 44 49 52 22 20 77 6f 72 6b 2d 61 72 65 UN_DIR" work-are
1390: 61 29 0a 09 20 20 28 73 65 74 65 6e 76 20 22 4d a).. (setenv "M
13a0: 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 65 73 T_TEST_NAME" tes
13b0: 74 2d 6e 61 6d 65 29 0a 09 20 20 28 73 65 74 65 t-name).. (sete
13c0: 6e 76 20 22 4d 54 5f 49 54 45 4d 5f 49 4e 46 4f nv "MT_ITEM_INFO
13d0: 22 20 28 63 6f 6e 63 20 69 74 65 6d 64 61 74 29 " (conc itemdat)
13e0: 29 0a 09 20 20 28 73 65 74 65 6e 76 20 22 4d 54 ).. (setenv "MT
13f0: 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e _RUNNAME" runn
1400: 61 6d 65 29 0a 09 20 20 28 73 65 74 65 6e 76 20 ame).. (setenv
1410: 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 20 20 6d "MT_MEGATEST" m
1420: 65 67 61 74 65 73 74 29 0a 09 20 20 28 73 65 74 egatest).. (set
1430: 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 20 env "MT_TARGET"
1440: 20 20 20 74 61 72 67 65 74 29 0a 09 20 20 28 69 target).. (i
1450: 66 20 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 f mt-bindir-path
1460: 20 28 73 65 74 65 6e 76 20 22 50 41 54 48 22 20 (setenv "PATH"
1470: 28 63 6f 6e 63 20 28 67 65 74 65 6e 76 20 22 50 (conc (getenv "P
1480: 41 54 48 22 29 20 22 3a 22 20 6d 74 2d 62 69 6e ATH") ":" mt-bin
1490: 64 69 72 2d 70 61 74 68 29 29 29 0a 09 20 20 3b dir-path))).. ;
14a0: 3b 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 ; (change-direct
14b0: 6f 72 79 20 74 6f 70 2d 70 61 74 68 29 0a 09 20 ory top-path)..
14c0: 20 28 69 66 20 28 6e 6f 74 20 28 73 65 74 75 70 (if (not (setup
14d0: 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 20 20 -for-run))..
14e0: 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 (begin...(debu
14f0: 67 3a 70 72 69 6e 74 20 30 20 22 46 61 69 6c 65 g:print 0 "Faile
1500: 64 20 74 6f 20 73 65 74 75 70 2c 20 65 78 69 74 d to setup, exit
1510: 69 6e 67 22 29 20 0a 09 09 3b 3b 20 28 73 71 6c ing") ...;; (sql
1520: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
1530: 62 29 0a 09 09 3b 3b 20 28 73 71 6c 69 74 65 33 b)...;; (sqlite3
1540: 3a 66 69 6e 61 6c 69 7a 65 21 20 74 64 62 29 0a :finalize! tdb).
1550: 09 09 28 65 78 69 74 20 31 29 29 29 0a 09 20 20 ..(exit 1)))..
1560: 3b 3b 20 43 61 6e 20 73 65 74 75 70 20 61 73 20 ;; Can setup as
1570: 63 6c 69 65 6e 74 20 66 6f 72 20 73 65 72 76 65 client for serve
1580: 72 20 6d 6f 64 65 20 6e 6f 77 0a 09 20 20 3b 3b r mode now.. ;;
1590: 20 28 63 6c 69 65 6e 74 3a 73 65 74 75 70 29 0a (client:setup).
15a0: 0a 09 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 .. (change-dire
15b0: 63 74 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 ctory *toppath*)
15c0: 20 0a 09 20 20 28 73 65 74 2d 6d 65 67 61 74 65 .. (set-megate
15d0: 73 74 2d 65 6e 76 2d 76 61 72 73 20 72 75 6e 2d st-env-vars run-
15e0: 69 64 29 20 3b 3b 20 74 68 65 73 65 20 6d 61 79 id) ;; these may
15f0: 20 62 65 20 6e 65 65 64 65 64 20 62 79 20 74 68 be needed by th
1600: 65 20 6c 61 75 6e 63 68 69 6e 67 20 70 72 6f 63 e launching proc
1610: 65 73 73 0a 09 20 20 28 63 68 61 6e 67 65 2d 64 ess.. (change-d
1620: 69 72 65 63 74 6f 72 79 20 77 6f 72 6b 2d 61 72 irectory work-ar
1630: 65 61 29 20 0a 0a 09 20 20 28 73 65 74 2d 72 75 ea) ... (set-ru
1640: 6e 2d 63 6f 6e 66 69 67 2d 76 61 72 73 20 72 75 n-config-vars ru
1650: 6e 2d 69 64 20 6b 65 79 76 61 6c 73 20 74 61 72 n-id keyvals tar
1660: 67 65 74 29 20 3b 3b 20 28 64 62 3a 67 65 74 2d get) ;; (db:get-
1670: 74 61 72 67 65 74 20 64 62 20 72 75 6e 2d 69 64 target db run-id
1680: 29 29 0a 09 20 20 3b 3b 20 65 6e 76 69 72 6f 6e )).. ;; environ
1690: 6d 65 6e 74 20 6f 76 65 72 72 69 64 65 73 20 61 ment overrides a
16a0: 72 65 20 64 6f 6e 65 20 2a 62 65 66 6f 72 65 2a re done *before*
16b0: 20 74 68 65 20 72 65 6d 61 69 6e 69 6e 67 20 63 the remaining c
16c0: 72 69 74 69 63 61 6c 20 65 6e 76 61 72 73 2e 0a ritical envars..
16d0: 09 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 . (alist->env-v
16e0: 61 72 73 20 65 6e 76 2d 6f 76 72 64 29 0a 09 20 ars env-ovrd)..
16f0: 20 28 73 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 (set-megatest-e
1700: 6e 76 2d 76 61 72 73 20 72 75 6e 2d 69 64 29 0a nv-vars run-id).
1710: 09 20 20 28 73 65 74 2d 69 74 65 6d 2d 65 6e 76 . (set-item-env
1720: 2d 76 61 72 73 20 69 74 65 6d 64 61 74 29 0a 09 -vars itemdat)..
1730: 20 20 28 73 61 76 65 2d 65 6e 76 69 72 6f 6e 6d (save-environm
1740: 65 6e 74 2d 61 73 2d 66 69 6c 65 73 20 22 6d 65 ent-as-files "me
1750: 67 61 74 65 73 74 22 29 0a 09 20 20 3b 3b 20 6f gatest").. ;; o
1760: 70 65 6e 2d 72 75 6e 2d 63 6c 6f 73 65 20 6e 6f pen-run-close no
1770: 74 20 6e 65 65 64 65 64 20 66 6f 72 20 74 65 73 t needed for tes
1780: 74 2d 73 65 74 2d 6d 65 74 61 2d 69 6e 66 6f 0a t-set-meta-info.
1790: 09 20 20 28 74 65 73 74 73 3a 73 65 74 2d 6d 65 . (tests:set-me
17a0: 74 61 2d 69 6e 66 6f 20 23 66 20 74 65 73 74 2d ta-info #f test-
17b0: 69 64 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e id run-id test-n
17c0: 61 6d 65 20 69 74 65 6d 64 61 74 20 30 20 77 6f ame itemdat 0 wo
17d0: 72 6b 2d 61 72 65 61 29 0a 09 20 20 28 74 65 73 rk-area).. (tes
17e0: 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 ts:test-set-stat
17f0: 75 73 21 20 74 65 73 74 2d 69 64 20 22 52 45 4d us! test-id "REM
1800: 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 6e OTEHOSTSTART" "n
1810: 2f 61 22 20 28 61 72 67 73 3a 67 65 74 2d 61 72 /a" (args:get-ar
1820: 67 20 22 2d 6d 22 29 20 23 66 29 0a 09 20 20 28 g "-m") #f).. (
1830: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
1840: 20 22 2d 78 74 65 72 6d 22 29 0a 09 20 20 20 20 "-xterm")..
1850: 20 20 28 73 65 74 21 20 66 75 6c 6c 72 75 6e 73 (set! fullruns
1860: 63 72 69 70 74 20 22 78 74 65 72 6d 22 29 0a 09 cript "xterm")..
1870: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 66 (if (and f
1880: 75 6c 6c 72 75 6e 73 63 72 69 70 74 20 28 6e 6f ullrunscript (no
1890: 74 20 28 66 69 6c 65 2d 65 78 65 63 75 74 65 2d t (file-execute-
18a0: 61 63 63 65 73 73 3f 20 66 75 6c 6c 72 75 6e 73 access? fullruns
18b0: 63 72 69 70 74 29 29 29 0a 09 09 20 20 28 73 79 cript)))... (sy
18c0: 73 74 65 6d 20 28 63 6f 6e 63 20 22 63 68 6d 6f stem (conc "chmo
18d0: 64 20 75 67 2b 78 20 22 20 66 75 6c 6c 72 75 6e d ug+x " fullrun
18e0: 73 63 72 69 70 74 29 29 29 29 0a 09 20 20 3b 3b script)))).. ;;
18f0: 20 57 65 20 61 72 65 20 61 62 6f 75 74 20 74 6f We are about to
1900: 20 61 63 74 75 61 6c 6c 79 20 6b 69 63 6b 20 6f actually kick o
1910: 66 66 20 74 68 65 20 74 65 73 74 0a 09 20 20 3b ff the test.. ;
1920: 3b 20 73 6f 20 74 68 69 73 20 69 73 20 61 20 67 ; so this is a g
1930: 6f 6f 64 20 70 6c 61 63 65 20 74 6f 20 72 65 6d ood place to rem
1940: 6f 76 65 20 74 68 65 20 72 65 63 6f 72 64 73 20 ove the records
1950: 66 6f 72 20 0a 09 20 20 3b 3b 20 61 6e 79 20 70 for .. ;; any p
1960: 72 65 76 69 6f 75 73 20 72 75 6e 73 0a 09 20 20 revious runs..
1970: 3b 3b 20 28 64 62 3a 74 65 73 74 2d 72 65 6d 6f ;; (db:test-remo
1980: 76 65 2d 73 74 65 70 73 20 64 62 20 72 75 6e 2d ve-steps db run-
1990: 69 64 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d id testname item
19a0: 64 61 74 29 0a 09 20 20 0a 09 20 20 28 6c 65 74 dat).. .. (let
19b0: 2a 20 28 28 6d 20 20 20 20 20 20 20 20 20 20 20 * ((m
19c0: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 09 (make-mutex))..
19d0: 09 20 28 6b 69 6c 6c 2d 6a 6f 62 3f 20 20 20 20 . (kill-job?
19e0: 23 66 29 0a 09 09 20 28 65 78 69 74 2d 69 6e 66 #f)... (exit-inf
19f0: 6f 20 20 20 20 28 76 65 63 74 6f 72 20 23 74 20 o (vector #t
1a00: 23 74 20 23 74 29 29 0a 09 09 20 28 6a 6f 62 2d #t #t))... (job-
1a10: 74 68 72 65 61 64 20 20 20 23 66 29 0a 09 09 20 thread #f)...
1a20: 28 72 75 6e 69 74 20 20 20 20 20 20 20 20 28 6c (runit (l
1a30: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 3b 3b ambda ()..... ;;
1a40: 20 28 6c 65 74 2d 76 61 6c 75 65 73 0a 09 09 09 (let-values....
1a50: 09 20 3b 3b 20 20 28 28 28 70 69 64 20 65 78 69 . ;; (((pid exi
1a60: 74 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f t-status exit-co
1a70: 64 65 29 0a 09 09 09 09 20 3b 3b 20 20 20 20 28 de)..... ;; (
1a80: 72 75 6e 2d 6e 2d 77 61 69 74 20 66 75 6c 6c 72 run-n-wait fullr
1a90: 75 6e 73 63 72 69 70 74 29 29 29 0a 09 09 09 09 unscript))).....
1aa0: 20 28 74 65 73 74 73 3a 74 65 73 74 2d 73 65 74 (tests:test-set
1ab0: 2d 73 74 61 74 75 73 21 20 74 65 73 74 2d 69 64 -status! test-id
1ac0: 20 22 52 55 4e 4e 49 4e 47 22 20 22 6e 2f 61 22 "RUNNING" "n/a"
1ad0: 20 23 66 20 23 66 29 0a 09 09 09 09 20 3b 3b 20 #f #f)..... ;;
1ae0: 69 66 20 74 68 65 72 65 20 69 73 20 61 20 72 75 if there is a ru
1af0: 6e 73 63 72 69 70 74 20 64 6f 20 69 74 20 66 69 nscript do it fi
1b00: 72 73 74 0a 09 09 09 09 20 28 69 66 20 66 75 6c rst..... (if ful
1b10: 6c 72 75 6e 73 63 72 69 70 74 0a 09 09 09 09 20 lrunscript.....
1b20: 20 20 20 20 28 6c 65 74 20 28 28 70 69 64 20 28 (let ((pid (
1b30: 70 72 6f 63 65 73 73 2d 72 75 6e 20 66 75 6c 6c process-run full
1b40: 72 75 6e 73 63 72 69 70 74 29 29 29 0a 09 09 09 runscript)))....
1b50: 09 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f . (let loo
1b60: 70 20 28 28 69 20 30 29 29 0a 09 09 09 09 09 20 p ((i 0))......
1b70: 28 6c 65 74 2d 76 61 6c 75 65 73 0a 09 09 09 09 (let-values.....
1b80: 09 20 20 28 28 28 70 69 64 2d 76 61 6c 20 65 78 . (((pid-val ex
1b90: 69 74 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 it-status exit-c
1ba0: 6f 64 65 29 20 28 70 72 6f 63 65 73 73 2d 77 61 ode) (process-wa
1bb0: 69 74 20 70 69 64 20 23 74 29 29 29 0a 09 09 09 it pid #t)))....
1bc0: 09 09 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 .. (mutex-lock!
1bd0: 20 6d 29 0a 09 09 09 09 09 20 20 28 76 65 63 74 m)...... (vect
1be0: 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e 66 or-set! exit-inf
1bf0: 6f 20 30 20 70 69 64 29 0a 09 09 09 09 09 20 20 o 0 pid)......
1c00: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 (vector-set! exi
1c10: 74 2d 69 6e 66 6f 20 31 20 65 78 69 74 2d 73 74 t-info 1 exit-st
1c20: 61 74 75 73 29 0a 09 09 09 09 09 20 20 28 76 65 atus)...... (ve
1c30: 63 74 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 ctor-set! exit-i
1c40: 6e 66 6f 20 32 20 65 78 69 74 2d 63 6f 64 65 29 nfo 2 exit-code)
1c50: 0a 09 09 09 09 09 20 20 28 73 65 74 21 20 72 6f ...... (set! ro
1c60: 6c 6c 75 70 2d 73 74 61 74 75 73 20 65 78 69 74 llup-status exit
1c70: 2d 63 6f 64 65 29 20 0a 09 09 09 09 09 20 20 28 -code) ...... (
1c80: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 29 mutex-unlock! m)
1c90: 0a 09 09 09 09 09 20 20 28 69 66 20 28 65 71 3f ...... (if (eq?
1ca0: 20 70 69 64 2d 76 61 6c 20 30 29 0a 09 09 09 09 pid-val 0).....
1cb0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
1cc0: 09 09 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 ....(thread-slee
1cd0: 70 21 20 32 29 0a 09 09 09 09 09 09 28 6c 6f 6f p! 2).......(loo
1ce0: 70 20 28 2b 20 69 20 31 29 29 29 0a 09 09 09 09 p (+ i 1))).....
1cf0: 09 20 20 20 20 20 20 29 29 29 29 29 0a 09 09 09 . )))))....
1d00: 09 20 3b 3b 20 74 68 65 6e 2c 20 69 66 20 72 75 . ;; then, if ru
1d10: 6e 73 63 72 69 70 74 20 72 61 6e 20 6f 6b 20 28 nscript ran ok (
1d20: 6f 72 20 64 69 64 20 6e 6f 74 20 67 65 74 20 63 or did not get c
1d30: 61 6c 6c 65 64 29 0a 09 09 09 09 20 3b 3b 20 64 alled)..... ;; d
1d40: 6f 20 61 6c 6c 20 74 68 65 20 65 7a 73 74 65 70 o all the ezstep
1d50: 73 20 28 69 66 20 61 6e 79 29 0a 09 09 09 09 20 s (if any).....
1d60: 28 69 66 20 65 7a 73 74 65 70 73 0a 09 09 09 09 (if ezsteps.....
1d70: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 65 73 (let* ((tes
1d80: 74 63 6f 6e 66 69 67 20 28 72 65 61 64 2d 63 6f tconfig (read-co
1d90: 6e 66 69 67 20 28 63 6f 6e 63 20 77 6f 72 6b 2d nfig (conc work-
1da0: 61 72 65 61 20 22 2f 74 65 73 74 63 6f 6e 66 69 area "/testconfi
1db0: 67 22 29 20 23 66 20 23 74 20 65 6e 76 69 72 6f g") #f #t enviro
1dc0: 6e 2d 70 61 74 74 3a 20 22 70 72 65 2d 6c 61 75 n-patt: "pre-lau
1dd0: 6e 63 68 2d 65 6e 76 2d 76 61 72 73 22 29 29 20 nch-env-vars"))
1de0: 3b 3b 20 46 49 58 4d 45 3f 3f 3f 20 69 73 20 61 ;; FIXME??? is a
1df0: 6c 6c 6f 77 2d 73 79 73 74 65 6d 20 6f 6b 20 68 llow-system ok h
1e00: 65 72 65 3f 0a 09 09 09 09 09 20 20 20 20 28 65 ere?...... (e
1e10: 7a 73 74 65 70 73 6c 73 74 20 28 68 61 73 68 2d zstepslst (hash-
1e20: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
1e30: 74 20 74 65 73 74 63 6f 6e 66 69 67 20 22 65 7a t testconfig "ez
1e40: 73 74 65 70 73 22 20 27 28 29 29 29 29 0a 09 09 steps" '())))...
1e50: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f .. (if (no
1e60: 74 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 t (file-exists?
1e70: 22 2e 65 7a 73 74 65 70 73 22 29 29 28 63 72 65 ".ezsteps"))(cre
1e80: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 22 2e ate-directory ".
1e90: 65 7a 73 74 65 70 73 22 29 29 0a 09 09 09 09 20 ezsteps")).....
1ea0: 20 20 20 20 20 20 3b 3b 20 69 66 20 65 7a 73 74 ;; if ezst
1eb0: 65 70 73 20 77 61 73 20 64 65 66 69 6e 65 64 20 eps was defined
1ec0: 74 68 65 6e 20 77 65 20 61 72 65 20 73 75 72 65 then we are sure
1ed0: 20 74 6f 20 68 61 76 65 20 61 74 20 6c 65 61 73 to have at leas
1ee0: 74 20 6f 6e 65 20 73 74 65 70 20 62 75 74 20 63 t one step but c
1ef0: 68 65 63 6b 20 61 6e 79 77 61 79 0a 09 09 09 09 heck anyway.....
1f00: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
1f10: 28 3e 20 28 6c 65 6e 67 74 68 20 65 7a 73 74 65 (> (length ezste
1f20: 70 73 6c 73 74 29 20 30 29 29 0a 09 09 09 09 09 pslst) 0))......
1f30: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1f40: 30 20 22 45 52 52 4f 52 3a 20 65 7a 73 74 65 70 0 "ERROR: ezstep
1f50: 73 20 64 65 66 69 6e 65 64 20 62 75 74 20 65 7a s defined but ez
1f60: 73 74 65 70 73 6c 73 74 20 69 73 20 7a 65 72 6f stepslst is zero
1f70: 20 6c 65 6e 67 74 68 22 29 0a 09 09 09 09 09 20 length")......
1f80: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 65 7a (let loop ((ez
1f90: 73 74 65 70 20 28 63 61 72 20 65 7a 73 74 65 70 step (car ezstep
1fa0: 73 6c 73 74 29 29 0a 09 09 09 09 09 09 20 20 20 slst)).......
1fb0: 20 20 20 28 74 61 6c 20 20 20 20 28 63 64 72 20 (tal (cdr
1fc0: 65 7a 73 74 65 70 73 6c 73 74 29 29 0a 09 09 09 ezstepslst))....
1fd0: 09 09 09 20 20 20 20 20 20 28 70 72 65 76 73 74 ... (prevst
1fe0: 65 70 20 23 66 29 29 0a 09 09 09 09 09 20 20 20 ep #f))......
1ff0: 20 20 3b 3b 20 63 68 65 63 6b 20 65 78 69 74 2d ;; check exit-
2000: 69 6e 66 6f 20 28 76 65 63 74 6f 72 2d 72 65 66 info (vector-ref
2010: 20 65 78 69 74 2d 69 6e 66 6f 20 31 29 0a 09 09 exit-info 1)...
2020: 09 09 09 20 20 20 20 20 28 69 66 20 28 76 65 63 ... (if (vec
2030: 74 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 tor-ref exit-inf
2040: 6f 20 31 29 0a 09 09 09 09 09 09 20 28 6c 65 74 o 1)....... (let
2050: 2a 20 28 28 73 74 65 70 6e 61 6d 65 20 20 28 63 * ((stepname (c
2060: 61 72 20 65 7a 73 74 65 70 29 29 20 20 3b 3b 20 ar ezstep)) ;;
2070: 64 6f 20 73 74 75 66 66 20 74 6f 20 72 75 6e 20 do stuff to run
2080: 74 68 65 20 73 74 65 70 0a 09 09 09 09 09 09 09 the step........
2090: 28 73 74 65 70 69 6e 66 6f 20 20 28 63 61 64 72 (stepinfo (cadr
20a0: 20 65 7a 73 74 65 70 29 29 0a 09 09 09 09 09 09 ezstep)).......
20b0: 09 28 73 74 65 70 70 61 72 74 73 20 28 73 74 72 .(stepparts (str
20c0: 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 ing-match (regex
20d0: 70 20 22 5e 28 5c 5c 7b 28 5b 5e 5c 5c 7d 5d 2a p "^(\\{([^\\}]*
20e0: 29 5c 5c 7d 5c 5c 73 2a 7c 29 28 2e 2a 29 24 22 )\\}\\s*|)(.*)$"
20f0: 29 20 73 74 65 70 69 6e 66 6f 29 29 0a 09 09 09 ) stepinfo))....
2100: 09 09 09 09 28 73 74 65 70 70 61 72 6d 73 20 28 ....(stepparms (
2110: 6c 69 73 74 2d 72 65 66 20 73 74 65 70 70 61 72 list-ref steppar
2120: 74 73 20 32 29 29 20 3b 3b 20 66 6f 72 20 66 75 ts 2)) ;; for fu
2130: 74 75 72 65 20 75 73 65 2c 20 7b 56 41 52 3d 31 ture use, {VAR=1
2140: 2c 32 2c 33 7d 2c 20 72 75 6e 20 73 74 65 70 20 ,2,3}, run step
2150: 66 6f 72 20 65 61 63 68 20 0a 09 09 09 09 09 09 for each .......
2160: 09 28 73 74 65 70 63 6d 64 20 20 20 28 6c 69 73 .(stepcmd (lis
2170: 74 2d 72 65 66 20 73 74 65 70 70 61 72 74 73 20 t-ref stepparts
2180: 33 29 29 0a 09 09 09 09 09 09 09 28 73 63 72 69 3))........(scri
2190: 70 74 20 20 20 20 22 22 29 20 3b 20 22 23 21 2f pt "") ; "#!/
21a0: 62 69 6e 2f 62 61 73 68 5c 6e 22 29 20 3b 3b 20 bin/bash\n") ;;
21b0: 79 65 70 2c 20 77 65 20 64 65 70 65 6e 64 20 6f yep, we depend o
21c0: 6e 20 62 69 6e 2f 62 61 73 68 20 46 49 58 4d 45 n bin/bash FIXME
21d0: 21 21 21 0a 09 09 09 09 09 09 09 28 6c 6f 67 70 !!!........(logp
21e0: 72 6f 2d 75 73 65 64 20 23 66 29 29 0a 09 09 09 ro-used #f))....
21f0: 09 09 09 20 20 20 3b 3b 20 4e 42 2f 2f 20 63 61 ... ;; NB// ca
2200: 6e 20 73 61 66 65 6c 79 20 61 73 73 75 6d 65 20 n safely assume
2210: 77 65 20 61 72 65 20 69 6e 20 74 65 73 74 2d 61 we are in test-a
2220: 72 65 61 20 64 69 72 65 63 74 6f 72 79 0a 09 09 rea directory...
2230: 09 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 .... (debug:pr
2240: 69 6e 74 20 34 20 22 65 7a 73 74 65 70 73 3a 5c int 4 "ezsteps:\
2250: 6e 20 73 74 65 70 6e 61 6d 65 3a 20 22 20 73 74 n stepname: " st
2260: 65 70 6e 61 6d 65 20 22 20 73 74 65 70 69 6e 66 epname " stepinf
2270: 6f 3a 20 22 20 73 74 65 70 69 6e 66 6f 20 22 20 o: " stepinfo "
2280: 73 74 65 70 70 61 72 74 73 3a 20 22 20 73 74 65 stepparts: " ste
2290: 70 70 61 72 74 73 0a 09 09 09 09 09 09 09 09 22 pparts........."
22a0: 20 73 74 65 70 70 61 72 6d 73 3a 20 22 20 73 74 stepparms: " st
22b0: 65 70 70 61 72 6d 73 20 22 20 73 74 65 70 63 6d epparms " stepcm
22c0: 64 3a 20 22 20 73 74 65 70 63 6d 64 29 0a 09 09 d: " stepcmd)...
22d0: 09 09 09 09 20 20 20 0a 09 09 09 09 09 09 20 20 .... .......
22e0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
22f0: 73 3f 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 6d s? (conc stepnam
2300: 65 20 22 2e 6c 6f 67 70 72 6f 22 29 29 28 73 65 e ".logpro"))(se
2310: 74 21 20 6c 6f 67 70 72 6f 2d 75 73 65 64 20 23 t! logpro-used #
2320: 74 29 29 0a 0a 09 09 09 09 09 09 20 20 20 3b 3b t))........ ;;
2330: 20 3b 3b 20 66 69 72 73 74 20 73 6f 75 72 63 65 ;; first source
2340: 20 74 68 65 20 70 72 65 76 69 6f 75 73 20 65 6e the previous en
2350: 76 69 72 6f 6e 6d 65 6e 74 0a 09 09 09 09 09 09 vironment.......
2360: 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 70 72 65 ;; (let ((pre
2370: 76 2d 65 6e 76 20 28 63 6f 6e 63 20 22 2e 65 7a v-env (conc ".ez
2380: 73 74 65 70 73 2f 22 20 70 72 65 76 73 74 65 70 steps/" prevstep
2390: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 61 (if (string-sea
23a0: 72 63 68 20 28 72 65 67 65 78 70 20 22 63 73 68 rch (regexp "csh
23b0: 22 29 20 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 ") ....... ;;
23c0: 20 20 20 20 20 09 09 09 09 09 09 09 20 28 67 65 ....... (ge
23d0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
23e0: 72 69 61 62 6c 65 20 22 53 48 45 4c 4c 22 29 29 riable "SHELL"))
23f0: 20 22 2e 63 73 68 22 20 22 2e 73 68 22 29 29 29 ".csh" ".sh")))
2400: 29 0a 09 09 09 09 09 09 20 20 20 3b 3b 20 20 20 )....... ;;
2410: 28 69 66 20 28 61 6e 64 20 70 72 65 76 73 74 65 (if (and prevste
2420: 70 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 p (file-exists?
2430: 70 72 65 76 2d 65 6e 76 29 29 0a 09 09 09 09 09 prev-env))......
2440: 09 20 20 20 3b 3b 20 20 20 20 20 20 20 28 73 65 . ;; (se
2450: 74 21 20 73 63 72 69 70 74 20 28 63 6f 6e 63 20 t! script (conc
2460: 73 63 72 69 70 74 20 22 73 6f 75 72 63 65 20 22 script "source "
2470: 20 70 72 65 76 2d 65 6e 76 29 29 29 29 0a 09 09 prev-env))))...
2480: 09 09 09 09 20 20 20 0a 09 09 09 09 09 09 20 20 .... .......
2490: 20 3b 3b 20 63 61 6c 6c 20 74 68 65 20 63 6f 6d ;; call the com
24a0: 6d 61 6e 64 20 75 73 69 6e 67 20 6d 74 5f 65 7a mand using mt_ez
24b0: 73 74 65 70 0a 09 09 09 09 09 09 20 20 20 28 73 step....... (s
24c0: 65 74 21 20 73 63 72 69 70 74 20 28 63 6f 6e 63 et! script (conc
24d0: 20 22 6d 74 5f 65 7a 73 74 65 70 20 22 20 73 74 "mt_ezstep " st
24e0: 65 70 6e 61 6d 65 20 22 20 22 20 28 69 66 20 70 epname " " (if p
24f0: 72 65 76 73 74 65 70 20 70 72 65 76 73 74 65 70 revstep prevstep
2500: 20 22 2d 22 29 20 22 20 22 20 73 74 65 70 63 6d "-") " " stepcm
2510: 64 29 29 0a 0a 09 09 09 09 09 09 20 20 20 28 64 d))........ (d
2520: 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 73 63 ebug:print 4 "sc
2530: 72 69 70 74 3a 20 22 20 73 63 72 69 70 74 29 0a ript: " script).
2540: 09 09 09 09 09 09 20 20 20 3b 3b 20 44 4f 20 4e ...... ;; DO N
2550: 4f 54 20 72 65 6d 6f 74 65 0a 09 09 09 09 09 09 OT remote.......
2560: 20 20 20 28 64 62 3a 74 65 73 74 73 74 65 70 2d (db:teststep-
2570: 73 65 74 2d 73 74 61 74 75 73 21 20 23 66 20 74 set-status! #f t
2580: 65 73 74 2d 69 64 20 73 74 65 70 6e 61 6d 65 20 est-id stepname
2590: 22 73 74 61 72 74 22 20 22 2d 22 20 23 66 20 23 "start" "-" #f #
25a0: 66 20 77 6f 72 6b 2d 61 72 65 61 3a 20 77 6f 72 f work-area: wor
25b0: 6b 2d 61 72 65 61 29 0a 09 09 09 09 09 09 20 20 k-area).......
25c0: 20 3b 3b 20 6e 6f 77 20 6c 61 75 6e 63 68 0a 09 ;; now launch..
25d0: 09 09 09 09 09 20 20 20 28 6c 65 74 20 28 28 70 ..... (let ((p
25e0: 69 64 20 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 id (process-run
25f0: 73 63 72 69 70 74 29 29 29 0a 09 09 09 09 09 09 script))).......
2600: 20 20 20 20 20 28 6c 65 74 20 70 72 6f 63 65 73 (let proces
2610: 73 6c 6f 6f 70 20 28 28 69 20 30 29 29 0a 09 09 sloop ((i 0))...
2620: 09 09 09 09 20 20 20 20 20 20 20 28 6c 65 74 2d .... (let-
2630: 76 61 6c 75 65 73 20 28 28 28 70 69 64 2d 76 61 values (((pid-va
2640: 6c 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 l exit-status ex
2650: 69 74 2d 63 6f 64 65 29 28 70 72 6f 63 65 73 73 it-code)(process
2660: 2d 77 61 69 74 20 70 69 64 20 23 74 29 29 29 0a -wait pid #t))).
2670: 09 09 09 09 09 09 09 09 20 20 20 28 6d 75 74 65 ........ (mute
2680: 78 2d 6c 6f 63 6b 21 20 6d 29 0a 09 09 09 09 09 x-lock! m)......
2690: 09 09 09 20 20 20 28 76 65 63 74 6f 72 2d 73 65 ... (vector-se
26a0: 74 21 20 65 78 69 74 2d 69 6e 66 6f 20 30 20 70 t! exit-info 0 p
26b0: 69 64 29 0a 09 09 09 09 09 09 09 09 20 20 20 28 id)......... (
26c0: 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 74 vector-set! exit
26d0: 2d 69 6e 66 6f 20 31 20 65 78 69 74 2d 73 74 61 -info 1 exit-sta
26e0: 74 75 73 29 0a 09 09 09 09 09 09 09 09 20 20 20 tus).........
26f0: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 65 78 69 (vector-set! exi
2700: 74 2d 69 6e 66 6f 20 32 20 65 78 69 74 2d 63 6f t-info 2 exit-co
2710: 64 65 29 0a 09 09 09 09 09 09 09 09 20 20 20 28 de)......... (
2720: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 29 mutex-unlock! m)
2730: 0a 09 09 09 09 09 09 09 09 20 20 20 28 69 66 20 ......... (if
2740: 28 65 71 3f 20 70 69 64 2d 76 61 6c 20 30 29 0a (eq? pid-val 0).
2750: 09 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 ........ (
2760: 62 65 67 69 6e 0a 09 09 09 09 09 09 09 09 09 20 begin..........
2770: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
2780: 29 0a 09 09 09 09 09 09 09 09 09 20 28 70 72 6f ).......... (pro
2790: 63 65 73 73 6c 6f 6f 70 20 28 2b 20 69 20 31 29 cessloop (+ i 1)
27a0: 29 29 29 0a 09 09 09 09 09 09 09 09 20 20 20 29 )))......... )
27b0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
27c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27e0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 65 78 (let ((ex
27f0: 69 6e 66 6f 20 28 76 65 63 74 6f 72 2d 72 65 66 info (vector-ref
2800: 20 65 78 69 74 2d 69 6e 66 6f 20 32 29 29 0a 20 exit-info 2)).
2810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2840: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 67 66 6e (logfn
2850: 61 20 28 69 66 20 6c 6f 67 70 72 6f 2d 75 73 65 a (if logpro-use
2860: 64 20 28 63 6f 6e 63 20 73 74 65 70 6e 61 6d 65 d (conc stepname
2870: 20 22 2e 68 74 6d 6c 22 29 20 22 22 29 29 29 0a ".html") ""))).
2880: 09 09 09 09 09 09 20 20 20 20 20 20 20 3b 3b 20 ...... ;;
2890: 74 65 73 74 69 6e 67 20 69 66 20 70 72 6f 63 65 testing if proce
28a0: 64 75 72 65 73 20 63 61 6c 6c 65 64 20 69 6e 20 dures called in
28b0: 61 20 72 65 6d 6f 74 65 20 63 61 6c 6c 20 63 61 a remote call ca
28c0: 75 73 65 20 70 72 6f 62 6c 65 6d 73 20 28 61 6e use problems (an
28d0: 73 3a 20 6e 6f 20 6f 72 20 73 6f 20 49 20 73 75 s: no or so I su
28e0: 73 70 65 63 74 29 0a 09 09 09 09 09 09 20 20 20 spect).......
28f0: 20 20 20 20 28 64 62 3a 74 65 73 74 73 74 65 70 (db:teststep
2900: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 23 66 20 -set-status! #f
2910: 74 65 73 74 2d 69 64 20 73 74 65 70 6e 61 6d 65 test-id stepname
2920: 20 22 65 6e 64 22 20 65 78 69 6e 66 6f 20 23 66 "end" exinfo #f
2930: 20 6c 6f 67 66 6e 61 20 77 6f 72 6b 2d 61 72 65 logfna work-are
2940: 61 3a 20 77 6f 72 6b 2d 61 72 65 61 29 29 0a 09 a: work-area))..
2950: 09 09 09 09 09 20 20 20 20 20 28 69 66 20 6c 6f ..... (if lo
2960: 67 70 72 6f 2d 75 73 65 64 0a 09 09 09 09 09 09 gpro-used.......
2970: 09 20 28 63 64 62 3a 74 65 73 74 2d 73 65 74 2d . (cdb:test-set-
2980: 6c 6f 67 21 20 2a 72 75 6e 72 65 6d 6f 74 65 2a log! *runremote*
2990: 20 20 74 65 73 74 2d 69 64 20 28 63 6f 6e 63 20 test-id (conc
29a0: 73 74 65 70 6e 61 6d 65 20 22 2e 68 74 6d 6c 22 stepname ".html"
29b0: 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 3b )))....... ;
29c0: 3b 20 73 65 74 20 74 68 65 20 74 65 73 74 20 66 ; set the test f
29d0: 69 6e 61 6c 20 73 74 61 74 75 73 0a 09 09 09 09 inal status.....
29e0: 09 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 .. (let* ((t
29f0: 68 69 73 2d 73 74 65 70 2d 73 74 61 74 75 73 20 his-step-status
2a00: 28 63 6f 6e 64 0a 09 09 09 09 09 09 09 09 09 20 (cond..........
2a10: 20 20 20 20 20 20 28 28 61 6e 64 20 28 65 71 3f ((and (eq?
2a20: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 (vector-ref exi
2a30: 74 2d 69 6e 66 6f 20 32 29 20 32 29 20 6c 6f 67 t-info 2) 2) log
2a40: 70 72 6f 2d 75 73 65 64 29 20 27 77 61 72 6e 29 pro-used) 'warn)
2a50: 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 20 20 ..........
2a60: 20 28 28 65 71 3f 20 28 76 65 63 74 6f 72 2d 72 ((eq? (vector-r
2a70: 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 32 29 20 ef exit-info 2)
2a80: 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
2a90: 20 20 20 20 20 27 70 61 73 73 29 0a 09 09 09 09 'pass).....
2aa0: 09 09 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 ..... (els
2ab0: 65 20 27 66 61 69 6c 29 29 29 0a 09 09 09 09 09 e 'fail)))......
2ac0: 09 09 20 20 20 20 28 6f 76 65 72 61 6c 6c 2d 73 .. (overall-s
2ad0: 74 61 74 75 73 20 20 20 28 63 6f 6e 64 0a 09 09 tatus (cond...
2ae0: 09 09 09 09 09 09 09 20 20 20 20 20 20 20 28 28 ....... ((
2af0: 65 71 3f 20 72 6f 6c 6c 75 70 2d 73 74 61 74 75 eq? rollup-statu
2b00: 73 20 32 29 20 27 77 61 72 6e 29 0a 09 09 09 09 s 2) 'warn).....
2b10: 09 09 09 09 09 20 20 20 20 20 20 20 28 28 65 71 ..... ((eq
2b20: 3f 20 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 ? rollup-status
2b30: 30 29 20 27 70 61 73 73 29 0a 09 09 09 09 09 09 0) 'pass).......
2b40: 09 09 09 20 20 20 20 20 20 20 28 65 6c 73 65 20 ... (else
2b50: 27 66 61 69 6c 29 29 29 0a 09 09 09 09 09 09 09 'fail)))........
2b60: 20 20 20 20 28 6e 65 78 74 2d 73 74 61 74 75 73 (next-status
2b70: 20 20 20 20 20 20 28 63 6f 6e 64 20 0a 09 09 09 (cond ....
2b80: 09 09 09 09 09 09 20 20 20 20 20 20 20 28 28 65 ...... ((e
2b90: 71 3f 20 6f 76 65 72 61 6c 6c 2d 73 74 61 74 75 q? overall-statu
2ba0: 73 20 27 70 61 73 73 29 20 74 68 69 73 2d 73 74 s 'pass) this-st
2bb0: 65 70 2d 73 74 61 74 75 73 29 0a 09 09 09 09 09 ep-status)......
2bc0: 09 09 09 09 20 20 20 20 20 20 20 28 28 65 71 3f .... ((eq?
2bd0: 20 6f 76 65 72 61 6c 6c 2d 73 74 61 74 75 73 20 overall-status
2be0: 27 77 61 72 6e 29 0a 09 09 09 09 09 09 09 09 09 'warn)..........
2bf0: 09 28 69 66 20 28 65 71 3f 20 74 68 69 73 2d 73 .(if (eq? this-s
2c00: 74 65 70 2d 73 74 61 74 75 73 20 27 66 61 69 6c tep-status 'fail
2c10: 29 20 27 66 61 69 6c 20 27 77 61 72 6e 29 29 0a ) 'fail 'warn)).
2c20: 09 09 09 09 09 09 09 09 09 20 20 20 20 20 20 20 .........
2c30: 28 65 6c 73 65 20 27 66 61 69 6c 29 29 29 29 0a (else 'fail)))).
2c40: 09 09 09 09 09 09 20 20 20 20 20 20 20 28 64 65 ...... (de
2c50: 62 75 67 3a 70 72 69 6e 74 20 34 20 22 45 78 69 bug:print 4 "Exi
2c60: 74 20 76 61 6c 75 65 20 72 65 63 65 69 76 65 64 t value received
2c70: 3a 20 22 20 28 76 65 63 74 6f 72 2d 72 65 66 20 : " (vector-ref
2c80: 65 78 69 74 2d 69 6e 66 6f 20 32 29 20 22 20 6c exit-info 2) " l
2c90: 6f 67 70 72 6f 2d 75 73 65 64 3a 20 22 20 6c 6f ogpro-used: " lo
2ca0: 67 70 72 6f 2d 75 73 65 64 20 0a 09 09 09 09 09 gpro-used ......
2cb0: 09 09 09 20 20 20 20 22 20 74 68 69 73 2d 73 74 ... " this-st
2cc0: 65 70 2d 73 74 61 74 75 73 3a 20 22 20 74 68 69 ep-status: " thi
2cd0: 73 2d 73 74 65 70 2d 73 74 61 74 75 73 20 22 20 s-step-status "
2ce0: 6f 76 65 72 61 6c 6c 2d 73 74 61 74 75 73 3a 20 overall-status:
2cf0: 22 20 6f 76 65 72 61 6c 6c 2d 73 74 61 74 75 73 " overall-status
2d00: 20 0a 09 09 09 09 09 09 09 09 20 20 20 20 22 20 ......... "
2d10: 6e 65 78 74 2d 73 74 61 74 75 73 3a 20 22 20 6e next-status: " n
2d20: 65 78 74 2d 73 74 61 74 75 73 20 22 20 72 6f 6c ext-status " rol
2d30: 6c 75 70 2d 73 74 61 74 75 73 3a 20 22 20 72 6f lup-status: " ro
2d40: 6c 6c 75 70 2d 73 74 61 74 75 73 29 0a 09 09 09 llup-status)....
2d50: 09 09 09 20 20 20 20 20 20 20 28 63 61 73 65 20 ... (case
2d60: 6e 65 78 74 2d 73 74 61 74 75 73 0a 09 09 09 09 next-status.....
2d70: 09 09 09 20 28 28 77 61 72 6e 29 0a 09 09 09 09 ... ((warn).....
2d80: 09 09 09 20 20 28 73 65 74 21 20 72 6f 6c 6c 75 ... (set! rollu
2d90: 70 2d 73 74 61 74 75 73 20 32 29 0a 09 09 09 09 p-status 2).....
2da0: 09 09 09 20 20 3b 3b 20 4e 42 2f 2f 20 74 65 73 ... ;; NB// tes
2db0: 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 6f t-set-status! do
2dc0: 65 73 20 72 64 62 20 63 61 6c 6c 73 20 75 6e 64 es rdb calls und
2dd0: 65 72 20 74 68 65 20 68 6f 6f 64 0a 09 09 09 09 er the hood.....
2de0: 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 73 74 ... (tests:test
2df0: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 74 65 73 -set-status! tes
2e00: 74 2d 69 64 20 22 52 55 4e 4e 49 4e 47 22 20 22 t-id "RUNNING" "
2e10: 57 41 52 4e 22 20 0a 09 09 09 09 09 09 09 09 09 WARN" ..........
2e20: 20 20 28 69 66 20 28 65 71 3f 20 74 68 69 73 2d (if (eq? this-
2e30: 73 74 65 70 2d 73 74 61 74 75 73 20 27 77 61 72 step-status 'war
2e40: 6e 29 20 22 4c 6f 67 70 72 6f 20 77 61 72 6e 69 n) "Logpro warni
2e50: 6e 67 20 66 6f 75 6e 64 22 20 23 66 29 0a 09 09 ng found" #f)...
2e60: 09 09 09 09 09 09 09 20 20 23 66 29 29 0a 09 09 ....... #f))...
2e70: 09 09 09 09 09 20 28 28 70 61 73 73 29 0a 09 09 ..... ((pass)...
2e80: 09 09 09 09 09 20 20 28 74 65 73 74 73 3a 74 65 ..... (tests:te
2e90: 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 74 st-set-status! t
2ea0: 65 73 74 2d 69 64 20 22 52 55 4e 4e 49 4e 47 22 est-id "RUNNING"
2eb0: 20 22 50 41 53 53 22 20 23 66 20 23 66 29 29 0a "PASS" #f #f)).
2ec0: 09 09 09 09 09 09 09 20 28 65 6c 73 65 20 3b 3b ....... (else ;;
2ed0: 20 27 66 61 69 6c 0a 09 09 09 09 09 09 09 20 20 'fail........
2ee0: 28 73 65 74 21 20 72 6f 6c 6c 75 70 2d 73 74 61 (set! rollup-sta
2ef0: 74 75 73 20 31 29 20 3b 3b 20 66 6f 72 63 65 20 tus 1) ;; force
2f00: 66 61 69 6c 0a 09 09 09 09 09 09 09 20 20 28 74 fail........ (t
2f10: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 ests:test-set-st
2f20: 61 74 75 73 21 20 74 65 73 74 2d 69 64 20 22 52 atus! test-id "R
2f30: 55 4e 4e 49 4e 47 22 20 22 46 41 49 4c 22 20 28 UNNING" "FAIL" (
2f40: 63 6f 6e 63 20 22 46 61 69 6c 65 64 20 61 74 20 conc "Failed at
2f50: 73 74 65 70 20 22 20 73 74 65 70 6e 61 6d 65 29 step " stepname)
2f60: 20 23 66 29 0a 09 09 09 09 09 09 09 20 20 29 29 #f)........ ))
2f70: 29 29 0a 09 09 09 09 09 09 20 20 20 28 69 66 20 ))....... (if
2f80: 28 61 6e 64 20 28 73 74 65 70 72 75 6e 2d 67 6f (and (steprun-go
2f90: 6f 64 3f 20 6c 6f 67 70 72 6f 2d 75 73 65 64 20 od? logpro-used
2fa0: 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 (vector-ref exit
2fb0: 2d 69 6e 66 6f 20 32 29 29 0a 09 09 09 09 09 09 -info 2)).......
2fc0: 09 20 20 20 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f . (not (null?
2fd0: 20 74 61 6c 29 29 29 0a 09 09 09 09 09 09 20 20 tal))).......
2fe0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
2ff0: 74 61 6c 29 20 28 63 64 72 20 74 61 6c 29 20 73 tal) (cdr tal) s
3000: 74 65 70 6e 61 6d 65 29 29 29 0a 09 09 09 09 09 tepname)))......
3010: 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 . (debug:print 4
3020: 20 22 57 41 52 4e 49 4e 47 3a 20 61 20 70 72 69 "WARNING: a pri
3030: 6f 72 20 73 74 65 70 20 66 61 69 6c 65 64 2c 20 or step failed,
3040: 73 74 6f 70 70 69 6e 67 20 61 74 20 22 20 65 7a stopping at " ez
3050: 73 74 65 70 29 29 29 29 29 29 29 29 0a 09 09 20 step))))))))...
3060: 28 6d 6f 6e 69 74 6f 72 6a 6f 62 20 20 20 28 6c (monitorjob (l
3070: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 20 28 6c ambda ()..... (l
3080: 65 74 2a 20 28 28 73 74 61 72 74 2d 73 65 63 6f et* ((start-seco
3090: 6e 64 73 20 28 63 75 72 72 65 6e 74 2d 73 65 63 nds (current-sec
30a0: 6f 6e 64 73 29 29 0a 09 09 09 09 09 28 63 61 6c onds))......(cal
30b0: 63 2d 6d 69 6e 75 74 65 73 20 20 28 6c 61 6d 62 c-minutes (lamb
30c0: 64 61 20 28 29 0a 09 09 09 09 09 09 09 20 28 69 da ()........ (i
30d0: 6e 65 78 61 63 74 2d 3e 65 78 61 63 74 20 0a 09 nexact->exact ..
30e0: 09 09 09 09 09 09 20 20 28 72 6f 75 6e 64 20 0a ...... (round .
30f0: 09 09 09 09 09 09 09 20 20 20 28 2d 20 0a 09 09 ....... (- ...
3100: 09 09 09 09 09 20 20 20 20 28 63 75 72 72 65 6e ..... (curren
3110: 74 2d 73 65 63 6f 6e 64 73 29 20 0a 09 09 09 09 t-seconds) .....
3120: 09 09 09 20 20 20 20 73 74 61 72 74 2d 73 65 63 ... start-sec
3130: 6f 6e 64 73 29 29 29 29 29 0a 09 09 09 09 09 28 onds)))))......(
3140: 6b 69 6c 6c 2d 74 72 69 65 73 20 30 29 29 0a 09 kill-tries 0))..
3150: 09 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ... (let loop
3160: 28 28 6d 69 6e 75 74 65 73 20 20 20 28 63 61 6c ((minutes (cal
3170: 63 2d 6d 69 6e 75 74 65 73 29 29 29 0a 09 09 09 c-minutes)))....
3180: 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 . (begin....
3190: 09 20 20 20 20 20 20 20 28 73 65 74 21 20 6b 69 . (set! ki
31a0: 6c 6c 2d 6a 6f 62 3f 20 28 74 65 73 74 2d 67 65 ll-job? (test-ge
31b0: 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 20 74 t-kill-request t
31c0: 65 73 74 2d 69 64 29 29 20 3b 3b 20 72 75 6e 2d est-id)) ;; run-
31d0: 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 id test-name ite
31e0: 6d 64 61 74 29 29 0a 09 09 09 09 20 20 20 20 20 mdat)).....
31f0: 20 20 3b 3b 20 6f 70 65 6e 2d 72 75 6e 2d 63 6c ;; open-run-cl
3200: 6f 73 65 20 6e 6f 74 20 6e 65 65 64 65 64 20 66 ose not needed f
3210: 6f 72 20 74 65 73 74 2d 73 65 74 2d 6d 65 74 61 or test-set-meta
3220: 2d 69 6e 66 6f 0a 09 09 09 09 20 20 20 20 20 20 -info.....
3230: 20 28 74 65 73 74 73 3a 73 65 74 2d 6d 65 74 61 (tests:set-meta
3240: 2d 69 6e 66 6f 20 23 66 20 74 65 73 74 2d 69 64 -info #f test-id
3250: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam
3260: 65 20 69 74 65 6d 64 61 74 20 6d 69 6e 75 74 65 e itemdat minute
3270: 73 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 09 09 s work-area)....
3280: 09 20 20 20 20 20 20 20 28 69 66 20 6b 69 6c 6c . (if kill
3290: 2d 6a 6f 62 3f 20 0a 09 09 09 09 09 20 20 20 28 -job? ...... (
32a0: 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 20 20 begin......
32b0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d 29 0a (mutex-lock! m).
32c0: 09 09 09 09 09 20 20 20 20 20 28 6c 65 74 2a 20 ..... (let*
32d0: 28 28 70 69 64 20 28 76 65 63 74 6f 72 2d 72 65 ((pid (vector-re
32e0: 66 20 65 78 69 74 2d 69 6e 66 6f 20 30 29 29 29 f exit-info 0)))
32f0: 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 69 66 ...... (if
3300: 20 28 6e 75 6d 62 65 72 3f 20 70 69 64 29 0a 09 (number? pid)..
3310: 09 09 09 09 09 20 20 20 28 62 65 67 69 6e 0a 09 ..... (begin..
3320: 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 67 ..... (debug
3330: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN
3340: 47 3a 20 52 65 71 75 65 73 74 20 72 65 63 65 69 G: Request recei
3350: 76 65 64 20 74 6f 20 6b 69 6c 6c 20 6a 6f 62 20 ved to kill job
3360: 28 61 74 74 65 6d 70 74 20 23 20 22 20 6b 69 6c (attempt # " kil
3370: 6c 2d 74 72 69 65 73 20 22 29 22 29 0a 09 09 09 l-tries ")")....
3380: 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 28 70 ... (let ((p
3390: 72 6f 63 65 73 73 65 73 20 28 63 6d 64 2d 72 75 rocesses (cmd-ru
33a0: 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 70 n->list (conc "p
33b0: 67 72 65 70 20 2d 6c 20 2d 50 20 22 20 70 69 64 grep -l -P " pid
33c0: 29 29 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 )))).......
33d0: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 09 09 (for-each ....
33e0: 09 09 09 09 28 6c 61 6d 62 64 61 20 28 70 29 0a ....(lambda (p).
33f0: 09 09 09 09 09 09 09 20 20 28 6c 65 74 2a 20 28 ....... (let* (
3400: 28 70 61 72 74 73 20 20 28 73 74 72 69 6e 67 2d (parts (string-
3410: 73 70 6c 69 74 20 70 29 29 0a 09 09 09 09 09 09 split p)).......
3420: 09 09 20 28 70 2d 69 64 20 20 20 28 69 66 20 28 .. (p-id (if (
3430: 3e 20 28 6c 65 6e 67 74 68 20 70 61 72 74 73 29 > (length parts)
3440: 20 30 29 0a 09 09 09 09 09 09 09 09 09 20 20 20 0)..........
3450: 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
3460: 72 20 28 63 61 72 20 70 61 72 74 73 29 29 0a 09 r (car parts))..
3470: 09 09 09 09 09 09 09 09 20 20 20 20 20 23 66 29 ........ #f)
3480: 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 28 69 ))........ (i
3490: 66 20 70 2d 69 64 0a 09 09 09 09 09 09 09 09 28 f p-id.........(
34a0: 62 65 67 69 6e 0a 09 09 09 09 09 09 09 09 20 20 begin.........
34b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
34c0: 4b 69 6c 6c 69 6e 67 20 22 20 28 63 61 64 72 20 Killing " (cadr
34d0: 70 61 72 74 73 29 20 22 3b 20 6b 69 6c 6c 20 2d parts) "; kill -
34e0: 39 20 20 22 20 70 2d 69 64 29 0a 09 09 09 09 09 9 " p-id)......
34f0: 09 09 09 20 20 28 73 79 73 74 65 6d 20 28 63 6f ... (system (co
3500: 6e 63 20 22 6b 69 6c 6c 20 2d 39 20 22 20 70 2d nc "kill -9 " p-
3510: 69 64 29 29 29 29 29 29 0a 09 09 09 09 09 09 09 id))))))........
3520: 28 63 61 72 20 70 72 6f 63 65 73 73 65 73 29 29 (car processes))
3530: 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 28 73 ....... (s
3540: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6b 69 6c ystem (conc "kil
3550: 6c 20 2d 39 20 2d 22 20 70 69 64 29 29 29 29 0a l -9 -" pid)))).
3560: 09 09 09 09 09 09 20 20 20 28 62 65 67 69 6e 0a ...... (begin.
3570: 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 75 ...... (debu
3580: 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 g:print 0 "WARNI
3590: 4e 47 3a 20 52 65 71 75 65 73 74 20 72 65 63 65 NG: Request rece
35a0: 69 76 65 64 20 74 6f 20 6b 69 6c 6c 20 6a 6f 62 ived to kill job
35b0: 20 62 75 74 20 70 72 6f 62 6c 65 6d 20 77 69 74 but problem wit
35c0: 68 20 70 72 6f 63 65 73 73 2c 20 61 74 74 65 6d h process, attem
35d0: 70 74 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 6d 61 pting to kill ma
35e0: 6e 61 67 65 72 20 70 72 6f 63 65 73 73 22 29 0a nager process").
35f0: 09 09 09 09 09 09 20 20 20 20 20 28 74 65 73 74 ...... (test
3600: 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 s:test-set-statu
3610: 73 21 20 74 65 73 74 2d 69 64 20 22 4b 49 4c 4c s! test-id "KILL
3620: 45 44 22 20 20 22 46 41 49 4c 22 0a 09 09 09 09 ED" "FAIL".....
3630: 09 09 09 09 20 20 20 20 20 28 61 72 67 73 3a 67 .... (args:g
3640: 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 23 66 29 et-arg "-m") #f)
3650: 0a 09 09 09 09 09 09 20 20 20 20 20 28 73 71 6c ....... (sql
3660: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 74 ite3:finalize! t
3670: 64 62 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 db)....... (
3680: 65 78 69 74 20 31 29 29 29 29 0a 09 09 09 09 09 exit 1))))......
3690: 20 20 20 20 20 28 73 65 74 21 20 6b 69 6c 6c 2d (set! kill-
36a0: 74 72 69 65 73 20 28 2b 20 31 20 6b 69 6c 6c 2d tries (+ 1 kill-
36b0: 74 72 69 65 73 29 29 0a 09 09 09 09 09 20 20 20 tries))......
36c0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
36d0: 20 6d 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 m))).....
36e0: 20 3b 3b 20 28 73 71 6c 69 74 65 33 3a 66 69 6e ;; (sqlite3:fin
36f0: 61 6c 69 7a 65 21 20 64 62 29 0a 09 09 09 09 20 alize! db).....
3700: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
3710: 65 65 70 21 20 28 2b 20 31 30 20 28 72 61 6e 64 eep! (+ 10 (rand
3720: 6f 6d 20 31 30 29 29 29 20 3b 3b 20 61 64 64 20 om 10))) ;; add
3730: 73 6f 6d 65 20 6a 69 74 74 65 72 20 74 6f 20 74 some jitter to t
3740: 68 65 20 63 61 6c 6c 20 68 6f 6d 65 20 74 69 6d he call home tim
3750: 65 20 74 6f 20 73 70 72 65 61 64 20 6f 75 74 20 e to spread out
3760: 74 68 65 20 64 62 20 61 63 63 65 73 73 65 73 0a the db accesses.
3770: 09 09 09 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 .... (loop
3780: 20 28 63 61 6c 63 2d 6d 69 6e 75 74 65 73 29 29 (calc-minutes))
3790: 29 29 29 29 29 0a 09 09 20 28 74 68 31 20 20 20 )))))... (th1
37a0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 74 68 72 (make-thr
37b0: 65 61 64 20 6d 6f 6e 69 74 6f 72 6a 6f 62 29 29 ead monitorjob))
37c0: 0a 09 09 20 28 74 68 32 20 20 20 20 20 20 20 20 ... (th2
37d0: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 72 (make-thread r
37e0: 75 6e 69 74 29 29 29 0a 09 20 20 20 20 28 73 65 unit))).. (se
37f0: 74 21 20 6a 6f 62 2d 74 68 72 65 61 64 20 74 68 t! job-thread th
3800: 32 29 0a 09 20 20 20 20 28 74 68 72 65 61 64 2d 2).. (thread-
3810: 73 74 61 72 74 21 20 74 68 31 29 0a 09 20 20 20 start! th1)..
3820: 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 (thread-start!
3830: 74 68 32 29 0a 09 20 20 20 20 28 74 68 72 65 61 th2).. (threa
3840: 64 2d 6a 6f 69 6e 21 20 74 68 32 29 0a 09 20 20 d-join! th2)..
3850: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d (mutex-lock! m
3860: 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 69 ).. (let* ((i
3870: 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c tem-path (item-l
3880: 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 ist->path itemda
3890: 74 29 29 0a 09 09 20 20 20 28 74 65 73 74 69 6e t))... (testin
38a0: 66 6f 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 fo (cdb:get-tes
38b0: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
38c0: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
38d0: 29 29 29 20 3b 3b 20 29 29 20 3b 3b 20 72 75 6e ))) ;; )) ;; run
38e0: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it
38f0: 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 20 20 20 em-path)))..
3900: 20 20 3b 3b 20 41 6d 20 49 20 63 6f 6d 70 6c 65 ;; Am I comple
3910: 74 65 64 3f 0a 09 20 20 20 20 20 20 28 69 66 20 ted?.. (if
3920: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 64 62 (not (equal? (db
3930: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 65 20 :test-get-state
3940: 74 65 73 74 69 6e 66 6f 29 20 22 43 4f 4d 50 4c testinfo) "COMPL
3950: 45 54 45 44 22 29 29 0a 09 09 20 20 28 62 65 67 ETED"))... (beg
3960: 69 6e 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a in... (debug:
3970: 70 72 69 6e 74 20 32 20 22 54 65 73 74 20 4e 4f print 2 "Test NO
3980: 54 20 6c 6f 67 67 65 64 20 61 73 20 43 4f 4d 50 T logged as COMP
3990: 4c 45 54 45 44 2c 20 28 73 74 61 74 65 3d 22 20 LETED, (state="
39a0: 28 64 62 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 (db:test-get-sta
39b0: 74 65 20 74 65 73 74 69 6e 66 6f 29 20 22 29 2c te testinfo) "),
39c0: 20 75 70 64 61 74 69 6e 67 20 72 65 73 75 6c 74 updating result
39d0: 2c 20 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 , rollup-status
39e0: 69 73 20 22 20 72 6f 6c 6c 75 70 2d 73 74 61 74 is " rollup-stat
39f0: 75 73 29 0a 09 09 20 20 20 20 28 74 65 73 74 73 us)... (tests
3a00: 3a 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 :test-set-status
3a10: 21 20 74 65 73 74 2d 69 64 20 0a 09 09 09 09 20 ! test-id .....
3a20: 20 20 20 28 69 66 20 6b 69 6c 6c 2d 6a 6f 62 3f (if kill-job?
3a30: 20 22 4b 49 4c 4c 45 44 22 20 22 43 4f 4d 50 4c "KILLED" "COMPL
3a40: 45 54 45 44 22 29 0a 09 09 09 09 20 20 20 20 28 ETED")..... (
3a50: 63 6f 6e 64 0a 09 09 09 09 20 20 20 20 20 28 28 cond..... ((
3a60: 6e 6f 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 not (vector-ref
3a70: 65 78 69 74 2d 69 6e 66 6f 20 31 29 29 20 22 46 exit-info 1)) "F
3a80: 41 49 4c 22 29 20 3b 3b 20 6a 6f 62 20 66 61 69 AIL") ;; job fai
3a90: 6c 65 64 20 74 6f 20 72 75 6e 0a 09 09 09 09 20 led to run.....
3aa0: 20 20 20 20 28 28 65 71 3f 20 72 6f 6c 6c 75 70 ((eq? rollup
3ab0: 2d 73 74 61 74 75 73 20 30 29 0a 09 09 09 09 20 -status 0).....
3ac0: 20 20 20 20 20 3b 3b 20 69 66 20 74 68 65 20 63 ;; if the c
3ad0: 75 72 72 65 6e 74 20 73 74 61 74 75 73 20 69 73 urrent status is
3ae0: 20 41 55 54 4f 20 74 68 65 20 64 65 66 65 72 20 AUTO the defer
3af0: 74 6f 20 74 68 65 20 63 61 6c 63 75 6c 61 74 65 to the calculate
3b00: 64 20 76 61 6c 75 65 20 28 69 2e 65 2e 20 6c 65 d value (i.e. le
3b10: 61 76 65 20 74 68 69 73 20 41 55 54 4f 29 0a 09 ave this AUTO)..
3b20: 09 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 ... (if (eq
3b30: 75 61 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 ual? (db:test-ge
3b40: 74 2d 73 74 61 74 75 73 20 74 65 73 74 69 6e 66 t-status testinf
3b50: 6f 29 20 22 41 55 54 4f 22 29 20 22 41 55 54 4f o) "AUTO") "AUTO
3b60: 22 20 22 50 41 53 53 22 29 29 0a 09 09 09 09 20 " "PASS")).....
3b70: 20 20 20 20 28 28 65 71 3f 20 72 6f 6c 6c 75 70 ((eq? rollup
3b80: 2d 73 74 61 74 75 73 20 31 29 20 22 46 41 49 4c -status 1) "FAIL
3b90: 22 29 0a 09 09 09 09 20 20 20 20 20 28 28 65 71 ")..... ((eq
3ba0: 3f 20 72 6f 6c 6c 75 70 2d 73 74 61 74 75 73 20 ? rollup-status
3bb0: 32 29 0a 09 09 09 09 20 20 20 20 20 20 3b 3b 20 2)..... ;;
3bc0: 69 66 20 74 68 65 20 63 75 72 72 65 6e 74 20 73 if the current s
3bd0: 74 61 74 75 73 20 69 73 20 41 55 54 4f 20 74 68 tatus is AUTO th
3be0: 65 20 64 65 66 65 72 20 74 6f 20 74 68 65 20 63 e defer to the c
3bf0: 61 6c 63 75 6c 61 74 65 64 20 76 61 6c 75 65 20 alculated value
3c00: 62 75 74 20 71 75 61 6c 69 66 79 20 28 69 2e 65 but qualify (i.e
3c10: 2e 20 6d 61 6b 65 20 74 68 69 73 20 41 55 54 4f . make this AUTO
3c20: 2d 57 41 52 4e 29 0a 09 09 09 09 20 20 20 20 20 -WARN).....
3c30: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 64 62 (if (equal? (db
3c40: 3a 74 65 73 74 2d 67 65 74 2d 73 74 61 74 75 73 :test-get-status
3c50: 20 74 65 73 74 69 6e 66 6f 29 20 22 41 55 54 4f testinfo) "AUTO
3c60: 22 29 20 22 41 55 54 4f 2d 57 41 52 4e 22 20 22 ") "AUTO-WARN" "
3c70: 57 41 52 4e 22 29 29 0a 09 09 09 09 20 20 20 20 WARN")).....
3c80: 20 28 65 6c 73 65 20 22 46 41 49 4c 22 29 29 0a (else "FAIL")).
3c90: 09 09 09 09 20 20 20 20 28 61 72 67 73 3a 67 65 .... (args:ge
3ca0: 74 2d 61 72 67 20 22 2d 6d 22 29 20 23 66 29 29 t-arg "-m") #f))
3cb0: 29 0a 09 20 20 20 20 20 20 3b 3b 20 66 6f 72 20 ).. ;; for
3cc0: 61 75 74 6f 6d 61 74 65 64 20 63 72 65 61 74 69 automated creati
3cd0: 6f 6e 20 6f 66 20 74 68 65 20 72 6f 6c 6c 75 70 on of the rollup
3ce0: 20 68 74 6d 6c 20 66 69 6c 65 20 74 68 69 73 20 html file this
3cf0: 69 73 20 61 20 67 6f 6f 64 20 70 6c 61 63 65 2e is a good place.
3d00: 2e 2e 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e .... (if (n
3d10: 6f 74 20 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d ot (equal? item-
3d20: 70 61 74 68 20 22 22 29 29 0a 09 09 20 20 28 74 path ""))... (t
3d30: 65 73 74 73 3a 73 75 6d 6d 61 72 69 7a 65 2d 69 ests:summarize-i
3d40: 74 65 6d 73 20 23 66 20 72 75 6e 2d 69 64 20 74 tems #f run-id t
3d50: 65 73 74 2d 6e 61 6d 65 20 23 66 29 29 20 3b 3b est-name #f)) ;;
3d60: 20 64 6f 6e 27 74 20 66 6f 72 63 65 20 2d 20 6a don't force - j
3d70: 75 73 74 20 75 70 64 61 74 65 20 69 66 20 6e 6f ust update if no
3d80: 0a 09 20 20 20 20 20 20 29 0a 09 20 20 20 20 28 .. ).. (
3d90: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 6d 29 mutex-unlock! m)
3da0: 0a 09 20 20 20 20 3b 3b 20 28 65 78 65 63 2d 72 .. ;; (exec-r
3db0: 65 73 75 6c 74 73 20 28 63 6d 64 2d 72 75 6e 2d esults (cmd-run-
3dc0: 3e 6c 69 73 74 20 66 75 6c 6c 72 75 6e 73 63 72 >list fullrunscr
3dd0: 69 70 74 29 29 20 3b 3b 20 20 28 6c 69 73 74 20 ipt)) ;; (list
3de0: 22 3e 22 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e ">" (conc test-n
3df0: 61 6d 65 20 22 2d 72 75 6e 2e 6c 6f 67 22 29 29 ame "-run.log"))
3e00: 29 29 0a 09 20 20 20 20 3b 3b 20 28 73 75 63 63 )).. ;; (succ
3e10: 65 73 73 20 20 20 20 20 20 65 78 65 63 2d 72 65 ess exec-re
3e20: 73 75 6c 74 73 29 29 20 3b 3b 20 28 65 71 3f 20 sults)) ;; (eq?
3e30: 28 63 61 64 72 20 65 78 65 63 2d 72 65 73 75 6c (cadr exec-resul
3e40: 74 73 29 20 30 29 29 29 0a 09 20 20 20 20 28 64 ts) 0))).. (d
3e50: 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 4f 75 ebug:print 2 "Ou
3e60: 74 70 75 74 20 66 72 6f 6d 20 72 75 6e 6e 69 6e tput from runnin
3e70: 67 20 22 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 g " fullrunscrip
3e80: 74 20 22 2c 20 70 69 64 20 22 20 28 76 65 63 74 t ", pid " (vect
3e90: 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f or-ref exit-info
3ea0: 20 30 29 20 22 20 69 6e 20 77 6f 72 6b 20 61 72 0) " in work ar
3eb0: 65 61 20 22 20 0a 09 09 09 20 77 6f 72 6b 2d 61 ea " .... work-a
3ec0: 72 65 61 20 22 3a 5c 6e 3d 3d 3d 3d 5c 6e 20 65 rea ":\n====\n e
3ed0: 78 69 74 20 63 6f 64 65 20 22 20 28 76 65 63 74 xit code " (vect
3ee0: 6f 72 2d 72 65 66 20 65 78 69 74 2d 69 6e 66 6f or-ref exit-info
3ef0: 20 32 29 20 22 5c 6e 22 20 22 3d 3d 3d 3d 5c 6e 2) "\n" "====\n
3f00: 22 29 0a 09 20 20 20 20 3b 3b 20 28 73 71 6c 69 ").. ;; (sqli
3f10: 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 te3:finalize! db
3f20: 29 0a 09 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 ).. ;; (sqlit
3f30: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 74 64 62 e3:finalize! tdb
3f40: 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ).. (if (not
3f50: 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 (vector-ref exit
3f60: 2d 69 6e 66 6f 20 31 29 29 0a 09 09 28 65 78 69 -info 1))...(exi
3f70: 74 20 34 29 29 29 29 29 29 29 0a 0a 3b 3b 20 73 t 4)))))))..;; s
3f80: 65 74 20 75 70 20 74 68 65 20 76 65 72 79 20 62 et up the very b
3f90: 61 73 69 63 73 20 6e 65 65 64 65 64 20 66 6f 72 asics needed for
3fa0: 20 64 6f 69 6e 67 20 61 6e 79 74 68 69 6e 67 20 doing anything
3fb0: 68 65 72 65 2e 0a 28 64 65 66 69 6e 65 20 28 73 here..(define (s
3fc0: 65 74 75 70 2d 66 6f 72 2d 72 75 6e 29 0a 20 20 etup-for-run).
3fd0: 3b 3b 20 77 6f 75 6c 64 20 73 65 74 20 76 61 6c ;; would set val
3fe0: 75 65 73 20 66 6f 72 20 4b 45 59 53 20 69 6e 20 ues for KEYS in
3ff0: 74 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 the environment
4000: 68 65 72 65 20 66 6f 72 20 62 65 74 74 65 72 20 here for better
4010: 73 75 70 70 6f 72 74 20 6f 66 20 65 6e 76 2d 6f support of env-o
4020: 76 65 72 72 69 64 65 20 62 75 74 20 0a 20 20 3b verride but . ;
4030: 3b 20 68 61 76 65 20 63 68 69 63 6b 65 6e 2f 65 ; have chicken/e
4040: 67 67 20 73 63 65 6e 61 72 69 6f 2e 20 6e 65 65 gg scenario. nee
4050: 64 20 74 6f 20 72 65 61 64 20 6d 65 67 61 74 65 d to read megate
4060: 73 74 2e 63 6f 6e 66 69 67 20 74 68 65 6e 20 72 st.config then r
4070: 65 61 64 20 69 74 20 61 67 61 69 6e 2e 20 47 6f ead it again. Go
4080: 69 6e 67 20 74 6f 20 0a 20 20 3b 3b 20 70 61 73 ing to . ;; pas
4090: 73 20 6f 6e 20 74 68 61 74 20 69 64 65 61 20 66 s on that idea f
40a0: 6f 72 20 6e 6f 77 0a 20 20 3b 3b 20 73 70 65 63 or now. ;; spec
40b0: 69 61 6c 20 63 61 73 65 0a 20 20 28 73 65 74 21 ial case. (set!
40c0: 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 20 28 66 *configinfo* (f
40d0: 69 6e 64 2d 61 6e 64 2d 72 65 61 64 2d 63 6f 6e ind-and-read-con
40e0: 66 69 67 20 0a 09 09 20 20 20 20 20 20 28 69 66 fig ... (if
40f0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
4100: 2d 63 6f 6e 66 69 67 22 29 28 61 72 67 73 3a 67 -config")(args:g
4110: 65 74 2d 61 72 67 20 22 2d 63 6f 6e 66 69 67 22 et-arg "-config"
4120: 29 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 ) "megatest.conf
4130: 69 67 22 29 0a 09 09 20 20 20 20 20 20 65 6e 76 ig")... env
4140: 69 72 6f 6e 2d 70 61 74 74 3a 20 22 65 6e 76 2d iron-patt: "env-
4150: 6f 76 65 72 72 69 64 65 22 0a 09 09 20 20 20 20 override"...
4160: 20 20 67 69 76 65 6e 2d 74 6f 70 70 61 74 68 3a given-toppath:
4170: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
4180: 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 t-variable "MT_R
4190: 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 0a 09 UN_AREA_HOME")..
41a0: 09 20 20 20 20 20 20 70 61 74 68 65 6e 76 76 61 . pathenvva
41b0: 72 3a 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f r: "MT_RUN_AREA_
41c0: 48 4f 4d 45 22 29 29 0a 20 20 28 73 65 74 21 20 HOME")). (set!
41d0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 20 28 69 66 *configdat* (if
41e0: 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 6e 66 (car *configinf
41f0: 6f 2a 29 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 o*)(car *configi
4200: 6e 66 6f 2a 29 20 23 66 29 29 0a 20 20 28 73 65 nfo*) #f)). (se
4210: 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 20 20 20 t! *toppath*
4220: 28 69 66 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 (if (car *config
4230: 69 6e 66 6f 2a 29 28 63 61 64 72 20 2a 63 6f 6e info*)(cadr *con
4240: 66 69 67 69 6e 66 6f 2a 29 20 23 66 29 29 0a 20 figinfo*) #f)).
4250: 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 0a 20 (if *toppath*.
4260: 20 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 (setenv "MT
4270: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 20 _RUN_AREA_HOME"
4280: 2a 74 6f 70 70 61 74 68 2a 29 20 3b 3b 20 74 6f *toppath*) ;; to
4290: 20 62 65 20 64 65 70 72 65 63 61 74 65 64 0a 20 be deprecated.
42a0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
42b0: 74 20 30 20 22 45 52 52 4f 52 3a 20 66 61 69 6c t 0 "ERROR: fail
42c0: 65 64 20 74 6f 20 66 69 6e 64 20 74 68 65 20 74 ed to find the t
42d0: 6f 70 20 70 61 74 68 20 74 6f 20 79 6f 75 72 20 op path to your
42e0: 72 75 6e 20 73 65 74 75 70 2e 22 29 29 0a 20 20 run setup.")).
42f0: 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 28 64 65 66 *toppath*)..(def
4300: 69 6e 65 20 28 67 65 74 2d 62 65 73 74 2d 64 69 ine (get-best-di
4310: 73 6b 20 63 6f 6e 66 64 61 74 29 0a 20 20 28 6c sk confdat). (l
4320: 65 74 2a 20 28 28 64 69 73 6b 73 20 20 20 20 28 et* ((disks (
4330: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
4340: 65 66 61 75 6c 74 20 63 6f 6e 66 64 61 74 20 22 efault confdat "
4350: 64 69 73 6b 73 22 20 23 66 29 29 0a 09 20 28 62 disks" #f)).. (b
4360: 65 73 74 20 20 20 20 20 23 66 29 0a 09 20 28 62 est #f).. (b
4370: 65 73 74 73 69 7a 65 20 30 29 29 0a 20 20 20 20 estsize 0)).
4380: 28 69 66 20 64 69 73 6b 73 20 0a 09 28 66 6f 72 (if disks ..(for
4390: 2d 65 61 63 68 20 0a 09 20 28 6c 61 6d 62 64 61 -each .. (lambda
43a0: 20 28 64 69 73 6b 2d 6e 75 6d 29 0a 09 20 20 20 (disk-num)..
43b0: 28 6c 65 74 2a 20 28 28 64 69 72 70 61 74 68 20 (let* ((dirpath
43c0: 20 20 20 28 63 61 64 72 20 28 61 73 73 6f 63 20 (cadr (assoc
43d0: 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 29 29 disk-num disks))
43e0: 29 0a 09 09 20 20 28 66 72 65 65 73 70 63 20 20 )... (freespc
43f0: 20 20 28 69 66 20 28 61 6e 64 20 28 64 69 72 65 (if (and (dire
4400: 63 74 6f 72 79 3f 20 64 69 72 70 61 74 68 29 0a ctory? dirpath).
4410: 09 09 09 09 20 20 20 20 20 20 20 28 66 69 6c 65 .... (file
4420: 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 -write-access? d
4430: 69 72 70 61 74 68 29 29 0a 09 09 09 09 20 20 28 irpath))..... (
4440: 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 29 0a get-df dirpath).
4450: 09 09 09 09 20 20 28 62 65 67 69 6e 0a 09 09 09 .... (begin....
4460: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
4470: 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 70 61 t 0 "WARNING: pa
4480: 74 68 20 22 20 64 69 72 70 61 74 68 20 22 20 69 th " dirpath " i
4490: 6e 20 5b 64 69 73 6b 73 5d 20 73 65 63 74 69 6f n [disks] sectio
44a0: 6e 20 6e 6f 74 20 76 61 6c 69 64 20 6f 72 20 77 n not valid or w
44b0: 72 69 74 61 62 6c 65 22 29 0a 09 09 09 09 20 20 ritable").....
44c0: 20 20 30 29 29 29 29 0a 09 20 20 20 20 20 28 69 0)))).. (i
44d0: 66 20 28 3e 20 66 72 65 65 73 70 63 20 62 65 73 f (> freespc bes
44e0: 74 73 69 7a 65 29 0a 09 09 20 28 62 65 67 69 6e tsize)... (begin
44f0: 0a 09 09 20 20 20 28 73 65 74 21 20 62 65 73 74 ... (set! best
4500: 20 20 20 20 20 64 69 72 70 61 74 68 29 0a 09 09 dirpath)...
4510: 20 20 20 28 73 65 74 21 20 62 65 73 74 73 69 7a (set! bestsiz
4520: 65 20 66 72 65 65 73 70 63 29 29 29 29 29 0a 09 e freespc)))))..
4530: 20 28 6d 61 70 20 63 61 72 20 64 69 73 6b 73 29 (map car disks)
4540: 29 29 0a 20 20 20 20 28 69 66 20 62 65 73 74 0a )). (if best.
4550: 09 62 65 73 74 0a 09 28 62 65 67 69 6e 0a 09 20 .best..(begin..
4560: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
4570: 22 45 52 52 4f 52 3a 20 4e 6f 20 76 61 6c 69 64 "ERROR: No valid
4580: 20 64 69 73 6b 73 20 66 6f 75 6e 64 20 69 6e 20 disks found in
4590: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 2e megatest.config.
45a0: 20 50 6c 65 61 73 65 20 61 64 64 20 73 6f 6d 65 Please add some
45b0: 20 74 6f 20 79 6f 75 72 20 5b 64 69 73 6b 73 5d to your [disks]
45c0: 20 73 65 63 74 69 6f 6e 22 29 0a 09 20 20 28 65 section").. (e
45d0: 78 69 74 20 31 29 29 29 29 29 0a 0a 3b 3b 20 44 xit 1)))))..;; D
45e0: 65 73 69 72 65 64 20 64 69 72 65 63 74 6f 72 79 esired directory
45f0: 20 73 74 72 75 63 74 75 72 65 3a 0a 3b 3b 0a 3b structure:.;;.;
4600: 3b 20 20 3c 6c 69 6e 6b 64 69 72 3e 20 2d 20 3c ; <linkdir> - <
4610: 74 61 72 67 65 74 3e 20 2d 20 3c 74 65 73 74 6e target> - <testn
4620: 61 6d 65 3e 20 2d 2e 0a 3b 3b 20 20 20 20 20 20 ame> -..;;
4630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 7c |
4650: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4670: 20 20 20 20 20 20 20 20 76 0a 3b 3b 20 20 3c 72 v.;; <r
4680: 75 6e 64 69 72 3e 20 20 2d 20 20 3c 74 61 72 67 undir> - <targ
4690: 65 74 3e 20 20 2d 20 20 20 20 3c 74 65 73 74 6e et> - <testn
46a0: 61 6d 65 3e 20 2d 7c 2d 20 3c 69 74 65 6d 70 61 ame> -|- <itempa
46b0: 74 68 28 73 29 3e 0a 3b 3b 0a 3b 3b 20 20 64 69 th(s)>.;;.;; di
46c0: 72 20 73 74 6f 72 65 64 20 69 6e 20 74 65 73 74 r stored in test
46d0: 20 69 73 3a 0a 3b 3b 20 0a 3b 3b 20 20 3c 6c 69 is:.;; .;; <li
46e0: 6e 6b 64 69 72 3e 20 2d 20 3c 74 61 72 67 65 74 nkdir> - <target
46f0: 3e 20 2d 20 3c 74 65 73 74 6e 61 6d 65 3e 20 5b > - <testname> [
4700: 20 2d 20 3c 69 74 65 6d 70 61 74 68 3e 20 5d 0a - <itempath> ].
4710: 3b 3b 20 0a 3b 3b 20 41 6c 6c 20 6c 6f 67 20 66 ;; .;; All log f
4720: 69 6c 65 20 6c 69 6e 6b 73 20 73 68 6f 75 6c 64 ile links should
4730: 20 62 65 20 73 74 6f 72 65 64 20 72 65 6c 61 74 be stored relat
4740: 69 76 65 20 74 6f 20 74 68 65 20 74 6f 70 20 6f ive to the top o
4750: 66 20 6c 69 6e 6b 20 70 61 74 68 0a 3b 3b 20 20 f link path.;;
4760: 0a 3b 3b 20 3c 74 61 72 67 65 74 3e 20 2d 20 3c .;; <target> - <
4770: 74 65 73 74 6e 61 6d 65 3e 20 5b 20 2d 20 3c 69 testname> [ - <i
4780: 74 65 6d 70 61 74 68 3e 20 5d 20 0a 3b 3b 0a 28 tempath> ] .;;.(
4790: 64 65 66 69 6e 65 20 28 63 72 65 61 74 65 2d 77 define (create-w
47a0: 6f 72 6b 2d 61 72 65 61 20 72 75 6e 2d 69 64 20 ork-area run-id
47b0: 72 75 6e 2d 69 6e 66 6f 20 6b 65 79 76 61 6c 73 run-info keyvals
47c0: 20 74 65 73 74 2d 69 64 20 74 65 73 74 2d 73 72 test-id test-sr
47d0: 63 2d 70 61 74 68 20 64 69 73 6b 2d 70 61 74 68 c-path disk-path
47e0: 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 64 61 testname itemda
47f0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 69 74 65 t). (let* ((ite
4800: 6d 2d 70 61 74 68 20 28 69 74 65 6d 2d 6c 69 73 m-path (item-lis
4810: 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 t->path itemdat)
4820: 29 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 28 64 ).. (runname (d
4830: 62 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 b:get-value-by-h
4840: 65 61 64 65 72 20 28 64 62 3a 67 65 74 2d 72 6f eader (db:get-ro
4850: 77 20 72 75 6e 2d 69 6e 66 6f 29 0a 09 09 09 09 w run-info).....
4860: 09 20 20 20 28 64 62 3a 67 65 74 2d 68 65 61 64 . (db:get-head
4870: 65 72 20 72 75 6e 2d 69 6e 66 6f 29 0a 09 09 09 er run-info)....
4880: 09 09 20 20 20 22 72 75 6e 6e 61 6d 65 22 29 29 .. "runname"))
4890: 0a 09 20 3b 3b 20 63 6f 6e 76 65 72 74 20 62 61 .. ;; convert ba
48a0: 63 6b 20 74 6f 20 64 62 3a 20 66 72 6f 6d 20 72 ck to db: from r
48b0: 64 62 3a 20 2d 20 74 68 69 73 20 69 73 20 61 6c db: - this is al
48c0: 77 61 79 73 20 72 75 6e 20 61 74 20 73 65 72 76 ways run at serv
48d0: 65 72 20 65 6e 64 0a 09 20 28 74 61 72 67 65 74 er end.. (target
48e0: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
48f0: 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 64 72 sperse (map cadr
4900: 20 6b 65 79 76 61 6c 73 29 20 22 2f 22 29 29 0a keyvals) "/")).
4910: 0a 09 20 28 6e 6f 74 2d 69 74 65 72 61 74 65 64 .. (not-iterated
4920: 20 20 28 65 71 75 61 6c 3f 20 22 22 20 69 74 65 (equal? "" ite
4930: 6d 2d 70 61 74 68 29 29 0a 0a 09 20 3b 3b 20 61 m-path))... ;; a
4940: 6c 6c 20 74 65 73 74 73 20 61 72 65 20 66 6f 75 ll tests are fou
4950: 6e 64 20 61 74 20 3c 72 75 6e 64 69 72 3e 2f 74 nd at <rundir>/t
4960: 65 73 74 2d 62 61 73 65 20 6f 72 20 3c 6c 69 6e est-base or <lin
4970: 6b 64 69 72 3e 2f 74 65 73 74 2d 62 61 73 65 0a kdir>/test-base.
4980: 09 20 28 74 65 73 74 74 6f 70 2d 62 61 73 65 20 . (testtop-base
4990: 28 63 6f 6e 63 20 74 61 72 67 65 74 20 22 2f 22 (conc target "/"
49a0: 20 72 75 6e 6e 61 6d 65 20 22 2f 22 20 74 65 73 runname "/" tes
49b0: 74 6e 61 6d 65 29 29 0a 09 20 28 74 65 73 74 2d tname)).. (test-
49c0: 62 61 73 65 20 20 20 20 28 63 6f 6e 63 20 74 65 base (conc te
49d0: 73 74 74 6f 70 2d 62 61 73 65 20 28 69 66 20 6e sttop-base (if n
49e0: 6f 74 2d 69 74 65 72 61 74 65 64 20 22 22 20 22 ot-iterated "" "
49f0: 2f 22 29 20 69 74 65 6d 2d 70 61 74 68 29 29 0a /") item-path)).
4a00: 0a 09 20 3b 3b 20 6e 62 2f 2f 20 69 66 20 69 74 .. ;; nb// if it
4a10: 65 6d 70 61 74 68 20 69 73 20 6e 6f 74 20 22 22 empath is not ""
4a20: 20 74 68 65 6e 20 69 74 20 69 73 20 70 72 65 66 then it is pref
4a30: 69 78 65 64 20 77 69 74 68 20 22 2f 22 0a 09 20 ixed with "/"..
4a40: 28 74 6f 70 74 65 73 74 2d 70 61 74 68 20 28 63 (toptest-path (c
4a50: 6f 6e 63 20 64 69 73 6b 2d 70 61 74 68 20 22 2f onc disk-path "/
4a60: 22 20 74 65 73 74 74 6f 70 2d 62 61 73 65 29 29 " testtop-base))
4a70: 0a 09 20 28 74 65 73 74 2d 70 61 74 68 20 20 20 .. (test-path
4a80: 20 28 63 6f 6e 63 20 64 69 73 6b 2d 70 61 74 68 (conc disk-path
4a90: 20 22 2f 22 20 74 65 73 74 2d 62 61 73 65 29 29 "/" test-base))
4aa0: 0a 0a 09 20 3b 3b 20 65 6e 73 75 72 65 20 74 68 ... ;; ensure th
4ab0: 69 73 20 65 78 69 73 74 73 20 66 69 72 73 74 20 is exists first
4ac0: 61 73 20 6c 69 6e 6b 73 20 74 6f 20 73 75 62 74 as links to subt
4ad0: 65 73 74 73 20 6d 75 73 74 20 62 65 20 63 72 65 ests must be cre
4ae0: 61 74 65 64 20 74 68 65 72 65 0a 09 20 28 6c 69 ated there.. (li
4af0: 6e 6b 74 72 65 65 20 20 28 6c 65 74 20 28 28 72 nktree (let ((r
4b00: 64 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 d (config-lookup
4b10: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
4b20: 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 tup" "linktree")
4b30: 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 72 ))... (if r
4b40: 64 20 72 64 20 28 63 6f 6e 63 20 2a 74 6f 70 70 d rd (conc *topp
4b50: 61 74 68 2a 20 22 2f 72 75 6e 73 22 29 29 29 29 ath* "/runs"))))
4b60: 0a 0a 09 20 28 6c 6e 6b 62 61 73 65 20 20 28 63 ... (lnkbase (c
4b70: 6f 6e 63 20 6c 69 6e 6b 74 72 65 65 20 22 2f 22 onc linktree "/"
4b80: 20 74 61 72 67 65 74 20 22 2f 22 20 72 75 6e 6e target "/" runn
4b90: 61 6d 65 29 29 0a 09 20 28 6c 6e 6b 70 61 74 68 ame)).. (lnkpath
4ba0: 20 20 28 63 6f 6e 63 20 6c 6e 6b 62 61 73 65 20 (conc lnkbase
4bb0: 22 2f 22 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 "/" testname))..
4bc0: 20 28 6c 6e 6b 70 61 74 68 66 20 28 63 6f 6e 63 (lnkpathf (conc
4bd0: 20 6c 6e 6b 70 61 74 68 20 28 69 66 20 6e 6f 74 lnkpath (if not
4be0: 2d 69 74 65 72 61 74 65 64 20 22 22 20 22 2f 22 -iterated "" "/"
4bf0: 29 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a 0a ) item-path)))..
4c00: 20 20 20 20 3b 3b 20 55 70 64 61 74 65 20 74 68 ;; Update th
4c10: 65 20 72 75 6e 64 69 72 20 70 61 74 68 20 69 6e e rundir path in
4c20: 20 74 68 65 20 74 65 73 74 20 72 65 63 6f 72 64 the test record
4c30: 20 66 6f 72 20 61 6c 6c 0a 20 20 20 20 28 63 64 for all. (cd
4c40: 62 3a 74 65 73 74 2d 73 65 74 2d 72 75 6e 64 69 b:test-set-rundi
4c50: 72 2d 62 79 2d 74 65 73 74 2d 69 64 20 2a 72 75 r-by-test-id *ru
4c60: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
4c70: 20 6c 6e 6b 70 61 74 68 66 29 0a 0a 20 20 20 20 lnkpathf)..
4c80: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 "
4c90: 49 4e 46 4f 3a 5c 6e 20 20 20 20 20 20 20 6c 6e INFO:\n ln
4ca0: 6b 62 61 73 65 3d 22 20 6c 6e 6b 62 61 73 65 20 kbase=" lnkbase
4cb0: 22 5c 6e 20 20 20 20 20 20 20 6c 6e 6b 70 61 74 "\n lnkpat
4cc0: 68 3d 22 20 6c 6e 6b 70 61 74 68 20 22 5c 6e 20 h=" lnkpath "\n
4cd0: 20 74 6f 70 74 65 73 74 2d 70 61 74 68 3d 22 20 toptest-path="
4ce0: 74 6f 70 74 65 73 74 2d 70 61 74 68 20 22 5c 6e toptest-path "\n
4cf0: 20 20 20 20 20 74 65 73 74 2d 70 61 74 68 3d 22 test-path="
4d00: 20 74 65 73 74 2d 70 61 74 68 29 0a 20 20 20 20 test-path).
4d10: 28 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 (if (not (file-e
4d20: 78 69 73 74 73 3f 20 6c 69 6e 6b 74 72 65 65 29 xists? linktree)
4d30: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
4d40: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
4d50: 4e 49 4e 47 3a 20 6c 69 6e 6b 74 72 65 65 20 64 NING: linktree d
4d60: 69 64 20 6e 6f 74 20 65 78 69 73 74 21 20 43 72 id not exist! Cr
4d70: 65 61 74 69 6e 67 20 69 74 20 6e 6f 77 20 61 74 eating it now at
4d80: 20 22 20 6c 69 6e 6b 74 72 65 65 29 0a 09 20 20 " linktree)..
4d90: 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 (create-director
4da0: 79 20 6c 69 6e 6b 74 72 65 65 20 23 74 29 29 29 y linktree #t)))
4db0: 20 3b 3b 20 28 73 79 73 74 65 6d 20 28 63 6f 6e ;; (system (con
4dc0: 63 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6c 69 c "mkdir -p " li
4dd0: 6e 6b 74 72 65 65 29 29 29 29 0a 20 20 20 20 3b nktree)))). ;
4de0: 3b 20 63 72 65 61 74 65 20 74 68 65 20 64 69 72 ; create the dir
4df0: 65 63 74 6f 72 79 20 66 6f 72 20 74 68 65 20 74 ectory for the t
4e00: 65 73 74 73 20 64 69 72 20 6c 69 6e 6b 73 2c 20 ests dir links,
4e10: 74 68 69 73 20 69 73 20 6e 65 65 64 65 64 20 6e this is needed n
4e20: 6f 20 6d 61 74 74 65 72 20 77 68 61 74 2e 2e 2e o matter what...
4e30: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 64 . (if (not (d
4e40: 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f irectory-exists?
4e50: 20 6c 6e 6b 62 61 73 65 29 29 0a 09 28 63 72 65 lnkbase))..(cre
4e60: 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 6c 6e ate-directory ln
4e70: 6b 62 61 73 65 20 23 74 29 29 0a 20 20 20 20 0a kbase #t)). .
4e80: 20 20 20 20 3b 3b 20 75 70 64 61 74 65 20 74 68 ;; update th
4e90: 65 20 74 6f 70 74 65 73 74 20 72 65 63 6f 72 64 e toptest record
4ea0: 20 77 69 74 68 20 69 74 73 20 6c 6f 63 61 74 69 with its locati
4eb0: 6f 6e 20 72 75 6e 64 69 72 2c 20 63 61 63 68 65 on rundir, cache
4ec0: 20 74 68 65 20 70 61 74 68 0a 20 20 20 20 3b 3b the path. ;;
4ed0: 20 54 68 69 73 20 77 61 73 73 20 68 69 67 68 6c This wass highl
4ee0: 79 20 69 6e 65 66 66 69 63 69 65 6e 74 2c 20 6f y inefficient, o
4ef0: 6e 65 20 64 62 20 77 72 69 74 65 20 66 6f 72 20 ne db write for
4f00: 65 76 65 72 79 20 73 75 62 74 65 73 74 2c 20 70 every subtest, p
4f10: 6f 74 65 6e 74 69 61 6c 6c 79 0a 20 20 20 20 3b otentially. ;
4f20: 3b 20 74 68 6f 75 73 61 6e 64 73 20 6f 66 20 75 ; thousands of u
4f30: 6e 6e 65 63 65 73 73 61 72 79 20 75 70 64 61 74 nnecessary updat
4f40: 65 73 2c 20 63 61 63 68 65 20 74 68 65 20 66 61 es, cache the fa
4f50: 63 74 20 69 74 20 77 61 73 20 73 65 74 20 61 6e ct it was set an
4f60: 64 20 64 6f 6e 27 74 20 73 65 74 20 69 74 20 0a d don't set it .
4f70: 20 20 20 20 3b 3b 20 61 67 61 69 6e 2e 20 0a 0a ;; again. ..
4f80: 20 20 20 20 3b 3b 20 4e 42 20 2d 20 54 68 69 73 ;; NB - This
4f90: 20 69 73 20 6e 6f 74 20 77 6f 72 6b 69 6e 67 20 is not working
4fa0: 72 69 67 68 74 20 2d 20 73 6f 6d 65 20 74 6f 70 right - some top
4fb0: 20 74 65 73 74 73 20 61 72 65 20 6e 6f 74 20 67 tests are not g
4fc0: 65 74 74 69 6e 67 20 74 68 65 20 70 61 74 68 20 etting the path
4fd0: 73 65 74 21 21 21 0a 0a 20 20 20 20 28 69 66 20 set!!!.. (if
4fe0: 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (not (hash-table
4ff0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 74 6f -ref/default *to
5000: 70 74 65 73 74 2d 70 61 74 68 73 2a 20 74 65 73 ptest-paths* tes
5010: 74 6e 61 6d 65 20 23 66 29 29 0a 09 28 6c 65 74 tname #f))..(let
5020: 2a 20 28 28 74 65 73 74 69 6e 66 6f 20 20 20 20 * ((testinfo
5030: 20 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 74 (cdb:get-test
5040: 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 6e -info-by-id *run
5050: 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 29 remote* test-id)
5060: 29 20 3b 3b 20 20 72 75 6e 2d 69 64 20 74 65 73 ) ;; run-id tes
5070: 74 6e 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 tname item-path)
5080: 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 2d ).. (curr-
5090: 74 65 73 74 2d 70 61 74 68 20 28 69 66 20 74 65 test-path (if te
50a0: 73 74 69 6e 66 6f 20 28 64 62 3a 74 65 73 74 2d stinfo (db:test-
50b0: 67 65 74 2d 72 75 6e 64 69 72 20 74 65 73 74 69 get-rundir testi
50c0: 6e 66 6f 29 20 23 66 29 29 29 0a 09 20 20 28 68 nfo) #f))).. (h
50d0: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
50e0: 74 6f 70 74 65 73 74 2d 70 61 74 68 73 2a 20 74 toptest-paths* t
50f0: 65 73 74 6e 61 6d 65 20 63 75 72 72 2d 74 65 73 estname curr-tes
5100: 74 2d 70 61 74 68 29 0a 09 20 20 3b 3b 20 4e 42 t-path).. ;; NB
5110: 2f 2f 20 57 61 73 20 74 68 69 73 20 66 6f 72 20 // Was this for
5120: 74 68 65 20 74 65 73 74 20 6f 72 20 66 6f 72 20 the test or for
5130: 74 68 65 20 70 61 72 65 6e 74 20 69 6e 20 61 6e the parent in an
5140: 20 69 74 65 72 61 74 65 64 20 74 65 73 74 3f 0a iterated test?.
5150: 09 20 20 28 63 64 62 3a 74 65 73 74 2d 73 65 74 . (cdb:test-set
5160: 2d 72 75 6e 64 69 72 21 20 2a 72 75 6e 72 65 6d -rundir! *runrem
5170: 6f 74 65 2a 20 72 75 6e 2d 69 64 20 74 65 73 74 ote* run-id test
5180: 6e 61 6d 65 20 22 22 20 6c 6e 6b 70 61 74 68 29 name "" lnkpath)
5190: 20 3b 3b 20 74 6f 70 74 65 73 74 2d 70 61 74 68 ;; toptest-path
51a0: 29 0a 09 20 20 28 69 66 20 28 6f 72 20 28 6e 6f ).. (if (or (no
51b0: 74 20 63 75 72 72 2d 74 65 73 74 2d 70 61 74 68 t curr-test-path
51c0: 29 0a 09 09 20 20 28 6e 6f 74 20 28 64 69 72 65 )... (not (dire
51d0: 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 74 6f ctory-exists? to
51e0: 70 74 65 73 74 2d 70 61 74 68 29 29 29 0a 09 20 ptest-path)))..
51f0: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 (begin...(d
5200: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
5210: 32 20 22 43 72 65 61 74 69 6e 67 20 22 20 74 6f 2 "Creating " to
5220: 70 74 65 73 74 2d 70 61 74 68 20 22 20 61 6e 64 ptest-path " and
5230: 20 6c 69 6e 6b 20 22 20 6c 6e 6b 70 61 74 68 29 link " lnkpath)
5240: 0a 09 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 ...(create-direc
5250: 74 6f 72 79 20 74 6f 70 74 65 73 74 2d 70 61 74 tory toptest-pat
5260: 68 20 23 74 29 0a 09 09 28 68 61 73 68 2d 74 61 h #t)...(hash-ta
5270: 62 6c 65 2d 73 65 74 21 20 2a 74 6f 70 74 65 73 ble-set! *toptes
5280: 74 2d 70 61 74 68 73 2a 20 74 65 73 74 6e 61 6d t-paths* testnam
5290: 65 20 74 6f 70 74 65 73 74 2d 70 61 74 68 29 29 e toptest-path))
52a0: 29 29 29 0a 0a 20 20 20 20 3b 3b 20 4e 6f 77 20 ))).. ;; Now
52b0: 63 72 65 61 74 65 20 74 68 65 20 6c 69 6e 6b 20 create the link
52c0: 66 72 6f 6d 20 74 68 65 20 74 65 73 74 20 70 61 from the test pa
52d0: 74 68 20 74 6f 20 74 68 65 20 6c 69 6e 6b 20 74 th to the link t
52e0: 72 65 65 2c 20 68 6f 77 65 76 65 72 0a 20 20 20 ree, however.
52f0: 20 3b 3b 20 69 66 20 74 68 65 20 74 65 73 74 20 ;; if the test
5300: 69 73 20 69 74 65 72 61 74 65 64 20 69 74 20 69 is iterated it i
5310: 73 20 6e 65 63 65 73 73 61 72 79 20 74 6f 20 63 s necessary to c
5320: 72 65 61 74 65 20 74 68 65 20 70 61 72 65 6e 74 reate the parent
5330: 20 70 61 74 68 0a 20 20 20 20 3b 3b 20 74 6f 20 path. ;; to
5340: 74 68 65 20 69 74 65 72 61 74 69 6f 6e 2e 20 75 the iteration. u
5350: 73 65 20 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 se pathname-dire
5360: 63 74 6f 72 79 20 74 6f 20 74 72 69 6d 20 74 68 ctory to trim th
5370: 65 20 70 61 74 68 20 62 79 20 6f 6e 65 0a 20 20 e path by one.
5380: 20 20 3b 3b 20 6c 65 76 65 6c 0a 20 20 20 20 28 ;; level. (
5390: 69 66 20 28 6e 6f 74 20 6e 6f 74 2d 69 74 65 72 if (not not-iter
53a0: 61 74 65 64 29 20 3b 3b 20 69 2e 65 2e 20 69 74 ated) ;; i.e. it
53b0: 65 72 61 74 65 64 0a 09 28 6c 65 74 20 28 28 69 erated..(let ((i
53c0: 74 65 72 61 74 65 64 2d 70 61 72 65 6e 74 20 20 terated-parent
53d0: 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 (pathname-direct
53e0: 6f 72 79 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 ory (conc lnkpat
53f0: 68 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 h "/" item-path)
5400: 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 ))).. (debug:pr
5410: 69 6e 74 2d 69 6e 66 6f 20 32 20 22 43 72 65 61 int-info 2 "Crea
5420: 74 69 6e 67 20 69 74 65 72 61 74 65 64 20 70 61 ting iterated pa
5430: 72 65 6e 74 20 22 20 69 74 65 72 61 74 65 64 2d rent " iterated-
5440: 70 61 72 65 6e 74 29 0a 09 20 20 28 68 61 6e 64 parent).. (hand
5450: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 le-exceptions..
5460: 20 20 65 78 6e 0a 09 20 20 20 28 62 65 67 69 6e exn.. (begin
5470: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
5480: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 20 46 int 0 "ERROR: F
5490: 61 69 6c 65 64 20 74 6f 20 63 72 65 61 74 65 20 ailed to create
54a0: 64 69 72 65 63 74 6f 72 79 20 22 20 69 74 65 72 directory " iter
54b0: 61 74 65 64 2d 70 61 72 65 6e 74 20 28 28 63 6f ated-parent ((co
54c0: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
54d0: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
54e0: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c message) exn) ",
54f0: 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 exiting")..
5500: 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 28 (exit 1)).. (
5510: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
5520: 20 69 74 65 72 61 74 65 64 2d 70 61 72 65 6e 74 iterated-parent
5530: 20 23 74 29 29 29 29 0a 0a 20 20 20 20 28 69 66 #t)))).. (if
5540: 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f (symbolic-link?
5550: 20 6c 6e 6b 70 61 74 68 29 20 0a 09 28 68 61 6e lnkpath) ..(han
5560: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
5570: 20 65 78 6e 0a 09 20 28 62 65 67 69 6e 0a 09 20 exn.. (begin..
5580: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
5590: 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 "ERROR: Failed
55a0: 20 74 6f 20 72 65 6d 6f 76 65 20 73 79 6d 6c 69 to remove symli
55b0: 6e 6b 20 22 20 6c 6e 6b 70 61 74 68 20 28 28 63 nk " lnkpath ((c
55c0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
55d0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
55e0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 'message) exn) "
55f0: 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 , exiting")..
5600: 28 65 78 69 74 20 31 29 29 0a 09 20 28 64 65 6c (exit 1)).. (del
5610: 65 74 65 2d 66 69 6c 65 20 6c 6e 6b 70 61 74 68 ete-file lnkpath
5620: 29 29 29 0a 0a 20 20 20 20 28 69 66 20 28 6e 6f ))).. (if (no
5630: 74 20 28 6f 72 20 28 66 69 6c 65 2d 65 78 69 73 t (or (file-exis
5640: 74 73 3f 20 6c 6e 6b 70 61 74 68 29 0a 09 09 20 ts? lnkpath)...
5650: 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 (symbolic-link?
5660: 6c 6e 6b 70 61 74 68 29 29 29 0a 09 28 68 61 6e lnkpath)))..(han
5670: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
5680: 20 65 78 6e 0a 09 20 28 62 65 67 69 6e 0a 09 20 exn.. (begin..
5690: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
56a0: 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 "ERROR: Failed
56b0: 20 74 6f 20 63 72 65 61 74 65 20 73 79 6d 6c 69 to create symli
56c0: 6e 6b 20 22 20 6c 6e 6b 70 61 74 68 20 28 28 63 nk " lnkpath ((c
56d0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
56e0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
56f0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 22 'message) exn) "
5700: 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 20 , exiting")..
5710: 28 65 78 69 74 20 31 29 29 0a 09 20 28 63 72 65 (exit 1)).. (cre
5720: 61 74 65 2d 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e ate-symbolic-lin
5730: 6b 20 74 6f 70 74 65 73 74 2d 70 61 74 68 20 6c k toptest-path l
5740: 6e 6b 70 61 74 68 29 29 29 0a 20 20 20 20 0a 20 nkpath))). .
5750: 20 20 20 3b 3b 20 54 68 65 20 74 6f 70 74 65 73 ;; The toptes
5760: 74 20 70 61 74 68 20 68 61 73 20 62 65 65 6e 20 t path has been
5770: 63 72 65 61 74 65 64 2c 20 74 68 65 20 6c 69 6e created, the lin
5780: 6b 20 74 6f 20 74 68 65 20 74 65 73 74 20 69 6e k to the test in
5790: 20 74 68 65 20 6c 69 6e 6b 74 72 65 65 20 68 61 the linktree ha
57a0: 73 0a 20 20 20 20 3b 3b 20 62 65 65 6e 20 63 72 s. ;; been cr
57b0: 65 61 74 65 64 2e 20 4e 6f 77 2c 20 69 66 20 74 eated. Now, if t
57c0: 68 69 73 20 69 73 20 61 6e 20 69 74 65 72 61 74 his is an iterat
57d0: 65 64 20 74 65 73 74 20 74 68 65 20 72 65 61 6c ed test the real
57e0: 20 74 65 73 74 20 64 69 72 20 6d 75 73 74 20 62 test dir must b
57f0: 65 20 63 72 65 61 74 65 64 0a 20 20 20 20 28 69 e created. (i
5800: 66 20 28 6e 6f 74 20 6e 6f 74 2d 69 74 65 72 61 f (not not-itera
5810: 74 65 64 29 20 3b 3b 20 74 68 69 73 20 69 73 20 ted) ;; this is
5820: 61 6e 20 69 74 65 72 61 74 65 64 20 74 65 73 74 an iterated test
5830: 0a 09 28 6c 65 74 20 28 28 6c 6e 6b 74 61 72 67 ..(let ((lnktarg
5840: 65 74 20 28 63 6f 6e 63 20 6c 6e 6b 70 61 74 68 et (conc lnkpath
5850: 20 22 2f 22 20 69 74 65 6d 2d 70 61 74 68 29 29 "/" item-path))
5860: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
5870: 74 20 32 20 22 53 65 74 74 69 6e 67 20 75 70 20 t 2 "Setting up
5880: 73 75 62 20 74 65 73 74 20 72 75 6e 20 61 72 65 sub test run are
5890: 61 22 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 a").. (debug:pr
58a0: 69 6e 74 20 32 20 22 20 2d 20 63 72 65 61 74 69 int 2 " - creati
58b0: 6e 67 20 72 75 6e 20 61 72 65 61 20 69 6e 20 22 ng run area in "
58c0: 20 74 65 73 74 2d 70 61 74 68 29 0a 09 20 20 28 test-path).. (
58d0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
58e0: 73 0a 09 20 20 20 65 78 6e 0a 09 20 20 20 28 62 s.. exn.. (b
58f0: 65 67 69 6e 0a 09 20 20 20 20 20 28 64 65 62 75 egin.. (debu
5900: 67 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 g:print 0 "ERROR
5910: 3a 20 20 46 61 69 6c 65 64 20 74 6f 20 63 72 65 : Failed to cre
5920: 61 74 65 20 64 69 72 65 63 74 6f 72 79 20 22 20 ate directory "
5930: 74 65 73 74 2d 70 61 74 68 20 28 28 63 6f 6e 64 test-path ((cond
5940: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
5950: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
5960: 73 73 61 67 65 29 20 65 78 6e 29 20 22 2c 20 65 ssage) exn) ", e
5970: 78 69 74 69 6e 67 22 29 0a 09 20 20 20 20 20 28 xiting").. (
5980: 65 78 69 74 20 31 29 29 0a 09 20 20 20 28 63 72 exit 1)).. (cr
5990: 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 74 eate-directory t
59a0: 65 73 74 2d 70 61 74 68 20 23 74 29 29 0a 09 20 est-path #t))..
59b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2
59c0: 0a 09 09 20 20 20 20 20 20 20 22 20 2d 20 63 72 ... " - cr
59d0: 65 61 74 69 6e 67 20 6c 69 6e 6b 20 66 72 6f 6d eating link from
59e0: 3a 20 22 20 74 65 73 74 2d 70 61 74 68 20 22 5c : " test-path "\
59f0: 6e 22 0a 09 09 20 20 20 20 20 20 20 22 20 20 20 n"... "
5a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a10: 74 6f 3a 20 22 20 6c 6e 6b 74 61 72 67 65 74 29 to: " lnktarget)
5a20: 0a 0a 09 20 20 3b 3b 20 49 66 20 74 68 65 72 65 ... ;; If there
5a30: 20 69 73 20 61 6c 72 65 61 64 79 20 61 20 73 79 is already a sy
5a40: 6d 6c 69 6e 6b 20 64 65 6c 65 74 65 20 69 74 20 mlink delete it
5a50: 61 6e 64 20 72 65 63 72 65 61 74 65 20 69 74 2e and recreate it.
5a60: 0a 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 .. (handle-exce
5a70: 70 74 69 6f 6e 73 0a 09 20 20 20 65 78 6e 0a 09 ptions.. exn..
5a80: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
5a90: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 22 (debug:print 0 "
5aa0: 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 ERROR: Failed t
5ab0: 6f 20 72 65 2d 63 72 65 61 74 65 20 6c 69 6e 6b o re-create link
5ac0: 20 22 20 6c 69 6e 6b 74 61 72 67 65 74 20 28 28 " linktarget ((
5ad0: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
5ae0: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
5af0: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 20 'message) exn)
5b00: 22 2c 20 65 78 69 74 69 6e 67 22 29 0a 09 20 20 ", exiting")..
5b10: 20 20 20 28 65 78 69 74 29 29 0a 09 20 20 20 28 (exit)).. (
5b20: 69 66 20 28 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e if (symbolic-lin
5b30: 6b 3f 20 6c 6e 6b 74 61 72 67 65 74 29 20 20 20 k? lnktarget)
5b40: 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 6c (delete-file l
5b50: 6e 6b 74 61 72 67 65 74 29 29 0a 09 20 20 20 28 nktarget)).. (
5b60: 69 66 20 28 6e 6f 74 20 28 66 69 6c 65 2d 65 78 if (not (file-ex
5b70: 69 73 74 73 3f 20 6c 6e 6b 74 61 72 67 65 74 29 ists? lnktarget)
5b80: 29 20 28 63 72 65 61 74 65 2d 73 79 6d 62 6f 6c ) (create-symbol
5b90: 69 63 2d 6c 69 6e 6b 20 74 65 73 74 2d 70 61 74 ic-link test-pat
5ba0: 68 20 6c 6e 6b 74 61 72 67 65 74 29 29 29 29 29 h lnktarget)))))
5bb0: 0a 0a 20 20 20 20 3b 3b 20 49 20 73 75 73 70 65 .. ;; I suspe
5bc0: 63 74 20 74 68 69 73 20 73 65 63 74 69 6f 6e 20 ct this section
5bd0: 77 61 73 20 64 65 6c 65 74 69 6e 67 20 74 65 73 was deleting tes
5be0: 74 20 64 69 72 65 63 74 6f 72 69 65 73 20 75 6e t directories un
5bf0: 64 65 72 20 73 6f 6d 65 20 0a 20 20 20 20 3b 3b der some . ;;
5c00: 20 77 69 65 72 64 20 73 69 74 61 74 69 6f 6e 73 wierd sitations
5c10: 3f 20 54 68 69 73 20 64 6f 65 73 6e 27 74 20 6d ? This doesn't m
5c20: 61 6b 65 20 73 65 6e 73 65 20 2d 20 72 65 65 6e ake sense - reen
5c30: 61 62 6c 69 6e 67 20 74 68 65 20 72 6d 20 2d 66 abling the rm -f
5c40: 20 0a 20 20 20 20 3b 3b 20 49 20 68 6f 6e 65 73 . ;; I hones
5c50: 74 6c 79 20 64 6f 6e 27 74 20 72 65 6d 65 6d 62 tly don't rememb
5c60: 65 72 20 2a 77 68 79 2a 20 74 68 69 73 20 63 68 er *why* this ch
5c70: 75 6e 6b 20 77 61 73 20 6e 65 65 64 65 64 2e 2e unk was needed..
5c80: 2e 0a 20 20 20 20 3b 3b 20 28 6c 65 74 20 28 28 .. ;; (let ((
5c90: 74 65 73 74 6c 69 6e 6b 20 28 63 6f 6e 63 20 6c testlink (conc l
5ca0: 6e 6b 70 61 74 68 20 22 2f 22 20 74 65 73 74 6e nkpath "/" testn
5cb0: 61 6d 65 29 29 29 0a 20 20 20 20 3b 3b 20 20 20 ame))). ;;
5cc0: 28 69 66 20 28 61 6e 64 20 28 66 69 6c 65 2d 65 (if (and (file-e
5cd0: 78 69 73 74 73 3f 20 74 65 73 74 6c 69 6e 6b 29 xists? testlink)
5ce0: 0a 20 20 20 20 3b 3b 20 20 20 20 20 20 20 20 20 . ;;
5cf0: 20 20 20 28 6f 72 20 28 72 65 67 75 6c 61 72 2d (or (regular-
5d00: 66 69 6c 65 3f 20 74 65 73 74 6c 69 6e 6b 29 0a file? testlink).
5d10: 20 20 20 20 3b 3b 20 20 20 20 20 09 20 20 20 28 ;; . (
5d20: 73 79 6d 62 6f 6c 69 63 2d 6c 69 6e 6b 3f 20 74 symbolic-link? t
5d30: 65 73 74 6c 69 6e 6b 29 29 29 0a 20 20 20 20 3b estlink))). ;
5d40: 3b 20 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 ; (system
5d50: 28 63 6f 6e 63 20 22 72 6d 20 2d 66 20 22 20 74 (conc "rm -f " t
5d60: 65 73 74 6c 69 6e 6b 29 29 29 0a 20 20 20 20 3b estlink))). ;
5d70: 3b 20 20 20 28 73 79 73 74 65 6d 20 20 28 63 6f ; (system (co
5d80: 6e 63 20 22 6c 6e 20 2d 73 66 20 22 20 74 65 73 nc "ln -sf " tes
5d90: 74 2d 70 61 74 68 20 22 20 22 20 74 65 73 74 6c t-path " " testl
5da0: 69 6e 6b 29 29 29 0a 20 20 20 20 28 69 66 20 28 ink))). (if (
5db0: 64 69 72 65 63 74 6f 72 79 3f 20 74 65 73 74 2d directory? test-
5dc0: 70 61 74 68 29 0a 09 28 62 65 67 69 6e 0a 09 20 path)..(begin..
5dd0: 20 28 6c 65 74 2a 20 28 28 6f 76 72 63 6d 64 20 (let* ((ovrcmd
5de0: 28 6c 65 74 20 28 28 63 6d 64 20 28 63 6f 6e 66 (let ((cmd (conf
5df0: 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 ig-lookup *confi
5e00: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 74 gdat* "setup" "t
5e10: 65 73 74 63 6f 70 79 63 6d 64 22 29 29 29 0a 09 estcopycmd")))..
5e20: 09 09 20 20 20 28 69 66 20 63 6d 64 0a 09 09 09 .. (if cmd....
5e30: 20 20 20 20 20 20 20 3b 3b 20 73 75 62 73 74 69 ;; substi
5e40: 74 75 74 65 20 74 68 65 20 54 45 53 54 5f 53 52 tute the TEST_SR
5e50: 43 5f 50 41 54 48 20 61 6e 64 20 54 45 53 54 5f C_PATH and TEST_
5e60: 54 41 52 47 5f 50 41 54 48 0a 09 09 09 20 20 20 TARG_PATH....
5e70: 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 62 73 (string-subs
5e80: 74 69 74 75 74 65 20 22 54 45 53 54 5f 54 41 52 titute "TEST_TAR
5e90: 47 5f 50 41 54 48 22 20 74 65 73 74 2d 70 61 74 G_PATH" test-pat
5ea0: 68 0a 09 09 09 09 09 09 20 20 28 73 74 72 69 6e h....... (strin
5eb0: 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 54 45 g-substitute "TE
5ec0: 53 54 5f 53 52 43 5f 50 41 54 48 22 20 74 65 73 ST_SRC_PATH" tes
5ed0: 74 2d 73 72 63 2d 70 61 74 68 20 63 6d 64 20 23 t-src-path cmd #
5ee0: 74 29 20 23 74 29 0a 09 09 09 20 20 20 20 20 20 t) #t)....
5ef0: 20 23 66 29 29 29 0a 09 09 20 28 63 6d 64 20 20 #f)))... (cmd
5f00: 20 20 28 69 66 20 6f 76 72 63 6d 64 20 0a 09 09 (if ovrcmd ...
5f10: 09 20 20 20 20 20 6f 76 72 63 6d 64 0a 09 09 09 . ovrcmd....
5f20: 20 20 20 20 20 28 63 6f 6e 63 20 22 72 73 79 6e (conc "rsyn
5f30: 63 20 2d 61 76 22 20 28 69 66 20 28 64 65 62 75 c -av" (if (debu
5f40: 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 20 g:debug-mode 1)
5f50: 22 22 20 22 71 22 29 20 22 20 22 20 74 65 73 74 "" "q") " " test
5f60: 2d 73 72 63 2d 70 61 74 68 20 22 2f 20 22 20 74 -src-path "/ " t
5f70: 65 73 74 2d 70 61 74 68 20 22 2f 22 0a 09 09 09 est-path "/"....
5f80: 09 20 20 20 22 20 3e 3e 20 22 20 74 65 73 74 2d . " >> " test-
5f90: 70 61 74 68 20 22 2f 6d 74 5f 6c 61 75 6e 63 68 path "/mt_launch
5fa0: 2e 6c 6f 67 20 32 3e 3e 20 22 20 74 65 73 74 2d .log 2>> " test-
5fb0: 70 61 74 68 20 22 2f 6d 74 5f 6c 61 75 6e 63 68 path "/mt_launch
5fc0: 2e 6c 6f 67 22 29 29 29 0a 09 09 20 28 73 74 61 .log")))... (sta
5fd0: 74 75 73 20 28 73 79 73 74 65 6d 20 63 6d 64 29 tus (system cmd)
5fe0: 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
5ff0: 20 28 65 71 3f 20 73 74 61 74 75 73 20 30 29 29 (eq? status 0))
6000: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
6010: 32 20 22 45 52 52 4f 52 3a 20 70 72 6f 62 6c 65 2 "ERROR: proble
6020: 6d 20 77 69 74 68 20 72 75 6e 6e 69 6e 67 20 5c m with running \
6030: 22 22 20 63 6d 64 20 22 5c 22 22 29 29 29 0a 09 "" cmd "\"")))..
6040: 20 20 28 6c 69 73 74 20 6c 6e 6b 70 61 74 68 66 (list lnkpathf
6050: 20 6c 6e 6b 70 61 74 68 20 29 29 0a 09 28 6c 69 lnkpath ))..(li
6060: 73 74 20 23 66 20 23 66 29 29 29 29 0a 0a 3b 3b st #f #f))))..;;
6070: 20 31 2e 20 6c 6f 6f 6b 20 74 68 6f 75 67 68 20 1. look though
6080: 64 69 73 6b 73 20 6c 69 73 74 20 66 6f 72 20 64 disks list for d
6090: 69 73 6b 20 77 69 74 68 20 6d 6f 73 74 20 73 70 isk with most sp
60a0: 61 63 65 0a 3b 3b 20 32 2e 20 63 72 65 61 74 65 ace.;; 2. create
60b0: 20 72 75 6e 20 64 69 72 20 6f 6e 20 64 69 73 6b run dir on disk
60c0: 2c 20 70 61 74 68 20 6e 61 6d 65 20 69 73 20 6d , path name is m
60d0: 65 61 6e 69 6e 67 66 75 6c 0a 3b 3b 20 33 2e 20 eaningful.;; 3.
60e0: 63 72 65 61 74 65 20 6c 69 6e 6b 20 66 72 6f 6d create link from
60f0: 20 72 75 6e 20 64 69 72 20 74 6f 20 6d 65 67 61 run dir to mega
6100: 74 65 73 74 20 72 75 6e 73 20 61 72 65 61 20 0a test runs area .
6110: 3b 3b 20 34 2e 20 72 65 6d 6f 74 65 6c 79 20 72 ;; 4. remotely r
6120: 75 6e 20 74 68 65 20 74 65 73 74 20 6f 6e 20 61 un the test on a
6130: 6c 6c 6f 63 61 74 65 64 20 68 6f 73 74 0a 3b 3b llocated host.;;
6140: 20 20 20 20 2d 20 63 6f 75 6c 64 20 62 65 20 73 - could be s
6150: 73 68 20 74 6f 20 68 6f 73 74 20 66 72 6f 6d 20 sh to host from
6160: 68 6f 73 74 73 20 74 61 62 6c 65 20 28 75 70 64 hosts table (upd
6170: 61 74 65 20 72 65 67 75 6c 61 72 6c 79 20 77 69 ate regularly wi
6180: 74 68 20 6c 6f 61 64 29 0a 3b 3b 20 20 20 20 2d th load).;; -
6190: 20 63 6f 75 6c 64 20 62 65 20 6e 65 74 62 61 74 could be netbat
61a0: 63 68 0a 3b 3b 20 20 20 20 20 20 28 6c 61 75 6e ch.;; (laun
61b0: 63 68 2d 74 65 73 74 20 64 62 20 28 63 61 64 72 ch-test db (cadr
61c0: 20 73 74 61 74 75 73 29 20 74 65 73 74 2d 63 6f status) test-co
61d0: 6e 66 29 29 0a 28 64 65 66 69 6e 65 20 28 6c 61 nf)).(define (la
61e0: 75 6e 63 68 2d 74 65 73 74 20 74 65 73 74 2d 69 unch-test test-i
61f0: 64 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e 66 d run-id run-inf
6200: 6f 20 6b 65 79 76 61 6c 73 20 72 75 6e 6e 61 6d o keyvals runnam
6210: 65 20 74 65 73 74 2d 63 6f 6e 66 20 74 65 73 74 e test-conf test
6220: 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 20 -name test-path
6230: 69 74 65 6d 64 61 74 20 70 61 72 61 6d 73 29 0a itemdat params).
6240: 20 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 (change-direct
6250: 6f 72 79 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 ory *toppath*).
6260: 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 (alist->env-var
6270: 73 20 3b 3b 20 63 6f 6e 73 6f 6c 69 64 61 74 65 s ;; consolidate
6280: 20 74 68 69 73 20 63 6f 64 65 20 77 69 74 68 20 this code with
6290: 74 68 65 20 63 6f 64 65 20 69 6e 20 6d 65 67 61 the code in mega
62a0: 74 65 73 74 2e 73 63 6d 20 66 6f 72 20 22 2d 65 test.scm for "-e
62b0: 78 65 63 75 74 65 22 0a 20 20 20 28 6c 69 73 74 xecute". (list
62c0: 20 3b 3b 20 28 6c 69 73 74 20 22 4d 54 5f 54 45 ;; (list "MT_TE
62d0: 53 54 5f 52 55 4e 5f 44 49 52 22 20 77 6f 72 6b ST_RUN_DIR" work
62e0: 2d 61 72 65 61 29 0a 20 20 20 20 28 6c 69 73 74 -area). (list
62f0: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
6300: 4d 45 22 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 ME" *toppath*).
6310: 20 20 20 28 6c 69 73 74 20 22 4d 54 5f 54 45 53 (list "MT_TES
6320: 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d T_NAME" test-nam
6330: 65 29 0a 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 e). ;; (list
6340: 22 4d 54 5f 49 54 45 4d 5f 49 4e 46 4f 22 20 28 "MT_ITEM_INFO" (
6350: 63 6f 6e 63 20 69 74 65 6d 64 61 74 29 29 20 0a conc itemdat)) .
6360: 20 20 20 20 28 6c 69 73 74 20 22 4d 54 5f 52 55 (list "MT_RU
6370: 4e 4e 41 4d 45 22 20 20 20 72 75 6e 6e 61 6d 65 NNAME" runname
6380: 29 0a 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 22 ). ;; (list "
6390: 4d 54 5f 54 41 52 47 45 54 22 20 20 20 20 6d 74 MT_TARGET" mt
63a0: 5f 74 61 72 67 65 74 29 0a 20 20 20 20 29 29 0a _target). )).
63b0: 20 20 28 6c 65 74 2a 20 28 28 75 73 65 73 68 65 (let* ((useshe
63c0: 6c 6c 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f ll (config-loo
63d0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
63e0: 22 6a 6f 62 74 6f 6f 6c 73 22 20 20 20 20 20 22 "jobtools" "
63f0: 75 73 65 73 68 65 6c 6c 22 29 29 0a 09 20 28 6c useshell")).. (l
6400: 61 75 6e 63 68 65 72 20 20 20 28 63 6f 6e 66 69 auncher (confi
6410: 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 g-lookup *config
6420: 64 61 74 2a 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 dat* "jobtools"
6430: 20 20 20 20 22 6c 61 75 6e 63 68 65 72 22 29 29 "launcher"))
6440: 0a 09 20 28 72 75 6e 73 63 72 69 70 74 20 20 28 .. (runscript (
6450: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 config-lookup te
6460: 73 74 2d 63 6f 6e 66 20 20 20 22 73 65 74 75 70 st-conf "setup
6470: 22 20 20 20 20 20 20 20 20 22 72 75 6e 73 63 72 " "runscr
6480: 69 70 74 22 29 29 0a 09 20 28 65 7a 73 74 65 70 ipt")).. (ezstep
6490: 73 20 20 20 20 28 3e 20 28 6c 65 6e 67 74 68 20 s (> (length
64a0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
64b0: 64 65 66 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e default test-con
64c0: 66 20 22 65 7a 73 74 65 70 73 22 20 27 28 29 29 f "ezsteps" '())
64d0: 29 20 30 29 29 20 3b 3b 20 64 6f 6e 27 74 20 73 ) 0)) ;; don't s
64e0: 65 6e 64 20 61 6c 6c 20 74 68 65 20 73 74 65 70 end all the step
64f0: 73 2c 20 63 6f 75 6c 64 20 62 65 20 62 69 67 0a s, could be big.
6500: 09 20 28 64 69 73 6b 73 70 61 63 65 20 20 28 63 . (diskspace (c
6510: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 onfig-lookup tes
6520: 74 2d 63 6f 6e 66 20 20 20 22 72 65 71 75 69 72 t-conf "requir
6530: 65 6d 65 6e 74 73 22 20 22 64 69 73 6b 73 70 61 ements" "diskspa
6540: 63 65 22 29 29 0a 09 20 28 6d 65 6d 6f 72 79 20 ce")).. (memory
6550: 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b (config-look
6560: 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 20 20 22 up test-conf "
6570: 72 65 71 75 69 72 65 6d 65 6e 74 73 22 20 22 6d requirements" "m
6580: 65 6d 6f 72 79 22 29 29 0a 09 20 28 68 6f 73 74 emory")).. (host
6590: 73 20 20 20 20 20 20 28 63 6f 6e 66 69 67 2d 6c s (config-l
65a0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
65b0: 2a 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 20 20 20 * "jobtools"
65c0: 20 22 77 6f 72 6b 68 6f 73 74 73 22 29 29 0a 09 "workhosts"))..
65d0: 20 28 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 (remote-megates
65e0: 74 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 t (config-lookup
65f0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
6600: 74 75 70 22 20 22 65 78 65 63 75 74 61 62 6c 65 tup" "executable
6610: 22 29 29 0a 09 20 3b 3b 20 46 49 58 4d 45 20 53 ")).. ;; FIXME S
6620: 4f 4d 45 44 41 59 3a 20 6e 6f 74 20 67 6f 6f 64 OMEDAY: not good
6630: 20 68 6f 77 20 74 68 69 73 20 69 73 20 73 6f 20 how this is so
6640: 6f 62 74 75 73 65 2c 20 74 68 69 73 20 68 61 63 obtuse, this hac
6650: 6b 20 69 73 20 74 6f 20 0a 09 20 3b 3b 20 20 20 k is to .. ;;
6660: 20 20 20 20 20 20 20 20 20 20 20 20 20 61 6c 6c all
6670: 6f 77 20 72 75 6e 6e 69 6e 67 20 66 72 6f 6d 20 ow running from
6680: 64 61 73 68 62 6f 61 72 64 2e 20 45 78 74 72 61 dashboard. Extra
6690: 63 74 20 74 68 65 20 70 61 74 68 0a 09 20 3b 3b ct the path.. ;;
66a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
66b0: 66 72 6f 6d 20 74 68 65 20 63 61 6c 6c 65 64 20 from the called
66c0: 6d 65 67 61 74 65 73 74 20 61 6e 64 20 63 6f 6e megatest and con
66d0: 76 65 72 74 20 64 61 73 68 62 6f 61 72 64 0a 09 vert dashboard..
66e0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
66f0: 09 20 20 6f 72 20 64 62 6f 61 72 64 20 74 6f 20 . or dboard to
6700: 6d 65 67 61 74 65 73 74 0a 09 20 28 6c 6f 63 61 megatest.. (loca
6710: 6c 2d 6d 65 67 61 74 65 73 74 20 20 28 6c 65 74 l-megatest (let
6720: 2a 20 28 28 6c 6d 20 20 28 63 61 72 20 28 61 72 * ((lm (car (ar
6730: 67 76 29 29 29 0a 09 09 09 09 20 28 64 69 72 20 gv)))..... (dir
6740: 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 (pathname-direct
6750: 6f 72 79 20 6c 6d 29 29 0a 09 09 09 09 20 28 65 ory lm))..... (e
6760: 78 65 20 28 70 61 74 68 6e 61 6d 65 2d 73 74 72 xe (pathname-str
6770: 69 70 2d 64 69 72 65 63 74 6f 72 79 20 6c 6d 29 ip-directory lm)
6780: 29 29 0a 09 09 09 20 20 20 20 28 63 6f 6e 63 20 )).... (conc
6790: 28 69 66 20 64 69 72 20 28 63 6f 6e 63 20 64 69 (if dir (conc di
67a0: 72 20 22 2f 22 29 20 22 22 29 0a 09 09 09 09 20 r "/") "").....
67b0: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
67c0: 73 79 6d 62 6f 6c 20 65 78 65 29 0a 09 09 09 09 symbol exe).....
67d0: 20 20 20 20 28 28 64 62 6f 61 72 64 29 20 20 20 ((dboard)
67e0: 20 22 6d 65 67 61 74 65 73 74 22 29 0a 09 09 09 "megatest")....
67f0: 09 20 20 20 20 28 28 6d 74 65 73 74 29 20 20 20 . ((mtest)
6800: 20 20 22 6d 65 67 61 74 65 73 74 22 29 0a 09 09 "megatest")...
6810: 09 09 20 20 20 20 28 28 64 61 73 68 62 6f 61 72 .. ((dashboar
6820: 64 29 20 22 6d 65 67 61 74 65 73 74 22 29 0a 09 d) "megatest")..
6830: 09 09 09 20 20 20 20 28 65 6c 73 65 20 65 78 65 ... (else exe
6840: 29 29 29 29 29 0a 09 20 28 74 65 73 74 2d 73 69 ))))).. (test-si
6850: 67 20 20 20 28 63 6f 6e 63 20 74 65 73 74 2d 6e g (conc test-n
6860: 61 6d 65 20 22 3a 22 20 28 69 74 65 6d 2d 6c 69 ame ":" (item-li
6870: 73 74 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 st->path itemdat
6880: 29 29 29 20 3b 3b 20 74 65 73 74 2d 70 61 74 68 ))) ;; test-path
6890: 20 69 73 20 74 68 65 20 66 75 6c 6c 20 70 61 74 is the full pat
68a0: 68 20 69 6e 63 6c 75 64 69 6e 67 20 74 68 65 20 h including the
68b0: 69 74 65 6d 2d 70 61 74 68 0a 09 20 28 77 6f 72 item-path.. (wor
68c0: 6b 2d 61 72 65 61 20 20 23 66 29 0a 09 20 28 74 k-area #f).. (t
68d0: 6f 70 74 65 73 74 2d 77 6f 72 6b 2d 61 72 65 61 optest-work-area
68e0: 20 23 66 29 20 3b 3b 20 66 6f 72 20 69 74 65 72 #f) ;; for iter
68f0: 61 74 65 64 20 74 65 73 74 73 20 74 68 65 20 74 ated tests the t
6900: 6f 70 20 74 65 73 74 20 63 6f 6e 74 61 69 6e 73 op test contains
6910: 20 64 61 74 61 20 72 65 6c 65 76 61 6e 74 20 66 data relevant f
6920: 6f 72 20 61 6c 6c 0a 09 20 28 64 69 73 6b 70 61 or all.. (diskpa
6930: 74 68 20 20 20 23 66 29 0a 09 20 28 63 6d 64 70 th #f).. (cmdp
6940: 61 72 6d 73 20 20 20 23 66 29 0a 09 20 28 66 75 arms #f).. (fu
6950: 6c 6c 63 6d 64 20 20 20 20 23 66 29 20 3b 3b 20 llcmd #f) ;;
6960: 28 64 65 66 69 6e 65 20 61 20 28 77 69 74 68 2d (define a (with-
6970: 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 output-to-string
6980: 20 28 6c 61 6d 62 64 61 20 28 29 28 77 72 69 74 (lambda ()(writ
6990: 65 20 78 29 29 29 29 0a 09 20 28 6d 74 2d 62 69 e x)))).. (mt-bi
69a0: 6e 64 69 72 2d 70 61 74 68 20 23 66 29 0a 09 20 ndir-path #f)..
69b0: 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 65 6d (item-path (item
69c0: 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 65 6d -list->path item
69d0: 64 61 74 29 29 0a 09 20 3b 3b 20 28 74 65 73 74 dat)).. ;; (test
69e0: 2d 69 64 20 20 20 20 28 63 64 62 3a 72 65 6d 6f -id (cdb:remo
69f0: 74 65 2d 72 75 6e 20 64 62 3a 67 65 74 2d 74 65 te-run db:get-te
6a00: 73 74 2d 69 64 20 23 66 20 72 75 6e 2d 69 64 20 st-id #f run-id
6a10: 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 6d 2d 70 test-name item-p
6a20: 61 74 68 29 29 0a 09 20 28 74 65 73 74 69 6e 66 ath)).. (testinf
6a30: 6f 20 20 20 28 63 64 62 3a 67 65 74 2d 74 65 73 o (cdb:get-tes
6a40: 74 2d 69 6e 66 6f 2d 62 79 2d 69 64 20 2a 72 75 t-info-by-id *ru
6a50: 6e 72 65 6d 6f 74 65 2a 20 74 65 73 74 2d 69 64 nremote* test-id
6a60: 29 29 0a 09 20 28 6d 74 5f 74 61 72 67 65 74 20 )).. (mt_target
6a70: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
6a80: 65 72 73 65 20 28 6d 61 70 20 63 61 64 72 20 6b erse (map cadr k
6a90: 65 79 76 61 6c 73 29 20 22 2f 22 29 29 0a 09 20 eyvals) "/"))..
6aa0: 28 64 65 62 75 67 2d 70 61 72 61 6d 20 28 61 70 (debug-param (ap
6ab0: 70 65 6e 64 20 28 69 66 20 28 61 72 67 73 3a 67 pend (if (args:g
6ac0: 65 74 2d 61 72 67 20 22 2d 64 65 62 75 67 22 29 et-arg "-debug")
6ad0: 20 20 28 6c 69 73 74 20 22 2d 64 65 62 75 67 22 (list "-debug"
6ae0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
6af0: 2d 64 65 62 75 67 22 29 29 20 27 28 29 29 0a 09 -debug")) '())..
6b00: 09 09 20 20 20 20 20 20 28 69 66 20 28 61 72 67 .. (if (arg
6b10: 73 3a 67 65 74 2d 61 72 67 20 22 2d 6c 6f 67 67 s:get-arg "-logg
6b20: 69 6e 67 22 29 28 6c 69 73 74 20 22 2d 6c 6f 67 ing")(list "-log
6b30: 67 69 6e 67 22 29 20 27 28 29 29 29 29 29 0a 20 ging") '())))).
6b40: 20 20 20 28 69 66 20 68 6f 73 74 73 20 28 73 65 (if hosts (se
6b50: 74 21 20 68 6f 73 74 73 20 28 73 74 72 69 6e 67 t! hosts (string
6b60: 2d 73 70 6c 69 74 20 68 6f 73 74 73 29 29 29 0a -split hosts))).
6b70: 20 20 20 20 3b 3b 20 73 65 74 20 74 68 65 20 6d ;; set the m
6b80: 65 67 61 74 65 73 74 20 74 6f 20 62 65 20 63 61 egatest to be ca
6b90: 6c 6c 65 64 20 6f 6e 20 74 68 65 20 72 65 6d 6f lled on the remo
6ba0: 74 65 20 68 6f 73 74 0a 20 20 20 20 28 69 66 20 te host. (if
6bb0: 28 6e 6f 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 (not remote-mega
6bc0: 74 65 73 74 29 28 73 65 74 21 20 72 65 6d 6f 74 test)(set! remot
6bd0: 65 2d 6d 65 67 61 74 65 73 74 20 6c 6f 63 61 6c e-megatest local
6be0: 2d 6d 65 67 61 74 65 73 74 29 29 20 3b 3b 20 22 -megatest)) ;; "
6bf0: 6d 65 67 61 74 65 73 74 22 29 29 0a 20 20 20 20 megatest")).
6c00: 28 73 65 74 21 20 6d 74 2d 62 69 6e 64 69 72 2d (set! mt-bindir-
6c10: 70 61 74 68 20 28 70 61 74 68 6e 61 6d 65 2d 64 path (pathname-d
6c20: 69 72 65 63 74 6f 72 79 20 72 65 6d 6f 74 65 2d irectory remote-
6c30: 6d 65 67 61 74 65 73 74 29 29 0a 20 20 20 20 28 megatest)). (
6c40: 69 66 20 6c 61 75 6e 63 68 65 72 20 28 73 65 74 if launcher (set
6c50: 21 20 6c 61 75 6e 63 68 65 72 20 28 73 74 72 69 ! launcher (stri
6c60: 6e 67 2d 73 70 6c 69 74 20 6c 61 75 6e 63 68 65 ng-split launche
6c70: 72 29 29 29 0a 20 20 20 20 3b 3b 20 73 65 74 20 r))). ;; set
6c80: 75 70 20 74 68 65 20 72 75 6e 20 77 6f 72 6b 20 up the run work
6c90: 61 72 65 61 20 66 6f 72 20 74 68 69 73 20 74 65 area for this te
6ca0: 73 74 0a 20 20 20 20 28 73 65 74 21 20 64 69 73 st. (set! dis
6cb0: 6b 70 61 74 68 20 28 67 65 74 2d 62 65 73 74 2d kpath (get-best-
6cc0: 64 69 73 6b 20 2a 63 6f 6e 66 69 67 64 61 74 2a disk *configdat*
6cd0: 29 29 0a 20 20 20 20 28 69 66 20 64 69 73 6b 70 )). (if diskp
6ce0: 61 74 68 0a 09 28 6c 65 74 20 28 28 64 61 74 20 ath..(let ((dat
6cf0: 20 28 63 72 65 61 74 65 2d 77 6f 72 6b 2d 61 72 (create-work-ar
6d00: 65 61 20 72 75 6e 2d 69 64 20 72 75 6e 2d 69 6e ea run-id run-in
6d10: 66 6f 20 6b 65 79 76 61 6c 73 20 74 65 73 74 2d fo keyvals test-
6d20: 69 64 20 74 65 73 74 2d 70 61 74 68 20 64 69 73 id test-path dis
6d30: 6b 70 61 74 68 20 74 65 73 74 2d 6e 61 6d 65 20 kpath test-name
6d40: 69 74 65 6d 64 61 74 29 29 29 0a 09 20 20 28 73 itemdat))).. (s
6d50: 65 74 21 20 77 6f 72 6b 2d 61 72 65 61 20 28 63 et! work-area (c
6d60: 61 72 20 64 61 74 29 29 0a 09 20 20 28 73 65 74 ar dat)).. (set
6d70: 21 20 74 6f 70 74 65 73 74 2d 77 6f 72 6b 2d 61 ! toptest-work-a
6d80: 72 65 61 20 28 63 61 64 72 20 64 61 74 29 29 0a rea (cadr dat)).
6d90: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
6da0: 69 6e 66 6f 20 32 20 22 55 73 69 6e 67 20 77 6f info 2 "Using wo
6db0: 72 6b 20 61 72 65 61 20 22 20 77 6f 72 6b 2d 61 rk area " work-a
6dc0: 72 65 61 29 29 0a 09 28 62 65 67 69 6e 0a 09 20 rea))..(begin..
6dd0: 20 28 73 65 74 21 20 77 6f 72 6b 2d 61 72 65 61 (set! work-area
6de0: 20 28 63 6f 6e 63 20 74 65 73 74 2d 70 61 74 68 (conc test-path
6df0: 20 22 2f 74 6d 70 5f 72 75 6e 22 29 29 0a 09 20 "/tmp_run"))..
6e00: 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f (create-directo
6e10: 72 79 20 77 6f 72 6b 2d 61 72 65 61 20 23 74 29 ry work-area #t)
6e20: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
6e30: 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 4e 6f 20 0 "WARNING: No
6e40: 64 69 73 6b 20 77 6f 72 6b 20 61 72 65 61 20 73 disk work area s
6e50: 70 65 63 69 66 69 65 64 20 2d 20 72 75 6e 6e 69 pecified - runni
6e60: 6e 67 20 69 6e 20 74 68 65 20 74 65 73 74 20 64 ng in the test d
6e70: 69 72 65 63 74 6f 72 79 20 75 6e 64 65 72 20 74 irectory under t
6e80: 6d 70 5f 72 75 6e 22 29 29 29 0a 20 20 20 20 28 mp_run"))). (
6e90: 73 65 74 21 20 63 6d 64 70 61 72 6d 73 20 28 62 set! cmdparms (b
6ea0: 61 73 65 36 34 3a 62 61 73 65 36 34 2d 65 6e 63 ase64:base64-enc
6eb0: 6f 64 65 20 0a 09 09 20 20 20 20 28 77 69 74 68 ode ... (with
6ec0: 2d 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e -output-to-strin
6ed0: 67 0a 09 09 20 20 20 20 20 20 28 6c 61 6d 62 64 g... (lambd
6ee0: 61 20 28 29 20 3b 3b 20 28 6c 69 73 74 20 27 68 a () ;; (list 'h
6ef0: 6f 73 74 73 20 20 20 20 20 68 6f 73 74 73 29 0a osts hosts).
6f00: 09 09 09 28 77 72 69 74 65 20 28 6c 69 73 74 20 ...(write (list
6f10: 28 6c 69 73 74 20 27 74 65 73 74 70 61 74 68 20 (list 'testpath
6f20: 20 74 65 73 74 2d 70 61 74 68 29 0a 09 09 09 09 test-path).....
6f30: 20 20 20 20 20 3b 3b 20 28 6c 69 73 74 20 27 72 ;; (list 'r
6f40: 75 6e 72 65 6d 6f 74 65 20 2a 72 75 6e 72 65 6d unremote *runrem
6f50: 6f 74 65 2a 29 0a 09 09 09 09 20 20 20 20 20 28 ote*)..... (
6f60: 6c 69 73 74 20 27 74 72 61 6e 73 70 6f 72 74 20 list 'transport
6f70: 28 63 6f 6e 63 20 2a 74 72 61 6e 73 70 6f 72 74 (conc *transport
6f80: 2d 74 79 70 65 2a 29 29 0a 09 09 09 09 20 20 20 -type*)).....
6f90: 20 20 28 6c 69 73 74 20 27 73 65 72 76 65 72 69 (list 'serveri
6fa0: 6e 66 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a nf *server-info*
6fb0: 29 0a 09 09 09 09 20 20 20 20 20 28 6c 69 73 74 )..... (list
6fc0: 20 27 74 6f 70 70 61 74 68 20 20 20 2a 74 6f 70 'toppath *top
6fd0: 70 61 74 68 2a 29 0a 09 09 09 09 20 20 20 20 20 path*).....
6fe0: 28 6c 69 73 74 20 27 77 6f 72 6b 2d 61 72 65 61 (list 'work-area
6ff0: 20 77 6f 72 6b 2d 61 72 65 61 29 0a 09 09 09 09 work-area).....
7000: 20 20 20 20 20 28 6c 69 73 74 20 27 74 65 73 74 (list 'test
7010: 2d 6e 61 6d 65 20 74 65 73 74 2d 6e 61 6d 65 29 -name test-name)
7020: 20 0a 09 09 09 09 20 20 20 20 20 28 6c 69 73 74 ..... (list
7030: 20 27 72 75 6e 73 63 72 69 70 74 20 72 75 6e 73 'runscript runs
7040: 63 72 69 70 74 29 20 0a 09 09 09 09 20 20 20 20 cript) .....
7050: 20 28 6c 69 73 74 20 27 72 75 6e 2d 69 64 20 20 (list 'run-id
7060: 20 20 72 75 6e 2d 69 64 20 20 20 29 0a 09 09 09 run-id )....
7070: 09 20 20 20 20 20 28 6c 69 73 74 20 27 74 65 73 . (list 'tes
7080: 74 2d 69 64 20 20 20 74 65 73 74 2d 69 64 20 20 t-id test-id
7090: 29 0a 09 09 09 09 20 20 20 20 20 28 6c 69 73 74 )..... (list
70a0: 20 27 69 74 65 6d 64 61 74 20 20 20 69 74 65 6d 'itemdat item
70b0: 64 61 74 20 20 29 0a 09 09 09 09 20 20 20 20 20 dat ).....
70c0: 28 6c 69 73 74 20 27 6d 65 67 61 74 65 73 74 20 (list 'megatest
70d0: 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 remote-megatest
70e0: 29 0a 09 09 09 09 20 20 20 20 20 28 6c 69 73 74 )..... (list
70f0: 20 27 65 7a 73 74 65 70 73 20 20 20 65 7a 73 74 'ezsteps ezst
7100: 65 70 73 29 20 0a 09 09 09 09 20 20 20 20 20 28 eps) ..... (
7110: 6c 69 73 74 20 27 74 61 72 67 65 74 20 20 20 20 list 'target
7120: 6d 74 5f 74 61 72 67 65 74 29 0a 09 09 09 09 20 mt_target).....
7130: 20 20 20 20 28 6c 69 73 74 20 27 65 6e 76 2d 6f (list 'env-o
7140: 76 72 64 20 20 28 68 61 73 68 2d 74 61 62 6c 65 vrd (hash-table
7150: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f -ref/default *co
7160: 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d 6f 76 nfigdat* "env-ov
7170: 65 72 72 69 64 65 22 20 27 28 29 29 29 20 0a 09 erride" '())) ..
7180: 09 09 09 20 20 20 20 20 28 6c 69 73 74 20 27 73 ... (list 's
7190: 65 74 2d 76 61 72 73 20 20 28 69 66 20 70 61 72 et-vars (if par
71a0: 61 6d 73 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ams (hash-table-
71b0: 72 65 66 2f 64 65 66 61 75 6c 74 20 70 61 72 61 ref/default para
71c0: 6d 73 20 22 2d 73 65 74 76 61 72 73 22 20 23 66 ms "-setvars" #f
71d0: 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 6c 69 )))..... (li
71e0: 73 74 20 27 72 75 6e 6e 61 6d 65 20 20 20 72 75 st 'runname ru
71f0: 6e 6e 61 6d 65 29 0a 09 09 09 09 20 20 20 20 20 nname).....
7200: 28 6c 69 73 74 20 27 6d 74 2d 62 69 6e 64 69 72 (list 'mt-bindir
7210: 2d 70 61 74 68 20 6d 74 2d 62 69 6e 64 69 72 2d -path mt-bindir-
7220: 70 61 74 68 29 29 29 29 29 29 29 0a 20 20 20 20 path))))))).
7230: 3b 3b 20 63 6c 65 61 6e 20 6f 75 74 20 73 74 65 ;; clean out ste
7240: 70 20 72 65 63 6f 72 64 73 20 66 72 6f 6d 20 70 p records from p
7250: 72 65 76 69 6f 75 73 20 72 75 6e 20 69 66 20 74 revious run if t
7260: 68 65 79 20 65 78 69 73 74 0a 20 20 20 20 3b 3b hey exist. ;;
7270: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
7280: 66 6f 20 34 20 22 46 49 58 4d 45 45 45 45 45 21 fo 4 "FIXMEEEEE!
7290: 21 21 21 20 54 68 69 73 20 63 61 6e 20 62 65 20 !!! This can be
72a0: 72 65 6d 6f 76 65 64 20 73 6f 6d 65 20 64 61 79 removed some day
72b0: 2c 20 70 65 72 68 61 70 73 20 6d 6f 76 65 20 61 , perhaps move a
72c0: 6c 6c 20 74 65 73 74 20 72 65 63 6f 72 64 73 20 ll test records
72d0: 74 6f 20 74 68 65 20 74 65 73 74 20 64 62 3f 22 to the test db?"
72e0: 29 0a 20 20 20 20 3b 3b 20 28 6f 70 65 6e 2d 72 ). ;; (open-r
72f0: 75 6e 2d 63 6c 6f 73 65 20 64 62 3a 64 65 6c 65 un-close db:dele
7300: 74 65 2d 74 65 73 74 2d 73 74 65 70 2d 72 65 63 te-test-step-rec
7310: 6f 72 64 73 20 64 62 20 74 65 73 74 2d 69 64 29 ords db test-id)
7320: 0a 20 20 20 20 28 63 68 61 6e 67 65 2d 64 69 72 . (change-dir
7330: 65 63 74 6f 72 79 20 77 6f 72 6b 2d 61 72 65 61 ectory work-area
7340: 29 20 3b 3b 20 73 6f 20 74 68 61 74 20 6c 6f 67 ) ;; so that log
7350: 20 66 69 6c 65 73 20 66 72 6f 6d 20 74 68 65 20 files from the
7360: 6c 61 75 6e 63 68 20 70 72 6f 63 65 73 73 20 64 launch process d
7370: 6f 6e 27 74 20 63 6c 75 74 74 65 72 20 74 68 65 on't clutter the
7380: 20 74 65 73 74 20 64 69 72 0a 20 20 20 20 28 74 test dir. (t
7390: 65 73 74 73 3a 74 65 73 74 2d 73 65 74 2d 73 74 ests:test-set-st
73a0: 61 74 75 73 21 20 74 65 73 74 2d 69 64 20 22 4c atus! test-id "L
73b0: 41 55 4e 43 48 45 44 22 20 22 6e 2f 61 22 20 23 AUNCHED" "n/a" #
73c0: 66 20 23 66 29 20 3b 3b 20 28 69 66 20 6c 61 75 f #f) ;; (if lau
73d0: 6e 63 68 2d 72 65 73 75 6c 74 73 20 6c 61 75 6e nch-results laun
73e0: 63 68 2d 72 65 73 75 6c 74 73 20 22 46 41 49 4c ch-results "FAIL
73f0: 45 44 22 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a ED")). (cond.
7400: 20 20 20 20 20 28 28 61 6e 64 20 6c 61 75 6e 63 ((and launc
7410: 68 65 72 20 68 6f 73 74 73 29 20 3b 3b 20 6d 75 her hosts) ;; mu
7420: 73 74 20 62 65 20 75 73 69 6e 67 20 73 73 68 20 st be using ssh
7430: 68 6f 73 74 6e 61 6d 65 0a 20 20 20 20 20 20 28 hostname. (
7440: 73 65 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 set! fullcmd (ap
7450: 70 65 6e 64 20 6c 61 75 6e 63 68 65 72 20 28 63 pend launcher (c
7460: 61 72 20 68 6f 73 74 73 29 28 6c 69 73 74 20 72 ar hosts)(list r
7470: 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 74 emote-megatest t
7480: 65 73 74 2d 73 69 67 20 22 2d 65 78 65 63 75 74 est-sig "-execut
7490: 65 22 20 63 6d 64 70 61 72 6d 73 29 20 64 65 62 e" cmdparms) deb
74a0: 75 67 2d 70 61 72 61 6d 29 29 29 0a 20 20 20 20 ug-param))).
74b0: 20 3b 3b 20 28 73 65 74 21 20 66 75 6c 6c 63 6d ;; (set! fullcm
74c0: 64 20 28 61 70 70 65 6e 64 20 6c 61 75 6e 63 68 d (append launch
74d0: 65 72 20 28 63 61 72 20 68 6f 73 74 73 29 28 6c er (car hosts)(l
74e0: 69 73 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 74 ist remote-megat
74f0: 65 73 74 20 74 65 73 74 2d 73 69 67 20 22 2d 65 est test-sig "-e
7500: 78 65 63 75 74 65 22 20 63 6d 64 70 61 72 6d 73 xecute" cmdparms
7510: 29 29 29 29 0a 20 20 20 20 20 28 6c 61 75 6e 63 )))). (launc
7520: 68 65 72 0a 20 20 20 20 20 20 28 73 65 74 21 20 her. (set!
7530: 66 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 fullcmd (append
7540: 6c 61 75 6e 63 68 65 72 20 28 6c 69 73 74 20 72 launcher (list r
7550: 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 74 emote-megatest t
7560: 65 73 74 2d 73 69 67 20 22 2d 65 78 65 63 75 74 est-sig "-execut
7570: 65 22 20 63 6d 64 70 61 72 6d 73 29 20 64 65 62 e" cmdparms) deb
7580: 75 67 2d 70 61 72 61 6d 29 29 29 0a 20 20 20 20 ug-param))).
7590: 20 3b 3b 20 28 73 65 74 21 20 66 75 6c 6c 63 6d ;; (set! fullcm
75a0: 64 20 28 61 70 70 65 6e 64 20 6c 61 75 6e 63 68 d (append launch
75b0: 65 72 20 28 6c 69 73 74 20 72 65 6d 6f 74 65 2d er (list remote-
75c0: 6d 65 67 61 74 65 73 74 20 74 65 73 74 2d 73 69 megatest test-si
75d0: 67 20 22 2d 65 78 65 63 75 74 65 22 20 63 6d 64 g "-execute" cmd
75e0: 70 61 72 6d 73 29 29 29 29 0a 20 20 20 20 20 28 parms)))). (
75f0: 65 6c 73 65 0a 20 20 20 20 20 20 28 69 66 20 28 else. (if (
7600: 6e 6f 74 20 75 73 65 73 68 65 6c 6c 29 28 64 65 not useshell)(de
7610: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR
7620: 4e 49 4e 47 3a 20 69 6e 74 65 72 6e 61 6c 20 6c NING: internal l
7630: 61 75 6e 63 68 69 6e 67 20 77 69 6c 6c 20 6e 6f aunching will no
7640: 74 20 77 6f 72 6b 20 77 65 6c 6c 20 77 69 74 68 t work well with
7650: 6f 75 74 20 5c 22 75 73 65 73 68 65 6c 6c 20 79 out \"useshell y
7660: 65 73 5c 22 20 69 6e 20 79 6f 75 72 20 5b 6a 6f es\" in your [jo
7670: 62 74 6f 6f 6c 73 5d 20 73 65 63 74 69 6f 6e 22 btools] section"
7680: 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 20 66 )). (set! f
7690: 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 28 ullcmd (append (
76a0: 6c 69 73 74 20 72 65 6d 6f 74 65 2d 6d 65 67 61 list remote-mega
76b0: 74 65 73 74 20 74 65 73 74 2d 73 69 67 20 22 2d test test-sig "-
76c0: 65 78 65 63 75 74 65 22 20 63 6d 64 70 61 72 6d execute" cmdparm
76d0: 73 29 20 64 65 62 75 67 2d 70 61 72 61 6d 20 28 s) debug-param (
76e0: 6c 69 73 74 20 28 69 66 20 75 73 65 73 68 65 6c list (if useshel
76f0: 6c 20 22 26 22 20 22 22 29 29 29 29 29 29 0a 20 l "&" "")))))).
7700: 20 20 20 3b 3b 20 28 73 65 74 21 20 66 75 6c 6c ;; (set! full
7710: 63 6d 64 20 28 6c 69 73 74 20 72 65 6d 6f 74 65 cmd (list remote
7720: 2d 6d 65 67 61 74 65 73 74 20 74 65 73 74 2d 73 -megatest test-s
7730: 69 67 20 22 2d 65 78 65 63 75 74 65 22 20 63 6d ig "-execute" cm
7740: 64 70 61 72 6d 73 20 28 69 66 20 75 73 65 73 68 dparms (if usesh
7750: 65 6c 6c 20 22 26 22 20 22 22 29 29 29 29 29 0a ell "&" ""))))).
7760: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
7770: 74 2d 61 72 67 20 22 2d 78 74 65 72 6d 22 29 28 t-arg "-xterm")(
7780: 73 65 74 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 set! fullcmd (ap
7790: 70 65 6e 64 20 66 75 6c 6c 63 6d 64 20 28 6c 69 pend fullcmd (li
77a0: 73 74 20 22 2d 78 74 65 72 6d 22 29 29 29 29 0a st "-xterm")))).
77b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
77c0: 20 31 20 22 4c 61 75 6e 63 68 69 6e 67 20 22 20 1 "Launching "
77d0: 77 6f 72 6b 2d 61 72 65 61 29 0a 20 20 20 20 3b work-area). ;
77e0: 3b 20 73 65 74 20 70 72 65 2d 6c 61 75 6e 63 68 ; set pre-launch
77f0: 2d 65 6e 76 2d 76 61 72 73 20 62 65 66 6f 72 65 -env-vars before
7800: 20 6c 61 75 6e 63 68 69 6e 67 2c 20 6b 65 65 70 launching, keep
7810: 20 74 68 65 20 76 61 72 73 20 69 6e 20 70 72 65 the vars in pre
7820: 76 76 61 6c 73 20 61 6e 64 20 70 75 74 20 74 68 vvals and put th
7830: 65 20 65 6e 76 69 6f 6e 6d 65 6e 74 20 62 61 63 e envionment bac
7840: 6b 20 77 68 65 6e 20 64 6f 6e 65 0a 20 20 20 20 k when done.
7850: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 22 (debug:print 4 "
7860: 66 75 6c 6c 63 6d 64 3a 20 22 20 66 75 6c 6c 63 fullcmd: " fullc
7870: 6d 64 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 md). (let* ((
7880: 63 6f 6d 6d 6f 6e 70 72 65 76 76 61 6c 73 20 28 commonprevvals (
7890: 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 0a alist->env-vars.
78a0: 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
78b0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
78c0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e 76 2d configdat* "env-
78d0: 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 29 29 override" '())))
78e0: 0a 09 20 20 20 28 74 65 73 74 70 72 65 76 76 61 .. (testprevva
78f0: 6c 73 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 ls (alist->env
7900: 2d 76 61 72 73 0a 09 09 09 20 20 20 20 28 68 61 -vars.... (ha
7910: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
7920: 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e 66 20 22 ault test-conf "
7930: 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 2d 6f pre-launch-env-o
7940: 76 65 72 72 69 64 65 73 22 20 27 28 29 29 29 29 verrides" '())))
7950: 0a 09 20 20 20 28 6d 69 73 63 70 72 65 76 76 61 .. (miscprevva
7960: 6c 73 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 ls (alist->env
7970: 2d 76 61 72 73 20 3b 3b 20 63 6f 6e 73 6f 6c 69 -vars ;; consoli
7980: 64 61 74 65 20 74 68 69 73 20 63 6f 64 65 20 77 date this code w
7990: 69 74 68 20 74 68 65 20 63 6f 64 65 20 69 6e 20 ith the code in
79a0: 6d 65 67 61 74 65 73 74 2e 73 63 6d 20 66 6f 72 megatest.scm for
79b0: 20 22 2d 65 78 65 63 75 74 65 22 0a 09 09 09 20 "-execute"....
79c0: 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 (append (list
79d0: 20 28 6c 69 73 74 20 22 4d 54 5f 54 45 53 54 5f (list "MT_TEST_
79e0: 52 55 4e 5f 44 49 52 22 20 77 6f 72 6b 2d 61 72 RUN_DIR" work-ar
79f0: 65 61 29 0a 09 09 09 09 09 20 20 28 6c 69 73 74 ea)...... (list
7a00: 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 "MT_TEST_NAME"
7a10: 74 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 09 test-name)......
7a20: 20 20 28 6c 69 73 74 20 22 4d 54 5f 49 54 45 4d (list "MT_ITEM
7a30: 5f 49 4e 46 4f 22 20 28 63 6f 6e 63 20 69 74 65 _INFO" (conc ite
7a40: 6d 64 61 74 29 29 20 0a 09 09 09 09 09 20 20 28 mdat)) ...... (
7a50: 6c 69 73 74 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 list "MT_RUNNAME
7a60: 22 20 20 20 72 75 6e 6e 61 6d 65 29 0a 09 09 09 " runname)....
7a70: 09 09 20 20 28 6c 69 73 74 20 22 4d 54 5f 54 41 .. (list "MT_TA
7a80: 52 47 45 54 22 20 20 20 20 6d 74 5f 74 61 72 67 RGET" mt_targ
7a90: 65 74 29 0a 09 09 09 09 09 20 20 29 0a 09 09 09 et)...... )....
7aa0: 09 20 20 20 20 69 74 65 6d 64 61 74 29 29 29 0a . itemdat))).
7ab0: 09 20 20 20 28 6c 61 75 6e 63 68 2d 72 65 73 75 . (launch-resu
7ac0: 6c 74 73 20 28 61 70 70 6c 79 20 28 69 66 20 28 lts (apply (if (
7ad0: 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a equal? (configf:
7ae0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
7af0: 74 2a 20 22 73 65 74 75 70 22 20 22 6c 61 75 6e t* "setup" "laun
7b00: 63 68 77 61 69 74 22 29 20 22 79 65 73 22 29 0a chwait") "yes").
7b10: 09 09 09 09 20 20 20 20 20 20 63 6d 64 2d 72 75 .... cmd-ru
7b20: 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 2d 3e 6c n-with-stderr->l
7b30: 69 73 74 0a 09 09 09 09 20 20 20 20 20 20 70 72 ist..... pr
7b40: 6f 63 65 73 73 2d 72 75 6e 29 0a 09 09 09 09 20 ocess-run).....
7b50: 20 28 69 66 20 75 73 65 73 68 65 6c 6c 0a 09 09 (if useshell...
7b60: 09 09 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d .. (string-
7b70: 69 6e 74 65 72 73 70 65 72 73 65 20 66 75 6c 6c intersperse full
7b80: 63 6d 64 20 22 20 22 29 0a 09 09 09 09 20 20 20 cmd " ").....
7b90: 20 20 20 28 63 61 72 20 66 75 6c 6c 63 6d 64 29 (car fullcmd)
7ba0: 29 0a 09 09 09 09 20 20 28 69 66 20 75 73 65 73 )..... (if uses
7bb0: 68 65 6c 6c 0a 09 09 09 09 20 20 20 20 20 20 27 hell..... '
7bc0: 28 29 0a 09 09 09 09 20 20 20 20 20 20 28 63 64 ()..... (cd
7bd0: 72 20 66 75 6c 6c 63 6d 64 29 29 29 29 29 0a 20 r fullcmd))))).
7be0: 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
7bf0: 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 29 0a launch-results).
7c00: 09 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
7c10: 74 6f 2d 66 69 6c 65 20 22 6d 74 5f 6c 61 75 6e to-file "mt_laun
7c20: 63 68 2e 6c 6f 67 22 0a 09 20 20 20 20 28 6c 61 ch.log".. (la
7c30: 6d 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 mbda ().. (
7c40: 61 70 70 6c 79 20 70 72 69 6e 74 20 6c 61 75 6e apply print laun
7c50: 63 68 2d 72 65 73 75 6c 74 73 29 29 0a 09 20 20 ch-results))..
7c60: 20 20 23 3a 61 70 70 65 6e 64 29 29 0a 20 20 20 #:append)).
7c70: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
7c80: 32 20 22 4c 61 75 6e 63 68 69 6e 67 20 63 6f 6d 2 "Launching com
7c90: 70 6c 65 74 65 64 2c 20 75 70 64 61 74 69 6e 67 pleted, updating
7ca0: 20 64 62 22 29 0a 20 20 20 20 20 20 28 64 65 62 db"). (deb
7cb0: 75 67 3a 70 72 69 6e 74 20 32 20 22 4c 61 75 6e ug:print 2 "Laun
7cc0: 63 68 20 72 65 73 75 6c 74 73 3a 20 22 20 6c 61 ch results: " la
7cd0: 75 6e 63 68 2d 72 65 73 75 6c 74 73 29 0a 20 20 unch-results).
7ce0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 6c 61 75 (if (not lau
7cf0: 6e 63 68 2d 72 65 73 75 6c 74 73 29 0a 20 20 20 nch-results).
7d00: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
7d10: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
7d20: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed
7d30: 74 6f 20 72 75 6e 20 22 20 28 73 74 72 69 6e 67 to run " (string
7d40: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 66 75 6c -intersperse ful
7d50: 6c 63 6d 64 20 22 20 22 29 20 22 2c 20 65 78 69 lcmd " ") ", exi
7d60: 74 69 6e 67 20 6e 6f 77 22 29 0a 20 20 20 20 20 ting now").
7d70: 20 20 20 20 20 20 20 3b 3b 20 28 73 71 6c 69 74 ;; (sqlit
7d80: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 e3:finalize! db)
7d90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 . ;;
7da0: 67 6f 6f 64 20 6f 6c 65 20 22 65 78 69 74 22 20 good ole "exit"
7db0: 73 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 seems not to wor
7dc0: 6b 0a 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b k. ;;
7dd0: 20 28 5f 65 78 69 74 20 39 29 0a 20 20 20 20 20 (_exit 9).
7de0: 20 20 20 20 20 20 20 3b 3b 20 62 75 74 20 74 68 ;; but th
7df0: 69 73 20 68 61 63 6b 20 77 69 6c 6c 20 77 6f 72 is hack will wor
7e00: 6b 21 20 54 68 61 6e 6b 73 20 67 6f 20 74 6f 20 k! Thanks go to
7e10: 41 6c 61 6e 20 50 6f 73 74 20 6f 66 20 74 68 65 Alan Post of the
7e20: 20 43 68 69 63 6b 65 6e 20 65 6d 61 69 6c 20 6c Chicken email l
7e30: 69 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 ist.
7e40: 3b 3b 20 4e 42 2f 2f 20 49 73 20 74 68 69 73 20 ;; NB// Is this
7e50: 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 20 53 68 still needed? Sh
7e60: 6f 75 6c 64 20 62 65 20 73 61 66 65 20 74 6f 20 ould be safe to
7e70: 67 6f 20 62 61 63 6b 20 74 6f 20 22 65 78 69 74 go back to "exit
7e80: 22 20 6e 6f 77 3f 0a 20 20 20 20 20 20 20 20 20 " now?.
7e90: 20 20 20 28 70 72 6f 63 65 73 73 2d 73 69 67 6e (process-sign
7ea0: 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 al (current-proc
7eb0: 65 73 73 2d 69 64 29 20 73 69 67 6e 61 6c 2f 6b ess-id) signal/k
7ec0: 69 6c 6c 29 0a 20 20 20 20 20 20 20 20 20 20 20 ill).
7ed0: 20 29 29 0a 20 20 20 20 20 20 28 61 6c 69 73 74 )). (alist
7ee0: 2d 3e 65 6e 76 2d 76 61 72 73 20 6d 69 73 63 70 ->env-vars miscp
7ef0: 72 65 76 76 61 6c 73 29 0a 20 20 20 20 20 20 28 revvals). (
7f00: 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 alist->env-vars
7f10: 74 65 73 74 70 72 65 76 76 61 6c 73 29 0a 20 20 testprevvals).
7f20: 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d (alist->env-
7f30: 76 61 72 73 20 63 6f 6d 6d 6f 6e 70 72 65 76 76 vars commonprevv
7f40: 61 6c 73 29 0a 20 20 20 20 20 20 6c 61 75 6e 63 als). launc
7f50: 68 2d 72 65 73 75 6c 74 73 29 29 0a 20 20 28 63 h-results)). (c
7f60: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory
7f70: 2a 74 6f 70 70 61 74 68 2a 29 29 0a 0a *toppath*))..