Artifact 4811d14f2de3d039a4879ee8c26a1f0eecbd3225:
- File launch.scm — part of check-in [3469edbbf7] at 2011-10-08 20:23:24 on branch trunk — 90% converted to using units (user: matt size: 8769)
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 31 2c 20 4d 61 74 74 68 65 77 06-2011, 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 29 0a 28 69 6d 70 6f 72 74 20 28 70 se64).(import (p 0250: 72 65 66 69 78 20 62 61 73 65 36 34 20 62 61 73 refix base64 bas 0260: 65 36 34 3a 29 29 0a 0a 28 64 65 63 6c 61 72 65 e64:))..(declare 0270: 20 28 75 6e 69 74 20 6c 61 75 6e 63 68 29 29 0a (unit launch)). 0280: 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 63 (declare (uses c 0290: 6f 6d 6d 6f 6e 29 29 0a 28 64 65 63 6c 61 72 65 ommon)).(declare 02a0: 20 28 75 73 65 73 20 63 6f 6e 66 69 67 66 29 29 (uses configf)) 02b0: 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 .(declare (uses 02c0: 64 62 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 db))..(include " 02d0: 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 common_records.s 02e0: 63 6d 22 29 0a 28 69 6e 63 6c 75 64 65 20 22 6b cm").(include "k 02f0: 65 79 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 ey_records.scm") 0300: 0a 28 69 6e 63 6c 75 64 65 20 22 64 62 5f 72 65 .(include "db_re 0310: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 28 64 65 cords.scm")..(de 0320: 66 69 6e 65 20 28 73 65 74 75 70 2d 66 6f 72 2d fine (setup-for- 0330: 72 75 6e 29 0a 20 20 28 73 65 74 21 20 2a 63 6f run). (set! *co 0340: 6e 66 69 67 69 6e 66 6f 2a 20 28 66 69 6e 64 2d nfiginfo* (find- 0350: 61 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 67 20 and-read-config 0360: 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (if (args:get-ar 0370: 67 20 22 2d 63 6f 6e 66 69 67 22 29 28 61 72 67 g "-config")(arg 0380: 73 3a 67 65 74 2d 61 72 67 20 22 2d 63 6f 6e 66 s:get-arg "-conf 0390: 69 67 22 29 20 22 6d 65 67 61 74 65 73 74 2e 63 ig") "megatest.c 03a0: 6f 6e 66 69 67 22 29 29 29 0a 20 20 28 73 65 74 onfig"))). (set 03b0: 21 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 20 28 ! *configdat* ( 03c0: 69 66 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 69 if (car *configi 03d0: 6e 66 6f 2a 29 28 63 61 72 20 2a 63 6f 6e 66 69 nfo*)(car *confi 03e0: 67 69 6e 66 6f 2a 29 20 23 66 29 29 0a 20 20 28 ginfo*) #f)). ( 03f0: 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 20 set! *toppath* 0400: 20 20 28 69 66 20 28 63 61 72 20 2a 63 6f 6e 66 (if (car *conf 0410: 69 67 69 6e 66 6f 2a 29 28 63 61 64 72 20 2a 63 iginfo*)(cadr *c 0420: 6f 6e 66 69 67 69 6e 66 6f 2a 29 20 23 66 29 29 onfiginfo*) #f)) 0430: 0a 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a . (if *toppath* 0440: 0a 20 20 20 20 20 20 28 73 65 74 65 6e 76 20 22 . (setenv " 0450: 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 MT_RUN_AREA_HOME 0460: 22 20 2a 74 6f 70 70 61 74 68 2a 29 20 3b 3b 20 " *toppath*) ;; 0470: 74 6f 20 62 65 20 64 65 70 72 65 63 61 74 65 64 to be deprecated 0480: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr 0490: 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 66 61 int 0 "ERROR: fa 04a0: 69 6c 65 64 20 74 6f 20 66 69 6e 64 20 74 68 65 iled to find the 04b0: 20 74 6f 70 20 70 61 74 68 20 74 6f 20 79 6f 75 top path to you 04c0: 72 20 72 75 6e 20 73 65 74 75 70 2e 22 29 29 0a r run setup.")). 04d0: 20 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 28 64 *toppath*)..(d 04e0: 65 66 69 6e 65 20 28 67 65 74 2d 62 65 73 74 2d efine (get-best- 04f0: 64 69 73 6b 20 63 6f 6e 66 64 61 74 29 0a 20 20 disk confdat). 0500: 28 6c 65 74 2a 20 28 28 64 69 73 6b 73 20 20 20 (let* ((disks 0510: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref 0520: 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 64 61 74 /default confdat 0530: 20 22 64 69 73 6b 73 22 20 23 66 29 29 0a 09 20 "disks" #f)).. 0540: 28 62 65 73 74 20 20 20 20 20 23 66 29 0a 09 20 (best #f).. 0550: 28 62 65 73 74 73 69 7a 65 20 30 29 29 0a 20 20 (bestsize 0)). 0560: 20 20 28 69 66 20 64 69 73 6b 73 20 0a 09 28 66 (if disks ..(f 0570: 6f 72 2d 65 61 63 68 20 0a 09 20 28 6c 61 6d 62 or-each .. (lamb 0580: 64 61 20 28 64 69 73 6b 2d 6e 75 6d 29 0a 09 20 da (disk-num).. 0590: 20 20 28 6c 65 74 2a 20 28 28 64 69 72 70 61 74 (let* ((dirpat 05a0: 68 20 20 20 20 28 63 61 64 72 20 28 61 73 73 6f h (cadr (asso 05b0: 63 20 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 c disk-num disks 05c0: 29 29 29 0a 09 09 20 20 28 66 72 65 65 73 70 63 )))... (freespc 05d0: 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 6f (if (directo 05e0: 72 79 3f 20 64 69 72 70 61 74 68 29 0a 09 09 09 ry? dirpath).... 05f0: 09 20 20 28 67 65 74 2d 64 66 20 64 69 72 70 61 . (get-df dirpa 0600: 74 68 29 0a 09 09 09 09 20 20 28 62 65 67 69 6e th)..... (begin 0610: 0a 09 09 09 09 20 20 20 20 28 64 65 62 75 67 3a ..... (debug: 0620: 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 print 0 "WARNING 0630: 3a 20 70 61 74 68 20 22 20 64 69 72 70 61 74 68 : path " dirpath 0640: 20 22 20 69 6e 20 5b 64 69 73 6b 73 5d 20 73 65 " in [disks] se 0650: 63 74 69 6f 6e 20 6e 6f 74 20 76 61 6c 69 64 22 ction not valid" 0660: 29 0a 09 09 09 09 20 20 20 20 30 29 29 29 29 0a )..... 0)))). 0670: 09 20 20 20 20 20 28 69 66 20 28 3e 20 66 72 65 . (if (> fre 0680: 65 73 70 63 20 62 65 73 74 73 69 7a 65 29 0a 09 espc bestsize).. 0690: 09 20 28 62 65 67 69 6e 0a 09 09 20 20 20 28 73 . (begin... (s 06a0: 65 74 21 20 62 65 73 74 20 20 20 20 20 64 69 72 et! best dir 06b0: 70 61 74 68 29 0a 09 09 20 20 20 28 73 65 74 21 path)... (set! 06c0: 20 62 65 73 74 73 69 7a 65 20 66 72 65 65 73 70 bestsize freesp 06d0: 63 29 29 29 29 29 0a 09 20 28 6d 61 70 20 63 61 c))))).. (map ca 06e0: 72 20 64 69 73 6b 73 29 29 29 0a 20 20 20 20 28 r disks))). ( 06f0: 69 66 20 62 65 73 74 0a 09 62 65 73 74 0a 09 28 if best..best..( 0700: 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a begin.. (debug: 0710: 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 print 0 "ERROR: 0720: 4e 6f 20 76 61 6c 69 64 20 64 69 73 6b 73 20 66 No valid disks f 0730: 6f 75 6e 64 20 69 6e 20 6d 65 67 61 74 65 73 74 ound in megatest 0740: 2e 63 6f 6e 66 69 67 2e 20 50 6c 65 61 73 65 20 .config. Please 0750: 61 64 64 20 73 6f 6d 65 20 74 6f 20 79 6f 75 72 add some to your 0760: 20 5b 64 69 73 6b 73 5d 20 73 65 63 74 69 6f 6e [disks] section 0770: 22 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 ").. (exit 1))) 0780: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 72 65 ))..(define (cre 0790: 61 74 65 2d 77 6f 72 6b 2d 61 72 65 61 20 64 62 ate-work-area db 07a0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 70 61 74 run-id test-pat 07b0: 68 20 64 69 73 6b 2d 70 61 74 68 20 74 65 73 74 h disk-path test 07c0: 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 20 name itemdat). 07d0: 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 6e 66 6f (let* ((run-info 07e0: 20 28 64 62 3a 67 65 74 2d 72 75 6e 2d 69 6e 66 (db:get-run-inf 07f0: 6f 20 64 62 20 72 75 6e 2d 69 64 29 29 0a 09 20 o db run-id)).. 0800: 28 69 74 65 6d 2d 70 61 74 68 20 28 6c 65 74 20 (item-path (let 0810: 28 28 69 70 20 28 69 74 65 6d 2d 6c 69 73 74 2d ((ip (item-list- 0820: 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 29 >path itemdat))) 0830: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 65 71 ... (if (eq 0840: 75 61 6c 3f 20 69 70 20 22 22 29 20 22 22 20 28 ual? ip "") "" ( 0850: 63 6f 6e 63 20 22 2f 22 20 69 70 29 29 29 29 0a conc "/" ip)))). 0860: 09 20 28 72 75 6e 6e 61 6d 65 20 20 28 64 62 3a . (runname (db: 0870: 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 61 get-value-by-hea 0880: 64 65 72 20 28 64 62 3a 67 65 74 2d 72 6f 77 20 der (db:get-row 0890: 72 75 6e 2d 69 6e 66 6f 29 0a 09 09 09 09 09 20 run-info)...... 08a0: 20 20 28 64 62 3a 67 65 74 2d 68 65 61 64 65 72 (db:get-header 08b0: 20 72 75 6e 2d 69 6e 66 6f 29 0a 09 09 09 09 09 run-info)...... 08c0: 20 20 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a 09 "runname")).. 08d0: 20 28 6b 65 79 2d 76 61 6c 73 20 28 67 65 74 2d (key-vals (get- 08e0: 6b 65 79 2d 76 61 6c 73 20 64 62 20 72 75 6e 2d key-vals db run- 08f0: 69 64 29 29 0a 09 20 28 6b 65 79 2d 73 74 72 20 id)).. (key-str 0900: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp 0910: 65 72 73 65 20 6b 65 79 2d 76 61 6c 73 20 22 2f erse key-vals "/ 0920: 22 29 29 0a 09 20 28 64 66 75 6c 6c 70 20 20 20 ")).. (dfullp 0930: 28 63 6f 6e 63 20 64 69 73 6b 2d 70 61 74 68 20 (conc disk-path 0940: 22 2f 22 20 6b 65 79 2d 73 74 72 20 22 2f 22 20 "/" key-str "/" 0950: 72 75 6e 6e 61 6d 65 20 22 2f 22 20 74 65 73 74 runname "/" test 0960: 6e 61 6d 65 0a 09 09 09 20 69 74 65 6d 2d 70 61 name.... item-pa 0970: 74 68 29 29 0a 09 20 28 74 6f 70 74 65 73 74 2d th)).. (toptest- 0980: 70 61 74 68 20 28 63 6f 6e 63 20 64 69 73 6b 2d path (conc disk- 0990: 70 61 74 68 20 22 2f 22 20 6b 65 79 2d 73 74 72 path "/" key-str 09a0: 20 22 2f 22 20 72 75 6e 6e 61 6d 65 20 22 2f 22 "/" runname "/" 09b0: 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 20 28 72 testname)).. (r 09c0: 75 6e 73 64 69 72 20 20 28 63 6f 6e 66 69 67 2d unsdir (config- 09d0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda 09e0: 74 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e 73 t* "setup" "runs 09f0: 64 69 72 22 29 29 0a 09 20 28 6c 6e 6b 70 61 74 dir")).. (lnkpat 0a00: 68 20 20 28 63 6f 6e 63 20 28 69 66 20 72 75 6e h (conc (if run 0a10: 73 64 69 72 20 72 75 6e 73 64 69 72 20 28 63 6f sdir runsdir (co 0a20: 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 nc *toppath* "/r 0a30: 75 6e 73 22 29 29 0a 09 09 09 20 22 2f 22 20 6b uns")).... "/" k 0a40: 65 79 2d 73 74 72 20 22 2f 22 20 72 75 6e 6e 61 ey-str "/" runna 0a50: 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 0a me item-path))). 0a60: 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 74 68 69 ;; since thi 0a70: 73 20 69 73 20 61 6e 20 69 74 65 72 61 74 65 64 s is an iterated 0a80: 20 74 65 73 74 20 74 68 69 73 20 69 73 20 61 73 test this is as 0a90: 20 67 6f 6f 64 20 61 20 70 6c 61 63 65 20 61 73 good a place as 0aa0: 20 61 6e 79 20 74 6f 0a 20 20 20 20 3b 3b 20 75 any to. ;; u 0ab0: 70 64 61 74 65 20 74 68 65 20 74 6f 70 74 65 73 pdate the toptes 0ac0: 74 20 72 65 63 6f 72 64 20 77 69 74 68 20 69 74 t record with it 0ad0: 73 20 6c 6f 63 61 74 69 6f 6e 20 72 75 6e 64 69 s location rundi 0ae0: 72 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 r. (if (not ( 0af0: 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 68 equal? item-path 0b00: 20 22 22 29 29 0a 09 28 64 62 3a 74 65 73 74 2d ""))..(db:test- 0b10: 73 65 74 2d 72 75 6e 64 69 72 21 20 64 62 20 72 set-rundir! db r 0b20: 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 22 un-id testname " 0b30: 22 20 74 6f 70 74 65 73 74 2d 70 61 74 68 29 29 " toptest-path)) 0b40: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin 0b50: 74 20 32 20 22 53 65 74 74 69 6e 67 20 75 70 20 t 2 "Setting up 0b60: 74 65 73 74 20 72 75 6e 20 61 72 65 61 22 29 0a test run area"). 0b70: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print 0b80: 20 32 20 22 20 2d 20 63 72 65 61 74 69 6e 67 20 2 " - creating 0b90: 72 75 6e 20 61 72 65 61 20 69 6e 20 22 20 64 66 run area in " df 0ba0: 75 6c 6c 70 29 0a 20 20 20 20 28 73 79 73 74 65 ullp). (syste 0bb0: 6d 20 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 20 m (conc "mkdir 0bc0: 2d 70 20 22 20 64 66 75 6c 6c 70 29 29 0a 20 20 -p " dfullp)). 0bd0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 (debug:print 2 0be0: 20 22 20 2d 20 63 72 65 61 74 69 6e 67 20 6c 69 " - creating li 0bf0: 6e 6b 20 66 72 6f 6d 20 22 20 64 66 75 6c 6c 70 nk from " dfullp 0c00: 20 22 2f 22 20 74 65 73 74 6e 61 6d 65 20 22 20 "/" testname " 0c10: 74 6f 20 22 20 6c 6e 6b 70 61 74 68 29 0a 20 20 to " lnkpath). 0c20: 20 20 28 73 79 73 74 65 6d 20 20 28 63 6f 6e 63 (system (conc 0c30: 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6c 6e 6b "mkdir -p " lnk 0c40: 70 61 74 68 29 29 0a 0a 3b 3b 20 49 20 73 75 73 path))..;; I sus 0c50: 70 65 63 74 20 74 68 69 73 20 73 65 63 74 69 6f pect this sectio 0c60: 6e 20 77 61 73 20 64 65 6c 65 74 69 6e 67 20 74 n was deleting t 0c70: 65 73 74 20 64 69 72 65 63 74 6f 72 69 65 73 20 est directories 0c80: 75 6e 64 65 72 20 73 6f 6d 65 20 0a 3b 3b 20 77 under some .;; w 0c90: 69 65 72 64 20 73 69 74 61 74 69 6f 6e 73 0a 0a ierd sitations.. 0ca0: 3b 3b 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d ;; (if (file- 0cb0: 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 6c 6e exists? (conc ln 0cc0: 6b 70 61 74 68 20 22 2f 22 20 74 65 73 74 6e 61 kpath "/" testna 0cd0: 6d 65 29 29 0a 3b 3b 09 28 73 79 73 74 65 6d 20 me)).;;.(system 0ce0: 28 63 6f 6e 63 20 22 72 6d 20 2d 66 20 22 20 6c (conc "rm -f " l 0cf0: 6e 6b 70 61 74 68 20 22 2f 22 20 74 65 73 74 6e nkpath "/" testn 0d00: 61 6d 65 29 29 29 0a 20 20 20 20 28 73 79 73 74 ame))). (syst 0d10: 65 6d 20 20 28 63 6f 6e 63 20 22 6c 6e 20 2d 73 em (conc "ln -s 0d20: 66 20 22 20 64 66 75 6c 6c 70 20 22 20 22 20 6c f " dfullp " " l 0d30: 6e 6b 70 61 74 68 20 22 2f 22 20 74 65 73 74 6e nkpath "/" testn 0d40: 61 6d 65 29 29 0a 20 20 20 20 28 69 66 20 28 64 ame)). (if (d 0d50: 69 72 65 63 74 6f 72 79 3f 20 64 66 75 6c 6c 70 irectory? dfullp 0d60: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 6c 65 )..(begin.. (le 0d70: 74 2a 20 28 28 63 6d 64 20 20 20 20 28 63 6f 6e t* ((cmd (con 0d80: 63 20 22 72 73 79 6e 63 20 2d 61 76 22 20 28 69 c "rsync -av" (i 0d90: 66 20 28 3e 20 2a 76 65 72 62 6f 73 69 74 79 2a f (> *verbosity* 0da0: 20 31 29 20 22 22 20 22 71 22 29 20 22 20 22 20 1) "" "q") " " 0db0: 74 65 73 74 2d 70 61 74 68 20 22 2f 20 22 20 64 test-path "/ " d 0dc0: 66 75 6c 6c 70 20 22 2f 22 29 29 0a 09 09 20 28 fullp "/"))... ( 0dd0: 73 74 61 74 75 73 20 28 73 79 73 74 65 6d 20 63 status (system c 0de0: 6d 64 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 md))).. (if ( 0df0: 6e 6f 74 20 28 65 71 3f 20 73 74 61 74 75 73 20 not (eq? status 0e00: 30 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 0))...(debug:pri 0e10: 6e 74 20 32 20 22 45 52 52 4f 52 3a 20 70 72 6f nt 2 "ERROR: pro 0e20: 62 6c 65 6d 20 77 69 74 68 20 72 75 6e 6e 69 6e blem with runnin 0e30: 67 20 5c 22 22 20 63 6d 64 20 22 5c 22 22 29 29 g \"" cmd "\"")) 0e40: 29 0a 09 20 20 28 6c 69 73 74 20 64 66 75 6c 6c ).. (list dfull 0e50: 70 20 74 6f 70 74 65 73 74 2d 70 61 74 68 29 29 p toptest-path)) 0e60: 0a 09 28 6c 69 73 74 20 23 66 20 23 66 29 29 29 ..(list #f #f))) 0e70: 29 0a 0a 3b 3b 20 31 2e 20 6c 6f 6f 6b 20 74 68 )..;; 1. look th 0e80: 6f 75 67 68 20 64 69 73 6b 73 20 6c 69 73 74 20 ough disks list 0e90: 66 6f 72 20 64 69 73 6b 20 77 69 74 68 20 6d 6f for disk with mo 0ea0: 73 74 20 73 70 61 63 65 0a 3b 3b 20 32 2e 20 63 st space.;; 2. c 0eb0: 72 65 61 74 65 20 72 75 6e 20 64 69 72 20 6f 6e reate run dir on 0ec0: 20 64 69 73 6b 2c 20 70 61 74 68 20 6e 61 6d 65 disk, path name 0ed0: 20 69 73 20 6d 65 61 6e 69 6e 67 66 75 6c 0a 3b is meaningful.; 0ee0: 3b 20 33 2e 20 63 72 65 61 74 65 20 6c 69 6e 6b ; 3. create link 0ef0: 20 66 72 6f 6d 20 72 75 6e 20 64 69 72 20 74 6f from run dir to 0f00: 20 6d 65 67 61 74 65 73 74 20 72 75 6e 73 20 61 megatest runs a 0f10: 72 65 61 20 0a 3b 3b 20 34 2e 20 72 65 6d 6f 74 rea .;; 4. remot 0f20: 65 6c 79 20 72 75 6e 20 74 68 65 20 74 65 73 74 ely run the test 0f30: 20 6f 6e 20 61 6c 6c 6f 63 61 74 65 64 20 68 6f on allocated ho 0f40: 73 74 0a 3b 3b 20 20 20 20 2d 20 63 6f 75 6c 64 st.;; - could 0f50: 20 62 65 20 73 73 68 20 74 6f 20 68 6f 73 74 20 be ssh to host 0f60: 66 72 6f 6d 20 68 6f 73 74 73 20 74 61 62 6c 65 from hosts table 0f70: 20 28 75 70 64 61 74 65 20 72 65 67 75 6c 61 72 (update regular 0f80: 6c 79 20 77 69 74 68 20 6c 6f 61 64 29 0a 3b 3b ly with load).;; 0f90: 20 20 20 20 2d 20 63 6f 75 6c 64 20 62 65 20 6e - could be n 0fa0: 65 74 62 61 74 63 68 0a 3b 3b 20 20 20 20 20 20 etbatch.;; 0fb0: 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 64 62 20 (launch-test db 0fc0: 28 63 61 64 72 20 73 74 61 74 75 73 29 20 74 65 (cadr status) te 0fd0: 73 74 2d 63 6f 6e 66 29 29 0a 28 64 65 66 69 6e st-conf)).(defin 0fe0: 65 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 64 e (launch-test d 0ff0: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 63 6f b run-id test-co 1000: 6e 66 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 73 nf keyvallst tes 1010: 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 68 t-name test-path 1020: 20 69 74 65 6d 64 61 74 29 0a 20 20 28 63 68 61 itemdat). (cha 1030: 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a 74 nge-directory *t 1040: 6f 70 70 61 74 68 2a 29 0a 20 20 28 6c 65 74 20 oppath*). (let 1050: 28 28 75 73 65 73 68 65 6c 6c 20 20 20 28 63 6f ((useshell (co 1060: 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e nfig-lookup *con 1070: 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f 6f 6c figdat* "jobtool 1080: 73 22 20 20 20 20 20 22 75 73 65 73 68 65 6c 6c s" "useshell 1090: 22 29 29 0a 09 28 6c 61 75 6e 63 68 65 72 20 20 "))..(launcher 10a0: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup 10b0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 *configdat* "job 10c0: 74 6f 6f 6c 73 22 20 20 20 20 20 22 6c 61 75 6e tools" "laun 10d0: 63 68 65 72 22 29 29 0a 09 28 72 75 6e 73 63 72 cher"))..(runscr 10e0: 69 70 74 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f ipt (config-loo 10f0: 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 20 20 kup test-conf 1100: 22 73 65 74 75 70 22 20 20 20 20 20 20 20 20 22 "setup" " 1110: 72 75 6e 73 63 72 69 70 74 22 29 29 0a 09 28 64 runscript"))..(d 1120: 69 73 6b 73 70 61 63 65 20 20 28 63 6f 6e 66 69 iskspace (confi 1130: 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 6f g-lookup test-co 1140: 6e 66 20 20 20 22 72 65 71 75 69 72 65 6d 65 6e nf "requiremen 1150: 74 73 22 20 22 64 69 73 6b 73 70 61 63 65 22 29 ts" "diskspace") 1160: 29 0a 09 28 6d 65 6d 6f 72 79 20 20 20 20 20 28 )..(memory ( 1170: 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 config-lookup te 1180: 73 74 2d 63 6f 6e 66 20 20 20 22 72 65 71 75 69 st-conf "requi 1190: 72 65 6d 65 6e 74 73 22 20 22 6d 65 6d 6f 72 79 rements" "memory 11a0: 22 29 29 0a 09 28 68 6f 73 74 73 20 20 20 20 20 "))..(hosts 11b0: 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 (config-lookup 11c0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 *configdat* "job 11d0: 74 6f 6f 6c 73 22 20 20 20 20 20 22 77 6f 72 6b tools" "work 11e0: 68 6f 73 74 73 22 29 29 0a 09 28 72 65 6d 6f 74 hosts"))..(remot 11f0: 65 2d 6d 65 67 61 74 65 73 74 20 28 63 6f 6e 66 e-megatest (conf 1200: 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 ig-lookup *confi 1210: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 65 gdat* "setup" "e 1220: 78 65 63 75 74 61 62 6c 65 22 29 29 0a 09 28 6c xecutable"))..(l 1230: 6f 63 61 6c 2d 6d 65 67 61 74 65 73 74 20 20 28 ocal-megatest ( 1240: 63 61 72 20 28 61 72 67 76 29 29 29 0a 09 3b 3b car (argv)))..;; 1250: 20 28 69 74 65 6d 2d 70 61 74 68 20 20 28 69 74 (item-path (it 1260: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it 1270: 65 6d 64 61 74 29 29 20 74 65 73 74 2d 70 61 74 emdat)) test-pat 1280: 68 20 69 73 20 74 68 65 20 66 75 6c 6c 20 70 61 h is the full pa 1290: 74 68 20 69 6e 63 6c 75 64 69 6e 67 20 74 68 65 th including the 12a0: 20 69 74 65 6d 2d 70 61 74 68 0a 09 28 77 6f 72 item-path..(wor 12b0: 6b 2d 61 72 65 61 20 20 23 66 29 0a 09 28 74 6f k-area #f)..(to 12c0: 70 74 65 73 74 2d 77 6f 72 6b 2d 61 72 65 61 20 ptest-work-area 12d0: 23 66 29 20 3b 3b 20 66 6f 72 20 69 74 65 72 61 #f) ;; for itera 12e0: 74 65 64 20 74 65 73 74 73 20 74 68 65 20 74 6f ted tests the to 12f0: 70 20 74 65 73 74 20 63 6f 6e 74 61 69 6e 73 20 p test contains 1300: 64 61 74 61 20 72 65 6c 65 76 61 6e 74 20 66 6f data relevant fo 1310: 72 20 61 6c 6c 0a 09 28 64 69 73 6b 70 61 74 68 r all..(diskpath 1320: 20 20 20 23 66 29 0a 09 28 63 6d 64 70 61 72 6d #f)..(cmdparm 1330: 73 20 20 20 23 66 29 0a 09 28 66 75 6c 6c 63 6d s #f)..(fullcm 1340: 64 20 20 20 20 23 66 29 20 3b 3b 20 28 64 65 66 d #f) ;; (def 1350: 69 6e 65 20 61 20 28 77 69 74 68 2d 6f 75 74 70 ine a (with-outp 1360: 75 74 2d 74 6f 2d 73 74 72 69 6e 67 20 28 6c 61 ut-to-string (la 1370: 6d 62 64 61 20 28 29 28 77 72 69 74 65 20 78 29 mbda ()(write x) 1380: 29 29 29 0a 09 28 6d 74 2d 62 69 6e 64 69 72 2d )))..(mt-bindir- 1390: 70 61 74 68 20 23 66 29 29 0a 20 20 20 20 28 69 path #f)). (i 13a0: 66 20 68 6f 73 74 73 20 28 73 65 74 21 20 68 6f f hosts (set! ho 13b0: 73 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 sts (string-spli 13c0: 74 20 68 6f 73 74 73 29 29 29 0a 20 20 20 20 28 t hosts))). ( 13d0: 69 66 20 28 6e 6f 74 20 72 65 6d 6f 74 65 2d 6d if (not remote-m 13e0: 65 67 61 74 65 73 74 29 28 73 65 74 21 20 72 65 egatest)(set! re 13f0: 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 6c 6f mote-megatest lo 1400: 63 61 6c 2d 6d 65 67 61 74 65 73 74 29 29 20 3b cal-megatest)) ; 1410: 3b 20 22 6d 65 67 61 74 65 73 74 22 29 29 0a 20 ; "megatest")). 1420: 20 20 20 28 73 65 74 21 20 6d 74 2d 62 69 6e 64 (set! mt-bind 1430: 69 72 2d 70 61 74 68 20 28 70 61 74 68 6e 61 6d ir-path (pathnam 1440: 65 2d 64 69 72 65 63 74 6f 72 79 20 72 65 6d 6f e-directory remo 1450: 74 65 2d 6d 65 67 61 74 65 73 74 29 29 0a 20 20 te-megatest)). 1460: 20 20 28 69 66 20 6c 61 75 6e 63 68 65 72 20 28 (if launcher ( 1470: 73 65 74 21 20 6c 61 75 6e 63 68 65 72 20 28 73 set! launcher (s 1480: 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 75 6e tring-split laun 1490: 63 68 65 72 29 29 29 0a 20 20 20 20 3b 3b 20 73 cher))). ;; s 14a0: 65 74 20 75 70 20 74 68 65 20 72 75 6e 20 77 6f et up the run wo 14b0: 72 6b 20 61 72 65 61 20 66 6f 72 20 74 68 69 73 rk area for this 14c0: 20 74 65 73 74 0a 20 20 20 20 28 73 65 74 21 20 test. (set! 14d0: 64 69 73 6b 70 61 74 68 20 28 67 65 74 2d 62 65 diskpath (get-be 14e0: 73 74 2d 64 69 73 6b 20 2a 63 6f 6e 66 69 67 64 st-disk *configd 14f0: 61 74 2a 29 29 0a 20 20 20 20 28 69 66 20 64 69 at*)). (if di 1500: 73 6b 70 61 74 68 0a 09 28 6c 65 74 20 28 28 64 skpath..(let ((d 1510: 61 74 20 20 28 63 72 65 61 74 65 2d 77 6f 72 6b at (create-work 1520: 2d 61 72 65 61 20 64 62 20 72 75 6e 2d 69 64 20 -area db run-id 1530: 74 65 73 74 2d 70 61 74 68 20 64 69 73 6b 70 61 test-path diskpa 1540: 74 68 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 65 th test-name ite 1550: 6d 64 61 74 29 29 29 0a 09 20 20 28 73 65 74 21 mdat))).. (set! 1560: 20 77 6f 72 6b 2d 61 72 65 61 20 28 63 61 72 20 work-area (car 1570: 64 61 74 29 29 0a 09 20 20 28 73 65 74 21 20 74 dat)).. (set! t 1580: 6f 70 74 65 73 74 2d 77 6f 72 6b 2d 61 72 65 61 optest-work-area 1590: 20 28 63 61 64 72 20 64 61 74 29 29 29 0a 09 28 (cadr dat)))..( 15a0: 62 65 67 69 6e 0a 09 20 20 28 73 65 74 21 20 77 begin.. (set! w 15b0: 6f 72 6b 2d 61 72 65 61 20 74 65 73 74 2d 70 61 ork-area test-pa 15c0: 74 68 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 th).. (debug:pr 15d0: 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a 20 int 0 "WARNING: 15e0: 4e 6f 20 64 69 73 6b 20 77 6f 72 6b 20 61 72 65 No disk work are 15f0: 61 20 73 70 65 63 69 66 69 65 64 20 2d 20 72 75 a specified - ru 1600: 6e 6e 69 6e 67 20 69 6e 20 74 68 65 20 74 65 73 nning in the tes 1610: 74 20 64 69 72 65 63 74 6f 72 79 22 29 29 29 0a t directory"))). 1620: 20 20 20 20 28 73 65 74 21 20 63 6d 64 70 61 72 (set! cmdpar 1630: 6d 73 20 28 62 61 73 65 36 34 3a 62 61 73 65 36 ms (base64:base6 1640: 34 2d 65 6e 63 6f 64 65 20 28 77 69 74 68 2d 6f 4-encode (with-o 1650: 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 0a utput-to-string. 1660: 09 09 09 09 20 20 20 20 28 6c 61 6d 62 64 61 20 .... (lambda 1670: 28 29 20 3b 3b 20 28 6c 69 73 74 20 27 68 6f 73 () ;; (list 'hos 1680: 74 73 20 20 20 20 20 68 6f 73 74 73 29 0a 09 09 ts hosts)... 1690: 09 09 20 20 20 20 20 20 28 77 72 69 74 65 20 28 .. (write ( 16a0: 6c 69 73 74 20 28 6c 69 73 74 20 27 74 65 73 74 list (list 'test 16b0: 70 61 74 68 20 20 74 65 73 74 2d 70 61 74 68 29 path test-path) 16c0: 0a 09 09 09 09 09 09 20 20 20 28 6c 69 73 74 20 ....... (list 16d0: 27 77 6f 72 6b 2d 61 72 65 61 20 77 6f 72 6b 2d 'work-area work- 16e0: 61 72 65 61 29 0a 09 09 09 09 09 09 20 20 20 28 area)....... ( 16f0: 6c 69 73 74 20 27 74 65 73 74 2d 6e 61 6d 65 20 list 'test-name 1700: 74 65 73 74 2d 6e 61 6d 65 29 20 0a 09 09 09 09 test-name) ..... 1710: 09 09 20 20 20 28 6c 69 73 74 20 27 72 75 6e 73 .. (list 'runs 1720: 63 72 69 70 74 20 72 75 6e 73 63 72 69 70 74 29 cript runscript) 1730: 20 0a 09 09 09 09 09 09 20 20 20 28 6c 69 73 74 ....... (list 1740: 20 27 72 75 6e 2d 69 64 20 20 20 20 72 75 6e 2d 'run-id run- 1750: 69 64 20 20 20 29 0a 09 09 09 09 09 09 20 20 20 id )....... 1760: 28 6c 69 73 74 20 27 69 74 65 6d 64 61 74 20 20 (list 'itemdat 1770: 20 69 74 65 6d 64 61 74 20 20 29 0a 09 09 09 09 itemdat )..... 1780: 09 09 20 20 20 28 6c 69 73 74 20 27 6d 65 67 61 .. (list 'mega 1790: 74 65 73 74 20 20 72 65 6d 6f 74 65 2d 6d 65 67 test remote-meg 17a0: 61 74 65 73 74 29 0a 09 09 09 09 09 09 20 20 20 atest)....... 17b0: 28 6c 69 73 74 20 27 65 6e 76 2d 6f 76 72 64 20 (list 'env-ovrd 17c0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref 17d0: 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 67 /default *config 17e0: 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 69 dat* "env-overri 17f0: 64 65 22 20 27 28 29 29 29 0a 09 09 09 09 09 09 de" '()))....... 1800: 20 20 20 28 6c 69 73 74 20 27 72 75 6e 6e 61 6d (list 'runnam 1810: 65 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 e (args:get-ar 1820: 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a 09 g ":runname")).. 1830: 09 09 09 09 09 20 20 20 28 6c 69 73 74 20 27 6d ..... (list 'm 1840: 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 6d 74 t-bindir-path mt 1850: 2d 62 69 6e 64 69 72 2d 70 61 74 68 29 29 29 29 -bindir-path)))) 1860: 29 29 29 20 3b 3b 20 28 73 74 72 69 6e 67 2d 69 ))) ;; (string-i 1870: 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 76 61 ntersperse keyva 1880: 6c 6c 73 74 20 22 20 22 29 29 29 29 0a 20 20 20 llst " ")))). 1890: 20 3b 3b 20 63 6c 65 61 6e 20 6f 75 74 20 73 74 ;; clean out st 18a0: 65 70 20 72 65 63 6f 72 64 73 20 66 72 6f 6d 20 ep records from 18b0: 70 72 65 76 69 6f 75 73 20 72 75 6e 20 69 66 20 previous run if 18c0: 74 68 65 79 20 65 78 69 73 74 0a 20 20 20 20 28 they exist. ( 18d0: 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d 73 db:delete-test-s 18e0: 74 65 70 2d 72 65 63 6f 72 64 73 20 64 62 20 72 tep-records db r 18f0: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name 1900: 69 74 65 6d 64 61 74 29 0a 20 20 20 20 28 63 68 itemdat). (ch 1910: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 77 ange-directory w 1920: 6f 72 6b 2d 61 72 65 61 29 20 3b 3b 20 73 6f 20 ork-area) ;; so 1930: 74 68 61 74 20 6c 6f 67 20 66 69 6c 65 73 20 66 that log files f 1940: 72 6f 6d 20 74 68 65 20 6c 61 75 6e 63 68 20 70 rom the launch p 1950: 72 6f 63 65 73 73 20 64 6f 6e 27 74 20 63 6c 75 rocess don't clu 1960: 74 74 65 72 20 74 68 65 20 74 65 73 74 20 64 69 tter the test di 1970: 72 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 r. (cond. 1980: 20 28 28 61 6e 64 20 6c 61 75 6e 63 68 65 72 20 ((and launcher 1990: 68 6f 73 74 73 29 20 3b 3b 20 6d 75 73 74 20 62 hosts) ;; must b 19a0: 65 20 75 73 69 6e 67 20 73 73 68 20 68 6f 73 74 e using ssh host 19b0: 6e 61 6d 65 0a 20 20 20 20 20 20 28 73 65 74 21 name. (set! 19c0: 20 66 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 fullcmd (append 19d0: 20 6c 61 75 6e 63 68 65 72 20 28 63 61 72 20 68 launcher (car h 19e0: 6f 73 74 73 29 28 6c 69 73 74 20 72 65 6d 6f 74 osts)(list remot 19f0: 65 2d 6d 65 67 61 74 65 73 74 20 22 2d 65 78 65 e-megatest "-exe 1a00: 63 75 74 65 22 20 63 6d 64 70 61 72 6d 73 29 29 cute" cmdparms)) 1a10: 29 29 0a 20 20 20 20 20 28 6c 61 75 6e 63 68 65 )). (launche 1a20: 72 0a 20 20 20 20 20 20 28 73 65 74 21 20 66 75 r. (set! fu 1a30: 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 6c 61 llcmd (append la 1a40: 75 6e 63 68 65 72 20 28 6c 69 73 74 20 72 65 6d uncher (list rem 1a50: 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 22 2d 65 ote-megatest "-e 1a60: 78 65 63 75 74 65 22 20 63 6d 64 70 61 72 6d 73 xecute" cmdparms 1a70: 29 29 29 29 0a 20 20 20 20 20 28 65 6c 73 65 0a )))). (else. 1a80: 20 20 20 20 20 20 28 73 65 74 21 20 66 75 6c 6c (set! full 1a90: 63 6d 64 20 28 6c 69 73 74 20 72 65 6d 6f 74 65 cmd (list remote 1aa0: 2d 6d 65 67 61 74 65 73 74 20 22 2d 65 78 65 63 -megatest "-exec 1ab0: 75 74 65 22 20 63 6d 64 70 61 72 6d 73 29 29 29 ute" cmdparms))) 1ac0: 29 0a 20 20 20 20 28 69 66 20 28 61 72 67 73 3a ). (if (args: 1ad0: 67 65 74 2d 61 72 67 20 22 2d 78 74 65 72 6d 22 get-arg "-xterm" 1ae0: 29 28 73 65 74 21 20 66 75 6c 6c 63 6d 64 20 28 )(set! fullcmd ( 1af0: 61 70 70 65 6e 64 20 66 75 6c 6c 63 6d 64 20 28 append fullcmd ( 1b00: 6c 69 73 74 20 22 2d 78 74 65 72 6d 22 29 29 29 list "-xterm"))) 1b10: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri 1b20: 6e 74 20 31 20 22 4c 61 75 6e 63 68 69 6e 67 20 nt 1 "Launching 1b30: 6d 65 67 61 74 65 73 74 20 66 6f 72 20 74 65 73 megatest for tes 1b40: 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 20 t " test-name " 1b50: 69 6e 20 22 20 77 6f 72 6b 2d 61 72 65 61 22 20 in " work-area" 1b60: 2e 2e 2e 22 29 0a 20 20 20 20 28 74 65 73 74 2d ..."). (test- 1b70: 73 65 74 2d 73 74 61 74 75 73 21 20 64 62 20 72 set-status! db r 1b80: 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 un-id test-name 1b90: 22 4c 41 55 4e 43 48 45 44 22 20 22 6e 2f 61 22 "LAUNCHED" "n/a" 1ba0: 20 69 74 65 6d 64 61 74 20 23 66 20 23 66 29 20 itemdat #f #f) 1bb0: 3b 3b 20 28 69 66 20 6c 61 75 6e 63 68 2d 72 65 ;; (if launch-re 1bc0: 73 75 6c 74 73 20 6c 61 75 6e 63 68 2d 72 65 73 sults launch-res 1bd0: 75 6c 74 73 20 22 46 41 49 4c 45 44 22 29 29 0a ults "FAILED")). 1be0: 20 20 20 20 3b 3b 20 73 65 74 20 0a 20 20 20 20 ;; set . 1bf0: 3b 3b 20 73 65 74 20 70 72 65 2d 6c 61 75 6e 63 ;; set pre-launc 1c00: 68 2d 65 6e 76 2d 76 61 72 73 20 62 65 66 6f 72 h-env-vars befor 1c10: 65 20 6c 61 75 6e 63 68 69 6e 67 2c 20 6b 65 65 e launching, kee 1c20: 70 20 74 68 65 20 76 61 72 73 20 69 6e 20 70 72 p the vars in pr 1c30: 65 76 76 61 6c 73 20 61 6e 64 20 70 75 74 20 74 evvals and put t 1c40: 68 65 20 65 6e 76 69 6f 6e 6d 65 6e 74 20 62 61 he envionment ba 1c50: 63 6b 20 77 68 65 6e 20 64 6f 6e 65 0a 20 20 20 ck when done. 1c60: 20 28 6c 65 74 2a 20 28 28 63 6f 6d 6d 6f 6e 70 (let* ((commonp 1c70: 72 65 76 76 61 6c 73 20 28 61 6c 69 73 74 2d 3e revvals (alist-> 1c80: 65 6e 76 2d 76 61 72 73 0a 09 09 09 20 20 20 20 env-vars.... 1c90: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/ 1ca0: 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 67 64 default *configd 1cb0: 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 at* "env-overrid 1cc0: 65 22 20 27 28 29 29 29 29 0a 09 20 20 20 28 74 e" '()))).. (t 1cd0: 65 73 74 70 72 65 76 76 61 6c 73 20 20 20 28 61 estprevvals (a 1ce0: 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 0a 09 list->env-vars.. 1cf0: 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c .. (hash-tabl 1d00: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 74 65 e-ref/default te 1d10: 73 74 2d 63 6f 6e 66 20 22 70 72 65 2d 6c 61 75 st-conf "pre-lau 1d20: 6e 63 68 2d 65 6e 76 2d 6f 76 65 72 72 69 64 65 nch-env-override 1d30: 73 22 20 27 28 29 29 29 29 0a 09 20 20 20 28 6d s" '()))).. (m 1d40: 69 73 63 70 72 65 76 76 61 6c 73 20 20 20 28 61 iscprevvals (a 1d50: 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 3b list->env-vars ; 1d60: 3b 20 63 6f 6e 73 6f 6c 69 64 61 74 65 20 74 68 ; consolidate th 1d70: 69 73 20 63 6f 64 65 20 77 69 74 68 20 74 68 65 is code with the 1d80: 20 63 6f 64 65 20 69 6e 20 6d 65 67 61 74 65 73 code in megates 1d90: 74 2e 73 63 6d 20 66 6f 72 20 22 2d 65 78 65 63 t.scm for "-exec 1da0: 75 74 65 22 0a 09 09 09 20 20 20 20 28 61 70 70 ute".... (app 1db0: 65 6e 64 20 28 6c 69 73 74 20 28 6c 69 73 74 20 end (list (list 1dc0: 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 "MT_TEST_NAME" t 1dd0: 65 73 74 2d 6e 61 6d 65 29 0a 09 09 09 09 09 20 est-name)...... 1de0: 20 28 6c 69 73 74 20 22 4d 54 5f 49 54 45 4d 5f (list "MT_ITEM_ 1df0: 49 4e 46 4f 22 20 28 63 6f 6e 63 20 69 74 65 6d INFO" (conc item 1e00: 64 61 74 29 29 20 0a 09 09 09 09 09 20 20 28 6c dat)) ...... (l 1e10: 69 73 74 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 ist "MT_RUNNAME" 1e20: 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 (args:get-arg 1e30: 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 29 0a 09 ":runname"))).. 1e40: 09 09 09 20 20 20 20 69 74 65 6d 64 61 74 29 29 ... itemdat)) 1e50: 29 0a 09 20 20 20 28 6c 61 75 6e 63 68 2d 72 65 ).. (launch-re 1e60: 73 75 6c 74 73 20 28 61 70 70 6c 79 20 63 6d 64 sults (apply cmd 1e70: 2d 72 75 6e 2d 70 72 6f 63 2d 65 61 63 68 2d 6c -run-proc-each-l 1e80: 69 6e 65 0a 09 09 09 09 20 20 28 69 66 20 75 73 ine..... (if us 1e90: 65 73 68 65 6c 6c 0a 09 09 09 09 20 20 20 20 20 eshell..... 1ea0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp 1eb0: 65 72 73 65 20 66 75 6c 6c 63 6d 64 20 22 20 22 erse fullcmd " " 1ec0: 29 0a 09 09 09 09 20 20 20 20 20 20 28 63 61 72 )..... (car 1ed0: 20 66 75 6c 6c 63 6d 64 29 29 0a 09 09 09 09 20 fullcmd))..... 1ee0: 20 70 72 69 6e 74 0a 09 09 09 09 20 20 28 69 66 print..... (if 1ef0: 20 75 73 65 73 68 65 6c 6c 0a 09 09 09 09 20 20 useshell..... 1f00: 20 20 20 20 27 28 29 0a 09 09 09 09 20 20 20 20 '()..... 1f10: 20 20 28 63 64 72 20 66 75 6c 6c 63 6d 64 29 29 (cdr fullcmd)) 1f20: 29 29 29 20 3b 3b 20 20 6c 61 75 6e 63 68 65 72 ))) ;; launcher 1f30: 20 66 75 6c 6c 63 6d 64 29 29 29 3b 3b 20 28 61 fullcmd)));; (a 1f40: 70 70 6c 79 20 63 6d 64 2d 72 75 6e 2d 70 72 6f pply cmd-run-pro 1f50: 63 2d 65 61 63 68 2d 6c 69 6e 65 20 6c 61 75 6e c-each-line laun 1f60: 63 68 65 72 20 70 72 69 6e 74 20 66 75 6c 6c 63 cher print fullc 1f70: 6d 64 29 29 29 20 3b 3b 20 28 63 6d 64 2d 72 75 md))) ;; (cmd-ru 1f80: 6e 2d 3e 6c 69 73 74 20 66 75 6c 6c 63 6d 64 29 n->list fullcmd) 1f90: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p 1fa0: 72 69 6e 74 20 32 20 22 4c 61 75 6e 63 68 69 6e rint 2 "Launchin 1fb0: 67 20 63 6f 6d 70 6c 65 74 65 64 2c 20 75 70 64 g completed, upd 1fc0: 61 74 69 6e 67 20 64 62 22 29 0a 20 20 20 20 20 ating db"). 1fd0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4 1fe0: 22 4c 61 75 6e 63 68 20 72 65 73 75 6c 74 73 3a "Launch results: 1ff0: 20 22 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 " launch-result 2000: 73 29 0a 20 20 20 20 20 20 28 69 66 20 28 6e 6f s). (if (no 2010: 74 20 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 t launch-results 2020: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin.. 2030: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR: 2040: 46 61 69 6c 65 64 20 74 6f 20 72 75 6e 20 22 20 Failed to run " 2050: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe 2060: 72 73 65 20 66 75 6c 6c 63 6d 64 20 22 20 22 29 rse fullcmd " ") 2070: 20 22 2c 20 65 78 69 74 69 6e 67 20 6e 6f 77 22 ", exiting now" 2080: 29 0a 09 20 20 20 20 28 73 71 6c 69 74 65 33 3a ).. (sqlite3: 2090: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 09 20 finalize! db).. 20a0: 20 20 20 3b 3b 20 67 6f 6f 64 20 6f 6c 65 20 22 ;; good ole " 20b0: 65 78 69 74 22 20 73 65 65 6d 73 20 6e 6f 74 20 exit" seems not 20c0: 74 6f 20 77 6f 72 6b 0a 09 20 20 20 20 3b 3b 20 to work.. ;; 20d0: 28 5f 65 78 69 74 20 39 29 0a 09 20 20 20 20 3b (_exit 9).. ; 20e0: 3b 20 62 75 74 20 74 68 69 73 20 68 61 63 6b 20 ; but this hack 20f0: 77 69 6c 6c 20 77 6f 72 6b 21 20 54 68 61 6e 6b will work! Thank 2100: 73 20 67 6f 20 74 6f 20 41 6c 61 6e 20 50 6f 73 s go to Alan Pos 2110: 74 20 6f 66 20 74 68 65 20 43 68 69 63 6b 65 6e t of the Chicken 2120: 20 65 6d 61 69 6c 20 6c 69 73 74 0a 09 20 20 20 email list.. 2130: 20 3b 3b 20 4e 42 2f 2f 20 49 73 20 74 68 69 73 ;; NB// Is this 2140: 20 73 74 69 6c 6c 20 6e 65 65 64 65 64 3f 20 53 still needed? S 2150: 68 6f 75 6c 64 20 62 65 20 73 61 66 65 20 74 6f hould be safe to 2160: 20 67 6f 20 62 61 63 6b 20 74 6f 20 22 65 78 69 go back to "exi 2170: 74 22 20 6e 6f 77 3f 0a 09 20 20 20 20 28 70 72 t" now?.. (pr 2180: 6f 63 65 73 73 2d 73 69 67 6e 61 6c 20 28 63 75 ocess-signal (cu 2190: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id 21a0: 29 20 73 69 67 6e 61 6c 2f 6b 69 6c 6c 29 0a 09 ) signal/kill).. 21b0: 20 20 20 20 29 29 0a 20 20 20 20 20 20 28 61 6c )). (al 21c0: 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 6d 69 ist->env-vars mi 21d0: 73 63 70 72 65 76 76 61 6c 73 29 0a 20 20 20 20 scprevvals). 21e0: 20 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 (alist->env-va 21f0: 72 73 20 74 65 73 74 70 72 65 76 76 61 6c 73 29 rs testprevvals) 2200: 0a 20 20 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 . (alist->e 2210: 6e 76 2d 76 61 72 73 20 63 6f 6d 6d 6f 6e 70 72 nv-vars commonpr 2220: 65 76 76 61 6c 73 29 0a 20 20 20 20 20 20 6c 61 evvals). la 2230: 75 6e 63 68 2d 72 65 73 75 6c 74 73 29 29 29 0a unch-results))). 2240: 0a .