0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 32 2c right 2006-2012,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 srfi-1 posix re
01f0: 67 65 78 2d 63 61 73 65 20 62 61 73 65 36 34 20 gex-case base64
0200: 66 6f 72 6d 61 74 20 64 6f 74 2d 6c 6f 63 6b 69 format dot-locki
0210: 6e 67 20 63 73 76 2d 78 6d 6c 20 7a 33 20 73 71 ng csv-xml z3 sq
0220: 6c 2d 64 65 2d 6c 69 74 65 20 68 6f 73 74 69 6e l-de-lite hostin
0230: 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 65 2d 64 fo md5 message-d
0240: 69 67 65 73 74 29 0a 28 72 65 71 75 69 72 65 2d igest).(require-
0250: 65 78 74 65 6e 73 69 6f 6e 20 72 65 67 65 78 20 extension regex
0260: 70 6f 73 69 78 29 0a 0a 28 72 65 71 75 69 72 65 posix)..(require
0270: 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 72 66 69 -extension (srfi
0280: 20 31 38 29 20 65 78 74 72 61 73 20 74 63 70 20 18) extras tcp
0290: 72 70 63 29 0a 0a 28 69 6d 70 6f 72 74 20 28 70 rpc)..(import (p
02a0: 72 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 refix sqlite3 sq
02b0: 6c 69 74 65 33 3a 29 29 0a 28 69 6d 70 6f 72 74 lite3:)).(import
02c0: 20 28 70 72 65 66 69 78 20 62 61 73 65 36 34 20 (prefix base64
02d0: 62 61 73 65 36 34 3a 29 29 0a 0a 28 64 65 63 6c base64:))..(decl
02e0: 61 72 65 20 28 75 6e 69 74 20 63 6f 6d 6d 6f 6e are (unit common
02f0: 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f ))..(include "co
0300: 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d mmon_records.scm
0310: 22 29 0a 0a 3b 3b 20 28 72 65 71 75 69 72 65 2d ")..;; (require-
0320: 6c 69 62 72 61 72 79 20 6d 61 72 67 73 29 0a 3b library margs).;
0330: 3b 20 28 69 6e 63 6c 75 64 65 20 22 6d 61 72 67 ; (include "marg
0340: 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 28 64 65 66 s.scm")..;; (def
0350: 69 6e 65 20 6f 6c 64 2d 65 78 69 74 20 65 78 69 ine old-exit exi
0360: 74 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e t).;; .;; (defin
0370: 65 20 28 65 78 69 74 20 2e 20 63 6f 64 65 29 0a e (exit . code).
0380: 3b 3b 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ;; (if (null?
0390: 63 6f 64 65 29 0a 3b 3b 20 20 20 20 20 20 20 28 code).;; (
03a0: 6f 6c 64 2d 65 78 69 74 29 0a 3b 3b 20 20 20 20 old-exit).;;
03b0: 20 20 20 28 6f 6c 64 2d 65 78 69 74 20 63 6f 64 (old-exit cod
03c0: 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 67 65 e)))..(define ge
03d0: 74 65 6e 76 20 67 65 74 2d 65 6e 76 69 72 6f 6e tenv get-environ
03e0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 29 0a 28 ment-variable).(
03f0: 64 65 66 69 6e 65 20 28 73 61 66 65 2d 73 65 74 define (safe-set
0400: 65 6e 76 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 env key val). (
0410: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
0420: 20 76 61 6c 29 28 73 74 72 69 6e 67 3f 20 6b 65 val)(string? ke
0430: 79 29 29 0a 20 20 20 20 20 20 28 68 61 6e 64 6c y)). (handl
0440: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
0450: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 28 exn. (
0460: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
0470: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
0480: 2d 70 6f 72 74 2a 20 22 62 61 64 20 76 61 6c 75 -port* "bad valu
0490: 65 20 66 6f 72 20 73 65 74 65 6e 76 2c 20 6b 65 e for setenv, ke
04a0: 79 3d 22 20 6b 65 79 20 22 2c 20 76 61 6c 75 65 y=" key ", value
04b0: 3d 22 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 =" val). (
04c0: 73 65 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 29 setenv key val))
04d0: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
04e0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
04f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
0500: 62 61 64 20 76 61 6c 75 65 20 66 6f 72 20 73 65 bad value for se
0510: 74 65 6e 76 2c 20 6b 65 79 3d 22 20 6b 65 79 20 tenv, key=" key
0520: 22 2c 20 76 61 6c 75 65 3d 22 20 76 61 6c 29 29 ", value=" val))
0530: 29 0a 0a 28 64 65 66 69 6e 65 20 68 6f 6d 65 20 )..(define home
0540: 28 67 65 74 65 6e 76 20 22 48 4f 4d 45 22 29 29 (getenv "HOME"))
0550: 0a 28 64 65 66 69 6e 65 20 75 73 65 72 20 28 67 .(define user (g
0560: 65 74 65 6e 76 20 22 55 53 45 52 22 29 29 0a 0a etenv "USER"))..
0570: 3b 3b 20 47 4c 4f 42 41 4c 20 47 4c 45 54 43 48 ;; GLOBAL GLETCH
0580: 45 53 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6b ES.(define *db-k
0590: 65 79 73 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e eys* #f)..(defin
05a0: 65 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 20 20 e *configinfo*
05b0: 20 23 66 29 20 20 20 3b 3b 20 72 61 77 20 72 65 #f) ;; raw re
05c0: 73 75 6c 74 73 20 66 72 6f 6d 20 73 65 74 75 70 sults from setup
05d0: 2c 20 69 6e 63 6c 75 64 65 73 20 74 6f 70 70 61 , includes toppa
05e0: 74 68 20 61 6e 64 20 74 61 62 6c 65 20 66 72 6f th and table fro
05f0: 6d 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 m megatest.confi
0600: 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 63 6f g.(define *runco
0610: 6e 66 69 67 64 61 74 2a 20 23 66 29 20 20 20 3b nfigdat* #f) ;
0620: 3b 20 72 75 6e 20 63 6f 6e 66 69 67 73 20 64 61 ; run configs da
0630: 74 61 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 ta.(define *conf
0640: 69 67 64 61 74 2a 20 20 20 20 23 66 29 20 20 20 igdat* #f)
0650: 3b 3b 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 ;; megatest.conf
0660: 69 67 20 64 61 74 61 0a 28 64 65 66 69 6e 65 20 ig data.(define
0670: 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 23 *configstatus* #
0680: 66 29 20 20 20 3b 3b 20 73 74 61 74 75 73 20 6f f) ;; status o
0690: 66 20 64 61 74 61 3b 20 27 66 75 6c 6c 64 61 74 f data; 'fulldat
06a0: 61 20 3a 20 61 6c 6c 20 70 72 6f 63 65 73 73 69 a : all processi
06b0: 6e 67 20 64 6f 6e 65 2c 20 23 66 20 3a 20 6e 6f ng done, #f : no
06c0: 20 64 61 74 61 20 79 65 74 2c 20 27 70 61 72 74 data yet, 'part
06d0: 69 61 6c 64 61 74 61 20 3a 20 70 61 72 74 69 61 ialdata : partia
06e0: 6c 20 72 65 61 64 20 64 6f 6e 65 0a 28 64 65 66 l read done.(def
06f0: 69 6e 65 20 2a 74 6f 70 70 61 74 68 2a 20 20 20 ine *toppath*
0700: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
0710: 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e already-seen-run
0720: 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 23 66 29 config-info* #f)
0730: 0a 0a 28 64 65 66 69 6e 65 20 2a 77 61 69 74 69 ..(define *waiti
0740: 6e 67 2d 71 75 65 75 65 2a 20 20 20 20 20 28 6d ng-queue* (m
0750: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
0760: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 6d .(define *test-m
0770: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 28 6d 61 eta-updated* (ma
0780: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
0790: 28 64 65 66 69 6e 65 20 2a 67 6c 6f 62 61 6c 65 (define *globale
07a0: 78 69 74 73 74 61 74 75 73 2a 20 20 30 29 20 3b xitstatus* 0) ;
07b0: 3b 20 61 74 74 65 6d 70 74 20 74 6f 20 77 6f 72 ; attempt to wor
07c0: 6b 20 61 72 6f 75 6e 64 20 70 6f 73 73 69 62 6c k around possibl
07d0: 65 20 74 68 72 65 61 64 20 69 73 73 75 65 73 0a e thread issues.
07e0: 28 64 65 66 69 6e 65 20 2a 70 61 73 73 6e 75 6d (define *passnum
07f0: 2a 20 20 20 20 20 20 20 20 20 20 20 30 29 20 3b * 0) ;
0800: 3b 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 74 ; when running t
0810: 72 61 63 6b 20 63 61 6c 6c 73 20 74 6f 20 72 75 rack calls to ru
0820: 6e 2d 74 65 73 74 73 20 6f 72 20 73 69 6d 69 6c n-tests or simil
0830: 61 72 0a 28 64 65 66 69 6e 65 20 2a 77 72 69 74 ar.(define *writ
0840: 65 2d 66 72 65 71 75 65 6e 63 79 2a 20 20 20 28 e-frequency* (
0850: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0860: 29 20 3b 3b 20 72 75 6e 2d 69 64 20 3d 3e 20 28 ) ;; run-id => (
0870: 76 65 63 74 6f 72 20 28 63 75 72 72 65 6e 74 2d vector (current-
0880: 73 65 63 6f 6e 64 73 29 20 30 29 29 0a 28 64 65 seconds) 0)).(de
0890: 66 69 6e 65 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 fine *alt-log-fi
08a0: 6c 65 2a 20 23 66 29 20 20 3b 3b 20 75 73 65 64 le* #f) ;; used
08b0: 20 62 79 20 2d 6c 6f 67 0a 28 64 65 66 69 6e 65 by -log.(define
08c0: 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 *common:denoise
08d0: 2a 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d * (make-hash-
08e0: 74 61 62 6c 65 29 29 20 3b 3b 20 66 6f 72 20 6c table)) ;; for l
08f0: 6f 77 20 6e 6f 69 73 65 20 70 72 69 6e 74 69 6e ow noise printin
0900: 67 0a 28 64 65 66 69 6e 65 20 2a 64 65 66 61 75 g.(define *defau
0910: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 63 lt-log-port* (c
0920: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
0930: 74 29 29 0a 0a 3b 3b 20 44 41 54 41 42 41 53 45 t))..;; DATABASE
0940: 0a 28 64 65 66 69 6e 65 20 2a 64 62 73 74 72 75 .(define *dbstru
0950: 63 74 2d 64 62 2a 20 20 23 66 29 0a 28 64 65 66 ct-db* #f).(def
0960: 69 6e 65 20 2a 64 62 2d 73 74 61 74 73 2a 20 20 ine *db-stats*
0970: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
0980: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
0990: 68 61 73 68 20 6f 66 20 76 65 63 74 6f 72 73 20 hash of vectors
09a0: 3c 20 63 6f 75 6e 74 20 64 75 72 61 74 69 6f 6e < count duration
09b0: 2d 74 6f 74 61 6c 20 3e 0a 28 64 65 66 69 6e 65 -total >.(define
09c0: 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 *db-stats-mutex
09d0: 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 * (make-mut
09e0: 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 ex)).(define *db
09f0: 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 20 20 20 20 -sync-mutex*
0a00: 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 (make-mutex))
0a10: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6d 75 6c .(define *db-mul
0a20: 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 20 28 ti-sync-mutex* (
0a30: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 make-mutex)).(de
0a40: 66 69 6e 65 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 fine *db-local-s
0a50: 79 6e 63 2a 20 20 20 20 20 20 20 28 6d 61 6b 65 ync* (make
0a60: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
0a70: 20 75 73 65 64 20 74 6f 20 72 65 63 6f 72 64 20 used to record
0a80: 6c 61 73 74 20 74 6f 75 63 68 20 6f 66 20 64 62 last touch of db
0a90: 0a 28 64 65 66 69 6e 65 20 2a 6d 65 67 61 74 65 .(define *megate
0aa0: 73 74 2d 64 62 2a 20 20 20 20 20 20 20 20 20 23 st-db* #
0ab0: 66 29 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 f).(define *last
0ac0: 2d 64 62 2d 61 63 63 65 73 73 2a 20 20 20 20 20 -db-access*
0ad0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
0ae0: 73 29 29 20 20 3b 3b 20 75 70 64 61 74 65 20 77 s)) ;; update w
0af0: 68 65 6e 20 64 62 20 69 73 20 61 63 63 65 73 73 hen db is access
0b00: 65 64 20 76 69 61 20 73 65 72 76 65 72 0a 28 64 ed via server.(d
0b10: 65 66 69 6e 65 20 2a 64 62 2d 77 72 69 74 65 2d efine *db-write-
0b20: 61 63 63 65 73 73 2a 20 20 20 20 20 23 74 29 0a access* #t).
0b30: 28 64 65 66 69 6e 65 20 2a 69 6e 6d 65 6d 64 62 (define *inmemdb
0b40: 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 * #f
0b50: 29 0a 28 64 65 66 69 6e 65 20 2a 74 61 73 6b 2d ).(define *task-
0b60: 64 62 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 db*
0b70: 23 66 29 20 3b 3b 20 28 76 65 63 74 6f 72 20 64 #f) ;; (vector d
0b80: 62 20 70 61 74 68 2d 74 6f 2d 64 62 29 0a 28 64 b path-to-db).(d
0b90: 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 73 73 efine *db-access
0ba0: 2d 61 6c 6c 6f 77 65 64 2a 20 20 20 23 74 29 20 -allowed* #t)
0bb0: 3b 3b 20 66 6c 61 67 20 74 6f 20 61 6c 6c 6f 77 ;; flag to allow
0bc0: 20 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 20 access.(define
0bd0: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
0be0: 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 * (make-mute
0bf0: 78 29 29 0a 0a 3b 3b 20 53 45 52 56 45 52 0a 28 x))..;; SERVER.(
0c00: 64 65 66 69 6e 65 20 2a 6d 79 2d 63 6c 69 65 6e define *my-clien
0c10: 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 23 66 29 t-signature* #f)
0c20: 0a 28 64 65 66 69 6e 65 20 2a 74 72 61 6e 73 70 .(define *transp
0c30: 6f 72 74 2d 74 79 70 65 2a 20 20 20 20 27 68 74 ort-type* 'ht
0c40: 74 70 29 0a 28 64 65 66 69 6e 65 20 2a 74 72 61 tp).(define *tra
0c50: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 20 20 20 nsport-type*
0c60: 27 68 74 74 70 29 20 20 20 20 20 20 20 20 20 20 'http)
0c70: 20 20 20 3b 3b 20 6f 76 65 72 72 69 64 65 20 77 ;; override w
0c80: 69 74 68 20 5b 73 65 72 76 65 72 5d 20 74 72 61 ith [server] tra
0c90: 6e 73 70 6f 72 74 20 68 74 74 70 7c 72 70 63 7c nsport http|rpc|
0ca0: 6e 6d 73 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 nmsg.(define *ru
0cb0: 6e 72 65 6d 6f 74 65 2a 20 20 20 20 20 20 20 20 nremote*
0cc0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0cd0: 65 29 29 20 3b 3b 20 69 66 20 73 65 74 20 75 70 e)) ;; if set up
0ce0: 20 66 6f 72 20 73 65 72 76 65 72 20 63 6f 6d 6d for server comm
0cf0: 75 6e 69 63 61 74 69 6f 6e 20 74 68 69 73 20 77 unication this w
0d00: 69 6c 6c 20 68 6f 6c 64 20 3c 68 6f 73 74 20 70 ill hold <host p
0d10: 6f 72 74 3e 0a 28 64 65 66 69 6e 65 20 2a 6d 61 ort>.(define *ma
0d20: 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 20 20 x-cache-size*
0d30: 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 67 0).(define *log
0d40: 67 65 64 2d 69 6e 2d 63 6c 69 65 6e 74 73 2a 20 ged-in-clients*
0d50: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
0d60: 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 6c 69 65 )).(define *clie
0d70: 6e 74 2d 6e 6f 6e 2d 62 6c 6f 63 6b 69 6e 67 2d nt-non-blocking-
0d80: 6d 6f 64 65 2a 20 23 66 29 0a 28 64 65 66 69 6e mode* #f).(defin
0d90: 65 20 2a 73 65 72 76 65 72 2d 69 64 2a 20 20 20 e *server-id*
0da0: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
0db0: 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 e *server-info*
0dc0: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
0dd0: 65 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a e *time-to-exit*
0de0: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
0df0: 65 20 2a 72 65 63 65 69 76 65 64 2d 72 65 73 70 e *received-resp
0e00: 6f 6e 73 65 2a 20 23 66 29 0a 28 64 65 66 69 6e onse* #f).(defin
0e10: 65 20 2a 64 65 66 61 75 6c 74 2d 6e 75 6d 74 72 e *default-numtr
0e20: 69 65 73 2a 20 20 31 30 29 0a 28 64 65 66 69 6e ies* 10).(defin
0e30: 65 20 2a 73 65 72 76 65 72 2d 72 75 6e 2a 20 20 e *server-run*
0e40: 20 20 20 20 20 20 23 74 29 0a 28 64 65 66 69 6e #t).(defin
0e50: 65 20 2a 72 75 6e 2d 69 64 2a 20 20 20 20 20 20 e *run-id*
0e60: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
0e70: 65 20 2a 73 65 72 76 65 72 2d 6b 69 6e 64 2d 72 e *server-kind-r
0e80: 75 6e 2a 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 un* (make-hash
0e90: 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 66 69 6e -table))..(defin
0ea0: 65 20 2a 74 61 72 67 65 74 2a 20 20 20 20 20 20 e *target*
0eb0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
0ec0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 -table)) ;; cach
0ed0: 65 20 74 68 65 20 74 61 72 67 65 74 20 68 65 72 e the target her
0ee0: 65 3b 20 74 61 72 67 65 74 20 69 73 20 6b 65 79 e; target is key
0ef0: 76 61 6c 31 2f 6b 65 79 76 61 6c 32 2f 2e 2e 2e val1/keyval2/...
0f00: 2f 6b 65 79 76 61 6c 4e 0a 28 64 65 66 69 6e 65 /keyvalN.(define
0f10: 20 2a 6b 65 79 73 2a 20 20 20 20 20 20 20 20 20 *keys*
0f20: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
0f30: 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 table)) ;; cache
0f40: 20 74 68 65 20 6b 65 79 73 20 68 65 72 65 0a 28 the keys here.(
0f50: 64 65 66 69 6e 65 20 2a 6b 65 79 76 61 6c 73 2a define *keyvals*
0f60: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
0f70: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 -hash-table)).(d
0f80: 65 66 69 6e 65 20 2a 74 6f 70 74 65 73 74 2d 70 efine *toptest-p
0f90: 61 74 68 73 2a 20 20 20 20 20 28 6d 61 6b 65 2d aths* (make-
0fa0: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
0fb0: 63 61 63 68 65 20 74 6f 70 74 65 73 74 20 70 61 cache toptest pa
0fc0: 74 68 20 73 65 74 74 69 6e 67 73 20 68 65 72 65 th settings here
0fd0: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 70 .(define *test-p
0fe0: 61 74 68 73 2a 20 20 20 20 20 20 20 20 28 6d 61 aths* (ma
0ff0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1000: 3b 3b 20 63 61 63 68 65 20 74 65 73 74 2d 69 64 ;; cache test-id
1010: 20 74 6f 20 74 65 73 74 20 72 75 6e 20 70 61 74 to test run pat
1020: 68 73 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 hs here.(define
1030: 2a 74 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 *test-ids*
1040: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1050: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
1060: 72 75 6e 2d 69 64 2c 20 74 65 73 74 6e 61 6d 65 run-id, testname
1070: 2c 20 61 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 , and item-path
1080: 3d 3e 20 74 65 73 74 2d 69 64 0a 28 64 65 66 69 => test-id.(defi
1090: 6e 65 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 ne *test-info*
10a0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
10b0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 h-table)) ;; cac
10c0: 68 65 20 74 68 65 20 74 65 73 74 20 69 6e 66 6f he the test info
10d0: 20 72 65 63 6f 72 64 73 2c 20 75 70 64 61 74 65 records, update
10e0: 20 74 68 65 20 73 74 61 74 65 2c 20 73 74 61 74 the state, stat
10f0: 75 73 2c 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e us, run_duration
1100: 20 65 74 63 2e 20 66 72 6f 6d 20 74 65 73 74 64 etc. from testd
1110: 61 74 2e 64 62 0a 0a 28 64 65 66 69 6e 65 20 2a at.db..(define *
1120: 72 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 run-info-cache*
1130: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1140: 62 6c 65 29 29 20 3b 3b 20 72 75 6e 20 69 6e 66 ble)) ;; run inf
1150: 6f 20 69 73 20 73 74 61 62 6c 65 2c 20 6e 6f 20 o is stable, no
1160: 6e 65 65 64 20 74 6f 20 72 65 67 65 74 0a 0a 3b need to reget..;
1170: 3b 20 41 77 66 75 6c 2e 20 50 6c 65 61 73 65 20 ; Awful. Please
1180: 46 49 58 4d 45 0a 28 64 65 66 69 6e 65 20 2a 65 FIXME.(define *e
1190: 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 nv-vars-by-run-i
11a0: 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 d* (make-hash-ta
11b0: 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 ble)).(define *c
11c0: 75 72 72 65 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a urrent-run-name*
11d0: 20 20 20 23 66 29 0a 0a 3b 3b 20 54 65 73 74 63 #f)..;; Testc
11e0: 6f 6e 66 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e onfig and runcon
11f0: 66 69 67 20 63 61 63 68 65 73 2e 20 0a 28 64 65 fig caches. .(de
1200: 66 69 6e 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 fine *testconfig
1210: 73 2a 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 s* (make-h
1220: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 ash-table)) ;; t
1230: 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 est-name => test
1240: 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 2a config.(define *
1250: 72 75 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 runconfigs*
1260: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1270: 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 74 20 ble)) ;; target
1280: 20 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 0a => runconfig.
1290: 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 63 61 .;; This is a ca
12a0: 63 68 65 20 6f 66 20 70 72 65 2d 72 65 71 73 20 che of pre-reqs
12b0: 6d 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d 63 61 met, don't re-ca
12c0: 6c 63 20 69 6e 20 63 61 73 65 73 20 77 68 65 72 lc in cases wher
12d0: 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 73 61 e called with sa
12e0: 6d 65 20 70 61 72 61 6d 73 20 6c 65 73 73 20 74 me params less t
12f0: 68 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 63 6f han.;; five seco
1300: 6e 64 73 20 61 67 6f 0a 28 64 65 66 69 6e 65 20 nds ago.(define
1310: 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 *pre-reqs-met-ca
1320: 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d che* (make-hash-
1330: 74 61 62 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 table))..(define
1340: 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 (common:clear-c
1350: 61 63 68 65 73 29 0a 20 20 28 73 65 74 21 20 2a aches). (set! *
1360: 74 61 72 67 65 74 2a 20 20 20 20 20 20 20 20 20 target*
1370: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1380: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
1390: 6b 65 79 73 2a 20 20 20 20 20 20 20 20 20 20 20 keys*
13a0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
13b0: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
13c0: 6b 65 79 76 61 6c 73 2a 20 20 20 20 20 20 20 20 keyvals*
13d0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
13e0: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
13f0: 74 6f 70 74 65 73 74 2d 70 61 74 68 73 2a 20 20 toptest-paths*
1400: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1410: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
1420: 74 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 20 test-paths*
1430: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1440: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
1450: 74 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 20 test-ids*
1460: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1470: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
1480: 74 65 73 74 2d 69 6e 66 6f 2a 20 20 20 20 20 20 test-info*
1490: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
14a0: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
14b0: 72 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 run-info-cache*
14c0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
14d0: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
14e0: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
14f0: 69 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 id* (make-hash-t
1500: 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a able)). (set! *
1510: 74 65 73 74 2d 69 64 2d 63 61 63 68 65 2a 20 20 test-id-cache*
1520: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1530: 61 62 6c 65 29 29 29 0a 0a 3b 3b 20 47 65 6e 65 able)))..;; Gene
1540: 72 69 63 20 73 74 72 69 6e 67 20 64 61 74 61 62 ric string datab
1550: 61 73 65 0a 28 64 65 66 69 6e 65 20 73 64 62 3a ase.(define sdb:
1560: 71 72 79 20 23 66 29 20 3b 3b 20 28 6d 61 6b 65 qry #f) ;; (make
1570: 2d 73 64 62 3a 71 72 79 29 29 20 3b 3b 20 20 27 -sdb:qry)) ;; '
1580: 69 6e 69 74 20 23 66 29 0a 3b 3b 20 47 65 6e 65 init #f).;; Gene
1590: 72 69 63 20 70 61 74 68 20 64 61 74 61 62 61 73 ric path databas
15a0: 65 0a 28 64 65 66 69 6e 65 20 2a 66 64 62 2a 20 e.(define *fdb*
15b0: 23 66 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d #f)..;;=========
15c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
1600: 20 56 20 45 20 52 20 53 20 49 20 4f 20 4e 0a 3b V E R S I O N.;
1610: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1650: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
1660: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c (common:get-ful
1670: 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 63 6f l-version). (co
1680: 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 nc megatest-vers
1690: 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 74 ion "-" megatest
16a0: 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a 0a -fossil-hash))..
16b0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
16c0: 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 version-signatur
16d0: 65 29 0a 20 20 28 63 6f 6e 63 20 6d 65 67 61 74 e). (conc megat
16e0: 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 est-version "-"
16f0: 28 73 75 62 73 74 72 69 6e 67 20 6d 65 67 61 74 (substring megat
1700: 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 20 est-fossil-hash
1710: 30 20 34 29 29 29 0a 0a 3b 3b 20 66 72 6f 6d 20 0 4)))..;; from
1720: 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 70 20 4d metadat lookup M
1730: 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 0a EGATEST_VERSION.
1740: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
1750: 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d on:get-last-run-
1760: 76 65 72 73 69 6f 6e 29 20 3b 3b 20 52 41 44 54 version) ;; RADT
1770: 20 3d 3e 20 48 6f 77 20 64 6f 65 73 20 74 68 69 => How does thi
1780: 73 20 77 6f 72 6b 20 69 6e 20 73 65 6e 64 2d 72 s work in send-r
1790: 65 63 65 69 76 65 20 66 75 6e 63 74 69 6f 6e 3f eceive function?
17a0: 3f 3b 20 61 73 73 75 6d 65 20 69 74 20 69 73 20 ?; assume it is
17b0: 74 68 65 20 76 61 6c 75 65 20 73 61 76 65 64 20 the value saved
17c0: 69 6e 20 73 6f 6d 65 20 44 42 0a 20 20 28 72 6d in some DB. (rm
17d0: 74 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 41 54 t:get-var "MEGAT
17e0: 45 53 54 5f 56 45 52 53 49 4f 4e 22 29 29 0a 0a EST_VERSION"))..
17f0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
1800: 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 get-last-run-ver
1810: 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 20 28 sion-number). (
1820: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a string->number .
1830: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 28 63 (substring (c
1840: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 ommon:get-last-r
1850: 75 6e 2d 76 65 72 73 69 6f 6e 29 20 30 20 36 29 un-version) 0 6)
1860: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
1870: 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e mon:set-last-run
1880: 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 72 6d 74 -version). (rmt
1890: 3a 73 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 :set-var "MEGATE
18a0: 53 54 5f 56 45 52 53 49 4f 4e 22 20 28 63 6f 6d ST_VERSION" (com
18b0: 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e mon:version-sign
18c0: 61 74 75 72 65 29 29 29 0a 0a 28 64 65 66 69 6e ature)))..(defin
18d0: 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f e (common:versio
18e0: 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 28 6e n-changed?). (n
18f0: 6f 74 20 28 65 71 75 61 6c 3f 20 28 63 6f 6d 6d ot (equal? (comm
1900: 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d on:get-last-run-
1910: 76 65 72 73 69 6f 6e 29 0a 09 20 20 20 20 20 20 version)..
1920: 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e (common:version
1930: 2d 73 69 67 6e 61 74 75 72 65 29 29 29 29 0a 0a -signature))))..
1940: 3b 3b 20 4d 6f 76 65 20 6d 65 20 65 6c 73 65 77 ;; Move me elsew
1950: 68 65 72 65 20 2e 2e 2e 0a 3b 3b 20 52 41 44 54 here ....;; RADT
1960: 20 3d 3e 20 57 68 79 20 64 6f 20 77 65 20 6d 65 => Why do we me
1970: 65 64 20 74 68 65 20 76 65 72 73 69 6f 6e 20 63 ed the version c
1980: 68 65 63 6b 20 68 65 72 65 2c 20 74 68 69 73 20 heck here, this
1990: 69 73 20 63 61 6c 6c 65 64 20 6f 6e 6c 79 20 69 is called only i
19a0: 66 20 76 65 72 73 69 6f 6e 20 6d 69 73 6d 61 0a f version misma.
19b0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
19c0: 6f 6e 3a 63 6c 65 61 6e 75 70 2d 64 62 29 0a 20 on:cleanup-db).
19d0: 20 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 (db:multi-db-sy
19e0: 6e 63 20 0a 20 20 20 23 66 20 3b 3b 20 64 6f 20 nc . #f ;; do
19f0: 61 6c 6c 20 72 75 6e 2d 69 64 73 0a 20 20 20 3b all run-ids. ;
1a00: 3b 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 27 6b ; 'new2old. 'k
1a10: 69 6c 6c 73 65 72 76 65 72 73 0a 20 20 20 27 64 illservers. 'd
1a20: 65 6a 75 6e 6b 0a 20 20 20 3b 3b 20 27 61 64 6a ejunk. ;; 'adj
1a30: 2d 74 65 73 74 69 64 73 0a 20 20 20 3b 3b 20 27 -testids. ;; '
1a40: 6f 6c 64 32 6e 65 77 0a 20 20 20 27 6e 65 77 32 old2new. 'new2
1a50: 6f 6c 64 0a 20 20 20 27 73 63 68 65 6d 61 29 0a old. 'schema).
1a60: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 (if (common:ve
1a70: 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a rsion-changed?).
1a80: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 65 (common:se
1a90: 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 t-last-run-versi
1aa0: 6f 6e 29 29 29 0a 0a 3b 3b 20 46 6f 72 63 65 20 on)))..;; Force
1ab0: 61 20 6d 65 67 61 74 65 73 74 20 63 6c 65 61 6e a megatest clean
1ac0: 75 70 2d 64 62 20 69 66 20 76 65 72 73 69 6f 6e up-db if version
1ad0: 20 69 73 20 63 68 61 6e 67 65 64 20 61 6e 64 20 is changed and
1ae0: 73 6b 69 70 2d 76 65 72 73 69 6f 6e 2d 63 68 65 skip-version-che
1af0: 63 6b 20 6e 6f 74 20 73 70 65 63 69 66 69 65 64 ck not specified
1b00: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
1b10: 6d 6f 6e 3a 65 78 69 74 2d 6f 6e 2d 76 65 72 73 mon:exit-on-vers
1b20: 69 6f 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 ion-changed). (
1b30: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 if (common:versi
1b40: 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 20 on-changed?).
1b50: 20 20 20 28 6c 65 74 20 28 28 6d 74 63 6f 6e 66 (let ((mtconf
1b60: 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 (conc (get-envi
1b70: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
1b80: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
1b90: 4d 45 22 29 20 22 2f 6d 65 67 61 74 65 73 74 2e ME") "/megatest.
1ba0: 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 20 config"))).
1bb0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
1bc0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1bd0: 6f 72 74 2a 0a 09 09 20 20 20 20 20 22 57 41 52 ort*... "WAR
1be0: 4e 49 4e 47 3a 20 56 65 72 73 69 6f 6e 20 6d 69 NING: Version mi
1bf0: 73 6d 61 74 63 68 21 5c 6e 22 0a 09 09 20 20 20 smatch!\n"...
1c00: 20 20 22 20 20 20 65 78 70 65 63 74 65 64 3a 20 " expected:
1c10: 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f " (common:versio
1c20: 6e 2d 73 69 67 6e 61 74 75 72 65 29 20 22 5c 6e n-signature) "\n
1c30: 22 0a 09 09 20 20 20 20 20 22 20 20 20 67 6f 74 "... " got
1c40: 3a 20 20 20 20 20 20 22 20 28 63 6f 6d 6d 6f 6e : " (common
1c50: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
1c60: 72 73 69 6f 6e 29 29 0a 09 28 69 66 20 28 61 6e rsion))..(if (an
1c70: 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 d (file-exists?
1c80: 6d 74 63 6f 6e 66 29 0a 09 09 20 28 65 71 3f 20 mtconf)... (eq?
1c90: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 (current-user-id
1ca0: 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 )(file-owner mtc
1cb0: 6f 6e 66 29 29 29 20 3b 3b 20 73 61 66 65 20 74 onf))) ;; safe t
1cc0: 6f 20 72 75 6e 20 2d 63 6c 65 61 6e 75 70 2d 64 o run -cleanup-d
1cd0: 62 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 b.. (begin..
1ce0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
1cf0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
1d00: 2d 70 6f 72 74 2a 20 22 20 20 20 49 20 73 65 65 -port* " I see
1d10: 20 79 6f 75 20 61 72 65 20 74 68 65 20 6f 77 6e you are the own
1d20: 65 72 20 6f 66 20 6d 65 67 61 74 65 73 74 2e 63 er of megatest.c
1d30: 6f 6e 66 69 67 2c 20 61 74 74 65 6d 70 74 69 6e onfig, attemptin
1d40: 67 20 74 6f 20 63 6c 65 61 6e 75 70 20 61 6e 64 g to cleanup and
1d50: 20 72 65 73 65 74 20 74 6f 20 6e 65 77 20 76 65 reset to new ve
1d60: 72 73 69 6f 6e 22 29 0a 09 20 20 20 20 20 20 28 rsion").. (
1d70: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
1d80: 73 0a 09 20 20 20 20 20 20 20 65 78 6e 0a 09 20 s.. exn..
1d90: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 20 (begin...
1da0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
1db0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1dc0: 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 73 77 69 * "Failed to swi
1dd0: 74 63 68 20 76 65 72 73 69 6f 6e 73 2e 22 29 0a tch versions.").
1de0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
1df0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
1e00: 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 ort* " message:
1e10: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
1e20: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
1e30: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
1e40: 78 6e 29 29 0a 09 09 20 28 70 72 69 6e 74 2d 63 xn))... (print-c
1e50: 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 all-chain (curre
1e60: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
1e70: 09 09 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 .. (exit 1))..
1e80: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 (common:cle
1e90: 61 6e 75 70 2d 64 62 29 29 29 0a 09 20 20 20 20 anup-db)))..
1ea0: 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 (begin.. (d
1eb0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
1ec0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1ed0: 22 20 74 6f 20 73 77 69 74 63 68 20 76 65 72 73 " to switch vers
1ee0: 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 72 75 6e ions you can run
1ef0: 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 2d 63 6c : \"megatest -cl
1f00: 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a 09 20 20 eanup-db\"")..
1f10: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 29 (exit 1)))))
1f20: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
1f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 ===========.;; S
1f70: 20 50 20 41 20 52 20 53 20 45 20 20 20 41 20 52 P A R S E A R
1f80: 20 52 20 41 20 59 20 53 0a 3b 3b 3d 3d 3d 3d 3d R A Y S.;;=====
1f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fd0: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 =..(define (make
1fe0: 2d 73 70 61 72 73 65 2d 61 72 72 61 79 29 0a 20 -sparse-array).
1ff0: 20 28 6c 65 74 20 28 28 61 20 28 6d 61 6b 65 2d (let ((a (make-
2000: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 29 sparse-vector)))
2010: 0a 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 . (sparse-vec
2020: 74 6f 72 2d 73 65 74 21 20 61 20 30 20 28 6d 61 tor-set! a 0 (ma
2030: 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 ke-sparse-vector
2040: 29 29 0a 20 20 20 20 61 29 29 0a 0a 28 64 65 66 )). a))..(def
2050: 69 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 ine (sparse-arra
2060: 79 3f 20 61 29 0a 20 20 28 61 6e 64 20 28 73 70 y? a). (and (sp
2070: 61 72 73 65 2d 76 65 63 74 6f 72 3f 20 61 29 0a arse-vector? a).
2080: 20 20 20 20 20 20 20 28 73 70 61 72 73 65 2d 76 (sparse-v
2090: 65 63 74 6f 72 3f 20 28 73 70 61 72 73 65 2d 76 ector? (sparse-v
20a0: 65 63 74 6f 72 2d 72 65 66 20 61 20 30 29 29 29 ector-ref a 0)))
20b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 61 72 )..(define (spar
20c0: 73 65 2d 61 72 72 61 79 2d 72 65 66 20 61 20 78 se-array-ref a x
20d0: 20 79 29 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 y). (let ((row
20e0: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d (sparse-vector-
20f0: 72 65 66 20 61 20 78 29 29 29 0a 20 20 20 20 28 ref a x))). (
2100: 69 66 20 72 6f 77 0a 09 28 73 70 61 72 73 65 2d if row..(sparse-
2110: 76 65 63 74 6f 72 2d 72 65 66 20 72 6f 77 20 79 vector-ref row y
2120: 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e )..#f)))..(defin
2130: 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 2d e (sparse-array-
2140: 73 65 74 21 20 61 20 78 20 79 20 76 61 6c 29 0a set! a x y val).
2150: 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 70 (let ((row (sp
2160: 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 arse-vector-ref
2170: 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 72 a x))). (if r
2180: 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 74 ow..(sparse-vect
2190: 6f 72 2d 73 65 74 21 20 72 6f 77 20 79 20 76 61 or-set! row y va
21a0: 6c 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 2d 72 l)..(let ((new-r
21b0: 6f 77 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d ow (make-sparse-
21c0: 76 65 63 74 6f 72 29 29 29 0a 09 20 20 28 73 70 vector))).. (sp
21d0: 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 arse-vector-set!
21e0: 20 61 20 78 20 6e 65 77 2d 72 6f 77 29 0a 09 20 a x new-row)..
21f0: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d (sparse-vector-
2200: 73 65 74 21 20 6e 65 77 2d 72 6f 77 20 79 20 76 set! new-row y v
2210: 61 6c 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d al)))))..;;=====
2220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2260: 3d 0a 3b 3b 20 4c 20 4f 20 43 20 4b 20 45 20 52 =.;; L O C K E R
2270: 20 53 20 20 20 41 20 4e 20 44 20 20 20 42 20 4c S A N D B L
2280: 20 4f 20 43 20 4b 20 45 20 52 20 53 20 0a 3b 3b O C K E R S .;;
2290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22d0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 6b ======..;; block
22e0: 20 66 75 72 74 68 65 72 20 61 63 63 65 73 73 65 further accesse
22f0: 73 20 74 6f 20 64 61 74 61 62 61 73 65 73 2e 20 s to databases.
2300: 43 61 6c 6c 20 74 68 69 73 20 62 65 66 6f 72 65 Call this before
2310: 20 73 68 75 74 74 69 6e 67 20 64 62 20 64 6f 77 shutting db dow
2320: 6e 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f n.(define (commo
2330: 6e 3a 64 62 2d 62 6c 6f 63 6b 2d 66 75 72 74 68 n:db-block-furth
2340: 65 72 2d 71 75 65 72 69 65 73 29 0a 20 20 28 6d er-queries). (m
2350: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 utex-lock! *db-a
2360: 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a 20 20 ccess-mutex*).
2370: 28 73 65 74 21 20 2a 64 62 2d 61 63 63 65 73 73 (set! *db-access
2380: 2d 61 6c 6c 6f 77 65 64 2a 20 23 66 29 0a 20 20 -allowed* #f).
2390: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
23a0: 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a db-access-mutex*
23b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
23c0: 6d 6f 6e 3a 64 62 2d 61 63 63 65 73 73 2d 61 6c mon:db-access-al
23d0: 6c 6f 77 65 64 3f 29 0a 20 20 28 6c 65 74 20 28 lowed?). (let (
23e0: 28 76 61 6c 20 28 62 65 67 69 6e 0a 09 20 20 20 (val (begin..
23f0: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
2400: 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 *db-access-mute
2410: 78 2a 29 0a 09 20 20 20 20 20 20 20 2a 64 62 2d x*).. *db-
2420: 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 2a 0a access-allowed*.
2430: 09 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 . (mutex-u
2440: 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 nlock! *db-acces
2450: 73 2d 6d 75 74 65 78 2a 29 29 29 29 0a 20 20 20 s-mutex*)))).
2460: 20 76 61 6c 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d val))..;;======
2470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24b0: 0a 3b 3b 20 55 20 53 20 45 20 46 20 55 20 4c 20 .;; U S E F U L
24c0: 20 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d S T U F F.;;==
24d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
24f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2510: 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 ====..;; convert
2520: 20 74 68 69 6e 67 73 20 74 6f 20 61 6e 20 61 6c things to an al
2530: 69 73 74 20 6f 72 20 61 73 73 6f 63 20 6c 69 73 ist or assoc lis
2540: 74 2c 20 23 66 20 67 65 74 73 20 63 6f 6e 76 65 t, #f gets conve
2550: 72 74 65 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 rted to "".;;.(d
2560: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f efine (common:to
2570: 2d 61 6c 69 73 74 20 64 61 74 29 0a 20 20 28 63 -alist dat). (c
2580: 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 64 ond. ((list? d
2590: 61 74 29 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f at) (map commo
25a0: 6e 3a 74 6f 2d 61 6c 69 73 74 20 64 61 74 29 29 n:to-alist dat))
25b0: 0a 20 20 20 28 28 76 65 63 74 6f 72 3f 20 64 61 . ((vector? da
25c0: 74 29 0a 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d t). (map comm
25d0: 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 76 65 63 on:to-alist (vec
25e0: 74 6f 72 2d 3e 6c 69 73 74 20 64 61 74 29 29 29 tor->list dat)))
25f0: 0a 20 20 20 28 28 70 61 69 72 3f 20 64 61 74 29 . ((pair? dat)
2600: 0a 20 20 20 20 28 63 6f 6e 73 20 28 63 6f 6d 6d . (cons (comm
2610: 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 61 72 on:to-alist (car
2620: 20 64 61 74 29 29 0a 09 20 20 28 63 6f 6d 6d 6f dat)).. (commo
2630: 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 64 72 20 n:to-alist (cdr
2640: 64 61 74 29 29 29 29 0a 20 20 20 28 28 68 61 73 dat)))). ((has
2650: 68 2d 74 61 62 6c 65 3f 20 64 61 74 29 0a 20 20 h-table? dat).
2660: 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f (map common:to
2670: 2d 61 6c 69 73 74 20 28 68 61 73 68 2d 74 61 62 -alist (hash-tab
2680: 6c 65 2d 3e 61 6c 69 73 74 20 64 61 74 29 29 29 le->alist dat)))
2690: 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 69 . (else. (i
26a0: 66 20 64 61 74 0a 09 64 61 74 0a 09 22 22 29 29 f dat..dat..""))
26b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
26c0: 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 mon:low-noise-pr
26d0: 69 6e 74 20 77 61 69 74 76 61 6c 20 2e 20 6b 65 int waitval . ke
26e0: 79 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 ys). (let* ((ke
26f0: 79 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 y (string-i
2700: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
2710: 63 6f 6e 63 20 6b 65 79 73 29 20 22 2d 22 20 29 conc keys) "-" )
2720: 29 0a 09 20 28 6c 61 73 74 74 69 6d 65 20 28 68 ).. (lasttime (h
2730: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
2740: 66 61 75 6c 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 fault *common:de
2750: 6e 6f 69 73 65 2a 20 6b 65 79 20 30 29 29 0a 09 noise* key 0))..
2760: 20 28 63 75 72 72 74 69 6d 65 20 28 63 75 72 72 (currtime (curr
2770: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 ent-seconds))).
2780: 20 20 20 28 69 66 20 28 3e 20 28 2d 20 63 75 72 (if (> (- cur
2790: 72 74 69 6d 65 20 6c 61 73 74 74 69 6d 65 29 20 rtime lasttime)
27a0: 77 61 69 74 76 61 6c 29 0a 09 28 62 65 67 69 6e waitval)..(begin
27b0: 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
27c0: 73 65 74 21 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e set! *common:den
27d0: 6f 69 73 65 2a 20 6b 65 79 20 63 75 72 72 74 69 oise* key currti
27e0: 6d 65 29 0a 09 20 20 23 74 29 0a 09 23 66 29 29 me).. #t)..#f))
27f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
2800: 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d on:get-megatest-
2810: 65 78 65 29 0a 20 20 28 6f 72 20 28 67 65 74 65 exe). (or (gete
2820: 6e 76 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 nv "MT_MEGATEST"
2830: 29 20 22 6d 65 67 61 74 65 73 74 22 29 29 0a 0a ) "megatest"))..
2840: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
2850: 72 65 61 64 2d 65 6e 63 6f 64 65 64 2d 73 74 72 read-encoded-str
2860: 69 6e 67 20 69 6e 73 74 72 29 0a 20 20 28 68 61 ing instr). (ha
2870: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
2880: 20 20 20 65 78 6e 0a 20 20 20 28 68 61 6e 64 6c exn. (handl
2890: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
28a0: 20 65 78 6e 0a 20 20 20 20 28 62 65 67 69 6e 0a exn. (begin.
28b0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
28c0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
28d0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
28e0: 65 63 65 69 76 65 64 20 62 61 64 20 65 6e 63 6f eceived bad enco
28f0: 64 65 64 20 73 74 72 69 6e 67 20 5c 22 22 20 69 ded string \"" i
2900: 6e 73 74 72 20 22 5c 22 2c 20 6d 65 73 73 61 67 nstr "\", messag
2910: 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e e: " ((condition
2920: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
2930: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
2940: 29 20 65 78 6e 29 29 0a 20 20 20 20 20 20 28 70 ) exn)). (p
2950: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
2960: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
2970: 6f 72 74 29 29 0a 20 20 20 20 20 20 23 66 29 0a ort)). #f).
2980: 20 20 20 20 28 72 65 61 64 20 28 6f 70 65 6e 2d (read (open-
2990: 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 28 62 61 input-string (ba
29a0: 73 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f se64:base64-deco
29b0: 64 65 20 69 6e 73 74 72 29 29 29 29 0a 20 20 20 de instr)))).
29c0: 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 (read (open-inpu
29d0: 74 2d 73 74 72 69 6e 67 20 28 7a 33 3a 64 65 63 t-string (z3:dec
29e0: 6f 64 65 2d 62 75 66 66 65 72 20 28 62 61 73 65 ode-buffer (base
29f0: 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 64:base64-decode
2a00: 20 69 6e 73 74 72 29 29 29 29 29 29 0a 0a 3b 3b instr))))))..;;
2a10: 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 dot-locking egg
2a20: 20 73 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f seems not to wo
2a30: 72 6b 2c 20 75 73 69 6e 67 20 74 68 69 73 20 66 rk, using this f
2a40: 6f 72 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 or now.;; if loc
2a50: 6b 20 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 k is older than
2a60: 65 78 70 69 72 65 2d 74 69 6d 65 20 74 68 65 6e expire-time then
2a70: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 remove it and t
2a80: 72 79 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 ry again.;; to g
2a90: 65 74 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 et the lock.;;.(
2aa0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
2ab0: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
2ac0: 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 65 78 70 fname #!key (exp
2ad0: 69 72 65 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 ire-time 300)).
2ae0: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
2af0: 73 3f 20 66 6e 61 6d 65 29 0a 20 20 20 20 20 20 s? fname).
2b00: 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 (if (> (- (curre
2b10: 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 nt-seconds)(file
2b20: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
2b30: 6d 65 20 66 6e 61 6d 65 29 29 20 65 78 70 69 72 me fname)) expir
2b40: 65 2d 74 69 6d 65 29 0a 09 20 20 28 62 65 67 69 e-time).. (begi
2b50: 6e 0a 09 20 20 20 20 28 64 65 6c 65 74 65 2d 66 n.. (delete-f
2b60: 69 6c 65 2a 20 66 6e 61 6d 65 29 0a 09 20 20 20 ile* fname)..
2b70: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
2b80: 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 file-lock fname
2b90: 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 expire-time: exp
2ba0: 69 72 65 2d 74 69 6d 65 29 29 0a 09 20 20 23 66 ire-time)).. #f
2bb0: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b ). (let ((k
2bc0: 65 79 2d 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 ey-string (conc
2bd0: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 (get-host-name)
2be0: 22 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f "-" (current-pro
2bf0: 63 65 73 73 2d 69 64 29 29 29 29 0a 09 28 77 69 cess-id))))..(wi
2c00: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c th-output-to-fil
2c10: 65 20 66 6e 61 6d 65 0a 09 20 20 28 6c 61 6d 62 e fname.. (lamb
2c20: 64 61 20 28 29 0a 09 20 20 20 20 28 70 72 69 6e da ().. (prin
2c30: 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a t key-string))).
2c40: 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 .(thread-sleep!
2c50: 30 2e 32 35 29 0a 09 28 69 66 20 28 66 69 6c 65 0.25)..(if (file
2c60: 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a -exists? fname).
2c70: 09 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 . (with-input
2c80: 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 -from-file fname
2c90: 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 .. (lambda
2ca0: 28 29 0a 09 09 28 65 71 75 61 6c 3f 20 6b 65 79 ()...(equal? key
2cb0: 2d 73 74 72 69 6e 67 20 28 72 65 61 64 2d 6c 69 -string (read-li
2cc0: 6e 65 29 29 29 29 0a 09 20 20 20 20 23 66 29 29 ne)))).. #f))
2cd0: 29 29 0a 09 0a 28 64 65 66 69 6e 65 20 28 63 6f ))...(define (co
2ce0: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
2cf0: 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e -release-lock fn
2d00: 61 6d 65 29 0a 20 20 28 64 65 6c 65 74 65 2d 66 ame). (delete-f
2d10: 69 6c 65 2a 20 66 6e 61 6d 65 29 29 0a 0a 3b 3b ile* fname))..;;
2d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d60: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 54 20 41 20 ======.;; S T A
2d70: 54 20 45 20 53 20 20 20 41 20 4e 20 44 20 20 20 T E S A N D
2d80: 53 20 54 20 41 20 54 20 55 20 53 20 45 20 53 0a S T A T U S E S.
2d90: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
2da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2dd0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
2de0: 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 e *common:std-st
2df0: 61 74 65 73 2a 20 20 20 0a 20 20 27 28 28 30 20 ates* . '((0
2e00: 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 20 20 20 "COMPLETED").
2e10: 20 28 31 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 (1 "NOT_STARTED
2e20: 22 29 0a 20 20 20 20 28 32 20 22 52 55 4e 4e 49 "). (2 "RUNNI
2e30: 4e 47 22 29 0a 20 20 20 20 28 33 20 22 52 45 4d NG"). (3 "REM
2e40: 4f 54 45 48 4f 53 54 53 54 41 52 54 22 29 0a 20 OTEHOSTSTART").
2e50: 20 20 20 28 34 20 22 4c 41 55 4e 43 48 45 44 22 (4 "LAUNCHED"
2e60: 29 0a 20 20 20 20 28 35 20 22 4b 49 4c 4c 45 44 ). (5 "KILLED
2e70: 22 29 0a 20 20 20 20 28 36 20 22 4b 49 4c 4c 52 "). (6 "KILLR
2e80: 45 51 22 29 0a 20 20 20 20 28 37 20 22 53 54 55 EQ"). (7 "STU
2e90: 43 4b 22 29 0a 20 20 20 20 28 38 20 22 41 52 43 CK"). (8 "ARC
2ea0: 48 49 56 45 44 22 29 29 29 0a 0a 28 64 65 66 69 HIVED")))..(defi
2eb0: 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 ne *common:std-s
2ec0: 74 61 74 75 73 65 73 2a 0a 20 20 27 28 28 30 20 tatuses*. '((0
2ed0: 22 50 41 53 53 22 29 0a 20 20 20 20 28 31 20 22 "PASS"). (1 "
2ee0: 57 41 52 4e 22 29 0a 20 20 20 20 28 32 20 22 46 WARN"). (2 "F
2ef0: 41 49 4c 22 29 0a 20 20 20 20 28 33 20 22 43 48 AIL"). (3 "CH
2f00: 45 43 4b 22 29 0a 20 20 20 20 28 34 20 22 6e 2f ECK"). (4 "n/
2f10: 61 22 29 0a 20 20 20 20 28 35 20 22 57 41 49 56 a"). (5 "WAIV
2f20: 45 44 22 29 0a 20 20 20 20 28 36 20 22 53 4b 49 ED"). (6 "SKI
2f30: 50 22 29 0a 20 20 20 20 28 37 20 22 44 45 4c 45 P"). (7 "DELE
2f40: 54 45 44 22 29 0a 20 20 20 20 28 38 20 22 53 54 TED"). (8 "ST
2f50: 55 43 4b 2f 44 45 41 44 22 29 0a 20 20 20 20 28 UCK/DEAD"). (
2f60: 39 20 22 41 42 4f 52 54 22 29 29 29 0a 0a 3b 3b 9 "ABORT")))..;;
2f70: 20 54 68 65 73 65 20 61 72 65 20 73 74 6f 70 70 These are stopp
2f80: 69 6e 67 20 63 6f 6e 64 69 74 69 6f 6e 73 20 74 ing conditions t
2f90: 68 61 74 20 70 72 65 76 65 6e 74 20 61 20 74 65 hat prevent a te
2fa0: 73 74 20 66 72 6f 6d 20 62 65 69 6e 67 20 72 75 st from being ru
2fb0: 6e 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f n.(define *commo
2fc0: 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 n:cant-run-state
2fd0: 73 2d 73 79 6d 2a 20 0a 20 20 27 28 43 4f 4d 50 s-sym* . '(COMP
2fe0: 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 57 41 49 LETED KILLED WAI
2ff0: 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 4e 43 4f VED UNKNOWN INCO
3000: 4d 50 4c 45 54 45 20 41 42 4f 52 54 20 41 52 43 MPLETE ABORT ARC
3010: 48 49 56 45 44 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d HIVED))..;;=====
3020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3060: 3d 0a 3b 3b 20 44 20 45 20 42 20 55 20 47 20 47 =.;; D E B U G G
3070: 20 49 20 4e 20 47 20 20 20 53 20 54 20 55 20 46 I N G S T U F
3080: 20 46 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F .;;==========
3090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
30d0: 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 efine *verbosity
30e0: 2a 20 20 20 20 20 20 20 20 20 31 29 0a 28 64 65 * 1).(de
30f0: 66 69 6e 65 20 2a 6c 6f 67 67 69 6e 67 2a 20 20 fine *logging*
3100: 20 20 20 20 20 20 20 20 20 23 66 29 0a 0a 28 64 #f)..(d
3110: 65 66 69 6e 65 20 28 67 65 74 2d 77 69 74 68 2d efine (get-with-
3120: 64 65 66 61 75 6c 74 20 76 61 6c 20 64 65 66 61 default val defa
3130: 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 76 61 ult). (let ((va
3140: 6c 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 l (args:get-arg
3150: 76 61 6c 29 29 29 0a 20 20 20 20 28 69 66 20 76 val))). (if v
3160: 61 6c 20 76 61 6c 20 64 65 66 61 75 6c 74 29 29 al val default))
3170: 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 73 73 6f )..(define (asso
3180: 63 2f 64 65 66 61 75 6c 74 20 6b 65 79 20 6c 73 c/default key ls
3190: 74 20 2e 20 64 65 66 61 75 6c 74 29 0a 20 20 28 t . default). (
31a0: 6c 65 74 20 28 28 72 65 73 20 28 61 73 73 6f 63 let ((res (assoc
31b0: 20 6b 65 79 20 6c 73 74 29 29 29 0a 20 20 20 20 key lst))).
31c0: 28 69 66 20 72 65 73 20 28 63 61 64 72 20 72 65 (if res (cadr re
31d0: 73 29 28 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 s)(if (null? def
31e0: 61 75 6c 74 29 20 23 66 20 28 63 61 72 20 64 65 ault) #f (car de
31f0: 66 61 75 6c 74 29 29 29 29 29 0a 0a 28 64 65 66 fault)))))..(def
3200: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
3210: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a testsuite-name).
3220: 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c (or (configf:l
3230: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
3240: 2a 20 22 73 65 74 75 70 22 20 22 74 65 73 74 73 * "setup" "tests
3250: 75 69 74 65 22 20 29 0a 20 20 20 20 20 20 28 69 uite" ). (i
3260: 66 20 2a 74 6f 70 70 61 74 68 2a 20 0a 20 20 20 f *toppath* .
3270: 20 20 20 20 20 20 20 28 70 61 74 68 6e 61 6d 65 (pathname
3280: 2d 66 69 6c 65 20 2a 74 6f 70 70 61 74 68 2a 29 -file *toppath*)
3290: 0a 20 20 20 20 20 20 20 20 20 20 28 70 61 74 68 . (path
32a0: 6e 61 6d 65 2d 66 69 6c 65 20 28 63 75 72 72 65 name-file (curre
32b0: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 29 nt-directory))))
32c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
32d0: 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 70 61 74 68 on:get-area-path
32e0: 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 6d -signature). (m
32f0: 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 essage-digest-st
3300: 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 ring (md5-primit
3310: 69 76 65 29 20 2a 74 6f 70 70 61 74 68 2a 29 29 ive) *toppath*))
3320: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
3330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 ==========.;; E
3370: 58 20 49 20 54 20 20 20 48 20 41 20 4e 20 44 20 X I T H A N D
3380: 4c 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d L I N G.;;======
3390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33d0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
33e0: 6e 3a 6c 65 67 61 63 79 2d 73 79 6e 63 2d 72 65 n:legacy-sync-re
33f0: 63 6f 6d 6d 65 6e 64 65 64 29 0a 20 20 28 6f 72 commended). (or
3400: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
3410: 2d 72 75 6e 74 65 73 74 73 22 29 0a 20 20 20 20 -runtests").
3420: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
3430: 22 2d 73 65 72 76 65 72 22 29 0a 20 20 20 20 20 "-server").
3440: 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ;; (args:get-ar
3450: 67 20 22 2d 73 65 74 2d 72 75 6e 2d 73 74 61 74 g "-set-run-stat
3460: 75 73 22 29 0a 20 20 20 20 20 20 28 61 72 67 73 us"). (args
3470: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 6d 6f 76 :get-arg "-remov
3480: 65 2d 72 75 6e 73 22 29 0a 20 20 20 20 20 20 3b e-runs"). ;
3490: 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ; (args:get-arg
34a0: 22 2d 67 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 "-get-run-status
34b0: 22 29 0a 20 20 20 20 20 20 28 61 72 67 73 3a 67 "). (args:g
34c0: 65 74 2d 61 72 67 20 22 2d 75 73 65 2d 64 62 2d et-arg "-use-db-
34d0: 63 61 63 68 65 22 29 20 3b 3b 20 66 65 65 6c 73 cache") ;; feels
34e0: 20 6c 69 6b 65 20 61 20 62 61 64 20 69 64 65 61 like a bad idea
34f0: 20 2e 2e 2e 0a 20 20 20 20 20 20 29 29 0a 0a 28 .... ))..(
3500: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c define (common:l
3510: 65 67 61 63 79 2d 73 79 6e 63 2d 72 65 71 75 69 egacy-sync-requi
3520: 72 65 64 29 0a 20 20 28 63 6f 6e 66 69 67 66 3a red). (configf:
3530: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
3540: 74 2a 20 22 73 65 74 75 70 22 20 22 6d 65 67 61 t* "setup" "mega
3550: 74 65 73 74 2d 64 62 22 29 29 0a 0a 3b 3b 20 72 test-db"))..;; r
3560: 75 6e 2d 69 64 73 0a 3b 3b 20 20 20 20 69 66 20 un-ids.;; if
3570: 23 66 20 75 73 65 20 2a 64 62 2d 6c 6f 63 61 6c #f use *db-local
3580: 2d 73 79 6e 63 2a 0a 3b 3b 20 20 20 20 69 66 20 -sync*.;; if
3590: 23 74 20 75 73 65 20 74 69 6d 65 73 74 61 6d 70 #t use timestamp
35a0: 73 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f s.(define (commo
35b0: 6e 3a 73 79 6e 63 2d 74 6f 2d 6d 65 67 61 74 65 n:sync-to-megate
35c0: 73 74 2e 64 62 20 72 75 6e 2d 69 64 73 29 20 0a st.db run-ids) .
35d0: 20 20 28 6c 65 74 20 28 28 73 74 61 72 74 2d 74 (let ((start-t
35e0: 69 6d 65 20 20 20 20 20 20 20 20 20 28 63 75 72 ime (cur
35f0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 20 rent-seconds)).
3600: 20 20 20 20 20 20 20 28 72 75 6e 2d 69 64 73 2d (run-ids-
3610: 74 6f 2d 70 72 6f 63 65 73 73 20 28 69 66 20 28 to-process (if (
3620: 6c 69 73 74 3f 20 72 75 6e 2d 69 64 73 29 0a 20 list? run-ids).
3630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 r
3650: 75 6e 2d 69 64 73 0a 20 20 20 20 20 20 20 20 20 un-ids.
3660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3670: 20 20 20 20 20 20 20 28 69 66 20 72 75 6e 2d 69 (if run-i
3680: 64 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ds.
3690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
36a0: 20 20 20 20 20 20 20 28 64 62 3a 67 65 74 2d 63 (db:get-c
36b0: 68 61 6e 67 65 64 2d 72 75 6e 2d 69 64 73 20 28 hanged-run-ids (
36c0: 6c 65 74 2a 20 28 28 6d 74 64 62 2d 66 70 61 74 let* ((mtdb-fpat
36d0: 68 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 h (conc *toppath
36e0: 2a 20 22 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 * "/megatest.db"
36f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3730: 20 20 20 20 20 20 28 6d 74 64 62 2d 65 78 69 73 (mtdb-exis
3740: 74 73 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f ts (file-exists?
3750: 20 6d 74 64 62 2d 66 70 61 74 68 29 29 29 0a 20 mtdb-fpath))).
3760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3790: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
37a0: 20 6d 74 64 62 2d 65 78 69 73 74 73 0a 20 20 20 mtdb-exists.
37b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
37e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
37f0: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
3800: 6e 2d 74 69 6d 65 20 6d 74 64 62 2d 66 70 61 74 n-time mtdb-fpat
3810: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
3820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3850: 20 20 20 20 20 30 29 29 29 0a 20 20 20 20 20 20 0))).
3860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
3880: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a ash-table-keys *
3890: 64 62 2d 6c 6f 63 61 6c 2d 73 79 6e 63 2a 29 29 db-local-sync*))
38a0: 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 ))). (debug:p
38b0: 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 rint-info 4 *def
38c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
38d0: 50 72 6f 63 65 73 73 69 6e 67 20 72 75 6e 2d 69 Processing run-i
38e0: 64 73 3a 20 22 20 72 75 6e 2d 69 64 73 2d 74 6f ds: " run-ids-to
38f0: 2d 70 72 6f 63 65 73 73 29 0a 20 20 20 20 28 66 -process). (f
3900: 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c or-each . (l
3910: 61 6d 62 64 61 20 28 72 75 6e 2d 69 64 29 0a 20 ambda (run-id).
3920: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 (mutex-loc
3930: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
3940: 63 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 c-mutex*).
3950: 20 28 69 66 20 28 6f 72 20 72 75 6e 2d 69 64 73 (if (or run-ids
3960: 20 3b 3b 20 69 66 20 77 65 20 77 65 72 65 20 70 ;; if we were p
3970: 72 6f 76 69 64 65 64 20 77 69 74 68 20 72 75 6e rovided with run
3980: 2d 69 64 73 2c 20 70 72 6f 63 65 65 64 0a 20 20 -ids, proceed.
3990: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
39a0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
39b0: 61 75 6c 74 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 ault *db-local-s
39c0: 79 6e 63 2a 20 72 75 6e 2d 69 64 20 23 66 29 29 ync* run-id #f))
39d0: 0a 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 . ;; (
39e0: 69 66 20 28 3e 20 28 2d 20 73 74 61 72 74 2d 74 if (> (- start-t
39f0: 69 6d 65 20 6c 61 73 74 2d 77 72 69 74 65 29 20 ime last-write)
3a00: 35 29 20 3b 3b 20 65 76 65 72 79 20 66 69 76 65 5) ;; every five
3a10: 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 20 seconds.
3a20: 20 20 20 20 28 62 65 67 69 6e 20 3b 3b 20 6c 65 (begin ;; le
3a30: 74 20 28 28 73 79 6e 63 2d 74 69 6d 65 20 28 2d t ((sync-time (-
3a40: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
3a50: 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 29 s) start-time)))
3a60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 . (d
3a70: 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 b:multi-db-sync
3a80: 28 6c 69 73 74 20 72 75 6e 2d 69 64 29 20 27 6e (list run-id) 'n
3a90: 65 77 32 6f 6c 64 29 0a 20 20 20 20 20 20 20 20 ew2old).
3aa0: 20 20 20 20 20 28 6c 65 74 20 28 28 73 79 6e 63 (let ((sync
3ab0: 2d 74 69 6d 65 20 28 2d 20 28 63 75 72 72 65 6e -time (- (curren
3ac0: 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 t-seconds) start
3ad0: 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 20 -time))).
3ae0: 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 (debug:p
3af0: 72 69 6e 74 2d 69 6e 66 6f 20 33 20 2a 64 65 66 rint-info 3 *def
3b00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3b10: 53 79 6e 63 20 6f 66 20 6e 65 77 64 62 20 74 6f Sync of newdb to
3b20: 20 6f 6c 64 64 62 20 66 6f 72 20 72 75 6e 2d 69 olddb for run-i
3b30: 64 20 22 20 72 75 6e 2d 69 64 20 22 20 63 6f 6d d " run-id " com
3b40: 70 6c 65 74 65 64 20 69 6e 20 22 20 73 79 6e 63 pleted in " sync
3b50: 2d 74 69 6d 65 20 22 20 73 65 63 6f 6e 64 73 22 -time " seconds"
3b60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3b70: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (if (common:low
3b80: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 20 -noise-print 30
3b90: 22 73 79 6e 63 20 6e 65 77 20 74 6f 20 6f 6c 64 "sync new to old
3ba0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
3bb0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3bc0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
3bd0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 79 lt-log-port* "Sy
3be0: 6e 63 20 6f 66 20 6e 65 77 64 62 20 74 6f 20 6f nc of newdb to o
3bf0: 6c 64 64 62 20 66 6f 72 20 72 75 6e 2d 69 64 20 lddb for run-id
3c00: 22 20 72 75 6e 2d 69 64 20 22 20 63 6f 6d 70 6c " run-id " compl
3c10: 65 74 65 64 20 69 6e 20 22 20 73 79 6e 63 2d 74 eted in " sync-t
3c20: 69 6d 65 20 22 20 73 65 63 6f 6e 64 73 22 29 29 ime " seconds"))
3c30: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
3c40: 68 61 73 68 2d 74 61 62 6c 65 2d 64 65 6c 65 74 hash-table-delet
3c50: 65 21 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 79 6e e! *db-local-syn
3c60: 63 2a 20 72 75 6e 2d 69 64 29 29 29 0a 20 20 20 c* run-id))).
3c70: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
3c80: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
3c90: 63 2d 6d 75 74 65 78 2a 29 29 0a 20 20 20 20 20 c-mutex*)).
3ca0: 72 75 6e 2d 69 64 73 2d 74 6f 2d 70 72 6f 63 65 run-ids-to-proce
3cb0: 73 73 29 29 29 0a 0a 0a 0a 0a 28 64 65 66 69 6e ss))).....(defin
3cc0: 65 20 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 e (std-exit-proc
3cd0: 65 64 75 72 65 29 0a 20 20 28 6c 65 74 20 28 28 edure). (let ((
3ce0: 6e 6f 2d 68 75 72 72 79 20 20 28 69 66 20 2a 74 no-hurry (if *t
3cf0: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3b 3b 20 ime-to-exit* ;;
3d00: 68 75 72 72 79 20 75 70 0a 09 09 20 20 20 20 20 hurry up...
3d10: 20 20 23 66 0a 09 09 20 20 20 20 20 20 20 28 62 #f... (b
3d20: 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 2a egin.... (set! *
3d30: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 time-to-exit* #t
3d40: 29 0a 09 09 09 20 23 74 29 29 29 29 0a 20 20 20 ).... #t)))).
3d50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
3d60: 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
3d70: 67 2d 70 6f 72 74 2a 20 22 73 74 61 72 74 69 6e g-port* "startin
3d80: 67 20 65 78 69 74 20 70 72 6f 63 65 73 73 2c 20 g exit process,
3d90: 66 69 6e 61 6c 69 7a 69 6e 67 20 64 61 74 61 62 finalizing datab
3da0: 61 73 65 73 2e 22 29 0a 20 20 20 20 28 69 66 20 ases."). (if
3db0: 28 61 6e 64 20 6e 6f 2d 68 75 72 72 79 20 28 64 (and no-hurry (d
3dc0: 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 ebug:debug-mode
3dd0: 31 38 29 29 0a 09 28 72 6d 74 3a 70 72 69 6e 74 18))..(rmt:print
3de0: 2d 64 62 2d 73 74 61 74 73 29 29 0a 20 20 20 20 -db-stats)).
3df0: 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b 65 (let ((th1 (make
3e00: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
3e10: 28 29 20 3b 3b 20 74 68 72 65 61 64 20 66 6f 72 () ;; thread for
3e20: 20 63 6c 65 61 6e 69 6e 67 20 75 70 2c 20 67 69 cleaning up, gi
3e30: 76 65 20 69 74 20 66 69 76 65 20 73 65 63 6f 6e ve it five secon
3e40: 64 73 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 ds.... (let
3e50: 20 28 28 72 75 6e 2d 69 64 73 20 28 68 61 73 68 ((run-ids (hash
3e60: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 64 62 2d -table-keys *db-
3e70: 6c 6f 63 61 6c 2d 73 79 6e 63 2a 29 29 29 0a 09 local-sync*)))..
3e80: 09 09 09 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 ...(if (and (not
3e90: 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 73 29 (null? run-ids)
3ea0: 29 0a 09 09 09 09 09 20 28 6f 72 20 28 63 6f 6d )...... (or (com
3eb0: 6d 6f 6e 3a 6c 65 67 61 63 79 2d 73 79 6e 63 2d mon:legacy-sync-
3ec0: 72 65 63 6f 6d 6d 65 6e 64 65 64 29 0a 09 09 09 recommended)....
3ed0: 09 09 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a .. (configf:
3ee0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
3ef0: 74 2a 20 22 73 65 74 75 70 22 20 22 6d 65 67 61 t* "setup" "mega
3f00: 74 65 73 74 2d 64 62 22 29 29 29 0a 09 09 09 09 test-db"))).....
3f10: 20 20 20 20 28 69 66 20 6e 6f 2d 68 75 72 72 79 (if no-hurry
3f20: 20 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 (db:multi-db-sy
3f30: 6e 63 20 72 75 6e 2d 69 64 73 20 27 6e 65 77 32 nc run-ids 'new2
3f40: 6f 6c 64 29 29 29 29 0a 09 09 09 20 20 20 20 20 old))))....
3f50: 20 28 69 66 20 2a 64 62 73 74 72 75 63 74 2d 64 (if *dbstruct-d
3f60: 62 2a 20 28 64 62 3a 63 6c 6f 73 65 2d 61 6c 6c b* (db:close-all
3f70: 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 29 29 *dbstruct-db*))
3f80: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 2a 69 .... (if *i
3f90: 6e 6d 65 6d 64 62 2a 20 20 20 20 20 28 64 62 3a nmemdb* (db:
3fa0: 63 6c 6f 73 65 2d 61 6c 6c 20 2a 69 6e 6d 65 6d close-all *inmem
3fb0: 64 62 2a 29 29 0a 09 09 09 20 20 20 20 20 20 28 db*)).... (
3fc0: 69 66 20 28 61 6e 64 20 2a 6d 65 67 61 74 65 73 if (and *megates
3fd0: 74 2d 64 62 2a 0a 09 09 09 09 20 20 20 20 20 20 t-db*.....
3fe0: 20 28 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 (sqlite3:databa
3ff0: 73 65 3f 20 2a 6d 65 67 61 74 65 73 74 2d 64 62 se? *megatest-db
4000: 2a 29 29 0a 09 09 09 09 20 20 28 62 65 67 69 6e *))..... (begin
4010: 0a 09 09 09 09 20 20 20 20 28 73 71 6c 69 74 65 ..... (sqlite
4020: 33 3a 69 6e 74 65 72 72 75 70 74 21 20 2a 6d 65 3:interrupt! *me
4030: 67 61 74 65 73 74 2d 64 62 2a 29 0a 09 09 09 09 gatest-db*).....
4040: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e (sqlite3:fin
4050: 61 6c 69 7a 65 21 20 2a 6d 65 67 61 74 65 73 74 alize! *megatest
4060: 2d 64 62 2a 20 23 74 29 0a 09 09 09 09 20 20 20 -db* #t).....
4070: 20 28 73 65 74 21 20 2a 6d 65 67 61 74 65 73 74 (set! *megatest
4080: 2d 64 62 2a 20 23 66 29 29 29 0a 09 09 09 20 20 -db* #f)))....
4090: 20 20 20 20 28 69 66 20 2a 74 61 73 6b 2d 64 62 (if *task-db
40a0: 2a 20 20 20 20 0a 09 09 09 09 20 20 28 6c 65 74 * ..... (let
40b0: 20 28 28 64 62 20 28 63 64 72 20 2a 74 61 73 6b ((db (cdr *task
40c0: 2d 64 62 2a 29 29 29 0a 09 09 09 09 20 20 20 20 -db*))).....
40d0: 28 69 66 20 28 73 71 6c 69 74 65 33 3a 64 61 74 (if (sqlite3:dat
40e0: 61 62 61 73 65 3f 20 64 62 29 0a 09 09 09 09 09 abase? db)......
40f0: 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 28 73 (begin...... (s
4100: 71 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 70 74 qlite3:interrupt
4110: 21 20 64 62 29 0a 09 09 09 09 09 20 20 28 73 71 ! db)...... (sq
4120: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
4130: 64 62 20 23 74 29 0a 09 09 09 09 09 20 20 28 76 db #t)...... (v
4140: 65 63 74 6f 72 2d 73 65 74 21 20 2a 74 61 73 6b ector-set! *task
4150: 2d 64 62 2a 20 30 20 23 66 29 29 29 29 29 0a 09 -db* 0 #f)))))..
4160: 09 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f .. (close-o
4170: 75 74 70 75 74 2d 70 6f 72 74 20 2a 64 65 66 61 utput-port *defa
4180: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 0a 09 ult-log-port*)..
4190: 09 09 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 .. (set! *d
41a0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
41b0: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
41c0: 70 6f 72 74 29 29 29 20 22 43 6c 65 61 6e 75 70 port))) "Cleanup
41d0: 20 64 62 20 65 78 69 74 20 74 68 72 65 61 64 22 db exit thread"
41e0: 29 29 0a 09 20 20 28 74 68 32 20 28 6d 61 6b 65 )).. (th2 (make
41f0: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
4200: 28 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 ().... (deb
4210: 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 ug:print 4 *defa
4220: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 ult-log-port* "A
4230: 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 ttempting clean
4240: 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 exit. Please be
4250: 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 patient and wait
4260: 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 2e 2e a few seconds..
4270: 2e 22 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 .").... (if
4280: 20 6e 6f 2d 68 75 72 72 79 0a 09 09 09 09 20 20 no-hurry.....
4290: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
42a0: 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 63 6c ) ;; give the cl
42b0: 65 61 6e 20 75 70 20 66 65 77 20 73 65 63 6f 6e ean up few secon
42c0: 64 73 20 74 6f 20 64 6f 20 69 74 27 73 20 73 74 ds to do it's st
42d0: 75 66 66 0a 09 09 09 09 20 20 28 74 68 72 65 61 uff..... (threa
42e0: 64 2d 73 6c 65 65 70 21 20 32 29 29 0a 09 09 09 d-sleep! 2))....
42f0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
4300: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
4310: 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 64 6f g-port* " ... do
4320: 6e 65 22 29 0a 09 09 09 20 20 20 20 20 20 29 0a ne").... ).
4330: 09 09 09 20 20 20 20 22 63 6c 65 61 6e 20 65 78 ... "clean ex
4340: 69 74 22 29 29 29 0a 20 20 20 20 20 20 28 74 68 it"))). (th
4350: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
4360: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
4370: 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 tart! th2).
4380: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
4390: 68 31 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 h1))))..(define
43a0: 28 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 (std-signal-hand
43b0: 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 20 3b 3b ler signum). ;;
43c0: 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 (signal-mask! s
43d0: 69 67 6e 75 6d 29 0a 20 20 28 73 65 74 21 20 2a ignum). (set! *
43e0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 time-to-exit* #t
43f0: 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
4400: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
4410: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 t-log-port* "Rec
4420: 65 69 76 65 64 20 73 69 67 6e 61 6c 20 22 20 73 eived signal " s
4430: 69 67 6e 75 6d 20 22 20 65 78 69 74 69 6e 67 20 ignum " exiting
4440: 70 72 6f 6d 70 74 6c 79 22 29 0a 20 20 3b 3b 20 promptly"). ;;
4450: 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 (std-exit-proced
4460: 75 72 65 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 ure) ;; shouldn'
4470: 74 20 6e 65 65 64 20 74 68 69 73 20 73 69 6e 63 t need this sinc
4480: 65 20 77 65 20 61 72 65 20 65 78 69 74 69 6e 67 e we are exiting
4490: 20 61 6e 64 20 69 74 20 77 69 6c 6c 20 62 65 20 and it will be
44a0: 63 61 6c 6c 65 64 20 61 6e 79 77 61 79 0a 20 20 called anyway.
44b0: 28 65 78 69 74 29 29 0a 0a 28 73 65 74 2d 73 69 (exit))..(set-si
44c0: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 gnal-handler! si
44d0: 67 6e 61 6c 2f 69 6e 74 20 20 73 74 64 2d 73 69 gnal/int std-si
44e0: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b gnal-handler) ;
44f0: 3b 20 5e 43 0a 28 73 65 74 2d 73 69 67 6e 61 6c ; ^C.(set-signal
4500: 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c -handler! signal
4510: 2f 74 65 72 6d 20 73 74 64 2d 73 69 67 6e 61 6c /term std-signal
4520: 2d 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 28 73 65 -handler).;; (se
4530: 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 t-signal-handler
4540: 21 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 74 ! signal/stop st
4550: 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 d-signal-handler
4560: 29 20 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 6f 20 ) ;; ^Z NO, do
4570: 4e 4f 54 20 68 61 6e 64 6c 65 20 5e 5a 21 0a 0a NOT handle ^Z!..
4580: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
4590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45c0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 ========.;; M I
45d0: 53 20 43 20 20 20 55 20 54 20 49 20 4c 20 53 0a S C U T I L S.
45e0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
45f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4620: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6f 6e 65 ========..;; one
4630: 2d 6f 66 20 61 72 67 73 20 64 65 66 69 6e 65 64 -of args defined
4640: 0a 28 64 65 66 69 6e 65 20 28 61 72 67 73 2d 64 .(define (args-d
4650: 65 66 69 6e 65 64 3f 20 2e 20 70 61 72 61 6d 29 efined? . param)
4660: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
4670: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
4680: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
4690: 61 72 67 29 0a 20 20 20 20 20 20 20 28 69 66 20 arg). (if
46a0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 61 72 (args:get-arg ar
46b0: 67 29 28 73 65 74 21 20 72 65 73 20 23 74 29 29 g)(set! res #t))
46c0: 29 0a 20 20 20 20 20 70 61 72 61 6d 29 0a 20 20 ). param).
46d0: 20 20 72 65 73 29 29 0a 0a 3b 3b 20 63 6f 6e 76 res))..;; conv
46e0: 65 72 74 20 73 74 75 66 66 20 74 6f 20 61 20 6e ert stuff to a n
46f0: 75 6d 62 65 72 20 69 66 20 70 6f 73 73 69 62 6c umber if possibl
4700: 65 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 2d 3e e.(define (any->
4710: 6e 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 number val). (c
4720: 6f 6e 64 20 0a 20 20 20 28 28 6e 75 6d 62 65 72 ond . ((number
4730: 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 ? val) val). (
4740: 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 28 73 (string? val) (s
4750: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 tring->number va
4760: 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f l)). ((symbol?
4770: 20 76 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 6d 62 val) (any->numb
4780: 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 er (symbol->stri
4790: 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 28 65 6c ng val))). (el
47a0: 73 65 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e se #f)))..(defin
47b0: 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 2d 69 e (any->number-i
47c0: 66 2d 70 6f 73 73 69 62 6c 65 20 76 61 6c 29 0a f-possible val).
47d0: 20 20 28 6c 65 74 20 28 28 6e 75 6d 20 28 61 6e (let ((num (an
47e0: 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 29 y->number val)))
47f0: 0a 20 20 20 20 28 69 66 20 6e 75 6d 20 6e 75 6d . (if num num
4800: 20 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 val)))..(define
4810: 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 (patt-list-matc
4820: 68 20 69 74 65 6d 20 70 61 74 74 73 29 0a 20 20 h item patts).
4830: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4840: 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 8 *default-log
4850: 2d 70 6f 72 74 2a 20 22 70 61 74 74 2d 6c 69 73 -port* "patt-lis
4860: 74 2d 6d 61 74 63 68 20 69 74 65 6d 3d 22 20 69 t-match item=" i
4870: 74 65 6d 20 22 20 70 61 74 74 73 3d 22 20 70 61 tem " patts=" pa
4880: 74 74 73 29 0a 20 20 28 69 66 20 28 61 6e 64 20 tts). (if (and
4890: 69 74 65 6d 20 70 61 74 74 73 29 20 20 3b 3b 20 item patts) ;;
48a0: 68 65 72 65 20 77 65 20 61 72 65 20 66 69 6c 74 here we are filt
48b0: 65 72 69 6e 67 20 66 6f 72 20 6d 61 74 63 68 65 ering for matche
48c0: 73 20 77 69 74 68 20 69 74 65 6d 20 70 61 74 74 s with item patt
48d0: 65 72 6e 73 0a 20 20 20 20 20 20 28 6c 65 74 20 erns. (let
48e0: 28 28 72 65 73 20 23 66 29 29 20 20 20 3b 3b 20 ((res #f)) ;;
48f0: 6c 6f 6f 6b 20 74 68 72 6f 75 67 68 20 61 6c 6c look through all
4900: 20 74 68 65 20 69 74 65 6d 2d 70 61 74 74 73 20 the item-patts
4910: 69 66 20 64 65 66 69 6e 65 64 2c 20 66 6f 72 6d if defined, form
4920: 61 74 20 69 73 20 70 61 74 74 31 2c 70 61 74 74 at is patt1,patt
4930: 32 2c 70 61 74 74 33 20 2e 2e 2e 20 77 69 6c 64 2,patt3 ... wild
4940: 63 61 72 64 20 69 73 20 25 0a 09 28 66 6f 72 2d card is %..(for-
4950: 65 61 63 68 20 0a 09 20 28 6c 61 6d 62 64 61 20 each .. (lambda
4960: 28 70 61 74 74 29 0a 09 20 20 20 28 6c 65 74 20 (patt).. (let
4970: 28 28 6d 6f 64 70 61 74 74 20 28 73 74 72 69 6e ((modpatt (strin
4980: 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 25 22 g-substitute "%"
4990: 20 22 2e 2a 22 20 70 61 74 74 20 23 74 29 29 29 ".*" patt #t)))
49a0: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
49b0: 69 6e 74 2d 69 6e 66 6f 20 31 30 20 2a 64 65 66 int-info 10 *def
49c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
49d0: 70 61 74 74 20 22 20 70 61 74 74 20 22 20 6d 6f patt " patt " mo
49e0: 64 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 29 dpatt " modpatt)
49f0: 0a 09 20 20 20 20 20 28 69 66 20 28 73 74 72 69 .. (if (stri
4a00: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
4a10: 20 6d 6f 64 70 61 74 74 29 20 69 74 65 6d 29 0a modpatt) item).
4a20: 09 09 20 28 73 65 74 21 20 72 65 73 20 23 74 29 .. (set! res #t)
4a30: 29 29 29 0a 09 20 28 73 74 72 69 6e 67 2d 73 70 ))).. (string-sp
4a40: 6c 69 74 20 70 61 74 74 73 20 22 2c 22 29 29 0a lit patts ",")).
4a50: 09 72 65 73 29 0a 20 20 20 20 20 20 23 74 29 29 .res). #t))
4a60: 0a 0a 3b 3b 20 28 6d 61 70 20 70 72 69 6e 74 20 ..;; (map print
4a70: 28 6d 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 (map car (hash-t
4a80: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 28 72 65 61 able->alist (rea
4a90: 64 2d 63 6f 6e 66 69 67 20 22 72 75 6e 63 6f 6e d-config "runcon
4aa0: 66 69 67 73 2e 63 6f 6e 66 69 67 22 20 23 66 20 figs.config" #f
4ab0: 23 74 29 29 29 29 0a 28 64 65 66 69 6e 65 20 28 #t)))).(define (
4ac0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 75 6e 63 6f common:get-runco
4ad0: 6e 66 69 67 2d 74 61 72 67 65 74 73 20 23 21 6b nfig-targets #!k
4ae0: 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 29 29 ey (configf #f))
4af0: 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 73 20 . (let ((targs
4b00: 20 20 20 20 20 20 28 73 6f 72 74 20 28 6d 61 70 (sort (map
4b10: 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 6c 65 car (hash-table
4b20: 2d 3e 61 6c 69 73 74 0a 09 09 09 09 20 20 20 20 ->alist.....
4b30: 20 28 6f 72 20 63 6f 6e 66 69 67 66 0a 09 09 09 (or configf....
4b40: 09 09 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 .. (read-config
4b50: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
4b60: 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "/runconfigs.con
4b70: 66 69 67 22 29 0a 09 09 09 09 09 09 20 20 20 20 fig").......
4b80: 20 20 23 66 20 23 74 29 0a 09 09 09 09 09 20 28 #f #t)...... (
4b90: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
4ba0: 29 29 29 0a 09 09 09 20 20 20 73 74 72 69 6e 67 ))).... string
4bb0: 3c 3f 29 29 0a 09 28 74 61 72 67 65 74 2d 70 61 <?))..(target-pa
4bc0: 74 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 tt (args:get-arg
4bd0: 20 22 2d 74 61 72 67 65 74 22 29 29 29 0a 20 20 "-target"))).
4be0: 20 20 28 69 66 20 74 61 72 67 65 74 2d 70 61 74 (if target-pat
4bf0: 74 0a 09 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 t..(filter (lamb
4c00: 64 61 20 28 78 29 0a 09 09 20 20 28 70 61 74 74 da (x)... (patt
4c10: 2d 6c 69 73 74 2d 6d 61 74 63 68 20 78 20 74 61 -list-match x ta
4c20: 72 67 65 74 2d 70 61 74 74 29 29 0a 09 09 74 61 rget-patt))...ta
4c30: 72 67 73 29 0a 09 74 61 72 67 73 29 29 29 0a 0a rgs)..targs)))..
4c40: 3b 3b 20 27 28 70 72 69 6e 74 20 28 73 74 72 69 ;; '(print (stri
4c50: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
4c60: 6d 61 70 20 63 61 64 72 20 28 68 61 73 68 2d 74 map cadr (hash-t
4c70: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
4c80: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d (read-config "m
4c90: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 egatest.config"
4ca0: 5c 23 66 20 5c 23 74 29 20 22 64 69 73 6b 73 22 \#f \#t) "disks"
4cb0: 20 27 22 27 22 27 28 22 6e 6f 6e 65 22 20 22 22 '"'"'("none" ""
4cc0: 29 29 29 20 22 5c 6e 22 29 29 27 0a 28 64 65 66 ))) "\n"))'.(def
4cd0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
4ce0: 64 69 73 6b 73 20 23 21 6b 65 79 20 28 63 6f 6e disks #!key (con
4cf0: 66 69 67 66 20 23 66 29 29 0a 20 20 28 68 61 73 figf #f)). (has
4d00: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4d10: 75 6c 74 20 0a 20 20 20 28 6f 72 20 63 6f 6e 66 ult . (or conf
4d20: 69 67 66 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 igf (read-config
4d30: 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 "megatest.confi
4d40: 67 22 20 23 66 20 23 74 29 29 0a 20 20 20 22 64 g" #f #t)). "d
4d50: 69 73 6b 73 22 20 27 28 22 6e 6f 6e 65 22 20 22 isks" '("none" "
4d60: 22 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 ")))..;; return
4d70: 66 69 72 73 74 20 63 6f 6d 6d 61 6e 64 20 74 68 first command th
4d80: 61 74 20 65 78 69 73 74 73 2c 20 65 6c 73 65 20 at exists, else
4d90: 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 #f.;;.(define (c
4da0: 6f 6d 6d 6f 6e 3a 77 68 69 63 68 20 63 6d 64 73 ommon:which cmds
4db0: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 ). (if (null? c
4dc0: 6d 64 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 mds). #f.
4dd0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
4de0: 68 65 64 20 28 63 61 72 20 63 6d 64 73 29 29 0a hed (car cmds)).
4df0: 09 09 20 28 74 61 6c 20 28 63 64 72 20 63 6d 64 .. (tal (cdr cmd
4e00: 73 29 29 29 0a 09 28 6c 65 74 20 28 28 72 65 73 s)))..(let ((res
4e10: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
4e20: 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 77 68 m-pipe (conc "wh
4e30: 69 63 68 20 22 20 68 65 64 29 20 72 65 61 64 2d ich " hed) read-
4e40: 6c 69 6e 65 29 29 29 0a 09 20 20 28 69 66 20 28 line))).. (if (
4e50: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 72 65 73 and (string? res
4e60: 29 0a 09 09 20 20 20 28 66 69 6c 65 2d 65 78 69 )... (file-exi
4e70: 73 74 73 3f 20 72 65 73 29 29 0a 09 20 20 20 20 sts? res))..
4e80: 20 20 72 65 73 0a 09 20 20 20 20 20 20 28 69 66 res.. (if
4e90: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
4ea0: 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 #f... (loop (c
4eb0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
4ec0: 29 29 29 29 29 29 29 0a 20 20 0a 28 64 65 66 69 ))))))). .(defi
4ed0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 ne (common:get-i
4ee0: 6e 73 74 61 6c 6c 2d 61 72 65 61 29 0a 20 20 28 nstall-area). (
4ef0: 6c 65 74 20 28 28 65 78 65 2d 70 61 74 68 20 28 let ((exe-path (
4f00: 63 61 72 20 28 61 72 67 76 29 29 29 29 0a 20 20 car (argv)))).
4f10: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
4f20: 74 73 3f 20 65 78 65 2d 70 61 74 68 29 0a 09 28 ts? exe-path)..(
4f30: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
4f40: 73 0a 09 20 65 78 6e 0a 09 20 23 66 0a 09 20 28 s.. exn.. #f.. (
4f50: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
4f60: 72 79 0a 09 20 20 28 70 61 74 68 6e 61 6d 65 2d ry.. (pathname-
4f70: 64 69 72 65 63 74 6f 72 79 20 0a 09 20 20 20 28 directory .. (
4f80: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
4f90: 72 79 20 65 78 65 2d 70 61 74 68 29 29 29 29 0a ry exe-path)))).
4fa0: 09 23 66 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 .#f)))..;; retur
4fb0: 6e 20 66 69 72 73 74 20 70 61 74 68 20 74 68 61 n first path tha
4fc0: 74 20 63 61 6e 20 62 65 20 63 72 65 61 74 65 64 t can be created
4fd0: 20 6f 72 20 61 6c 72 65 61 64 79 20 65 78 69 73 or already exis
4fe0: 74 73 20 61 6e 64 20 69 73 20 77 72 69 74 61 62 ts and is writab
4ff0: 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 le.;;.(define (c
5000: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 74 65 ommon:get-create
5010: 2d 77 72 69 74 65 61 62 6c 65 2d 64 69 72 20 64 -writeable-dir d
5020: 69 72 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c irs). (if (null
5030: 3f 20 64 69 72 73 29 0a 20 20 20 20 20 20 23 66 ? dirs). #f
5040: 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 . (let loop
5050: 20 28 28 68 65 64 20 28 63 61 72 20 64 69 72 73 ((hed (car dirs
5060: 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 ))... (tal (cdr
5070: 64 69 72 73 29 29 29 0a 09 28 6c 65 74 20 28 28 dirs)))..(let ((
5080: 72 65 73 20 28 6f 72 20 28 61 6e 64 20 28 64 69 res (or (and (di
5090: 72 65 63 74 6f 72 79 3f 20 68 65 64 29 0a 09 09 rectory? hed)...
50a0: 09 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 . (file-write
50b0: 2d 61 63 63 65 73 73 3f 20 68 65 64 29 0a 09 09 -access? hed)...
50c0: 09 20 20 20 20 68 65 64 29 0a 09 09 20 20 20 20 . hed)...
50d0: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
50e0: 74 69 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 09 09 tions....exn....
50f0: 23 66 0a 09 09 09 28 63 72 65 61 74 65 2d 64 69 #f....(create-di
5100: 72 65 63 74 6f 72 79 20 68 65 64 20 23 74 29 29 rectory hed #t))
5110: 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ))).. (if (and
5120: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 (string? res)...
5130: 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 72 (directory? r
5140: 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 73 0a es)).. res.
5150: 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
5160: 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 ? tal)... #f...
5170: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
5180: 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 )(cdr tal)))))))
5190: 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ). .;;=========
51a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
51b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
51c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
51d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
51e0: 20 54 20 41 20 52 20 47 20 45 20 54 20 53 20 20 T A R G E T S
51f0: 2c 20 20 20 53 20 54 20 41 20 54 20 45 20 2c 20 , S T A T E ,
5200: 20 20 53 20 54 20 41 20 54 20 55 20 53 20 2c 20 S T A T U S ,
5210: 20 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 .;;
5220: 20 20 20 20 20 20 20 20 20 52 20 55 20 4e 20 4e R U N N
5230: 20 41 20 4d 20 45 20 20 20 20 41 20 4e 20 44 20 A M E A N D
5240: 20 20 54 20 45 20 53 20 54 20 50 20 41 20 54 20 T E S T P A T
5250: 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d T.;;============
5260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4c ==========..;; L
52a0: 6f 6f 6b 75 70 20 61 20 76 61 6c 75 65 20 69 6e ookup a value in
52b0: 20 72 75 6e 63 6f 6e 66 69 67 73 20 62 61 73 65 runconfigs base
52c0: 64 20 6f 6e 20 2d 72 65 71 74 61 72 67 20 6f 72 d on -reqtarg or
52d0: 20 2d 74 61 72 67 65 74 0a 28 64 65 66 69 6e 65 -target.(define
52e0: 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 65 74 (runconfigs-get
52f0: 20 63 6f 6e 66 69 67 20 76 61 72 29 0a 20 20 28 config var). (
5300: 6c 65 74 20 28 28 74 61 72 67 20 28 63 6f 6d 6d let ((targ (comm
5310: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 on:args-get-targ
5320: 65 74 29 29 29 20 3b 3b 20 28 6f 72 20 28 61 72 et))) ;; (or (ar
5330: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 gs:get-arg "-req
5340: 74 61 72 67 22 29 28 61 72 67 73 3a 67 65 74 2d targ")(args:get-
5350: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 28 67 arg "-target")(g
5360: 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 etenv "MT_TARGET
5370: 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 74 61 ")))). (if ta
5380: 72 67 0a 09 28 6f 72 20 28 63 6f 6e 66 69 67 66 rg..(or (configf
5390: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 74 :lookup config t
53a0: 61 72 67 20 76 61 72 29 0a 09 20 20 20 20 28 63 arg var).. (c
53b0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
53c0: 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 20 76 nfig "default" v
53d0: 61 72 29 29 0a 09 28 63 6f 6e 66 69 67 66 3a 6c ar))..(configf:l
53e0: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 64 65 ookup config "de
53f0: 66 61 75 6c 74 22 20 76 61 72 29 29 29 29 0a 0a fault" var))))..
5400: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
5410: 61 72 67 73 2d 67 65 74 2d 73 74 61 74 65 29 0a args-get-state).
5420: 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d (or (args:get-
5430: 61 72 67 20 22 2d 73 74 61 74 65 22 29 28 61 72 arg "-state")(ar
5440: 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 gs:get-arg ":sta
5450: 74 65 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 te")))..(define
5460: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
5470: 2d 73 74 61 74 75 73 29 0a 20 20 28 6f 72 20 28 -status). (or (
5480: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 args:get-arg "-s
5490: 74 61 74 75 73 22 29 28 61 72 67 73 3a 67 65 74 tatus")(args:get
54a0: 2d 61 72 67 20 22 3a 73 74 61 74 75 73 22 29 29 -arg ":status"))
54b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
54c0: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 65 73 74 on:args-get-test
54d0: 70 61 74 74 20 72 63 6f 6e 66 29 0a 20 20 28 6c patt rconf). (l
54e0: 65 74 2a 20 28 28 72 74 65 73 74 70 61 74 74 20 et* ((rtestpatt
54f0: 20 20 20 20 28 69 66 20 72 63 6f 6e 66 20 28 72 (if rconf (r
5500: 75 6e 63 6f 6e 66 69 67 73 2d 67 65 74 20 72 63 unconfigs-get rc
5510: 6f 6e 66 20 22 54 45 53 54 50 41 54 54 22 29 20 onf "TESTPATT")
5520: 23 66 29 29 0a 09 20 28 61 72 67 73 2d 74 65 73 #f)).. (args-tes
5530: 74 70 61 74 74 20 28 6f 72 20 28 61 72 67 73 3a tpatt (or (args:
5540: 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 get-arg "-testpa
5550: 74 74 22 29 0a 09 09 09 20 20 20 20 28 61 72 67 tt").... (arg
5560: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 s:get-arg "-runt
5570: 65 73 74 73 22 29 0a 09 09 09 20 20 20 20 22 25 ests").... "%
5580: 22 29 29 0a 09 20 28 74 65 73 74 70 61 74 74 20 ")).. (testpatt
5590: 20 20 20 28 6f 72 20 28 61 6e 64 20 28 65 71 75 (or (and (equ
55a0: 61 6c 3f 20 61 72 67 73 2d 74 65 73 74 70 61 74 al? args-testpat
55b0: 74 20 22 25 22 29 0a 09 09 09 20 20 20 20 20 20 t "%")....
55c0: 20 72 74 65 73 74 70 61 74 74 29 0a 09 09 09 20 rtestpatt)....
55d0: 20 61 72 67 73 2d 74 65 73 74 70 61 74 74 29 29 args-testpatt))
55e0: 29 0a 20 20 20 20 28 69 66 20 72 74 65 73 74 70 ). (if rtestp
55f0: 61 74 74 20 28 64 65 62 75 67 3a 70 72 69 6e 74 att (debug:print
5600: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5610: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 45 53 54 -log-port* "TEST
5620: 50 41 54 54 20 66 72 6f 6d 20 72 75 6e 63 6f 6e PATT from runcon
5630: 66 69 67 73 3a 20 22 20 72 74 65 73 74 70 61 74 figs: " rtestpat
5640: 74 29 29 0a 20 20 20 20 74 65 73 74 70 61 74 74 t)). testpatt
5650: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
5660: 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 mon:get-linktree
5670: 29 0a 20 20 28 6f 72 20 28 67 65 74 65 6e 76 20 ). (or (getenv
5680: 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 20 "MT_LINKTREE").
5690: 20 20 20 20 20 28 69 66 20 2a 63 6f 6e 66 69 67 (if *config
56a0: 64 61 74 2a 0a 09 20 20 28 63 6f 6e 66 69 67 66 dat*.. (configf
56b0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
56c0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 69 6e at* "setup" "lin
56d0: 6b 74 72 65 65 22 29 29 29 29 0a 0a 28 64 65 66 ktree"))))..(def
56e0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 ine (common:args
56f0: 2d 67 65 74 2d 72 75 6e 6e 61 6d 65 29 0a 20 20 -get-runname).
5700: 28 6c 65 74 20 28 28 72 65 73 20 28 6f 72 20 28 (let ((res (or (
5710: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
5720: 75 6e 6e 61 6d 65 22 29 0a 09 09 20 28 61 72 67 unname")... (arg
5730: 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e s:get-arg ":runn
5740: 61 6d 65 22 29 0a 09 09 20 28 67 65 74 65 6e 76 ame")... (getenv
5750: 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 29 29 "MT_RUNNAME")))
5760: 29 0a 20 20 20 20 3b 3b 20 28 69 66 20 72 65 73 ). ;; (if res
5770: 20 28 73 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (set-environmen
5780: 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 t-variable "MT_R
5790: 55 4e 4e 41 4d 45 22 20 72 65 73 29 29 20 3b 3b UNNAME" res)) ;;
57a0: 20 6e 6f 74 20 73 75 72 65 20 69 66 20 74 68 69 not sure if thi
57b0: 73 20 69 73 20 61 20 67 6f 6f 64 20 69 64 65 61 s is a good idea
57c0: 2e 20 73 69 64 65 20 65 66 66 65 63 74 20 61 6e . side effect an
57d0: 64 20 61 6c 6c 20 2e 2e 2e 0a 20 20 20 20 72 65 d all .... re
57e0: 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f s))..(define (co
57f0: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 mmon:args-get-ta
5800: 72 67 65 74 20 23 21 6b 65 79 20 28 73 70 6c 69 rget #!key (spli
5810: 74 20 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 t #f)). (let* (
5820: 28 6b 65 79 73 20 20 20 20 28 69 66 20 28 68 61 (keys (if (ha
5830: 73 68 2d 74 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 sh-table? *confi
5840: 67 64 61 74 2a 29 20 28 6b 65 79 73 3a 63 6f 6e gdat*) (keys:con
5850: 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 2a fig-get-fields *
5860: 63 6f 6e 66 69 67 64 61 74 2a 29 20 27 28 29 29 configdat*) '())
5870: 29 0a 09 20 28 6e 75 6d 6b 65 79 73 20 28 6c 65 ).. (numkeys (le
5880: 6e 67 74 68 20 6b 65 79 73 29 29 0a 09 20 28 74 ngth keys)).. (t
5890: 61 72 67 65 74 20 20 28 6f 72 20 28 61 72 67 73 arget (or (args
58a0: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
58b0: 72 67 22 29 0a 09 09 20 20 20 20 20 20 28 61 72 rg")... (ar
58c0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 gs:get-arg "-tar
58d0: 67 65 74 22 29 0a 09 09 20 20 20 20 20 20 28 67 get")... (g
58e0: 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 etenv "MT_TARGET
58f0: 22 29 29 29 0a 09 20 28 74 6c 69 73 74 20 20 20 "))).. (tlist
5900: 28 69 66 20 74 61 72 67 65 74 20 28 73 74 72 69 (if target (stri
5910: 6e 67 2d 73 70 6c 69 74 20 74 61 72 67 65 74 20 ng-split target
5920: 22 2f 22 20 23 74 29 20 27 28 29 29 29 0a 09 20 "/" #t) '()))..
5930: 28 76 61 6c 69 64 20 20 20 28 69 66 20 74 61 72 (valid (if tar
5940: 67 65 74 0a 09 09 20 20 20 20 20 20 28 6f 72 20 get... (or
5950: 28 6e 75 6c 6c 3f 20 6b 65 79 73 29 20 3b 3b 20 (null? keys) ;;
5960: 70 72 6f 62 61 62 6c 79 20 64 6f 6e 27 74 20 6b probably don't k
5970: 6e 6f 77 20 6f 75 72 20 6b 65 79 73 20 79 65 74 now our keys yet
5980: 0a 09 09 09 20 20 28 61 6e 64 20 28 6e 6f 74 20 .... (and (not
5990: 28 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 29 0a 09 (null? tlist))..
59a0: 09 09 20 20 20 20 20 20 20 28 65 71 3f 20 6e 75 .. (eq? nu
59b0: 6d 6b 65 79 73 20 28 6c 65 6e 67 74 68 20 74 6c mkeys (length tl
59c0: 69 73 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 ist))....
59d0: 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 73 (null? (filter s
59e0: 74 72 69 6e 67 2d 6e 75 6c 6c 3f 20 74 6c 69 73 tring-null? tlis
59f0: 74 29 29 29 29 0a 09 09 20 20 20 20 20 20 23 66 t))))... #f
5a00: 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c 69 ))). (if vali
5a10: 64 0a 09 28 69 66 20 73 70 6c 69 74 0a 09 20 20 d..(if split..
5a20: 20 20 74 6c 69 73 74 0a 09 20 20 20 20 74 61 72 tlist.. tar
5a30: 67 65 74 29 0a 09 28 69 66 20 74 61 72 67 65 74 get)..(if target
5a40: 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 .. (begin..
5a50: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5a60: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
5a70: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 76 t-log-port* "Inv
5a80: 61 6c 69 64 20 74 61 72 67 65 74 2c 20 73 70 61 alid target, spa
5a90: 63 65 73 20 6f 72 20 62 6c 61 6e 6b 73 20 6e 6f ces or blanks no
5aa0: 74 20 61 6c 6c 6f 77 65 64 20 5c 22 22 20 74 61 t allowed \"" ta
5ab0: 72 67 65 74 20 22 5c 22 2c 20 74 61 72 67 65 74 rget "\", target
5ac0: 20 73 68 6f 75 6c 64 20 62 65 3a 20 22 20 28 73 should be: " (s
5ad0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
5ae0: 65 20 6b 65 79 73 20 22 2f 22 29 20 22 2c 20 68 e keys "/") ", h
5af0: 61 76 65 20 22 20 74 6c 69 73 74 20 22 20 66 6f ave " tlist " fo
5b00: 72 20 65 6c 65 6d 65 6e 74 73 22 29 0a 09 20 20 r elements")..
5b10: 20 20 20 20 23 66 29 0a 09 20 20 20 20 23 66 29 #f).. #f)
5b20: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
5b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
5b70: 20 4d 20 49 20 53 20 43 20 20 20 4c 20 49 20 53 M I S C L I S
5b80: 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;=========
5b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
5bd0: 3b 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 61 ; items in lista
5be0: 20 61 72 65 20 6d 61 74 63 68 65 64 20 76 61 6c are matched val
5bf0: 75 65 20 61 6e 64 20 70 6f 73 69 74 69 6f 6e 20 ue and position
5c00: 69 6e 20 6c 69 73 74 62 0a 3b 3b 20 72 65 74 75 in listb.;; retu
5c10: 72 6e 20 74 68 65 20 72 65 6d 61 69 6e 69 6e 67 rn the remaining
5c20: 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 items in listb
5c30: 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 or #f.;;.(define
5c40: 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 69 73 (common:list-is
5c50: 2d 73 75 62 6c 69 73 74 20 6c 69 73 74 61 20 6c -sublist lista l
5c60: 69 73 74 62 29 0a 20 20 28 69 66 20 28 6e 75 6c istb). (if (nul
5c70: 6c 3f 20 6c 69 73 74 61 29 0a 20 20 20 20 20 20 l? lista).
5c80: 6c 69 73 74 62 20 3b 3b 20 61 6c 6c 20 69 74 65 listb ;; all ite
5c90: 6d 73 20 69 6e 20 6c 69 73 74 62 20 61 72 65 20 ms in listb are
5ca0: 22 72 65 6d 61 69 6e 69 6e 67 22 0a 20 20 20 20 "remaining".
5cb0: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
5cc0: 20 6c 69 73 74 61 29 28 6c 65 6e 67 74 68 20 6c lista)(length l
5cd0: 69 73 74 62 29 29 20 0a 09 20 20 23 66 0a 09 20 istb)) .. #f..
5ce0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
5cf0: 61 20 28 63 61 72 20 6c 69 73 74 61 29 29 0a 09 a (car lista))..
5d00: 09 20 20 20 20 20 28 74 61 6c 61 20 28 63 64 72 . (tala (cdr
5d10: 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 20 lista))...
5d20: 28 68 65 64 62 20 28 63 61 72 20 6c 69 73 74 62 (hedb (car listb
5d30: 29 29 0a 09 09 20 20 20 20 20 28 74 61 6c 62 20 ))... (talb
5d40: 28 63 64 72 20 6c 69 73 74 62 29 29 29 0a 09 20 (cdr listb)))..
5d50: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 68 (if (equal? h
5d60: 65 64 61 20 68 65 64 62 29 0a 09 09 28 69 66 20 eda hedb)...(if
5d70: 28 6e 75 6c 6c 3f 20 74 61 6c 61 29 20 3b 3b 20 (null? tala) ;;
5d80: 77 65 20 61 72 65 20 64 6f 6e 65 0a 09 09 20 20 we are done...
5d90: 20 20 74 61 6c 62 0a 09 09 20 20 20 20 28 6c 6f talb... (lo
5da0: 6f 70 20 28 63 61 72 20 74 61 6c 61 29 0a 09 09 op (car tala)...
5db0: 09 20 20 28 63 64 72 20 74 61 6c 61 29 0a 09 09 . (cdr tala)...
5dc0: 09 20 20 28 63 61 72 20 74 61 6c 62 29 0a 09 09 . (car talb)...
5dd0: 09 20 20 28 63 64 72 20 74 61 6c 62 29 29 29 0a . (cdr talb))).
5de0: 09 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 4e 65 ..#f)))))..;; Ne
5df0: 65 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 6c 69 eded for long li
5e00: 73 74 73 20 74 6f 20 62 65 20 73 6f 72 74 65 64 sts to be sorted
5e10: 20 77 68 65 72 65 20 28 61 70 70 6c 79 20 6d 61 where (apply ma
5e20: 78 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b 3b 0a x ... ) dies.;;.
5e30: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
5e40: 6d 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 6c 65 max inlst). (le
5e50: 74 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 61 6c t loop ((max-val
5e60: 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 (car inlst))..
5e70: 20 20 20 20 28 68 65 64 20 20 20 20 20 28 63 61 (hed (ca
5e80: 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 20 20 r inlst))..
5e90: 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 69 6e (tal (cdr in
5ea0: 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 lst))). (if (
5eb0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
5ec0: 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 65 64 ..(loop (max hed
5ed0: 20 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 20 20 max-val)..
5ee0: 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 20 20 (car tal)..
5ef0: 20 20 28 63 64 72 20 74 61 6c 29 29 0a 09 28 6d (cdr tal))..(m
5f00: 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 29 ax hed max-val))
5f10: 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e 20 6f ))..;; get min o
5f20: 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 6f 72 r max, use > for
5f30: 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 20 6d max and < for m
5f40: 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 20 61 in, this works a
5f50: 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 74 73 round the limits
5f60: 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 64 65 on apply.;;.(de
5f70: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d 69 6e fine (common:min
5f80: 2d 6d 61 78 20 63 6f 6d 70 20 6c 73 74 29 0a 20 -max comp lst).
5f90: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 29 (if (null? lst)
5fa0: 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 62 65 74 . #f ;; bet
5fb0: 74 65 72 20 74 68 61 6e 20 61 6e 20 65 78 63 65 ter than an exce
5fc0: 70 74 69 6f 6e 20 66 6f 72 20 6d 79 20 6e 65 65 ption for my nee
5fd0: 64 73 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 28 ds. (fold (
5fe0: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 20 lambda (a b)..
5ff0: 20 20 20 20 28 69 66 20 28 63 6f 6d 70 20 61 20 (if (comp a
6000: 62 29 20 61 20 62 29 29 0a 09 20 20 20 20 28 63 b) a b)).. (c
6010: 61 72 20 6c 73 74 29 0a 09 20 20 20 20 6c 73 74 ar lst).. lst
6020: 29 29 29 0a 0a 3b 3b 20 70 61 74 68 20 6c 69 73 )))..;; path lis
6030: 74 20 74 6f 20 68 61 73 68 2d 74 61 62 6c 65 20 t to hash-table
6040: 74 72 65 65 0a 3b 3b 20 20 20 28 28 61 20 62 20 tree.;; ((a b
6050: 63 29 28 61 20 62 20 64 29 28 65 20 62 20 63 29 c)(a b d)(e b c)
6060: 29 20 3d 3e 20 28 28 61 20 28 62 20 28 64 29 20 ) => ((a (b (d)
6070: 28 63 29 29 29 20 28 65 20 28 62 20 28 63 29 29 (c))) (e (b (c))
6080: 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 )).;;.(define (c
6090: 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 ommon:list->htre
60a0: 65 20 6c 73 74 29 0a 20 20 28 6c 65 74 20 28 28 e lst). (let ((
60b0: 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d resh (make-hash-
60c0: 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 66 6f table))). (fo
60d0: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
60e0: 62 64 61 20 28 69 6e 6c 73 74 29 0a 20 20 20 20 bda (inlst).
60f0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
6100: 74 20 20 72 65 73 68 29 0a 09 09 20 20 28 68 65 t resh)... (he
6110: 64 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 d (car inlst))..
6120: 09 20 20 28 74 61 6c 20 28 63 64 72 20 69 6e 6c . (tal (cdr inl
6130: 73 74 29 29 29 0a 09 20 28 69 66 20 28 68 61 73 st))).. (if (has
6140: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
6150: 75 6c 74 20 68 74 20 68 65 64 20 23 66 29 0a 09 ult ht hed #f)..
6160: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e (if (not (n
6170: 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 28 6c ull? tal))... (l
6180: 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 6c 65 2d oop (hash-table-
6190: 72 65 66 20 68 74 20 68 65 64 29 0a 09 09 20 20 ref ht hed)...
61a0: 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 0a 09 (car tal)..
61b0: 09 20 20 20 20 20 20 20 28 63 64 72 20 74 61 6c . (cdr tal
61c0: 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e ))).. (begin
61d0: 0a 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 .. (hash-t
61e0: 61 62 6c 65 2d 73 65 74 21 20 68 74 20 68 65 64 able-set! ht hed
61f0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
6200: 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c 6f 6f e)).. (loo
6210: 70 20 68 74 20 68 65 64 20 74 61 6c 29 29 29 29 p ht hed tal))))
6220: 29 0a 20 20 20 20 20 6c 73 74 29 0a 20 20 20 20 ). lst).
6230: 72 65 73 68 29 29 0a 0a 3b 3b 20 68 61 73 68 2d resh))..;; hash-
6240: 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 68 74 table tree to ht
6250: 6d 6c 20 6c 69 73 74 20 74 72 65 65 0a 3b 3b 0a ml list tree.;;.
6260: 3b 3b 20 20 20 74 69 70 66 75 6e 63 20 74 61 6b ;; tipfunc tak
6270: 65 73 20 74 77 6f 20 70 61 72 61 6d 65 74 65 72 es two parameter
6280: 73 3a 20 79 20 74 68 65 20 74 69 70 20 76 61 6c s: y the tip val
6290: 75 65 20 61 6e 64 20 70 61 74 68 20 74 68 65 20 ue and path the
62a0: 70 61 74 68 20 74 6f 20 74 68 61 74 20 70 6f 69 path to that poi
62b0: 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 nt.;;.(define (c
62c0: 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d ommon:htree->htm
62d0: 6c 20 68 74 20 70 61 74 68 20 74 69 70 66 75 6e l ht path tipfun
62e0: 63 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 6c c). (let ((datl
62f0: 69 73 74 20 09 28 73 6f 72 74 20 28 68 61 73 68 ist .(sort (hash
6300: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 74 -table->alist ht
6310: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6330: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 20 (lambda (a b).
6340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
6360: 74 72 69 6e 67 3c 20 28 63 61 72 20 61 29 28 63 tring< (car a)(c
6370: 61 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 28 ar b)))))). (
6380: 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 6c 69 73 if (null? datlis
6390: 74 29 0a 20 20 20 20 09 28 74 69 70 66 75 6e 63 t). .(tipfunc
63a0: 20 23 66 20 70 61 74 68 29 20 3b 3b 20 72 65 61 #f path) ;; rea
63b0: 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 lly shouldn't ge
63c0: 74 20 68 65 72 65 0a 09 28 73 3a 75 6c 0a 09 20 t here..(s:ul..
63d0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
63e0: 0a 09 09 28 6c 65 74 2a 20 28 28 6c 65 76 65 6c ...(let* ((level
63f0: 6e 61 6d 65 20 28 63 61 72 20 78 29 29 0a 09 09 name (car x))...
6400: 20 20 20 20 20 20 20 28 79 20 20 20 20 20 20 20 (y
6410: 20 20 28 63 64 72 20 78 29 29 0a 09 09 20 20 20 (cdr x))...
6420: 20 20 20 20 28 6e 65 77 70 61 74 68 20 20 20 28 (newpath (
6430: 61 70 70 65 6e 64 20 70 61 74 68 20 28 6c 69 73 append path (lis
6440: 74 20 6c 65 76 65 6c 6e 61 6d 65 29 29 29 0a 09 t levelname)))..
6450: 09 20 20 20 20 20 20 20 28 6c 65 61 66 20 20 20 . (leaf
6460: 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 68 61 73 (or (not (has
6470: 68 2d 74 61 62 6c 65 3f 20 79 29 29 0a 09 09 09 h-table? y))....
6480: 09 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 28 68 . (null? (h
6490: 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 79 ash-table-keys y
64a0: 29 29 29 29 29 0a 09 09 20 20 28 69 66 20 6c 65 )))))... (if le
64b0: 61 66 0a 09 09 20 20 20 20 20 20 28 73 3a 6c 69 af... (s:li
64c0: 20 28 74 69 70 66 75 6e 63 20 79 20 6e 65 77 70 (tipfunc y newp
64d0: 61 74 68 29 29 0a 09 09 20 20 20 20 20 20 28 73 ath))... (s
64e0: 3a 6c 69 0a 09 09 20 20 20 20 20 20 20 28 6c 69 :li... (li
64f0: 73 74 20 0a 09 09 09 6c 65 76 65 6c 6e 61 6d 65 st ....levelname
6500: 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 ....(common:htre
6510: 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 77 70 61 74 e->html y newpat
6520: 68 20 74 69 70 66 75 6e 63 29 29 29 29 29 29 0a h tipfunc)))))).
6530: 09 20 20 20 20 20 20 64 61 74 6c 69 73 74 29 29 . datlist))
6540: 29 29 29 0a 0a 3b 3b 20 68 61 73 68 2d 74 61 62 )))..;; hash-tab
6550: 6c 65 20 74 72 65 65 20 74 6f 20 61 6c 69 73 74 le tree to alist
6560: 20 74 72 65 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 tree.;;.(define
6570: 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e (common:htree->
6580: 61 74 72 65 65 20 68 74 29 0a 20 20 28 6d 61 70 atree ht). (map
6590: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 20 28 (lambda (x).. (
65a0: 63 6f 6e 73 20 28 63 61 72 20 78 29 0a 09 20 20 cons (car x)..
65b0: 20 20 20 20 20 28 6c 65 74 20 28 28 79 20 28 63 (let ((y (c
65c0: 64 72 20 78 29 29 29 0a 09 09 20 28 69 66 20 28 dr x)))... (if (
65d0: 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 0a 09 hash-table? y)..
65e0: 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 74 . (common:ht
65f0: 72 65 65 2d 3e 61 74 72 65 65 20 79 29 0a 09 09 ree->atree y)...
6600: 20 20 20 20 20 79 29 29 29 29 0a 20 20 20 20 20 y)))).
6610: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 (hash-table->a
6620: 6c 69 73 74 20 68 74 29 29 29 0a 0a 3b 3b 3d 3d list ht)))..;;==
6630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6670: 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4e 20 47 20 ====.;; M U N G
6680: 45 20 20 20 44 20 41 20 54 20 41 20 20 20 49 20 E D A T A I
6690: 4e 20 54 20 4f 20 20 20 4e 20 49 20 43 20 45 20 N T O N I C E
66a0: 20 20 46 20 4f 20 52 20 4d 20 53 0a 3b 3b 3d 3d F O R M S.;;==
66b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66f0: 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 72 61 74 ====..;; Generat
6700: 65 20 61 6e 20 69 6e 64 65 78 20 66 6f 72 20 61 e an index for a
6710: 20 73 70 61 72 73 65 20 6c 69 73 74 20 6f 66 20 sparse list of
6720: 6b 65 79 20 76 61 6c 75 65 73 0a 3b 3b 20 20 20 key values.;;
6730: 28 20 28 72 6f 77 6e 61 6d 65 31 20 63 6f 6c 6e ( (rowname1 coln
6740: 61 6d 65 31 20 76 61 6c 31 29 28 72 6f 77 6e 61 ame1 val1)(rowna
6750: 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 20 76 61 6c me2 colname2 val
6760: 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e 20 0a 3b 2) ).;;.;; => .;
6770: 3b 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e 61 6d ;.;; ( (rownam
6780: 65 31 20 30 29 28 72 6f 77 6e 61 6d 65 32 20 31 e1 0)(rowname2 1
6790: 29 29 20 20 20 20 3b 3b 20 72 6f 77 6e 61 6d 65 )) ;; rowname
67a0: 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 20 20 20 s -> num.;;
67b0: 28 63 6f 6c 6e 61 6d 65 31 20 30 29 28 63 6f 6c (colname1 0)(col
67c0: 6e 61 6d 65 32 20 31 29 29 20 29 20 20 3b 3b 20 name2 1)) ) ;;
67d0: 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a colnames -> num.
67e0: 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e 61 6c 20 ;; .;; optional
67f0: 61 70 70 6c 79 20 70 72 6f 63 20 74 6f 20 72 6f apply proc to ro
6800: 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 61 6c 75 wnum colnum valu
6810: 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f e.(define (commo
6820: 6e 3a 73 70 61 72 73 65 2d 6c 69 73 74 2d 67 65 n:sparse-list-ge
6830: 6e 65 72 61 74 65 2d 69 6e 64 65 78 20 64 61 74 nerate-index dat
6840: 61 20 23 21 6b 65 79 20 28 70 72 6f 63 20 23 66 a #!key (proc #f
6850: 29 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 )). (if (null?
6860: 64 61 74 61 29 0a 20 20 20 20 20 20 28 6c 69 73 data). (lis
6870: 74 20 27 28 29 20 27 28 29 29 0a 20 20 20 20 20 t '() '()).
6880: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
6890: 20 28 63 61 72 20 64 61 74 61 29 29 0a 09 09 20 (car data))...
68a0: 28 74 61 6c 20 28 63 64 72 20 64 61 74 61 29 29 (tal (cdr data))
68b0: 0a 09 09 20 28 72 6f 77 6e 61 6d 65 73 20 27 28 ... (rownames '(
68c0: 29 29 0a 09 09 20 28 63 6f 6c 6e 61 6d 65 73 20 ))... (colnames
68d0: 27 28 29 29 0a 09 09 20 28 72 6f 77 6e 75 6d 20 '())... (rownum
68e0: 20 20 30 29 0a 09 09 20 28 63 6f 6c 6e 75 6d 20 0)... (colnum
68f0: 20 20 30 29 29 0a 09 28 6c 65 74 2a 20 28 28 72 0))..(let* ((r
6900: 6f 77 6b 65 79 20 20 20 20 20 20 20 20 20 20 28 owkey (
6910: 63 61 72 20 20 20 68 65 64 29 29 0a 09 20 20 20 car hed))..
6920: 20 20 20 20 28 63 6f 6c 6b 65 79 20 20 20 20 20 (colkey
6930: 20 20 20 20 20 28 63 61 64 72 20 20 68 65 64 29 (cadr hed)
6940: 29 0a 09 20 20 20 20 20 20 20 28 76 61 6c 75 65 ).. (value
6950: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 64 64 (cadd
6960: 72 20 68 65 64 29 29 0a 09 20 20 20 20 20 20 20 r hed))..
6970: 28 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 (existing-rowdat
6980: 20 28 61 73 73 6f 63 20 72 6f 77 6b 65 79 20 72 (assoc rowkey r
6990: 6f 77 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 20 ownames))..
69a0: 20 20 28 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 (existing-cold
69b0: 61 74 20 28 61 73 73 6f 63 20 63 6f 6c 6b 65 79 at (assoc colkey
69c0: 20 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 20 20 20 colnames))..
69d0: 20 20 20 20 28 63 75 72 72 2d 72 6f 77 6e 75 6d (curr-rownum
69e0: 20 20 20 20 20 28 69 66 20 65 78 69 73 74 69 6e (if existin
69f0: 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e 75 6d 20 g-rowdat rownum
6a00: 28 2b 20 72 6f 77 6e 75 6d 20 31 29 29 29 0a 09 (+ rownum 1)))..
6a10: 20 20 20 20 20 20 20 28 63 75 72 72 2d 63 6f 6c (curr-col
6a20: 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 num (if exis
6a30: 74 69 6e 67 2d 63 6f 6c 64 61 74 20 63 6f 6c 6e ting-coldat coln
6a40: 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 31 29 29 um (+ colnum 1))
6a50: 29 0a 09 20 20 20 20 20 20 20 28 6e 65 77 2d 72 ).. (new-r
6a60: 6f 77 6e 61 6d 65 73 20 20 20 20 28 69 66 20 65 ownames (if e
6a70: 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 20 72 xisting-rowdat r
6a80: 6f 77 6e 61 6d 65 73 20 28 63 6f 6e 73 20 28 6c ownames (cons (l
6a90: 69 73 74 20 72 6f 77 6b 65 79 20 63 75 72 72 2d ist rowkey curr-
6aa0: 72 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 6d 65 73 rownum) rownames
6ab0: 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 77 ))).. (new
6ac0: 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 20 28 69 66 -colnames (if
6ad0: 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 existing-coldat
6ae0: 20 63 6f 6c 6e 61 6d 65 73 20 28 63 6f 6e 73 20 colnames (cons
6af0: 28 6c 69 73 74 20 63 6f 6c 6b 65 79 20 63 75 72 (list colkey cur
6b00: 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c 6e 61 6d r-colnum) colnam
6b10: 65 73 29 29 29 29 0a 09 20 20 3b 3b 20 28 64 65 es)))).. ;; (de
6b20: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
6b30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6b40: 72 74 2a 20 22 50 72 6f 63 65 73 73 69 6e 67 20 rt* "Processing
6b50: 72 65 63 6f 72 64 3a 20 22 20 68 65 64 20 29 0a record: " hed ).
6b60: 09 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 6f . (if proc (pro
6b70: 63 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 63 75 c curr-rownum cu
6b80: 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 6b 65 79 rr-colnum rowkey
6b90: 20 63 6f 6c 6b 65 79 20 76 61 6c 75 65 29 29 0a colkey value)).
6ba0: 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 . (if (null? ta
6bb0: 6c 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 l).. (list
6bc0: 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 6e 65 77 new-rownames new
6bd0: 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 20 20 20 -colnames)..
6be0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
6bf0: 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 6c )... (cdr tal
6c00: 29 0a 09 09 20 20 20 20 6e 65 77 2d 72 6f 77 6e )... new-rown
6c10: 61 6d 65 73 0a 09 09 20 20 20 20 6e 65 77 2d 63 ames... new-c
6c20: 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 20 20 28 69 olnames... (i
6c30: 66 20 28 3e 20 63 75 72 72 2d 72 6f 77 6e 75 6d f (> curr-rownum
6c40: 20 72 6f 77 6e 75 6d 29 20 63 75 72 72 2d 72 6f rownum) curr-ro
6c50: 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a 09 09 20 wnum rownum)...
6c60: 20 20 20 28 69 66 20 28 3e 20 63 75 72 72 2d 63 (if (> curr-c
6c70: 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 20 63 75 olnum colnum) cu
6c80: 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d rr-colnum colnum
6c90: 29 0a 09 09 20 20 20 20 29 29 29 29 29 29 0a 0a )... ))))))..
6ca0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ce0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 59 20 ========.;; S Y
6cf0: 53 20 54 20 45 20 4d 20 20 20 53 20 54 20 55 20 S T E M S T U
6d00: 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F F.;;==========
6d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
6d50: 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 74 20 66 lazy-safe get f
6d60: 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e 20 6f 6e ile mod time. on
6d70: 20 61 6e 79 20 65 72 72 6f 72 20 28 66 69 6c 65 any error (file
6d80: 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 20 65 74 not existing et
6d90: 63 2e 29 20 72 65 74 75 72 6e 20 30 0a 3b 3b 0a c.) return 0.;;.
6da0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
6db0: 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f lazy-modificatio
6dc0: 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a 20 20 n-time fpath).
6dd0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
6de0: 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 30 0a 20 ns. exn. 0.
6df0: 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 (file-modifica
6e00: 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 tion-time fpath)
6e10: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 61 20 ))..;; return a
6e20: 6e 69 63 65 20 63 6c 65 61 6e 20 70 61 74 68 6e nice clean pathn
6e30: 61 6d 65 20 6d 61 64 65 20 61 62 73 6f 6c 75 74 ame made absolut
6e40: 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f e.(define (commo
6e50: 6e 3a 6e 69 63 65 2d 70 61 74 68 20 64 69 72 29 n:nice-path dir)
6e60: 0a 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 . (let ((match
6e70: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e (string-match "^
6e80: 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 2e 2a (~[^\\/]*)(\\/.*
6e90: 7c 29 24 22 20 64 69 72 29 29 29 0a 20 20 20 20 |)$" dir))).
6ea0: 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 75 73 69 (if match ;; usi
6eb0: 6e 67 20 7e 20 66 6f 72 20 68 6f 6d 65 3f 0a 09 ng ~ for home?..
6ec0: 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 (common:nice-pat
6ed0: 68 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a h (conc (common:
6ee0: 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 28 63 61 64 read-link-f (cad
6ef0: 72 20 6d 61 74 63 68 29 29 20 22 2f 22 20 28 63 r match)) "/" (c
6f00: 61 64 64 72 20 6d 61 74 63 68 29 29 29 0a 09 28 addr match)))..(
6f10: 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 68 6e 61 normalize-pathna
6f20: 6d 65 20 28 69 66 20 28 61 62 73 6f 6c 75 74 65 me (if (absolute
6f30: 2d 70 61 74 68 6e 61 6d 65 3f 20 64 69 72 29 0a -pathname? dir).
6f40: 09 09 09 09 64 69 72 0a 09 09 09 09 28 63 6f 6e ....dir.....(con
6f50: 63 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 c (current-direc
6f60: 74 6f 72 79 29 20 22 2f 22 20 64 69 72 29 29 29 tory) "/" dir)))
6f70: 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 22 6e 69 )))..;; make "ni
6f80: 63 65 2d 70 61 74 68 22 20 61 76 61 69 6c 61 62 ce-path" availab
6f90: 6c 65 20 69 6e 20 63 6f 6e 66 69 67 20 66 69 6c le in config fil
6fa0: 65 73 20 61 6e 64 20 74 68 65 20 72 65 70 6c 0a es and the repl.
6fb0: 28 64 65 66 69 6e 65 20 6e 69 63 65 2d 70 61 74 (define nice-pat
6fc0: 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 h common:nice-pa
6fd0: 74 68 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f th)..(define (co
6fe0: 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 mmon:read-link-f
6ff0: 20 70 61 74 68 29 0a 20 20 28 68 61 6e 64 6c 65 path). (handle
7000: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
7010: 20 20 65 78 6e 0a 20 20 20 20 20 20 28 62 65 67 exn. (beg
7020: 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 in..(debug:print
7030: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
7040: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d t-log-port* "com
7050: 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f 72 65 61 64 mand \"/bin/read
7060: 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 20 22 link -f " path "
7070: 5c 22 20 66 61 69 6c 65 64 2e 22 29 0a 09 70 61 \" failed.")..pa
7080: 74 68 29 20 3b 3b 20 6a 75 73 74 20 67 69 76 65 th) ;; just give
7090: 20 75 70 0a 20 20 20 20 28 77 69 74 68 2d 69 6e up. (with-in
70a0: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 28 put-from-pipe..(
70b0: 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 65 61 64 6c conc "/bin/readl
70c0: 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 29 0a 20 ink -f " path).
70d0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
70e0: 09 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 .(read-line)))))
70f0: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 63 ..(define (get-c
7100: 70 75 2d 6c 6f 61 64 20 23 21 6b 65 79 20 28 72 pu-load #!key (r
7110: 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a emote-host #f)).
7120: 20 20 28 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 67 (car (common:g
7130: 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f et-cpu-load remo
7140: 74 65 2d 68 6f 73 74 29 29 29 0a 3b 3b 20 20 20 te-host))).;;
7150: 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d 72 65 73 (let* ((load-res
7160: 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 (process:cmd-ru
7170: 6e 2d 3e 6c 69 73 74 20 22 75 70 74 69 6d 65 22 n->list "uptime"
7180: 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 2d 72 78 )).;; . (load-rx
7190: 20 20 28 72 65 67 65 78 70 20 22 6c 6f 61 64 20 (regexp "load
71a0: 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 5c 5c 64 average:\\s+(\\d
71b0: 2b 29 22 29 29 0a 3b 3b 20 09 20 28 63 70 75 2d +)")).;; . (cpu-
71c0: 6c 6f 61 64 20 23 66 29 29 0a 3b 3b 20 20 20 20 load #f)).;;
71d0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
71e0: 64 61 20 28 6c 29 0a 3b 3b 20 09 09 28 6c 65 74 da (l).;; ..(let
71f0: 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 ((match (string
7200: 2d 73 65 61 72 63 68 20 6c 6f 61 64 2d 72 78 20 -search load-rx
7210: 6c 29 29 29 0a 3b 3b 20 09 09 20 20 28 69 66 20 l))).;; .. (if
7220: 6d 61 74 63 68 0a 3b 3b 20 09 09 20 20 20 20 20 match.;; ..
7230: 20 28 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 (let ((newval (
7240: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
7250: 63 61 64 72 20 6d 61 74 63 68 29 29 29 29 0a 3b cadr match)))).;
7260: 3b 20 09 09 09 28 69 66 20 28 6e 75 6d 62 65 72 ; ...(if (number
7270: 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 09 09 09 ? newval).;; ...
7280: 20 20 20 20 28 73 65 74 21 20 63 70 75 2d 6c 6f (set! cpu-lo
7290: 61 64 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a ad newval)))))).
72a0: 3b 3b 20 09 20 20 20 20 20 20 28 63 61 72 20 6c ;; . (car l
72b0: 6f 61 64 2d 72 65 73 29 29 0a 3b 3b 20 20 20 20 oad-res)).;;
72c0: 20 63 70 75 2d 6c 6f 61 64 29 29 0a 0a 3b 3b 20 cpu-load))..;;
72d0: 67 65 74 20 63 70 75 20 6c 6f 61 64 20 62 79 20 get cpu load by
72e0: 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 2f 70 72 reading from /pr
72f0: 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 72 65 74 75 oc/loadavg, retu
7300: 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 61 6c rn all three val
7310: 75 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ues.;;.(define (
7320: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c common:get-cpu-l
7330: 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 oad remote-host)
7340: 0a 20 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f . (if remote-ho
7350: 73 74 0a 20 20 20 20 20 20 28 6d 61 70 20 28 6c st. (map (l
7360: 61 6d 62 64 61 20 28 72 65 73 29 0a 09 20 20 20 ambda (res)..
7370: 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 (if (eof-objec
7380: 74 3f 20 72 65 73 29 20 39 65 39 39 20 72 65 73 t? res) 9e99 res
7390: 29 29 0a 09 20 20 20 28 77 69 74 68 2d 69 6e 70 )).. (with-inp
73a0: 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 20 ut-from-pipe ..
73b0: 20 20 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 (conc "ssh "
73c0: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 remote-host " ca
73d0: 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 t /proc/loadavg"
73e0: 29 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 ).. (lambda (
73f0: 29 28 6c 69 73 74 20 28 72 65 61 64 29 28 72 65 )(list (read)(re
7400: 61 64 29 28 72 65 61 64 29 29 29 29 29 0a 20 20 ad)(read))))).
7410: 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
7420: 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 from-file "/proc
7430: 2f 6c 6f 61 64 61 76 67 22 20 0a 09 28 6c 61 6d /loadavg" ..(lam
7440: 62 64 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 bda ()(list (rea
7450: 64 29 28 72 65 61 64 29 28 72 65 61 64 29 29 29 d)(read)(read)))
7460: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
7470: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 mmon:wait-for-cp
7480: 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 uload maxload nu
7490: 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 20 mcpus waitdelay
74a0: 23 21 6b 65 79 20 28 63 6f 75 6e 74 20 31 30 30 #!key (count 100
74b0: 30 29 20 28 6d 73 67 20 23 66 29 28 72 65 6d 6f 0) (msg #f)(remo
74c0: 74 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 20 28 te-host #f)). (
74d0: 6c 65 74 2a 20 28 28 6c 6f 61 64 61 76 67 20 28 let* ((loadavg (
74e0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c common:get-cpu-l
74f0: 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 oad remote-host)
7500: 29 0a 09 20 28 66 69 72 73 74 20 20 20 28 63 61 ).. (first (ca
7510: 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 6e r loadavg)).. (n
7520: 65 78 74 20 20 20 20 28 63 61 64 72 20 6c 6f 61 ext (cadr loa
7530: 64 61 76 67 29 29 0a 09 20 28 61 64 6a 6c 6f 61 davg)).. (adjloa
7540: 64 20 28 2a 20 6d 61 78 6c 6f 61 64 20 6e 75 6d d (* maxload num
7550: 63 70 75 73 29 29 0a 09 20 28 6c 6f 61 64 6a 6d cpus)).. (loadjm
7560: 70 20 28 2d 20 66 69 72 73 74 20 6e 65 78 74 29 p (- first next)
7570: 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 )). (cond.
7580: 20 20 28 28 61 6e 64 20 28 3e 20 66 69 72 73 74 ((and (> first
7590: 20 61 64 6a 6c 6f 61 64 29 0a 09 20 20 20 28 3e adjload).. (>
75a0: 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 count 0)).
75b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
75c0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
75d0: 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 6e 67 g-port* "waiting
75e0: 20 22 20 77 61 69 74 64 65 6c 61 79 20 22 20 73 " waitdelay " s
75f0: 65 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f econds due to lo
7600: 61 64 20 22 20 66 69 72 73 74 20 22 20 65 78 63 ad " first " exc
7610: 65 65 64 69 6e 67 20 6d 61 78 20 6f 66 20 22 20 eeding max of "
7620: 61 64 6a 6c 6f 61 64 20 28 69 66 20 6d 73 67 20 adjload (if msg
7630: 6d 73 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 msg "")). (
7640: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 77 61 thread-sleep! wa
7650: 69 74 64 65 6c 61 79 29 0a 20 20 20 20 20 20 28 itdelay). (
7660: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
7670: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
7680: 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 numcpus waitdela
7690: 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e y count: (- coun
76a0: 74 20 31 29 29 29 0a 20 20 20 20 20 28 28 61 6e t 1))). ((an
76b0: 64 20 28 3e 20 6c 6f 61 64 6a 6d 70 20 6e 75 6d d (> loadjmp num
76c0: 63 70 75 73 29 0a 09 20 20 20 28 3e 20 63 6f 75 cpus).. (> cou
76d0: 6e 74 20 30 29 29 0a 20 20 20 20 20 20 28 64 65 nt 0)). (de
76e0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
76f0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
7700: 72 74 2a 20 22 77 61 69 74 69 6e 67 20 22 20 77 rt* "waiting " w
7710: 61 69 74 64 65 6c 61 79 20 22 20 73 65 63 6f 6e aitdelay " secon
7720: 64 73 20 64 75 65 20 74 6f 20 6c 6f 61 64 20 6a ds due to load j
7730: 75 6d 70 20 22 20 6c 6f 61 64 6a 6d 70 20 22 20 ump " loadjmp "
7740: 3e 20 6e 75 6d 63 70 75 73 20 22 20 6e 75 6d 63 > numcpus " numc
7750: 70 75 73 20 28 69 66 20 6d 73 67 20 6d 73 67 20 pus (if msg msg
7760: 22 22 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 "")). (thre
7770: 61 64 2d 73 6c 65 65 70 21 20 77 61 69 74 64 65 ad-sleep! waitde
7780: 6c 61 79 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d lay). (comm
7790: 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c on:wait-for-cpul
77a0: 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 oad maxload numc
77b0: 70 75 73 20 77 61 69 74 64 65 6c 61 79 20 63 6f pus waitdelay co
77c0: 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 20 31 29 unt: (- count 1)
77d0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
77e0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 common:get-num-c
77f0: 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 pus remote-host)
7800: 0a 20 20 28 6c 65 74 20 28 28 70 72 6f 63 20 28 . (let ((proc (
7810: 6c 61 6d 62 64 61 20 28 29 0a 09 09 28 6c 65 74 lambda ()...(let
7820: 20 6c 6f 6f 70 20 28 28 6e 75 6d 63 70 75 20 30 loop ((numcpu 0
7830: 29 0a 09 09 09 20 20 20 28 69 6e 6c 20 20 20 20 ).... (inl
7840: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 09 (read-line)))...
7850: 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 (if (eof-objec
7860: 74 3f 20 69 6e 6c 29 0a 09 09 20 20 20 20 20 20 t? inl)...
7870: 6e 75 6d 63 70 75 0a 09 09 20 20 20 20 20 20 28 numcpu... (
7880: 6c 6f 6f 70 20 28 69 66 20 28 73 74 72 69 6e 67 loop (if (string
7890: 2d 6d 61 74 63 68 20 22 5e 70 72 6f 63 65 73 73 -match "^process
78a0: 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b 5c 5c 64 2b 24 or\\s+:\\s+\\d+$
78b0: 22 20 69 6e 6c 29 0a 09 09 09 09 28 2b 20 6e 75 " inl).....(+ nu
78c0: 6d 63 70 75 20 31 29 0a 09 09 09 09 6e 75 6d 63 mcpu 1).....numc
78d0: 70 75 29 0a 09 09 09 20 20 20 20 28 72 65 61 64 pu).... (read
78e0: 2d 6c 69 6e 65 29 29 29 29 29 29 29 0a 20 20 20 -line))))))).
78f0: 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f 73 74 (if remote-host
7900: 0a 09 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 ..(with-input-fr
7910: 6f 6d 2d 70 69 70 65 20 0a 09 20 28 63 6f 6e 63 om-pipe .. (conc
7920: 20 22 73 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 "ssh " remote-h
7930: 6f 73 74 20 22 20 63 61 74 20 2f 70 72 6f 63 2f ost " cat /proc/
7940: 63 70 75 69 6e 66 6f 22 29 0a 09 20 70 72 6f 63 cpuinfo").. proc
7950: 29 0a 09 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 )..(with-input-f
7960: 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f rom-file "/proc/
7970: 63 70 75 69 6e 66 6f 22 20 70 72 6f 63 29 29 29 cpuinfo" proc)))
7980: 29 0a 0a 3b 3b 20 77 61 69 74 20 66 6f 72 20 6e )..;; wait for n
7990: 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f ormalized cpu lo
79a0: 61 64 20 74 6f 20 64 72 6f 70 20 62 65 6c 6f 77 ad to drop below
79b0: 20 6d 61 78 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 maxload.;;.(def
79c0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 ine (common:wait
79d0: 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d -for-normalized-
79e0: 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 23 21 6b load maxload #!k
79f0: 65 79 20 28 6d 73 67 20 23 66 29 28 72 65 6d 6f ey (msg #f)(remo
7a00: 74 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 20 28 te-host #f)). (
7a10: 6c 65 74 20 28 28 6e 75 6d 2d 63 70 75 73 20 28 let ((num-cpus (
7a20: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 common:get-num-c
7a30: 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 pus remote-host)
7a40: 29 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 )). (common:w
7a50: 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 ait-for-cpuload
7a60: 6d 61 78 6c 6f 61 64 20 6e 75 6d 2d 63 70 75 73 maxload num-cpus
7a70: 20 31 35 20 6d 73 67 3a 20 6d 73 67 29 29 29 0a 15 msg: msg))).
7a80: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 75 6e .(define (get-un
7a90: 61 6d 65 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 ame . params).
7aa0: 28 6c 65 74 2a 20 28 28 75 6e 61 6d 65 2d 72 65 (let* ((uname-re
7ab0: 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 s (process:cmd-r
7ac0: 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 un->list (conc "
7ad0: 75 6e 61 6d 65 20 22 20 28 69 66 20 28 6e 75 6c uname " (if (nul
7ae0: 6c 3f 20 70 61 72 61 6d 73 29 20 22 2d 61 22 20 l? params) "-a"
7af0: 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 29 29 (car params)))))
7b00: 0a 09 20 28 75 6e 61 6d 65 20 23 66 29 29 0a 20 .. (uname #f)).
7b10: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 (if (null? (c
7b20: 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 0a 09 ar uname-res))..
7b30: 22 75 6e 6b 6e 6f 77 6e 22 0a 09 28 63 61 61 72 "unknown"..(caar
7b40: 20 75 6e 61 6d 65 2d 72 65 73 29 29 29 29 0a 0a uname-res))))..
7b50: 3b 3b 20 66 6f 72 20 72 65 61 73 6f 6e 73 20 49 ;; for reasons I
7b60: 20 64 6f 6e 27 74 20 75 6e 64 65 72 73 74 61 6e don't understan
7b70: 64 20 6d 75 6c 74 69 70 6c 65 20 63 61 6c 6c 73 d multiple calls
7b80: 20 74 6f 20 72 65 61 6c 2d 70 61 74 68 20 69 6e to real-path in
7b90: 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 parallel thread
7ba0: 73 0a 3b 3b 20 6d 75 73 74 20 62 65 20 70 72 6f s.;; must be pro
7bb0: 74 65 63 74 65 64 20 62 79 20 6d 75 74 65 78 65 tected by mutexe
7bc0: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f s.;;.(define (co
7bd0: 6d 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 68 20 69 mmon:real-path i
7be0: 6e 70 61 74 68 29 0a 20 20 3b 3b 20 28 70 72 6f npath). ;; (pro
7bf0: 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 cess:cmd-run-wit
7c00: 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 74 20 22 h-stderr->list "
7c10: 72 65 61 64 6c 69 6e 6b 22 20 22 2d 66 22 20 69 readlink" "-f" i
7c20: 6e 70 61 74 68 29 29 20 3b 3b 20 63 6d 64 20 2e npath)) ;; cmd .
7c30: 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 6c params). ;; (l
7c40: 65 74 2d 76 61 6c 75 65 73 20 0a 20 20 3b 3b 20 et-values . ;;
7c50: 20 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 (((inp oup pid)
7c60: 20 28 70 72 6f 63 65 73 73 20 22 72 65 61 64 6c (process "readl
7c70: 69 6e 6b 22 20 28 6c 69 73 74 20 22 2d 66 22 20 ink" (list "-f"
7c80: 69 6e 70 61 74 68 29 29 29 29 0a 20 20 3b 3b 20 inpath)))). ;;
7c90: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
7ca0: 6d 2d 70 6f 72 74 20 69 6e 70 0a 20 20 3b 3b 20 m-port inp. ;;
7cb0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 (let loop ((i
7cc0: 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a nl (read-line)).
7cd0: 20 20 3b 3b 20 20 20 20 20 20 20 09 28 72 65 73 ;; .(res
7ce0: 20 23 66 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 #f)). ;;
7cf0: 28 70 72 69 6e 74 20 22 69 6e 6c 3d 22 20 69 6e (print "inl=" in
7d00: 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 28 69 66 l). ;; (if
7d10: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e (eof-object? in
7d20: 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 l). ;;
7d30: 20 28 62 65 67 69 6e 0a 20 20 3b 3b 20 20 20 20 (begin. ;;
7d40: 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 69 (close-i
7d50: 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 20 nput-port inp).
7d60: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 ;; (
7d70: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
7d80: 74 20 6f 75 70 29 0a 20 20 3b 3b 20 20 20 20 20 t oup). ;;
7d90: 20 20 20 20 20 20 20 3b 3b 20 28 70 72 6f 63 65 ;; (proce
7da0: 73 73 2d 77 61 69 74 20 70 69 64 29 0a 20 20 3b ss-wait pid). ;
7db0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 ; res
7dc0: 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ). ;;
7dd0: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 (loop (read-line
7de0: 29 20 69 6e 6c 29 29 29 29 29 29 0a 20 20 28 77 ) inl)))))). (w
7df0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
7e00: 69 70 65 20 28 63 6f 6e 63 20 22 72 65 61 64 6c ipe (conc "readl
7e10: 69 6e 6b 20 2d 66 20 22 20 69 6e 70 61 74 68 29 ink -f " inpath)
7e20: 20 72 65 61 64 2d 6c 69 6e 65 29 29 0a 0a 3b 3b read-line))..;;
7e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e70: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 20 53 20 ======.;; D I S
7e80: 4b 20 20 20 53 20 50 20 41 20 43 20 45 20 0a 3b K S P A C E .;
7e90: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ed0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
7ee0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 (common:get-dis
7ef0: 6b 2d 73 70 61 63 65 2d 75 73 65 64 20 66 70 61 k-space-used fpa
7f00: 74 68 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 th). (with-inpu
7f10: 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e t-from-pipe (con
7f20: 63 20 22 2f 75 73 72 2f 62 69 6e 2f 64 75 20 2d c "/usr/bin/du -
7f30: 73 20 22 20 66 70 61 74 68 29 20 72 65 61 64 29 s " fpath) read)
7f40: 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 70 61 74 68 )..;; given path
7f50: 20 67 65 74 20 66 72 65 65 20 73 70 61 63 65 2c get free space,
7f60: 20 61 6c 6c 6f 77 73 20 6f 76 65 72 72 69 64 65 allows override
7f70: 20 69 6e 20 5b 73 65 74 75 70 5d 0a 3b 3b 20 77 in [setup].;; w
7f80: 69 74 68 20 66 72 65 65 2d 73 70 61 63 65 2d 73 ith free-space-s
7f90: 63 72 69 70 74 20 2f 70 61 74 68 2f 74 6f 2f 73 cript /path/to/s
7fa0: 6f 6d 65 2f 73 63 72 69 70 74 2e 73 68 0a 3b 3b ome/script.sh.;;
7fb0: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 66 .(define (get-df
7fc0: 20 70 61 74 68 29 0a 20 20 28 69 66 20 28 63 6f path). (if (co
7fd0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
7fe0: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
7ff0: 20 22 66 72 65 65 2d 73 70 61 63 65 2d 73 63 72 "free-space-scr
8000: 69 70 74 22 29 0a 20 20 20 20 20 20 28 77 69 74 ipt"). (wit
8010: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
8020: 65 20 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 e . (conc
8030: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
8040: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
8050: 75 70 22 20 22 66 72 65 65 2d 73 70 61 63 65 2d up" "free-space-
8060: 73 63 72 69 70 74 22 29 20 22 20 22 20 70 61 74 script") " " pat
8070: 68 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 h). (lambd
8080: 61 20 28 29 0a 09 20 28 6c 65 74 20 28 28 72 65 a ().. (let ((re
8090: 73 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a s (read-line))).
80a0: 09 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f . (if (string?
80b0: 20 72 65 73 29 0a 09 20 20 20 20 20 20 20 28 73 res).. (s
80c0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 tring->number re
80d0: 73 29 29 29 29 29 0a 20 20 20 20 20 20 28 67 65 s))))). (ge
80e0: 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 68 29 29 t-unix-df path))
80f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get-
8100: 75 6e 69 78 2d 64 66 20 70 61 74 68 29 0a 20 20 unix-df path).
8110: 28 6c 65 74 2a 20 28 28 64 66 2d 72 65 73 75 6c (let* ((df-resul
8120: 74 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d ts (process:cmd-
8130: 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 run->list (conc
8140: 22 64 66 20 22 20 70 61 74 68 29 29 29 0a 09 20 "df " path)))..
8150: 28 73 70 61 63 65 2d 72 78 20 20 20 28 72 65 67 (space-rx (reg
8160: 65 78 70 20 22 28 5b 30 2d 39 5d 2b 29 5c 5c 73 exp "([0-9]+)\\s
8170: 2b 28 5b 30 2d 39 5d 2b 29 25 22 29 29 0a 09 20 +([0-9]+)%"))..
8180: 28 66 72 65 65 73 70 63 20 20 20 20 23 66 29 29 (freespc #f))
8190: 0a 20 20 20 20 3b 3b 20 28 77 72 69 74 65 20 64 . ;; (write d
81a0: 66 2d 72 65 73 75 6c 74 73 29 0a 20 20 20 20 28 f-results). (
81b0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
81c0: 20 28 6c 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 (l)...(let ((ma
81d0: 74 63 68 20 28 73 74 72 69 6e 67 2d 73 65 61 72 tch (string-sear
81e0: 63 68 20 73 70 61 63 65 2d 72 78 20 6c 29 29 29 ch space-rx l)))
81f0: 0a 09 09 20 20 28 69 66 20 6d 61 74 63 68 20 0a ... (if match .
8200: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e .. (let ((n
8210: 65 77 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e ewval (string->n
8220: 75 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 umber (cadr matc
8230: 68 29 29 29 29 0a 09 09 09 28 69 66 20 28 6e 75 h))))....(if (nu
8240: 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 mber? newval)...
8250: 09 20 20 20 20 28 73 65 74 21 20 66 72 65 65 73 . (set! frees
8260: 70 63 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a pc newval)))))).
8270: 09 20 20 20 20 20 20 28 63 61 72 20 64 66 2d 72 . (car df-r
8280: 65 73 75 6c 74 73 29 29 0a 20 20 20 20 66 72 65 esults)). fre
8290: 65 73 70 63 29 29 0a 0a 3b 3b 20 63 68 65 63 6b espc))..;; check
82a0: 20 73 70 61 63 65 20 69 6e 20 64 62 64 69 72 0a space in dbdir.
82b0: 3b 3b 20 72 65 74 75 72 6e 73 3a 20 6f 6b 2f 6e ;; returns: ok/n
82c0: 6f 74 20 64 62 73 70 61 63 65 20 72 65 71 75 69 ot dbspace requi
82d0: 72 65 64 2d 73 70 61 63 65 0a 3b 3b 0a 28 64 65 red-space.;;.(de
82e0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 fine (common:che
82f0: 63 6b 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 29 ck-db-dir-space)
8300: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 64 69 72 . (let* ((dbdir
8310: 20 20 20 20 28 64 62 3a 67 65 74 2d 64 62 64 69 (db:get-dbdi
8320: 72 29 29 0a 09 20 28 64 62 73 70 61 63 65 20 20 r)).. (dbspace
8330: 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 (if (directory?
8340: 64 62 64 69 72 29 0a 09 09 20 20 20 20 20 20 20 dbdir)...
8350: 28 67 65 74 2d 64 66 20 64 62 64 69 72 29 0a 09 (get-df dbdir)..
8360: 09 20 20 20 20 20 20 20 30 29 29 0a 09 20 28 72 . 0)).. (r
8370: 65 71 75 69 72 65 64 20 28 73 74 72 69 6e 67 2d equired (string-
8380: 3e 6e 75 6d 62 65 72 20 0a 09 09 20 20 20 20 28 >number ... (
8390: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
83a0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
83b0: 73 65 74 75 70 22 20 22 64 62 64 69 72 2d 73 70 setup" "dbdir-sp
83c0: 61 63 65 2d 72 65 71 75 69 72 65 64 22 29 0a 09 ace-required")..
83d0: 09 09 22 31 30 30 30 30 30 22 29 29 29 29 0a 20 .."100000")))).
83e0: 20 20 20 28 6c 69 73 74 20 28 3e 20 64 62 73 70 (list (> dbsp
83f0: 61 63 65 20 72 65 71 75 69 72 65 64 29 0a 09 20 ace required)..
8400: 20 64 62 73 70 61 63 65 0a 09 20 20 72 65 71 75 dbspace.. requ
8410: 69 72 65 64 0a 09 20 20 64 62 64 69 72 29 29 29 ired.. dbdir)))
8420: 0a 0a 3b 3b 20 63 68 65 63 6b 20 61 76 61 69 6c ..;; check avail
8430: 61 62 6c 65 20 73 70 61 63 65 20 69 6e 20 64 62 able space in db
8440: 64 69 72 2c 20 65 78 69 74 20 69 66 20 69 6e 73 dir, exit if ins
8450: 75 66 66 69 63 69 65 6e 74 0a 3b 3b 0a 28 64 65 ufficient.;;.(de
8460: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 fine (common:che
8470: 63 6b 2d 64 62 2d 64 69 72 2d 61 6e 64 2d 65 78 ck-db-dir-and-ex
8480: 69 74 2d 69 66 2d 69 6e 73 75 66 66 69 63 69 65 it-if-insufficie
8490: 6e 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 70 nt). (let* ((sp
84a0: 61 63 65 64 61 74 20 28 63 6f 6d 6d 6f 6e 3a 63 acedat (common:c
84b0: 68 65 63 6b 2d 64 62 2d 64 69 72 2d 73 70 61 63 heck-db-dir-spac
84c0: 65 29 29 0a 09 20 28 69 73 2d 6f 6b 20 20 20 20 e)).. (is-ok
84d0: 28 63 61 72 20 73 70 61 63 65 64 61 74 29 29 0a (car spacedat)).
84e0: 09 20 28 64 62 73 70 61 63 65 20 20 28 63 61 64 . (dbspace (cad
84f0: 72 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 28 r spacedat)).. (
8500: 72 65 71 75 69 72 65 64 20 28 63 61 64 64 72 20 required (caddr
8510: 73 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 62 spacedat)).. (db
8520: 64 69 72 20 20 20 20 28 63 61 64 64 64 72 20 73 dir (cadddr s
8530: 70 61 63 65 64 61 74 29 29 29 0a 20 20 20 20 28 pacedat))). (
8540: 69 66 20 28 6e 6f 74 20 69 73 2d 6f 6b 29 0a 09 if (not is-ok)..
8550: 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 (begin.. (debug
8560: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
8570: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
8580: 2a 20 22 49 6e 73 75 66 66 69 63 69 65 6e 74 20 * "Insufficient
8590: 73 70 61 63 65 20 69 6e 20 22 20 64 62 64 69 72 space in " dbdir
85a0: 20 22 2c 20 72 65 71 75 69 72 65 20 22 20 72 65 ", require " re
85b0: 71 75 69 72 65 64 20 22 2c 20 68 61 76 65 20 22 quired ", have "
85c0: 20 64 62 73 70 61 63 65 20 20 22 2c 20 65 78 69 dbspace ", exi
85d0: 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 20 20 28 ting now.").. (
85e0: 65 78 69 74 20 31 29 29 29 29 29 0a 20 20 0a 3b exit 1))))). .;
85f0: 3b 20 70 61 74 68 73 20 69 73 20 6c 69 73 74 20 ; paths is list
8600: 6f 66 20 6c 69 73 74 73 20 28 28 6e 61 6d 65 20 of lists ((name
8610: 70 61 74 68 29 20 2e 2e 2e 20 29 0a 3b 3b 0a 28 path) ... ).;;.(
8620: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
8630: 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d 6d 6f 73 et-disk-with-mos
8640: 74 2d 66 72 65 65 2d 73 70 61 63 65 20 64 69 73 t-free-space dis
8650: 6b 73 20 6d 69 6e 73 69 7a 65 29 0a 20 20 28 6c ks minsize). (l
8660: 65 74 20 28 28 62 65 73 74 20 20 20 20 20 23 66 et ((best #f
8670: 29 0a 09 28 62 65 73 74 73 69 7a 65 20 30 29 29 )..(bestsize 0))
8680: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
8690: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 69 (lambda (di
86a0: 73 6b 2d 6e 75 6d 29 0a 20 20 20 20 20 20 20 28 sk-num). (
86b0: 6c 65 74 2a 20 28 28 64 69 72 70 61 74 68 20 20 let* ((dirpath
86c0: 20 20 28 63 61 64 72 20 28 61 73 73 6f 63 20 64 (cadr (assoc d
86d0: 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 29 29 29 isk-num disks)))
86e0: 0a 09 20 20 20 20 20 20 28 66 72 65 65 73 70 63 .. (freespc
86f0: 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 20 20 20 (cond....
8700: 28 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 79 ((not (directory
8710: 3f 20 64 69 72 70 61 74 68 29 29 0a 09 09 09 20 ? dirpath))....
8720: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c (if (common:l
8730: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 ow-noise-print 3
8740: 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 61 20 00 "disks not a
8750: 64 69 72 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a dir " disk-num).
8760: 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
8770: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
8780: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
8790: 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 disk " disk-num
87a0: 22 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 69 " at path \"" di
87b0: 72 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 rpath "\" is not
87c0: 20 61 20 64 69 72 65 63 74 6f 72 79 20 2d 20 69 a directory - i
87d0: 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 29 0a 09 gnoring it."))..
87e0: 09 09 20 20 20 20 2d 31 29 0a 09 09 09 20 20 20 .. -1)....
87f0: 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 ((not (file-writ
8800: 65 2d 61 63 63 65 73 73 3f 20 64 69 72 70 61 74 e-access? dirpat
8810: 68 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 h)).... (if (
8820: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
8830: 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 73 6b -print 300 "disk
8840: 73 20 6e 6f 74 20 77 72 69 74 65 61 62 6c 65 20 s not writeable
8850: 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 " disk-num).....
8860: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
8870: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
8880: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b * "WARNING: disk
8890: 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 " disk-num " at
88a0: 20 70 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 path \"" dirpat
88b0: 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 77 72 69 h "\" is not wri
88c0: 74 65 61 62 6c 65 20 2d 20 69 67 6e 6f 72 69 6e teable - ignorin
88d0: 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 20 g it."))....
88e0: 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 -1).... ((not
88f0: 28 65 71 3f 20 28 73 74 72 69 6e 67 2d 72 65 66 (eq? (string-ref
8900: 20 64 69 72 70 61 74 68 20 30 29 20 23 5c 2f 29 dirpath 0) #\/)
8910: 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 63 6f ).... (if (co
8920: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
8930: 72 69 6e 74 20 33 30 30 20 22 64 69 73 6b 73 20 rint 300 "disks
8940: 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 70 61 74 not a proper pat
8950: 68 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 h " disk-num)...
8960: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
8970: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
8980: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 rt* "WARNING: di
8990: 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 sk " disk-num "
89a0: 61 74 20 70 61 74 68 20 5c 22 22 20 64 69 72 70 at path \"" dirp
89b0: 61 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 61 ath "\" is not a
89c0: 20 66 75 6c 6c 79 20 71 75 61 6c 69 66 69 65 64 fully qualified
89d0: 20 70 61 74 68 20 2d 20 69 67 6e 6f 72 69 6e 67 path - ignoring
89e0: 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 20 2d it.")).... -
89f0: 31 29 0a 09 09 09 20 20 20 28 65 6c 73 65 0a 09 1).... (else..
8a00: 09 09 20 20 20 20 28 67 65 74 2d 64 66 20 64 69 .. (get-df di
8a10: 72 70 61 74 68 29 29 29 29 29 0a 09 20 28 69 66 rpath))))).. (if
8a20: 20 28 3e 20 66 72 65 65 73 70 63 20 62 65 73 74 (> freespc best
8a30: 73 69 7a 65 29 0a 09 20 20 20 20 20 28 62 65 67 size).. (beg
8a40: 69 6e 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 in.. (set!
8a50: 20 62 65 73 74 20 20 20 20 20 28 63 6f 6e 73 20 best (cons
8a60: 64 69 73 6b 2d 6e 75 6d 20 64 69 72 70 61 74 68 disk-num dirpath
8a70: 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 )).. (set!
8a80: 20 62 65 73 74 73 69 7a 65 20 66 72 65 65 73 70 bestsize freesp
8a90: 63 29 29 29 29 29 0a 20 20 20 20 20 28 6d 61 70 c))))). (map
8aa0: 20 63 61 72 20 64 69 73 6b 73 29 29 0a 20 20 20 car disks)).
8ab0: 20 28 69 66 20 28 61 6e 64 20 62 65 73 74 20 28 (if (and best (
8ac0: 3e 20 62 65 73 74 73 69 7a 65 20 6d 69 6e 73 69 > bestsize minsi
8ad0: 7a 65 29 29 0a 09 62 65 73 74 0a 09 23 66 29 29 ze))..best..#f))
8ae0: 29 20 3b 3b 20 23 66 20 6d 65 61 6e 73 20 6e 6f ) ;; #f means no
8af0: 20 64 69 73 6b 20 63 61 6e 64 69 64 61 74 65 20 disk candidate
8b00: 66 6f 75 6e 64 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d found..;;=======
8b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8b50: 3b 3b 20 45 20 4e 20 56 20 49 20 52 20 4f 20 4e ;; E N V I R O N
8b60: 20 4d 20 45 20 4e 20 54 20 20 20 56 20 41 20 52 M E N T V A R
8b70: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
8b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 09 20 20 20 ===========..
8bc0: 20 20 20 0a 28 64 65 66 69 6e 65 20 28 73 61 76 .(define (sav
8bd0: 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 73 e-environment-as
8be0: 2d 66 69 6c 65 73 20 66 6e 61 6d 65 20 23 21 6b -files fname #!k
8bf0: 65 79 20 28 69 67 6e 6f 72 65 76 61 72 73 20 28 ey (ignorevars (
8c00: 6c 69 73 74 20 22 55 53 45 52 22 20 22 48 4f 4d list "USER" "HOM
8c10: 45 22 20 22 44 49 53 50 4c 41 59 22 20 22 4c 53 E" "DISPLAY" "LS
8c20: 5f 43 4f 4c 4f 52 53 22 20 22 58 4b 45 59 53 59 _COLORS" "XKEYSY
8c30: 4d 44 42 22 20 22 45 44 49 54 4f 52 22 20 22 4d MDB" "EDITOR" "M
8c40: 41 4b 45 46 4c 41 47 53 22 20 22 4d 41 4b 45 46 AKEFLAGS" "MAKEF
8c50: 22 20 22 4d 41 4b 45 4f 56 45 52 52 49 44 45 53 " "MAKEOVERRIDES
8c60: 22 29 29 29 0a 20 20 28 6c 65 74 20 28 28 65 6e "))). (let ((en
8c70: 76 76 61 72 73 20 28 67 65 74 2d 65 6e 76 69 72 vvars (get-envir
8c80: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 onment-variables
8c90: 29 29 0a 20 20 20 20 20 20 20 20 28 77 68 69 74 )). (whit
8ca0: 65 73 70 20 28 72 65 67 65 78 70 20 22 5b 5e 61 esp (regexp "[^a
8cb0: 2d 7a 41 2d 5a 30 2d 39 5f 5c 5c 2d 3a 2c 2e 5c -zA-Z0-9_\\-:,.\
8cc0: 5c 2f 25 24 5d 22 29 29 0a 09 28 6d 75 6e 67 65 \/%$]"))..(munge
8cd0: 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 76 61 6c val (lambda (val
8ce0: 29 0a 09 09 20 20 20 20 28 63 6f 6e 64 0a 09 09 )... (cond...
8cf0: 20 20 20 20 20 28 28 65 71 3f 20 76 61 6c 20 23 ((eq? val #
8d00: 74 29 20 22 22 29 20 3b 3b 20 63 6f 6e 76 65 72 t) "") ;; conver
8d10: 74 20 23 74 20 74 6f 20 65 6d 70 74 79 20 73 74 t #t to empty st
8d20: 72 69 6e 67 0a 09 09 20 20 20 20 20 28 28 65 71 ring... ((eq
8d30: 3f 20 76 61 6c 20 23 66 29 20 23 66 29 20 3b 3b ? val #f) #f) ;;
8d40: 20 63 6f 6e 76 65 72 74 20 23 66 20 74 6f 20 69 convert #f to i
8d50: 74 73 65 6c 66 20 28 73 74 69 6c 6c 20 74 68 69 tself (still thi
8d60: 6e 6b 69 6e 67 20 61 62 6f 75 74 20 74 68 69 73 nking about this
8d70: 20 6f 6e 65 0a 09 09 20 20 20 20 20 28 65 6c 73 one... (els
8d80: 65 20 76 61 6c 29 29 29 29 29 0a 20 20 20 20 20 e val))))).
8d90: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
8da0: 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e 61 6d 65 file (conc fname
8db0: 20 22 2e 63 73 68 22 29 0a 20 20 20 20 20 20 20 ".csh").
8dc0: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
8dd0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
8de0: 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 0a lambda (keyval).
8df0: 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
8e00: 6b 65 79 20 20 20 28 63 61 72 20 6b 65 79 76 61 key (car keyva
8e10: 6c 29 29 0a 09 09 09 20 20 20 20 20 28 76 61 6c l)).... (val
8e20: 20 20 20 28 63 64 72 20 6b 65 79 76 61 6c 29 29 (cdr keyval))
8e30: 0a 09 09 09 20 20 20 20 20 28 64 65 6c 69 6d 20 .... (delim
8e40: 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 (if (string-sear
8e50: 63 68 20 77 68 69 74 65 73 70 20 76 61 6c 29 20 ch whitesp val)
8e60: 0a 09 09 09 09 09 22 5c 22 22 0a 09 09 09 09 09 ......"\""......
8e70: 22 22 29 29 29 0a 09 09 09 28 70 72 69 6e 74 20 "")))....(print
8e80: 28 69 66 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 (if (member key
8e90: 69 67 6e 6f 72 65 76 61 72 73 29 0a 09 09 09 09 ignorevars).....
8ea0: 20 20 20 22 23 20 73 65 74 65 6e 76 20 22 0a 09 "# setenv "..
8eb0: 09 09 09 20 20 20 22 73 65 74 65 6e 76 20 22 29 ... "setenv ")
8ec0: 0a 09 09 09 20 20 20 20 20 20 20 6b 65 79 20 22 .... key "
8ed0: 20 22 20 64 65 6c 69 6d 20 28 6d 75 6e 67 65 76 " delim (mungev
8ee0: 61 6c 20 76 61 6c 29 20 64 65 6c 69 6d 29 29 29 al val) delim)))
8ef0: 0a 09 09 20 20 20 20 65 6e 76 76 61 72 73 29 29 ... envvars))
8f00: 29 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 ). (with-out
8f10: 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e put-to-file (con
8f20: 63 20 66 6e 61 6d 65 20 22 2e 73 68 22 29 0a 20 c fname ".sh").
8f30: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
8f40: 0a 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d . (for-
8f50: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
8f60: 79 76 61 6c 29 0a 09 09 20 20 20 20 20 20 28 6c yval)... (l
8f70: 65 74 2a 20 28 28 6b 65 79 20 28 63 61 72 20 6b et* ((key (car k
8f80: 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 eyval))....
8f90: 28 76 61 6c 20 28 63 64 72 20 6b 65 79 76 61 6c (val (cdr keyval
8fa0: 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 6c 69 )).... (deli
8fb0: 6d 20 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 m (if (string-se
8fc0: 61 72 63 68 20 77 68 69 74 65 73 70 20 76 61 6c arch whitesp val
8fd0: 29 20 0a 09 09 09 09 09 22 5c 22 22 0a 09 09 09 ) ......"\""....
8fe0: 09 09 22 22 29 29 29 0a 09 09 09 28 70 72 69 6e .."")))....(prin
8ff0: 74 20 28 69 66 20 28 6d 65 6d 62 65 72 20 6b 65 t (if (member ke
9000: 79 20 69 67 6e 6f 72 65 76 61 72 73 29 0a 09 09 y ignorevars)...
9010: 09 09 20 20 20 22 23 20 65 78 70 6f 72 74 20 22 .. "# export "
9020: 0a 09 09 09 09 20 20 20 22 65 78 70 6f 72 74 20 ..... "export
9030: 22 29 0a 09 09 09 20 20 20 20 20 20 20 6b 65 79 ").... key
9040: 20 22 3d 22 20 64 65 6c 69 6d 20 28 6d 75 6e 67 "=" delim (mung
9050: 65 76 61 6c 20 76 61 6c 29 20 64 65 6c 69 6d 29 eval val) delim)
9060: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
9070: 20 20 20 20 20 20 20 65 6e 76 76 61 72 73 29 29 envvars))
9080: 29 29 29 0a 0a 3b 3b 20 73 65 74 20 73 6f 6d 65 )))..;; set some
9090: 20 65 6e 76 20 76 61 72 73 20 66 72 6f 6d 20 61 env vars from a
90a0: 6e 20 61 6c 69 73 74 2c 20 72 65 74 75 72 6e 20 n alist, return
90b0: 61 6e 20 61 6c 69 73 74 20 77 69 74 68 20 6f 72 an alist with or
90c0: 69 67 69 6e 61 6c 20 76 61 6c 75 65 73 0a 3b 3b iginal values.;;
90d0: 20 28 28 22 56 41 52 22 20 22 76 61 6c 75 65 22 (("VAR" "value"
90e0: 29 20 2e 2e 2e 29 0a 28 64 65 66 69 6e 65 20 28 ) ...).(define (
90f0: 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 alist->env-vars
9100: 6c 73 74 29 0a 20 20 28 69 66 20 28 6c 69 73 74 lst). (if (list
9110: 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 28 6c 65 ? lst). (le
9120: 74 20 28 28 72 65 73 20 27 28 29 29 29 0a 09 28 t ((res '()))..(
9130: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
9140: 20 28 70 29 0a 09 09 20 20 20 20 28 6c 65 74 2a (p)... (let*
9150: 20 28 28 76 61 72 20 28 63 61 72 20 20 70 29 29 ((var (car p))
9160: 0a 09 09 09 20 20 20 28 76 61 6c 20 28 63 61 64 .... (val (cad
9170: 72 20 70 29 29 0a 09 09 09 20 20 20 28 70 72 76 r p)).... (prv
9180: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
9190: 74 2d 76 61 72 69 61 62 6c 65 20 76 61 72 29 29 t-variable var))
91a0: 29 0a 09 09 20 20 20 20 20 20 28 73 65 74 21 20 )... (set!
91b0: 72 65 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 res (cons (list
91c0: 76 61 72 20 70 72 76 29 20 72 65 73 29 29 0a 09 var prv) res))..
91d0: 09 20 20 20 20 20 20 28 69 66 20 76 61 6c 20 0a . (if val .
91e0: 09 09 09 20 20 28 73 65 74 65 6e 76 20 76 61 72 ... (setenv var
91f0: 20 28 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 (->string val))
9200: 0a 09 09 09 20 20 28 75 6e 73 65 74 65 6e 76 20 .... (unsetenv
9210: 76 61 72 29 29 29 29 0a 09 09 20 20 6c 73 74 29 var))))... lst)
9220: 0a 09 72 65 73 29 0a 20 20 20 20 20 20 27 28 29 ..res). '()
9230: 29 29 0a 0a 3b 3b 20 63 6c 65 61 72 20 76 61 72 ))..;; clear var
9240: 73 20 6d 61 74 63 68 69 6e 67 20 70 61 74 74 65 s matching patte
9250: 72 6e 2c 20 72 75 6e 20 70 72 6f 63 2c 20 73 65 rn, run proc, se
9260: 74 20 76 61 72 73 20 62 61 63 6b 0a 3b 3b 20 69 t vars back.;; i
9270: 66 20 70 72 6f 63 20 69 73 20 61 20 73 74 72 69 f proc is a stri
9280: 6e 67 20 72 75 6e 20 74 68 61 74 20 73 74 72 69 ng run that stri
9290: 6e 67 20 61 73 20 61 20 63 6f 6d 6d 61 6e 64 20 ng as a command
92a0: 77 69 74 68 0a 3b 3b 20 73 79 73 74 65 6d 2e 0a with.;; system..
92b0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
92c0: 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 73 20 on:without-vars
92d0: 70 72 6f 63 20 2e 20 76 61 72 2d 70 61 74 74 73 proc . var-patts
92e0: 29 0a 20 20 28 6c 65 74 20 28 28 76 61 72 73 20 ). (let ((vars
92f0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
9300: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
9310: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
9320: 76 61 72 64 61 74 29 20 3b 3b 20 65 61 63 68 20 vardat) ;; each
9330: 65 6e 76 20 76 61 72 0a 20 20 20 20 20 20 20 28 env var. (
9340: 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 6d 62 64 for-each..(lambd
9350: 61 20 28 76 61 72 2d 70 61 74 74 29 0a 09 20 20 a (var-patt)..
9360: 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 (if (string-matc
9370: 68 20 76 61 72 2d 70 61 74 74 20 28 63 61 72 20 h var-patt (car
9380: 76 61 72 64 61 74 29 29 0a 09 20 20 20 20 20 20 vardat))..
9390: 28 6c 65 74 20 28 28 76 61 72 20 28 63 61 72 20 (let ((var (car
93a0: 76 61 72 64 61 74 29 29 0a 09 09 20 20 20 20 28 vardat))... (
93b0: 76 61 6c 20 28 63 64 72 20 76 61 72 64 61 74 29 val (cdr vardat)
93c0: 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 6c 65 ))...(hash-table
93d0: 2d 73 65 74 21 20 76 61 72 73 20 76 61 72 20 76 -set! vars var v
93e0: 61 6c 29 0a 09 09 28 75 6e 73 65 74 65 6e 76 20 al)...(unsetenv
93f0: 76 61 72 29 29 29 29 0a 09 76 61 72 2d 70 61 74 var))))..var-pat
9400: 74 73 29 29 0a 20 20 20 20 20 28 67 65 74 2d 65 ts)). (get-e
9410: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
9420: 62 6c 65 73 29 29 0a 20 20 20 20 28 63 6f 6e 64 bles)). (cond
9430: 0a 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 . ((string?
9440: 70 72 6f 63 29 28 73 79 73 74 65 6d 20 70 72 6f proc)(system pro
9450: 63 29 29 0a 20 20 20 20 20 28 70 72 6f 63 20 20 c)). (proc
9460: 20 20 20 20 20 20 20 20 28 70 72 6f 63 29 29 29 (proc)))
9470: 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 . (hash-table
9480: 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 76 -for-each. v
9490: 61 72 73 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ars. (lambda
94a0: 20 28 76 61 72 20 76 61 6c 29 0a 20 20 20 20 20 (var val).
94b0: 20 20 28 73 65 74 65 6e 76 20 76 61 72 20 76 61 (setenv var va
94c0: 6c 29 29 29 0a 20 20 20 20 76 61 72 73 29 29 0a l))). vars)).
94d0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
94e0: 3a 72 75 6e 2d 61 2d 63 6f 6d 6d 61 6e 64 20 63 :run-a-command c
94f0: 6d 64 20 23 21 6b 65 79 20 28 77 69 74 68 2d 76 md #!key (with-v
9500: 61 72 73 20 23 66 29 29 0a 20 20 28 6c 65 74 2a ars #f)). (let*
9510: 20 28 28 70 72 65 2d 63 6d 64 20 20 28 64 74 65 ((pre-cmd (dte
9520: 73 74 73 3a 67 65 74 2d 70 72 65 2d 63 6f 6d 6d sts:get-pre-comm
9530: 61 6e 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 and)). (
9540: 70 6f 73 74 2d 63 6d 64 20 28 64 74 65 73 74 73 post-cmd (dtests
9550: 3a 67 65 74 2d 70 6f 73 74 2d 63 6f 6d 6d 61 6e :get-post-comman
9560: 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 66 75 d)). (fu
9570: 6c 6c 63 6d 64 20 20 28 69 66 20 28 6f 72 20 70 llcmd (if (or p
9580: 72 65 2d 63 6d 64 20 70 6f 73 74 2d 63 6d 64 29 re-cmd post-cmd)
9590: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
95a0: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 70 72 (conc pr
95b0: 65 2d 63 6d 64 20 63 6d 64 20 70 6f 73 74 2d 63 e-cmd cmd post-c
95c0: 6d 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 md).
95d0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 (conc
95e0: 20 22 76 69 65 77 73 63 72 65 65 6e 20 22 20 63 "viewscreen " c
95f0: 6d 64 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 md)))). (debu
9600: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 32 20 g:print-info 02
9610: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
9620: 74 2a 20 22 52 75 6e 6e 69 6e 67 20 63 6f 6d 6d t* "Running comm
9630: 61 6e 64 3a 20 22 20 66 75 6c 6c 63 6d 64 29 0a and: " fullcmd).
9640: 20 20 20 20 28 69 66 20 77 69 74 68 2d 76 61 72 (if with-var
9650: 73 0a 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f s. (commo
9660: 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 73 20 63 n:without-vars c
9670: 6d 64 29 0a 20 20 20 20 20 20 20 20 28 63 6f 6d md). (com
9680: 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 73 mon:without-vars
9690: 20 66 75 6c 6c 63 6d 64 20 22 4d 54 5f 2e 2a 22 fullcmd "MT_.*"
96a0: 29 29 29 29 0a 09 09 20 20 0a 3b 3b 3d 3d 3d 3d ))))... .;;====
96b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
96c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
96d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
96e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
96f0: 3d 3d 0a 3b 3b 20 54 20 49 20 4d 20 45 20 20 20 ==.;; T I M E
9700: 41 20 4e 20 44 20 20 20 44 20 41 20 54 20 45 0a A N D D A T E.
9710: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
9720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9750: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 43 6f 6e ========..;; Con
9760: 76 65 72 74 20 73 74 72 69 6e 67 73 20 6c 69 6b vert strings lik
9770: 65 20 22 35 73 20 32 68 20 33 6d 22 20 3d 3e 20 e "5s 2h 3m" =>
9780: 36 30 78 36 30 78 32 20 2b 20 33 78 36 30 20 2b 60x60x2 + 3x60 +
9790: 20 35 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 5.(define (comm
97a0: 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 2d 3e 73 on:hms-string->s
97b0: 65 63 6f 6e 64 73 20 74 73 74 72 29 0a 20 20 28 econds tstr). (
97c0: 6c 65 74 20 28 28 70 61 72 74 73 20 20 20 20 20 let ((parts
97d0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 73 (string-split ts
97e0: 74 72 29 29 0a 09 28 74 69 6d 65 2d 73 65 63 73 tr))..(time-secs
97f0: 20 30 29 0a 09 3b 3b 20 73 3d 73 65 63 6f 6e 64 0)..;; s=second
9800: 73 2c 20 6d 3d 6d 69 6e 75 74 65 73 2c 20 68 3d s, m=minutes, h=
9810: 68 6f 75 72 73 2c 20 64 3d 64 61 79 73 0a 09 28 hours, d=days..(
9820: 74 72 78 20 20 20 20 20 20 20 28 72 65 67 65 78 trx (regex
9830: 70 20 22 28 5c 5c 64 2b 29 28 5b 73 6d 68 64 5d p "(\\d+)([smhd]
9840: 29 22 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 )"))). (for-e
9850: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 61 72 ach (lambda (par
9860: 74 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 74 63 t)...(let ((matc
9870: 68 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 h (string-match
9880: 20 74 72 78 20 70 61 72 74 29 29 29 0a 09 09 20 trx part)))...
9890: 20 28 69 66 20 6d 61 74 63 68 0a 09 09 20 20 20 (if match...
98a0: 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 73 (let ((val (s
98b0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 tring->number (c
98c0: 61 64 72 20 6d 61 74 63 68 29 29 29 0a 09 09 09 adr match)))....
98d0: 20 20 20 20 28 75 6e 74 20 28 63 61 64 64 72 20 (unt (caddr
98e0: 6d 61 74 63 68 29 29 29 0a 09 09 09 28 69 66 20 match)))....(if
98f0: 76 61 6c 20 0a 09 09 09 20 20 20 20 28 73 65 74 val .... (set
9900: 21 20 74 69 6d 65 2d 73 65 63 73 20 28 2b 20 74 ! time-secs (+ t
9910: 69 6d 65 2d 73 65 63 73 20 28 2a 20 76 61 6c 0a ime-secs (* val.
9920: 09 09 09 09 09 09 09 20 20 20 20 28 63 61 73 65 ....... (case
9930: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
9940: 20 75 6e 74 29 0a 09 09 09 09 09 09 09 20 20 20 unt)........
9950: 20 20 20 28 28 73 29 20 31 29 0a 09 09 09 09 09 ((s) 1)......
9960: 09 09 20 20 20 20 20 20 28 28 6d 29 20 36 30 29 .. ((m) 60)
9970: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 ........ ((
9980: 68 29 20 28 2a 20 36 30 20 36 30 29 29 0a 09 09 h) (* 60 60))...
9990: 09 09 09 09 09 20 20 20 20 20 20 28 28 64 29 20 ..... ((d)
99a0: 28 2a 20 32 34 20 36 30 20 36 30 29 29 0a 09 09 (* 24 60 60))...
99b0: 09 09 09 09 09 20 20 20 20 20 20 28 65 6c 73 65 ..... (else
99c0: 20 30 29 29 29 29 29 29 29 29 29 29 0a 09 20 20 0))))))))))..
99d0: 20 20 20 20 70 61 72 74 73 29 0a 20 20 20 20 74 parts). t
99e0: 69 6d 65 2d 73 65 63 73 29 29 0a 09 09 20 20 20 ime-secs))...
99f0: 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 73 65 .(define (se
9a00: 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 conds->hr-min-se
9a10: 63 20 73 65 63 73 29 0a 20 20 28 6c 65 74 2a 20 c secs). (let*
9a20: 28 28 68 72 73 20 28 71 75 6f 74 69 65 6e 74 20 ((hrs (quotient
9a30: 73 65 63 73 20 33 36 30 30 29 29 0a 09 20 28 6d secs 3600)).. (m
9a40: 69 6e 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 in (quotient (-
9a50: 73 65 63 73 20 28 2a 20 68 72 73 20 33 36 30 30 secs (* hrs 3600
9a60: 29 29 20 36 30 29 29 0a 09 20 28 73 65 63 20 28 )) 60)).. (sec (
9a70: 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 33 36 - secs (* hrs 36
9a80: 30 30 29 28 2a 20 6d 69 6e 20 36 30 29 29 29 29 00)(* min 60))))
9a90: 0a 20 20 20 20 28 63 6f 6e 63 20 28 69 66 20 28 . (conc (if (
9aa0: 3e 20 68 72 73 20 30 29 28 63 6f 6e 63 20 68 72 > hrs 0)(conc hr
9ab0: 73 20 22 68 72 20 22 29 20 22 22 29 0a 09 20 20 s "hr ") "")..
9ac0: 28 69 66 20 28 3e 20 6d 69 6e 20 30 29 28 63 6f (if (> min 0)(co
9ad0: 6e 63 20 6d 69 6e 20 22 6d 20 22 29 20 20 22 22 nc min "m ") ""
9ae0: 29 0a 09 20 20 73 65 63 20 22 73 22 29 29 29 0a ).. sec "s"))).
9af0: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
9b00: 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 s->time-string s
9b10: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
9b20: 69 6e 67 20 0a 20 20 20 28 73 65 63 6f 6e 64 73 ing . (seconds
9b30: 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
9b40: 29 20 22 25 48 3a 25 4d 3a 25 53 22 29 29 0a 0a ) "%H:%M:%S"))..
9b50: 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 (define (seconds
9b60: 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d ->work-week/day-
9b70: 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d time sec). (tim
9b80: 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 e->string. (se
9b90: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
9ba0: 65 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 20 e sec) "ww%V.%u
9bb0: 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 69 6e %H:%M"))..(defin
9bc0: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b e (seconds->work
9bd0: 2d 77 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 -week/day sec).
9be0: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 (time->string.
9bf0: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
9c00: 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 77 77 25 l-time sec) "ww%
9c10: 56 2e 25 75 22 29 29 0a 0a 28 64 65 66 69 6e 65 V.%u"))..(define
9c20: 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d (seconds->year-
9c30: 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 20 73 65 work-week/day se
9c40: 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 c). (time->stri
9c50: 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e ng. (seconds->
9c60: 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 local-time sec)
9c70: 22 25 79 77 77 25 56 2e 25 77 22 29 29 0a 0a 28 "%yww%V.%w"))..(
9c80: 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d define (seconds-
9c90: 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f >year-work-week/
9ca0: 64 61 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 day-time sec).
9cb0: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 (time->string.
9cc0: 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
9cd0: 2d 74 69 6d 65 20 73 65 63 29 20 22 25 59 77 77 -time sec) "%Yww
9ce0: 25 56 2e 25 77 20 25 48 3a 25 4d 22 29 29 0a 0a %V.%w %H:%M"))..
9cf0: 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 (define (seconds
9d00: 2d 3e 79 65 61 72 2d 77 65 65 6b 2f 64 61 79 2d ->year-week/day-
9d10: 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d time sec). (tim
9d20: 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 e->string. (se
9d30: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
9d40: 65 20 73 65 63 29 20 22 25 59 77 25 56 2e 25 77 e sec) "%Yw%V.%w
9d50: 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 69 %H:%M"))..(defi
9d60: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 71 75 61 ne (seconds->qua
9d70: 72 74 65 72 20 73 65 63 29 0a 20 20 28 63 61 73 rter sec). (cas
9d80: 65 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 e (string->numbe
9d90: 72 0a 09 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e r.. (time->strin
9da0: 67 20 0a 09 20 20 28 73 65 63 6f 6e 64 73 2d 3e g .. (seconds->
9db0: 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 0a local-time sec).
9dc0: 09 20 20 22 25 6d 22 29 29 0a 20 20 20 20 28 28 . "%m")). ((
9dd0: 31 20 32 20 33 29 20 31 29 0a 20 20 20 20 28 28 1 2 3) 1). ((
9de0: 34 20 35 20 36 29 20 32 29 0a 20 20 20 20 28 28 4 5 6) 2). ((
9df0: 37 20 38 20 39 29 20 33 29 0a 20 20 20 20 28 28 7 8 9) 3). ((
9e00: 31 30 20 31 31 20 31 32 29 20 34 29 0a 20 20 20 10 11 12) 4).
9e10: 20 28 65 6c 73 65 20 23 66 29 29 29 0a 0a 3b 3b (else #f)))..;;
9e20: 20 67 69 76 65 6e 20 73 70 61 6e 20 6f 66 20 73 given span of s
9e30: 65 63 6f 6e 64 73 20 74 73 74 61 72 74 20 74 6f econds tstart to
9e40: 20 74 65 6e 64 0a 3b 3b 20 66 69 6e 64 20 73 74 tend.;; find st
9e50: 61 72 74 20 74 69 6d 65 20 74 6f 20 6d 61 72 6b art time to mark
9e60: 20 61 6e 64 20 6d 61 72 6b 20 64 65 6c 74 61 0a and mark delta.
9e70: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
9e80: 6f 6e 3a 66 69 6e 64 2d 73 74 61 72 74 2d 6d 61 on:find-start-ma
9e90: 72 6b 2d 61 6e 64 2d 6d 61 72 6b 2d 64 65 6c 74 rk-and-mark-delt
9ea0: 61 20 74 73 74 61 72 74 20 74 65 6e 64 29 0a 20 a tstart tend).
9eb0: 20 28 6c 65 74 2a 20 28 28 64 65 6c 74 61 74 20 (let* ((deltat
9ec0: 20 20 28 2d 20 28 6d 61 78 20 74 65 6e 64 20 28 (- (max tend (
9ed0: 2b 20 74 65 6e 64 20 31 30 29 29 20 74 73 74 61 + tend 10)) tsta
9ee0: 72 74 29 29 20 3b 3b 20 63 61 6e 27 74 20 68 61 rt)) ;; can't ha
9ef0: 6e 64 6c 65 20 72 75 6e 73 20 6f 66 20 6c 65 73 ndle runs of les
9f00: 73 20 74 68 61 6e 20 34 20 73 65 63 6f 6e 64 73 s than 4 seconds
9f10: 2e 20 50 61 64 20 69 74 20 74 6f 20 31 30 20 73 . Pad it to 10 s
9f20: 65 63 6f 6e 64 73 20 2e 2e 2e 0a 09 20 28 72 65 econds ..... (re
9f30: 73 75 6c 74 20 20 20 23 66 29 0a 09 20 28 6d 69 sult #f).. (mi
9f40: 6e 20 20 20 20 20 20 36 30 29 0a 09 20 28 68 72 n 60).. (hr
9f50: 20 20 20 20 20 20 20 28 2a 20 36 30 20 36 30 29 (* 60 60)
9f60: 29 0a 09 20 28 64 61 79 20 20 20 20 20 20 28 2a ).. (day (*
9f70: 20 32 34 20 68 72 29 29 0a 09 20 28 79 72 20 20 24 hr)).. (yr
9f80: 20 20 20 20 20 28 2a 20 33 36 35 20 64 61 79 29 (* 365 day)
9f90: 29 20 3b 3b 20 79 65 61 72 0a 09 20 28 6d 6f 20 ) ;; year.. (mo
9fa0: 20 20 20 20 20 20 28 2f 20 79 72 20 31 32 29 29 (/ yr 12))
9fb0: 0a 09 20 28 77 6b 20 20 20 20 20 20 20 28 2a 20 .. (wk (*
9fc0: 64 61 79 20 37 29 29 29 0a 20 20 20 20 28 66 6f day 7))). (fo
9fd0: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
9fe0: 62 64 61 20 28 6d 61 78 2d 62 6c 6b 73 29 0a 20 bda (max-blks).
9ff0: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a (for-each.
a000: 09 28 6c 61 6d 62 64 61 20 28 73 70 61 6e 29 20 .(lambda (span)
a010: 3b 3b 20 35 20 32 20 31 0a 09 20 20 28 69 66 20 ;; 5 2 1.. (if
a020: 28 6e 6f 74 20 72 65 73 75 6c 74 29 0a 09 20 20 (not result)..
a030: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 09 (for-each ..
a040: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
a050: 74 69 6d 65 75 6e 69 74 20 74 69 6d 65 73 79 6d timeunit timesym
a060: 29 20 3b 3b 20 79 65 61 72 20 6d 6f 6e 74 68 20 ) ;; year month
a070: 64 61 79 20 68 72 20 6d 69 6e 20 73 65 63 0a 09 day hr min sec..
a080: 09 20 28 69 66 20 28 6e 6f 74 20 72 65 73 75 6c . (if (not resul
a090: 74 29 0a 09 09 20 20 20 20 20 28 6c 65 74 2a 20 t)... (let*
a0a0: 28 28 74 69 6d 65 2d 62 6c 6b 20 28 2a 20 73 70 ((time-blk (* sp
a0b0: 61 6e 20 74 69 6d 65 75 6e 69 74 29 29 0a 09 09 an timeunit))...
a0c0: 09 20 20 20 20 28 6e 75 6d 2d 62 6c 6b 73 20 28 . (num-blks (
a0d0: 71 75 6f 74 69 65 6e 74 20 64 65 6c 74 61 74 20 quotient deltat
a0e0: 74 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 20 20 time-blk)))...
a0f0: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 3e (if (and (>
a100: 20 6e 75 6d 2d 62 6c 6b 73 20 34 29 28 3c 20 6e num-blks 4)(< n
a110: 75 6d 2d 62 6c 6b 73 20 6d 61 78 2d 62 6c 6b 73 um-blks max-blks
a120: 29 29 0a 09 09 09 20 20 20 28 6c 65 74 20 28 28 )).... (let ((
a130: 66 69 72 73 74 20 28 2a 20 28 71 75 6f 74 69 65 first (* (quotie
a140: 6e 74 20 74 73 74 61 72 74 20 74 69 6d 65 2d 62 nt tstart time-b
a150: 6c 6b 29 20 74 69 6d 65 2d 62 6c 6b 29 29 29 0a lk) time-blk))).
a160: 09 09 09 20 20 20 20 20 28 73 65 74 21 20 72 65 ... (set! re
a170: 73 75 6c 74 20 28 6c 69 73 74 20 73 70 61 6e 20 sult (list span
a180: 74 69 6d 65 75 6e 69 74 20 74 69 6d 65 2d 62 6c timeunit time-bl
a190: 6b 20 66 69 72 73 74 20 74 69 6d 65 73 79 6d 29 k first timesym)
a1a0: 29 0a 09 09 09 20 20 20 20 20 29 29 29 29 29 0a ).... ))))).
a1b0: 09 20 20 20 20 20 20 20 28 6c 69 73 74 20 79 72 . (list yr
a1c0: 20 6d 6f 20 77 6b 20 64 61 79 20 68 72 20 6d 69 mo wk day hr mi
a1d0: 6e 20 31 29 0a 09 20 20 20 20 20 20 20 27 28 20 n 1).. '(
a1e0: 20 20 20 20 79 20 20 6d 6f 20 77 20 20 64 20 20 y mo w d
a1f0: 20 68 20 20 6d 20 20 20 73 29 29 29 29 0a 09 28 h m s))))..(
a200: 6c 69 73 74 20 38 20 36 20 35 20 32 20 31 29 29 list 8 6 5 2 1))
a210: 29 0a 20 20 20 20 20 27 28 35 20 31 30 20 31 35 ). '(5 10 15
a220: 20 32 30 20 33 30 20 34 30 20 35 30 20 35 30 30 20 30 40 50 500
a230: 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c 75 65 )). (if value
a240: 73 0a 09 28 61 70 70 6c 79 20 76 61 6c 75 65 73 s..(apply values
a250: 20 72 65 73 75 6c 74 29 0a 09 28 76 61 6c 75 65 result)..(value
a260: 73 20 30 20 64 61 79 20 31 20 30 20 27 64 29 29 s 0 day 1 0 'd))
a270: 29 29 0a 09 20 20 20 20 0a 09 20 20 0a 0a 3b 3b )).. .. ..;;
a280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2c0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4f 20 4c 20 ======.;; C O L
a2d0: 4f 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d O R S.;;========
a2e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 ==============.
a320: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 63 .(define (c
a330: 6f 6d 6d 6f 6e 3a 6e 61 6d 65 2d 3e 69 75 70 2d ommon:name->iup-
a340: 63 6f 6c 6f 72 20 6e 61 6d 65 29 0a 20 20 28 63 color name). (c
a350: 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ase (string->sym
a360: 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e bol (string-down
a370: 63 61 73 65 20 6e 61 6d 65 29 29 0a 20 20 20 20 case name)).
a380: 28 28 72 65 64 29 20 20 20 20 22 32 32 33 20 33 ((red) "223 3
a390: 33 20 34 39 22 29 0a 20 20 20 20 28 28 67 72 65 3 49"). ((gre
a3a0: 79 29 20 20 20 22 31 39 32 20 31 39 32 20 31 39 y) "192 192 19
a3b0: 32 22 29 0a 20 20 20 20 28 28 6f 72 61 6e 67 65 2"). ((orange
a3c0: 29 20 22 32 35 35 20 31 37 32 20 31 33 22 29 0a ) "255 172 13").
a3d0: 20 20 20 20 28 28 70 75 72 70 6c 65 29 20 22 54 ((purple) "T
a3e0: 68 69 73 20 69 73 20 75 6e 66 69 6e 69 73 68 65 his is unfinishe
a3f0: 64 20 2e 2e 2e 22 29 29 29 0a 0a 3b 3b 20 28 64 d ...")))..;; (d
a400: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
a410: 74 2d 63 6f 6c 6f 72 2d 66 6f 72 2d 73 74 61 74 t-color-for-stat
a420: 65 2d 73 74 61 74 75 73 20 73 74 61 74 65 20 73 e-status state s
a430: 74 61 74 75 73 29 0a 3b 3b 20 20 20 28 63 61 73 tatus).;; (cas
a440: 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f e (string->symbo
a450: 6c 20 73 74 61 74 65 29 0a 3b 3b 20 20 20 20 20 l state).;;
a460: 28 28 43 4f 4d 50 4c 45 54 45 44 29 0a 3b 3b 20 ((COMPLETED).;;
a470: 20 20 20 20 20 28 63 61 73 65 20 28 73 74 72 69 (case (stri
a480: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 74 75 ng->symbol statu
a490: 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 50 s).;; ((P
a4a0: 41 53 53 29 20 20 20 20 20 20 20 20 22 37 30 20 ASS) "70
a4b0: 20 32 34 39 20 37 33 22 29 0a 3b 3b 20 20 20 20 249 73").;;
a4c0: 20 20 20 20 28 28 57 41 52 4e 20 57 41 49 56 45 ((WARN WAIVE
a4d0: 44 29 20 22 32 35 35 20 31 37 32 20 31 33 22 29 D) "255 172 13")
a4e0: 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 53 4b 49 .;; ((SKI
a4f0: 50 29 20 20 20 20 20 20 20 20 22 32 33 30 20 32 P) "230 2
a500: 33 30 20 30 22 29 0a 3b 3b 20 20 20 20 20 20 20 30 0").;;
a510: 20 28 65 6c 73 65 20 22 32 32 33 20 33 33 20 34 (else "223 33 4
a520: 39 22 29 29 29 0a 3b 3b 20 20 20 20 20 28 28 4c 9"))).;; ((L
a530: 41 55 4e 43 48 45 44 29 20 20 20 20 20 20 20 20 AUNCHED)
a540: 20 22 31 30 31 20 31 32 33 20 31 34 32 22 29 0a "101 123 142").
a550: 3b 3b 20 20 20 20 20 28 28 43 48 45 43 4b 29 20 ;; ((CHECK)
a560: 20 20 20 20 20 20 20 20 20 20 20 22 32 35 35 20 "255
a570: 31 30 30 20 35 30 22 29 0a 3b 3b 20 20 20 20 20 100 50").;;
a580: 28 28 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 ((REMOTEHOSTSTAR
a590: 54 29 20 20 22 35 30 20 20 31 33 30 20 31 39 35 T) "50 130 195
a5a0: 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 55 4e 4e ").;; ((RUNN
a5b0: 49 4e 47 29 20 20 20 20 20 20 20 20 20 20 22 39 ING) "9
a5c0: 20 20 20 31 33 31 20 32 33 32 22 29 0a 3b 3b 20 131 232").;;
a5d0: 20 20 20 20 28 28 4b 49 4c 4c 52 45 51 29 20 20 ((KILLREQ)
a5e0: 20 20 20 20 20 20 20 20 22 33 39 20 20 38 32 20 "39 82
a5f0: 20 32 30 36 22 29 0a 3b 3b 20 20 20 20 20 28 28 206").;; ((
a600: 4b 49 4c 4c 45 44 29 20 20 20 20 20 20 20 20 20 KILLED)
a610: 20 20 22 32 33 34 20 31 30 31 20 31 37 22 29 0a "234 101 17").
a620: 3b 3b 20 20 20 20 20 28 28 4e 4f 54 5f 53 54 41 ;; ((NOT_STA
a630: 52 54 45 44 29 20 20 20 20 20 20 22 32 34 30 20 RTED) "240
a640: 32 34 30 20 32 34 30 22 29 0a 3b 3b 20 20 20 20 240 240").;;
a650: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 (else
a660: 20 20 20 20 20 22 31 39 32 20 31 39 32 20 31 39 "192 192 19
a670: 32 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 2")))..(define (
a680: 63 6f 6d 6d 6f 6e 3a 69 75 70 2d 63 6f 6c 6f 72 common:iup-color
a690: 2d 3e 72 67 62 2d 68 65 78 20 69 6e 73 74 72 29 ->rgb-hex instr)
a6a0: 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 . (string-inter
a6b0: 73 70 65 72 73 65 20 0a 20 20 20 28 6d 61 70 20 sperse . (map
a6c0: 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 (lambda (x).
a6d0: 20 20 20 20 20 20 28 6e 75 6d 62 65 72 2d 3e 73 (number->s
a6e0: 74 72 69 6e 67 20 78 20 31 36 29 29 0a 20 20 20 tring x 16)).
a6f0: 20 20 20 20 20 28 6d 61 70 20 73 74 72 69 6e 67 (map string
a700: 2d 3e 6e 75 6d 62 65 72 0a 20 20 20 20 20 20 20 ->number.
a710: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 (string-sp
a720: 6c 69 74 20 69 6e 73 74 72 29 29 29 0a 20 20 20 lit instr))).
a730: 22 2f 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 "/"))..(define (
a740: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
a750: 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 -from-status sta
a760: 74 75 73 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 tus). (cond.
a770: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
a780: 22 50 41 53 53 22 29 20 20 20 20 22 67 72 65 65 "PASS") "gree
a790: 6e 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 n"). ((equal?
a7a0: 73 74 61 74 75 73 20 22 46 41 49 4c 22 29 20 20 status "FAIL")
a7b0: 20 20 22 72 65 64 22 29 0a 20 20 20 28 28 65 71 "red"). ((eq
a7c0: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 57 41 52 ual? status "WAR
a7d0: 4e 22 29 20 20 20 20 22 6f 72 61 6e 67 65 22 29 N") "orange")
a7e0: 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
a7f0: 74 75 73 20 22 4b 49 4c 4c 45 44 22 29 20 20 22 tus "KILLED") "
a800: 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 28 65 71 orange"). ((eq
a810: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 4b 49 4c ual? status "KIL
a820: 4c 52 45 51 22 29 20 22 70 75 72 70 6c 65 22 29 LREQ") "purple")
a830: 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
a840: 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 29 20 22 tus "RUNNING") "
a850: 62 6c 75 65 22 29 0a 20 20 20 28 28 65 71 75 61 blue"). ((equa
a860: 6c 3f 20 73 74 61 74 75 73 20 22 41 42 4f 52 54 l? status "ABORT
a870: 22 29 20 20 20 22 62 72 6f 77 6e 22 29 0a 20 20 ") "brown").
a880: 20 28 65 6c 73 65 20 22 62 6c 61 63 6b 22 29 29 (else "black"))
a890: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
a8a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a8d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e ===========.;; N
a8e0: 20 41 20 4e 20 4f 20 4d 20 53 20 47 20 20 20 43 A N O M S G C
a8f0: 20 4c 20 49 20 45 20 4e 20 54 0a 3b 3b 3d 3d 3d L I E N T.;;===
a900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a940: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 ===..(define (se
a950: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 rver:get-best-gu
a960: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
a970: 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 name). (let ((r
a980: 65 73 20 23 66 29 29 0a 20 20 20 20 28 66 6f 72 es #f)). (for
a990: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
a9a0: 62 64 61 20 28 61 64 72 29 0a 20 20 20 20 20 20 bda (adr).
a9b0: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 28 (if (not (eq? (
a9c0: 75 38 76 65 63 74 6f 72 2d 72 65 66 20 61 64 72 u8vector-ref adr
a9d0: 20 30 29 20 31 32 37 29 29 0a 09 20 20 20 28 73 0) 127)).. (s
a9e0: 65 74 21 20 72 65 73 20 61 64 72 29 29 29 0a 20 et! res adr))).
a9f0: 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 ;; NOTE: Thi
aa00: 73 20 63 61 6e 20 66 61 69 6c 20 77 68 65 6e 20 s can fail when
aa10: 74 68 65 72 65 20 69 73 20 6e 6f 20 6d 65 6e 74 there is no ment
aa20: 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f 73 74 20 ion of the host
aa30: 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 2e 20 46 in /etc/hosts. F
aa40: 49 58 4d 45 0a 20 20 20 20 20 28 76 65 63 74 6f IXME. (vecto
aa50: 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 69 6e 66 r->list (hostinf
aa60: 6f 2d 61 64 64 72 65 73 73 65 73 20 28 68 6f 73 o-addresses (hos
aa70: 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 tname->hostinfo
aa80: 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 20 hostname)))).
aa90: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
aaa0: 65 72 73 65 20 0a 20 20 20 20 20 28 6d 61 70 20 erse . (map
aab0: 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 0a 09 number->string..
aac0: 20 20 28 75 38 76 65 63 74 6f 72 2d 3e 6c 69 73 (u8vector->lis
aad0: 74 0a 09 20 20 20 28 69 66 20 72 65 73 20 72 65 t.. (if res re
aae0: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 s (hostname->ip
aaf0: 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 22 2e 22 hostname)))) "."
ab00: 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 63 )))...(define (c
ab10: 6f 6d 6d 6f 6e 3a 73 65 6e 64 2d 64 62 6f 61 72 ommon:send-dboar
ab20: 64 2d 6d 61 69 6e 2d 63 68 61 6e 67 65 64 29 0a d-main-changed).
ab30: 20 20 28 6c 65 74 2a 20 28 28 64 61 73 68 62 6f (let* ((dashbo
ab40: 61 72 64 2d 69 70 73 20 28 6d 64 64 62 3a 67 65 ard-ips (mddb:ge
ab50: 74 2d 64 61 73 68 62 6f 61 72 64 73 29 29 29 0a t-dashboards))).
ab60: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
ab70: 20 20 20 28 6c 61 6d 62 64 61 20 28 69 70 61 64 (lambda (ipad
ab80: 72 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 r). (let*
ab90: 28 28 73 6f 63 20 28 63 6f 6d 6d 6f 6e 3a 6f 70 ((soc (common:op
aba0: 65 6e 2d 6e 6d 2d 72 65 71 20 28 63 6f 6e 63 20 en-nm-req (conc
abb0: 22 74 63 70 3a 2f 2f 22 20 69 70 61 64 72 29 29 "tcp://" ipadr))
abc0: 29 0a 09 20 20 20 20 20 20 28 6d 73 67 20 28 63 ).. (msg (c
abd0: 6f 6e 63 20 22 6d 61 69 6e 20 22 20 2a 74 6f 70 onc "main " *top
abe0: 70 61 74 68 2a 29 29 0a 09 20 20 20 20 20 20 28 path*)).. (
abf0: 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a 6e 6d 2d 73 res (common:nm-s
ac00: 65 6e 64 2d 72 65 63 65 69 76 65 2d 74 69 6d 65 end-receive-time
ac10: 6f 75 74 20 73 6f 63 20 6d 73 67 29 29 29 0a 09 out soc msg)))..
ac20: 20 28 69 66 20 28 6e 6f 74 20 72 65 73 29 20 3b (if (not res) ;
ac30: 3b 20 63 6f 75 6c 64 6e 27 74 20 72 65 61 63 68 ; couldn't reach
ac40: 20 74 68 61 74 20 64 61 73 68 62 6f 61 72 64 20 that dashboard
ac50: 2d 20 72 65 6d 6f 76 65 20 69 74 20 66 72 6f 6d - remove it from
ac60: 20 64 62 0a 09 20 20 20 20 20 28 70 72 69 6e 74 db.. (print
ac70: 20 22 45 52 52 4f 52 3a 20 63 6f 75 6c 64 6e 27 "ERROR: couldn'
ac80: 74 20 72 65 61 63 68 20 64 61 73 68 62 6f 61 72 t reach dashboar
ac90: 64 20 22 20 69 70 61 64 72 29 29 0a 09 20 72 65 d " ipadr)).. re
aca0: 73 29 29 0a 20 20 20 20 20 64 61 73 68 62 6f 61 s)). dashboa
acb0: 72 64 2d 69 70 73 29 29 29 0a 20 20 20 20 0a 20 rd-ips))). .
acc0: 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;==========
acd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ace0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
ad10: 44 20 41 20 53 20 48 20 42 20 4f 20 41 20 52 20 D A S H B O A R
ad20: 44 20 20 20 44 20 42 20 0a 3b 3b 3d 3d 3d 3d 3d D D B .;;=====
ad30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad70: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 =..(define (mddb
ad80: 3a 6f 70 65 6e 2d 64 62 29 0a 20 20 28 6c 65 74 :open-db). (let
ad90: 2a 20 28 28 64 62 20 28 6f 70 65 6e 2d 64 61 74 * ((db (open-dat
ada0: 61 62 61 73 65 20 28 63 6f 6e 63 20 28 67 65 74 abase (conc (get
adb0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
adc0: 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f iable "HOME") "/
add0: 2e 64 61 73 68 62 6f 61 72 64 2e 64 62 22 29 29 .dashboard.db"))
ade0: 29 29 0a 20 20 20 20 28 73 65 74 2d 62 75 73 79 )). (set-busy
adf0: 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 28 62 75 -handler! db (bu
ae00: 73 79 2d 74 69 6d 65 6f 75 74 20 31 30 30 30 30 sy-timeout 10000
ae10: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
ae20: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 71 . (lambda (q
ae30: 72 79 29 0a 20 20 20 20 20 20 20 28 65 78 65 63 ry). (exec
ae40: 20 28 73 71 6c 20 64 62 20 71 72 79 29 29 29 0a (sql db qry))).
ae50: 20 20 20 20 20 28 6c 69 73 74 20 0a 20 20 20 20 (list .
ae60: 20 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 "CREATE TABLE
ae70: 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 76 61 IF NOT EXISTS va
ae80: 72 73 20 20 20 20 20 20 20 28 69 64 20 49 4e 54 rs (id INT
ae90: 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 EGER PRIMARY KEY
aea0: 2c 6b 65 79 20 54 45 58 54 2c 20 76 61 6c 20 54 ,key TEXT, val T
aeb0: 45 58 54 2c 20 43 4f 4e 53 54 52 41 49 4e 54 20 EXT, CONSTRAINT
aec0: 76 61 72 73 63 6f 6e 73 74 72 61 69 6e 74 20 55 varsconstraint U
aed0: 4e 49 51 55 45 20 28 6b 65 79 29 29 3b 22 0a 20 NIQUE (key));".
aee0: 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 "CREATE TAB
aef0: 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 LE IF NOT EXISTS
af00: 20 64 61 73 68 62 6f 61 72 64 73 20 28 0a 20 20 dashboards (.
af10: 20 20 20 20 20 20 20 20 69 64 20 20 20 20 20 20 id
af20: 20 20 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 INTEGER PRIMA
af30: 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 20 20 20 RY KEY,.
af40: 20 20 70 69 64 20 20 20 20 20 20 20 20 49 4e 54 pid INT
af50: 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 20 EGER,.
af60: 75 73 65 72 6e 61 6d 65 20 20 20 54 45 58 54 2c username TEXT,
af70: 0a 20 20 20 20 20 20 20 20 20 20 68 6f 73 74 6e . hostn
af80: 61 6d 65 20 20 20 54 45 58 54 2c 0a 20 20 20 20 ame TEXT,.
af90: 20 20 20 20 20 20 69 70 61 64 64 72 20 20 20 20 ipaddr
afa0: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
afb0: 20 70 6f 72 74 6e 75 6d 20 20 20 20 49 4e 54 45 portnum INTE
afc0: 47 45 52 2c 0a 20 20 20 20 20 20 20 20 20 20 73 GER,. s
afd0: 74 61 72 74 5f 74 69 6d 65 20 54 49 4d 45 53 54 tart_time TIMEST
afe0: 41 4d 50 20 44 45 46 41 55 4c 54 20 28 73 74 72 AMP DEFAULT (str
aff0: 66 74 69 6d 65 28 27 25 73 27 2c 27 6e 6f 77 27 ftime('%s','now'
b000: 29 29 2c 0a 20 20 20 20 20 20 20 20 20 20 20 20 )),.
b010: 20 43 4f 4e 53 54 52 41 49 4e 54 20 68 6f 73 74 CONSTRAINT host
b020: 70 6f 72 74 20 55 4e 49 51 55 45 20 28 68 6f 73 port UNIQUE (hos
b030: 74 6e 61 6d 65 2c 70 6f 72 74 6e 75 6d 29 0a 20 tname,portnum).
b040: 20 20 20 20 20 20 20 29 3b 22 0a 20 20 20 20 20 );".
b050: 20 29 29 0a 20 20 20 20 64 62 29 29 0a 0a 3b 3b )). db))..;;
b060: 20 72 65 67 69 73 74 65 72 20 61 20 64 61 73 68 register a dash
b070: 62 6f 61 72 64 20 0a 3b 3b 0a 28 64 65 66 69 6e board .;;.(defin
b080: 65 20 28 6d 64 64 62 3a 72 65 67 69 73 74 65 72 e (mddb:register
b090: 2d 64 61 73 68 62 6f 61 72 64 20 70 6f 72 74 29 -dashboard port)
b0a0: 0a 20 20 28 6c 65 74 2a 20 28 28 70 69 64 20 20 . (let* ((pid
b0b0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f (current-pro
b0c0: 63 65 73 73 2d 69 64 29 29 0a 09 20 28 68 6f 73 cess-id)).. (hos
b0d0: 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f 73 74 2d tname (get-host-
b0e0: 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 64 64 72 name)).. (ipaddr
b0f0: 20 20 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 (server:get-b
b100: 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 est-guess-addres
b110: 73 20 68 6f 73 74 6e 61 6d 65 29 29 0a 09 20 28 s hostname)).. (
b120: 75 73 65 72 6e 61 6d 65 20 28 63 75 72 72 65 6e username (curren
b130: 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 20 3b 3b t-user-name)) ;;
b140: 20 28 63 61 72 20 75 73 65 72 69 6e 66 6f 29 29 (car userinfo))
b150: 29 0a 09 20 28 64 62 20 20 20 20 20 20 28 6d 64 ).. (db (md
b160: 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 db:open-db))).
b170: 20 20 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 (print "Regist
b180: 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 70 69 64 3a er monitor, pid:
b190: 20 22 20 70 69 64 20 22 2c 20 68 6f 73 74 6e 61 " pid ", hostna
b1a0: 6d 65 3a 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 me: " hostname "
b1b0: 2c 20 70 6f 72 74 3a 20 22 20 70 6f 72 74 20 22 , port: " port "
b1c0: 2c 20 75 73 65 72 6e 61 6d 65 3a 20 22 20 75 73 , username: " us
b1d0: 65 72 6e 61 6d 65 29 0a 20 20 20 20 28 65 78 65 ername). (exe
b1e0: 63 20 28 73 71 6c 20 64 62 20 22 49 4e 53 45 52 c (sql db "INSER
b1f0: 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e 54 T OR REPLACE INT
b200: 4f 20 64 61 73 68 62 6f 61 72 64 73 20 28 70 69 O dashboards (pi
b210: 64 2c 75 73 65 72 6e 61 6d 65 2c 68 6f 73 74 6e d,username,hostn
b220: 61 6d 65 2c 69 70 61 64 64 72 2c 70 6f 72 74 6e ame,ipaddr,portn
b230: 75 6d 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f 2c um) VALUES (?,?,
b240: 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 20 70 69 ?,?,?);").. pi
b250: 64 20 75 73 65 72 6e 61 6d 65 20 68 6f 73 74 6e d username hostn
b260: 61 6d 65 20 69 70 61 64 64 72 20 70 6f 72 74 29 ame ipaddr port)
b270: 0a 20 20 20 20 28 63 6c 6f 73 65 2d 64 61 74 61 . (close-data
b280: 62 61 73 65 20 64 62 29 29 29 0a 0a 3b 3b 20 75 base db)))..;; u
b290: 6e 72 65 67 69 73 74 65 72 20 61 20 6d 6f 6e 69 nregister a moni
b2a0: 74 6f 72 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 tor.;;.(define (
b2b0: 6d 64 64 62 3a 75 6e 72 65 67 69 73 74 65 72 2d mddb:unregister-
b2c0: 64 61 73 68 62 6f 61 72 64 20 68 6f 73 74 20 70 dashboard host p
b2d0: 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 ort). (let* ((d
b2e0: 62 20 20 20 20 20 20 28 6d 64 64 62 3a 6f 70 65 b (mddb:ope
b2f0: 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 70 72 69 n-db))). (pri
b300: 6e 74 20 22 52 65 67 69 73 74 65 72 20 75 6e 72 nt "Register unr
b310: 65 67 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 2c egister monitor,
b320: 20 68 6f 73 74 3a 70 6f 72 74 3d 22 20 68 6f 73 host:port=" hos
b330: 74 20 22 3a 22 20 70 6f 72 74 29 0a 20 20 20 20 t ":" port).
b340: 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 22 44 (exec (sql db "D
b350: 45 4c 45 54 45 20 46 52 4f 4d 20 64 61 73 68 62 ELETE FROM dashb
b360: 6f 61 72 64 73 20 57 48 45 52 45 20 68 6f 73 74 oards WHERE host
b370: 6e 61 6d 65 3d 3f 20 41 4e 44 20 70 6f 72 74 6e name=? AND portn
b380: 75 6d 3d 3f 3b 22 29 20 68 6f 73 74 20 70 6f 72 um=?;") host por
b390: 74 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 64 61 t). (close-da
b3a0: 74 61 62 61 73 65 20 64 62 29 29 29 0a 0a 3b 3b tabase db)))..;;
b3b0: 20 67 65 74 20 72 65 67 69 73 74 65 72 65 64 20 get registered
b3c0: 64 61 73 68 62 6f 61 72 64 73 0a 3b 3b 0a 28 64 dashboards.;;.(d
b3d0: 65 66 69 6e 65 20 28 6d 64 64 62 3a 67 65 74 2d efine (mddb:get-
b3e0: 64 61 73 68 62 6f 61 72 64 73 29 0a 20 20 28 6c dashboards). (l
b3f0: 65 74 20 28 28 64 62 20 28 6d 64 64 62 3a 6f 70 et ((db (mddb:op
b400: 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 71 75 en-db))). (qu
b410: 65 72 79 20 66 65 74 63 68 2d 63 6f 6c 75 6d 6e ery fetch-column
b420: 0a 09 20 20 20 28 73 71 6c 20 64 62 20 22 53 45 .. (sql db "SE
b430: 4c 45 43 54 20 69 70 61 64 64 72 20 7c 7c 20 27 LECT ipaddr || '
b440: 3a 27 20 7c 7c 20 70 6f 72 74 6e 75 6d 20 46 52 :' || portnum FR
b450: 4f 4d 20 64 61 73 68 62 6f 61 72 64 73 3b 22 29 OM dashboards;")
b460: 29 29 29 0a 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d ))). .;;=====
b470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b4b0: 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 20 20 20 =.;; T E S T
b4c0: 4c 20 41 20 55 20 4e 20 43 20 48 20 49 20 4e 20 L A U N C H I N
b4d0: 47 20 20 20 50 20 45 20 52 20 20 20 49 20 54 20 G P E R I T
b4e0: 45 20 4d 20 20 20 57 20 49 20 54 20 48 20 20 20 E M W I T H
b4f0: 48 20 4f 20 53 20 54 20 20 20 54 20 59 20 50 20 H O S T T Y P
b500: 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E S.;;==========
b510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
b550: 0a 3b 3b 20 5b 68 6f 73 74 2d 74 79 70 65 73 5d .;; [host-types]
b560: 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 73 73 68 20 .;; general ssh
b570: 23 7b 67 65 74 62 67 65 73 74 68 6f 73 74 20 67 #{getbgesthost g
b580: 65 6e 65 72 61 6c 7d 0a 3b 3b 20 6e 62 67 65 6e eneral}.;; nbgen
b590: 65 72 61 6c 20 6e 62 6a 6f 62 20 72 75 6e 20 4a eral nbjob run J
b5a0: 4f 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f 67 20 24 OBCOMMAND -log $
b5b0: 4d 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 4d 54 5f MT_LINKTREE/$MT_
b5c0: 54 41 52 47 45 54 2f 24 4d 54 5f 52 55 4e 4e 41 TARGET/$MT_RUNNA
b5d0: 4d 45 2e 24 4d 54 5f 54 45 53 54 4e 41 4d 45 2d ME.$MT_TESTNAME-
b5e0: 24 4d 54 5f 49 54 45 4d 5f 50 41 54 48 2e 6c 67 $MT_ITEM_PATH.lg
b5f0: 6f 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 73 5d o.;; .;; [hosts]
b600: 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 63 75 62 69 .;; general cubi
b610: 61 6e 20 78 65 6e 61 0a 3b 3b 20 0a 3b 3b 20 5b an xena.;; .;; [
b620: 6c 61 75 6e 63 68 65 72 73 5d 0a 3b 3b 20 65 6e launchers].;; en
b630: 76 73 65 74 75 70 20 67 65 6e 65 72 61 6c 0a 3b vsetup general.;
b640: 3b 20 78 6f 72 2f 25 2f 6e 20 34 43 31 36 47 0a ; xor/%/n 4C16G.
b650: 3b 3b 20 25 20 6e 62 67 65 6e 65 72 61 6c 0a 3b ;; % nbgeneral.;
b660: 3b 20 0a 3b 3b 20 5b 6a 6f 62 74 6f 6f 6c 73 5d ; .;; [jobtools]
b670: 0a 3b 3b 20 6c 61 75 6e 63 68 65 72 20 62 73 75 .;; launcher bsu
b680: 62 0a 3b 3b 20 23 20 69 66 20 64 65 66 69 6e 65 b.;; # if define
b690: 64 20 61 6e 64 20 6e 6f 74 20 22 6e 6f 22 20 66 d and not "no" f
b6a0: 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 77 69 lexi-launcher wi
b6b0: 6c 6c 20 62 79 70 61 73 73 20 6c 61 75 6e 63 68 ll bypass launch
b6c0: 65 72 20 75 6e 6c 65 73 73 20 74 68 65 72 65 20 er unless there
b6d0: 69 73 20 6e 6f 0a 3b 3b 20 23 20 6d 61 74 63 68 is no.;; # match
b6e0: 2e 0a 3b 3b 20 66 6c 65 78 69 2d 6c 61 75 6e 63 ..;; flexi-launc
b6f0: 68 65 72 20 79 65 73 20 20 0a 0a 28 64 65 66 69 her yes ..(defi
b700: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c ne (common:get-l
b710: 61 75 6e 63 68 65 72 20 63 6f 6e 66 69 67 64 61 auncher configda
b720: 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 t testname itemp
b730: 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 66 61 ath). (let ((fa
b740: 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 20 llback-launcher
b750: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
b760: 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 6f configdat "jobto
b770: 6f 6c 73 22 20 22 6c 61 75 6e 63 68 65 72 22 29 ols" "launcher")
b780: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
b790: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
b7a0: 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 6f configdat "jobto
b7b0: 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 75 6e ols" "flexi-laun
b7c0: 63 68 65 72 22 29 20 3b 3b 20 6f 76 65 72 72 69 cher") ;; overri
b7d0: 64 65 73 20 6c 61 75 6e 63 68 65 72 0a 09 20 20 des launcher..
b7e0: 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 (not (equal?
b7f0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
b800: 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 6f configdat "jobto
b810: 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 75 6e ols" "flexi-laun
b820: 63 68 65 72 22 29 20 22 6e 6f 22 29 29 29 0a 09 cher") "no")))..
b830: 28 6c 65 74 2a 20 28 28 6c 61 75 6e 63 68 65 72 (let* ((launcher
b840: 73 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d s (hash-
b850: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
b860: 74 20 63 6f 6e 66 69 67 64 61 74 20 22 6c 61 75 t configdat "lau
b870: 6e 63 68 65 72 73 22 20 27 28 29 29 29 29 0a 09 nchers" '())))..
b880: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 61 75 (if (null? lau
b890: 6e 63 68 65 72 73 29 0a 09 20 20 20 20 20 20 66 nchers).. f
b8a0: 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 allback-launcher
b8b0: 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f .. (let loo
b8c0: 70 20 28 28 68 65 64 20 28 63 61 72 20 6c 61 75 p ((hed (car lau
b8d0: 6e 63 68 65 72 73 29 29 0a 09 09 09 20 28 74 61 nchers)).... (ta
b8e0: 6c 20 28 63 64 72 20 6c 61 75 6e 63 68 65 72 73 l (cdr launchers
b8f0: 29 29 29 0a 09 09 28 6c 65 74 20 28 28 70 61 74 )))...(let ((pat
b900: 74 20 20 20 20 20 20 28 63 61 72 20 68 65 64 29 t (car hed)
b910: 29 0a 09 09 20 20 20 20 20 20 28 68 6f 73 74 2d )... (host-
b920: 74 79 70 65 20 28 63 61 64 72 20 68 65 64 29 29 type (cadr hed))
b930: 29 0a 09 09 20 20 28 69 66 20 28 74 65 73 74 73 )... (if (tests
b940: 3a 6d 61 74 63 68 20 70 61 74 74 20 74 65 73 74 :match patt test
b950: 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 09 name itempath)..
b960: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
b970: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e .(debug:print-in
b980: 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 2 *default-lo
b990: 67 2d 70 6f 72 74 2a 20 22 48 61 76 65 20 66 6c g-port* "Have fl
b9a0: 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 6d 61 74 exi-launcher mat
b9b0: 63 68 20 66 6f 72 20 22 20 74 65 73 74 6e 61 6d ch for " testnam
b9c0: 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 20 22 e "/" itempath "
b9d0: 20 3d 20 22 20 68 6f 73 74 2d 74 79 70 65 29 0a = " host-type).
b9e0: 09 09 09 28 6c 65 74 20 28 28 6c 61 75 6e 63 68 ...(let ((launch
b9f0: 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b er (configf:look
ba00: 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 68 6f up configdat "ho
ba10: 73 74 2d 74 79 70 65 73 22 20 68 6f 73 74 2d 74 st-types" host-t
ba20: 79 70 65 29 29 29 0a 09 09 09 20 20 28 69 66 20 ype))).... (if
ba30: 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 20 20 launcher....
ba40: 20 20 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 launcher....
ba50: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 (begin.....(
ba60: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
ba70: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
ba80: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
ba90: 6e 6f 20 6c 61 75 6e 63 68 65 72 20 66 6f 75 6e no launcher foun
baa0: 64 20 66 6f 72 20 68 6f 73 74 2d 74 79 70 65 20 d for host-type
bab0: 22 20 68 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 " host-type)....
bac0: 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 .(if (null? tal)
bad0: 0a 09 09 09 09 20 20 20 20 66 61 6c 6c 62 61 63 ..... fallbac
bae0: 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 09 09 09 20 k-launcher.....
baf0: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
bb00: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
bb10: 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 )... ;; no
bb20: 6d 61 74 63 68 2c 20 74 72 79 20 61 67 61 69 6e match, try again
bb30: 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 ... (if (nu
bb40: 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 66 61 ll? tal).... fa
bb50: 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 0a llback-launcher.
bb60: 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
bb70: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
bb80: 29 29 29 29 0a 09 66 61 6c 6c 62 61 63 6b 2d 6c ))))..fallback-l
bb90: 61 75 6e 63 68 65 72 29 29 29 0a 20 20 0a 3b 3b auncher))). .;;
bba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bbb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bbc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bbd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bbe0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 ======.;; D A S
bbf0: 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 55 20 H B O A R D U
bc00: 53 20 45 20 52 20 20 20 56 20 49 20 45 20 57 20 S E R V I E W
bc10: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
bc20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bc30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bc40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bc50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 ==========..;; f
bc60: 69 72 73 74 20 72 65 61 64 20 7e 2f 76 69 65 77 irst read ~/view
bc70: 73 2e 63 6f 6e 66 69 67 20 69 66 20 69 74 20 65 s.config if it e
bc80: 78 69 73 74 73 2c 20 74 68 65 6e 20 72 65 61 64 xists, then read
bc90: 20 24 4d 54 52 41 48 2f 76 69 65 77 73 2e 63 6f $MTRAH/views.co
bca0: 6e 66 69 67 20 69 66 20 69 74 20 65 78 69 73 74 nfig if it exist
bcb0: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f s.;;.(define (co
bcc0: 6d 6d 6f 6e 3a 6c 6f 61 64 2d 76 69 65 77 73 2d mmon:load-views-
bcd0: 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 config). (let*
bce0: 28 28 76 69 65 77 2d 63 66 67 64 61 74 20 20 20 ((view-cfgdat
bcf0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
bd00: 65 29 29 0a 09 20 28 68 6f 6d 65 2d 63 66 67 66 e)).. (home-cfgf
bd10: 69 6c 65 20 20 20 28 63 6f 6e 63 20 28 67 65 74 ile (conc (get
bd20: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
bd30: 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f iable "HOME") "/
bd40: 2e 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 .mtviews.config"
bd50: 29 29 0a 09 20 28 6d 74 68 6f 6d 65 2d 63 66 67 )).. (mthome-cfg
bd60: 66 69 6c 65 20 28 63 6f 6e 63 20 2a 74 6f 70 70 file (conc *topp
bd70: 61 74 68 2a 20 22 2f 2e 6d 74 76 69 65 77 73 2e ath* "/.mtviews.
bd80: 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 config"))). (
bd90: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
bda0: 20 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 mthome-cfgfile)
bdb0: 0a 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 6d ..(read-config m
bdc0: 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 thome-cfgfile vi
bdd0: 65 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 ew-cfgdat #t)).
bde0: 20 20 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 68 ;; we load th
bdf0: 65 20 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 20 e home dir file
be00: 41 46 54 45 52 20 74 68 65 20 4d 54 52 41 48 20 AFTER the MTRAH
be10: 66 69 6c 65 20 73 6f 20 74 68 65 20 75 73 65 72 file so the user
be20: 20 63 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 74 can clobber set
be30: 74 69 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e 69 tings when runni
be40: 6e 67 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 ng the dashboard
be50: 20 69 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 72 in read-only ar
be60: 65 61 73 0a 20 20 20 20 28 69 66 20 28 66 69 6c eas. (if (fil
be70: 65 2d 65 78 69 73 74 73 3f 20 68 6f 6d 65 2d 63 e-exists? home-c
be80: 66 67 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 fgfile)..(read-c
be90: 6f 6e 66 69 67 20 68 6f 6d 65 2d 63 66 67 66 69 onfig home-cfgfi
bea0: 6c 65 20 76 69 65 77 2d 63 66 67 64 61 74 20 23 le view-cfgdat #
beb0: 74 29 29 0a 20 20 20 20 76 69 65 77 2d 63 66 67 t)). view-cfg
bec0: 64 61 74 29 29 0a 0a dat))..