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 74 79 70 65 64 2d 72 65 63 6f 72 64 73 fo typed-records
0240: 29 0a 28 72 65 71 75 69 72 65 2d 65 78 74 65 6e ).(require-exten
0250: 73 69 6f 6e 20 72 65 67 65 78 20 70 6f 73 69 78 sion regex posix
0260: 29 0a 0a 28 72 65 71 75 69 72 65 2d 65 78 74 65 )..(require-exte
0270: 6e 73 69 6f 6e 20 28 73 72 66 69 20 31 38 29 20 nsion (srfi 18)
0280: 65 78 74 72 61 73 20 74 63 70 20 72 70 63 29 0a extras tcp rpc).
0290: 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 .(import (prefix
02a0: 20 73 71 6c 69 74 65 33 20 73 71 6c 69 74 65 33 sqlite3 sqlite3
02b0: 3a 29 29 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 :)).(import (pre
02c0: 66 69 78 20 62 61 73 65 36 34 20 62 61 73 65 36 fix base64 base6
02d0: 34 3a 29 29 0a 0a 28 64 65 63 6c 61 72 65 20 28 4:))..(declare (
02e0: 75 6e 69 74 20 63 6f 6d 6d 6f 6e 29 29 0a 0a 28 unit common))..(
02f0: 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f include "common_
0300: 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 0a 0a 3b records.scm")..;
0310: 3b 20 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 ; (require-libra
0320: 72 79 20 6d 61 72 67 73 29 0a 3b 3b 20 28 69 6e ry margs).;; (in
0330: 63 6c 75 64 65 20 22 6d 61 72 67 73 2e 73 63 6d clude "margs.scm
0340: 22 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 6f ")..;; (define o
0350: 6c 64 2d 65 78 69 74 20 65 78 69 74 29 0a 3b 3b ld-exit exit).;;
0360: 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 65 78 .;; (define (ex
0370: 69 74 20 2e 20 63 6f 64 65 29 0a 3b 3b 20 20 20 it . code).;;
0380: 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6f 64 65 29 (if (null? code)
0390: 0a 3b 3b 20 20 20 20 20 20 20 28 6f 6c 64 2d 65 .;; (old-e
03a0: 78 69 74 29 0a 3b 3b 20 20 20 20 20 20 20 28 6f xit).;; (o
03b0: 6c 64 2d 65 78 69 74 20 63 6f 64 65 29 29 29 0a ld-exit code))).
03c0: 0a 28 64 65 66 69 6e 65 20 67 65 74 65 6e 76 20 .(define getenv
03d0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
03e0: 76 61 72 69 61 62 6c 65 29 0a 28 64 65 66 69 6e variable).(defin
03f0: 65 20 28 73 61 66 65 2d 73 65 74 65 6e 76 20 6b e (safe-setenv k
0400: 65 79 20 76 61 6c 29 0a 20 20 28 69 66 20 28 61 ey val). (if (a
0410: 6e 64 20 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 nd (string? val)
0420: 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 29 0a 20 (string? key)).
0430: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
0440: 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 65 eptions. e
0450: 78 6e 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 xn. (debug
0460: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
0470: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0480: 2a 20 22 62 61 64 20 76 61 6c 75 65 20 66 6f 72 * "bad value for
0490: 20 73 65 74 65 6e 76 2c 20 6b 65 79 3d 22 20 6b setenv, key=" k
04a0: 65 79 20 22 2c 20 76 61 6c 75 65 3d 22 20 76 61 ey ", value=" va
04b0: 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 65 6e l). (seten
04c0: 76 20 6b 65 79 20 76 61 6c 29 29 0a 20 20 20 20 v key val)).
04d0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
04e0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
04f0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 76 log-port* "bad v
0500: 61 6c 75 65 20 66 6f 72 20 73 65 74 65 6e 76 2c alue for setenv,
0510: 20 6b 65 79 3d 22 20 6b 65 79 20 22 2c 20 76 61 key=" key ", va
0520: 6c 75 65 3d 22 20 76 61 6c 29 29 29 0a 0a 28 64 lue=" val)))..(d
0530: 65 66 69 6e 65 20 68 6f 6d 65 20 28 67 65 74 65 efine home (gete
0540: 6e 76 20 22 48 4f 4d 45 22 29 29 0a 28 64 65 66 nv "HOME")).(def
0550: 69 6e 65 20 75 73 65 72 20 28 67 65 74 65 6e 76 ine user (getenv
0560: 20 22 55 53 45 52 22 29 29 0a 0a 3b 3b 20 47 4c "USER"))..;; GL
0570: 4f 42 41 4c 20 47 4c 45 54 43 48 45 53 0a 0a 28 OBAL GLETCHES..(
0580: 64 65 66 69 6e 65 20 2a 63 6f 6e 74 65 78 74 73 define *contexts
0590: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
05a0: 6c 65 29 29 0a 0a 3b 3b 20 43 6f 6d 6d 6f 6e 20 le))..;; Common
05b0: 64 61 74 61 20 73 74 72 75 63 74 75 72 65 20 66 data structure f
05c0: 6f 72 20 0a 28 64 65 66 73 74 72 75 63 74 20 63 or .(defstruct c
05d0: 78 74 0a 20 20 28 74 61 73 6b 64 62 20 23 66 29 xt. (taskdb #f)
05e0: 0a 20 20 28 63 6d 75 74 65 78 20 28 6d 61 6b 65 . (cmutex (make
05f0: 2d 6d 75 74 65 78 29 29 29 0a 0a 3b 3b 20 73 61 -mutex)))..;; sa
0600: 66 65 20 6d 65 74 68 6f 64 20 66 6f 72 20 61 63 fe method for ac
0610: 63 65 73 73 69 6e 67 20 61 20 63 6f 6e 74 65 78 cessing a contex
0620: 74 20 67 69 76 65 6e 20 61 20 74 6f 70 70 61 74 t given a toppat
0630: 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f h.;;.(define (co
0640: 6d 6d 6f 6e 3a 77 69 74 68 2d 63 78 74 20 74 6f mmon:with-cxt to
0650: 70 70 61 74 68 20 70 72 6f 63 29 0a 20 20 28 6d ppath proc). (m
0660: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 63 6f 6e 74 utex-lock! *cont
0670: 65 78 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 6c ext-mutex*). (l
0680: 65 74 20 28 28 63 78 74 20 28 68 61 73 68 2d 74 et ((cxt (hash-t
0690: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
06a0: 20 2a 63 6f 6e 74 65 78 74 73 2a 20 74 6f 70 70 *contexts* topp
06b0: 61 74 68 20 23 66 29 29 29 0a 20 20 20 20 28 69 ath #f))). (i
06c0: 66 20 28 6e 6f 74 20 63 78 74 29 0a 20 20 20 20 f (not cxt).
06d0: 20 20 20 20 28 73 65 74 21 20 63 78 74 20 28 6c (set! cxt (l
06e0: 65 74 20 28 28 78 20 28 6d 61 6b 65 2d 63 78 74 et ((x (make-cxt
06f0: 29 29 29 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 )))(hash-table-s
0700: 65 74 21 20 2a 63 6f 6e 74 65 78 74 73 2a 20 74 et! *contexts* t
0710: 6f 70 70 61 74 68 20 78 29 20 78 29 29 29 0a 20 oppath x) x))).
0720: 20 20 20 28 6c 65 74 20 28 28 63 78 74 2d 6d 75 (let ((cxt-mu
0730: 74 65 78 20 28 63 78 74 2d 6d 75 74 65 78 20 63 tex (cxt-mutex c
0740: 78 74 29 29 29 0a 20 20 20 20 20 20 28 6d 75 74 xt))). (mut
0750: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 63 6f 6e 74 ex-unlock! *cont
0760: 65 78 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 ext-mutex*).
0770: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 63 (mutex-lock! c
0780: 78 74 2d 6d 75 74 65 78 29 0a 20 20 20 20 20 20 xt-mutex).
0790: 28 6c 65 74 20 28 28 72 65 73 20 28 70 72 6f 63 (let ((res (proc
07a0: 20 63 78 74 29 29 29 0a 20 20 20 20 20 20 20 20 cxt))).
07b0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 63 (mutex-unlock! c
07c0: 78 74 2d 6d 75 74 65 78 29 0a 20 20 20 20 20 20 xt-mutex).
07d0: 20 20 72 65 73 29 29 29 29 0a 20 20 20 20 20 20 res)))).
07e0: 20 20 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6b .(define *db-k
07f0: 65 79 73 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e eys* #f)..(defin
0800: 65 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 20 20 e *configinfo*
0810: 20 23 66 29 20 20 20 3b 3b 20 72 61 77 20 72 65 #f) ;; raw re
0820: 73 75 6c 74 73 20 66 72 6f 6d 20 73 65 74 75 70 sults from setup
0830: 2c 20 69 6e 63 6c 75 64 65 73 20 74 6f 70 70 61 , includes toppa
0840: 74 68 20 61 6e 64 20 74 61 62 6c 65 20 66 72 6f th and table fro
0850: 6d 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 m megatest.confi
0860: 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 63 6f g.(define *runco
0870: 6e 66 69 67 64 61 74 2a 20 23 66 29 20 20 20 3b nfigdat* #f) ;
0880: 3b 20 72 75 6e 20 63 6f 6e 66 69 67 73 20 64 61 ; run configs da
0890: 74 61 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 ta.(define *conf
08a0: 69 67 64 61 74 2a 20 20 20 20 23 66 29 20 20 20 igdat* #f)
08b0: 3b 3b 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 ;; megatest.conf
08c0: 69 67 20 64 61 74 61 0a 28 64 65 66 69 6e 65 20 ig data.(define
08d0: 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 23 *configstatus* #
08e0: 66 29 20 20 20 3b 3b 20 73 74 61 74 75 73 20 6f f) ;; status o
08f0: 66 20 64 61 74 61 3b 20 27 66 75 6c 6c 64 61 74 f data; 'fulldat
0900: 61 20 3a 20 61 6c 6c 20 70 72 6f 63 65 73 73 69 a : all processi
0910: 6e 67 20 64 6f 6e 65 2c 20 23 66 20 3a 20 6e 6f ng done, #f : no
0920: 20 64 61 74 61 20 79 65 74 2c 20 27 70 61 72 74 data yet, 'part
0930: 69 61 6c 64 61 74 61 20 3a 20 70 61 72 74 69 61 ialdata : partia
0940: 6c 20 72 65 61 64 20 64 6f 6e 65 0a 28 64 65 66 l read done.(def
0950: 69 6e 65 20 2a 74 6f 70 70 61 74 68 2a 20 20 20 ine *toppath*
0960: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
0970: 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e already-seen-run
0980: 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 23 66 29 config-info* #f)
0990: 0a 0a 28 64 65 66 69 6e 65 20 2a 77 61 69 74 69 ..(define *waiti
09a0: 6e 67 2d 71 75 65 75 65 2a 20 20 20 20 20 28 6d ng-queue* (m
09b0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
09c0: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 6d .(define *test-m
09d0: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 28 6d 61 eta-updated* (ma
09e0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
09f0: 28 64 65 66 69 6e 65 20 2a 67 6c 6f 62 61 6c 65 (define *globale
0a00: 78 69 74 73 74 61 74 75 73 2a 20 20 30 29 20 3b xitstatus* 0) ;
0a10: 3b 20 61 74 74 65 6d 70 74 20 74 6f 20 77 6f 72 ; attempt to wor
0a20: 6b 20 61 72 6f 75 6e 64 20 70 6f 73 73 69 62 6c k around possibl
0a30: 65 20 74 68 72 65 61 64 20 69 73 73 75 65 73 0a e thread issues.
0a40: 28 64 65 66 69 6e 65 20 2a 70 61 73 73 6e 75 6d (define *passnum
0a50: 2a 20 20 20 20 20 20 20 20 20 20 20 30 29 20 3b * 0) ;
0a60: 3b 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 74 ; when running t
0a70: 72 61 63 6b 20 63 61 6c 6c 73 20 74 6f 20 72 75 rack calls to ru
0a80: 6e 2d 74 65 73 74 73 20 6f 72 20 73 69 6d 69 6c n-tests or simil
0a90: 61 72 0a 28 64 65 66 69 6e 65 20 2a 77 72 69 74 ar.(define *writ
0aa0: 65 2d 66 72 65 71 75 65 6e 63 79 2a 20 20 20 28 e-frequency* (
0ab0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0ac0: 29 20 3b 3b 20 72 75 6e 2d 69 64 20 3d 3e 20 28 ) ;; run-id => (
0ad0: 76 65 63 74 6f 72 20 28 63 75 72 72 65 6e 74 2d vector (current-
0ae0: 73 65 63 6f 6e 64 73 29 20 30 29 29 0a 28 64 65 seconds) 0)).(de
0af0: 66 69 6e 65 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 fine *alt-log-fi
0b00: 6c 65 2a 20 23 66 29 20 20 3b 3b 20 75 73 65 64 le* #f) ;; used
0b10: 20 62 79 20 2d 6c 6f 67 0a 28 64 65 66 69 6e 65 by -log.(define
0b20: 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 *common:denoise
0b30: 2a 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d * (make-hash-
0b40: 74 61 62 6c 65 29 29 20 3b 3b 20 66 6f 72 20 6c table)) ;; for l
0b50: 6f 77 20 6e 6f 69 73 65 20 70 72 69 6e 74 69 6e ow noise printin
0b60: 67 0a 28 64 65 66 69 6e 65 20 2a 64 65 66 61 75 g.(define *defau
0b70: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 63 lt-log-port* (c
0b80: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
0b90: 74 29 29 0a 0a 3b 3b 20 44 41 54 41 42 41 53 45 t))..;; DATABASE
0ba0: 0a 28 64 65 66 69 6e 65 20 2a 64 62 73 74 72 75 .(define *dbstru
0bb0: 63 74 2d 64 62 2a 20 20 23 66 29 0a 28 64 65 66 ct-db* #f).(def
0bc0: 69 6e 65 20 2a 64 62 2d 73 74 61 74 73 2a 20 20 ine *db-stats*
0bd0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
0be0: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
0bf0: 68 61 73 68 20 6f 66 20 76 65 63 74 6f 72 73 20 hash of vectors
0c00: 3c 20 63 6f 75 6e 74 20 64 75 72 61 74 69 6f 6e < count duration
0c10: 2d 74 6f 74 61 6c 20 3e 0a 28 64 65 66 69 6e 65 -total >.(define
0c20: 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 *db-stats-mutex
0c30: 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 * (make-mut
0c40: 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 ex)).(define *db
0c50: 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 20 20 20 20 -sync-mutex*
0c60: 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 (make-mutex))
0c70: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6d 75 6c .(define *db-mul
0c80: 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 20 28 ti-sync-mutex* (
0c90: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 make-mutex)).(de
0ca0: 66 69 6e 65 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 fine *db-local-s
0cb0: 79 6e 63 2a 20 20 20 20 20 20 20 28 6d 61 6b 65 ync* (make
0cc0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
0cd0: 20 75 73 65 64 20 74 6f 20 72 65 63 6f 72 64 20 used to record
0ce0: 6c 61 73 74 20 74 6f 75 63 68 20 6f 66 20 64 62 last touch of db
0cf0: 0a 28 64 65 66 69 6e 65 20 2a 6d 65 67 61 74 65 .(define *megate
0d00: 73 74 2d 64 62 2a 20 20 20 20 20 20 20 20 20 23 st-db* #
0d10: 66 29 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 f).(define *last
0d20: 2d 64 62 2d 61 63 63 65 73 73 2a 20 20 20 20 20 -db-access*
0d30: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
0d40: 73 29 29 20 20 3b 3b 20 75 70 64 61 74 65 20 77 s)) ;; update w
0d50: 68 65 6e 20 64 62 20 69 73 20 61 63 63 65 73 73 hen db is access
0d60: 65 64 20 76 69 61 20 73 65 72 76 65 72 0a 28 64 ed via server.(d
0d70: 65 66 69 6e 65 20 2a 64 62 2d 77 72 69 74 65 2d efine *db-write-
0d80: 61 63 63 65 73 73 2a 20 20 20 20 20 23 74 29 0a access* #t).
0d90: 28 64 65 66 69 6e 65 20 2a 69 6e 6d 65 6d 64 62 (define *inmemdb
0da0: 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 * #f
0db0: 29 0a 28 64 65 66 69 6e 65 20 2a 74 61 73 6b 2d ).(define *task-
0dc0: 64 62 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 db*
0dd0: 23 66 29 20 3b 3b 20 28 76 65 63 74 6f 72 20 64 #f) ;; (vector d
0de0: 62 20 70 61 74 68 2d 74 6f 2d 64 62 29 0a 28 64 b path-to-db).(d
0df0: 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 73 73 efine *db-access
0e00: 2d 61 6c 6c 6f 77 65 64 2a 20 20 20 23 74 29 20 -allowed* #t)
0e10: 3b 3b 20 66 6c 61 67 20 74 6f 20 61 6c 6c 6f 77 ;; flag to allow
0e20: 20 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 20 access.(define
0e30: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
0e40: 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 * (make-mute
0e50: 78 29 29 0a 0a 3b 3b 20 53 45 52 56 45 52 0a 28 x))..;; SERVER.(
0e60: 64 65 66 69 6e 65 20 2a 6d 79 2d 63 6c 69 65 6e define *my-clien
0e70: 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 23 66 29 t-signature* #f)
0e80: 0a 28 64 65 66 69 6e 65 20 2a 74 72 61 6e 73 70 .(define *transp
0e90: 6f 72 74 2d 74 79 70 65 2a 20 20 20 20 27 68 74 ort-type* 'ht
0ea0: 74 70 29 0a 28 64 65 66 69 6e 65 20 2a 74 72 61 tp).(define *tra
0eb0: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 20 20 20 nsport-type*
0ec0: 27 68 74 74 70 29 20 20 20 20 20 20 20 20 20 20 'http)
0ed0: 20 20 20 3b 3b 20 6f 76 65 72 72 69 64 65 20 77 ;; override w
0ee0: 69 74 68 20 5b 73 65 72 76 65 72 5d 20 74 72 61 ith [server] tra
0ef0: 6e 73 70 6f 72 74 20 68 74 74 70 7c 72 70 63 7c nsport http|rpc|
0f00: 6e 6d 73 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 nmsg.(define *ru
0f10: 6e 72 65 6d 6f 74 65 2a 20 20 20 20 20 20 20 20 nremote*
0f20: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0f30: 65 29 29 20 3b 3b 20 69 66 20 73 65 74 20 75 70 e)) ;; if set up
0f40: 20 66 6f 72 20 73 65 72 76 65 72 20 63 6f 6d 6d for server comm
0f50: 75 6e 69 63 61 74 69 6f 6e 20 74 68 69 73 20 77 unication this w
0f60: 69 6c 6c 20 68 6f 6c 64 20 3c 68 6f 73 74 20 70 ill hold <host p
0f70: 6f 72 74 3e 0a 28 64 65 66 69 6e 65 20 2a 6d 61 ort>.(define *ma
0f80: 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 20 20 x-cache-size*
0f90: 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 67 0).(define *log
0fa0: 67 65 64 2d 69 6e 2d 63 6c 69 65 6e 74 73 2a 20 ged-in-clients*
0fb0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
0fc0: 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 6c 69 65 )).(define *clie
0fd0: 6e 74 2d 6e 6f 6e 2d 62 6c 6f 63 6b 69 6e 67 2d nt-non-blocking-
0fe0: 6d 6f 64 65 2a 20 23 66 29 0a 28 64 65 66 69 6e mode* #f).(defin
0ff0: 65 20 2a 73 65 72 76 65 72 2d 69 64 2a 20 20 20 e *server-id*
1000: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
1010: 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 e *server-info*
1020: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
1030: 65 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a e *time-to-exit*
1040: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
1050: 65 20 2a 72 65 63 65 69 76 65 64 2d 72 65 73 70 e *received-resp
1060: 6f 6e 73 65 2a 20 23 66 29 0a 28 64 65 66 69 6e onse* #f).(defin
1070: 65 20 2a 64 65 66 61 75 6c 74 2d 6e 75 6d 74 72 e *default-numtr
1080: 69 65 73 2a 20 20 31 30 29 0a 28 64 65 66 69 6e ies* 10).(defin
1090: 65 20 2a 73 65 72 76 65 72 2d 72 75 6e 2a 20 20 e *server-run*
10a0: 20 20 20 20 20 20 23 74 29 0a 28 64 65 66 69 6e #t).(defin
10b0: 65 20 2a 72 75 6e 2d 69 64 2a 20 20 20 20 20 20 e *run-id*
10c0: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
10d0: 65 20 2a 73 65 72 76 65 72 2d 6b 69 6e 64 2d 72 e *server-kind-r
10e0: 75 6e 2a 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 un* (make-hash
10f0: 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 66 69 6e -table))..(defin
1100: 65 20 2a 74 61 72 67 65 74 2a 20 20 20 20 20 20 e *target*
1110: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
1120: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 -table)) ;; cach
1130: 65 20 74 68 65 20 74 61 72 67 65 74 20 68 65 72 e the target her
1140: 65 3b 20 74 61 72 67 65 74 20 69 73 20 6b 65 79 e; target is key
1150: 76 61 6c 31 2f 6b 65 79 76 61 6c 32 2f 2e 2e 2e val1/keyval2/...
1160: 2f 6b 65 79 76 61 6c 4e 0a 28 64 65 66 69 6e 65 /keyvalN.(define
1170: 20 2a 6b 65 79 73 2a 20 20 20 20 20 20 20 20 20 *keys*
1180: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1190: 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 table)) ;; cache
11a0: 20 74 68 65 20 6b 65 79 73 20 68 65 72 65 0a 28 the keys here.(
11b0: 64 65 66 69 6e 65 20 2a 6b 65 79 76 61 6c 73 2a define *keyvals*
11c0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
11d0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 -hash-table)).(d
11e0: 65 66 69 6e 65 20 2a 74 6f 70 74 65 73 74 2d 70 efine *toptest-p
11f0: 61 74 68 73 2a 20 20 20 20 20 28 6d 61 6b 65 2d aths* (make-
1200: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1210: 63 61 63 68 65 20 74 6f 70 74 65 73 74 20 70 61 cache toptest pa
1220: 74 68 20 73 65 74 74 69 6e 67 73 20 68 65 72 65 th settings here
1230: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 70 .(define *test-p
1240: 61 74 68 73 2a 20 20 20 20 20 20 20 20 28 6d 61 aths* (ma
1250: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1260: 3b 3b 20 63 61 63 68 65 20 74 65 73 74 2d 69 64 ;; cache test-id
1270: 20 74 6f 20 74 65 73 74 20 72 75 6e 20 70 61 74 to test run pat
1280: 68 73 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 hs here.(define
1290: 2a 74 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 *test-ids*
12a0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
12b0: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
12c0: 72 75 6e 2d 69 64 2c 20 74 65 73 74 6e 61 6d 65 run-id, testname
12d0: 2c 20 61 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 , and item-path
12e0: 3d 3e 20 74 65 73 74 2d 69 64 0a 28 64 65 66 69 => test-id.(defi
12f0: 6e 65 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 ne *test-info*
1300: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
1310: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 h-table)) ;; cac
1320: 68 65 20 74 68 65 20 74 65 73 74 20 69 6e 66 6f he the test info
1330: 20 72 65 63 6f 72 64 73 2c 20 75 70 64 61 74 65 records, update
1340: 20 74 68 65 20 73 74 61 74 65 2c 20 73 74 61 74 the state, stat
1350: 75 73 2c 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e us, run_duration
1360: 20 65 74 63 2e 20 66 72 6f 6d 20 74 65 73 74 64 etc. from testd
1370: 61 74 2e 64 62 0a 0a 28 64 65 66 69 6e 65 20 2a at.db..(define *
1380: 72 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 run-info-cache*
1390: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
13a0: 62 6c 65 29 29 20 3b 3b 20 72 75 6e 20 69 6e 66 ble)) ;; run inf
13b0: 6f 20 69 73 20 73 74 61 62 6c 65 2c 20 6e 6f 20 o is stable, no
13c0: 6e 65 65 64 20 74 6f 20 72 65 67 65 74 0a 0a 3b need to reget..;
13d0: 3b 20 41 77 66 75 6c 2e 20 50 6c 65 61 73 65 20 ; Awful. Please
13e0: 46 49 58 4d 45 0a 28 64 65 66 69 6e 65 20 2a 65 FIXME.(define *e
13f0: 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 nv-vars-by-run-i
1400: 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 d* (make-hash-ta
1410: 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 ble)).(define *c
1420: 75 72 72 65 6e 74 2d 72 75 6e 2d 6e 61 6d 65 2a urrent-run-name*
1430: 20 20 20 23 66 29 0a 0a 3b 3b 20 54 65 73 74 63 #f)..;; Testc
1440: 6f 6e 66 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e onfig and runcon
1450: 66 69 67 20 63 61 63 68 65 73 2e 20 0a 28 64 65 fig caches. .(de
1460: 66 69 6e 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 fine *testconfig
1470: 73 2a 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 s* (make-h
1480: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 ash-table)) ;; t
1490: 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 est-name => test
14a0: 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 2a config.(define *
14b0: 72 75 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 runconfigs*
14c0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
14d0: 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 74 20 ble)) ;; target
14e0: 20 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 0a => runconfig.
14f0: 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 63 61 .;; This is a ca
1500: 63 68 65 20 6f 66 20 70 72 65 2d 72 65 71 73 20 che of pre-reqs
1510: 6d 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d 63 61 met, don't re-ca
1520: 6c 63 20 69 6e 20 63 61 73 65 73 20 77 68 65 72 lc in cases wher
1530: 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 73 61 e called with sa
1540: 6d 65 20 70 61 72 61 6d 73 20 6c 65 73 73 20 74 me params less t
1550: 68 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 63 6f han.;; five seco
1560: 6e 64 73 20 61 67 6f 0a 28 64 65 66 69 6e 65 20 nds ago.(define
1570: 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 *pre-reqs-met-ca
1580: 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d che* (make-hash-
1590: 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 table))..;; cach
15a0: 65 20 6f 66 20 76 65 72 62 6f 73 69 74 79 20 67 e of verbosity g
15b0: 69 76 65 6e 20 73 74 72 69 6e 67 0a 3b 3b 0a 28 iven string.;;.(
15c0: 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 define *verbosit
15d0: 79 2d 63 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 y-cache* (make-h
15e0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 ash-table))..(de
15f0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 fine (common:cle
1600: 61 72 2d 63 61 63 68 65 73 29 0a 20 20 28 73 65 ar-caches). (se
1610: 74 21 20 2a 74 61 72 67 65 74 2a 20 20 20 20 20 t! *target*
1620: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1630: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
1640: 74 21 20 2a 6b 65 79 73 2a 20 20 20 20 20 20 20 t! *keys*
1650: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1660: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
1670: 74 21 20 2a 6b 65 79 76 61 6c 73 2a 20 20 20 20 t! *keyvals*
1680: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1690: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
16a0: 74 21 20 2a 74 6f 70 74 65 73 74 2d 70 61 74 68 t! *toptest-path
16b0: 73 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 s* (make-ha
16c0: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
16d0: 74 21 20 2a 74 65 73 74 2d 70 61 74 68 73 2a 20 t! *test-paths*
16e0: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
16f0: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
1700: 74 21 20 2a 74 65 73 74 2d 69 64 73 2a 20 20 20 t! *test-ids*
1710: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1720: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
1730: 74 21 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 t! *test-info*
1740: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1750: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
1760: 74 21 20 2a 72 75 6e 2d 69 6e 66 6f 2d 63 61 63 t! *run-info-cac
1770: 68 65 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 he* (make-ha
1780: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
1790: 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d t! *env-vars-by-
17a0: 72 75 6e 2d 69 64 2a 20 28 6d 61 6b 65 2d 68 61 run-id* (make-ha
17b0: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 65 sh-table)). (se
17c0: 74 21 20 2a 74 65 73 74 2d 69 64 2d 63 61 63 68 t! *test-id-cach
17d0: 65 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 e* (make-ha
17e0: 73 68 2d 74 61 62 6c 65 29 29 29 0a 0a 3b 3b 20 sh-table)))..;;
17f0: 47 65 6e 65 72 69 63 20 73 74 72 69 6e 67 20 64 Generic string d
1800: 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e 65 20 atabase.(define
1810: 73 64 62 3a 71 72 79 20 23 66 29 20 3b 3b 20 28 sdb:qry #f) ;; (
1820: 6d 61 6b 65 2d 73 64 62 3a 71 72 79 29 29 20 3b make-sdb:qry)) ;
1830: 3b 20 20 27 69 6e 69 74 20 23 66 29 0a 3b 3b 20 ; 'init #f).;;
1840: 47 65 6e 65 72 69 63 20 70 61 74 68 20 64 61 74 Generic path dat
1850: 61 62 61 73 65 0a 28 64 65 66 69 6e 65 20 2a 66 abase.(define *f
1860: 64 62 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 db* #f)..(define
1870: 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a 20 28 *last-launch* (
1880: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
1890: 29 20 3b 3b 20 75 73 65 20 66 6f 72 20 74 68 72 ) ;; use for thr
18a0: 6f 74 74 6c 69 6e 67 20 74 68 65 20 6c 61 75 6e ottling the laun
18b0: 63 68 20 72 61 74 65 2e 20 57 6f 75 6c 64 20 62 ch rate. Would b
18c0: 65 20 62 65 74 74 65 72 20 74 6f 20 75 73 65 20 e better to use
18d0: 74 68 65 20 64 62 20 61 6e 64 20 6c 61 73 74 20 the db and last
18e0: 74 69 6d 65 20 6f 66 20 61 20 74 65 73 74 20 69 time of a test i
18f0: 6e 20 4c 41 55 4e 43 48 45 44 20 73 74 61 74 65 n LAUNCHED state
1900: 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ...;;===========
1910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 56 ===========.;; V
1950: 20 45 20 52 20 53 20 49 20 4f 20 4e 0a 3b 3b 3d E R S I O N.;;=
1960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
19a0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
19b0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c 2d common:get-full-
19c0: 76 65 72 73 69 6f 6e 29 0a 20 20 28 63 6f 6e 63 version). (conc
19d0: 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f megatest-versio
19e0: 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 74 2d 66 n "-" megatest-f
19f0: 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a 0a 28 64 ossil-hash))..(d
1a00: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 efine (common:ve
1a10: 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 rsion-signature)
1a20: 0a 20 20 28 63 6f 6e 63 20 6d 65 67 61 74 65 73 . (conc megates
1a30: 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 28 73 t-version "-" (s
1a40: 75 62 73 74 72 69 6e 67 20 6d 65 67 61 74 65 73 ubstring megates
1a50: 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 20 30 20 t-fossil-hash 0
1a60: 34 29 29 29 0a 0a 3b 3b 20 66 72 6f 6d 20 6d 65 4)))..;; from me
1a70: 74 61 64 61 74 20 6c 6f 6f 6b 75 70 20 4d 45 47 tadat lookup MEG
1a80: 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 0a 3b 3b ATEST_VERSION.;;
1a90: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
1aa0: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
1ab0: 72 73 69 6f 6e 29 20 3b 3b 20 52 41 44 54 20 3d rsion) ;; RADT =
1ac0: 3e 20 48 6f 77 20 64 6f 65 73 20 74 68 69 73 20 > How does this
1ad0: 77 6f 72 6b 20 69 6e 20 73 65 6e 64 2d 72 65 63 work in send-rec
1ae0: 65 69 76 65 20 66 75 6e 63 74 69 6f 6e 3f 3f 3b eive function??;
1af0: 20 61 73 73 75 6d 65 20 69 74 20 69 73 20 74 68 assume it is th
1b00: 65 20 76 61 6c 75 65 20 73 61 76 65 64 20 69 6e e value saved in
1b10: 20 73 6f 6d 65 20 44 42 0a 20 20 28 72 6d 74 3a some DB. (rmt:
1b20: 67 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 53 get-var "MEGATES
1b30: 54 5f 56 45 52 53 49 4f 4e 22 29 29 0a 0a 28 64 T_VERSION"))..(d
1b40: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
1b50: 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 t-last-run-versi
1b60: 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 20 28 73 74 on-number). (st
1b70: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 20 20 ring->number .
1b80: 20 28 73 75 62 73 74 72 69 6e 67 20 28 63 6f 6d (substring (com
1b90: 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e mon:get-last-run
1ba0: 2d 76 65 72 73 69 6f 6e 29 20 30 20 36 29 29 29 -version) 0 6)))
1bb0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
1bc0: 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:set-last-run-v
1bd0: 65 72 73 69 6f 6e 29 0a 20 20 28 72 6d 74 3a 73 ersion). (rmt:s
1be0: 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 53 54 et-var "MEGATEST
1bf0: 5f 56 45 52 53 49 4f 4e 22 20 28 63 6f 6d 6d 6f _VERSION" (commo
1c00: 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 n:version-signat
1c10: 75 72 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ure)))..(define
1c20: 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d (common:version-
1c30: 63 68 61 6e 67 65 64 3f 29 0a 20 20 28 6e 6f 74 changed?). (not
1c40: 20 28 65 71 75 61 6c 3f 20 28 63 6f 6d 6d 6f 6e (equal? (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 0a 09 20 20 20 20 20 20 20 28 rsion).. (
1c70: 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 common:version-s
1c80: 69 67 6e 61 74 75 72 65 29 29 29 29 0a 0a 3b 3b ignature))))..;;
1c90: 20 4d 6f 76 65 20 6d 65 20 65 6c 73 65 77 68 65 Move me elsewhe
1ca0: 72 65 20 2e 2e 2e 0a 3b 3b 20 52 41 44 54 20 3d re ....;; RADT =
1cb0: 3e 20 57 68 79 20 64 6f 20 77 65 20 6d 65 65 64 > Why do we meed
1cc0: 20 74 68 65 20 76 65 72 73 69 6f 6e 20 63 68 65 the version che
1cd0: 63 6b 20 68 65 72 65 2c 20 74 68 69 73 20 69 73 ck here, this is
1ce0: 20 63 61 6c 6c 65 64 20 6f 6e 6c 79 20 69 66 20 called only if
1cf0: 76 65 72 73 69 6f 6e 20 6d 69 73 6d 61 0a 3b 3b version misma.;;
1d00: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
1d10: 3a 63 6c 65 61 6e 75 70 2d 64 62 29 0a 20 20 28 :cleanup-db). (
1d20: 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 db:multi-db-sync
1d30: 20 0a 20 20 20 23 66 20 3b 3b 20 64 6f 20 61 6c . #f ;; do al
1d40: 6c 20 72 75 6e 2d 69 64 73 0a 20 20 20 3b 3b 20 l run-ids. ;;
1d50: 27 6e 65 77 32 6f 6c 64 0a 20 20 20 27 6b 69 6c 'new2old. 'kil
1d60: 6c 73 65 72 76 65 72 73 0a 20 20 20 27 64 65 6a lservers. 'dej
1d70: 75 6e 6b 0a 20 20 20 3b 3b 20 27 61 64 6a 2d 74 unk. ;; 'adj-t
1d80: 65 73 74 69 64 73 0a 20 20 20 3b 3b 20 27 6f 6c estids. ;; 'ol
1d90: 64 32 6e 65 77 0a 20 20 20 27 6e 65 77 32 6f 6c d2new. 'new2ol
1da0: 64 29 0a 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e d). (if (common
1db0: 3a 76 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 :version-changed
1dc0: 3f 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e ?). (common
1dd0: 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :set-last-run-ve
1de0: 72 73 69 6f 6e 29 29 29 0a 0a 3b 3b 20 46 6f 72 rsion)))..;; For
1df0: 63 65 20 61 20 6d 65 67 61 74 65 73 74 20 63 6c ce a megatest cl
1e00: 65 61 6e 75 70 2d 64 62 20 69 66 20 76 65 72 73 eanup-db if vers
1e10: 69 6f 6e 20 69 73 20 63 68 61 6e 67 65 64 20 61 ion is changed a
1e20: 6e 64 20 73 6b 69 70 2d 76 65 72 73 69 6f 6e 2d nd skip-version-
1e30: 63 68 65 63 6b 20 6e 6f 74 20 73 70 65 63 69 66 check not specif
1e40: 69 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ied.;;.(define (
1e50: 63 6f 6d 6d 6f 6e 3a 65 78 69 74 2d 6f 6e 2d 76 common:exit-on-v
1e60: 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 29 0a ersion-changed).
1e70: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 (if (common:ve
1e80: 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a rsion-changed?).
1e90: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6d 74 63 (let ((mtc
1ea0: 6f 6e 66 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 onf (conc (get-e
1eb0: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
1ec0: 62 6c 65 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 ble "MT_RUN_AREA
1ed0: 5f 48 4f 4d 45 22 29 20 22 2f 6d 65 67 61 74 65 _HOME") "/megate
1ee0: 73 74 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 st.config"))).
1ef0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
1f00: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
1f10: 67 2d 70 6f 72 74 2a 0a 09 09 20 20 20 20 20 22 g-port*... "
1f20: 57 41 52 4e 49 4e 47 3a 20 56 65 72 73 69 6f 6e WARNING: Version
1f30: 20 6d 69 73 6d 61 74 63 68 21 5c 6e 22 0a 09 09 mismatch!\n"...
1f40: 20 20 20 20 20 22 20 20 20 65 78 70 65 63 74 65 " expecte
1f50: 64 3a 20 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 d: " (common:ver
1f60: 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 20 sion-signature)
1f70: 22 5c 6e 22 0a 09 09 20 20 20 20 20 22 20 20 20 "\n"... "
1f80: 67 6f 74 3a 20 20 20 20 20 20 22 20 28 63 6f 6d got: " (com
1f90: 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e mon:get-last-run
1fa0: 2d 76 65 72 73 69 6f 6e 29 29 0a 09 28 69 66 20 -version))..(if
1fb0: 28 61 6e 64 20 28 66 69 6c 65 2d 65 78 69 73 74 (and (file-exist
1fc0: 73 3f 20 6d 74 63 6f 6e 66 29 0a 09 09 20 28 65 s? mtconf)... (e
1fd0: 71 3f 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 q? (current-user
1fe0: 2d 69 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 -id)(file-owner
1ff0: 6d 74 63 6f 6e 66 29 29 29 20 3b 3b 20 73 61 66 mtconf))) ;; saf
2000: 65 20 74 6f 20 72 75 6e 20 2d 63 6c 65 61 6e 75 e to run -cleanu
2010: 70 2d 64 62 0a 09 20 20 20 20 28 62 65 67 69 6e p-db.. (begin
2020: 0a 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
2030: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2040: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 49 20 log-port* " I
2050: 73 65 65 20 79 6f 75 20 61 72 65 20 74 68 65 20 see you are the
2060: 6f 77 6e 65 72 20 6f 66 20 6d 65 67 61 74 65 73 owner of megates
2070: 74 2e 63 6f 6e 66 69 67 2c 20 61 74 74 65 6d 70 t.config, attemp
2080: 74 69 6e 67 20 74 6f 20 63 6c 65 61 6e 75 70 20 ting to cleanup
2090: 61 6e 64 20 72 65 73 65 74 20 74 6f 20 6e 65 77 and reset to new
20a0: 20 76 65 72 73 69 6f 6e 22 29 0a 09 20 20 20 20 version")..
20b0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
20c0: 69 6f 6e 73 0a 09 20 20 20 20 20 20 20 65 78 6e ions.. exn
20d0: 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
20e0: 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 .. (debug:print
20f0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2100: 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 ort* "Failed to
2110: 73 77 69 74 63 68 20 76 65 72 73 69 6f 6e 73 2e switch versions.
2120: 22 29 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 ")... (debug:pri
2130: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2140: 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 g-port* " messag
2150: 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e e: " ((condition
2160: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
2170: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
2180: 29 20 65 78 6e 29 29 0a 09 09 20 28 70 72 69 6e ) exn))... (prin
2190: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
21a0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
21b0: 29 29 0a 09 09 20 28 65 78 69 74 20 31 29 29 0a ))... (exit 1)).
21c0: 09 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a . (common:
21d0: 63 6c 65 61 6e 75 70 2d 64 62 29 29 29 0a 09 20 cleanup-db)))..
21e0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
21f0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2200: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2210: 74 2a 20 22 20 74 6f 20 73 77 69 74 63 68 20 76 t* " to switch v
2220: 65 72 73 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 ersions you can
2230: 72 75 6e 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 run: \"megatest
2240: 2d 63 6c 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a -cleanup-db\"").
2250: 09 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 . (exit 1))
2260: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
2270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b ==============.;
22b0: 3b 20 53 20 50 20 41 20 52 20 53 20 45 20 20 20 ; S P A R S E
22c0: 41 20 52 20 52 20 41 20 59 20 53 0a 3b 3b 3d 3d A R R A Y S.;;==
22d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
22f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2310: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d ====..(define (m
2320: 61 6b 65 2d 73 70 61 72 73 65 2d 61 72 72 61 79 ake-sparse-array
2330: 29 0a 20 20 28 6c 65 74 20 28 28 61 20 28 6d 61 ). (let ((a (ma
2340: 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 ke-sparse-vector
2350: 29 29 29 0a 20 20 20 20 28 73 70 61 72 73 65 2d ))). (sparse-
2360: 76 65 63 74 6f 72 2d 73 65 74 21 20 61 20 30 20 vector-set! a 0
2370: 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 (make-sparse-vec
2380: 74 6f 72 29 29 0a 20 20 20 20 61 29 29 0a 0a 28 tor)). a))..(
2390: 64 65 66 69 6e 65 20 28 73 70 61 72 73 65 2d 61 define (sparse-a
23a0: 72 72 61 79 3f 20 61 29 0a 20 20 28 61 6e 64 20 rray? a). (and
23b0: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 3f 20 (sparse-vector?
23c0: 61 29 0a 20 20 20 20 20 20 20 28 73 70 61 72 73 a). (spars
23d0: 65 2d 76 65 63 74 6f 72 3f 20 28 73 70 61 72 73 e-vector? (spars
23e0: 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 30 e-vector-ref a 0
23f0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 ))))..(define (s
2400: 70 61 72 73 65 2d 61 72 72 61 79 2d 72 65 66 20 parse-array-ref
2410: 61 20 78 20 79 29 0a 20 20 28 6c 65 74 20 28 28 a x y). (let ((
2420: 72 6f 77 20 28 73 70 61 72 73 65 2d 76 65 63 74 row (sparse-vect
2430: 6f 72 2d 72 65 66 20 61 20 78 29 29 29 0a 20 20 or-ref a x))).
2440: 20 20 28 69 66 20 72 6f 77 0a 09 28 73 70 61 72 (if row..(spar
2450: 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 72 6f se-vector-ref ro
2460: 77 20 79 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 w y)..#f)))..(de
2470: 66 69 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 fine (sparse-arr
2480: 61 79 2d 73 65 74 21 20 61 20 78 20 79 20 76 61 ay-set! a x y va
2490: 6c 29 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 l). (let ((row
24a0: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 (sparse-vector-r
24b0: 65 66 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 ef a x))). (i
24c0: 66 20 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 f row..(sparse-v
24d0: 65 63 74 6f 72 2d 73 65 74 21 20 72 6f 77 20 79 ector-set! row y
24e0: 20 76 61 6c 29 0a 09 28 6c 65 74 20 28 28 6e 65 val)..(let ((ne
24f0: 77 2d 72 6f 77 20 28 6d 61 6b 65 2d 73 70 61 72 w-row (make-spar
2500: 73 65 2d 76 65 63 74 6f 72 29 29 29 0a 09 20 20 se-vector)))..
2510: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 (sparse-vector-s
2520: 65 74 21 20 61 20 78 20 6e 65 77 2d 72 6f 77 29 et! a x new-row)
2530: 0a 09 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 .. (sparse-vect
2540: 6f 72 2d 73 65 74 21 20 6e 65 77 2d 72 6f 77 20 or-set! new-row
2550: 79 20 76 61 6c 29 29 29 29 29 0a 0a 3b 3b 3d 3d y val)))))..;;==
2560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25a0: 3d 3d 3d 3d 0a 3b 3b 20 4c 20 4f 20 43 20 4b 20 ====.;; L O C K
25b0: 45 20 52 20 53 20 20 20 41 20 4e 20 44 20 20 20 E R S A N D
25c0: 42 20 4c 20 4f 20 43 20 4b 20 45 20 52 20 53 20 B L O C K E R S
25d0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
25e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 62 6c =========..;; bl
2620: 6f 63 6b 20 66 75 72 74 68 65 72 20 61 63 63 65 ock further acce
2630: 73 73 65 73 20 74 6f 20 64 61 74 61 62 61 73 65 sses to database
2640: 73 2e 20 43 61 6c 6c 20 74 68 69 73 20 62 65 66 s. Call this bef
2650: 6f 72 65 20 73 68 75 74 74 69 6e 67 20 64 62 20 ore shutting db
2660: 64 6f 77 6e 0a 28 64 65 66 69 6e 65 20 28 63 6f down.(define (co
2670: 6d 6d 6f 6e 3a 64 62 2d 62 6c 6f 63 6b 2d 66 75 mmon:db-block-fu
2680: 72 74 68 65 72 2d 71 75 65 72 69 65 73 29 0a 20 rther-queries).
2690: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 (mutex-lock! *d
26a0: 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 b-access-mutex*)
26b0: 0a 20 20 28 73 65 74 21 20 2a 64 62 2d 61 63 63 . (set! *db-acc
26c0: 65 73 73 2d 61 6c 6c 6f 77 65 64 2a 20 23 66 29 ess-allowed* #f)
26d0: 0a 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b . (mutex-unlock
26e0: 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 ! *db-access-mut
26f0: 65 78 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ex*))..(define (
2700: 63 6f 6d 6d 6f 6e 3a 64 62 2d 61 63 63 65 73 73 common:db-access
2710: 2d 61 6c 6c 6f 77 65 64 3f 29 0a 20 20 28 6c 65 -allowed?). (le
2720: 74 20 28 28 76 61 6c 20 28 62 65 67 69 6e 0a 09 t ((val (begin..
2730: 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f (mutex-lo
2740: 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d ck! *db-access-m
2750: 75 74 65 78 2a 29 0a 09 20 20 20 20 20 20 20 2a utex*).. *
2760: 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 db-access-allowe
2770: 64 2a 0a 09 20 20 20 20 20 20 20 28 6d 75 74 65 d*.. (mute
2780: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 x-unlock! *db-ac
2790: 63 65 73 73 2d 6d 75 74 65 78 2a 29 29 29 29 0a cess-mutex*)))).
27a0: 20 20 20 20 76 61 6c 29 29 0a 0a 3b 3b 3d 3d 3d val))..;;===
27b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27f0: 3d 3d 3d 0a 3b 3b 20 55 20 53 20 45 20 46 20 55 ===.;; U S E F U
2800: 20 4c 20 20 20 53 20 54 20 55 20 46 20 46 0a 3b L S T U F F.;
2810: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
2820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2850: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 =======..;; conv
2860: 65 72 74 20 74 68 69 6e 67 73 20 74 6f 20 61 6e ert things to an
2870: 20 61 6c 69 73 74 20 6f 72 20 61 73 73 6f 63 20 alist or assoc
2880: 6c 69 73 74 2c 20 23 66 20 67 65 74 73 20 63 6f list, #f gets co
2890: 6e 76 65 72 74 65 64 20 74 6f 20 22 22 0a 3b 3b nverted to "".;;
28a0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
28b0: 3a 74 6f 2d 61 6c 69 73 74 20 64 61 74 29 0a 20 :to-alist dat).
28c0: 20 28 63 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 (cond. ((list
28d0: 3f 20 64 61 74 29 20 20 20 28 6d 61 70 20 63 6f ? dat) (map co
28e0: 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 64 61 mmon:to-alist da
28f0: 74 29 29 0a 20 20 20 28 28 76 65 63 74 6f 72 3f t)). ((vector?
2900: 20 64 61 74 29 0a 20 20 20 20 28 6d 61 70 20 63 dat). (map c
2910: 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 ommon:to-alist (
2920: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 64 61 74 vector->list dat
2930: 29 29 29 0a 20 20 20 28 28 70 61 69 72 3f 20 64 ))). ((pair? d
2940: 61 74 29 0a 20 20 20 20 28 63 6f 6e 73 20 28 63 at). (cons (c
2950: 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 ommon:to-alist (
2960: 63 61 72 20 64 61 74 29 29 0a 09 20 20 28 63 6f car dat)).. (co
2970: 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 mmon:to-alist (c
2980: 64 72 20 64 61 74 29 29 29 29 0a 20 20 20 28 28 dr dat)))). ((
2990: 68 61 73 68 2d 74 61 62 6c 65 3f 20 64 61 74 29 hash-table? dat)
29a0: 0a 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e . (map common
29b0: 3a 74 6f 2d 61 6c 69 73 74 20 28 68 61 73 68 2d :to-alist (hash-
29c0: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 64 61 74 table->alist dat
29d0: 29 29 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 ))). (else.
29e0: 20 28 69 66 20 64 61 74 0a 09 64 61 74 0a 09 22 (if dat..dat.."
29f0: 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 "))))..(define (
2a00: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
2a10: 2d 70 72 69 6e 74 20 77 61 69 74 76 61 6c 20 2e -print waitval .
2a20: 20 6b 65 79 73 29 0a 20 20 28 6c 65 74 2a 20 28 keys). (let* (
2a30: 28 6b 65 79 20 20 20 20 20 20 28 73 74 72 69 6e (key (strin
2a40: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d g-intersperse (m
2a50: 61 70 20 63 6f 6e 63 20 6b 65 79 73 29 20 22 2d ap conc keys) "-
2a60: 22 20 29 29 0a 09 20 28 6c 61 73 74 74 69 6d 65 " )).. (lasttime
2a70: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
2a80: 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6d 6d 6f 6e /default *common
2a90: 3a 64 65 6e 6f 69 73 65 2a 20 6b 65 79 20 30 29 :denoise* key 0)
2aa0: 29 0a 09 20 28 63 75 72 72 74 69 6d 65 20 28 63 ).. (currtime (c
2ab0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
2ac0: 29 0a 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 ). (if (> (-
2ad0: 63 75 72 72 74 69 6d 65 20 6c 61 73 74 74 69 6d currtime lasttim
2ae0: 65 29 20 77 61 69 74 76 61 6c 29 0a 09 28 62 65 e) waitval)..(be
2af0: 67 69 6e 0a 09 20 20 28 68 61 73 68 2d 74 61 62 gin.. (hash-tab
2b00: 6c 65 2d 73 65 74 21 20 2a 63 6f 6d 6d 6f 6e 3a le-set! *common:
2b10: 64 65 6e 6f 69 73 65 2a 20 6b 65 79 20 63 75 72 denoise* key cur
2b20: 72 74 69 6d 65 29 0a 09 20 20 23 74 29 0a 09 23 rtime).. #t)..#
2b30: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 f)))..(define (c
2b40: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 ommon:get-megate
2b50: 73 74 2d 65 78 65 29 0a 20 20 28 6f 72 20 28 67 st-exe). (or (g
2b60: 65 74 65 6e 76 20 22 4d 54 5f 4d 45 47 41 54 45 etenv "MT_MEGATE
2b70: 53 54 22 29 20 22 6d 65 67 61 74 65 73 74 22 29 ST") "megatest")
2b80: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
2b90: 6f 6e 3a 72 65 61 64 2d 65 6e 63 6f 64 65 64 2d on:read-encoded-
2ba0: 73 74 72 69 6e 67 20 69 6e 73 74 72 29 0a 20 20 string instr).
2bb0: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
2bc0: 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 68 61 ns. exn. (ha
2bd0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
2be0: 20 20 20 20 65 78 6e 0a 20 20 20 20 28 62 65 67 exn. (beg
2bf0: 69 6e 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a in. (debug:
2c00: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
2c10: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2c20: 20 22 72 65 63 65 69 76 65 64 20 62 61 64 20 65 "received bad e
2c30: 6e 63 6f 64 65 64 20 73 74 72 69 6e 67 20 5c 22 ncoded string \"
2c40: 22 20 69 6e 73 74 72 20 22 5c 22 2c 20 6d 65 73 " instr "\", mes
2c50: 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 sage: " ((condit
2c60: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
2c70: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
2c80: 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 age) exn)).
2c90: 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 (print-call-cha
2ca0: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
2cb0: 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 20 23 r-port)). #
2cc0: 66 29 0a 20 20 20 20 28 72 65 61 64 20 28 6f 70 f). (read (op
2cd0: 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 en-input-string
2ce0: 28 62 61 73 65 36 34 3a 62 61 73 65 36 34 2d 64 (base64:base64-d
2cf0: 65 63 6f 64 65 20 69 6e 73 74 72 29 29 29 29 0a ecode instr)))).
2d00: 20 20 20 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 (read (open-i
2d10: 6e 70 75 74 2d 73 74 72 69 6e 67 20 28 7a 33 3a nput-string (z3:
2d20: 64 65 63 6f 64 65 2d 62 75 66 66 65 72 20 28 62 decode-buffer (b
2d30: 61 73 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 ase64:base64-dec
2d40: 6f 64 65 20 69 6e 73 74 72 29 29 29 29 29 29 0a ode instr)))))).
2d50: 0a 3b 3b 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 .;; dot-locking
2d60: 65 67 67 20 73 65 65 6d 73 20 6e 6f 74 20 74 6f egg seems not to
2d70: 20 77 6f 72 6b 2c 20 75 73 69 6e 67 20 74 68 69 work, using thi
2d80: 73 20 66 6f 72 20 6e 6f 77 0a 3b 3b 20 69 66 20 s for now.;; if
2d90: 6c 6f 63 6b 20 69 73 20 6f 6c 64 65 72 20 74 68 lock is older th
2da0: 61 6e 20 65 78 70 69 72 65 2d 74 69 6d 65 20 74 an expire-time t
2db0: 68 65 6e 20 72 65 6d 6f 76 65 20 69 74 20 61 6e hen remove it an
2dc0: 64 20 74 72 79 20 61 67 61 69 6e 0a 3b 3b 20 74 d try again.;; t
2dd0: 6f 20 67 65 74 20 74 68 65 20 6c 6f 63 6b 0a 3b o get the lock.;
2de0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2df0: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f n:simple-file-lo
2e00: 63 6b 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 ck fname #!key (
2e10: 65 78 70 69 72 65 2d 74 69 6d 65 20 33 30 30 29 expire-time 300)
2e20: 29 0a 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 ). (if (file-ex
2e30: 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 20 20 20 ists? fname).
2e40: 20 20 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 (if (> (- (cu
2e50: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 rrent-seconds)(f
2e60: 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e ile-modification
2e70: 2d 74 69 6d 65 20 66 6e 61 6d 65 29 29 20 65 78 -time fname)) ex
2e80: 70 69 72 65 2d 74 69 6d 65 29 0a 09 20 20 28 62 pire-time).. (b
2e90: 65 67 69 6e 0a 09 20 20 20 20 28 64 65 6c 65 74 egin.. (delet
2ea0: 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 29 0a 09 e-file* fname)..
2eb0: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 (common:simp
2ec0: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 le-file-lock fna
2ed0: 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 me expire-time:
2ee0: 65 78 70 69 72 65 2d 74 69 6d 65 29 29 0a 09 20 expire-time))..
2ef0: 20 23 66 29 0a 20 20 20 20 20 20 28 6c 65 74 20 #f). (let
2f00: 28 28 6b 65 79 2d 73 74 72 69 6e 67 20 28 63 6f ((key-string (co
2f10: 6e 63 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d nc (get-host-nam
2f20: 65 29 20 22 2d 22 20 28 63 75 72 72 65 6e 74 2d e) "-" (current-
2f30: 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 0a 09 process-id))))..
2f40: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
2f50: 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 28 6c file fname.. (l
2f60: 61 6d 62 64 61 20 28 29 0a 09 20 20 20 20 28 70 ambda ().. (p
2f70: 72 69 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 rint key-string)
2f80: 29 29 0a 09 28 74 68 72 65 61 64 2d 73 6c 65 65 ))..(thread-slee
2f90: 70 21 20 30 2e 32 35 29 0a 09 28 69 66 20 28 66 p! 0.25)..(if (f
2fa0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d ile-exists? fnam
2fb0: 65 29 0a 09 20 20 20 20 28 77 69 74 68 2d 69 6e e).. (with-in
2fc0: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e put-from-file fn
2fd0: 61 6d 65 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 ame.. (lamb
2fe0: 64 61 20 28 29 0a 09 09 28 65 71 75 61 6c 3f 20 da ()...(equal?
2ff0: 6b 65 79 2d 73 74 72 69 6e 67 20 28 72 65 61 64 key-string (read
3000: 2d 6c 69 6e 65 29 29 29 29 0a 09 20 20 20 20 23 -line)))).. #
3010: 66 29 29 29 29 0a 09 0a 28 64 65 66 69 6e 65 20 f))))...(define
3020: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
3030: 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b ile-release-lock
3040: 20 66 6e 61 6d 65 29 0a 20 20 28 64 65 6c 65 74 fname). (delet
3050: 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 0a e-file* fname)).
3060: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 53 20 54 =========.;; S T
30b0: 20 41 20 54 20 45 20 53 20 20 20 41 20 4e 20 44 A T E S A N D
30c0: 20 20 20 53 20 54 20 41 20 54 20 55 20 53 20 45 S T A T U S E
30d0: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
30e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
30f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
3120: 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 fine *common:std
3130: 2d 73 74 61 74 65 73 2a 20 20 20 0a 20 20 27 28 -states* . '(
3140: 28 30 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a (0 "COMPLETED").
3150: 20 20 20 20 28 31 20 22 4e 4f 54 5f 53 54 41 52 (1 "NOT_STAR
3160: 54 45 44 22 29 0a 20 20 20 20 28 32 20 22 52 55 TED"). (2 "RU
3170: 4e 4e 49 4e 47 22 29 0a 20 20 20 20 28 33 20 22 NNING"). (3 "
3180: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 REMOTEHOSTSTART"
3190: 29 0a 20 20 20 20 28 34 20 22 4c 41 55 4e 43 48 ). (4 "LAUNCH
31a0: 45 44 22 29 0a 20 20 20 20 28 35 20 22 4b 49 4c ED"). (5 "KIL
31b0: 4c 45 44 22 29 0a 20 20 20 20 28 36 20 22 4b 49 LED"). (6 "KI
31c0: 4c 4c 52 45 51 22 29 0a 20 20 20 20 28 37 20 22 LLREQ"). (7 "
31d0: 53 54 55 43 4b 22 29 0a 20 20 20 20 28 38 20 22 STUCK"). (8 "
31e0: 41 52 43 48 49 56 45 44 22 29 29 29 0a 0a 28 64 ARCHIVED")))..(d
31f0: 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 efine *common:st
3200: 64 2d 73 74 61 74 75 73 65 73 2a 0a 20 20 27 28 d-statuses*. '(
3210: 28 30 20 22 50 41 53 53 22 29 0a 20 20 20 20 28 (0 "PASS"). (
3220: 31 20 22 57 41 52 4e 22 29 0a 20 20 20 20 28 32 1 "WARN"). (2
3230: 20 22 46 41 49 4c 22 29 0a 20 20 20 20 28 33 20 "FAIL"). (3
3240: 22 43 48 45 43 4b 22 29 0a 20 20 20 20 28 34 20 "CHECK"). (4
3250: 22 6e 2f 61 22 29 0a 20 20 20 20 28 35 20 22 57 "n/a"). (5 "W
3260: 41 49 56 45 44 22 29 0a 20 20 20 20 28 36 20 22 AIVED"). (6 "
3270: 53 4b 49 50 22 29 0a 20 20 20 20 28 37 20 22 44 SKIP"). (7 "D
3280: 45 4c 45 54 45 44 22 29 0a 20 20 20 20 28 38 20 ELETED"). (8
3290: 22 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 20 20 "STUCK/DEAD").
32a0: 20 20 28 39 20 22 41 42 4f 52 54 22 29 29 29 0a (9 "ABORT"))).
32b0: 0a 3b 3b 20 54 68 65 73 65 20 61 72 65 20 73 74 .;; These are st
32c0: 6f 70 70 69 6e 67 20 63 6f 6e 64 69 74 69 6f 6e opping condition
32d0: 73 20 74 68 61 74 20 70 72 65 76 65 6e 74 20 61 s that prevent a
32e0: 20 74 65 73 74 20 66 72 6f 6d 20 62 65 69 6e 67 test from being
32f0: 20 72 75 6e 0a 28 64 65 66 69 6e 65 20 2a 63 6f run.(define *co
3300: 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 mmon:cant-run-st
3310: 61 74 65 73 2d 73 79 6d 2a 20 0a 20 20 27 28 43 ates-sym* . '(C
3320: 4f 4d 50 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 OMPLETED KILLED
3330: 57 41 49 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 WAIVED UNKNOWN I
3340: 4e 43 4f 4d 50 4c 45 54 45 20 41 42 4f 52 54 20 NCOMPLETE ABORT
3350: 41 52 43 48 49 56 45 44 29 29 0a 0a 3b 3b 3d 3d ARCHIVED))..;;==
3360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33a0: 3d 3d 3d 3d 0a 3b 3b 20 44 20 45 20 42 20 55 20 ====.;; D E B U
33b0: 47 20 47 20 49 20 4e 20 47 20 20 20 53 20 54 20 G G I N G S T
33c0: 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d U F F .;;=======
33d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3410: 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 .(define *verbos
3420: 69 74 79 2a 20 20 20 20 20 20 20 20 20 31 29 0a ity* 1).
3430: 28 64 65 66 69 6e 65 20 2a 6c 6f 67 67 69 6e 67 (define *logging
3440: 2a 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a * #f).
3450: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 77 69 .(define (get-wi
3460: 74 68 2d 64 65 66 61 75 6c 74 20 76 61 6c 20 64 th-default val d
3470: 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 efault). (let (
3480: 28 76 61 6c 20 28 61 72 67 73 3a 67 65 74 2d 61 (val (args:get-a
3490: 72 67 20 76 61 6c 29 29 29 0a 20 20 20 20 28 69 rg val))). (i
34a0: 66 20 76 61 6c 20 76 61 6c 20 64 65 66 61 75 6c f val val defaul
34b0: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 t)))..(define (a
34c0: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 6b 65 79 ssoc/default key
34d0: 20 6c 73 74 20 2e 20 64 65 66 61 75 6c 74 29 0a lst . default).
34e0: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 61 73 (let ((res (as
34f0: 73 6f 63 20 6b 65 79 20 6c 73 74 29 29 29 0a 20 soc key lst))).
3500: 20 20 20 28 69 66 20 72 65 73 20 28 63 61 64 72 (if res (cadr
3510: 20 72 65 73 29 28 69 66 20 28 6e 75 6c 6c 3f 20 res)(if (null?
3520: 64 65 66 61 75 6c 74 29 20 23 66 20 28 63 61 72 default) #f (car
3530: 20 64 65 66 61 75 6c 74 29 29 29 29 29 0a 0a 28 default)))))..(
3540: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
3550: 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d et-testsuite-nam
3560: 65 29 0a 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 e). (or (config
3570: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
3580: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 74 65 dat* "setup" "te
3590: 73 74 73 75 69 74 65 22 20 29 0a 20 20 20 20 20 stsuite" ).
35a0: 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 0a (if *toppath* .
35b0: 20 20 20 20 20 20 20 20 20 20 28 70 61 74 68 6e (pathn
35c0: 61 6d 65 2d 66 69 6c 65 20 2a 74 6f 70 70 61 74 ame-file *toppat
35d0: 68 2a 29 0a 20 20 20 20 20 20 20 20 20 20 28 70 h*). (p
35e0: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 75 athname-file (cu
35f0: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
3600: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
3610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
3650: 3b 20 45 20 58 20 49 20 54 20 20 20 48 20 41 20 ; E X I T H A
3660: 4e 20 44 20 4c 20 49 20 4e 20 47 0a 3b 3b 3d 3d N D L I N G.;;==
3670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36b0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 63 ====..(define (c
36c0: 6f 6d 6d 6f 6e 3a 6c 65 67 61 63 79 2d 73 79 6e ommon:legacy-syn
36d0: 63 2d 72 65 63 6f 6d 6d 65 6e 64 65 64 29 0a 20 c-recommended).
36e0: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
36f0: 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 29 0a rg "-runtests").
3700: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
3710: 61 72 67 20 22 2d 72 75 6e 22 29 0a 20 20 20 20 arg "-run").
3720: 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 (args:get-arg
3730: 22 2d 73 65 72 76 65 72 22 29 0a 20 20 20 20 20 "-server").
3740: 20 3b 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 ;; (args:get-ar
3750: 67 20 22 2d 73 65 74 2d 72 75 6e 2d 73 74 61 74 g "-set-run-stat
3760: 75 73 22 29 0a 20 20 20 20 20 20 28 61 72 67 73 us"). (args
3770: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 6d 6f 76 :get-arg "-remov
3780: 65 2d 72 75 6e 73 22 29 0a 20 20 20 20 20 20 3b e-runs"). ;
3790: 3b 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ; (args:get-arg
37a0: 22 2d 67 65 74 2d 72 75 6e 2d 73 74 61 74 75 73 "-get-run-status
37b0: 22 29 0a 20 20 20 20 20 20 29 29 0a 0a 28 64 65 "). ))..(de
37c0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 65 67 fine (common:leg
37d0: 61 63 79 2d 73 79 6e 63 2d 72 65 71 75 69 72 65 acy-sync-require
37e0: 64 29 0a 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f d). (configf:lo
37f0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
3800: 20 22 73 65 74 75 70 22 20 22 6d 65 67 61 74 65 "setup" "megate
3810: 73 74 2d 64 62 22 29 29 0a 0a 28 64 65 66 69 6e st-db"))..(defin
3820: 65 20 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 e (std-exit-proc
3830: 65 64 75 72 65 29 0a 20 20 28 6c 65 74 20 28 28 edure). (let ((
3840: 6e 6f 2d 68 75 72 72 79 20 20 28 69 66 20 2a 74 no-hurry (if *t
3850: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3b 3b 20 ime-to-exit* ;;
3860: 68 75 72 72 79 20 75 70 0a 09 09 20 20 20 20 20 hurry up...
3870: 20 20 23 66 0a 09 09 20 20 20 20 20 20 20 28 62 #f... (b
3880: 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 2a egin.... (set! *
3890: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 time-to-exit* #t
38a0: 29 0a 09 09 09 20 23 74 29 29 29 29 0a 20 20 20 ).... #t)))).
38b0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
38c0: 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
38d0: 67 2d 70 6f 72 74 2a 20 22 73 74 61 72 74 69 6e g-port* "startin
38e0: 67 20 65 78 69 74 20 70 72 6f 63 65 73 73 2c 20 g exit process,
38f0: 66 69 6e 61 6c 69 7a 69 6e 67 20 64 61 74 61 62 finalizing datab
3900: 61 73 65 73 2e 22 29 0a 20 20 20 20 28 69 66 20 ases."). (if
3910: 28 61 6e 64 20 6e 6f 2d 68 75 72 72 79 20 28 64 (and no-hurry (d
3920: 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 ebug:debug-mode
3930: 31 38 29 29 0a 09 28 72 6d 74 3a 70 72 69 6e 74 18))..(rmt:print
3940: 2d 64 62 2d 73 74 61 74 73 29 29 0a 20 20 20 20 -db-stats)).
3950: 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b 65 (let ((th1 (make
3960: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
3970: 28 29 20 3b 3b 20 74 68 72 65 61 64 20 66 6f 72 () ;; thread for
3980: 20 63 6c 65 61 6e 69 6e 67 20 75 70 2c 20 67 69 cleaning up, gi
3990: 76 65 20 69 74 20 66 69 76 65 20 73 65 63 6f 6e ve it five secon
39a0: 64 73 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 ds.... (let
39b0: 20 28 28 72 75 6e 2d 69 64 73 20 28 68 61 73 68 ((run-ids (hash
39c0: 2d 74 61 62 6c 65 2d 6b 65 79 73 20 2a 64 62 2d -table-keys *db-
39d0: 6c 6f 63 61 6c 2d 73 79 6e 63 2a 29 29 29 0a 09 local-sync*)))..
39e0: 09 09 09 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 ...(if (and (not
39f0: 20 28 6e 75 6c 6c 3f 20 72 75 6e 2d 69 64 73 29 (null? run-ids)
3a00: 29 0a 09 09 09 09 09 20 28 6f 72 20 28 63 6f 6d )...... (or (com
3a10: 6d 6f 6e 3a 6c 65 67 61 63 79 2d 73 79 6e 63 2d mon:legacy-sync-
3a20: 72 65 63 6f 6d 6d 65 6e 64 65 64 29 0a 09 09 09 recommended)....
3a30: 09 09 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a .. (configf:
3a40: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
3a50: 74 2a 20 22 73 65 74 75 70 22 20 22 6d 65 67 61 t* "setup" "mega
3a60: 74 65 73 74 2d 64 62 22 29 29 29 0a 09 09 09 09 test-db"))).....
3a70: 20 20 20 20 28 69 66 20 6e 6f 2d 68 75 72 72 79 (if no-hurry
3a80: 20 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 (db:multi-db-sy
3a90: 6e 63 20 72 75 6e 2d 69 64 73 20 27 6e 65 77 32 nc run-ids 'new2
3aa0: 6f 6c 64 29 29 29 29 0a 09 09 09 20 20 20 20 20 old))))....
3ab0: 20 28 69 66 20 2a 64 62 73 74 72 75 63 74 2d 64 (if *dbstruct-d
3ac0: 62 2a 20 28 64 62 3a 63 6c 6f 73 65 2d 61 6c 6c b* (db:close-all
3ad0: 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 29 29 *dbstruct-db*))
3ae0: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 2a 69 .... (if *i
3af0: 6e 6d 65 6d 64 62 2a 20 20 20 20 20 28 64 62 3a nmemdb* (db:
3b00: 63 6c 6f 73 65 2d 61 6c 6c 20 2a 69 6e 6d 65 6d close-all *inmem
3b10: 64 62 2a 29 29 0a 09 09 09 20 20 20 20 20 20 28 db*)).... (
3b20: 69 66 20 28 61 6e 64 20 2a 6d 65 67 61 74 65 73 if (and *megates
3b30: 74 2d 64 62 2a 0a 09 09 09 09 20 20 20 20 20 20 t-db*.....
3b40: 20 28 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 (sqlite3:databa
3b50: 73 65 3f 20 2a 6d 65 67 61 74 65 73 74 2d 64 62 se? *megatest-db
3b60: 2a 29 29 0a 09 09 09 09 20 20 28 62 65 67 69 6e *))..... (begin
3b70: 0a 09 09 09 09 20 20 20 20 28 73 71 6c 69 74 65 ..... (sqlite
3b80: 33 3a 69 6e 74 65 72 72 75 70 74 21 20 2a 6d 65 3:interrupt! *me
3b90: 67 61 74 65 73 74 2d 64 62 2a 29 0a 09 09 09 09 gatest-db*).....
3ba0: 20 20 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e (sqlite3:fin
3bb0: 61 6c 69 7a 65 21 20 2a 6d 65 67 61 74 65 73 74 alize! *megatest
3bc0: 2d 64 62 2a 20 23 74 29 0a 09 09 09 09 20 20 20 -db* #t).....
3bd0: 20 28 73 65 74 21 20 2a 6d 65 67 61 74 65 73 74 (set! *megatest
3be0: 2d 64 62 2a 20 23 66 29 29 29 0a 09 09 09 20 20 -db* #f)))....
3bf0: 20 20 20 20 28 69 66 20 2a 74 61 73 6b 2d 64 62 (if *task-db
3c00: 2a 20 20 20 20 0a 09 09 09 09 20 20 28 6c 65 74 * ..... (let
3c10: 20 28 28 64 62 20 28 63 64 72 20 2a 74 61 73 6b ((db (cdr *task
3c20: 2d 64 62 2a 29 29 29 0a 09 09 09 09 20 20 20 20 -db*))).....
3c30: 28 69 66 20 28 73 71 6c 69 74 65 33 3a 64 61 74 (if (sqlite3:dat
3c40: 61 62 61 73 65 3f 20 64 62 29 0a 09 09 09 09 09 abase? db)......
3c50: 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 28 73 (begin...... (s
3c60: 71 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 70 74 qlite3:interrupt
3c70: 21 20 64 62 29 0a 09 09 09 09 09 20 20 28 73 71 ! db)...... (sq
3c80: 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 lite3:finalize!
3c90: 64 62 20 23 74 29 0a 09 09 09 09 09 20 20 28 76 db #t)...... (v
3ca0: 65 63 74 6f 72 2d 73 65 74 21 20 2a 74 61 73 6b ector-set! *task
3cb0: 2d 64 62 2a 20 30 20 23 66 29 29 29 29 29 0a 09 -db* 0 #f)))))..
3cc0: 09 09 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f .. (close-o
3cd0: 75 74 70 75 74 2d 70 6f 72 74 20 2a 64 65 66 61 utput-port *defa
3ce0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 0a 09 ult-log-port*)..
3cf0: 09 09 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 .. (set! *d
3d00: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3d10: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
3d20: 70 6f 72 74 29 29 29 20 22 43 6c 65 61 6e 75 70 port))) "Cleanup
3d30: 20 64 62 20 65 78 69 74 20 74 68 72 65 61 64 22 db exit thread"
3d40: 29 29 0a 09 20 20 28 74 68 32 20 28 6d 61 6b 65 )).. (th2 (make
3d50: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
3d60: 28 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 ().... (deb
3d70: 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 ug:print 4 *defa
3d80: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 ult-log-port* "A
3d90: 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 ttempting clean
3da0: 65 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 exit. Please be
3db0: 70 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 patient and wait
3dc0: 20 61 20 66 65 77 20 73 65 63 6f 6e 64 73 2e 2e a few seconds..
3dd0: 2e 22 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 .").... (if
3de0: 20 6e 6f 2d 68 75 72 72 79 0a 09 09 09 09 20 20 no-hurry.....
3df0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
3e00: 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 63 6c ) ;; give the cl
3e10: 65 61 6e 20 75 70 20 66 65 77 20 73 65 63 6f 6e ean up few secon
3e20: 64 73 20 74 6f 20 64 6f 20 69 74 27 73 20 73 74 ds to do it's st
3e30: 75 66 66 0a 09 09 09 09 20 20 28 74 68 72 65 61 uff..... (threa
3e40: 64 2d 73 6c 65 65 70 21 20 32 29 29 0a 09 09 09 d-sleep! 2))....
3e50: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3e60: 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 4 *default-lo
3e70: 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 64 6f g-port* " ... do
3e80: 6e 65 22 29 0a 09 09 09 20 20 20 20 20 20 29 0a ne").... ).
3e90: 09 09 09 20 20 20 20 22 63 6c 65 61 6e 20 65 78 ... "clean ex
3ea0: 69 74 22 29 29 29 0a 20 20 20 20 20 20 28 74 68 it"))). (th
3eb0: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
3ec0: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
3ed0: 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 tart! th2).
3ee0: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
3ef0: 68 31 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 h1))))..(define
3f00: 28 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 (std-signal-hand
3f10: 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 20 3b 3b ler signum). ;;
3f20: 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 (signal-mask! s
3f30: 69 67 6e 75 6d 29 0a 20 20 28 73 65 74 21 20 2a ignum). (set! *
3f40: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 time-to-exit* #t
3f50: 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
3f60: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
3f70: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 t-log-port* "Rec
3f80: 65 69 76 65 64 20 73 69 67 6e 61 6c 20 22 20 73 eived signal " s
3f90: 69 67 6e 75 6d 20 22 20 65 78 69 74 69 6e 67 20 ignum " exiting
3fa0: 70 72 6f 6d 70 74 6c 79 22 29 0a 20 20 3b 3b 20 promptly"). ;;
3fb0: 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 (std-exit-proced
3fc0: 75 72 65 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 ure) ;; shouldn'
3fd0: 74 20 6e 65 65 64 20 74 68 69 73 20 73 69 6e 63 t need this sinc
3fe0: 65 20 77 65 20 61 72 65 20 65 78 69 74 69 6e 67 e we are exiting
3ff0: 20 61 6e 64 20 69 74 20 77 69 6c 6c 20 62 65 20 and it will be
4000: 63 61 6c 6c 65 64 20 61 6e 79 77 61 79 0a 20 20 called anyway.
4010: 28 65 78 69 74 29 29 0a 0a 28 73 65 74 2d 73 69 (exit))..(set-si
4020: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 gnal-handler! si
4030: 67 6e 61 6c 2f 69 6e 74 20 20 73 74 64 2d 73 69 gnal/int std-si
4040: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b gnal-handler) ;
4050: 3b 20 5e 43 0a 28 73 65 74 2d 73 69 67 6e 61 6c ; ^C.(set-signal
4060: 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c -handler! signal
4070: 2f 74 65 72 6d 20 73 74 64 2d 73 69 67 6e 61 6c /term std-signal
4080: 2d 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 28 73 65 -handler).;; (se
4090: 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 t-signal-handler
40a0: 21 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 74 ! signal/stop st
40b0: 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 d-signal-handler
40c0: 29 20 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 6f 20 ) ;; ^Z NO, do
40d0: 4e 4f 54 20 68 61 6e 64 6c 65 20 5e 5a 21 0a 0a NOT handle ^Z!..
40e0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
40f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4120: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 ========.;; M I
4130: 53 20 43 20 20 20 55 20 54 20 49 20 4c 20 53 0a S C U T I L S.
4140: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
4150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4180: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6f 6e 65 ========..;; one
4190: 2d 6f 66 20 61 72 67 73 20 64 65 66 69 6e 65 64 -of args defined
41a0: 0a 28 64 65 66 69 6e 65 20 28 61 72 67 73 2d 64 .(define (args-d
41b0: 65 66 69 6e 65 64 3f 20 2e 20 70 61 72 61 6d 29 efined? . param)
41c0: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
41d0: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
41e0: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
41f0: 61 72 67 29 0a 20 20 20 20 20 20 20 28 69 66 20 arg). (if
4200: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 61 72 (args:get-arg ar
4210: 67 29 28 73 65 74 21 20 72 65 73 20 23 74 29 29 g)(set! res #t))
4220: 29 0a 20 20 20 20 20 70 61 72 61 6d 29 0a 20 20 ). param).
4230: 20 20 72 65 73 29 29 0a 0a 3b 3b 20 63 6f 6e 76 res))..;; conv
4240: 65 72 74 20 73 74 75 66 66 20 74 6f 20 61 20 6e ert stuff to a n
4250: 75 6d 62 65 72 20 69 66 20 70 6f 73 73 69 62 6c umber if possibl
4260: 65 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 2d 3e e.(define (any->
4270: 6e 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 number val). (c
4280: 6f 6e 64 20 0a 20 20 20 28 28 6e 75 6d 62 65 72 ond . ((number
4290: 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 ? val) val). (
42a0: 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 28 73 (string? val) (s
42b0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 tring->number va
42c0: 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f l)). ((symbol?
42d0: 20 76 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 6d 62 val) (any->numb
42e0: 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 er (symbol->stri
42f0: 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 28 65 6c ng val))). (el
4300: 73 65 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e se #f)))..(defin
4310: 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 2d 69 e (any->number-i
4320: 66 2d 70 6f 73 73 69 62 6c 65 20 76 61 6c 29 0a f-possible val).
4330: 20 20 28 6c 65 74 20 28 28 6e 75 6d 20 28 61 6e (let ((num (an
4340: 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 29 y->number val)))
4350: 0a 20 20 20 20 28 69 66 20 6e 75 6d 20 6e 75 6d . (if num num
4360: 20 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 val)))..(define
4370: 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 (patt-list-matc
4380: 68 20 69 74 65 6d 20 70 61 74 74 73 29 0a 20 20 h item patts).
4390: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
43a0: 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 8 *default-log
43b0: 2d 70 6f 72 74 2a 20 22 70 61 74 74 2d 6c 69 73 -port* "patt-lis
43c0: 74 2d 6d 61 74 63 68 20 69 74 65 6d 3d 22 20 69 t-match item=" i
43d0: 74 65 6d 20 22 20 70 61 74 74 73 3d 22 20 70 61 tem " patts=" pa
43e0: 74 74 73 29 0a 20 20 28 69 66 20 28 61 6e 64 20 tts). (if (and
43f0: 69 74 65 6d 20 70 61 74 74 73 29 20 20 3b 3b 20 item patts) ;;
4400: 68 65 72 65 20 77 65 20 61 72 65 20 66 69 6c 74 here we are filt
4410: 65 72 69 6e 67 20 66 6f 72 20 6d 61 74 63 68 65 ering for matche
4420: 73 20 77 69 74 68 20 69 74 65 6d 20 70 61 74 74 s with item patt
4430: 65 72 6e 73 0a 20 20 20 20 20 20 28 6c 65 74 20 erns. (let
4440: 28 28 72 65 73 20 23 66 29 29 20 20 20 3b 3b 20 ((res #f)) ;;
4450: 6c 6f 6f 6b 20 74 68 72 6f 75 67 68 20 61 6c 6c look through all
4460: 20 74 68 65 20 69 74 65 6d 2d 70 61 74 74 73 20 the item-patts
4470: 69 66 20 64 65 66 69 6e 65 64 2c 20 66 6f 72 6d if defined, form
4480: 61 74 20 69 73 20 70 61 74 74 31 2c 70 61 74 74 at is patt1,patt
4490: 32 2c 70 61 74 74 33 20 2e 2e 2e 20 77 69 6c 64 2,patt3 ... wild
44a0: 63 61 72 64 20 69 73 20 25 0a 09 28 66 6f 72 2d card is %..(for-
44b0: 65 61 63 68 20 0a 09 20 28 6c 61 6d 62 64 61 20 each .. (lambda
44c0: 28 70 61 74 74 29 0a 09 20 20 20 28 6c 65 74 20 (patt).. (let
44d0: 28 28 6d 6f 64 70 61 74 74 20 28 73 74 72 69 6e ((modpatt (strin
44e0: 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 25 22 g-substitute "%"
44f0: 20 22 2e 2a 22 20 70 61 74 74 20 23 74 29 29 29 ".*" patt #t)))
4500: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
4510: 69 6e 74 2d 69 6e 66 6f 20 31 30 20 2a 64 65 66 int-info 10 *def
4520: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
4530: 70 61 74 74 20 22 20 70 61 74 74 20 22 20 6d 6f patt " patt " mo
4540: 64 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 29 dpatt " modpatt)
4550: 0a 09 20 20 20 20 20 28 69 66 20 28 73 74 72 69 .. (if (stri
4560: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
4570: 20 6d 6f 64 70 61 74 74 29 20 69 74 65 6d 29 0a modpatt) item).
4580: 09 09 20 28 73 65 74 21 20 72 65 73 20 23 74 29 .. (set! res #t)
4590: 29 29 29 0a 09 20 28 73 74 72 69 6e 67 2d 73 70 ))).. (string-sp
45a0: 6c 69 74 20 70 61 74 74 73 20 22 2c 22 29 29 0a lit patts ",")).
45b0: 09 72 65 73 29 0a 20 20 20 20 20 20 23 74 29 29 .res). #t))
45c0: 0a 0a 3b 3b 20 28 6d 61 70 20 70 72 69 6e 74 20 ..;; (map print
45d0: 28 6d 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 (map car (hash-t
45e0: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 28 72 65 61 able->alist (rea
45f0: 64 2d 63 6f 6e 66 69 67 20 22 72 75 6e 63 6f 6e d-config "runcon
4600: 66 69 67 73 2e 63 6f 6e 66 69 67 22 20 23 66 20 figs.config" #f
4610: 23 74 29 29 29 29 0a 28 64 65 66 69 6e 65 20 28 #t)))).(define (
4620: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 75 6e 63 6f common:get-runco
4630: 6e 66 69 67 2d 74 61 72 67 65 74 73 20 23 21 6b nfig-targets #!k
4640: 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 29 29 ey (configf #f))
4650: 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 73 20 . (let ((targs
4660: 20 20 20 20 20 20 28 73 6f 72 74 20 28 6d 61 70 (sort (map
4670: 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 6c 65 car (hash-table
4680: 2d 3e 61 6c 69 73 74 0a 09 09 09 09 20 20 20 20 ->alist.....
4690: 20 28 6f 72 20 63 6f 6e 66 69 67 66 0a 09 09 09 (or configf....
46a0: 09 09 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 .. (read-config
46b0: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
46c0: 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "/runconfigs.con
46d0: 66 69 67 22 29 0a 09 09 09 09 09 09 20 20 20 20 fig").......
46e0: 20 20 23 66 20 23 74 29 0a 09 09 09 09 09 20 28 #f #t)...... (
46f0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
4700: 29 29 29 0a 09 09 09 20 20 20 73 74 72 69 6e 67 ))).... string
4710: 3c 3f 29 29 0a 09 28 74 61 72 67 65 74 2d 70 61 <?))..(target-pa
4720: 74 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 tt (args:get-arg
4730: 20 22 2d 74 61 72 67 65 74 22 29 29 29 0a 20 20 "-target"))).
4740: 20 20 28 69 66 20 74 61 72 67 65 74 2d 70 61 74 (if target-pat
4750: 74 0a 09 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 t..(filter (lamb
4760: 64 61 20 28 78 29 0a 09 09 20 20 28 70 61 74 74 da (x)... (patt
4770: 2d 6c 69 73 74 2d 6d 61 74 63 68 20 78 20 74 61 -list-match x ta
4780: 72 67 65 74 2d 70 61 74 74 29 29 0a 09 09 74 61 rget-patt))...ta
4790: 72 67 73 29 0a 09 74 61 72 67 73 29 29 29 0a 0a rgs)..targs)))..
47a0: 3b 3b 20 27 28 70 72 69 6e 74 20 28 73 74 72 69 ;; '(print (stri
47b0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 ng-intersperse (
47c0: 6d 61 70 20 63 61 64 72 20 28 68 61 73 68 2d 74 map cadr (hash-t
47d0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
47e0: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d (read-config "m
47f0: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 egatest.config"
4800: 5c 23 66 20 5c 23 74 29 20 22 64 69 73 6b 73 22 \#f \#t) "disks"
4810: 20 27 22 27 22 27 28 22 6e 6f 6e 65 22 20 22 22 '"'"'("none" ""
4820: 29 29 29 20 22 5c 6e 22 29 29 27 0a 28 64 65 66 ))) "\n"))'.(def
4830: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
4840: 64 69 73 6b 73 20 23 21 6b 65 79 20 28 63 6f 6e disks #!key (con
4850: 66 69 67 66 20 23 66 29 29 0a 20 20 28 68 61 73 figf #f)). (has
4860: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
4870: 75 6c 74 20 0a 20 20 20 28 6f 72 20 63 6f 6e 66 ult . (or conf
4880: 69 67 66 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 igf (read-config
4890: 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 "megatest.confi
48a0: 67 22 20 23 66 20 23 74 29 29 0a 20 20 20 22 64 g" #f #t)). "d
48b0: 69 73 6b 73 22 20 27 28 22 6e 6f 6e 65 22 20 22 isks" '("none" "
48c0: 22 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 ")))..;; return
48d0: 66 69 72 73 74 20 63 6f 6d 6d 61 6e 64 20 74 68 first command th
48e0: 61 74 20 65 78 69 73 74 73 2c 20 65 6c 73 65 20 at exists, else
48f0: 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 #f.;;.(define (c
4900: 6f 6d 6d 6f 6e 3a 77 68 69 63 68 20 63 6d 64 73 ommon:which cmds
4910: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 ). (if (null? c
4920: 6d 64 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 mds). #f.
4930: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
4940: 68 65 64 20 28 63 61 72 20 63 6d 64 73 29 29 0a hed (car cmds)).
4950: 09 09 20 28 74 61 6c 20 28 63 64 72 20 63 6d 64 .. (tal (cdr cmd
4960: 73 29 29 29 0a 09 28 6c 65 74 20 28 28 72 65 73 s)))..(let ((res
4970: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
4980: 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 77 68 m-pipe (conc "wh
4990: 69 63 68 20 22 20 68 65 64 29 20 72 65 61 64 2d ich " hed) read-
49a0: 6c 69 6e 65 29 29 29 0a 09 20 20 28 69 66 20 28 line))).. (if (
49b0: 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 72 65 73 and (string? res
49c0: 29 0a 09 09 20 20 20 28 66 69 6c 65 2d 65 78 69 )... (file-exi
49d0: 73 74 73 3f 20 72 65 73 29 29 0a 09 20 20 20 20 sts? res))..
49e0: 20 20 72 65 73 0a 09 20 20 20 20 20 20 28 69 66 res.. (if
49f0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 (null? tal)...
4a00: 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 #f... (loop (c
4a10: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
4a20: 29 29 29 29 29 29 29 0a 20 20 0a 28 64 65 66 69 ))))))). .(defi
4a30: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 ne (common:get-i
4a40: 6e 73 74 61 6c 6c 2d 61 72 65 61 29 0a 20 20 28 nstall-area). (
4a50: 6c 65 74 20 28 28 65 78 65 2d 70 61 74 68 20 28 let ((exe-path (
4a60: 63 61 72 20 28 61 72 67 76 29 29 29 29 0a 20 20 car (argv)))).
4a70: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
4a80: 74 73 3f 20 65 78 65 2d 70 61 74 68 29 0a 09 28 ts? exe-path)..(
4a90: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
4aa0: 73 0a 09 20 65 78 6e 0a 09 20 23 66 0a 09 20 28 s.. exn.. #f.. (
4ab0: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
4ac0: 72 79 0a 09 20 20 28 70 61 74 68 6e 61 6d 65 2d ry.. (pathname-
4ad0: 64 69 72 65 63 74 6f 72 79 20 0a 09 20 20 20 28 directory .. (
4ae0: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
4af0: 72 79 20 65 78 65 2d 70 61 74 68 29 29 29 29 0a ry exe-path)))).
4b00: 09 23 66 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d .#f)))..;;======
4b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b50: 0a 3b 3b 20 54 20 41 20 52 20 47 20 45 20 54 20 .;; T A R G E T
4b60: 53 20 20 2c 20 20 20 53 20 54 20 41 20 54 20 45 S , S T A T E
4b70: 20 2c 20 20 20 53 20 54 20 41 20 54 20 55 20 53 , S T A T U S
4b80: 20 2c 20 20 20 0a 3b 3b 20 20 20 20 20 20 20 20 , .;;
4b90: 20 20 20 20 20 20 20 20 20 20 20 20 52 20 55 20 R U
4ba0: 4e 20 4e 20 41 20 4d 20 45 20 20 20 20 41 20 4e N N A M E A N
4bb0: 20 44 20 20 20 54 20 45 20 53 20 54 20 50 20 41 D T E S T P A
4bc0: 20 54 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T T.;;=========
4bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
4c10: 3b 20 4c 6f 6f 6b 75 70 20 61 20 76 61 6c 75 65 ; Lookup a value
4c20: 20 69 6e 20 72 75 6e 63 6f 6e 66 69 67 73 20 62 in runconfigs b
4c30: 61 73 65 64 20 6f 6e 20 2d 72 65 71 74 61 72 67 ased on -reqtarg
4c40: 20 6f 72 20 2d 74 61 72 67 65 74 0a 28 64 65 66 or -target.(def
4c50: 69 6e 65 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d ine (runconfigs-
4c60: 67 65 74 20 63 6f 6e 66 69 67 20 76 61 72 29 0a get config var).
4c70: 20 20 28 6c 65 74 20 28 28 74 61 72 67 20 28 63 (let ((targ (c
4c80: 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 ommon:args-get-t
4c90: 61 72 67 65 74 29 29 29 20 3b 3b 20 28 6f 72 20 arget))) ;; (or
4ca0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
4cb0: 72 65 71 74 61 72 67 22 29 28 61 72 67 73 3a 67 reqtarg")(args:g
4cc0: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
4cd0: 29 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 )(getenv "MT_TAR
4ce0: 47 45 54 22 29 29 29 29 0a 20 20 20 20 28 69 66 GET")))). (if
4cf0: 20 74 61 72 67 0a 09 28 6f 72 20 28 63 6f 6e 66 targ..(or (conf
4d00: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
4d10: 67 20 74 61 72 67 20 76 61 72 29 0a 09 20 20 20 g targ var)..
4d20: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
4d30: 20 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 config "default
4d40: 22 20 76 61 72 29 29 0a 09 28 63 6f 6e 66 69 67 " var))..(config
4d50: 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 f:lookup config
4d60: 22 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 29 "default" var)))
4d70: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
4d80: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 on:args-get-stat
4d90: 65 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 e). (or (args:g
4da0: 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 29 et-arg "-state")
4db0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
4dc0: 73 74 61 74 65 22 29 29 29 0a 0a 28 64 65 66 69 state")))..(defi
4dd0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d ne (common:args-
4de0: 67 65 74 2d 73 74 61 74 75 73 29 0a 20 20 28 6f get-status). (o
4df0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
4e00: 22 2d 73 74 61 74 75 73 22 29 28 61 72 67 73 3a "-status")(args:
4e10: 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 get-arg ":status
4e20: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ")))..(define (c
4e30: 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 ommon:args-get-t
4e40: 65 73 74 70 61 74 74 20 72 63 6f 6e 66 29 0a 20 estpatt rconf).
4e50: 20 28 6c 65 74 2a 20 28 28 72 74 65 73 74 70 61 (let* ((rtestpa
4e60: 74 74 20 20 20 20 20 28 69 66 20 72 63 6f 6e 66 tt (if rconf
4e70: 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 65 74 (runconfigs-get
4e80: 20 72 63 6f 6e 66 20 22 54 45 53 54 50 41 54 54 rconf "TESTPATT
4e90: 22 29 20 23 66 29 29 0a 09 20 28 61 72 67 73 2d ") #f)).. (args-
4ea0: 74 65 73 74 70 61 74 74 20 28 6f 72 20 28 61 72 testpatt (or (ar
4eb0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 gs:get-arg "-tes
4ec0: 74 70 61 74 74 22 29 0a 09 09 09 20 20 20 20 28 tpatt").... (
4ed0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
4ee0: 75 6e 74 65 73 74 73 22 29 0a 09 09 09 20 20 20 untests")....
4ef0: 20 22 25 22 29 29 0a 09 20 28 74 65 73 74 70 61 "%")).. (testpa
4f00: 74 74 20 20 20 20 28 6f 72 20 28 61 6e 64 20 28 tt (or (and (
4f10: 65 71 75 61 6c 3f 20 61 72 67 73 2d 74 65 73 74 equal? args-test
4f20: 70 61 74 74 20 22 25 22 29 0a 09 09 09 20 20 20 patt "%")....
4f30: 20 20 20 20 72 74 65 73 74 70 61 74 74 29 0a 09 rtestpatt)..
4f40: 09 09 20 20 61 72 67 73 2d 74 65 73 74 70 61 74 .. args-testpat
4f50: 74 29 29 29 0a 20 20 20 20 28 69 66 20 72 74 65 t))). (if rte
4f60: 73 74 70 61 74 74 20 28 64 65 62 75 67 3a 70 72 stpatt (debug:pr
4f70: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
4f80: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 54 ult-log-port* "T
4f90: 45 53 54 50 41 54 54 20 66 72 6f 6d 20 72 75 6e ESTPATT from run
4fa0: 63 6f 6e 66 69 67 73 3a 20 22 20 72 74 65 73 74 configs: " rtest
4fb0: 70 61 74 74 29 29 0a 20 20 20 20 74 65 73 74 70 patt)). testp
4fc0: 61 74 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 att))..(define (
4fd0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b 74 common:get-linkt
4fe0: 72 65 65 29 0a 20 20 28 6f 72 20 28 67 65 74 65 ree). (or (gete
4ff0: 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 22 nv "MT_LINKTREE"
5000: 29 0a 20 20 20 20 20 20 28 69 66 20 2a 63 6f 6e ). (if *con
5010: 66 69 67 64 61 74 2a 0a 09 20 20 28 63 6f 6e 66 figdat*.. (conf
5020: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
5030: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
5040: 6c 69 6e 6b 74 72 65 65 22 29 29 29 29 0a 0a 28 linktree"))))..(
5050: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 define (common:a
5060: 72 67 73 2d 67 65 74 2d 72 75 6e 6e 61 6d 65 29 rgs-get-runname)
5070: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 6f . (let ((res (o
5080: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
5090: 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 09 09 20 28 "-runname")... (
50a0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 args:get-arg ":r
50b0: 75 6e 6e 61 6d 65 22 29 0a 09 09 20 28 67 65 74 unname")... (get
50c0: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
50d0: 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 69 66 20 )))). ;; (if
50e0: 72 65 73 20 28 73 65 74 2d 65 6e 76 69 72 6f 6e res (set-environ
50f0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
5100: 54 5f 52 55 4e 4e 41 4d 45 22 20 72 65 73 29 29 T_RUNNAME" res))
5110: 20 3b 3b 20 6e 6f 74 20 73 75 72 65 20 69 66 20 ;; not sure if
5120: 74 68 69 73 20 69 73 20 61 20 67 6f 6f 64 20 69 this is a good i
5130: 64 65 61 2e 20 73 69 64 65 20 65 66 66 65 63 74 dea. side effect
5140: 20 61 6e 64 20 61 6c 6c 20 2e 2e 2e 0a 20 20 20 and all ....
5150: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
5160: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
5170: 2d 74 61 72 67 65 74 20 23 21 6b 65 79 20 28 73 -target #!key (s
5180: 70 6c 69 74 20 23 66 29 29 0a 20 20 28 6c 65 74 plit #f)). (let
5190: 2a 20 28 28 6b 65 79 73 20 20 20 20 28 69 66 20 * ((keys (if
51a0: 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 2a 63 6f (hash-table? *co
51b0: 6e 66 69 67 64 61 74 2a 29 20 28 6b 65 79 73 3a nfigdat*) (keys:
51c0: 63 6f 6e 66 69 67 2d 67 65 74 2d 66 69 65 6c 64 config-get-field
51d0: 73 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 20 27 s *configdat*) '
51e0: 28 29 29 29 0a 09 20 28 6e 75 6d 6b 65 79 73 20 ())).. (numkeys
51f0: 28 6c 65 6e 67 74 68 20 6b 65 79 73 29 29 0a 09 (length keys))..
5200: 20 28 74 61 72 67 65 74 20 20 28 6f 72 20 28 61 (target (or (a
5210: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 rgs:get-arg "-re
5220: 71 74 61 72 67 22 29 0a 09 09 20 20 20 20 20 20 qtarg")...
5230: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
5240: 74 61 72 67 65 74 22 29 0a 09 09 20 20 20 20 20 target")...
5250: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 (getenv "MT_TAR
5260: 47 45 54 22 29 29 29 0a 09 20 28 74 6c 69 73 74 GET"))).. (tlist
5270: 20 20 20 28 69 66 20 74 61 72 67 65 74 20 28 73 (if target (s
5280: 74 72 69 6e 67 2d 73 70 6c 69 74 20 74 61 72 67 tring-split targ
5290: 65 74 20 22 2f 22 20 23 74 29 20 27 28 29 29 29 et "/" #t) '()))
52a0: 0a 09 20 28 76 61 6c 69 64 20 20 20 28 69 66 20 .. (valid (if
52b0: 74 61 72 67 65 74 0a 09 09 20 20 20 20 20 20 28 target... (
52c0: 6f 72 20 28 6e 75 6c 6c 3f 20 6b 65 79 73 29 20 or (null? keys)
52d0: 3b 3b 20 70 72 6f 62 61 62 6c 79 20 64 6f 6e 27 ;; probably don'
52e0: 74 20 6b 6e 6f 77 20 6f 75 72 20 6b 65 79 73 20 t know our keys
52f0: 79 65 74 0a 09 09 09 20 20 28 61 6e 64 20 28 6e yet.... (and (n
5300: 6f 74 20 28 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 ot (null? tlist)
5310: 29 0a 09 09 09 20 20 20 20 20 20 20 28 65 71 3f ).... (eq?
5320: 20 6e 75 6d 6b 65 79 73 20 28 6c 65 6e 67 74 68 numkeys (length
5330: 20 74 6c 69 73 74 29 29 0a 09 09 09 20 20 20 20 tlist))....
5340: 20 20 20 28 6e 75 6c 6c 3f 20 28 66 69 6c 74 65 (null? (filte
5350: 72 20 73 74 72 69 6e 67 2d 6e 75 6c 6c 3f 20 74 r string-null? t
5360: 6c 69 73 74 29 29 29 29 0a 09 09 20 20 20 20 20 list))))...
5370: 20 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 76 #f))). (if v
5380: 61 6c 69 64 0a 09 28 69 66 20 73 70 6c 69 74 0a alid..(if split.
5390: 09 20 20 20 20 74 6c 69 73 74 0a 09 20 20 20 20 . tlist..
53a0: 74 61 72 67 65 74 29 0a 09 28 69 66 20 74 61 72 target)..(if tar
53b0: 67 65 74 0a 09 20 20 20 20 28 62 65 67 69 6e 0a get.. (begin.
53c0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
53d0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
53e0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
53f0: 49 6e 76 61 6c 69 64 20 74 61 72 67 65 74 2c 20 Invalid target,
5400: 73 70 61 63 65 73 20 6f 72 20 62 6c 61 6e 6b 73 spaces or blanks
5410: 20 6e 6f 74 20 61 6c 6c 6f 77 65 64 20 5c 22 22 not allowed \""
5420: 20 74 61 72 67 65 74 20 22 5c 22 2c 20 74 61 72 target "\", tar
5430: 67 65 74 20 73 68 6f 75 6c 64 20 62 65 3a 20 22 get should be: "
5440: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
5450: 65 72 73 65 20 6b 65 79 73 20 22 2f 22 29 20 22 erse keys "/") "
5460: 2c 20 68 61 76 65 20 22 20 74 6c 69 73 74 20 22 , have " tlist "
5470: 20 66 6f 72 20 65 6c 65 6d 65 6e 74 73 22 29 0a for elements").
5480: 09 20 20 20 20 20 20 23 66 29 0a 09 20 20 20 20 . #f)..
5490: 23 66 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d #f))))..;;======
54a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
54e0: 0a 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 4c 20 .;; M I S C L
54f0: 49 20 53 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d I S T S.;;======
5500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5540: 0a 0a 3b 3b 20 69 74 65 6d 73 20 69 6e 20 6c 69 ..;; items in li
5550: 73 74 61 20 61 72 65 20 6d 61 74 63 68 65 64 20 sta are matched
5560: 76 61 6c 75 65 20 61 6e 64 20 70 6f 73 69 74 69 value and positi
5570: 6f 6e 20 69 6e 20 6c 69 73 74 62 0a 3b 3b 20 72 on in listb.;; r
5580: 65 74 75 72 6e 20 74 68 65 20 72 65 6d 61 69 6e eturn the remain
5590: 69 6e 67 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 ing items in lis
55a0: 74 62 20 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 tb or #f.;;.(def
55b0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 ine (common:list
55c0: 2d 69 73 2d 73 75 62 6c 69 73 74 20 6c 69 73 74 -is-sublist list
55d0: 61 20 6c 69 73 74 62 29 0a 20 20 28 69 66 20 28 a listb). (if (
55e0: 6e 75 6c 6c 3f 20 6c 69 73 74 61 29 0a 20 20 20 null? lista).
55f0: 20 20 20 6c 69 73 74 62 20 3b 3b 20 61 6c 6c 20 listb ;; all
5600: 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 61 items in listb a
5610: 72 65 20 22 72 65 6d 61 69 6e 69 6e 67 22 0a 20 re "remaining".
5620: 20 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e (if (> (len
5630: 67 74 68 20 6c 69 73 74 61 29 28 6c 65 6e 67 74 gth lista)(lengt
5640: 68 20 6c 69 73 74 62 29 29 20 0a 09 20 20 23 66 h listb)) .. #f
5650: 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 .. (let loop ((
5660: 68 65 64 61 20 28 63 61 72 20 6c 69 73 74 61 29 heda (car lista)
5670: 29 0a 09 09 20 20 20 20 20 28 74 61 6c 61 20 28 )... (tala (
5680: 63 64 72 20 6c 69 73 74 61 29 29 0a 09 09 20 20 cdr lista))...
5690: 20 20 20 28 68 65 64 62 20 28 63 61 72 20 6c 69 (hedb (car li
56a0: 73 74 62 29 29 0a 09 09 20 20 20 20 20 28 74 61 stb))... (ta
56b0: 6c 62 20 28 63 64 72 20 6c 69 73 74 62 29 29 29 lb (cdr listb)))
56c0: 0a 09 20 20 20 20 28 69 66 20 28 65 71 75 61 6c .. (if (equal
56d0: 3f 20 68 65 64 61 20 68 65 64 62 29 0a 09 09 28 ? heda hedb)...(
56e0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 61 29 20 if (null? tala)
56f0: 3b 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 09 ;; we are done..
5700: 09 20 20 20 20 74 61 6c 62 0a 09 09 20 20 20 20 . talb...
5710: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 61 29 (loop (car tala)
5720: 0a 09 09 09 20 20 28 63 64 72 20 74 61 6c 61 29 .... (cdr tala)
5730: 0a 09 09 09 20 20 28 63 61 72 20 74 61 6c 62 29 .... (car talb)
5740: 0a 09 09 09 20 20 28 63 64 72 20 74 61 6c 62 29 .... (cdr talb)
5750: 29 29 0a 09 09 23 66 29 29 29 29 29 0a 0a 3b 3b ))...#f)))))..;;
5760: 20 4e 65 65 64 65 64 20 66 6f 72 20 6c 6f 6e 67 Needed for long
5770: 20 6c 69 73 74 73 20 74 6f 20 62 65 20 73 6f 72 lists to be sor
5780: 74 65 64 20 77 68 65 72 65 20 28 61 70 70 6c 79 ted where (apply
5790: 20 6d 61 78 20 2e 2e 2e 20 29 20 64 69 65 73 0a max ... ) dies.
57a0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
57b0: 6f 6e 3a 6d 61 78 20 69 6e 6c 73 74 29 0a 20 20 on:max inlst).
57c0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6d 61 78 2d (let loop ((max-
57d0: 76 61 6c 20 28 63 61 72 20 69 6e 6c 73 74 29 29 val (car inlst))
57e0: 0a 09 20 20 20 20 20 28 68 65 64 20 20 20 20 20 .. (hed
57f0: 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 (car inlst))..
5800: 20 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 (tal (cdr
5810: 20 69 6e 6c 73 74 29 29 29 0a 20 20 20 20 28 69 inlst))). (i
5820: 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 f (not (null? ta
5830: 6c 29 29 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 20 l))..(loop (max
5840: 68 65 64 20 6d 61 78 2d 76 61 6c 29 0a 09 20 20 hed max-val)..
5850: 20 20 20 20 28 63 61 72 20 74 61 6c 29 0a 09 20 (car tal)..
5860: 20 20 20 20 20 28 63 64 72 20 74 61 6c 29 29 0a (cdr tal)).
5870: 09 28 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 .(max hed max-va
5880: 6c 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 l))))..;; get mi
5890: 6e 20 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 n or max, use >
58a0: 66 6f 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f for max and < fo
58b0: 72 20 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b r min, this work
58c0: 73 20 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d s around the lim
58d0: 69 74 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a its on apply.;;.
58e0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
58f0: 6d 69 6e 2d 6d 61 78 20 63 6f 6d 70 20 6c 73 74 min-max comp lst
5900: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c ). (if (null? l
5910: 73 74 29 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 st). #f ;;
5920: 62 65 74 74 65 72 20 74 68 61 6e 20 61 6e 20 65 better than an e
5930: 78 63 65 70 74 69 6f 6e 20 66 6f 72 20 6d 79 20 xception for my
5940: 6e 65 65 64 73 0a 20 20 20 20 20 20 28 66 6f 6c needs. (fol
5950: 64 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a d (lambda (a b).
5960: 09 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 70 . (if (comp
5970: 20 61 20 62 29 20 61 20 62 29 29 0a 09 20 20 20 a b) a b))..
5980: 20 28 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 (car lst)..
5990: 6c 73 74 29 29 29 0a 0a 3b 3b 20 70 61 74 68 20 lst)))..;; path
59a0: 6c 69 73 74 20 74 6f 20 68 61 73 68 2d 74 61 62 list to hash-tab
59b0: 6c 65 20 74 72 65 65 0a 3b 3b 20 20 20 28 28 61 le tree.;; ((a
59c0: 20 62 20 63 29 28 61 20 62 20 64 29 28 65 20 62 b c)(a b d)(e b
59d0: 20 63 29 29 20 3d 3e 20 28 28 61 20 28 62 20 28 c)) => ((a (b (
59e0: 64 29 20 28 63 29 29 29 20 28 65 20 28 62 20 28 d) (c))) (e (b (
59f0: 63 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 c)))).;;.(define
5a00: 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 (common:list->h
5a10: 74 72 65 65 20 6c 73 74 29 0a 20 20 28 6c 65 74 tree lst). (let
5a20: 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 ((resh (make-ha
5a30: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
5a40: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
5a50: 6c 61 6d 62 64 61 20 28 69 6e 6c 73 74 29 0a 20 lambda (inlst).
5a60: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
5a70: 28 28 68 74 20 20 72 65 73 68 29 0a 09 09 20 20 ((ht resh)...
5a80: 28 68 65 64 20 28 63 61 72 20 69 6e 6c 73 74 29 (hed (car inlst)
5a90: 29 0a 09 09 20 20 28 74 61 6c 20 28 63 64 72 20 )... (tal (cdr
5aa0: 69 6e 6c 73 74 29 29 29 0a 09 20 28 69 66 20 28 inlst))).. (if (
5ab0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
5ac0: 65 66 61 75 6c 74 20 68 74 20 68 65 64 20 23 66 efault ht hed #f
5ad0: 29 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ).. (if (not
5ae0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
5af0: 20 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 (loop (hash-tab
5b00: 6c 65 2d 72 65 66 20 68 74 20 68 65 64 29 0a 09 le-ref ht hed)..
5b10: 09 20 20 20 20 20 20 20 28 63 61 72 20 74 61 6c . (car tal
5b20: 29 0a 09 09 20 20 20 20 20 20 20 28 63 64 72 20 )... (cdr
5b30: 74 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 tal))).. (be
5b40: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 68 61 73 gin.. (has
5b50: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 h-table-set! ht
5b60: 68 65 64 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 hed (make-hash-t
5b70: 61 62 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 able)).. (
5b80: 6c 6f 6f 70 20 68 74 20 68 65 64 20 74 61 6c 29 loop ht hed tal)
5b90: 29 29 29 29 0a 20 20 20 20 20 6c 73 74 29 0a 20 )))). lst).
5ba0: 20 20 20 72 65 73 68 29 29 0a 0a 3b 3b 20 68 61 resh))..;; ha
5bb0: 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 6f sh-table tree to
5bc0: 20 68 74 6d 6c 20 6c 69 73 74 20 74 72 65 65 0a html list tree.
5bd0: 3b 3b 0a 3b 3b 20 20 20 74 69 70 66 75 6e 63 20 ;;.;; tipfunc
5be0: 74 61 6b 65 73 20 74 77 6f 20 70 61 72 61 6d 65 takes two parame
5bf0: 74 65 72 73 3a 20 79 20 74 68 65 20 74 69 70 20 ters: y the tip
5c00: 76 61 6c 75 65 20 61 6e 64 20 70 61 74 68 20 74 value and path t
5c10: 68 65 20 70 61 74 68 20 74 6f 20 74 68 61 74 20 he path to that
5c20: 70 6f 69 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 point.;;.(define
5c30: 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e (common:htree->
5c40: 68 74 6d 6c 20 68 74 20 70 61 74 68 20 74 69 70 html ht path tip
5c50: 66 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 64 func). (let ((d
5c60: 61 74 6c 69 73 74 20 09 28 73 6f 72 74 20 28 68 atlist .(sort (h
5c70: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
5c80: 20 68 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 ht).
5c90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ca0: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 (lambda (a b)
5cb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
5cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cd0: 20 28 73 74 72 69 6e 67 3c 20 28 63 61 72 20 61 (string< (car a
5ce0: 29 28 63 61 72 20 62 29 29 29 29 29 29 0a 20 20 )(car b)))))).
5cf0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 (if (null? dat
5d00: 6c 69 73 74 29 0a 20 20 20 20 09 28 74 69 70 66 list). .(tipf
5d10: 75 6e 63 20 23 66 20 70 61 74 68 29 20 3b 3b 20 unc #f path) ;;
5d20: 72 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 really shouldn't
5d30: 20 67 65 74 20 68 65 72 65 0a 09 28 73 3a 75 6c get here..(s:ul
5d40: 0a 09 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 .. (map (lambda
5d50: 28 78 29 0a 09 09 28 6c 65 74 2a 20 28 28 6c 65 (x)...(let* ((le
5d60: 76 65 6c 6e 61 6d 65 20 28 63 61 72 20 78 29 29 velname (car x))
5d70: 0a 09 09 20 20 20 20 20 20 20 28 79 20 20 20 20 ... (y
5d80: 20 20 20 20 20 28 63 64 72 20 78 29 29 0a 09 09 (cdr x))...
5d90: 20 20 20 20 20 20 20 28 6e 65 77 70 61 74 68 20 (newpath
5da0: 20 20 28 61 70 70 65 6e 64 20 70 61 74 68 20 28 (append path (
5db0: 6c 69 73 74 20 6c 65 76 65 6c 6e 61 6d 65 29 29 list levelname))
5dc0: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 61 66 )... (leaf
5dd0: 20 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 (or (not (
5de0: 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 29 0a hash-table? y)).
5df0: 09 09 09 09 20 20 20 20 20 20 28 6e 75 6c 6c 3f .... (null?
5e00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
5e10: 73 20 79 29 29 29 29 29 0a 09 09 20 20 28 69 66 s y)))))... (if
5e20: 20 6c 65 61 66 0a 09 09 20 20 20 20 20 20 28 73 leaf... (s
5e30: 3a 6c 69 20 28 74 69 70 66 75 6e 63 20 79 20 6e :li (tipfunc y n
5e40: 65 77 70 61 74 68 29 29 0a 09 09 20 20 20 20 20 ewpath))...
5e50: 20 28 73 3a 6c 69 0a 09 09 20 20 20 20 20 20 20 (s:li...
5e60: 28 6c 69 73 74 20 0a 09 09 09 6c 65 76 65 6c 6e (list ....leveln
5e70: 61 6d 65 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a 68 ame....(common:h
5e80: 74 72 65 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 77 tree->html y new
5e90: 70 61 74 68 20 74 69 70 66 75 6e 63 29 29 29 29 path tipfunc))))
5ea0: 29 29 0a 09 20 20 20 20 20 20 64 61 74 6c 69 73 )).. datlis
5eb0: 74 29 29 29 29 29 0a 0a 3b 3b 20 68 61 73 68 2d t)))))..;; hash-
5ec0: 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 61 6c table tree to al
5ed0: 69 73 74 20 74 72 65 65 0a 3b 3b 0a 28 64 65 66 ist tree.;;.(def
5ee0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 ine (common:htre
5ef0: 65 2d 3e 61 74 72 65 65 20 68 74 29 0a 20 20 28 e->atree ht). (
5f00: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
5f10: 09 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 0a . (cons (car x).
5f20: 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 79 . (let ((y
5f30: 20 28 63 64 72 20 78 29 29 29 0a 09 09 20 28 69 (cdr x)))... (i
5f40: 66 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 f (hash-table? y
5f50: 29 0a 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e )... (common
5f60: 3a 68 74 72 65 65 2d 3e 61 74 72 65 65 20 79 29 :htree->atree y)
5f70: 0a 09 09 20 20 20 20 20 79 29 29 29 29 0a 20 20 ... y)))).
5f80: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
5f90: 2d 3e 61 6c 69 73 74 20 68 74 29 29 29 0a 0a 3b ->alist ht)))..;
5fa0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
5fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5fe0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4e =======.;; M U N
5ff0: 20 47 20 45 20 20 20 44 20 41 20 54 20 41 20 20 G E D A T A
6000: 20 49 20 4e 20 54 20 4f 20 20 20 4e 20 49 20 43 I N T O N I C
6010: 20 45 20 20 20 46 20 4f 20 52 20 4d 20 53 0a 3b E F O R M S.;
6020: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
6030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6060: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 =======..;; Gene
6070: 72 61 74 65 20 61 6e 20 69 6e 64 65 78 20 66 6f rate an index fo
6080: 72 20 61 20 73 70 61 72 73 65 20 6c 69 73 74 20 r a sparse list
6090: 6f 66 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b 3b of key values.;;
60a0: 20 20 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 63 ( (rowname1 c
60b0: 6f 6c 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 6f olname1 val1)(ro
60c0: 77 6e 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 20 wname2 colname2
60d0: 76 61 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e val2) ).;;.;; =>
60e0: 20 0a 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f 77 .;;.;; ( (row
60f0: 6e 61 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d 65 name1 0)(rowname
6100: 32 20 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 6e 2 1)) ;; rown
6110: 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 ames -> num.;;
6120: 20 20 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 28 (colname1 0)(
6130: 63 6f 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 20 colname2 1)) )
6140: 3b 3b 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e ;; colnames -> n
6150: 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e um.;; .;; option
6160: 61 6c 20 61 70 70 6c 79 20 70 72 6f 63 20 74 6f al apply proc to
6170: 20 72 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 rownum colnum v
6180: 61 6c 75 65 0a 28 64 65 66 69 6e 65 20 28 63 6f alue.(define (co
6190: 6d 6d 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 74 mmon:sparse-list
61a0: 2d 67 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 20 -generate-index
61b0: 64 61 74 61 20 23 21 6b 65 79 20 28 70 72 6f 63 data #!key (proc
61c0: 20 23 66 29 29 0a 20 20 28 69 66 20 28 6e 75 6c #f)). (if (nul
61d0: 6c 3f 20 64 61 74 61 29 0a 20 20 20 20 20 20 28 l? data). (
61e0: 6c 69 73 74 20 27 28 29 20 27 28 29 29 0a 20 20 list '() '()).
61f0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
6200: 68 65 64 20 28 63 61 72 20 64 61 74 61 29 29 0a hed (car data)).
6210: 09 09 20 28 74 61 6c 20 28 63 64 72 20 64 61 74 .. (tal (cdr dat
6220: 61 29 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 73 a))... (rownames
6230: 20 27 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 6d '())... (colnam
6240: 65 73 20 27 28 29 29 0a 09 09 20 28 72 6f 77 6e es '())... (rown
6250: 75 6d 20 20 20 30 29 0a 09 09 20 28 63 6f 6c 6e um 0)... (coln
6260: 75 6d 20 20 20 30 29 29 0a 09 28 6c 65 74 2a 20 um 0))..(let*
6270: 28 28 72 6f 77 6b 65 79 20 20 20 20 20 20 20 20 ((rowkey
6280: 20 20 28 63 61 72 20 20 20 68 65 64 29 29 0a 09 (car hed))..
6290: 20 20 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 20 (colkey
62a0: 20 20 20 20 20 20 20 20 28 63 61 64 72 20 20 68 (cadr h
62b0: 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 ed)).. (va
62c0: 6c 75 65 20 20 20 20 20 20 20 20 20 20 20 28 63 lue (c
62d0: 61 64 64 72 20 68 65 64 29 29 0a 09 20 20 20 20 addr hed))..
62e0: 20 20 20 28 65 78 69 73 74 69 6e 67 2d 72 6f 77 (existing-row
62f0: 64 61 74 20 28 61 73 73 6f 63 20 72 6f 77 6b 65 dat (assoc rowke
6300: 79 20 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 20 y rownames))..
6310: 20 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d 63 (existing-c
6320: 6f 6c 64 61 74 20 28 61 73 73 6f 63 20 63 6f 6c oldat (assoc col
6330: 6b 65 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 key colnames))..
6340: 20 20 20 20 20 20 20 28 63 75 72 72 2d 72 6f 77 (curr-row
6350: 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 num (if exis
6360: 74 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e ting-rowdat rown
6370: 75 6d 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 29 um (+ rownum 1))
6380: 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 2d ).. (curr-
6390: 63 6f 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 65 colnum (if e
63a0: 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 63 xisting-coldat c
63b0: 6f 6c 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 olnum (+ colnum
63c0: 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 1))).. (ne
63d0: 77 2d 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 69 w-rownames (i
63e0: 66 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 f existing-rowda
63f0: 74 20 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e 73 t rownames (cons
6400: 20 28 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 75 (list rowkey cu
6410: 72 72 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 rr-rownum) rowna
6420: 6d 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 mes))).. (
6430: 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 20 new-colnames
6440: 28 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c (if existing-col
6450: 64 61 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 6f dat colnames (co
6460: 6e 73 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 20 ns (list colkey
6470: 63 75 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c curr-colnum) col
6480: 6e 61 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b 20 names)))).. ;;
6490: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
64a0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
64b0: 2d 70 6f 72 74 2a 20 22 50 72 6f 63 65 73 73 69 -port* "Processi
64c0: 6e 67 20 72 65 63 6f 72 64 3a 20 22 20 68 65 64 ng record: " hed
64d0: 20 29 0a 09 20 20 28 69 66 20 70 72 6f 63 20 28 ).. (if proc (
64e0: 70 72 6f 63 20 63 75 72 72 2d 72 6f 77 6e 75 6d proc curr-rownum
64f0: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 curr-colnum row
6500: 6b 65 79 20 63 6f 6c 6b 65 79 20 76 61 6c 75 65 key colkey value
6510: 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f )).. (if (null?
6520: 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 69 tal).. (li
6530: 73 74 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 st new-rownames
6540: 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 new-colnames)..
6550: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
6560: 74 61 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 tal)... (cdr
6570: 74 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 2d 72 tal)... new-r
6580: 6f 77 6e 61 6d 65 73 0a 09 09 20 20 20 20 6e 65 ownames... ne
6590: 77 2d 63 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 20 w-colnames...
65a0: 20 28 69 66 20 28 3e 20 63 75 72 72 2d 72 6f 77 (if (> curr-row
65b0: 6e 75 6d 20 72 6f 77 6e 75 6d 29 20 63 75 72 72 num rownum) curr
65c0: 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a -rownum rownum).
65d0: 09 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 .. (if (> cur
65e0: 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 r-colnum colnum)
65f0: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c curr-colnum col
6600: 6e 75 6d 29 0a 09 09 20 20 20 20 29 29 29 29 29 num)... )))))
6610: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
6620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 53 ===========.;; S
6660: 20 59 20 53 20 54 20 45 20 4d 20 20 20 53 20 54 Y S T E M S T
6670: 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d U F F.;;=======
6680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
66b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
66c0: 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 .;; lazy-safe ge
66d0: 74 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e t file mod time.
66e0: 20 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 66 on any error (f
66f0: 69 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 ile not existing
6700: 20 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 0a etc.) return 0.
6710: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
6720: 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 on:lazy-modifica
6730: 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 tion-time fpath)
6740: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
6750: 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 tions. exn.
6760: 30 0a 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 0. (file-modif
6770: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 ication-time fpa
6780: 74 68 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e th)))..;; return
6790: 20 61 20 6e 69 63 65 20 63 6c 65 61 6e 20 70 61 a nice clean pa
67a0: 74 68 6e 61 6d 65 20 6d 61 64 65 20 61 62 73 6f thname made abso
67b0: 6c 75 74 65 0a 28 64 65 66 69 6e 65 20 28 63 6f lute.(define (co
67c0: 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 64 mmon:nice-path d
67d0: 69 72 29 0a 20 20 28 6c 65 74 20 28 28 6d 61 74 ir). (let ((mat
67e0: 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ch (string-match
67f0: 20 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c "^(~[^\\/]*)(\\
6800: 2f 2e 2a 7c 29 24 22 20 64 69 72 29 29 29 0a 20 /.*|)$" dir))).
6810: 20 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 (if match ;;
6820: 75 73 69 6e 67 20 7e 20 66 6f 72 20 68 6f 6d 65 using ~ for home
6830: 3f 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d ?..(common:nice-
6840: 70 61 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d 6d path (conc (comm
6850: 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 28 on:read-link-f (
6860: 63 61 64 72 20 6d 61 74 63 68 29 29 20 22 2f 22 cadr match)) "/"
6870: 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 (caddr match)))
6880: 0a 09 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 ..(normalize-pat
6890: 68 6e 61 6d 65 20 28 69 66 20 28 61 62 73 6f 6c hname (if (absol
68a0: 75 74 65 2d 70 61 74 68 6e 61 6d 65 3f 20 64 69 ute-pathname? di
68b0: 72 29 0a 09 09 09 09 64 69 72 0a 09 09 09 09 28 r).....dir.....(
68c0: 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 64 69 conc (current-di
68d0: 72 65 63 74 6f 72 79 29 20 22 2f 22 20 64 69 72 rectory) "/" dir
68e0: 29 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 ))))))..;; make
68f0: 22 6e 69 63 65 2d 70 61 74 68 22 20 61 76 61 69 "nice-path" avai
6900: 6c 61 62 6c 65 20 69 6e 20 63 6f 6e 66 69 67 20 lable in config
6910: 66 69 6c 65 73 20 61 6e 64 20 74 68 65 20 72 65 files and the re
6920: 70 6c 0a 28 64 65 66 69 6e 65 20 6e 69 63 65 2d pl.(define nice-
6930: 70 61 74 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 path common:nice
6940: 2d 70 61 74 68 29 0a 0a 28 64 65 66 69 6e 65 20 -path)..(define
6950: 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e (common:read-lin
6960: 6b 2d 66 20 70 61 74 68 29 0a 20 20 28 68 61 6e k-f path). (han
6970: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
6980: 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 28 exn. (
6990: 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 begin..(debug:pr
69a0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
69b0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
69c0: 63 6f 6d 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f 72 command \"/bin/r
69d0: 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 eadlink -f " pat
69e0: 68 20 22 5c 22 20 66 61 69 6c 65 64 2e 22 29 0a h "\" failed.").
69f0: 09 70 61 74 68 29 20 3b 3b 20 6a 75 73 74 20 67 .path) ;; just g
6a00: 69 76 65 20 75 70 0a 20 20 20 20 28 77 69 74 68 ive up. (with
6a10: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
6a20: 0a 09 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 65 ..(conc "/bin/re
6a30: 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 adlink -f " path
6a40: 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ). (lambda
6a50: 28 29 0a 09 28 72 65 61 64 2d 6c 69 6e 65 29 29 ()..(read-line))
6a60: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 )))..(define (ge
6a70: 74 2d 63 70 75 2d 6c 6f 61 64 20 23 21 6b 65 79 t-cpu-load #!key
6a80: 20 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 (remote-host #f
6a90: 29 29 0a 20 20 28 63 61 72 20 28 63 6f 6d 6d 6f )). (car (commo
6aa0: 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 n:get-cpu-load r
6ab0: 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 3b 3b emote-host))).;;
6ac0: 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d (let* ((load-
6ad0: 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 res (process:cmd
6ae0: 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 69 -run->list "upti
6af0: 6d 65 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 me")).;; . (load
6b00: 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 6c 6f -rx (regexp "lo
6b10: 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 ad average:\\s+(
6b20: 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 63 \\d+)")).;; . (c
6b30: 70 75 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b 20 pu-load #f)).;;
6b40: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
6b50: 61 6d 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 28 ambda (l).;; ..(
6b60: 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 let ((match (str
6b70: 69 6e 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 2d ing-search load-
6b80: 72 78 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 28 rx l))).;; .. (
6b90: 69 66 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 20 if match.;; ..
6ba0: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 61 (let ((newva
6bb0: 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 l (string->numbe
6bc0: 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 r (cadr match)))
6bd0: 29 0a 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 6d ).;; ...(if (num
6be0: 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 ber? newval).;;
6bf0: 09 09 09 20 20 20 20 28 73 65 74 21 20 63 70 75 ... (set! cpu
6c00: 2d 6c 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 29 -load newval))))
6c10: 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 61 )).;; . (ca
6c20: 72 20 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b 20 r load-res)).;;
6c30: 20 20 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a 0a cpu-load))..
6c40: 3b 3b 20 67 65 74 20 63 70 75 20 6c 6f 61 64 20 ;; get cpu load
6c50: 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 by reading from
6c60: 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 72 /proc/loadavg, r
6c70: 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 eturn all three
6c80: 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 6e values.;;.(defin
6c90: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 e (common:get-cp
6ca0: 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f u-load remote-ho
6cb0: 73 74 29 0a 20 20 28 69 66 20 72 65 6d 6f 74 65 st). (if remote
6cc0: 2d 68 6f 73 74 0a 20 20 20 20 20 20 28 6d 61 70 -host. (map
6cd0: 20 28 6c 61 6d 62 64 61 20 28 72 65 73 29 0a 09 (lambda (res)..
6ce0: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
6cf0: 6a 65 63 74 3f 20 72 65 73 29 20 39 65 39 39 20 ject? res) 9e99
6d00: 72 65 73 29 29 0a 09 20 20 20 28 77 69 74 68 2d res)).. (with-
6d10: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
6d20: 0a 09 20 20 20 20 28 63 6f 6e 63 20 22 73 73 68 .. (conc "ssh
6d30: 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 " remote-host "
6d40: 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 cat /proc/loada
6d50: 76 67 22 29 0a 09 20 20 20 20 28 6c 61 6d 62 64 vg").. (lambd
6d60: 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 29 a ()(list (read)
6d70: 28 72 65 61 64 29 28 72 65 61 64 29 29 29 29 29 (read)(read)))))
6d80: 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 . (with-inp
6d90: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 ut-from-file "/p
6da0: 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 0a 09 28 roc/loadavg" ..(
6db0: 6c 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 28 lambda ()(list (
6dc0: 72 65 61 64 29 28 72 65 61 64 29 28 72 65 61 64 read)(read)(read
6dd0: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
6de0: 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 (common:wait-for
6df0: 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 -cpuload maxload
6e00: 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c numcpus waitdel
6e10: 61 79 20 23 21 6b 65 79 20 28 63 6f 75 6e 74 20 ay #!key (count
6e20: 31 30 30 30 29 20 28 6d 73 67 20 23 66 29 28 72 1000) (msg #f)(r
6e30: 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a emote-host #f)).
6e40: 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 61 76 (let* ((loadav
6e50: 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 g (common:get-cp
6e60: 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f u-load remote-ho
6e70: 73 74 29 29 0a 09 20 28 66 69 72 73 74 20 20 20 st)).. (first
6e80: 28 63 61 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 (car loadavg))..
6e90: 20 28 6e 65 78 74 20 20 20 20 28 63 61 64 72 20 (next (cadr
6ea0: 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 61 64 6a loadavg)).. (adj
6eb0: 6c 6f 61 64 20 28 2a 20 6d 61 78 6c 6f 61 64 20 load (* maxload
6ec0: 6e 75 6d 63 70 75 73 29 29 0a 09 20 28 6c 6f 61 numcpus)).. (loa
6ed0: 64 6a 6d 70 20 28 2d 20 66 69 72 73 74 20 6e 65 djmp (- first ne
6ee0: 78 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a xt))). (cond.
6ef0: 20 20 20 20 20 28 28 61 6e 64 20 28 3e 20 66 69 ((and (> fi
6f00: 72 73 74 20 61 64 6a 6c 6f 61 64 29 0a 09 20 20 rst adjload)..
6f10: 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 (> count 0)).
6f20: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6f30: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
6f40: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
6f50: 69 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 20 ing " waitdelay
6f60: 22 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f " seconds due to
6f70: 20 6c 6f 61 64 20 22 20 66 69 72 73 74 20 22 20 load " first "
6f80: 65 78 63 65 65 64 69 6e 67 20 6d 61 78 20 6f 66 exceeding max of
6f90: 20 22 20 61 64 6a 6c 6f 61 64 20 28 69 66 20 6d " adjload (if m
6fa0: 73 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 20 sg msg "")).
6fb0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
6fc0: 20 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 20 waitdelay).
6fd0: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 (common:wait-f
6fe0: 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f or-cpuload maxlo
6ff0: 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 ad numcpus waitd
7000: 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 elay count: (- c
7010: 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 28 ount 1))). (
7020: 28 61 6e 64 20 28 3e 20 6c 6f 61 64 6a 6d 70 20 (and (> loadjmp
7030: 6e 75 6d 63 70 75 73 29 0a 09 20 20 20 28 3e 20 numcpus).. (>
7040: 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 20 count 0)).
7050: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7060: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
7070: 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 6e 67 20 -port* "waiting
7080: 22 20 77 61 69 74 64 65 6c 61 79 20 22 20 73 65 " waitdelay " se
7090: 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f 61 conds due to loa
70a0: 64 20 6a 75 6d 70 20 22 20 6c 6f 61 64 6a 6d 70 d jump " loadjmp
70b0: 20 22 20 3e 20 6e 75 6d 63 70 75 73 20 22 20 6e " > numcpus " n
70c0: 75 6d 63 70 75 73 20 28 69 66 20 6d 73 67 20 6d umcpus (if msg m
70d0: 73 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 sg "")). (t
70e0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 77 61 69 hread-sleep! wai
70f0: 74 64 65 6c 61 79 29 0a 20 20 20 20 20 20 28 63 tdelay). (c
7100: 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 ommon:wait-for-c
7110: 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e puload maxload n
7120: 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 umcpus waitdelay
7130: 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 count: (- count
7140: 20 31 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 1))))))..(defin
7150: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 e (common:get-nu
7160: 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f m-cpus remote-ho
7170: 73 74 29 0a 20 20 28 6c 65 74 20 28 28 70 72 6f st). (let ((pro
7180: 63 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 28 c (lambda ()...(
7190: 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 6d 63 70 let loop ((numcp
71a0: 75 20 30 29 0a 09 09 09 20 20 20 28 69 6e 6c 20 u 0).... (inl
71b0: 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 (read-line)))
71c0: 0a 09 09 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 ... (if (eof-ob
71d0: 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 09 20 20 20 ject? inl)...
71e0: 20 20 20 6e 75 6d 63 70 75 0a 09 09 20 20 20 20 numcpu...
71f0: 20 20 28 6c 6f 6f 70 20 28 69 66 20 28 73 74 72 (loop (if (str
7200: 69 6e 67 2d 6d 61 74 63 68 20 22 5e 70 72 6f 63 ing-match "^proc
7210: 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b 5c 5c essor\\s+:\\s+\\
7220: 64 2b 24 22 20 69 6e 6c 29 0a 09 09 09 09 28 2b d+$" inl).....(+
7230: 20 6e 75 6d 63 70 75 20 31 29 0a 09 09 09 09 6e numcpu 1).....n
7240: 75 6d 63 70 75 29 0a 09 09 09 20 20 20 20 28 72 umcpu).... (r
7250: 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 29 29 0a ead-line))))))).
7260: 20 20 20 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 (if remote-h
7270: 6f 73 74 0a 09 28 77 69 74 68 2d 69 6e 70 75 74 ost..(with-input
7280: 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 20 28 63 -from-pipe .. (c
7290: 6f 6e 63 20 22 73 73 68 20 22 20 72 65 6d 6f 74 onc "ssh " remot
72a0: 65 2d 68 6f 73 74 20 22 20 63 61 74 20 2f 70 72 e-host " cat /pr
72b0: 6f 63 2f 63 70 75 69 6e 66 6f 22 29 0a 09 20 70 oc/cpuinfo").. p
72c0: 72 6f 63 29 0a 09 28 77 69 74 68 2d 69 6e 70 75 roc)..(with-inpu
72d0: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 t-from-file "/pr
72e0: 6f 63 2f 63 70 75 69 6e 66 6f 22 20 70 72 6f 63 oc/cpuinfo" proc
72f0: 29 29 29 29 0a 0a 3b 3b 20 77 61 69 74 20 66 6f ))))..;; wait fo
7300: 72 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 r normalized cpu
7310: 20 6c 6f 61 64 20 74 6f 20 64 72 6f 70 20 62 65 load to drop be
7320: 6c 6f 77 20 6d 61 78 6c 6f 61 64 0a 3b 3b 0a 28 low maxload.;;.(
7330: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
7340: 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a ait-for-normaliz
7350: 65 64 2d 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 ed-load maxload
7360: 23 21 6b 65 79 20 28 6d 73 67 20 23 66 29 28 72 #!key (msg #f)(r
7370: 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a emote-host #f)).
7380: 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 63 70 75 (let ((num-cpu
7390: 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 s (common:get-nu
73a0: 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f m-cpus remote-ho
73b0: 73 74 29 29 29 0a 20 20 20 20 28 63 6f 6d 6d 6f st))). (commo
73c0: 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f n:wait-for-cpulo
73d0: 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 2d 63 ad maxload num-c
73e0: 70 75 73 20 31 35 20 6d 73 67 3a 20 6d 73 67 29 pus 15 msg: msg)
73f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 ))..(define (get
7400: 2d 75 6e 61 6d 65 20 2e 20 70 61 72 61 6d 73 29 -uname . params)
7410: 0a 20 20 28 6c 65 74 2a 20 28 28 75 6e 61 6d 65 . (let* ((uname
7420: 2d 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d -res (process:cm
7430: 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e d-run->list (con
7440: 63 20 22 75 6e 61 6d 65 20 22 20 28 69 66 20 28 c "uname " (if (
7450: 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 2d null? params) "-
7460: 61 22 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 a" (car params))
7470: 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 23 66 29 ))).. (uname #f)
7480: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
7490: 20 28 63 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 (car uname-res)
74a0: 29 0a 09 22 75 6e 6b 6e 6f 77 6e 22 0a 09 28 63 ).."unknown"..(c
74b0: 61 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 29 aar uname-res)))
74c0: 29 0a 0a 3b 3b 20 66 6f 72 20 72 65 61 73 6f 6e )..;; for reason
74d0: 73 20 49 20 64 6f 6e 27 74 20 75 6e 64 65 72 73 s I don't unders
74e0: 74 61 6e 64 20 6d 75 6c 74 69 70 6c 65 20 63 61 tand multiple ca
74f0: 6c 6c 73 20 74 6f 20 72 65 61 6c 2d 70 61 74 68 lls to real-path
7500: 20 69 6e 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 in parallel thr
7510: 65 61 64 73 0a 3b 3b 20 6d 75 73 74 20 62 65 20 eads.;; must be
7520: 70 72 6f 74 65 63 74 65 64 20 62 79 20 6d 75 74 protected by mut
7530: 65 78 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 exes.;;.(define
7540: 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 (common:real-pat
7550: 68 20 69 6e 70 61 74 68 29 0a 20 20 3b 3b 20 28 h inpath). ;; (
7560: 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d process:cmd-run-
7570: 77 69 74 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 with-stderr->lis
7580: 74 20 22 72 65 61 64 6c 69 6e 6b 22 20 22 2d 66 t "readlink" "-f
7590: 22 20 69 6e 70 61 74 68 29 29 20 3b 3b 20 63 6d " inpath)) ;; cm
75a0: 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b d . params). ;;
75b0: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 0a 20 20 (let-values .
75c0: 3b 3b 20 20 28 28 28 69 6e 70 20 6f 75 70 20 70 ;; (((inp oup p
75d0: 69 64 29 20 28 70 72 6f 63 65 73 73 20 22 72 65 id) (process "re
75e0: 61 64 6c 69 6e 6b 22 20 28 6c 69 73 74 20 22 2d adlink" (list "-
75f0: 66 22 20 69 6e 70 61 74 68 29 29 29 29 0a 20 20 f" inpath)))).
7600: 3b 3b 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ;; (with-input-
7610: 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 0a 20 20 from-port inp.
7620: 3b 3b 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ;; (let loop
7630: 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 ((inl (read-line
7640: 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 09 28 )). ;; .(
7650: 72 65 73 20 23 66 29 29 0a 20 20 3b 3b 20 20 20 res #f)). ;;
7660: 20 20 20 28 70 72 69 6e 74 20 22 69 6e 6c 3d 22 (print "inl="
7670: 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 inl). ;;
7680: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
7690: 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 inl). ;;
76a0: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 3b 3b 20 (begin. ;;
76b0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 (clos
76c0: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 e-input-port inp
76d0: 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ). ;;
76e0: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
76f0: 70 6f 72 74 20 6f 75 70 29 0a 20 20 3b 3b 20 20 port oup). ;;
7700: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ;; (pr
7710: 6f 63 65 73 73 2d 77 61 69 74 20 70 69 64 29 0a ocess-wait pid).
7720: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
7730: 72 65 73 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 res). ;;
7740: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c (loop (read-l
7750: 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 29 0a 20 ine) inl)))))).
7760: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
7770: 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 72 65 m-pipe (conc "re
7780: 61 64 6c 69 6e 6b 20 2d 66 20 22 20 69 6e 70 61 adlink -f " inpa
7790: 74 68 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 0a th) read-line)).
77a0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
77b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 =========.;; D I
77f0: 20 53 20 4b 20 20 20 53 20 50 20 41 20 43 20 45 S K S P A C E
7800: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
7810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
7850: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
7860: 64 69 73 6b 2d 73 70 61 63 65 2d 75 73 65 64 20 disk-space-used
7870: 66 70 61 74 68 29 0a 20 20 28 77 69 74 68 2d 69 fpath). (with-i
7880: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 nput-from-pipe (
7890: 63 6f 6e 63 20 22 2f 75 73 72 2f 62 69 6e 2f 64 conc "/usr/bin/d
78a0: 75 20 2d 73 20 22 20 66 70 61 74 68 29 20 72 65 u -s " fpath) re
78b0: 61 64 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 70 ad))..;; given p
78c0: 61 74 68 20 67 65 74 20 66 72 65 65 20 73 70 61 ath get free spa
78d0: 63 65 2c 20 61 6c 6c 6f 77 73 20 6f 76 65 72 72 ce, allows overr
78e0: 69 64 65 20 69 6e 20 5b 73 65 74 75 70 5d 0a 3b ide in [setup].;
78f0: 3b 20 77 69 74 68 20 66 72 65 65 2d 73 70 61 63 ; with free-spac
7900: 65 2d 73 63 72 69 70 74 20 2f 70 61 74 68 2f 74 e-script /path/t
7910: 6f 2f 73 6f 6d 65 2f 73 63 72 69 70 74 2e 73 68 o/some/script.sh
7920: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 74 .;;.(define (get
7930: 2d 64 66 20 70 61 74 68 29 0a 20 20 28 69 66 20 -df path). (if
7940: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
7950: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
7960: 75 70 22 20 22 66 72 65 65 2d 73 70 61 63 65 2d up" "free-space-
7970: 73 63 72 69 70 74 22 29 0a 20 20 20 20 20 20 28 script"). (
7980: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
7990: 70 69 70 65 20 0a 20 20 20 20 20 20 20 28 63 6f pipe . (co
79a0: 6e 63 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b nc (configf:look
79b0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
79c0: 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 70 61 setup" "free-spa
79d0: 63 65 2d 73 63 72 69 70 74 22 29 20 22 20 22 20 ce-script") " "
79e0: 70 61 74 68 29 0a 20 20 20 20 20 20 20 28 6c 61 path). (la
79f0: 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 74 20 28 mbda ().. (let (
7a00: 28 72 65 73 20 28 72 65 61 64 2d 6c 69 6e 65 29 (res (read-line)
7a10: 29 29 0a 09 20 20 20 28 69 66 20 28 73 74 72 69 )).. (if (stri
7a20: 6e 67 3f 20 72 65 73 29 0a 09 20 20 20 20 20 20 ng? res)..
7a30: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
7a40: 20 72 65 73 29 29 29 29 29 0a 20 20 20 20 20 20 res))))).
7a50: 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 (get-unix-df pat
7a60: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 h)))..(define (g
7a70: 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 68 29 et-unix-df path)
7a80: 0a 20 20 28 6c 65 74 2a 20 28 28 64 66 2d 72 65 . (let* ((df-re
7a90: 73 75 6c 74 73 20 28 70 72 6f 63 65 73 73 3a 63 sults (process:c
7aa0: 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f md-run->list (co
7ab0: 6e 63 20 22 64 66 20 22 20 70 61 74 68 29 29 29 nc "df " path)))
7ac0: 0a 09 20 28 73 70 61 63 65 2d 72 78 20 20 20 28 .. (space-rx (
7ad0: 72 65 67 65 78 70 20 22 28 5b 30 2d 39 5d 2b 29 regexp "([0-9]+)
7ae0: 5c 5c 73 2b 28 5b 30 2d 39 5d 2b 29 25 22 29 29 \\s+([0-9]+)%"))
7af0: 0a 09 20 28 66 72 65 65 73 70 63 20 20 20 20 23 .. (freespc #
7b00: 66 29 29 0a 20 20 20 20 3b 3b 20 28 77 72 69 74 f)). ;; (writ
7b10: 65 20 64 66 2d 72 65 73 75 6c 74 73 29 0a 20 20 e df-results).
7b20: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
7b30: 62 64 61 20 28 6c 29 0a 09 09 28 6c 65 74 20 28 bda (l)...(let (
7b40: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 73 (match (string-s
7b50: 65 61 72 63 68 20 73 70 61 63 65 2d 72 78 20 6c earch space-rx l
7b60: 29 29 29 0a 09 09 20 20 28 69 66 20 6d 61 74 63 )))... (if matc
7b70: 68 20 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 h ... (let
7b80: 28 28 6e 65 77 76 61 6c 20 28 73 74 72 69 6e 67 ((newval (string
7b90: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d ->number (cadr m
7ba0: 61 74 63 68 29 29 29 29 0a 09 09 09 28 69 66 20 atch))))....(if
7bb0: 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 (number? newval)
7bc0: 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 66 72 .... (set! fr
7bd0: 65 65 73 70 63 20 6e 65 77 76 61 6c 29 29 29 29 eespc newval))))
7be0: 29 29 0a 09 20 20 20 20 20 20 28 63 61 72 20 64 )).. (car d
7bf0: 66 2d 72 65 73 75 6c 74 73 29 29 0a 20 20 20 20 f-results)).
7c00: 66 72 65 65 73 70 63 29 29 0a 0a 3b 3b 20 63 68 freespc))..;; ch
7c10: 65 63 6b 20 73 70 61 63 65 20 69 6e 20 64 62 64 eck space in dbd
7c20: 69 72 0a 3b 3b 20 72 65 74 75 72 6e 73 3a 20 6f ir.;; returns: o
7c30: 6b 2f 6e 6f 74 20 64 62 73 70 61 63 65 20 72 65 k/not dbspace re
7c40: 71 75 69 72 65 64 2d 73 70 61 63 65 0a 3b 3b 0a quired-space.;;.
7c50: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
7c60: 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 73 70 61 check-db-dir-spa
7c70: 63 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 ce). (let* ((db
7c80: 64 69 72 20 20 20 20 28 64 62 3a 67 65 74 2d 64 dir (db:get-d
7c90: 62 64 69 72 29 29 0a 09 20 28 64 62 73 70 61 63 bdir)).. (dbspac
7ca0: 65 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 e (if (director
7cb0: 79 3f 20 64 62 64 69 72 29 0a 09 09 20 20 20 20 y? dbdir)...
7cc0: 20 20 20 28 67 65 74 2d 64 66 20 64 62 64 69 72 (get-df dbdir
7cd0: 29 0a 09 09 20 20 20 20 20 20 20 30 29 29 0a 09 )... 0))..
7ce0: 20 28 72 65 71 75 69 72 65 64 20 28 73 74 72 69 (required (stri
7cf0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 09 09 20 20 ng->number ...
7d00: 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c (or (configf:l
7d10: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
7d20: 2a 20 22 73 65 74 75 70 22 20 22 64 62 64 69 72 * "setup" "dbdir
7d30: 2d 73 70 61 63 65 2d 72 65 71 75 69 72 65 64 22 -space-required"
7d40: 29 0a 09 09 09 22 31 30 30 30 30 30 22 29 29 29 )...."100000")))
7d50: 29 0a 20 20 20 20 28 6c 69 73 74 20 28 3e 20 64 ). (list (> d
7d60: 62 73 70 61 63 65 20 72 65 71 75 69 72 65 64 29 bspace required)
7d70: 0a 09 20 20 64 62 73 70 61 63 65 0a 09 20 20 72 .. dbspace.. r
7d80: 65 71 75 69 72 65 64 0a 09 20 20 64 62 64 69 72 equired.. dbdir
7d90: 29 29 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 61 76 )))..;; check av
7da0: 61 69 6c 61 62 6c 65 20 73 70 61 63 65 20 69 6e ailable space in
7db0: 20 64 62 64 69 72 2c 20 65 78 69 74 20 69 66 20 dbdir, exit if
7dc0: 69 6e 73 75 66 66 69 63 69 65 6e 74 0a 3b 3b 0a insufficient.;;.
7dd0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
7de0: 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 61 6e 64 check-db-dir-and
7df0: 2d 65 78 69 74 2d 69 66 2d 69 6e 73 75 66 66 69 -exit-if-insuffi
7e00: 63 69 65 6e 74 29 0a 20 20 28 6c 65 74 2a 20 28 cient). (let* (
7e10: 28 73 70 61 63 65 64 61 74 20 28 63 6f 6d 6d 6f (spacedat (commo
7e20: 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 73 n:check-db-dir-s
7e30: 70 61 63 65 29 29 0a 09 20 28 69 73 2d 6f 6b 20 pace)).. (is-ok
7e40: 20 20 20 28 63 61 72 20 73 70 61 63 65 64 61 74 (car spacedat
7e50: 29 29 0a 09 20 28 64 62 73 70 61 63 65 20 20 28 )).. (dbspace (
7e60: 63 61 64 72 20 73 70 61 63 65 64 61 74 29 29 0a cadr spacedat)).
7e70: 09 20 28 72 65 71 75 69 72 65 64 20 28 63 61 64 . (required (cad
7e80: 64 72 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 dr spacedat))..
7e90: 28 64 62 64 69 72 20 20 20 20 28 63 61 64 64 64 (dbdir (caddd
7ea0: 72 20 73 70 61 63 65 64 61 74 29 29 29 0a 20 20 r spacedat))).
7eb0: 20 20 28 69 66 20 28 6e 6f 74 20 69 73 2d 6f 6b (if (not is-ok
7ec0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
7ed0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
7ee0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
7ef0: 6f 72 74 2a 20 22 49 6e 73 75 66 66 69 63 69 65 ort* "Insufficie
7f00: 6e 74 20 73 70 61 63 65 20 69 6e 20 22 20 64 62 nt space in " db
7f10: 64 69 72 20 22 2c 20 72 65 71 75 69 72 65 20 22 dir ", require "
7f20: 20 72 65 71 75 69 72 65 64 20 22 2c 20 68 61 76 required ", hav
7f30: 65 20 22 20 64 62 73 70 61 63 65 20 20 22 2c 20 e " dbspace ",
7f40: 65 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 exiting now.")..
7f50: 20 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 20 (exit 1))))).
7f60: 20 0a 3b 3b 20 70 61 74 68 73 20 69 73 20 6c 69 .;; paths is li
7f70: 73 74 20 6f 66 20 6c 69 73 74 73 20 28 28 6e 61 st of lists ((na
7f80: 6d 65 20 70 61 74 68 29 20 2e 2e 2e 20 29 0a 3b me path) ... ).;
7f90: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
7fa0: 6e 3a 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d n:get-disk-with-
7fb0: 6d 6f 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 most-free-space
7fc0: 64 69 73 6b 73 20 6d 69 6e 73 69 7a 65 29 0a 20 disks minsize).
7fd0: 20 28 6c 65 74 20 28 28 62 65 73 74 20 20 20 20 (let ((best
7fe0: 20 23 66 29 0a 09 28 62 65 73 74 73 69 7a 65 20 #f)..(bestsize
7ff0: 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 0)). (for-eac
8000: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
8010: 28 64 69 73 6b 2d 6e 75 6d 29 0a 20 20 20 20 20 (disk-num).
8020: 20 20 28 6c 65 74 2a 20 28 28 64 69 72 70 61 74 (let* ((dirpat
8030: 68 20 20 20 20 28 63 61 64 72 20 28 61 73 73 6f h (cadr (asso
8040: 63 20 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 c disk-num disks
8050: 29 29 29 0a 09 20 20 20 20 20 20 28 66 72 65 65 ))).. (free
8060: 73 70 63 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 spc (cond....
8070: 20 20 20 28 28 6e 6f 74 20 28 64 69 72 65 63 74 ((not (direct
8080: 6f 72 79 3f 20 64 69 72 70 61 74 68 29 29 0a 09 ory? dirpath))..
8090: 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f .. (if (commo
80a0: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
80b0: 74 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 t 300 "disks not
80c0: 20 61 20 64 69 72 20 22 20 64 69 73 6b 2d 6e 75 a dir " disk-nu
80d0: 6d 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 m).....(debug:pr
80e0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
80f0: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
8100: 47 3a 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e G: disk " disk-n
8110: 75 6d 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 um " at path \""
8120: 20 64 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 dirpath "\" is
8130: 6e 6f 74 20 61 20 64 69 72 65 63 74 6f 72 79 20 not a directory
8140: 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 - ignoring it.")
8150: 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 ).... -1)....
8160: 20 20 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 ((not (file-w
8170: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 69 72 rite-access? dir
8180: 70 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 path)).... (i
8190: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
81a0: 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 ise-print 300 "d
81b0: 69 73 6b 73 20 6e 6f 74 20 77 72 69 74 65 61 62 isks not writeab
81c0: 6c 65 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 le " disk-num)..
81d0: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
81e0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
81f0: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 ort* "WARNING: d
8200: 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 isk " disk-num "
8210: 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 69 72 at path \"" dir
8220: 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 path "\" is not
8230: 77 72 69 74 65 61 62 6c 65 20 2d 20 69 67 6e 6f writeable - igno
8240: 72 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 ring it."))....
8250: 20 20 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e -1).... ((n
8260: 6f 74 20 28 65 71 3f 20 28 73 74 72 69 6e 67 2d ot (eq? (string-
8270: 72 65 66 20 64 69 72 70 61 74 68 20 30 29 20 23 ref dirpath 0) #
8280: 5c 2f 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 \/)).... (if
8290: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
82a0: 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 73 e-print 300 "dis
82b0: 6b 73 20 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 ks not a proper
82c0: 70 61 74 68 20 22 20 64 69 73 6b 2d 6e 75 6d 29 path " disk-num)
82d0: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
82e0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
82f0: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
8300: 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d disk " disk-num
8310: 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 " at path \"" d
8320: 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f irpath "\" is no
8330: 74 20 61 20 66 75 6c 6c 79 20 71 75 61 6c 69 66 t a fully qualif
8340: 69 65 64 20 70 61 74 68 20 2d 20 69 67 6e 6f 72 ied path - ignor
8350: 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 ing it."))....
8360: 20 20 2d 31 29 0a 09 09 09 20 20 20 28 65 6c 73 -1).... (els
8370: 65 0a 09 09 09 20 20 20 20 28 67 65 74 2d 64 66 e.... (get-df
8380: 20 64 69 72 70 61 74 68 29 29 29 29 29 0a 09 20 dirpath)))))..
8390: 28 69 66 20 28 3e 20 66 72 65 65 73 70 63 20 62 (if (> freespc b
83a0: 65 73 74 73 69 7a 65 29 0a 09 20 20 20 20 20 28 estsize).. (
83b0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 73 begin.. (s
83c0: 65 74 21 20 62 65 73 74 20 20 20 20 20 28 63 6f et! best (co
83d0: 6e 73 20 64 69 73 6b 2d 6e 75 6d 20 64 69 72 70 ns disk-num dirp
83e0: 61 74 68 29 29 20 20 3b 3b 20 4e 4f 54 45 3a 20 ath)) ;; NOTE:
83f0: 64 69 66 66 65 72 65 6e 74 20 73 74 6f 72 61 67 different storag
8400: 65 20 73 74 79 6c 65 21 0a 09 20 20 20 20 20 20 e style!..
8410: 20 28 73 65 74 21 20 62 65 73 74 73 69 7a 65 20 (set! bestsize
8420: 66 72 65 65 73 70 63 29 29 29 29 29 0a 20 20 20 freespc))))).
8430: 20 20 28 6d 61 70 20 63 61 72 20 64 69 73 6b 73 (map car disks
8440: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
8450: 62 65 73 74 20 28 3e 20 62 65 73 74 73 69 7a 65 best (> bestsize
8460: 20 6d 69 6e 73 69 7a 65 29 29 0a 09 62 65 73 74 minsize))..best
8470: 0a 09 23 66 29 29 29 20 3b 3b 20 23 66 20 6d 65 ..#f))) ;; #f me
8480: 61 6e 73 20 6e 6f 20 64 69 73 6b 20 63 61 6e 64 ans no disk cand
8490: 69 64 61 74 65 20 66 6f 75 6e 64 0a 0a 3b 3b 3d idate found..;;=
84a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
84b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
84c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
84d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
84e0: 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 4e 20 56 20 49 =====.;; E N V I
84f0: 20 52 20 4f 20 4e 20 4d 20 45 20 4e 20 54 20 20 R O N M E N T
8500: 20 56 20 41 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d V A R S.;;=====
8510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8550: 3d 0a 09 20 20 20 20 20 20 0a 28 64 65 66 69 6e =.. .(defin
8560: 65 20 28 73 61 76 65 2d 65 6e 76 69 72 6f 6e 6d e (save-environm
8570: 65 6e 74 2d 61 73 2d 66 69 6c 65 73 20 66 6e 61 ent-as-files fna
8580: 6d 65 20 23 21 6b 65 79 20 28 69 67 6e 6f 72 65 me #!key (ignore
8590: 76 61 72 73 20 28 6c 69 73 74 20 22 55 53 45 52 vars (list "USER
85a0: 22 20 22 48 4f 4d 45 22 20 22 44 49 53 50 4c 41 " "HOME" "DISPLA
85b0: 59 22 20 22 4c 53 5f 43 4f 4c 4f 52 53 22 20 22 Y" "LS_COLORS" "
85c0: 58 4b 45 59 53 59 4d 44 42 22 20 22 45 44 49 54 XKEYSYMDB" "EDIT
85d0: 4f 52 22 20 22 4d 41 4b 45 46 4c 41 47 53 22 20 OR" "MAKEFLAGS"
85e0: 22 4d 41 4b 45 46 22 20 22 4d 41 4b 45 4f 56 45 "MAKEF" "MAKEOVE
85f0: 52 52 49 44 45 53 22 29 29 29 0a 20 20 28 6c 65 RRIDES"))). (le
8600: 74 20 28 28 65 6e 76 76 61 72 73 20 28 67 65 74 t ((envvars (get
8610: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
8620: 69 61 62 6c 65 73 29 29 0a 20 20 20 20 20 20 20 iables)).
8630: 20 28 77 68 69 74 65 73 70 20 28 72 65 67 65 78 (whitesp (regex
8640: 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 2d 39 5f 5c p "[^a-zA-Z0-9_\
8650: 5c 2d 3a 2c 2e 5c 5c 2f 25 24 5d 22 29 29 0a 09 \-:,.\\/%$]"))..
8660: 28 6d 75 6e 67 65 76 61 6c 20 28 6c 61 6d 62 64 (mungeval (lambd
8670: 61 20 28 76 61 6c 29 0a 09 09 20 20 20 20 28 63 a (val)... (c
8680: 6f 6e 64 0a 09 09 20 20 20 20 20 28 28 65 71 3f ond... ((eq?
8690: 20 76 61 6c 20 23 74 29 20 22 22 29 20 3b 3b 20 val #t) "") ;;
86a0: 63 6f 6e 76 65 72 74 20 23 74 20 74 6f 20 65 6d convert #t to em
86b0: 70 74 79 20 73 74 72 69 6e 67 0a 09 09 20 20 20 pty string...
86c0: 20 20 28 28 65 71 3f 20 76 61 6c 20 23 66 29 20 ((eq? val #f)
86d0: 23 66 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 #f) ;; convert #
86e0: 66 20 74 6f 20 69 74 73 65 6c 66 20 28 73 74 69 f to itself (sti
86f0: 6c 6c 20 74 68 69 6e 6b 69 6e 67 20 61 62 6f 75 ll thinking abou
8700: 74 20 74 68 69 73 20 6f 6e 65 0a 09 09 20 20 20 t this one...
8710: 20 20 28 65 6c 73 65 20 76 61 6c 29 29 29 29 29 (else val)))))
8720: 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 . (with-outp
8730: 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 ut-to-file (conc
8740: 20 66 6e 61 6d 65 20 22 2e 63 73 68 22 29 0a 20 fname ".csh").
8750: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
8760: 0a 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d . (for-
8770: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
8780: 79 76 61 6c 29 0a 09 09 20 20 20 20 20 20 28 6c yval)... (l
8790: 65 74 2a 20 28 28 6b 65 79 20 20 20 28 63 61 72 et* ((key (car
87a0: 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 keyval))....
87b0: 20 20 28 76 61 6c 20 20 20 28 63 64 72 20 6b 65 (val (cdr ke
87c0: 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 yval)).... (
87d0: 64 65 6c 69 6d 20 28 69 66 20 28 73 74 72 69 6e delim (if (strin
87e0: 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 73 70 g-search whitesp
87f0: 20 76 61 6c 29 20 0a 09 09 09 09 09 22 5c 22 22 val) ......"\""
8800: 0a 09 09 09 09 09 22 22 29 29 29 0a 09 09 09 28 ......"")))....(
8810: 70 72 69 6e 74 20 28 69 66 20 28 6d 65 6d 62 65 print (if (membe
8820: 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 72 73 r key ignorevars
8830: 29 0a 09 09 09 09 20 20 20 22 23 20 73 65 74 65 )..... "# sete
8840: 6e 76 20 22 0a 09 09 09 09 20 20 20 22 73 65 74 nv "..... "set
8850: 65 6e 76 20 22 29 0a 09 09 09 20 20 20 20 20 20 env ")....
8860: 20 6b 65 79 20 22 20 22 20 64 65 6c 69 6d 20 28 key " " delim (
8870: 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 64 65 mungeval val) de
8880: 6c 69 6d 29 29 29 0a 09 09 20 20 20 20 65 6e 76 lim)))... env
8890: 76 61 72 73 29 29 29 0a 20 20 20 20 20 28 77 69 vars))). (wi
88a0: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c th-output-to-fil
88b0: 65 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e e (conc fname ".
88c0: 73 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d sh"). (lam
88d0: 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 bda ().
88e0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
88f0: 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 da (keyval)...
8900: 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 (let* ((key
8910: 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 (car keyval))...
8920: 09 20 20 20 20 20 28 76 61 6c 20 28 63 64 72 20 . (val (cdr
8930: 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 keyval))....
8940: 20 28 64 65 6c 69 6d 20 28 69 66 20 28 73 74 72 (delim (if (str
8950: 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 ing-search white
8960: 73 70 20 76 61 6c 29 20 0a 09 09 09 09 09 22 5c sp val) ......"\
8970: 22 22 0a 09 09 09 09 09 22 22 29 29 29 0a 09 09 ""......"")))...
8980: 09 28 70 72 69 6e 74 20 28 69 66 20 28 6d 65 6d .(print (if (mem
8990: 62 65 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 ber key ignoreva
89a0: 72 73 29 0a 09 09 09 09 20 20 20 22 23 20 65 78 rs)..... "# ex
89b0: 70 6f 72 74 20 22 0a 09 09 09 09 20 20 20 22 65 port "..... "e
89c0: 78 70 6f 72 74 20 22 29 0a 09 09 09 20 20 20 20 xport ")....
89d0: 20 20 20 6b 65 79 20 22 3d 22 20 64 65 6c 69 6d key "=" delim
89e0: 20 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 (mungeval val)
89f0: 64 65 6c 69 6d 29 29 29 0a 20 20 20 20 20 20 20 delim))).
8a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 65 6e 76 env
8a10: 76 61 72 73 29 29 29 29 29 0a 0a 3b 3b 20 73 65 vars)))))..;; se
8a20: 74 20 73 6f 6d 65 20 65 6e 76 20 76 61 72 73 20 t some env vars
8a30: 66 72 6f 6d 20 61 6e 20 61 6c 69 73 74 2c 20 72 from an alist, r
8a40: 65 74 75 72 6e 20 61 6e 20 61 6c 69 73 74 20 77 eturn an alist w
8a50: 69 74 68 20 6f 72 69 67 69 6e 61 6c 20 76 61 6c ith original val
8a60: 75 65 73 0a 3b 3b 20 28 28 22 56 41 52 22 20 22 ues.;; (("VAR" "
8a70: 76 61 6c 75 65 22 29 20 2e 2e 2e 29 0a 28 64 65 value") ...).(de
8a80: 66 69 6e 65 20 28 61 6c 69 73 74 2d 3e 65 6e 76 fine (alist->env
8a90: 2d 76 61 72 73 20 6c 73 74 29 0a 20 20 28 69 66 -vars lst). (if
8aa0: 20 28 6c 69 73 74 3f 20 6c 73 74 29 0a 20 20 20 (list? lst).
8ab0: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 (let ((res '(
8ac0: 29 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 )))..(for-each (
8ad0: 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 lambda (p)...
8ae0: 20 28 6c 65 74 2a 20 28 28 76 61 72 20 28 63 61 (let* ((var (ca
8af0: 72 20 20 70 29 29 0a 09 09 09 20 20 20 28 76 61 r p)).... (va
8b00: 6c 20 28 63 61 64 72 20 70 29 29 0a 09 09 09 20 l (cadr p))....
8b10: 20 20 28 70 72 76 20 28 67 65 74 2d 65 6e 76 69 (prv (get-envi
8b20: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
8b30: 20 76 61 72 29 29 29 0a 09 09 20 20 20 20 20 20 var)))...
8b40: 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 (set! res (cons
8b50: 28 6c 69 73 74 20 76 61 72 20 70 72 76 29 20 72 (list var prv) r
8b60: 65 73 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 es))... (if
8b70: 20 76 61 6c 20 0a 09 09 09 20 20 28 73 65 74 65 val .... (sete
8b80: 6e 76 20 76 61 72 20 28 2d 3e 73 74 72 69 6e 67 nv var (->string
8b90: 20 76 61 6c 29 29 0a 09 09 09 20 20 28 75 6e 73 val)).... (uns
8ba0: 65 74 65 6e 76 20 76 61 72 29 29 29 29 0a 09 09 etenv var))))...
8bb0: 20 20 6c 73 74 29 0a 09 72 65 73 29 0a 20 20 20 lst)..res).
8bc0: 20 20 20 27 28 29 29 29 0a 0a 3b 3b 20 63 6c 65 '()))..;; cle
8bd0: 61 72 20 76 61 72 73 20 6d 61 74 63 68 69 6e 67 ar vars matching
8be0: 20 70 61 74 74 65 72 6e 2c 20 72 75 6e 20 70 72 pattern, run pr
8bf0: 6f 63 2c 20 73 65 74 20 76 61 72 73 20 62 61 63 oc, set vars bac
8c00: 6b 0a 3b 3b 20 69 66 20 70 72 6f 63 20 69 73 20 k.;; if proc is
8c10: 61 20 73 74 72 69 6e 67 20 72 75 6e 20 74 68 61 a string run tha
8c20: 74 20 73 74 72 69 6e 67 20 61 73 20 61 20 63 6f t string as a co
8c30: 6d 6d 61 6e 64 20 77 69 74 68 0a 3b 3b 20 73 79 mmand with.;; sy
8c40: 73 74 65 6d 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 stem..;;.(define
8c50: 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 (common:without
8c60: 2d 76 61 72 73 20 70 72 6f 63 20 2e 20 76 61 72 -vars proc . var
8c70: 2d 70 61 74 74 73 29 0a 20 20 28 6c 65 74 20 28 -patts). (let (
8c80: 28 76 61 72 73 20 28 6d 61 6b 65 2d 68 61 73 68 (vars (make-hash
8c90: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 66 -table))). (f
8ca0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
8cb0: 6d 62 64 61 20 28 76 61 72 64 61 74 29 20 3b 3b mbda (vardat) ;;
8cc0: 20 65 61 63 68 20 65 6e 76 20 76 61 72 0a 20 20 each env var.
8cd0: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 (for-each..
8ce0: 28 6c 61 6d 62 64 61 20 28 76 61 72 2d 70 61 74 (lambda (var-pat
8cf0: 74 29 0a 09 20 20 28 69 66 20 28 73 74 72 69 6e t).. (if (strin
8d00: 67 2d 6d 61 74 63 68 20 76 61 72 2d 70 61 74 74 g-match var-patt
8d10: 20 28 63 61 72 20 76 61 72 64 61 74 29 29 0a 09 (car vardat))..
8d20: 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 (let ((var
8d30: 20 28 63 61 72 20 76 61 72 64 61 74 29 29 0a 09 (car vardat))..
8d40: 09 20 20 20 20 28 76 61 6c 20 28 63 64 72 20 76 . (val (cdr v
8d50: 61 72 64 61 74 29 29 29 0a 09 09 28 68 61 73 68 ardat)))...(hash
8d60: 2d 74 61 62 6c 65 2d 73 65 74 21 20 76 61 72 73 -table-set! vars
8d70: 20 76 61 72 20 76 61 6c 29 0a 09 09 28 75 6e 73 var val)...(uns
8d80: 65 74 65 6e 76 20 76 61 72 29 29 29 29 0a 09 76 etenv var))))..v
8d90: 61 72 2d 70 61 74 74 73 29 29 0a 20 20 20 20 20 ar-patts)).
8da0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
8db0: 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 20 -variables)).
8dc0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 73 74 (cond. ((st
8dd0: 72 69 6e 67 3f 20 70 72 6f 63 29 28 73 79 73 74 ring? proc)(syst
8de0: 65 6d 20 70 72 6f 63 29 29 0a 20 20 20 20 20 28 em proc)). (
8df0: 70 72 6f 63 20 20 20 20 20 20 20 20 20 20 28 70 proc (p
8e00: 72 6f 63 29 29 29 0a 20 20 20 20 28 68 61 73 68 roc))). (hash
8e10: 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a -table-for-each.
8e20: 20 20 20 20 20 76 61 72 73 0a 20 20 20 20 20 28 vars. (
8e30: 6c 61 6d 62 64 61 20 28 76 61 72 20 76 61 6c 29 lambda (var val)
8e40: 0a 20 20 20 20 20 20 20 28 73 65 74 65 6e 76 20 . (setenv
8e50: 76 61 72 20 76 61 6c 29 29 29 0a 20 20 20 20 76 var val))). v
8e60: 61 72 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ars))..(define (
8e70: 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 61 2d 63 6f 6d common:run-a-com
8e80: 6d 61 6e 64 20 63 6d 64 20 23 21 6b 65 79 20 28 mand cmd #!key (
8e90: 77 69 74 68 2d 76 61 72 73 20 23 66 29 29 0a 20 with-vars #f)).
8ea0: 20 28 6c 65 74 2a 20 28 28 70 72 65 2d 63 6d 64 (let* ((pre-cmd
8eb0: 20 20 28 64 74 65 73 74 73 3a 67 65 74 2d 70 72 (dtests:get-pr
8ec0: 65 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 20 e-command)).
8ed0: 20 20 20 20 20 28 70 6f 73 74 2d 63 6d 64 20 28 (post-cmd (
8ee0: 64 74 65 73 74 73 3a 67 65 74 2d 70 6f 73 74 2d dtests:get-post-
8ef0: 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 20 20 20 command)).
8f00: 20 20 20 28 66 75 6c 6c 63 6d 64 20 20 28 69 66 (fullcmd (if
8f10: 20 28 6f 72 20 70 72 65 2d 63 6d 64 20 70 6f 73 (or pre-cmd pos
8f20: 74 2d 63 6d 64 29 0a 20 20 20 20 20 20 20 20 20 t-cmd).
8f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
8f40: 6f 6e 63 20 70 72 65 2d 63 6d 64 20 63 6d 64 20 onc pre-cmd cmd
8f50: 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 20 20 20 post-cmd).
8f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8f70: 20 28 63 6f 6e 63 20 22 76 69 65 77 73 63 72 65 (conc "viewscre
8f80: 65 6e 20 22 20 63 6d 64 29 29 29 29 0a 20 20 20 en " cmd)))).
8f90: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
8fa0: 66 6f 20 30 32 20 2a 64 65 66 61 75 6c 74 2d 6c fo 02 *default-l
8fb0: 6f 67 2d 70 6f 72 74 2a 20 22 52 75 6e 6e 69 6e og-port* "Runnin
8fc0: 67 20 63 6f 6d 6d 61 6e 64 3a 20 22 20 66 75 6c g command: " ful
8fd0: 6c 63 6d 64 29 0a 20 20 20 20 28 69 66 20 77 69 lcmd). (if wi
8fe0: 74 68 2d 76 61 72 73 0a 20 20 20 20 20 20 20 20 th-vars.
8ff0: 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d (common:without-
9000: 76 61 72 73 20 63 6d 64 29 0a 20 20 20 20 20 20 vars cmd).
9010: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 (common:withou
9020: 74 2d 76 61 72 73 20 66 75 6c 6c 63 6d 64 20 22 t-vars fullcmd "
9030: 4d 54 5f 2e 2a 22 29 29 29 29 0a 09 09 20 20 0a MT_.*"))))... .
9040: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
9050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9080: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 49 20 ========.;; T I
9090: 4d 20 45 20 20 20 41 20 4e 20 44 20 20 20 44 20 M E A N D D
90a0: 41 20 54 20 45 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d A T E.;;========
90b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
90e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
90f0: 3b 3b 20 43 6f 6e 76 65 72 74 20 73 74 72 69 6e ;; Convert strin
9100: 67 73 20 6c 69 6b 65 20 22 35 73 20 32 68 20 33 gs like "5s 2h 3
9110: 6d 22 20 3d 3e 20 36 30 78 36 30 78 32 20 2b 20 m" => 60x60x2 +
9120: 33 78 36 30 20 2b 20 35 0a 28 64 65 66 69 6e 65 3x60 + 5.(define
9130: 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 72 (common:hms-str
9140: 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 74 73 74 ing->seconds tst
9150: 72 29 0a 20 20 28 6c 65 74 20 28 28 70 61 72 74 r). (let ((part
9160: 73 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 s (string-sp
9170: 6c 69 74 20 74 73 74 72 29 29 0a 09 28 74 69 6d lit tstr))..(tim
9180: 65 2d 73 65 63 73 20 30 29 0a 09 3b 3b 20 73 3d e-secs 0)..;; s=
9190: 73 65 63 6f 6e 64 73 2c 20 6d 3d 6d 69 6e 75 74 seconds, m=minut
91a0: 65 73 2c 20 68 3d 68 6f 75 72 73 2c 20 64 3d 64 es, h=hours, d=d
91b0: 61 79 73 0a 09 28 74 72 78 20 20 20 20 20 20 20 ays..(trx
91c0: 28 72 65 67 65 78 70 20 22 28 5c 5c 64 2b 29 28 (regexp "(\\d+)(
91d0: 5b 73 6d 68 64 5d 29 22 29 29 29 0a 20 20 20 20 [smhd])"))).
91e0: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
91f0: 61 20 28 70 61 72 74 29 0a 09 09 28 6c 65 74 20 a (part)...(let
9200: 28 28 6d 61 74 63 68 20 20 28 73 74 72 69 6e 67 ((match (string
9210: 2d 6d 61 74 63 68 20 74 72 78 20 70 61 72 74 29 -match trx part)
9220: 29 29 0a 09 09 20 20 28 69 66 20 6d 61 74 63 68 ))... (if match
9230: 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
9240: 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d val (string->num
9250: 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 ber (cadr match)
9260: 29 29 0a 09 09 09 20 20 20 20 28 75 6e 74 20 28 )).... (unt (
9270: 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 0a 09 caddr match)))..
9280: 09 09 28 69 66 20 76 61 6c 20 0a 09 09 09 20 20 ..(if val ....
9290: 20 20 28 73 65 74 21 20 74 69 6d 65 2d 73 65 63 (set! time-sec
92a0: 73 20 28 2b 20 74 69 6d 65 2d 73 65 63 73 20 28 s (+ time-secs (
92b0: 2a 20 76 61 6c 0a 09 09 09 09 09 09 09 20 20 20 * val........
92c0: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
92d0: 73 79 6d 62 6f 6c 20 75 6e 74 29 0a 09 09 09 09 symbol unt).....
92e0: 09 09 09 20 20 20 20 20 20 28 28 73 29 20 31 29 ... ((s) 1)
92f0: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 ........ ((
9300: 6d 29 20 36 30 29 0a 09 09 09 09 09 09 09 20 20 m) 60)........
9310: 20 20 20 20 28 28 68 29 20 28 2a 20 36 30 20 36 ((h) (* 60 6
9320: 30 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 0))........
9330: 20 28 28 64 29 20 28 2a 20 32 34 20 36 30 20 36 ((d) (* 24 60 6
9340: 30 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 0))........
9350: 20 28 65 6c 73 65 20 30 29 29 29 29 29 29 29 29 (else 0))))))))
9360: 29 29 0a 09 20 20 20 20 20 20 70 61 72 74 73 29 )).. parts)
9370: 0a 20 20 20 20 74 69 6d 65 2d 73 65 63 73 29 29 . time-secs))
9380: 0a 09 09 20 20 20 20 20 20 20 0a 28 64 65 66 69 ... .(defi
9390: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d ne (seconds->hr-
93a0: 6d 69 6e 2d 73 65 63 20 73 65 63 73 29 0a 20 20 min-sec secs).
93b0: 28 6c 65 74 2a 20 28 28 68 72 73 20 28 71 75 6f (let* ((hrs (quo
93c0: 74 69 65 6e 74 20 73 65 63 73 20 33 36 30 30 29 tient secs 3600)
93d0: 29 0a 09 20 28 6d 69 6e 20 28 71 75 6f 74 69 65 ).. (min (quotie
93e0: 6e 74 20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 nt (- secs (* hr
93f0: 73 20 33 36 30 30 29 29 20 36 30 29 29 0a 09 20 s 3600)) 60))..
9400: 28 73 65 63 20 28 2d 20 73 65 63 73 20 28 2a 20 (sec (- secs (*
9410: 68 72 73 20 33 36 30 30 29 28 2a 20 6d 69 6e 20 hrs 3600)(* min
9420: 36 30 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 60)))). (conc
9430: 20 28 69 66 20 28 3e 20 68 72 73 20 30 29 28 63 (if (> hrs 0)(c
9440: 6f 6e 63 20 68 72 73 20 22 68 72 20 22 29 20 22 onc hrs "hr ") "
9450: 22 29 0a 09 20 20 28 69 66 20 28 3e 20 6d 69 6e ").. (if (> min
9460: 20 30 29 28 63 6f 6e 63 20 6d 69 6e 20 22 6d 20 0)(conc min "m
9470: 22 29 20 20 22 22 29 0a 09 20 20 73 65 63 20 22 ") "").. sec "
9480: 73 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s")))..(define (
9490: 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 seconds->time-st
94a0: 72 69 6e 67 20 73 65 63 29 0a 20 20 28 74 69 6d ring sec). (tim
94b0: 65 2d 3e 73 74 72 69 6e 67 20 0a 20 20 20 28 73 e->string . (s
94c0: 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
94d0: 6d 65 20 73 65 63 29 20 22 25 48 3a 25 4d 3a 25 me sec) "%H:%M:%
94e0: 53 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 S"))..(define (s
94f0: 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 econds->work-wee
9500: 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 0a k/day-time sec).
9510: 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a (time->string.
9520: 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
9530: 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 77 77 al-time sec) "ww
9540: 25 56 2e 25 75 20 25 48 3a 25 4d 22 29 29 0a 0a %V.%u %H:%M"))..
9550: 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 (define (seconds
9560: 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 20 ->work-week/day
9570: 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
9580: 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
9590: 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
95a0: 29 20 22 77 77 25 56 2e 25 75 22 29 29 0a 0a 28 ) "ww%V.%u"))..(
95b0: 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d define (seconds-
95c0: 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f >year-work-week/
95d0: 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d 65 day sec). (time
95e0: 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 ->string. (sec
95f0: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
9600: 20 73 65 63 29 20 22 25 79 77 77 25 56 2e 25 77 sec) "%yww%V.%w
9610: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
9620: 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b conds->year-work
9630: 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 -week/day-time s
9640: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
9650: 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ing. (seconds-
9660: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
9670: 20 22 25 59 77 77 25 56 2e 25 77 20 25 48 3a 25 "%Yww%V.%w %H:%
9680: 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 M"))..(define (s
9690: 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 65 65 econds->year-wee
96a0: 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 0a k/day-time sec).
96b0: 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a (time->string.
96c0: 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
96d0: 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 59 al-time sec) "%Y
96e0: 77 25 56 2e 25 77 20 25 48 3a 25 4d 22 29 29 0a w%V.%w %H:%M")).
96f0: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
9700: 73 2d 3e 71 75 61 72 74 65 72 20 73 65 63 29 0a s->quarter sec).
9710: 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
9720: 3e 6e 75 6d 62 65 72 0a 09 20 28 74 69 6d 65 2d >number.. (time-
9730: 3e 73 74 72 69 6e 67 20 0a 09 20 20 28 73 65 63 >string .. (sec
9740: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
9750: 20 73 65 63 29 0a 09 20 20 22 25 6d 22 29 29 0a sec).. "%m")).
9760: 20 20 20 20 28 28 31 20 32 20 33 29 20 31 29 0a ((1 2 3) 1).
9770: 20 20 20 20 28 28 34 20 35 20 36 29 20 32 29 0a ((4 5 6) 2).
9780: 20 20 20 20 28 28 37 20 38 20 39 29 20 33 29 0a ((7 8 9) 3).
9790: 20 20 20 20 28 28 31 30 20 31 31 20 31 32 29 20 ((10 11 12)
97a0: 34 29 0a 20 20 20 20 28 65 6c 73 65 20 23 66 29 4). (else #f)
97b0: 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 73 70 61 ))..;; given spa
97c0: 6e 20 6f 66 20 73 65 63 6f 6e 64 73 20 74 73 74 n of seconds tst
97d0: 61 72 74 20 74 6f 20 74 65 6e 64 0a 3b 3b 20 66 art to tend.;; f
97e0: 69 6e 64 20 73 74 61 72 74 20 74 69 6d 65 20 74 ind start time t
97f0: 6f 20 6d 61 72 6b 20 61 6e 64 20 6d 61 72 6b 20 o mark and mark
9800: 64 65 6c 74 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 delta.;;.(define
9810: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 73 74 (common:find-st
9820: 61 72 74 2d 6d 61 72 6b 2d 61 6e 64 2d 6d 61 72 art-mark-and-mar
9830: 6b 2d 64 65 6c 74 61 20 74 73 74 61 72 74 20 74 k-delta tstart t
9840: 65 6e 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 end). (let* ((d
9850: 65 6c 74 61 74 20 20 20 28 2d 20 28 6d 61 78 20 eltat (- (max
9860: 74 65 6e 64 20 28 2b 20 74 65 6e 64 20 31 30 29 tend (+ tend 10)
9870: 29 20 74 73 74 61 72 74 29 29 20 3b 3b 20 63 61 ) tstart)) ;; ca
9880: 6e 27 74 20 68 61 6e 64 6c 65 20 72 75 6e 73 20 n't handle runs
9890: 6f 66 20 6c 65 73 73 20 74 68 61 6e 20 34 20 73 of less than 4 s
98a0: 65 63 6f 6e 64 73 2e 20 50 61 64 20 69 74 20 74 econds. Pad it t
98b0: 6f 20 31 30 20 73 65 63 6f 6e 64 73 20 2e 2e 2e o 10 seconds ...
98c0: 0a 09 20 28 72 65 73 75 6c 74 20 20 20 23 66 29 .. (result #f)
98d0: 0a 09 20 28 6d 69 6e 20 20 20 20 20 20 36 30 29 .. (min 60)
98e0: 0a 09 20 28 68 72 20 20 20 20 20 20 20 28 2a 20 .. (hr (*
98f0: 36 30 20 36 30 29 29 0a 09 20 28 64 61 79 20 20 60 60)).. (day
9900: 20 20 20 20 28 2a 20 32 34 20 68 72 29 29 0a 09 (* 24 hr))..
9910: 20 28 79 72 20 20 20 20 20 20 20 28 2a 20 33 36 (yr (* 36
9920: 35 20 64 61 79 29 29 20 3b 3b 20 79 65 61 72 0a 5 day)) ;; year.
9930: 09 20 28 6d 6f 20 20 20 20 20 20 20 28 2f 20 79 . (mo (/ y
9940: 72 20 31 32 29 29 0a 09 20 28 77 6b 20 20 20 20 r 12)).. (wk
9950: 20 20 20 28 2a 20 64 61 79 20 37 29 29 29 0a 20 (* day 7))).
9960: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
9970: 20 20 28 6c 61 6d 62 64 61 20 28 6d 61 78 2d 62 (lambda (max-b
9980: 6c 6b 73 29 0a 20 20 20 20 20 20 20 28 66 6f 72 lks). (for
9990: 2d 65 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 -each..(lambda (
99a0: 73 70 61 6e 29 20 3b 3b 20 35 20 32 20 31 0a 09 span) ;; 5 2 1..
99b0: 20 20 28 69 66 20 28 6e 6f 74 20 72 65 73 75 6c (if (not resul
99c0: 74 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d 65 t).. (for-e
99d0: 61 63 68 20 0a 09 20 20 20 20 20 20 20 28 6c 61 ach .. (la
99e0: 6d 62 64 61 20 28 74 69 6d 65 75 6e 69 74 20 74 mbda (timeunit t
99f0: 69 6d 65 73 79 6d 29 20 3b 3b 20 79 65 61 72 20 imesym) ;; year
9a00: 6d 6f 6e 74 68 20 64 61 79 20 68 72 20 6d 69 6e month day hr min
9a10: 20 73 65 63 0a 09 09 20 28 69 66 20 28 6e 6f 74 sec... (if (not
9a20: 20 72 65 73 75 6c 74 29 0a 09 09 20 20 20 20 20 result)...
9a30: 28 6c 65 74 2a 20 28 28 74 69 6d 65 2d 62 6c 6b (let* ((time-blk
9a40: 20 28 2a 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 (* span timeuni
9a50: 74 29 29 0a 09 09 09 20 20 20 20 28 6e 75 6d 2d t)).... (num-
9a60: 62 6c 6b 73 20 28 71 75 6f 74 69 65 6e 74 20 64 blks (quotient d
9a70: 65 6c 74 61 74 20 74 69 6d 65 2d 62 6c 6b 29 29 eltat time-blk))
9a80: 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 28 )... (if (
9a90: 61 6e 64 20 28 3e 20 6e 75 6d 2d 62 6c 6b 73 20 and (> num-blks
9aa0: 34 29 28 3c 20 6e 75 6d 2d 62 6c 6b 73 20 6d 61 4)(< num-blks ma
9ab0: 78 2d 62 6c 6b 73 29 29 0a 09 09 09 20 20 20 28 x-blks)).... (
9ac0: 6c 65 74 20 28 28 66 69 72 73 74 20 28 2a 20 28 let ((first (* (
9ad0: 71 75 6f 74 69 65 6e 74 20 74 73 74 61 72 74 20 quotient tstart
9ae0: 74 69 6d 65 2d 62 6c 6b 29 20 74 69 6d 65 2d 62 time-blk) time-b
9af0: 6c 6b 29 29 29 0a 09 09 09 20 20 20 20 20 28 73 lk))).... (s
9b00: 65 74 21 20 72 65 73 75 6c 74 20 28 6c 69 73 74 et! result (list
9b10: 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 20 74 span timeunit t
9b20: 69 6d 65 2d 62 6c 6b 20 66 69 72 73 74 20 74 69 ime-blk first ti
9b30: 6d 65 73 79 6d 29 29 0a 09 09 09 20 20 20 20 20 mesym))....
9b40: 29 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 6c ))))).. (l
9b50: 69 73 74 20 79 72 20 6d 6f 20 77 6b 20 64 61 79 ist yr mo wk day
9b60: 20 68 72 20 6d 69 6e 20 31 29 0a 09 20 20 20 20 hr min 1)..
9b70: 20 20 20 27 28 20 20 20 20 20 79 20 20 6d 6f 20 '( y mo
9b80: 77 20 20 64 20 20 20 68 20 20 6d 20 20 20 73 29 w d h m s)
9b90: 29 29 29 0a 09 28 6c 69 73 74 20 38 20 36 20 35 )))..(list 8 6 5
9ba0: 20 32 20 31 29 29 29 0a 20 20 20 20 20 27 28 35 2 1))). '(5
9bb0: 20 31 30 20 31 35 20 32 30 20 33 30 20 34 30 20 10 15 20 30 40
9bc0: 35 30 20 35 30 30 29 29 0a 20 20 20 20 28 69 66 50 500)). (if
9bd0: 20 76 61 6c 75 65 73 0a 09 28 61 70 70 6c 79 20 values..(apply
9be0: 76 61 6c 75 65 73 20 72 65 73 75 6c 74 29 0a 09 values result)..
9bf0: 28 76 61 6c 75 65 73 20 30 20 64 61 79 20 31 20 (values 0 day 1
9c00: 30 20 27 64 29 29 29 29 0a 09 20 20 20 20 0a 09 0 'd)))).. ..
9c10: 20 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;==========
9c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
9c60: 43 20 4f 20 4c 20 4f 20 52 20 53 0a 3b 3b 3d 3d C O L O R S.;;==
9c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9cb0: 3d 3d 3d 3d 0a 20 20 20 20 20 20 0a 28 64 65 66 ====. .(def
9cc0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6e 61 6d 65 ine (common:name
9cd0: 2d 3e 69 75 70 2d 63 6f 6c 6f 72 20 6e 61 6d 65 ->iup-color name
9ce0: 29 0a 20 20 28 63 61 73 65 20 28 73 74 72 69 6e ). (case (strin
9cf0: 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e g->symbol (strin
9d00: 67 2d 64 6f 77 6e 63 61 73 65 20 6e 61 6d 65 29 g-downcase name)
9d10: 29 0a 20 20 20 20 28 28 72 65 64 29 20 20 20 20 ). ((red)
9d20: 22 32 32 33 20 33 33 20 34 39 22 29 0a 20 20 20 "223 33 49").
9d30: 20 28 28 67 72 65 79 29 20 20 20 22 31 39 32 20 ((grey) "192
9d40: 31 39 32 20 31 39 32 22 29 0a 20 20 20 20 28 28 192 192"). ((
9d50: 6f 72 61 6e 67 65 29 20 22 32 35 35 20 31 37 32 orange) "255 172
9d60: 20 31 33 22 29 0a 20 20 20 20 28 28 70 75 72 70 13"). ((purp
9d70: 6c 65 29 20 22 54 68 69 73 20 69 73 20 75 6e 66 le) "This is unf
9d80: 69 6e 69 73 68 65 64 20 2e 2e 2e 22 29 29 29 0a inished ..."))).
9d90: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6f 6d .;; (define (com
9da0: 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 6f mon:get-color-fo
9db0: 72 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 73 r-state-status s
9dc0: 74 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 tate status).;;
9dd0: 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
9de0: 3e 73 79 6d 62 6f 6c 20 73 74 61 74 65 29 0a 3b >symbol state).;
9df0: 3b 20 20 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 ; ((COMPLETE
9e00: 44 29 0a 3b 3b 20 20 20 20 20 20 28 63 61 73 65 D).;; (case
9e10: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
9e20: 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 20 20 status).;;
9e30: 20 20 20 28 28 50 41 53 53 29 20 20 20 20 20 20 ((PASS)
9e40: 20 20 22 37 30 20 20 32 34 39 20 37 33 22 29 0a "70 249 73").
9e50: 3b 3b 20 20 20 20 20 20 20 20 28 28 57 41 52 4e ;; ((WARN
9e60: 20 57 41 49 56 45 44 29 20 22 32 35 35 20 31 37 WAIVED) "255 17
9e70: 32 20 31 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 2 13").;;
9e80: 20 28 28 53 4b 49 50 29 20 20 20 20 20 20 20 20 ((SKIP)
9e90: 22 32 33 30 20 32 33 30 20 30 22 29 0a 3b 3b 20 "230 230 0").;;
9ea0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 22 32 32 (else "22
9eb0: 33 20 33 33 20 34 39 22 29 29 29 0a 3b 3b 20 20 3 33 49"))).;;
9ec0: 20 20 20 28 28 4c 41 55 4e 43 48 45 44 29 20 20 ((LAUNCHED)
9ed0: 20 20 20 20 20 20 20 22 31 30 31 20 31 32 33 20 "101 123
9ee0: 31 34 32 22 29 0a 3b 3b 20 20 20 20 20 28 28 43 142").;; ((C
9ef0: 48 45 43 4b 29 20 20 20 20 20 20 20 20 20 20 20 HECK)
9f00: 20 22 32 35 35 20 31 30 30 20 35 30 22 29 0a 3b "255 100 50").;
9f10: 3b 20 20 20 20 20 28 28 52 45 4d 4f 54 45 48 4f ; ((REMOTEHO
9f20: 53 54 53 54 41 52 54 29 20 20 22 35 30 20 20 31 STSTART) "50 1
9f30: 33 30 20 31 39 35 22 29 0a 3b 3b 20 20 20 20 20 30 195").;;
9f40: 28 28 52 55 4e 4e 49 4e 47 29 20 20 20 20 20 20 ((RUNNING)
9f50: 20 20 20 20 22 39 20 20 20 31 33 31 20 32 33 32 "9 131 232
9f60: 22 29 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c ").;; ((KILL
9f70: 52 45 51 29 20 20 20 20 20 20 20 20 20 20 22 33 REQ) "3
9f80: 39 20 20 38 32 20 20 32 30 36 22 29 0a 3b 3b 20 9 82 206").;;
9f90: 20 20 20 20 28 28 4b 49 4c 4c 45 44 29 20 20 20 ((KILLED)
9fa0: 20 20 20 20 20 20 20 20 22 32 33 34 20 31 30 31 "234 101
9fb0: 20 31 37 22 29 0a 3b 3b 20 20 20 20 20 28 28 4e 17").;; ((N
9fc0: 4f 54 5f 53 54 41 52 54 45 44 29 20 20 20 20 20 OT_STARTED)
9fd0: 20 22 32 34 30 20 32 34 30 20 32 34 30 22 29 0a "240 240 240").
9fe0: 3b 3b 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 ;; (else
9ff0: 20 20 20 20 20 20 20 20 20 20 20 22 31 39 32 20 "192
a000: 31 39 32 20 31 39 32 22 29 29 29 0a 0a 28 64 65 192 192")))..(de
a010: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 69 75 70 fine (common:iup
a020: 2d 63 6f 6c 6f 72 2d 3e 72 67 62 2d 68 65 78 20 -color->rgb-hex
a030: 69 6e 73 74 72 29 0a 20 20 28 73 74 72 69 6e 67 instr). (string
a040: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 -intersperse .
a050: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
a060: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6e 75 6d ). (num
a070: 62 65 72 2d 3e 73 74 72 69 6e 67 20 78 20 31 36 ber->string x 16
a080: 29 29 0a 20 20 20 20 20 20 20 20 28 6d 61 70 20 )). (map
a090: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 20 string->number.
a0a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
a0b0: 69 6e 67 2d 73 70 6c 69 74 20 69 6e 73 74 72 29 ing-split instr)
a0c0: 29 29 0a 20 20 20 22 2f 22 29 29 0a 0a 28 64 65 )). "/"))..(de
a0d0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
a0e0: 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 -color-from-stat
a0f0: 75 73 20 73 74 61 74 75 73 29 0a 20 20 28 63 6f us status). (co
a100: 6e 64 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 nd. ((equal? s
a110: 74 61 74 75 73 20 22 50 41 53 53 22 29 20 20 20 tatus "PASS")
a120: 20 22 67 72 65 65 6e 22 29 0a 20 20 20 28 28 65 "green"). ((e
a130: 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 qual? status "FA
a140: 49 4c 22 29 20 20 20 20 22 72 65 64 22 29 0a 20 IL") "red").
a150: 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 ((equal? statu
a160: 73 20 22 57 41 52 4e 22 29 20 20 20 20 22 6f 72 s "WARN") "or
a170: 61 6e 67 65 22 29 0a 20 20 20 28 28 65 71 75 61 ange"). ((equa
a180: 6c 3f 20 73 74 61 74 75 73 20 22 4b 49 4c 4c 45 l? status "KILLE
a190: 44 22 29 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 D") "orange").
a1a0: 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 ((equal? statu
a1b0: 73 20 22 4b 49 4c 4c 52 45 51 22 29 20 22 70 75 s "KILLREQ") "pu
a1c0: 72 70 6c 65 22 29 0a 20 20 20 28 28 65 71 75 61 rple"). ((equa
a1d0: 6c 3f 20 73 74 61 74 75 73 20 22 52 55 4e 4e 49 l? status "RUNNI
a1e0: 4e 47 22 29 20 22 62 6c 75 65 22 29 0a 20 20 20 NG") "blue").
a1f0: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
a200: 22 41 42 4f 52 54 22 29 20 20 20 22 62 72 6f 77 "ABORT") "brow
a210: 6e 22 29 0a 20 20 20 28 65 6c 73 65 20 22 62 6c n"). (else "bl
a220: 61 63 6b 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d ack")))..;;=====
a230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a270: 3d 0a 3b 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 53 =.;; N A N O M S
a280: 20 47 20 20 20 43 20 4c 20 49 20 45 20 4e 20 54 G C L I E N T
a290: 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a2d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
a2e0: 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 ne (server:get-b
a2f0: 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 est-guess-addres
a300: 73 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c s hostname). (l
a310: 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 et ((res #f)).
a320: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
a330: 20 20 28 6c 61 6d 62 64 61 20 28 61 64 72 29 0a (lambda (adr).
a340: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
a350: 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 (eq? (u8vector-r
a360: 65 66 20 61 64 72 20 30 29 20 31 32 37 29 29 0a ef adr 0) 127)).
a370: 09 20 20 20 28 73 65 74 21 20 72 65 73 20 61 64 . (set! res ad
a380: 72 29 29 29 0a 20 20 20 20 20 3b 3b 20 4e 4f 54 r))). ;; NOT
a390: 45 3a 20 54 68 69 73 20 63 61 6e 20 66 61 69 6c E: This can fail
a3a0: 20 77 68 65 6e 20 74 68 65 72 65 20 69 73 20 6e when there is n
a3b0: 6f 20 6d 65 6e 74 69 6f 6e 20 6f 66 20 74 68 65 o mention of the
a3c0: 20 68 6f 73 74 20 69 6e 20 2f 65 74 63 2f 68 6f host in /etc/ho
a3d0: 73 74 73 2e 20 46 49 58 4d 45 0a 20 20 20 20 20 sts. FIXME.
a3e0: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 (vector->list (h
a3f0: 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 ostinfo-addresse
a400: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 s (hostname->hos
a410: 74 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 tinfo hostname))
a420: 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 )). (string-i
a430: 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 20 ntersperse .
a440: 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 (map number->st
a450: 72 69 6e 67 0a 09 20 20 28 75 38 76 65 63 74 6f ring.. (u8vecto
a460: 72 2d 3e 6c 69 73 74 0a 09 20 20 20 28 69 66 20 r->list.. (if
a470: 72 65 73 20 72 65 73 20 28 68 6f 73 74 6e 61 6d res res (hostnam
a480: 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 e->ip hostname))
a490: 29 29 20 22 2e 22 29 29 29 0a 0a 0a 28 64 65 66 )) ".")))...(def
a4a0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e 64 ine (common:send
a4b0: 2d 64 62 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 61 -dboard-main-cha
a4c0: 6e 67 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 nged). (let* ((
a4d0: 64 61 73 68 62 6f 61 72 64 2d 69 70 73 20 28 6d dashboard-ips (m
a4e0: 64 64 62 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 ddb:get-dashboar
a4f0: 64 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 ds))). (for-e
a500: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
a510: 20 28 69 70 61 64 72 29 0a 20 20 20 20 20 20 20 (ipadr).
a520: 28 6c 65 74 2a 20 28 28 73 6f 63 20 28 63 6f 6d (let* ((soc (com
a530: 6d 6f 6e 3a 6f 70 65 6e 2d 6e 6d 2d 72 65 71 20 mon:open-nm-req
a540: 28 63 6f 6e 63 20 22 74 63 70 3a 2f 2f 22 20 69 (conc "tcp://" i
a550: 70 61 64 72 29 29 29 0a 09 20 20 20 20 20 20 28 padr))).. (
a560: 6d 73 67 20 28 63 6f 6e 63 20 22 6d 61 69 6e 20 msg (conc "main
a570: 22 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 " *toppath*))..
a580: 20 20 20 20 20 28 72 65 73 20 28 63 6f 6d 6d 6f (res (commo
a590: 6e 3a 6e 6d 2d 73 65 6e 64 2d 72 65 63 65 69 76 n:nm-send-receiv
a5a0: 65 2d 74 69 6d 65 6f 75 74 20 73 6f 63 20 6d 73 e-timeout soc ms
a5b0: 67 29 29 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 g))).. (if (not
a5c0: 72 65 73 29 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 res) ;; couldn't
a5d0: 20 72 65 61 63 68 20 74 68 61 74 20 64 61 73 68 reach that dash
a5e0: 62 6f 61 72 64 20 2d 20 72 65 6d 6f 76 65 20 69 board - remove i
a5f0: 74 20 66 72 6f 6d 20 64 62 0a 09 20 20 20 20 20 t from db..
a600: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 63 (print "ERROR: c
a610: 6f 75 6c 64 6e 27 74 20 72 65 61 63 68 20 64 61 ouldn't reach da
a620: 73 68 62 6f 61 72 64 20 22 20 69 70 61 64 72 29 shboard " ipadr)
a630: 29 0a 09 20 72 65 73 29 29 0a 20 20 20 20 20 64 ).. res)). d
a640: 61 73 68 62 6f 61 72 64 2d 69 70 73 29 29 29 0a ashboard-ips))).
a650: 20 20 20 20 0a 20 20 20 20 0a 3b 3b 3d 3d 3d 3d . .;;====
a660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6a0: 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 48 20 42 20 ==.;; D A S H B
a6b0: 4f 20 41 20 52 20 44 20 20 20 44 20 42 20 0a 3b O A R D D B .;
a6c0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
a6d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a700: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
a710: 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 0a (mddb:open-db).
a720: 20 20 28 6c 65 74 2a 20 28 28 64 62 20 28 6f 70 (let* ((db (op
a730: 65 6e 2d 64 61 74 61 62 61 73 65 20 28 63 6f 6e en-database (con
a740: 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 c (get-environme
a750: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d nt-variable "HOM
a760: 45 22 29 20 22 2f 2e 64 61 73 68 62 6f 61 72 64 E") "/.dashboard
a770: 2e 64 62 22 29 29 29 29 0a 20 20 20 20 28 73 65 .db")))). (se
a780: 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 t-busy-handler!
a790: 64 62 20 28 62 75 73 79 2d 74 69 6d 65 6f 75 74 db (busy-timeout
a7a0: 20 31 30 30 30 30 29 29 0a 20 20 20 20 28 66 6f 10000)). (fo
a7b0: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
a7c0: 62 64 61 20 28 71 72 79 29 0a 20 20 20 20 20 20 bda (qry).
a7d0: 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 71 (exec (sql db q
a7e0: 72 79 29 29 29 0a 20 20 20 20 20 28 6c 69 73 74 ry))). (list
a7f0: 20 0a 20 20 20 20 20 20 22 43 52 45 41 54 45 20 . "CREATE
a800: 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 TABLE IF NOT EXI
a810: 53 54 53 20 76 61 72 73 20 20 20 20 20 20 20 28 STS vars (
a820: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
a830: 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c RY KEY,key TEXT,
a840: 20 76 61 6c 20 54 45 58 54 2c 20 43 4f 4e 53 54 val TEXT, CONST
a850: 52 41 49 4e 54 20 76 61 72 73 63 6f 6e 73 74 72 RAINT varsconstr
a860: 61 69 6e 74 20 55 4e 49 51 55 45 20 28 6b 65 79 aint UNIQUE (key
a870: 29 29 3b 22 0a 20 20 20 20 20 20 22 43 52 45 41 ));". "CREA
a880: 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 TE TABLE IF NOT
a890: 45 58 49 53 54 53 20 64 61 73 68 62 6f 61 72 64 EXISTS dashboard
a8a0: 73 20 28 0a 20 20 20 20 20 20 20 20 20 20 69 64 s (. id
a8b0: 20 20 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 INTEGER
a8c0: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 PRIMARY KEY,.
a8d0: 20 20 20 20 20 20 20 20 70 69 64 20 20 20 20 20 pid
a8e0: 20 20 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 INTEGER,.
a8f0: 20 20 20 20 20 20 75 73 65 72 6e 61 6d 65 20 20 username
a900: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
a910: 20 68 6f 73 74 6e 61 6d 65 20 20 20 54 45 58 54 hostname TEXT
a920: 2c 0a 20 20 20 20 20 20 20 20 20 20 69 70 61 64 ,. ipad
a930: 64 72 20 20 20 20 20 54 45 58 54 2c 0a 20 20 20 dr TEXT,.
a940: 20 20 20 20 20 20 20 70 6f 72 74 6e 75 6d 20 20 portnum
a950: 20 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 INTEGER,.
a960: 20 20 20 20 20 73 74 61 72 74 5f 74 69 6d 65 20 start_time
a970: 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 55 4c TIMESTAMP DEFAUL
a980: 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 T (strftime('%s'
a990: 2c 27 6e 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 ,'now')),.
a9a0: 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 49 4e CONSTRAIN
a9b0: 54 20 68 6f 73 74 70 6f 72 74 20 55 4e 49 51 55 T hostport UNIQU
a9c0: 45 20 28 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 E (hostname,port
a9d0: 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 29 3b 22 num). );"
a9e0: 0a 20 20 20 20 20 20 29 29 0a 20 20 20 20 64 62 . )). db
a9f0: 29 29 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 ))..;; register
aa00: 61 20 64 61 73 68 62 6f 61 72 64 20 0a 3b 3b 0a a dashboard .;;.
aa10: 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 72 65 (define (mddb:re
aa20: 67 69 73 74 65 72 2d 64 61 73 68 62 6f 61 72 64 gister-dashboard
aa30: 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 port). (let* (
aa40: 28 70 69 64 20 20 20 20 20 20 28 63 75 72 72 65 (pid (curre
aa50: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a nt-process-id)).
aa60: 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 . (hostname (get
aa70: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 -host-name)).. (
aa80: 69 70 61 64 64 72 20 20 20 28 73 65 72 76 65 72 ipaddr (server
aa90: 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d :get-best-guess-
aaa0: 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 address hostname
aab0: 29 29 0a 09 20 28 75 73 65 72 6e 61 6d 65 20 28 )).. (username (
aac0: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d current-user-nam
aad0: 65 29 29 20 3b 3b 20 28 63 61 72 20 75 73 65 72 e)) ;; (car user
aae0: 69 6e 66 6f 29 29 29 0a 09 20 28 64 62 20 20 20 info))).. (db
aaf0: 20 20 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 (mddb:open-db
ab00: 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 ))). (print "
ab10: 52 65 67 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 Register monitor
ab20: 2c 20 70 69 64 3a 20 22 20 70 69 64 20 22 2c 20 , pid: " pid ",
ab30: 68 6f 73 74 6e 61 6d 65 3a 20 22 20 68 6f 73 74 hostname: " host
ab40: 6e 61 6d 65 20 22 2c 20 70 6f 72 74 3a 20 22 20 name ", port: "
ab50: 70 6f 72 74 20 22 2c 20 75 73 65 72 6e 61 6d 65 port ", username
ab60: 3a 20 22 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 : " username).
ab70: 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 (exec (sql db
ab80: 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 "INSERT OR REPLA
ab90: 43 45 20 49 4e 54 4f 20 64 61 73 68 62 6f 61 72 CE INTO dashboar
aba0: 64 73 20 28 70 69 64 2c 75 73 65 72 6e 61 6d 65 ds (pid,username
abb0: 2c 68 6f 73 74 6e 61 6d 65 2c 69 70 61 64 64 72 ,hostname,ipaddr
abc0: 2c 70 6f 72 74 6e 75 6d 29 20 56 41 4c 55 45 53 ,portnum) VALUES
abd0: 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a (?,?,?,?,?);").
abe0: 09 20 20 20 70 69 64 20 75 73 65 72 6e 61 6d 65 . pid username
abf0: 20 68 6f 73 74 6e 61 6d 65 20 69 70 61 64 64 72 hostname ipaddr
ac00: 20 70 6f 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 port). (clos
ac10: 65 2d 64 61 74 61 62 61 73 65 20 64 62 29 29 29 e-database db)))
ac20: 0a 0a 3b 3b 20 75 6e 72 65 67 69 73 74 65 72 20 ..;; unregister
ac30: 61 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 0a 28 64 65 a monitor.;;.(de
ac40: 66 69 6e 65 20 28 6d 64 64 62 3a 75 6e 72 65 67 fine (mddb:unreg
ac50: 69 73 74 65 72 2d 64 61 73 68 62 6f 61 72 64 20 ister-dashboard
ac60: 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 host port). (le
ac70: 74 2a 20 28 28 64 62 20 20 20 20 20 20 28 6d 64 t* ((db (md
ac80: 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 db:open-db))).
ac90: 20 20 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 (print "Regist
aca0: 65 72 20 75 6e 72 65 67 69 73 74 65 72 20 6d 6f er unregister mo
acb0: 6e 69 74 6f 72 2c 20 68 6f 73 74 3a 70 6f 72 74 nitor, host:port
acc0: 3d 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 =" host ":" port
acd0: 29 0a 20 20 20 20 28 65 78 65 63 20 28 73 71 6c ). (exec (sql
ace0: 20 64 62 20 22 44 45 4c 45 54 45 20 46 52 4f 4d db "DELETE FROM
acf0: 20 64 61 73 68 62 6f 61 72 64 73 20 57 48 45 52 dashboards WHER
ad00: 45 20 68 6f 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 E hostname=? AND
ad10: 20 70 6f 72 74 6e 75 6d 3d 3f 3b 22 29 20 68 6f portnum=?;") ho
ad20: 73 74 20 70 6f 72 74 29 0a 20 20 20 20 28 63 6c st port). (cl
ad30: 6f 73 65 2d 64 61 74 61 62 61 73 65 20 64 62 29 ose-database db)
ad40: 29 29 0a 0a 3b 3b 20 67 65 74 20 72 65 67 69 73 ))..;; get regis
ad50: 74 65 72 65 64 20 64 61 73 68 62 6f 61 72 64 73 tered dashboards
ad60: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 .;;.(define (mdd
ad70: 62 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 64 73 b:get-dashboards
ad80: 29 0a 20 20 28 6c 65 74 20 28 28 64 62 20 28 6d ). (let ((db (m
ad90: 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 ddb:open-db))).
ada0: 20 20 20 28 71 75 65 72 79 20 66 65 74 63 68 2d (query fetch-
adb0: 63 6f 6c 75 6d 6e 0a 09 20 20 20 28 73 71 6c 20 column.. (sql
adc0: 64 62 20 22 53 45 4c 45 43 54 20 69 70 61 64 64 db "SELECT ipadd
add0: 72 20 7c 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 74 r || ':' || port
ade0: 6e 75 6d 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 num FROM dashboa
adf0: 72 64 73 3b 22 29 29 29 29 0a 20 20 20 20 0a 3b rds;")))). .;
ae00: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
ae10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ae40: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 =======.;; T E
ae50: 53 20 54 20 20 20 4c 20 41 20 55 20 4e 20 43 20 S T L A U N C
ae60: 48 20 49 20 4e 20 47 20 20 20 50 20 45 20 52 20 H I N G P E R
ae70: 20 20 49 20 54 20 45 20 4d 20 20 20 57 20 49 20 I T E M W I
ae80: 54 20 48 20 20 20 48 20 4f 20 53 20 54 20 20 20 T H H O S T
ae90: 54 20 59 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d 3d T Y P E S.;;====
aea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aeb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aee0: 3d 3d 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 2d ==.;; .;; [host-
aef0: 74 79 70 65 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 types].;; genera
af00: 6c 20 73 73 68 20 23 7b 67 65 74 62 67 65 73 74 l ssh #{getbgest
af10: 68 6f 73 74 20 67 65 6e 65 72 61 6c 7d 0a 3b 3b host general}.;;
af20: 20 6e 62 67 65 6e 65 72 61 6c 20 6e 62 6a 6f 62 nbgeneral nbjob
af30: 20 72 75 6e 20 4a 4f 42 43 4f 4d 4d 41 4e 44 20 run JOBCOMMAND
af40: 2d 6c 6f 67 20 24 4d 54 5f 4c 49 4e 4b 54 52 45 -log $MT_LINKTRE
af50: 45 2f 24 4d 54 5f 54 41 52 47 45 54 2f 24 4d 54 E/$MT_TARGET/$MT
af60: 5f 52 55 4e 4e 41 4d 45 2e 24 4d 54 5f 54 45 53 _RUNNAME.$MT_TES
af70: 54 4e 41 4d 45 2d 24 4d 54 5f 49 54 45 4d 5f 50 TNAME-$MT_ITEM_P
af80: 41 54 48 2e 6c 67 6f 0a 3b 3b 20 0a 3b 3b 20 5b ATH.lgo.;; .;; [
af90: 68 6f 73 74 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 hosts].;; genera
afa0: 6c 20 63 75 62 69 61 6e 20 78 65 6e 61 0a 3b 3b l cubian xena.;;
afb0: 20 0a 3b 3b 20 5b 6c 61 75 6e 63 68 65 72 73 5d .;; [launchers]
afc0: 0a 3b 3b 20 65 6e 76 73 65 74 75 70 20 67 65 6e .;; envsetup gen
afd0: 65 72 61 6c 0a 3b 3b 20 78 6f 72 2f 25 2f 6e 20 eral.;; xor/%/n
afe0: 34 43 31 36 47 0a 3b 3b 20 25 20 6e 62 67 65 6e 4C16G.;; % nbgen
aff0: 65 72 61 6c 0a 3b 3b 20 0a 3b 3b 20 5b 6a 6f 62 eral.;; .;; [job
b000: 74 6f 6f 6c 73 5d 0a 3b 3b 20 6c 61 75 6e 63 68 tools].;; launch
b010: 65 72 20 62 73 75 62 0a 3b 3b 20 23 20 69 66 20 er bsub.;; # if
b020: 64 65 66 69 6e 65 64 20 61 6e 64 20 6e 6f 74 20 defined and not
b030: 22 6e 6f 22 20 66 6c 65 78 69 2d 6c 61 75 6e 63 "no" flexi-launc
b040: 68 65 72 20 77 69 6c 6c 20 62 79 70 61 73 73 20 her will bypass
b050: 6c 61 75 6e 63 68 65 72 20 75 6e 6c 65 73 73 20 launcher unless
b060: 74 68 65 72 65 20 69 73 20 6e 6f 0a 3b 3b 20 23 there is no.;; #
b070: 20 6d 61 74 63 68 2e 0a 3b 3b 20 66 6c 65 78 69 match..;; flexi
b080: 2d 6c 61 75 6e 63 68 65 72 20 79 65 73 20 20 0a -launcher yes .
b090: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
b0a0: 3a 67 65 74 2d 6c 61 75 6e 63 68 65 72 20 63 6f :get-launcher co
b0b0: 6e 66 69 67 64 61 74 20 74 65 73 74 6e 61 6d 65 nfigdat testname
b0c0: 20 69 74 65 6d 70 61 74 68 29 0a 20 20 28 6c 65 itempath). (le
b0d0: 74 20 28 28 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 t ((fallback-lau
b0e0: 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c ncher (configf:l
b0f0: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 ookup configdat
b100: 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6c 61 75 6e "jobtools" "laun
b110: 63 68 65 72 22 29 29 29 0a 20 20 20 20 28 69 66 cher"))). (if
b120: 20 28 61 6e 64 20 28 63 6f 6e 66 69 67 66 3a 6c (and (configf:l
b130: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 ookup configdat
b140: 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 "jobtools" "flex
b150: 69 2d 6c 61 75 6e 63 68 65 72 22 29 20 3b 3b 20 i-launcher") ;;
b160: 6f 76 65 72 72 69 64 65 73 20 6c 61 75 6e 63 68 overrides launch
b170: 65 72 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 65 er.. (not (e
b180: 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c qual? (configf:l
b190: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 ookup configdat
b1a0: 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 "jobtools" "flex
b1b0: 69 2d 6c 61 75 6e 63 68 65 72 22 29 20 22 6e 6f i-launcher") "no
b1c0: 22 29 29 29 0a 09 28 6c 65 74 2a 20 28 28 6c 61 ")))..(let* ((la
b1d0: 75 6e 63 68 65 72 73 20 20 20 20 20 20 20 20 20 unchers
b1e0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
b1f0: 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 64 61 default configda
b200: 74 20 22 6c 61 75 6e 63 68 65 72 73 22 20 27 28 t "launchers" '(
b210: 29 29 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c )))).. (if (nul
b220: 6c 3f 20 6c 61 75 6e 63 68 65 72 73 29 0a 09 20 l? launchers)..
b230: 20 20 20 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 fallback-la
b240: 75 6e 63 68 65 72 0a 09 20 20 20 20 20 20 28 6c uncher.. (l
b250: 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
b260: 61 72 20 6c 61 75 6e 63 68 65 72 73 29 29 0a 09 ar launchers))..
b270: 09 09 20 28 74 61 6c 20 28 63 64 72 20 6c 61 75 .. (tal (cdr lau
b280: 6e 63 68 65 72 73 29 29 29 0a 09 09 28 6c 65 74 nchers)))...(let
b290: 20 28 28 70 61 74 74 20 20 20 20 20 20 28 63 61 ((patt (ca
b2a0: 72 20 68 65 64 29 29 0a 09 09 20 20 20 20 20 20 r hed))...
b2b0: 28 68 6f 73 74 2d 74 79 70 65 20 28 63 61 64 72 (host-type (cadr
b2c0: 20 68 65 64 29 29 29 0a 09 09 20 20 28 69 66 20 hed)))... (if
b2d0: 28 74 65 73 74 73 3a 6d 61 74 63 68 20 70 61 74 (tests:match pat
b2e0: 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 t testname itemp
b2f0: 61 74 68 29 0a 09 09 20 20 20 20 20 20 28 62 65 ath)... (be
b300: 67 69 6e 0a 09 09 09 28 64 65 62 75 67 3a 70 72 gin....(debug:pr
b310: 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 int-info 2 *defa
b320: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 48 ult-log-port* "H
b330: 61 76 65 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 ave flexi-launch
b340: 65 72 20 6d 61 74 63 68 20 66 6f 72 20 22 20 74 er match for " t
b350: 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d estname "/" item
b360: 70 61 74 68 20 22 20 3d 20 22 20 68 6f 73 74 2d path " = " host-
b370: 74 79 70 65 29 0a 09 09 09 28 6c 65 74 20 28 28 type)....(let ((
b380: 6c 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 launcher (config
b390: 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 f:lookup configd
b3a0: 61 74 20 22 68 6f 73 74 2d 74 79 70 65 73 22 20 at "host-types"
b3b0: 68 6f 73 74 2d 74 79 70 65 29 29 29 0a 09 09 09 host-type)))....
b3c0: 20 20 28 69 66 20 6c 61 75 6e 63 68 65 72 0a 09 (if launcher..
b3d0: 09 09 20 20 20 20 20 20 6c 61 75 6e 63 68 65 72 .. launcher
b3e0: 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 6e .... (begin
b3f0: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
b400: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
b410: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
b420: 4e 49 4e 47 3a 20 6e 6f 20 6c 61 75 6e 63 68 65 NING: no launche
b430: 72 20 66 6f 75 6e 64 20 66 6f 72 20 68 6f 73 74 r found for host
b440: 2d 74 79 70 65 20 22 20 68 6f 73 74 2d 74 79 70 -type " host-typ
b450: 65 29 0a 09 09 09 09 28 69 66 20 28 6e 75 6c 6c e).....(if (null
b460: 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 20 20 66 ? tal)..... f
b470: 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 allback-launcher
b480: 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 ..... (loop (
b490: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
b4a0: 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 )))))))...
b4b0: 3b 3b 20 6e 6f 20 6d 61 74 63 68 2c 20 74 72 79 ;; no match, try
b4c0: 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 20 28 again... (
b4d0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
b4e0: 09 09 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 .. fallback-lau
b4f0: 6e 63 68 65 72 0a 09 09 09 20 20 28 6c 6f 6f 70 ncher.... (loop
b500: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
b510: 61 6c 29 29 29 29 29 29 29 29 0a 09 66 61 6c 6c al))))))))..fall
b520: 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 29 29 29 back-launcher)))
b530: 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d . .;;==========
b540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
b580: 44 20 41 20 53 20 48 20 42 20 4f 20 41 20 52 20 D A S H B O A R
b590: 44 20 20 20 55 20 53 20 45 20 52 20 20 20 56 20 D U S E R V
b5a0: 49 20 45 20 57 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d I E W S.;;======
b5b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b5c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b5d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b5e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b5f0: 0a 0a 3b 3b 20 66 69 72 73 74 20 72 65 61 64 20 ..;; first read
b600: 7e 2f 76 69 65 77 73 2e 63 6f 6e 66 69 67 20 69 ~/views.config i
b610: 66 20 69 74 20 65 78 69 73 74 73 2c 20 74 68 65 f it exists, the
b620: 6e 20 72 65 61 64 20 24 4d 54 52 41 48 2f 76 69 n read $MTRAH/vi
b630: 65 77 73 2e 63 6f 6e 66 69 67 20 69 66 20 69 74 ews.config if it
b640: 20 65 78 69 73 74 73 0a 3b 3b 0a 28 64 65 66 69 exists.;;.(defi
b650: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 61 64 2d ne (common:load-
b660: 76 69 65 77 73 2d 63 6f 6e 66 69 67 29 0a 20 20 views-config).
b670: 28 6c 65 74 2a 20 28 28 76 69 65 77 2d 63 66 67 (let* ((view-cfg
b680: 64 61 74 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 dat (make-has
b690: 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 68 6f 6d h-table)).. (hom
b6a0: 65 2d 63 66 67 66 69 6c 65 20 20 20 28 63 6f 6e e-cfgfile (con
b6b0: 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 c (get-environme
b6c0: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d nt-variable "HOM
b6d0: 45 22 29 20 22 2f 2e 6d 74 76 69 65 77 73 2e 63 E") "/.mtviews.c
b6e0: 6f 6e 66 69 67 22 29 29 0a 09 20 28 6d 74 68 6f onfig")).. (mtho
b6f0: 6d 65 2d 63 66 67 66 69 6c 65 20 28 63 6f 6e 63 me-cfgfile (conc
b700: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e 6d 74 *toppath* "/.mt
b710: 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 29 29 29 views.config")))
b720: 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 . (if (file-e
b730: 78 69 73 74 73 3f 20 6d 74 68 6f 6d 65 2d 63 66 xists? mthome-cf
b740: 67 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 6f gfile)..(read-co
b750: 6e 66 69 67 20 6d 74 68 6f 6d 65 2d 63 66 67 66 nfig mthome-cfgf
b760: 69 6c 65 20 76 69 65 77 2d 63 66 67 64 61 74 20 ile view-cfgdat
b770: 23 74 29 29 0a 20 20 20 20 3b 3b 20 77 65 20 6c #t)). ;; we l
b780: 6f 61 64 20 74 68 65 20 68 6f 6d 65 20 64 69 72 oad the home dir
b790: 20 66 69 6c 65 20 41 46 54 45 52 20 74 68 65 20 file AFTER the
b7a0: 4d 54 52 41 48 20 66 69 6c 65 20 73 6f 20 74 68 MTRAH file so th
b7b0: 65 20 75 73 65 72 20 63 61 6e 20 63 6c 6f 62 62 e user can clobb
b7c0: 65 72 20 73 65 74 74 69 6e 67 73 20 77 68 65 6e er settings when
b7d0: 20 72 75 6e 6e 69 6e 67 20 74 68 65 20 64 61 73 running the das
b7e0: 68 62 6f 61 72 64 20 69 6e 20 72 65 61 64 2d 6f hboard in read-o
b7f0: 6e 6c 79 20 61 72 65 61 73 0a 20 20 20 20 28 69 nly areas. (i
b800: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
b810: 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a 09 28 home-cfgfile)..(
b820: 72 65 61 64 2d 63 6f 6e 66 69 67 20 68 6f 6d 65 read-config home
b830: 2d 63 66 67 66 69 6c 65 20 76 69 65 77 2d 63 66 -cfgfile view-cf
b840: 67 64 61 74 20 23 74 29 29 0a 20 20 20 20 76 69 gdat #t)). vi
b850: 65 77 2d 63 66 67 64 61 74 29 29 0a 0a ew-cfgdat))..