Artifact 0de4fcbff3e4153754d04906cd03f03b13d864d2:
- File launch.scm — part of check-in [37589f80eb] at 2011-10-09 00:17:30 on branch trunk — Minor reorganisation in megatest.scm. added placeholder for ezsteps (user: matt size: 15754)
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 20 73 71 6c 69 74 65 33 29 0a 28 69 se64 sqlite3).(i 0250: 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 62 61 mport (prefix ba 0260: 73 65 36 34 20 62 61 73 65 36 34 3a 29 29 0a 28 se64 base64:)).( 0270: 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 import (prefix s 0280: 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 qlite3 sqlite3:) 0290: 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 )..(declare (uni 02a0: 74 20 6c 61 75 6e 63 68 29 29 0a 28 64 65 63 6c t launch)).(decl 02b0: 61 72 65 20 28 75 73 65 73 20 63 6f 6d 6d 6f 6e are (uses common 02c0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use 02d0: 73 20 63 6f 6e 66 69 67 66 29 29 0a 28 64 65 63 s configf)).(dec 02e0: 6c 61 72 65 20 28 75 73 65 73 20 64 62 29 29 0a lare (uses db)). 02f0: 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f .(include "commo 0300: 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a n_records.scm"). 0310: 28 69 6e 63 6c 75 64 65 20 22 6b 65 79 5f 72 65 (include "key_re 0320: 63 6f 72 64 73 2e 73 63 6d 22 29 0a 28 69 6e 63 cords.scm").(inc 0330: 6c 75 64 65 20 22 64 62 5f 72 65 63 6f 72 64 73 lude "db_records 0340: 2e 73 63 6d 22 29 0a 0a 28 64 65 66 69 6e 65 20 .scm")..(define 0350: 28 6c 61 75 6e 63 68 3a 65 78 65 63 75 74 65 20 (launch:execute 0360: 65 6e 63 6f 64 65 64 2d 63 6d 64 29 0a 20 20 28 encoded-cmd). ( 0370: 6c 65 74 2a 20 28 28 63 6d 64 69 6e 66 6f 20 20 let* ((cmdinfo 0380: 20 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 (read (open-inp 0390: 75 74 2d 73 74 72 69 6e 67 20 28 62 61 73 65 36 ut-string (base6 03a0: 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 4:base64-decode 03b0: 65 6e 63 6f 64 65 64 2d 63 6d 64 29 29 29 29 29 encoded-cmd))))) 03c0: 0a 20 20 20 20 28 73 65 74 65 6e 76 20 22 4d 54 . (setenv "MT 03d0: 5f 43 4d 44 49 4e 46 4f 22 20 65 6e 63 6f 64 65 _CMDINFO" encode 03e0: 64 2d 63 6d 64 29 0a 20 20 20 20 28 69 66 20 28 d-cmd). (if ( 03f0: 6c 69 73 74 3f 20 63 6d 64 69 6e 66 6f 29 20 3b list? cmdinfo) ; 0400: 3b 20 28 28 74 65 73 74 70 61 74 68 20 2f 74 6d ; ((testpath /tm 0410: 70 2f 6d 72 77 65 6c 6c 61 6e 2f 6a 61 7a 7a 6d p/mrwellan/jazzm 0420: 69 6e 64 2f 73 72 63 2f 65 78 61 6d 70 6c 65 5f ind/src/example_ 0430: 72 75 6e 2f 74 65 73 74 73 2f 73 71 6c 69 74 65 run/tests/sqlite 0440: 73 70 65 65 64 29 20 28 74 65 73 74 2d 6e 61 6d speed) (test-nam 0450: 65 20 73 71 6c 69 74 65 73 70 65 65 64 29 20 28 e sqlitespeed) ( 0460: 72 75 6e 73 63 72 69 70 74 20 72 75 6e 73 63 72 runscript runscr 0470: 69 70 74 2e 72 62 29 20 28 64 62 2d 68 6f 73 74 ipt.rb) (db-host 0480: 20 6c 6f 63 61 6c 68 6f 73 74 29 20 28 72 75 6e localhost) (run 0490: 2d 69 64 20 31 29 29 0a 09 28 6c 65 74 2a 20 28 -id 1))..(let* ( 04a0: 28 74 65 73 74 70 61 74 68 20 20 28 61 73 73 6f (testpath (asso 04b0: 63 2f 64 65 66 61 75 6c 74 20 27 74 65 73 74 70 c/default 'testp 04c0: 61 74 68 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 ath cmdinfo)).. 04d0: 20 20 20 20 20 20 20 28 77 6f 72 6b 2d 61 72 65 (work-are 04e0: 61 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 a (assoc/default 04f0: 20 27 77 6f 72 6b 2d 61 72 65 61 20 63 6d 64 69 'work-area cmdi 0500: 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 74 nfo)).. (t 0510: 65 73 74 2d 6e 61 6d 65 20 28 61 73 73 6f 63 2f est-name (assoc/ 0520: 64 65 66 61 75 6c 74 20 27 74 65 73 74 2d 6e 61 default 'test-na 0530: 6d 65 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 me cmdinfo)).. 0540: 20 20 20 20 20 28 72 75 6e 73 63 72 69 70 74 20 (runscript 0550: 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 (assoc/default ' 0560: 72 75 6e 73 63 72 69 70 74 20 63 6d 64 69 6e 66 runscript cmdinf 0570: 6f 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 2d o)).. (db- 0580: 68 6f 73 74 20 20 20 28 61 73 73 6f 63 2f 64 65 host (assoc/de 0590: 66 61 75 6c 74 20 27 64 62 2d 68 6f 73 74 20 20 fault 'db-host 05a0: 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 cmdinfo)).. 05b0: 20 20 20 28 72 75 6e 2d 69 64 20 20 20 20 28 61 (run-id (a 05c0: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 27 72 75 ssoc/default 'ru 05d0: 6e 2d 69 64 20 20 20 20 63 6d 64 69 6e 66 6f 29 n-id cmdinfo) 05e0: 29 0a 09 20 20 20 20 20 20 20 28 69 74 65 6d 64 ).. (itemd 05f0: 61 74 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 at (assoc/defa 0600: 75 6c 74 20 27 69 74 65 6d 64 61 74 20 20 20 63 ult 'itemdat c 0610: 6d 64 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 mdinfo)).. 0620: 20 28 65 6e 76 2d 6f 76 72 64 20 20 28 61 73 73 (env-ovrd (ass 0630: 6f 63 2f 64 65 66 61 75 6c 74 20 27 65 6e 76 2d oc/default 'env- 0640: 6f 76 72 64 20 20 63 6d 64 69 6e 66 6f 29 29 0a ovrd cmdinfo)). 0650: 09 20 20 20 20 20 20 20 28 72 75 6e 6e 61 6d 65 . (runname 0660: 20 20 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c (assoc/defaul 0670: 74 20 27 72 75 6e 6e 61 6d 65 20 20 20 63 6d 64 t 'runname cmd 0680: 69 6e 66 6f 29 29 0a 09 20 20 20 20 20 20 20 28 info)).. ( 0690: 6d 65 67 61 74 65 73 74 20 20 28 61 73 73 6f 63 megatest (assoc 06a0: 2f 64 65 66 61 75 6c 74 20 27 6d 65 67 61 74 65 /default 'megate 06b0: 73 74 20 20 63 6d 64 69 6e 66 6f 29 29 0a 09 20 st cmdinfo)).. 06c0: 20 20 20 20 20 20 28 6d 74 2d 62 69 6e 64 69 72 (mt-bindir 06d0: 2d 70 61 74 68 20 28 61 73 73 6f 63 2f 64 65 66 -path (assoc/def 06e0: 61 75 6c 74 20 27 6d 74 2d 62 69 6e 64 69 72 2d ault 'mt-bindir- 06f0: 70 61 74 68 20 63 6d 64 69 6e 66 6f 29 29 0a 09 path cmdinfo)).. 0700: 20 20 20 20 20 20 20 28 66 75 6c 6c 72 75 6e 73 (fullruns 0710: 63 72 69 70 74 20 28 63 6f 6e 63 20 74 65 73 74 cript (conc test 0720: 70 61 74 68 20 22 2f 22 20 72 75 6e 73 63 72 69 path "/" runscri 0730: 70 74 29 29 0a 09 20 20 20 20 20 20 20 28 64 62 pt)).. (db 0740: 20 20 20 20 20 20 20 20 23 66 29 29 0a 09 20 20 #f)).. 0750: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 (debug:print 2 " 0760: 45 78 65 63 74 75 69 6e 67 20 22 20 74 65 73 74 Exectuing " test 0770: 2d 6e 61 6d 65 20 22 20 6f 6e 20 22 20 28 67 65 -name " on " (ge 0780: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 t-host-name)).. 0790: 20 28 63 68 61 6e 67 65 2d 64 69 72 65 63 74 6f (change-directo 07a0: 72 79 20 74 65 73 74 70 61 74 68 29 0a 09 20 20 ry testpath).. 07b0: 28 73 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 54 (setenv "MT_TEST 07c0: 5f 52 55 4e 5f 44 49 52 22 20 77 6f 72 6b 2d 61 _RUN_DIR" work-a 07d0: 72 65 61 29 0a 09 20 20 28 73 65 74 65 6e 76 20 rea).. (setenv 07e0: 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 20 74 "MT_TEST_NAME" t 07f0: 65 73 74 2d 6e 61 6d 65 29 0a 09 20 20 28 73 65 est-name).. (se 0800: 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d 5f 49 4e tenv "MT_ITEM_IN 0810: 46 4f 22 20 28 63 6f 6e 63 20 69 74 65 6d 64 61 FO" (conc itemda 0820: 74 29 29 0a 09 20 20 28 73 65 74 65 6e 76 20 22 t)).. (setenv " 0830: 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 20 20 72 75 MT_RUNNAME" ru 0840: 6e 6e 61 6d 65 29 0a 09 20 20 28 73 65 74 65 6e nname).. (seten 0850: 76 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 20 v "MT_MEGATEST" 0860: 20 6d 65 67 61 74 65 73 74 29 0a 09 20 20 28 69 megatest).. (i 0870: 66 20 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 f mt-bindir-path 0880: 20 28 73 65 74 65 6e 76 20 22 50 41 54 48 22 20 (setenv "PATH" 0890: 28 63 6f 6e 63 20 28 67 65 74 65 6e 76 20 22 50 (conc (getenv "P 08a0: 41 54 48 22 29 20 22 3a 22 20 6d 74 2d 62 69 6e ATH") ":" mt-bin 08b0: 64 69 72 2d 70 61 74 68 29 29 29 0a 09 20 20 0a dir-path))).. . 08c0: 09 20 20 28 69 66 20 28 6e 6f 74 20 28 73 65 74 . (if (not (set 08d0: 75 70 2d 66 6f 72 2d 72 75 6e 29 29 0a 09 20 20 up-for-run)).. 08e0: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 (begin...(de 08f0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 46 61 69 bug:print 0 "Fai 0900: 6c 65 64 20 74 6f 20 73 65 74 75 70 2c 20 65 78 led to setup, ex 0910: 69 74 69 6e 67 22 29 20 0a 09 09 28 65 78 69 74 iting") ...(exit 0920: 20 31 29 29 29 0a 09 20 20 3b 3b 20 6e 6f 77 20 1))).. ;; now 0930: 63 61 6e 20 66 69 6e 64 20 6f 75 72 20 64 62 0a can find our db. 0940: 09 20 20 28 73 65 74 21 20 64 62 20 28 6f 70 65 . (set! db (ope 0950: 6e 2d 64 62 29 29 0a 09 20 20 28 63 68 61 6e 67 n-db)).. (chang 0960: 65 2d 64 69 72 65 63 74 6f 72 79 20 77 6f 72 6b e-directory work 0970: 2d 61 72 65 61 29 20 0a 09 20 20 28 73 65 74 2d -area) .. (set- 0980: 72 75 6e 2d 63 6f 6e 66 69 67 2d 76 61 72 73 20 run-config-vars 0990: 64 62 20 72 75 6e 2d 69 64 29 0a 09 20 20 3b 3b db run-id).. ;; 09a0: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 6f 76 65 environment ove 09b0: 72 72 69 64 65 73 20 61 72 65 20 64 6f 6e 65 20 rrides are done 09c0: 2a 62 65 66 6f 72 65 2a 20 74 68 65 20 72 65 6d *before* the rem 09d0: 61 69 6e 69 6e 67 20 63 72 69 74 69 63 61 6c 20 aining critical 09e0: 65 6e 76 61 72 73 2e 0a 09 20 20 28 61 6c 69 73 envars... (alis 09f0: 74 2d 3e 65 6e 76 2d 76 61 72 73 20 65 6e 76 2d t->env-vars env- 0a00: 6f 76 72 64 29 0a 09 20 20 28 73 65 74 2d 6d 65 ovrd).. (set-me 0a10: 67 61 74 65 73 74 2d 65 6e 76 2d 76 61 72 73 20 gatest-env-vars 0a20: 64 62 20 72 75 6e 2d 69 64 29 0a 09 20 20 28 73 db run-id).. (s 0a30: 65 74 2d 69 74 65 6d 2d 65 6e 76 2d 76 61 72 73 et-item-env-vars 0a40: 20 69 74 65 6d 64 61 74 29 0a 09 20 20 28 73 61 itemdat).. (sa 0a50: 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 ve-environment-a 0a60: 73 2d 66 69 6c 65 73 20 22 6d 65 67 61 74 65 73 s-files "megates 0a70: 74 22 29 0a 09 20 20 28 74 65 73 74 2d 73 65 74 t").. (test-set 0a80: 2d 6d 65 74 61 2d 69 6e 66 6f 20 64 62 20 72 75 -meta-info db ru 0a90: 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 n-id test-name i 0aa0: 74 65 6d 64 61 74 29 0a 09 20 20 28 74 65 73 74 temdat).. (test 0ab0: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 62 20 -set-status! db 0ac0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name 0ad0: 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 "REMOTEHOSTSTAR 0ae0: 54 22 20 22 6e 2f 61 22 20 69 74 65 6d 64 61 74 T" "n/a" itemdat 0af0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg " 0b00: 2d 6d 22 29 20 23 66 29 0a 09 20 20 28 69 66 20 -m") #f).. (if 0b10: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "- 0b20: 78 74 65 72 6d 22 29 0a 09 20 20 20 20 20 20 28 xterm").. ( 0b30: 73 65 74 21 20 66 75 6c 6c 72 75 6e 73 63 72 69 set! fullrunscri 0b40: 70 74 20 22 78 74 65 72 6d 22 29 0a 09 20 20 20 pt "xterm").. 0b50: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 66 69 6c (if (not (fil 0b60: 65 2d 65 78 65 63 75 74 65 2d 61 63 63 65 73 73 e-execute-access 0b70: 3f 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 29 ? fullrunscript) 0b80: 29 0a 09 09 20 20 28 73 79 73 74 65 6d 20 28 63 )... (system (c 0b90: 6f 6e 63 20 22 63 68 6d 6f 64 20 75 67 2b 78 20 onc "chmod ug+x 0ba0: 22 20 66 75 6c 6c 72 75 6e 73 63 72 69 70 74 29 " fullrunscript) 0bb0: 29 29 29 0a 09 20 20 3b 3b 20 57 65 20 61 72 65 ))).. ;; We are 0bc0: 20 61 62 6f 75 74 20 74 6f 20 61 63 74 75 61 6c about to actual 0bd0: 6c 79 20 6b 69 63 6b 20 6f 66 66 20 74 68 65 20 ly kick off the 0be0: 74 65 73 74 0a 09 20 20 3b 3b 20 73 6f 20 74 68 test.. ;; so th 0bf0: 69 73 20 69 73 20 61 20 67 6f 6f 64 20 70 6c 61 is is a good pla 0c00: 63 65 20 74 6f 20 72 65 6d 6f 76 65 20 74 68 65 ce to remove the 0c10: 20 72 65 63 6f 72 64 73 20 66 6f 72 20 0a 09 20 records for .. 0c20: 20 3b 3b 20 61 6e 79 20 70 72 65 76 69 6f 75 73 ;; any previous 0c30: 20 72 75 6e 73 0a 09 20 20 3b 3b 20 28 64 62 3a runs.. ;; (db: 0c40: 74 65 73 74 2d 72 65 6d 6f 76 65 2d 73 74 65 70 test-remove-step 0c50: 73 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 s db run-id test 0c60: 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 09 20 name itemdat).. 0c70: 20 0a 09 20 20 3b 3b 20 66 72 6f 6d 20 68 65 72 .. ;; from her 0c80: 65 20 6f 6e 20 6f 75 74 20 77 65 20 77 69 6c 6c e on out we will 0c90: 20 6f 70 65 6e 20 61 6e 64 20 63 6c 6f 73 65 20 open and close 0ca0: 74 68 65 20 64 62 0a 09 20 20 3b 3b 20 6f 6e 20 the db.. ;; on 0cb0: 65 76 65 72 79 20 61 63 63 65 73 73 20 74 6f 20 every access to 0cc0: 72 65 64 75 63 65 20 74 68 65 20 70 72 6f 62 61 reduce the proba 0cd0: 62 6c 69 74 69 79 20 6f 66 20 0a 09 20 20 3b 3b blitiy of .. ;; 0ce0: 20 63 6f 6e 74 65 6e 74 69 6f 6e 20 6f 72 20 73 contention or s 0cf0: 74 75 63 6b 20 61 63 63 65 73 73 20 6f 6e 20 6e tuck access on n 0d00: 66 73 2e 0a 09 20 20 28 73 71 6c 69 74 65 33 3a fs... (sqlite3: 0d10: 66 69 6e 61 6c 69 7a 65 21 20 64 62 29 0a 0a 09 finalize! db)... 0d20: 20 20 28 6c 65 74 2a 20 28 28 6d 20 20 20 20 20 (let* ((m 0d30: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 (make-mut 0d40: 65 78 29 29 0a 09 09 20 28 6b 69 6c 6c 2d 6a 6f ex))... (kill-jo 0d50: 62 3f 20 20 20 20 23 66 29 0a 09 09 20 28 65 78 b? #f)... (ex 0d60: 69 74 2d 69 6e 66 6f 20 20 20 20 28 6d 61 6b 65 it-info (make 0d70: 2d 76 65 63 74 6f 72 20 33 29 29 0a 09 09 20 28 -vector 3))... ( 0d80: 6a 6f 62 2d 74 68 72 65 61 64 20 20 20 23 66 29 job-thread #f) 0d90: 0a 09 09 20 28 72 75 6e 69 74 20 20 20 20 20 20 ... (runit 0da0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 (lambda ().... 0db0: 09 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 65 73 . ;; (let-values 0dc0: 0a 09 09 09 09 20 3b 3b 20 20 28 28 28 70 69 64 ..... ;; (((pid 0dd0: 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 exit-status exi 0de0: 74 2d 63 6f 64 65 29 0a 09 09 09 09 20 3b 3b 20 t-code)..... ;; 0df0: 20 20 20 28 72 75 6e 2d 6e 2d 77 61 69 74 20 66 (run-n-wait f 0e00: 75 6c 6c 72 75 6e 73 63 72 69 70 74 29 29 29 0a ullrunscript))). 0e10: 09 09 09 09 20 28 6c 65 74 20 28 28 70 69 64 20 .... (let ((pid 0e20: 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 66 75 6c (process-run ful 0e30: 6c 72 75 6e 73 63 72 69 70 74 29 29 29 0a 09 09 lrunscript)))... 0e40: 09 09 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 .. (let loop ( 0e50: 28 69 20 30 29 29 0a 09 09 09 09 20 20 20 20 20 (i 0))..... 0e60: 28 6c 65 74 2d 76 61 6c 75 65 73 0a 09 09 09 09 (let-values..... 0e70: 20 20 20 20 20 20 28 28 28 70 69 64 2d 76 61 6c (((pid-val 0e80: 20 65 78 69 74 2d 73 74 61 74 75 73 20 65 78 69 exit-status exi 0e90: 74 2d 63 6f 64 65 29 20 28 70 72 6f 63 65 73 73 t-code) (process 0ea0: 2d 77 61 69 74 20 70 69 64 20 23 74 29 29 29 0a -wait pid #t))). 0eb0: 09 09 09 09 20 20 20 20 20 20 28 6d 75 74 65 78 .... (mutex 0ec0: 2d 6c 6f 63 6b 21 20 6d 29 0a 09 09 09 09 20 20 -lock! m)..... 0ed0: 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set! 0ee0: 20 65 78 69 74 2d 69 6e 66 6f 20 30 20 70 69 64 exit-info 0 pid 0ef0: 29 0a 09 09 09 09 20 20 20 20 20 20 28 76 65 63 )..... (vec 0f00: 74 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e tor-set! exit-in 0f10: 66 6f 20 31 20 65 78 69 74 2d 73 74 61 74 75 73 fo 1 exit-status 0f20: 29 0a 09 09 09 09 20 20 20 20 20 20 28 76 65 63 )..... (vec 0f30: 74 6f 72 2d 73 65 74 21 20 65 78 69 74 2d 69 6e tor-set! exit-in 0f40: 66 6f 20 32 20 65 78 69 74 2d 63 6f 64 65 29 0a fo 2 exit-code). 0f50: 09 09 09 09 20 20 20 20 20 20 28 6d 75 74 65 78 .... (mutex 0f60: 2d 75 6e 6c 6f 63 6b 21 20 6d 29 0a 09 09 09 09 -unlock! m)..... 0f70: 20 20 20 20 20 20 28 69 66 20 28 65 71 3f 20 70 (if (eq? p 0f80: 69 64 2d 76 61 6c 20 30 29 0a 09 09 09 09 09 20 id-val 0)...... 0f90: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 (begin...... 0fa0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep! 0fb0: 32 29 0a 09 09 09 09 09 20 20 20 20 28 6c 6f 6f 2)...... (loo 0fc0: 70 20 28 2b 20 69 20 31 29 29 29 0a 09 09 09 09 p (+ i 1)))..... 0fd0: 09 20 20 29 29 29 29 29 29 0a 09 09 20 28 6d 6f . ))))))... (mo 0fe0: 6e 69 74 6f 72 6a 6f 62 20 20 20 28 6c 61 6d 62 nitorjob (lamb 0ff0: 64 61 20 28 29 0a 09 09 09 09 20 28 6c 65 74 2a da ()..... (let* 1000: 20 28 28 73 74 61 72 74 2d 73 65 63 6f 6e 64 73 ((start-seconds 1010: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second 1020: 73 29 29 0a 09 09 09 09 09 28 63 61 6c 63 2d 6d s))......(calc-m 1030: 69 6e 75 74 65 73 20 20 28 6c 61 6d 62 64 61 20 inutes (lambda 1040: 28 29 0a 09 09 09 09 09 09 09 20 28 69 6e 65 78 ()........ (inex 1050: 61 63 74 2d 3e 65 78 61 63 74 20 0a 09 09 09 09 act->exact ..... 1060: 09 09 09 20 20 28 72 6f 75 6e 64 20 0a 09 09 09 ... (round .... 1070: 09 09 09 09 20 20 20 28 2d 20 0a 09 09 09 09 09 .... (- ...... 1080: 09 09 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 .. (current-s 1090: 65 63 6f 6e 64 73 29 20 0a 09 09 09 09 09 09 09 econds) ........ 10a0: 20 20 20 20 73 74 61 72 74 2d 73 65 63 6f 6e 64 start-second 10b0: 73 29 29 29 29 29 0a 09 09 09 09 09 28 6b 69 6c s)))))......(kil 10c0: 6c 2d 74 72 69 65 73 20 30 29 29 0a 09 09 09 09 l-tries 0))..... 10d0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6d (let loop ((m 10e0: 69 6e 75 74 65 73 20 20 20 28 63 61 6c 63 2d 6d inutes (calc-m 10f0: 69 6e 75 74 65 73 29 29 29 0a 09 09 09 09 20 20 inutes)))..... 1100: 20 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 (let* ((db 1110: 20 20 20 20 28 6f 70 65 6e 2d 64 62 29 29 0a 09 (open-db)).. 1120: 09 09 09 09 20 20 20 20 28 63 70 75 6c 6f 61 64 .... (cpuload 1130: 20 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 (get-cpu-load) 1140: 29 0a 09 09 09 09 09 20 20 20 20 28 64 69 73 6b )...... (disk 1150: 66 72 65 65 20 28 67 65 74 2d 64 66 20 28 63 75 free (get-df (cu 1160: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory) 1170: 29 29 0a 09 09 09 09 09 20 20 20 20 28 74 6d 70 ))...... (tmp 1180: 66 72 65 65 20 20 28 67 65 74 2d 64 66 20 22 2f free (get-df "/ 1190: 74 6d 70 22 29 29 29 0a 09 09 09 09 20 20 20 20 tmp")))..... 11a0: 20 20 20 28 69 66 20 28 6e 6f 74 20 63 70 75 6c (if (not cpul 11b0: 6f 61 64 29 20 20 28 62 65 67 69 6e 20 28 64 65 oad) (begin (de 11c0: 62 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 bug:print 0 "WAR 11d0: 4e 49 4e 47 3a 20 43 50 55 4c 4f 41 44 20 6e 6f NING: CPULOAD no 11e0: 74 20 66 6f 75 6e 64 2e 22 29 20 20 28 73 65 74 t found.") (set 11f0: 21 20 63 70 75 6c 6f 61 64 20 22 6e 2f 61 22 29 ! cpuload "n/a") 1200: 29 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 69 ))..... (i 1210: 66 20 28 6e 6f 74 20 64 69 73 6b 66 72 65 65 29 f (not diskfree) 1220: 20 28 62 65 67 69 6e 20 28 64 65 62 75 67 3a 70 (begin (debug:p 1230: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING: 1240: 20 44 49 53 4b 46 52 45 45 20 6e 6f 74 20 66 6f DISKFREE not fo 1250: 75 6e 64 2e 22 29 20 28 73 65 74 21 20 64 69 73 und.") (set! dis 1260: 6b 66 72 65 65 20 22 6e 2f 61 22 29 29 29 0a 09 kfree "n/a"))).. 1270: 09 09 09 20 20 20 20 20 20 20 28 73 65 74 21 20 ... (set! 1280: 6b 69 6c 6c 2d 6a 6f 62 3f 20 28 74 65 73 74 2d kill-job? (test- 1290: 67 65 74 2d 6b 69 6c 6c 2d 72 65 71 75 65 73 74 get-kill-request 12a0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test- 12b0: 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 29 0a 09 name itemdat)).. 12c0: 09 09 09 20 20 20 20 20 20 20 28 74 65 73 74 2d ... (test- 12d0: 75 70 64 61 74 65 2d 6d 65 74 61 2d 69 6e 66 6f update-meta-info 12e0: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test- 12f0: 6e 61 6d 65 20 69 74 65 6d 64 61 74 20 6d 69 6e name itemdat min 1300: 75 74 65 73 20 63 70 75 6c 6f 61 64 20 64 69 73 utes cpuload dis 1310: 6b 66 72 65 65 20 74 6d 70 66 72 65 65 29 0a 09 kfree tmpfree).. 1320: 09 09 09 20 20 20 20 20 20 20 28 69 66 20 6b 69 ... (if ki 1330: 6c 6c 2d 6a 6f 62 3f 20 0a 09 09 09 09 09 20 20 ll-job? ...... 1340: 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 20 (begin...... 1350: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 6d (mutex-lock! m 1360: 29 0a 09 09 09 09 09 20 20 20 20 20 28 6c 65 74 )...... (let 1370: 2a 20 28 28 70 69 64 20 28 76 65 63 74 6f 72 2d * ((pid (vector- 1380: 72 65 66 20 65 78 69 74 2d 69 6e 66 6f 20 30 29 ref exit-info 0) 1390: 29 29 0a 09 09 09 09 09 20 20 20 20 20 20 20 28 ))...... ( 13a0: 69 66 20 28 6e 75 6d 62 65 72 3f 20 70 69 64 29 if (number? pid) 13b0: 0a 09 09 09 09 09 09 20 20 20 28 62 65 67 69 6e ....... (begin 13c0: 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb 13d0: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN 13e0: 49 4e 47 3a 20 52 65 71 75 65 73 74 20 72 65 63 ING: Request rec 13f0: 65 69 76 65 64 20 74 6f 20 6b 69 6c 6c 20 6a 6f eived to kill jo 1400: 62 20 28 61 74 74 65 6d 70 74 20 23 20 22 20 6b b (attempt # " k 1410: 69 6c 6c 2d 74 72 69 65 73 20 22 29 22 29 0a 09 ill-tries ")").. 1420: 09 09 09 09 09 20 20 20 20 20 28 6c 65 74 20 28 ..... (let ( 1430: 28 70 72 6f 63 65 73 73 65 73 20 28 63 6d 64 2d (processes (cmd- 1440: 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 run->list (conc 1450: 22 70 67 72 65 70 20 2d 6c 20 2d 50 20 22 20 70 "pgrep -l -P " p 1460: 69 64 29 29 29 29 0a 09 09 09 09 09 09 20 20 20 id))))....... 1470: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 (for-each .. 1480: 09 09 09 09 09 09 28 6c 61 6d 62 64 61 20 28 70 ......(lambda (p 1490: 29 0a 09 09 09 09 09 09 09 20 20 28 6c 65 74 2a )........ (let* 14a0: 20 28 28 70 61 72 74 73 20 20 28 73 74 72 69 6e ((parts (strin 14b0: 67 2d 73 70 6c 69 74 20 70 29 29 0a 09 09 09 09 g-split p))..... 14c0: 09 09 09 09 20 28 70 2d 69 64 20 20 20 28 69 66 .... (p-id (if 14d0: 20 28 3e 20 28 6c 65 6e 67 74 68 20 70 61 72 74 (> (length part 14e0: 73 29 20 30 29 0a 09 09 09 09 09 09 09 09 09 20 s) 0).......... 14f0: 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d (string->num 1500: 62 65 72 20 28 63 61 72 20 70 61 72 74 73 29 29 ber (car parts)) 1510: 0a 09 09 09 09 09 09 09 09 09 20 20 20 20 20 23 .......... # 1520: 66 29 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 f)))........ 1530: 28 69 66 20 70 2d 69 64 0a 09 09 09 09 09 09 09 (if p-id........ 1540: 09 28 62 65 67 69 6e 0a 09 09 09 09 09 09 09 09 .(begin......... 1550: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0 1560: 20 22 4b 69 6c 6c 69 6e 67 20 22 20 28 63 61 64 "Killing " (cad 1570: 72 20 70 61 72 74 73 29 20 22 3b 20 6b 69 6c 6c r parts) "; kill 1580: 20 2d 39 20 20 22 20 70 2d 69 64 29 0a 09 09 09 -9 " p-id).... 1590: 09 09 09 09 09 20 20 28 73 79 73 74 65 6d 20 28 ..... (system ( 15a0: 63 6f 6e 63 20 22 6b 69 6c 6c 20 2d 39 20 22 20 conc "kill -9 " 15b0: 70 2d 69 64 29 29 29 29 29 29 0a 09 09 09 09 09 p-id))))))...... 15c0: 09 09 28 63 61 72 20 70 72 6f 63 65 73 73 65 73 ..(car processes 15d0: 29 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 20 ))....... 15e0: 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 6b (system (conc "k 15f0: 69 6c 6c 20 2d 39 20 22 20 70 69 64 29 29 29 29 ill -9 " pid)))) 1600: 0a 09 09 09 09 09 09 20 20 20 28 62 65 67 69 6e ....... (begin 1610: 0a 09 09 09 09 09 09 20 20 20 20 20 28 64 65 62 ....... (deb 1620: 75 67 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e ug:print 0 "WARN 1630: 49 4e 47 3a 20 52 65 71 75 65 73 74 20 72 65 63 ING: Request rec 1640: 65 69 76 65 64 20 74 6f 20 6b 69 6c 6c 20 6a 6f eived to kill jo 1650: 62 20 62 75 74 20 70 72 6f 62 6c 65 6d 20 77 69 b but problem wi 1660: 74 68 20 70 72 6f 63 65 73 73 2c 20 61 74 74 65 th process, atte 1670: 6d 70 74 69 6e 67 20 74 6f 20 6b 69 6c 6c 20 6d mpting to kill m 1680: 61 6e 61 67 65 72 20 70 72 6f 63 65 73 73 22 29 anager process") 1690: 0a 09 09 09 09 09 09 20 20 20 20 20 28 74 65 73 ....... (tes 16a0: 74 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 62 t-set-status! db 16b0: 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d run-id test-nam 16c0: 65 20 22 4b 49 4c 4c 45 44 22 20 20 22 46 41 49 e "KILLED" "FAI 16d0: 4c 22 0a 09 09 09 09 09 09 09 09 20 20 20 20 20 L"......... 16e0: 20 20 69 74 65 6d 64 61 74 20 28 61 72 67 73 3a itemdat (args: 16f0: 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 20 23 66 get-arg "-m") #f 1700: 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 73 71 )....... (sq 1710: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize! 1720: 64 62 29 0a 09 09 09 09 09 09 20 20 20 20 20 28 db)....... ( 1730: 65 78 69 74 20 31 29 29 29 29 0a 09 09 09 09 09 exit 1))))...... 1740: 20 20 20 20 20 28 73 65 74 21 20 6b 69 6c 6c 2d (set! kill- 1750: 74 72 69 65 73 20 28 2b 20 31 20 6b 69 6c 6c 2d tries (+ 1 kill- 1760: 74 72 69 65 73 29 29 0a 09 09 09 09 09 20 20 20 tries))...... 1770: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock! 1780: 20 6d 29 29 29 0a 09 09 09 09 20 20 20 20 20 20 m)))..... 1790: 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 (sqlite3:finali 17a0: 7a 65 21 20 64 62 29 0a 09 09 09 09 20 20 20 20 ze! db)..... 17b0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep 17c0: 21 20 28 2b 20 38 20 28 72 61 6e 64 6f 6d 20 34 ! (+ 8 (random 4 17d0: 29 29 29 20 3b 3b 20 61 64 64 20 73 6f 6d 65 20 ))) ;; add some 17e0: 6a 69 74 74 65 72 20 74 6f 20 74 68 65 20 63 61 jitter to the ca 17f0: 6c 6c 20 68 6f 6d 65 20 74 69 6d 65 20 74 6f 20 ll home time to 1800: 73 70 72 65 61 64 20 6f 75 74 20 74 68 65 20 64 spread out the d 1810: 62 20 61 63 63 65 73 73 65 73 0a 09 09 09 09 20 b accesses..... 1820: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 6c (loop (cal 1830: 63 2d 6d 69 6e 75 74 65 73 29 29 29 29 29 29 29 c-minutes))))))) 1840: 0a 09 09 20 28 74 68 31 20 20 20 20 20 20 20 20 ... (th1 1850: 20 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 6d (make-thread m 1860: 6f 6e 69 74 6f 72 6a 6f 62 29 29 0a 09 09 20 28 onitorjob))... ( 1870: 74 68 32 20 20 20 20 20 20 20 20 20 20 28 6d 61 th2 (ma 1880: 6b 65 2d 74 68 72 65 61 64 20 72 75 6e 69 74 29 ke-thread runit) 1890: 29 29 0a 09 20 20 20 20 28 73 65 74 21 20 6a 6f )).. (set! jo 18a0: 62 2d 74 68 72 65 61 64 20 74 68 32 29 0a 09 20 b-thread th2).. 18b0: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start 18c0: 21 20 74 68 31 29 0a 09 20 20 20 20 28 74 68 72 ! th1).. (thr 18d0: 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a ead-start! th2). 18e0: 09 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 . (thread-joi 18f0: 6e 21 20 74 68 32 29 0a 09 20 20 20 20 28 6d 75 n! th2).. (mu 1900: 74 65 78 2d 6c 6f 63 6b 21 20 6d 29 0a 09 20 20 tex-lock! m).. 1910: 20 20 28 73 65 74 21 20 64 62 20 28 6f 70 65 6e (set! db (open 1920: 2d 64 62 29 29 0a 09 20 20 20 20 28 6c 65 74 2a -db)).. (let* 1930: 20 28 28 69 74 65 6d 2d 70 61 74 68 20 28 69 74 ((item-path (it 1940: 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 74 em-list->path it 1950: 65 6d 64 61 74 29 29 0a 09 09 20 20 20 28 74 65 emdat))... (te 1960: 73 74 69 6e 66 6f 20 20 28 64 62 3a 67 65 74 2d stinfo (db:get- 1970: 74 65 73 74 2d 69 6e 66 6f 20 64 62 20 72 75 6e test-info db run 1980: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 -id test-name it 1990: 65 6d 2d 70 61 74 68 29 29 29 0a 09 20 20 20 20 em-path))).. 19a0: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 75 61 (if (not (equa 19b0: 6c 3f 20 28 64 62 3a 74 65 73 74 2d 67 65 74 2d l? (db:test-get- 19c0: 73 74 61 74 65 20 74 65 73 74 69 6e 66 6f 29 20 state testinfo) 19d0: 22 43 4f 4d 50 4c 45 54 45 44 22 29 29 0a 09 09 "COMPLETED"))... 19e0: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 (begin... ( 19f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 22 54 debug:print 2 "T 1a00: 65 73 74 20 4e 4f 54 20 6c 6f 67 67 65 64 20 61 est NOT logged a 1a10: 73 20 43 4f 4d 50 4c 45 54 45 44 2c 20 28 73 74 s COMPLETED, (st 1a20: 61 74 65 3d 22 20 28 64 62 3a 74 65 73 74 2d 67 ate=" (db:test-g 1a30: 65 74 2d 73 74 61 74 65 20 74 65 73 74 69 6e 66 et-state testinf 1a40: 6f 29 20 22 29 2c 20 75 70 64 61 74 69 6e 67 20 o) "), updating 1a50: 72 65 73 75 6c 74 22 29 0a 09 09 20 20 20 20 28 result")... ( 1a60: 74 65 73 74 2d 73 65 74 2d 73 74 61 74 75 73 21 test-set-status! 1a70: 20 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d db run-id test- 1a80: 6e 61 6d 65 0a 09 09 09 09 20 20 20 20 20 20 28 name..... ( 1a90: 69 66 20 6b 69 6c 6c 2d 6a 6f 62 3f 20 22 4b 49 if kill-job? "KI 1aa0: 4c 4c 45 44 22 20 22 43 4f 4d 50 4c 45 54 45 44 LLED" "COMPLETED 1ab0: 22 29 0a 09 09 09 09 20 20 20 20 20 20 28 69 66 ")..... (if 1ac0: 20 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 (vector-ref exi 1ad0: 74 2d 69 6e 66 6f 20 31 29 20 3b 3b 20 6c 6f 6f t-info 1) ;; loo 1ae0: 6b 20 61 74 20 74 68 65 20 65 78 69 74 2d 73 74 k at the exit-st 1af0: 61 74 75 73 0a 09 09 09 09 09 20 20 28 69 66 20 atus...... (if 1b00: 28 61 6e 64 20 28 6e 6f 74 20 6b 69 6c 6c 2d 6a (and (not kill-j 1b10: 6f 62 3f 29 20 0a 09 09 09 09 09 09 20 20 20 28 ob?) ....... ( 1b20: 65 71 3f 20 28 76 65 63 74 6f 72 2d 72 65 66 20 eq? (vector-ref 1b30: 65 78 69 74 2d 69 6e 66 6f 20 32 29 20 30 29 29 exit-info 2) 0)) 1b40: 0a 09 09 09 09 09 20 20 20 20 20 20 22 50 41 53 ...... "PAS 1b50: 53 22 0a 09 09 09 09 09 20 20 20 20 20 20 22 46 S"...... "F 1b60: 41 49 4c 22 29 0a 09 09 09 09 09 20 20 22 46 41 AIL")...... "FA 1b70: 49 4c 22 29 20 69 74 65 6d 64 61 74 20 28 61 72 IL") itemdat (ar 1b80: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 22 29 gs:get-arg "-m") 1b90: 20 23 66 29 29 29 0a 09 20 20 20 20 20 20 3b 3b #f))).. ;; 1ba0: 20 66 6f 72 20 61 75 74 6f 6d 61 74 65 64 20 63 for automated c 1bb0: 72 65 61 74 69 6f 6e 20 6f 66 20 74 68 65 20 72 reation of the r 1bc0: 6f 6c 6c 75 70 20 68 74 6d 6c 20 66 69 6c 65 20 ollup html file 1bd0: 74 68 69 73 20 69 73 20 61 20 67 6f 6f 64 20 70 this is a good p 1be0: 6c 61 63 65 2e 2e 2e 0a 09 20 20 20 20 20 20 28 lace..... ( 1bf0: 69 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 if (not (equal? 1c00: 69 74 65 6d 2d 70 61 74 68 20 22 22 29 29 0a 09 item-path "")).. 1c10: 09 20 20 28 74 65 73 74 73 3a 73 75 6d 6d 61 72 . (tests:summar 1c20: 69 7a 65 2d 69 74 65 6d 73 20 64 62 20 72 75 6e ize-items db run 1c30: 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 20 23 66 -id test-name #f 1c40: 29 29 20 3b 3b 20 64 6f 6e 27 74 20 66 6f 72 63 )) ;; don't forc 1c50: 65 20 2d 20 6a 75 73 74 20 75 70 64 61 74 65 20 e - just update 1c60: 69 66 20 6e 6f 0a 09 20 20 20 20 20 20 29 0a 09 if no.. ).. 1c70: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc 1c80: 6b 21 20 6d 29 0a 09 20 20 20 20 3b 3b 20 28 65 k! m).. ;; (e 1c90: 78 65 63 2d 72 65 73 75 6c 74 73 20 28 63 6d 64 xec-results (cmd 1ca0: 2d 72 75 6e 2d 3e 6c 69 73 74 20 66 75 6c 6c 72 -run->list fullr 1cb0: 75 6e 73 63 72 69 70 74 29 29 20 3b 3b 20 20 28 unscript)) ;; ( 1cc0: 6c 69 73 74 20 22 3e 22 20 28 63 6f 6e 63 20 74 list ">" (conc t 1cd0: 65 73 74 2d 6e 61 6d 65 20 22 2d 72 75 6e 2e 6c est-name "-run.l 1ce0: 6f 67 22 29 29 29 29 0a 09 20 20 20 20 3b 3b 20 og")))).. ;; 1cf0: 28 73 75 63 63 65 73 73 20 20 20 20 20 20 65 78 (success ex 1d00: 65 63 2d 72 65 73 75 6c 74 73 29 29 20 3b 3b 20 ec-results)) ;; 1d10: 28 65 71 3f 20 28 63 61 64 72 20 65 78 65 63 2d (eq? (cadr exec- 1d20: 72 65 73 75 6c 74 73 29 20 30 29 29 29 0a 09 20 results) 0))).. 1d30: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print 1d40: 32 20 22 4f 75 74 70 75 74 20 66 72 6f 6d 20 72 2 "Output from r 1d50: 75 6e 6e 69 6e 67 20 22 20 66 75 6c 6c 72 75 6e unning " fullrun 1d60: 73 63 72 69 70 74 20 22 2c 20 70 69 64 20 22 20 script ", pid " 1d70: 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 (vector-ref exit 1d80: 2d 69 6e 66 6f 20 30 29 20 22 20 69 6e 20 77 6f -info 0) " in wo 1d90: 72 6b 20 61 72 65 61 20 22 20 0a 09 09 09 20 77 rk area " .... w 1da0: 6f 72 6b 2d 61 72 65 61 20 22 3a 5c 6e 3d 3d 3d ork-area ":\n=== 1db0: 3d 5c 6e 20 65 78 69 74 20 63 6f 64 65 20 22 20 =\n exit code " 1dc0: 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 69 74 (vector-ref exit 1dd0: 2d 69 6e 66 6f 20 32 29 20 22 5c 6e 22 20 22 3d -info 2) "\n" "= 1de0: 3d 3d 3d 5c 6e 22 29 0a 09 20 20 20 20 28 73 71 ===\n").. (sq 1df0: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize! 1e00: 64 62 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f db).. (if (no 1e10: 74 20 28 76 65 63 74 6f 72 2d 72 65 66 20 65 78 t (vector-ref ex 1e20: 69 74 2d 69 6e 66 6f 20 31 29 29 0a 09 09 28 65 it-info 1))...(e 1e30: 78 69 74 20 34 29 29 29 29 29 29 29 0a 0a 28 64 xit 4)))))))..(d 1e40: 65 66 69 6e 65 20 28 73 65 74 75 70 2d 66 6f 72 efine (setup-for 1e50: 2d 72 75 6e 29 0a 20 20 28 73 65 74 21 20 2a 63 -run). (set! *c 1e60: 6f 6e 66 69 67 69 6e 66 6f 2a 20 28 66 69 6e 64 onfiginfo* (find 1e70: 2d 61 6e 64 2d 72 65 61 64 2d 63 6f 6e 66 69 67 -and-read-config 1e80: 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a 1e90: 72 67 20 22 2d 63 6f 6e 66 69 67 22 29 28 61 72 rg "-config")(ar 1ea0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 63 6f 6e gs:get-arg "-con 1eb0: 66 69 67 22 29 20 22 6d 65 67 61 74 65 73 74 2e fig") "megatest. 1ec0: 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 28 73 65 config"))). (se 1ed0: 74 21 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 20 t! *configdat* 1ee0: 28 69 66 20 28 63 61 72 20 2a 63 6f 6e 66 69 67 (if (car *config 1ef0: 69 6e 66 6f 2a 29 28 63 61 72 20 2a 63 6f 6e 66 info*)(car *conf 1f00: 69 67 69 6e 66 6f 2a 29 20 23 66 29 29 0a 20 20 iginfo*) #f)). 1f10: 28 73 65 74 21 20 2a 74 6f 70 70 61 74 68 2a 20 (set! *toppath* 1f20: 20 20 20 28 69 66 20 28 63 61 72 20 2a 63 6f 6e (if (car *con 1f30: 66 69 67 69 6e 66 6f 2a 29 28 63 61 64 72 20 2a figinfo*)(cadr * 1f40: 63 6f 6e 66 69 67 69 6e 66 6f 2a 29 20 23 66 29 configinfo*) #f) 1f50: 29 0a 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 ). (if *toppath 1f60: 2a 0a 20 20 20 20 20 20 28 73 65 74 65 6e 76 20 *. (setenv 1f70: 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d "MT_RUN_AREA_HOM 1f80: 45 22 20 2a 74 6f 70 70 61 74 68 2a 29 20 3b 3b E" *toppath*) ;; 1f90: 20 74 6f 20 62 65 20 64 65 70 72 65 63 61 74 65 to be deprecate 1fa0: 64 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 d. (debug:p 1fb0: 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a 20 66 rint 0 "ERROR: f 1fc0: 61 69 6c 65 64 20 74 6f 20 66 69 6e 64 20 74 68 ailed to find th 1fd0: 65 20 74 6f 70 20 70 61 74 68 20 74 6f 20 79 6f e top path to yo 1fe0: 75 72 20 72 75 6e 20 73 65 74 75 70 2e 22 29 29 ur run setup.")) 1ff0: 0a 20 20 2a 74 6f 70 70 61 74 68 2a 29 0a 0a 28 . *toppath*)..( 2000: 64 65 66 69 6e 65 20 28 67 65 74 2d 62 65 73 74 define (get-best 2010: 2d 64 69 73 6b 20 63 6f 6e 66 64 61 74 29 0a 20 -disk confdat). 2020: 20 28 6c 65 74 2a 20 28 28 64 69 73 6b 73 20 20 (let* ((disks 2030: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re 2040: 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 64 61 f/default confda 2050: 74 20 22 64 69 73 6b 73 22 20 23 66 29 29 0a 09 t "disks" #f)).. 2060: 20 28 62 65 73 74 20 20 20 20 20 23 66 29 0a 09 (best #f).. 2070: 20 28 62 65 73 74 73 69 7a 65 20 30 29 29 0a 20 (bestsize 0)). 2080: 20 20 20 28 69 66 20 64 69 73 6b 73 20 0a 09 28 (if disks ..( 2090: 66 6f 72 2d 65 61 63 68 20 0a 09 20 28 6c 61 6d for-each .. (lam 20a0: 62 64 61 20 28 64 69 73 6b 2d 6e 75 6d 29 0a 09 bda (disk-num).. 20b0: 20 20 20 28 6c 65 74 2a 20 28 28 64 69 72 70 61 (let* ((dirpa 20c0: 74 68 20 20 20 20 28 63 61 64 72 20 28 61 73 73 th (cadr (ass 20d0: 6f 63 20 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b oc disk-num disk 20e0: 73 29 29 29 0a 09 09 20 20 28 66 72 65 65 73 70 s)))... (freesp 20f0: 63 20 20 20 20 28 69 66 20 28 64 69 72 65 63 74 c (if (direct 2100: 6f 72 79 3f 20 64 69 72 70 61 74 68 29 0a 09 09 ory? dirpath)... 2110: 09 09 20 20 28 67 65 74 2d 64 66 20 64 69 72 70 .. (get-df dirp 2120: 61 74 68 29 0a 09 09 09 09 20 20 28 62 65 67 69 ath)..... (begi 2130: 6e 0a 09 09 09 09 20 20 20 20 28 64 65 62 75 67 n..... (debug 2140: 3a 70 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e :print 0 "WARNIN 2150: 47 3a 20 70 61 74 68 20 22 20 64 69 72 70 61 74 G: path " dirpat 2160: 68 20 22 20 69 6e 20 5b 64 69 73 6b 73 5d 20 73 h " in [disks] s 2170: 65 63 74 69 6f 6e 20 6e 6f 74 20 76 61 6c 69 64 ection not valid 2180: 22 29 0a 09 09 09 09 20 20 20 20 30 29 29 29 29 ")..... 0)))) 2190: 0a 09 20 20 20 20 20 28 69 66 20 28 3e 20 66 72 .. (if (> fr 21a0: 65 65 73 70 63 20 62 65 73 74 73 69 7a 65 29 0a eespc bestsize). 21b0: 09 09 20 28 62 65 67 69 6e 0a 09 09 20 20 20 28 .. (begin... ( 21c0: 73 65 74 21 20 62 65 73 74 20 20 20 20 20 64 69 set! best di 21d0: 72 70 61 74 68 29 0a 09 09 20 20 20 28 73 65 74 rpath)... (set 21e0: 21 20 62 65 73 74 73 69 7a 65 20 66 72 65 65 73 ! bestsize frees 21f0: 70 63 29 29 29 29 29 0a 09 20 28 6d 61 70 20 63 pc))))).. (map c 2200: 61 72 20 64 69 73 6b 73 29 29 29 0a 20 20 20 20 ar disks))). 2210: 28 69 66 20 62 65 73 74 0a 09 62 65 73 74 0a 09 (if best..best.. 2220: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug 2230: 3a 70 72 69 6e 74 20 30 20 22 45 52 52 4f 52 3a :print 0 "ERROR: 2240: 20 4e 6f 20 76 61 6c 69 64 20 64 69 73 6b 73 20 No valid disks 2250: 66 6f 75 6e 64 20 69 6e 20 6d 65 67 61 74 65 73 found in megates 2260: 74 2e 63 6f 6e 66 69 67 2e 20 50 6c 65 61 73 65 t.config. Please 2270: 20 61 64 64 20 73 6f 6d 65 20 74 6f 20 79 6f 75 add some to you 2280: 72 20 5b 64 69 73 6b 73 5d 20 73 65 63 74 69 6f r [disks] sectio 2290: 6e 22 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 n").. (exit 1)) 22a0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 72 )))..(define (cr 22b0: 65 61 74 65 2d 77 6f 72 6b 2d 61 72 65 61 20 64 eate-work-area d 22c0: 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 70 61 b run-id test-pa 22d0: 74 68 20 64 69 73 6b 2d 70 61 74 68 20 74 65 73 th disk-path tes 22e0: 74 6e 61 6d 65 20 69 74 65 6d 64 61 74 29 0a 20 tname itemdat). 22f0: 20 28 6c 65 74 2a 20 28 28 72 75 6e 2d 69 6e 66 (let* ((run-inf 2300: 6f 20 28 64 62 3a 67 65 74 2d 72 75 6e 2d 69 6e o (db:get-run-in 2310: 66 6f 20 64 62 20 72 75 6e 2d 69 64 29 29 0a 09 fo db run-id)).. 2320: 20 28 69 74 65 6d 2d 70 61 74 68 20 28 6c 65 74 (item-path (let 2330: 20 28 28 69 70 20 28 69 74 65 6d 2d 6c 69 73 74 ((ip (item-list 2340: 2d 3e 70 61 74 68 20 69 74 65 6d 64 61 74 29 29 ->path itemdat)) 2350: 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 65 )... (if (e 2360: 71 75 61 6c 3f 20 69 70 20 22 22 29 20 22 22 20 qual? ip "") "" 2370: 28 63 6f 6e 63 20 22 2f 22 20 69 70 29 29 29 29 (conc "/" ip)))) 2380: 0a 09 20 28 72 75 6e 6e 61 6d 65 20 20 28 64 62 .. (runname (db 2390: 3a 67 65 74 2d 76 61 6c 75 65 2d 62 79 2d 68 65 :get-value-by-he 23a0: 61 64 65 72 20 28 64 62 3a 67 65 74 2d 72 6f 77 ader (db:get-row 23b0: 20 72 75 6e 2d 69 6e 66 6f 29 0a 09 09 09 09 09 run-info)...... 23c0: 20 20 20 28 64 62 3a 67 65 74 2d 68 65 61 64 65 (db:get-heade 23d0: 72 20 72 75 6e 2d 69 6e 66 6f 29 0a 09 09 09 09 r run-info)..... 23e0: 09 20 20 20 22 72 75 6e 6e 61 6d 65 22 29 29 0a . "runname")). 23f0: 09 20 28 6b 65 79 2d 76 61 6c 73 20 28 67 65 74 . (key-vals (get 2400: 2d 6b 65 79 2d 76 61 6c 73 20 64 62 20 72 75 6e -key-vals db run 2410: 2d 69 64 29 29 0a 09 20 28 6b 65 79 2d 73 74 72 -id)).. (key-str 2420: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters 2430: 70 65 72 73 65 20 6b 65 79 2d 76 61 6c 73 20 22 perse key-vals " 2440: 2f 22 29 29 0a 09 20 28 64 66 75 6c 6c 70 20 20 /")).. (dfullp 2450: 20 28 63 6f 6e 63 20 64 69 73 6b 2d 70 61 74 68 (conc disk-path 2460: 20 22 2f 22 20 6b 65 79 2d 73 74 72 20 22 2f 22 "/" key-str "/" 2470: 20 72 75 6e 6e 61 6d 65 20 22 2f 22 20 74 65 73 runname "/" tes 2480: 74 6e 61 6d 65 0a 09 09 09 20 69 74 65 6d 2d 70 tname.... item-p 2490: 61 74 68 29 29 0a 09 20 28 74 6f 70 74 65 73 74 ath)).. (toptest 24a0: 2d 70 61 74 68 20 28 63 6f 6e 63 20 64 69 73 6b -path (conc disk 24b0: 2d 70 61 74 68 20 22 2f 22 20 6b 65 79 2d 73 74 -path "/" key-st 24c0: 72 20 22 2f 22 20 72 75 6e 6e 61 6d 65 20 22 2f r "/" runname "/ 24d0: 22 20 74 65 73 74 6e 61 6d 65 29 29 0a 09 20 28 " testname)).. ( 24e0: 72 75 6e 73 64 69 72 20 20 28 63 6f 6e 66 69 67 runsdir (config 24f0: 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 -lookup *configd 2500: 61 74 2a 20 22 73 65 74 75 70 22 20 22 72 75 6e at* "setup" "run 2510: 73 64 69 72 22 29 29 0a 09 20 28 6c 6e 6b 70 61 sdir")).. (lnkpa 2520: 74 68 20 20 28 63 6f 6e 63 20 28 69 66 20 72 75 th (conc (if ru 2530: 6e 73 64 69 72 20 72 75 6e 73 64 69 72 20 28 63 nsdir runsdir (c 2540: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/ 2550: 72 75 6e 73 22 29 29 0a 09 09 09 20 22 2f 22 20 runs")).... "/" 2560: 6b 65 79 2d 73 74 72 20 22 2f 22 20 72 75 6e 6e key-str "/" runn 2570: 61 6d 65 20 69 74 65 6d 2d 70 61 74 68 29 29 29 ame item-path))) 2580: 0a 20 20 20 20 3b 3b 20 73 69 6e 63 65 20 74 68 . ;; since th 2590: 69 73 20 69 73 20 61 6e 20 69 74 65 72 61 74 65 is is an iterate 25a0: 64 20 74 65 73 74 20 74 68 69 73 20 69 73 20 61 d test this is a 25b0: 73 20 67 6f 6f 64 20 61 20 70 6c 61 63 65 20 61 s good a place a 25c0: 73 20 61 6e 79 20 74 6f 0a 20 20 20 20 3b 3b 20 s any to. ;; 25d0: 75 70 64 61 74 65 20 74 68 65 20 74 6f 70 74 65 update the topte 25e0: 73 74 20 72 65 63 6f 72 64 20 77 69 74 68 20 69 st record with i 25f0: 74 73 20 6c 6f 63 61 74 69 6f 6e 20 72 75 6e 64 ts location rund 2600: 69 72 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 ir. (if (not 2610: 28 65 71 75 61 6c 3f 20 69 74 65 6d 2d 70 61 74 (equal? item-pat 2620: 68 20 22 22 29 29 0a 09 28 64 62 3a 74 65 73 74 h ""))..(db:test 2630: 2d 73 65 74 2d 72 75 6e 64 69 72 21 20 64 62 20 -set-rundir! db 2640: 72 75 6e 2d 69 64 20 74 65 73 74 6e 61 6d 65 20 run-id testname 2650: 22 22 20 74 6f 70 74 65 73 74 2d 70 61 74 68 29 "" toptest-path) 2660: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri 2670: 6e 74 20 32 20 22 53 65 74 74 69 6e 67 20 75 70 nt 2 "Setting up 2680: 20 74 65 73 74 20 72 75 6e 20 61 72 65 61 22 29 test run area") 2690: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin 26a0: 74 20 32 20 22 20 2d 20 63 72 65 61 74 69 6e 67 t 2 " - creating 26b0: 20 72 75 6e 20 61 72 65 61 20 69 6e 20 22 20 64 run area in " d 26c0: 66 75 6c 6c 70 29 0a 20 20 20 20 28 73 79 73 74 fullp). (syst 26d0: 65 6d 20 20 28 63 6f 6e 63 20 22 6d 6b 64 69 72 em (conc "mkdir 26e0: 20 2d 70 20 22 20 64 66 75 6c 6c 70 29 29 0a 20 -p " dfullp)). 26f0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print 2700: 32 20 22 20 2d 20 63 72 65 61 74 69 6e 67 20 6c 2 " - creating l 2710: 69 6e 6b 20 66 72 6f 6d 20 22 20 64 66 75 6c 6c ink from " dfull 2720: 70 20 22 2f 22 20 74 65 73 74 6e 61 6d 65 20 22 p "/" testname " 2730: 20 74 6f 20 22 20 6c 6e 6b 70 61 74 68 29 0a 20 to " lnkpath). 2740: 20 20 20 28 73 79 73 74 65 6d 20 20 28 63 6f 6e (system (con 2750: 63 20 22 6d 6b 64 69 72 20 2d 70 20 22 20 6c 6e c "mkdir -p " ln 2760: 6b 70 61 74 68 29 29 0a 0a 3b 3b 20 49 20 73 75 kpath))..;; I su 2770: 73 70 65 63 74 20 74 68 69 73 20 73 65 63 74 69 spect this secti 2780: 6f 6e 20 77 61 73 20 64 65 6c 65 74 69 6e 67 20 on was deleting 2790: 74 65 73 74 20 64 69 72 65 63 74 6f 72 69 65 73 test directories 27a0: 20 75 6e 64 65 72 20 73 6f 6d 65 20 0a 3b 3b 20 under some .;; 27b0: 77 69 65 72 64 20 73 69 74 61 74 69 6f 6e 73 0a wierd sitations. 27c0: 0a 3b 3b 20 20 20 20 28 69 66 20 28 66 69 6c 65 .;; (if (file 27d0: 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 6c -exists? (conc l 27e0: 6e 6b 70 61 74 68 20 22 2f 22 20 74 65 73 74 6e nkpath "/" testn 27f0: 61 6d 65 29 29 0a 3b 3b 09 28 73 79 73 74 65 6d ame)).;;.(system 2800: 20 28 63 6f 6e 63 20 22 72 6d 20 2d 66 20 22 20 (conc "rm -f " 2810: 6c 6e 6b 70 61 74 68 20 22 2f 22 20 74 65 73 74 lnkpath "/" test 2820: 6e 61 6d 65 29 29 29 0a 20 20 20 20 28 73 79 73 name))). (sys 2830: 74 65 6d 20 20 28 63 6f 6e 63 20 22 6c 6e 20 2d tem (conc "ln - 2840: 73 66 20 22 20 64 66 75 6c 6c 70 20 22 20 22 20 sf " dfullp " " 2850: 6c 6e 6b 70 61 74 68 20 22 2f 22 20 74 65 73 74 lnkpath "/" test 2860: 6e 61 6d 65 29 29 0a 20 20 20 20 28 69 66 20 28 name)). (if ( 2870: 64 69 72 65 63 74 6f 72 79 3f 20 64 66 75 6c 6c directory? dfull 2880: 70 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 6c p)..(begin.. (l 2890: 65 74 2a 20 28 28 63 6d 64 20 20 20 20 28 63 6f et* ((cmd (co 28a0: 6e 63 20 22 72 73 79 6e 63 20 2d 61 76 22 20 28 nc "rsync -av" ( 28b0: 69 66 20 28 3e 20 2a 76 65 72 62 6f 73 69 74 79 if (> *verbosity 28c0: 2a 20 31 29 20 22 22 20 22 71 22 29 20 22 20 22 * 1) "" "q") " " 28d0: 20 74 65 73 74 2d 70 61 74 68 20 22 2f 20 22 20 test-path "/ " 28e0: 64 66 75 6c 6c 70 20 22 2f 22 29 29 0a 09 09 20 dfullp "/"))... 28f0: 28 73 74 61 74 75 73 20 28 73 79 73 74 65 6d 20 (status (system 2900: 63 6d 64 29 29 29 0a 09 20 20 20 20 28 69 66 20 cmd))).. (if 2910: 28 6e 6f 74 20 28 65 71 3f 20 73 74 61 74 75 73 (not (eq? status 2920: 20 30 29 29 0a 09 09 28 64 65 62 75 67 3a 70 72 0))...(debug:pr 2930: 69 6e 74 20 32 20 22 45 52 52 4f 52 3a 20 70 72 int 2 "ERROR: pr 2940: 6f 62 6c 65 6d 20 77 69 74 68 20 72 75 6e 6e 69 oblem with runni 2950: 6e 67 20 5c 22 22 20 63 6d 64 20 22 5c 22 22 29 ng \"" cmd "\"") 2960: 29 29 0a 09 20 20 28 6c 69 73 74 20 64 66 75 6c )).. (list dful 2970: 6c 70 20 74 6f 70 74 65 73 74 2d 70 61 74 68 29 lp toptest-path) 2980: 29 0a 09 28 6c 69 73 74 20 23 66 20 23 66 29 29 )..(list #f #f)) 2990: 29 29 0a 0a 3b 3b 20 31 2e 20 6c 6f 6f 6b 20 74 ))..;; 1. look t 29a0: 68 6f 75 67 68 20 64 69 73 6b 73 20 6c 69 73 74 hough disks list 29b0: 20 66 6f 72 20 64 69 73 6b 20 77 69 74 68 20 6d for disk with m 29c0: 6f 73 74 20 73 70 61 63 65 0a 3b 3b 20 32 2e 20 ost space.;; 2. 29d0: 63 72 65 61 74 65 20 72 75 6e 20 64 69 72 20 6f create run dir o 29e0: 6e 20 64 69 73 6b 2c 20 70 61 74 68 20 6e 61 6d n disk, path nam 29f0: 65 20 69 73 20 6d 65 61 6e 69 6e 67 66 75 6c 0a e is meaningful. 2a00: 3b 3b 20 33 2e 20 63 72 65 61 74 65 20 6c 69 6e ;; 3. create lin 2a10: 6b 20 66 72 6f 6d 20 72 75 6e 20 64 69 72 20 74 k from run dir t 2a20: 6f 20 6d 65 67 61 74 65 73 74 20 72 75 6e 73 20 o megatest runs 2a30: 61 72 65 61 20 0a 3b 3b 20 34 2e 20 72 65 6d 6f area .;; 4. remo 2a40: 74 65 6c 79 20 72 75 6e 20 74 68 65 20 74 65 73 tely run the tes 2a50: 74 20 6f 6e 20 61 6c 6c 6f 63 61 74 65 64 20 68 t on allocated h 2a60: 6f 73 74 0a 3b 3b 20 20 20 20 2d 20 63 6f 75 6c ost.;; - coul 2a70: 64 20 62 65 20 73 73 68 20 74 6f 20 68 6f 73 74 d be ssh to host 2a80: 20 66 72 6f 6d 20 68 6f 73 74 73 20 74 61 62 6c from hosts tabl 2a90: 65 20 28 75 70 64 61 74 65 20 72 65 67 75 6c 61 e (update regula 2aa0: 72 6c 79 20 77 69 74 68 20 6c 6f 61 64 29 0a 3b rly with load).; 2ab0: 3b 20 20 20 20 2d 20 63 6f 75 6c 64 20 62 65 20 ; - could be 2ac0: 6e 65 74 62 61 74 63 68 0a 3b 3b 20 20 20 20 20 netbatch.;; 2ad0: 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 64 62 (launch-test db 2ae0: 20 28 63 61 64 72 20 73 74 61 74 75 73 29 20 74 (cadr status) t 2af0: 65 73 74 2d 63 6f 6e 66 29 29 0a 28 64 65 66 69 est-conf)).(defi 2b00: 6e 65 20 28 6c 61 75 6e 63 68 2d 74 65 73 74 20 ne (launch-test 2b10: 64 62 20 72 75 6e 2d 69 64 20 74 65 73 74 2d 63 db run-id test-c 2b20: 6f 6e 66 20 6b 65 79 76 61 6c 6c 73 74 20 74 65 onf keyvallst te 2b30: 73 74 2d 6e 61 6d 65 20 74 65 73 74 2d 70 61 74 st-name test-pat 2b40: 68 20 69 74 65 6d 64 61 74 29 0a 20 20 28 63 68 h itemdat). (ch 2b50: 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 2a ange-directory * 2b60: 74 6f 70 70 61 74 68 2a 29 0a 20 20 28 6c 65 74 toppath*). (let 2b70: 20 28 28 75 73 65 73 68 65 6c 6c 20 20 20 28 63 ((useshell (c 2b80: 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f onfig-lookup *co 2b90: 6e 66 69 67 64 61 74 2a 20 22 6a 6f 62 74 6f 6f nfigdat* "jobtoo 2ba0: 6c 73 22 20 20 20 20 20 22 75 73 65 73 68 65 6c ls" "useshel 2bb0: 6c 22 29 29 0a 09 28 6c 61 75 6e 63 68 65 72 20 l"))..(launcher 2bc0: 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 (config-lookup 2bd0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f *configdat* "jo 2be0: 62 74 6f 6f 6c 73 22 20 20 20 20 20 22 6c 61 75 btools" "lau 2bf0: 6e 63 68 65 72 22 29 29 0a 09 28 72 75 6e 73 63 ncher"))..(runsc 2c00: 72 69 70 74 20 20 28 63 6f 6e 66 69 67 2d 6c 6f ript (config-lo 2c10: 6f 6b 75 70 20 74 65 73 74 2d 63 6f 6e 66 20 20 okup test-conf 2c20: 20 22 73 65 74 75 70 22 20 20 20 20 20 20 20 20 "setup" 2c30: 22 72 75 6e 73 63 72 69 70 74 22 29 29 0a 09 28 "runscript"))..( 2c40: 64 69 73 6b 73 70 61 63 65 20 20 28 63 6f 6e 66 diskspace (conf 2c50: 69 67 2d 6c 6f 6f 6b 75 70 20 74 65 73 74 2d 63 ig-lookup test-c 2c60: 6f 6e 66 20 20 20 22 72 65 71 75 69 72 65 6d 65 onf "requireme 2c70: 6e 74 73 22 20 22 64 69 73 6b 73 70 61 63 65 22 nts" "diskspace" 2c80: 29 29 0a 09 28 6d 65 6d 6f 72 79 20 20 20 20 20 ))..(memory 2c90: 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 20 74 (config-lookup t 2ca0: 65 73 74 2d 63 6f 6e 66 20 20 20 22 72 65 71 75 est-conf "requ 2cb0: 69 72 65 6d 65 6e 74 73 22 20 22 6d 65 6d 6f 72 irements" "memor 2cc0: 79 22 29 29 0a 09 28 68 6f 73 74 73 20 20 20 20 y"))..(hosts 2cd0: 20 20 28 63 6f 6e 66 69 67 2d 6c 6f 6f 6b 75 70 (config-lookup 2ce0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 6a 6f *configdat* "jo 2cf0: 62 74 6f 6f 6c 73 22 20 20 20 20 20 22 77 6f 72 btools" "wor 2d00: 6b 68 6f 73 74 73 22 29 29 0a 09 28 72 65 6d 6f khosts"))..(remo 2d10: 74 65 2d 6d 65 67 61 74 65 73 74 20 28 63 6f 6e te-megatest (con 2d20: 66 69 67 2d 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 fig-lookup *conf 2d30: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" " 2d40: 65 78 65 63 75 74 61 62 6c 65 22 29 29 0a 09 28 executable"))..( 2d50: 6c 6f 63 61 6c 2d 6d 65 67 61 74 65 73 74 20 20 local-megatest 2d60: 28 63 61 72 20 28 61 72 67 76 29 29 29 0a 09 3b (car (argv)))..; 2d70: 3b 20 28 69 74 65 6d 2d 70 61 74 68 20 20 28 69 ; (item-path (i 2d80: 74 65 6d 2d 6c 69 73 74 2d 3e 70 61 74 68 20 69 tem-list->path i 2d90: 74 65 6d 64 61 74 29 29 20 74 65 73 74 2d 70 61 temdat)) test-pa 2da0: 74 68 20 69 73 20 74 68 65 20 66 75 6c 6c 20 70 th is the full p 2db0: 61 74 68 20 69 6e 63 6c 75 64 69 6e 67 20 74 68 ath including th 2dc0: 65 20 69 74 65 6d 2d 70 61 74 68 0a 09 28 77 6f e item-path..(wo 2dd0: 72 6b 2d 61 72 65 61 20 20 23 66 29 0a 09 28 74 rk-area #f)..(t 2de0: 6f 70 74 65 73 74 2d 77 6f 72 6b 2d 61 72 65 61 optest-work-area 2df0: 20 23 66 29 20 3b 3b 20 66 6f 72 20 69 74 65 72 #f) ;; for iter 2e00: 61 74 65 64 20 74 65 73 74 73 20 74 68 65 20 74 ated tests the t 2e10: 6f 70 20 74 65 73 74 20 63 6f 6e 74 61 69 6e 73 op test contains 2e20: 20 64 61 74 61 20 72 65 6c 65 76 61 6e 74 20 66 data relevant f 2e30: 6f 72 20 61 6c 6c 0a 09 28 64 69 73 6b 70 61 74 or all..(diskpat 2e40: 68 20 20 20 23 66 29 0a 09 28 63 6d 64 70 61 72 h #f)..(cmdpar 2e50: 6d 73 20 20 20 23 66 29 0a 09 28 66 75 6c 6c 63 ms #f)..(fullc 2e60: 6d 64 20 20 20 20 23 66 29 20 3b 3b 20 28 64 65 md #f) ;; (de 2e70: 66 69 6e 65 20 61 20 28 77 69 74 68 2d 6f 75 74 fine a (with-out 2e80: 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 20 28 6c put-to-string (l 2e90: 61 6d 62 64 61 20 28 29 28 77 72 69 74 65 20 78 ambda ()(write x 2ea0: 29 29 29 29 0a 09 28 6d 74 2d 62 69 6e 64 69 72 ))))..(mt-bindir 2eb0: 2d 70 61 74 68 20 23 66 29 29 0a 20 20 20 20 28 -path #f)). ( 2ec0: 69 66 20 68 6f 73 74 73 20 28 73 65 74 21 20 68 if hosts (set! h 2ed0: 6f 73 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c osts (string-spl 2ee0: 69 74 20 68 6f 73 74 73 29 29 29 0a 20 20 20 20 it hosts))). 2ef0: 28 69 66 20 28 6e 6f 74 20 72 65 6d 6f 74 65 2d (if (not remote- 2f00: 6d 65 67 61 74 65 73 74 29 28 73 65 74 21 20 72 megatest)(set! r 2f10: 65 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 6c emote-megatest l 2f20: 6f 63 61 6c 2d 6d 65 67 61 74 65 73 74 29 29 20 ocal-megatest)) 2f30: 3b 3b 20 22 6d 65 67 61 74 65 73 74 22 29 29 0a ;; "megatest")). 2f40: 20 20 20 20 28 73 65 74 21 20 6d 74 2d 62 69 6e (set! mt-bin 2f50: 64 69 72 2d 70 61 74 68 20 28 70 61 74 68 6e 61 dir-path (pathna 2f60: 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 72 65 6d me-directory rem 2f70: 6f 74 65 2d 6d 65 67 61 74 65 73 74 29 29 0a 20 ote-megatest)). 2f80: 20 20 20 28 69 66 20 6c 61 75 6e 63 68 65 72 20 (if launcher 2f90: 28 73 65 74 21 20 6c 61 75 6e 63 68 65 72 20 28 (set! launcher ( 2fa0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 75 string-split lau 2fb0: 6e 63 68 65 72 29 29 29 0a 20 20 20 20 3b 3b 20 ncher))). ;; 2fc0: 73 65 74 20 75 70 20 74 68 65 20 72 75 6e 20 77 set up the run w 2fd0: 6f 72 6b 20 61 72 65 61 20 66 6f 72 20 74 68 69 ork area for thi 2fe0: 73 20 74 65 73 74 0a 20 20 20 20 28 73 65 74 21 s test. (set! 2ff0: 20 64 69 73 6b 70 61 74 68 20 28 67 65 74 2d 62 diskpath (get-b 3000: 65 73 74 2d 64 69 73 6b 20 2a 63 6f 6e 66 69 67 est-disk *config 3010: 64 61 74 2a 29 29 0a 20 20 20 20 28 69 66 20 64 dat*)). (if d 3020: 69 73 6b 70 61 74 68 0a 09 28 6c 65 74 20 28 28 iskpath..(let (( 3030: 64 61 74 20 20 28 63 72 65 61 74 65 2d 77 6f 72 dat (create-wor 3040: 6b 2d 61 72 65 61 20 64 62 20 72 75 6e 2d 69 64 k-area db run-id 3050: 20 74 65 73 74 2d 70 61 74 68 20 64 69 73 6b 70 test-path diskp 3060: 61 74 68 20 74 65 73 74 2d 6e 61 6d 65 20 69 74 ath test-name it 3070: 65 6d 64 61 74 29 29 29 0a 09 20 20 28 73 65 74 emdat))).. (set 3080: 21 20 77 6f 72 6b 2d 61 72 65 61 20 28 63 61 72 ! work-area (car 3090: 20 64 61 74 29 29 0a 09 20 20 28 73 65 74 21 20 dat)).. (set! 30a0: 74 6f 70 74 65 73 74 2d 77 6f 72 6b 2d 61 72 65 toptest-work-are 30b0: 61 20 28 63 61 64 72 20 64 61 74 29 29 29 0a 09 a (cadr dat))).. 30c0: 28 62 65 67 69 6e 0a 09 20 20 28 73 65 74 21 20 (begin.. (set! 30d0: 77 6f 72 6b 2d 61 72 65 61 20 74 65 73 74 2d 70 work-area test-p 30e0: 61 74 68 29 0a 09 20 20 28 64 65 62 75 67 3a 70 ath).. (debug:p 30f0: 72 69 6e 74 20 30 20 22 57 41 52 4e 49 4e 47 3a rint 0 "WARNING: 3100: 20 4e 6f 20 64 69 73 6b 20 77 6f 72 6b 20 61 72 No disk work ar 3110: 65 61 20 73 70 65 63 69 66 69 65 64 20 2d 20 72 ea specified - r 3120: 75 6e 6e 69 6e 67 20 69 6e 20 74 68 65 20 74 65 unning in the te 3130: 73 74 20 64 69 72 65 63 74 6f 72 79 22 29 29 29 st directory"))) 3140: 0a 20 20 20 20 28 73 65 74 21 20 63 6d 64 70 61 . (set! cmdpa 3150: 72 6d 73 20 28 62 61 73 65 36 34 3a 62 61 73 65 rms (base64:base 3160: 36 34 2d 65 6e 63 6f 64 65 20 28 77 69 74 68 2d 64-encode (with- 3170: 6f 75 74 70 75 74 2d 74 6f 2d 73 74 72 69 6e 67 output-to-string 3180: 0a 09 09 09 09 20 20 20 20 28 6c 61 6d 62 64 61 ..... (lambda 3190: 20 28 29 20 3b 3b 20 28 6c 69 73 74 20 27 68 6f () ;; (list 'ho 31a0: 73 74 73 20 20 20 20 20 68 6f 73 74 73 29 0a 09 sts hosts).. 31b0: 09 09 09 20 20 20 20 20 20 28 77 72 69 74 65 20 ... (write 31c0: 28 6c 69 73 74 20 28 6c 69 73 74 20 27 74 65 73 (list (list 'tes 31d0: 74 70 61 74 68 20 20 74 65 73 74 2d 70 61 74 68 tpath test-path 31e0: 29 0a 09 09 09 09 09 09 20 20 20 28 6c 69 73 74 )....... (list 31f0: 20 27 77 6f 72 6b 2d 61 72 65 61 20 77 6f 72 6b 'work-area work 3200: 2d 61 72 65 61 29 0a 09 09 09 09 09 09 20 20 20 -area)....... 3210: 28 6c 69 73 74 20 27 74 65 73 74 2d 6e 61 6d 65 (list 'test-name 3220: 20 74 65 73 74 2d 6e 61 6d 65 29 20 0a 09 09 09 test-name) .... 3230: 09 09 09 20 20 20 28 6c 69 73 74 20 27 72 75 6e ... (list 'run 3240: 73 63 72 69 70 74 20 72 75 6e 73 63 72 69 70 74 script runscript 3250: 29 20 0a 09 09 09 09 09 09 20 20 20 28 6c 69 73 ) ....... (lis 3260: 74 20 27 72 75 6e 2d 69 64 20 20 20 20 72 75 6e t 'run-id run 3270: 2d 69 64 20 20 20 29 0a 09 09 09 09 09 09 20 20 -id )....... 3280: 20 28 6c 69 73 74 20 27 69 74 65 6d 64 61 74 20 (list 'itemdat 3290: 20 20 69 74 65 6d 64 61 74 20 20 29 0a 09 09 09 itemdat ).... 32a0: 09 09 09 20 20 20 28 6c 69 73 74 20 27 6d 65 67 ... (list 'meg 32b0: 61 74 65 73 74 20 20 72 65 6d 6f 74 65 2d 6d 65 atest remote-me 32c0: 67 61 74 65 73 74 29 0a 09 09 09 09 09 09 20 20 gatest)....... 32d0: 20 28 6c 69 73 74 20 27 65 6e 76 2d 6f 76 72 64 (list 'env-ovrd 32e0: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re 32f0: 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e 66 69 f/default *confi 3300: 67 64 61 74 2a 20 22 65 6e 76 2d 6f 76 65 72 72 gdat* "env-overr 3310: 69 64 65 22 20 27 28 29 29 29 0a 09 09 09 09 09 ide" '()))...... 3320: 09 20 20 20 28 6c 69 73 74 20 27 72 75 6e 6e 61 . (list 'runna 3330: 6d 65 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 me (args:get-a 3340: 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 29 0a rg ":runname")). 3350: 09 09 09 09 09 09 20 20 20 28 6c 69 73 74 20 27 ...... (list ' 3360: 6d 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 20 6d mt-bindir-path m 3370: 74 2d 62 69 6e 64 69 72 2d 70 61 74 68 29 29 29 t-bindir-path))) 3380: 29 29 29 29 20 3b 3b 20 28 73 74 72 69 6e 67 2d )))) ;; (string- 3390: 69 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 76 intersperse keyv 33a0: 61 6c 6c 73 74 20 22 20 22 29 29 29 29 0a 20 20 allst " ")))). 33b0: 20 20 3b 3b 20 63 6c 65 61 6e 20 6f 75 74 20 73 ;; clean out s 33c0: 74 65 70 20 72 65 63 6f 72 64 73 20 66 72 6f 6d tep records from 33d0: 20 70 72 65 76 69 6f 75 73 20 72 75 6e 20 69 66 previous run if 33e0: 20 74 68 65 79 20 65 78 69 73 74 0a 20 20 20 20 they exist. 33f0: 28 64 62 3a 64 65 6c 65 74 65 2d 74 65 73 74 2d (db:delete-test- 3400: 73 74 65 70 2d 72 65 63 6f 72 64 73 20 64 62 20 step-records db 3410: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name 3420: 20 69 74 65 6d 64 61 74 29 0a 20 20 20 20 28 63 itemdat). (c 3430: 68 61 6e 67 65 2d 64 69 72 65 63 74 6f 72 79 20 hange-directory 3440: 77 6f 72 6b 2d 61 72 65 61 29 20 3b 3b 20 73 6f work-area) ;; so 3450: 20 74 68 61 74 20 6c 6f 67 20 66 69 6c 65 73 20 that log files 3460: 66 72 6f 6d 20 74 68 65 20 6c 61 75 6e 63 68 20 from the launch 3470: 70 72 6f 63 65 73 73 20 64 6f 6e 27 74 20 63 6c process don't cl 3480: 75 74 74 65 72 20 74 68 65 20 74 65 73 74 20 64 utter the test d 3490: 69 72 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 ir. (cond. 34a0: 20 20 28 28 61 6e 64 20 6c 61 75 6e 63 68 65 72 ((and launcher 34b0: 20 68 6f 73 74 73 29 20 3b 3b 20 6d 75 73 74 20 hosts) ;; must 34c0: 62 65 20 75 73 69 6e 67 20 73 73 68 20 68 6f 73 be using ssh hos 34d0: 74 6e 61 6d 65 0a 20 20 20 20 20 20 28 73 65 74 tname. (set 34e0: 21 20 66 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e ! fullcmd (appen 34f0: 64 20 6c 61 75 6e 63 68 65 72 20 28 63 61 72 20 d launcher (car 3500: 68 6f 73 74 73 29 28 6c 69 73 74 20 72 65 6d 6f hosts)(list remo 3510: 74 65 2d 6d 65 67 61 74 65 73 74 20 22 2d 65 78 te-megatest "-ex 3520: 65 63 75 74 65 22 20 63 6d 64 70 61 72 6d 73 29 ecute" cmdparms) 3530: 29 29 29 0a 20 20 20 20 20 28 6c 61 75 6e 63 68 ))). (launch 3540: 65 72 0a 20 20 20 20 20 20 28 73 65 74 21 20 66 er. (set! f 3550: 75 6c 6c 63 6d 64 20 28 61 70 70 65 6e 64 20 6c ullcmd (append l 3560: 61 75 6e 63 68 65 72 20 28 6c 69 73 74 20 72 65 auncher (list re 3570: 6d 6f 74 65 2d 6d 65 67 61 74 65 73 74 20 22 2d mote-megatest "- 3580: 65 78 65 63 75 74 65 22 20 63 6d 64 70 61 72 6d execute" cmdparm 3590: 73 29 29 29 29 0a 20 20 20 20 20 28 65 6c 73 65 s)))). (else 35a0: 0a 20 20 20 20 20 20 28 73 65 74 21 20 66 75 6c . (set! ful 35b0: 6c 63 6d 64 20 28 6c 69 73 74 20 72 65 6d 6f 74 lcmd (list remot 35c0: 65 2d 6d 65 67 61 74 65 73 74 20 22 2d 65 78 65 e-megatest "-exe 35d0: 63 75 74 65 22 20 63 6d 64 70 61 72 6d 73 29 29 cute" cmdparms)) 35e0: 29 29 0a 20 20 20 20 28 69 66 20 28 61 72 67 73 )). (if (args 35f0: 3a 67 65 74 2d 61 72 67 20 22 2d 78 74 65 72 6d :get-arg "-xterm 3600: 22 29 28 73 65 74 21 20 66 75 6c 6c 63 6d 64 20 ")(set! fullcmd 3610: 28 61 70 70 65 6e 64 20 66 75 6c 6c 63 6d 64 20 (append fullcmd 3620: 28 6c 69 73 74 20 22 2d 78 74 65 72 6d 22 29 29 (list "-xterm")) 3630: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr 3640: 69 6e 74 20 31 20 22 4c 61 75 6e 63 68 69 6e 67 int 1 "Launching 3650: 20 6d 65 67 61 74 65 73 74 20 66 6f 72 20 74 65 megatest for te 3660: 73 74 20 22 20 74 65 73 74 2d 6e 61 6d 65 20 22 st " test-name " 3670: 20 69 6e 20 22 20 77 6f 72 6b 2d 61 72 65 61 22 in " work-area" 3680: 20 2e 2e 2e 22 29 0a 20 20 20 20 28 74 65 73 74 ..."). (test 3690: 2d 73 65 74 2d 73 74 61 74 75 73 21 20 64 62 20 -set-status! db 36a0: 72 75 6e 2d 69 64 20 74 65 73 74 2d 6e 61 6d 65 run-id test-name 36b0: 20 22 4c 41 55 4e 43 48 45 44 22 20 22 6e 2f 61 "LAUNCHED" "n/a 36c0: 22 20 69 74 65 6d 64 61 74 20 23 66 20 23 66 29 " itemdat #f #f) 36d0: 20 3b 3b 20 28 69 66 20 6c 61 75 6e 63 68 2d 72 ;; (if launch-r 36e0: 65 73 75 6c 74 73 20 6c 61 75 6e 63 68 2d 72 65 esults launch-re 36f0: 73 75 6c 74 73 20 22 46 41 49 4c 45 44 22 29 29 sults "FAILED")) 3700: 0a 20 20 20 20 3b 3b 20 73 65 74 20 0a 20 20 20 . ;; set . 3710: 20 3b 3b 20 73 65 74 20 70 72 65 2d 6c 61 75 6e ;; set pre-laun 3720: 63 68 2d 65 6e 76 2d 76 61 72 73 20 62 65 66 6f ch-env-vars befo 3730: 72 65 20 6c 61 75 6e 63 68 69 6e 67 2c 20 6b 65 re launching, ke 3740: 65 70 20 74 68 65 20 76 61 72 73 20 69 6e 20 70 ep the vars in p 3750: 72 65 76 76 61 6c 73 20 61 6e 64 20 70 75 74 20 revvals and put 3760: 74 68 65 20 65 6e 76 69 6f 6e 6d 65 6e 74 20 62 the envionment b 3770: 61 63 6b 20 77 68 65 6e 20 64 6f 6e 65 0a 20 20 ack when done. 3780: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4 3790: 20 22 66 75 6c 6c 63 6d 64 3a 20 22 20 66 75 6c "fullcmd: " ful 37a0: 6c 63 6d 64 29 0a 20 20 20 20 28 6c 65 74 2a 20 lcmd). (let* 37b0: 28 28 63 6f 6d 6d 6f 6e 70 72 65 76 76 61 6c 73 ((commonprevvals 37c0: 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 (alist->env-var 37d0: 73 0a 09 09 09 20 20 20 20 28 68 61 73 68 2d 74 s.... (hash-t 37e0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default 37f0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 65 6e *configdat* "en 3800: 76 2d 6f 76 65 72 72 69 64 65 22 20 27 28 29 29 v-override" '()) 3810: 29 29 0a 09 20 20 20 28 74 65 73 74 70 72 65 76 )).. (testprev 3820: 76 61 6c 73 20 20 20 28 61 6c 69 73 74 2d 3e 65 vals (alist->e 3830: 6e 76 2d 76 61 72 73 0a 09 09 09 20 20 20 20 28 nv-vars.... ( 3840: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d 3850: 65 66 61 75 6c 74 20 74 65 73 74 2d 63 6f 6e 66 efault test-conf 3860: 20 22 70 72 65 2d 6c 61 75 6e 63 68 2d 65 6e 76 "pre-launch-env 3870: 2d 6f 76 65 72 72 69 64 65 73 22 20 27 28 29 29 -overrides" '()) 3880: 29 29 0a 09 20 20 20 28 6d 69 73 63 70 72 65 76 )).. (miscprev 3890: 76 61 6c 73 20 20 20 28 61 6c 69 73 74 2d 3e 65 vals (alist->e 38a0: 6e 76 2d 76 61 72 73 20 3b 3b 20 63 6f 6e 73 6f nv-vars ;; conso 38b0: 6c 69 64 61 74 65 20 74 68 69 73 20 63 6f 64 65 lidate this code 38c0: 20 77 69 74 68 20 74 68 65 20 63 6f 64 65 20 69 with the code i 38d0: 6e 20 6d 65 67 61 74 65 73 74 2e 73 63 6d 20 66 n megatest.scm f 38e0: 6f 72 20 22 2d 65 78 65 63 75 74 65 22 0a 09 09 or "-execute"... 38f0: 09 20 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 . (append (li 3900: 73 74 20 28 6c 69 73 74 20 22 4d 54 5f 54 45 53 st (list "MT_TES 3910: 54 5f 4e 41 4d 45 22 20 74 65 73 74 2d 6e 61 6d T_NAME" test-nam 3920: 65 29 0a 09 09 09 09 09 20 20 28 6c 69 73 74 20 e)...... (list 3930: 22 4d 54 5f 49 54 45 4d 5f 49 4e 46 4f 22 20 28 "MT_ITEM_INFO" ( 3940: 63 6f 6e 63 20 69 74 65 6d 64 61 74 29 29 20 0a conc itemdat)) . 3950: 09 09 09 09 09 20 20 28 6c 69 73 74 20 22 4d 54 ..... (list "MT 3960: 5f 52 55 4e 4e 41 4d 45 22 20 20 20 28 61 72 67 _RUNNAME" (arg 3970: 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e s:get-arg ":runn 3980: 61 6d 65 22 29 29 29 0a 09 09 09 09 20 20 20 20 ame")))..... 3990: 69 74 65 6d 64 61 74 29 29 29 0a 09 20 20 20 28 itemdat))).. ( 39a0: 6c 61 75 6e 63 68 2d 72 65 73 75 6c 74 73 20 28 launch-results ( 39b0: 61 70 70 6c 79 20 63 6d 64 2d 72 75 6e 2d 70 72 apply cmd-run-pr 39c0: 6f 63 2d 65 61 63 68 2d 6c 69 6e 65 0a 09 09 09 oc-each-line.... 39d0: 09 20 20 28 69 66 20 75 73 65 73 68 65 6c 6c 0a . (if useshell. 39e0: 09 09 09 09 20 20 20 20 20 20 28 73 74 72 69 6e .... (strin 39f0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 66 75 g-intersperse fu 3a00: 6c 6c 63 6d 64 20 22 20 22 29 0a 09 09 09 09 20 llcmd " ")..... 3a10: 20 20 20 20 20 28 63 61 72 20 66 75 6c 6c 63 6d (car fullcm 3a20: 64 29 29 0a 09 09 09 09 20 20 70 72 69 6e 74 0a d))..... print. 3a30: 09 09 09 09 20 20 28 69 66 20 75 73 65 73 68 65 .... (if useshe 3a40: 6c 6c 0a 09 09 09 09 20 20 20 20 20 20 27 28 29 ll..... '() 3a50: 0a 09 09 09 09 20 20 20 20 20 20 28 63 64 72 20 ..... (cdr 3a60: 66 75 6c 6c 63 6d 64 29 29 29 29 29 20 3b 3b 20 fullcmd))))) ;; 3a70: 20 6c 61 75 6e 63 68 65 72 20 66 75 6c 6c 63 6d launcher fullcm 3a80: 64 29 29 29 3b 3b 20 28 61 70 70 6c 79 20 63 6d d)));; (apply cm 3a90: 64 2d 72 75 6e 2d 70 72 6f 63 2d 65 61 63 68 2d d-run-proc-each- 3aa0: 6c 69 6e 65 20 6c 61 75 6e 63 68 65 72 20 70 72 line launcher pr 3ab0: 69 6e 74 20 66 75 6c 6c 63 6d 64 29 29 29 20 3b int fullcmd))) ; 3ac0: 3b 20 28 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 ; (cmd-run->list 3ad0: 20 66 75 6c 6c 63 6d 64 29 29 0a 20 20 20 20 20 fullcmd)). 3ae0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 32 20 (debug:print 2 3af0: 22 4c 61 75 6e 63 68 69 6e 67 20 63 6f 6d 70 6c "Launching compl 3b00: 65 74 65 64 2c 20 75 70 64 61 74 69 6e 67 20 64 eted, updating d 3b10: 62 22 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 b"). (debug 3b20: 3a 70 72 69 6e 74 20 34 20 22 4c 61 75 6e 63 68 :print 4 "Launch 3b30: 20 72 65 73 75 6c 74 73 3a 20 22 20 6c 61 75 6e results: " laun 3b40: 63 68 2d 72 65 73 75 6c 74 73 29 0a 20 20 20 20 ch-results). 3b50: 20 20 28 69 66 20 28 6e 6f 74 20 6c 61 75 6e 63 (if (not launc 3b60: 68 2d 72 65 73 75 6c 74 73 29 0a 09 20 20 28 62 h-results).. (b 3b70: 65 67 69 6e 0a 09 20 20 20 20 28 70 72 69 6e 74 egin.. (print 3b80: 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 64 20 "ERROR: Failed 3b90: 74 6f 20 72 75 6e 20 22 20 28 73 74 72 69 6e 67 to run " (string 3ba0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 66 75 6c -intersperse ful 3bb0: 6c 63 6d 64 20 22 20 22 29 20 22 2c 20 65 78 69 lcmd " ") ", exi 3bc0: 74 69 6e 67 20 6e 6f 77 22 29 0a 09 20 20 20 20 ting now").. 3bd0: 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a (sqlite3:finaliz 3be0: 65 21 20 64 62 29 0a 09 20 20 20 20 3b 3b 20 67 e! db).. ;; g 3bf0: 6f 6f 64 20 6f 6c 65 20 22 65 78 69 74 22 20 73 ood ole "exit" s 3c00: 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b eems not to work 3c10: 0a 09 20 20 20 20 3b 3b 20 28 5f 65 78 69 74 20 .. ;; (_exit 3c20: 39 29 0a 09 20 20 20 20 3b 3b 20 62 75 74 20 74 9).. ;; but t 3c30: 68 69 73 20 68 61 63 6b 20 77 69 6c 6c 20 77 6f his hack will wo 3c40: 72 6b 21 20 54 68 61 6e 6b 73 20 67 6f 20 74 6f rk! Thanks go to 3c50: 20 41 6c 61 6e 20 50 6f 73 74 20 6f 66 20 74 68 Alan Post of th 3c60: 65 20 43 68 69 63 6b 65 6e 20 65 6d 61 69 6c 20 e Chicken email 3c70: 6c 69 73 74 0a 09 20 20 20 20 3b 3b 20 4e 42 2f list.. ;; NB/ 3c80: 2f 20 49 73 20 74 68 69 73 20 73 74 69 6c 6c 20 / Is this still 3c90: 6e 65 65 64 65 64 3f 20 53 68 6f 75 6c 64 20 62 needed? Should b 3ca0: 65 20 73 61 66 65 20 74 6f 20 67 6f 20 62 61 63 e safe to go bac 3cb0: 6b 20 74 6f 20 22 65 78 69 74 22 20 6e 6f 77 3f k to "exit" now? 3cc0: 0a 09 20 20 20 20 28 70 72 6f 63 65 73 73 2d 73 .. (process-s 3cd0: 69 67 6e 61 6c 20 28 63 75 72 72 65 6e 74 2d 70 ignal (current-p 3ce0: 72 6f 63 65 73 73 2d 69 64 29 20 73 69 67 6e 61 rocess-id) signa 3cf0: 6c 2f 6b 69 6c 6c 29 0a 09 20 20 20 20 29 29 0a l/kill).. )). 3d00: 20 20 20 20 20 20 28 61 6c 69 73 74 2d 3e 65 6e (alist->en 3d10: 76 2d 76 61 72 73 20 6d 69 73 63 70 72 65 76 76 v-vars miscprevv 3d20: 61 6c 73 29 0a 20 20 20 20 20 20 28 61 6c 69 73 als). (alis 3d30: 74 2d 3e 65 6e 76 2d 76 61 72 73 20 74 65 73 74 t->env-vars test 3d40: 70 72 65 76 76 61 6c 73 29 0a 20 20 20 20 20 20 prevvals). 3d50: 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 (alist->env-vars 3d60: 20 63 6f 6d 6d 6f 6e 70 72 65 76 76 61 6c 73 29 commonprevvals) 3d70: 0a 20 20 20 20 20 20 6c 61 75 6e 63 68 2d 72 65 . launch-re 3d80: 73 75 6c 74 73 29 29 29 0a 0a sults)))..