0000: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0040: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 70 79 ========.;; Copy
0050: 72 69 67 68 74 20 32 30 30 36 2d 32 30 31 32 2c right 2006-2012,
0060: 20 4d 61 74 74 68 65 77 20 57 65 6c 6c 61 6e 64 Matthew Welland
0070: 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 69 73 20 70 ..;; .;; This p
0080: 72 6f 67 72 61 6d 20 69 73 20 6d 61 64 65 20 61 rogram is made a
0090: 76 61 69 6c 61 62 6c 65 20 75 6e 64 65 72 20 74 vailable under t
00a0: 68 65 20 47 4e 55 20 47 50 4c 20 76 65 72 73 69 he GNU GPL versi
00b0: 6f 6e 20 32 2e 30 20 6f 72 0a 3b 3b 20 20 67 72 on 2.0 or.;; gr
00c0: 65 61 74 65 72 2e 20 53 65 65 20 74 68 65 20 61 eater. See the a
00d0: 63 63 6f 6d 70 61 6e 79 69 6e 67 20 66 69 6c 65 ccompanying file
00e0: 20 43 4f 50 59 49 4e 47 20 66 6f 72 20 64 65 74 COPYING for det
00f0: 61 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 54 68 ails..;; .;; Th
0100: 69 73 20 70 72 6f 67 72 61 6d 20 69 73 20 64 69 is program is di
0110: 73 74 72 69 62 75 74 65 64 20 57 49 54 48 4f 55 stributed WITHOU
0120: 54 20 41 4e 59 20 57 41 52 52 41 4e 54 59 3b 20 T ANY WARRANTY;
0130: 77 69 74 68 6f 75 74 20 65 76 65 6e 20 74 68 65 without even the
0140: 0a 3b 3b 20 20 69 6d 70 6c 69 65 64 20 77 61 72 .;; implied war
0150: 72 61 6e 74 79 20 6f 66 20 4d 45 52 43 48 41 4e ranty of MERCHAN
0160: 54 41 42 49 4c 49 54 59 20 6f 72 20 46 49 54 4e TABILITY or FITN
0170: 45 53 53 20 46 4f 52 20 41 20 50 41 52 54 49 43 ESS FOR A PARTIC
0180: 55 4c 41 52 0a 3b 3b 20 20 50 55 52 50 4f 53 45 ULAR.;; PURPOSE
0190: 2e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
01a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 ==========..(use
01e0: 20 73 72 66 69 2d 31 20 70 6f 73 69 78 20 72 65 srfi-1 posix re
01f0: 67 65 78 2d 63 61 73 65 20 62 61 73 65 36 34 20 gex-case base64
0200: 66 6f 72 6d 61 74 20 64 6f 74 2d 6c 6f 63 6b 69 format dot-locki
0210: 6e 67 20 63 73 76 2d 78 6d 6c 20 7a 33 20 73 71 ng csv-xml z3 sq
0220: 6c 2d 64 65 2d 6c 69 74 65 20 68 6f 73 74 69 6e l-de-lite hostin
0230: 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 65 2d 64 fo md5 message-d
0240: 69 67 65 73 74 20 74 79 70 65 64 2d 72 65 63 6f igest typed-reco
0250: 72 64 73 20 64 69 72 65 63 74 6f 72 79 2d 75 74 rds directory-ut
0260: 69 6c 73 29 0a 28 72 65 71 75 69 72 65 2d 65 78 ils).(require-ex
0270: 74 65 6e 73 69 6f 6e 20 72 65 67 65 78 20 70 6f tension regex po
0280: 73 69 78 29 0a 0a 28 72 65 71 75 69 72 65 2d 65 six)..(require-e
0290: 78 74 65 6e 73 69 6f 6e 20 28 73 72 66 69 20 31 xtension (srfi 1
02a0: 38 29 20 65 78 74 72 61 73 20 74 63 70 20 72 70 8) extras tcp rp
02b0: 63 29 0a 0a 28 69 6d 70 6f 72 74 20 28 70 72 65 c)..(import (pre
02c0: 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 fix sqlite3 sqli
02d0: 74 65 33 3a 29 29 0a 28 69 6d 70 6f 72 74 20 28 te3:)).(import (
02e0: 70 72 65 66 69 78 20 62 61 73 65 36 34 20 62 61 prefix base64 ba
02f0: 73 65 36 34 3a 29 29 0a 0a 28 64 65 63 6c 61 72 se64:))..(declar
0300: 65 20 28 75 6e 69 74 20 63 6f 6d 6d 6f 6e 29 29 e (unit common))
0310: 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d ..(include "comm
0320: 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 on_records.scm")
0330: 0a 0a 3b 3b 20 28 72 65 71 75 69 72 65 2d 6c 69 ..;; (require-li
0340: 62 72 61 72 79 20 6d 61 72 67 73 29 0a 3b 3b 20 brary margs).;;
0350: 28 69 6e 63 6c 75 64 65 20 22 6d 61 72 67 73 2e (include "margs.
0360: 73 63 6d 22 29 0a 0a 3b 3b 20 28 64 65 66 69 6e scm")..;; (defin
0370: 65 20 6f 6c 64 2d 65 78 69 74 20 65 78 69 74 29 e old-exit exit)
0380: 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 .;; .;; (define
0390: 28 65 78 69 74 20 2e 20 63 6f 64 65 29 0a 3b 3b (exit . code).;;
03a0: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6f (if (null? co
03b0: 64 65 29 0a 3b 3b 20 20 20 20 20 20 20 28 6f 6c de).;; (ol
03c0: 64 2d 65 78 69 74 29 0a 3b 3b 20 20 20 20 20 20 d-exit).;;
03d0: 20 28 6f 6c 64 2d 65 78 69 74 20 63 6f 64 65 29 (old-exit code)
03e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 67 65 74 65 ))..(define gete
03f0: 6e 76 20 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 nv get-environme
0400: 6e 74 2d 76 61 72 69 61 62 6c 65 29 0a 28 64 65 nt-variable).(de
0410: 66 69 6e 65 20 28 73 61 66 65 2d 73 65 74 65 6e fine (safe-seten
0420: 76 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 69 66 v key val). (if
0430: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 76 (and (string? v
0440: 61 6c 29 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 al)(string? key)
0450: 29 0a 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d ). (handle-
0460: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
0470: 20 20 65 78 6e 0a 20 20 20 20 20 20 20 28 64 65 exn. (de
0480: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
0490: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
04a0: 6f 72 74 2a 20 22 62 61 64 20 76 61 6c 75 65 20 ort* "bad value
04b0: 66 6f 72 20 73 65 74 65 6e 76 2c 20 6b 65 79 3d for setenv, key=
04c0: 22 20 6b 65 79 20 22 2c 20 76 61 6c 75 65 3d 22 " key ", value="
04d0: 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 val). (se
04e0: 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 29 0a 20 tenv key val)).
04f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
0500: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
0510: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 lt-log-port* "ba
0520: 64 20 76 61 6c 75 65 20 66 6f 72 20 73 65 74 65 d value for sete
0530: 6e 76 2c 20 6b 65 79 3d 22 20 6b 65 79 20 22 2c nv, key=" key ",
0540: 20 76 61 6c 75 65 3d 22 20 76 61 6c 29 29 29 0a value=" val))).
0550: 0a 28 64 65 66 69 6e 65 20 68 6f 6d 65 20 28 67 .(define home (g
0560: 65 74 65 6e 76 20 22 48 4f 4d 45 22 29 29 0a 28 etenv "HOME")).(
0570: 64 65 66 69 6e 65 20 75 73 65 72 20 28 67 65 74 define user (get
0580: 65 6e 76 20 22 55 53 45 52 22 29 29 0a 0a 3b 3b env "USER"))..;;
0590: 20 47 4c 4f 42 41 4c 20 47 4c 45 54 43 48 45 53 GLOBAL GLETCHES
05a0: 0a 0a 3b 3b 20 43 4f 4e 54 45 58 54 53 0a 28 64 ..;; CONTEXTS.(d
05b0: 65 66 73 74 72 75 63 74 20 63 78 74 0a 20 20 28 efstruct cxt. (
05c0: 74 61 73 6b 64 62 20 23 66 29 0a 20 20 28 63 6d taskdb #f). (cm
05d0: 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 utex (make-mutex
05e0: 29 29 29 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e ))).(define *con
05f0: 74 65 78 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 texts* (make-has
0600: 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e h-table)).(defin
0610: 65 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 65 78 e *context-mutex
0620: 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a * (make-mutex)).
0630: 0a 3b 3b 20 73 61 66 65 20 6d 65 74 68 6f 64 20 .;; safe method
0640: 66 6f 72 20 61 63 63 65 73 73 69 6e 67 20 61 20 for accessing a
0650: 63 6f 6e 74 65 78 74 20 67 69 76 65 6e 20 61 20 context given a
0660: 74 6f 70 70 61 74 68 0a 3b 3b 0a 28 64 65 66 69 toppath.;;.(defi
0670: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d ne (common:with-
0680: 63 78 74 20 74 6f 70 70 61 74 68 20 70 72 6f 63 cxt toppath proc
0690: 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 ). (mutex-lock!
06a0: 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a *context-mutex*
06b0: 29 0a 20 20 28 6c 65 74 20 28 28 63 78 74 20 28 ). (let ((cxt (
06c0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
06d0: 65 66 61 75 6c 74 20 2a 63 6f 6e 74 65 78 74 73 efault *contexts
06e0: 2a 20 74 6f 70 70 61 74 68 20 23 66 29 29 29 0a * toppath #f))).
06f0: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 63 78 74 (if (not cxt
0700: 29 0a 20 20 20 20 20 20 20 20 28 73 65 74 21 20 ). (set!
0710: 63 78 74 20 28 6c 65 74 20 28 28 78 20 28 6d 61 cxt (let ((x (ma
0720: 6b 65 2d 63 78 74 29 29 29 28 68 61 73 68 2d 74 ke-cxt)))(hash-t
0730: 61 62 6c 65 2d 73 65 74 21 20 2a 63 6f 6e 74 65 able-set! *conte
0740: 78 74 73 2a 20 74 6f 70 70 61 74 68 20 78 29 20 xts* toppath x)
0750: 78 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 x))). (let ((
0760: 63 78 74 2d 6d 75 74 65 78 20 28 63 78 74 2d 6d cxt-mutex (cxt-m
0770: 75 74 65 78 20 63 78 74 29 29 29 0a 20 20 20 20 utex cxt))).
0780: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
0790: 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a *context-mutex*
07a0: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 6c ). (mutex-l
07b0: 6f 63 6b 21 20 63 78 74 2d 6d 75 74 65 78 29 0a ock! cxt-mutex).
07c0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
07d0: 20 28 70 72 6f 63 20 63 78 74 29 29 29 0a 20 20 (proc cxt))).
07e0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
07f0: 6f 63 6b 21 20 63 78 74 2d 6d 75 74 65 78 29 0a ock! cxt-mutex).
0800: 20 20 20 20 20 20 20 20 72 65 73 29 29 29 29 0a res)))).
0810: 20 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 .(define
0820: 20 2a 64 62 2d 6b 65 79 73 2a 20 23 66 29 0a 0a *db-keys* #f)..
0830: 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 69 (define *configi
0840: 6e 66 6f 2a 20 20 20 23 66 29 20 20 20 3b 3b 20 nfo* #f) ;;
0850: 72 61 77 20 72 65 73 75 6c 74 73 20 66 72 6f 6d raw results from
0860: 20 73 65 74 75 70 2c 20 69 6e 63 6c 75 64 65 73 setup, includes
0870: 20 74 6f 70 70 61 74 68 20 61 6e 64 20 74 61 62 toppath and tab
0880: 6c 65 20 66 72 6f 6d 20 6d 65 67 61 74 65 73 74 le from megatest
0890: 2e 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 .config.(define
08a0: 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 23 *runconfigdat* #
08b0: 66 29 20 20 20 3b 3b 20 72 75 6e 20 63 6f 6e 66 f) ;; run conf
08c0: 69 67 73 20 64 61 74 61 0a 28 64 65 66 69 6e 65 igs data.(define
08d0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 20 20 20 *configdat*
08e0: 23 66 29 20 20 20 3b 3b 20 6d 65 67 61 74 65 73 #f) ;; megates
08f0: 74 2e 63 6f 6e 66 69 67 20 64 61 74 61 0a 28 64 t.config data.(d
0900: 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 73 74 61 efine *configsta
0910: 74 75 73 2a 20 23 66 29 20 20 20 3b 3b 20 73 74 tus* #f) ;; st
0920: 61 74 75 73 20 6f 66 20 64 61 74 61 3b 20 27 66 atus of data; 'f
0930: 75 6c 6c 64 61 74 61 20 3a 20 61 6c 6c 20 70 72 ulldata : all pr
0940: 6f 63 65 73 73 69 6e 67 20 64 6f 6e 65 2c 20 23 ocessing done, #
0950: 66 20 3a 20 6e 6f 20 64 61 74 61 20 79 65 74 2c f : no data yet,
0960: 20 27 70 61 72 74 69 61 6c 64 61 74 61 20 3a 20 'partialdata :
0970: 70 61 72 74 69 61 6c 20 72 65 61 64 20 64 6f 6e partial read don
0980: 65 0a 28 64 65 66 69 6e 65 20 2a 74 6f 70 70 61 e.(define *toppa
0990: 74 68 2a 20 20 20 20 20 20 23 66 29 0a 28 64 65 th* #f).(de
09a0: 66 69 6e 65 20 2a 61 6c 72 65 61 64 79 2d 73 65 fine *already-se
09b0: 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 en-runconfig-inf
09c0: 6f 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 o* #f)..(define
09d0: 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 *test-meta-updat
09e0: 65 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ed* (make-hash-t
09f0: 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a able)).(define *
0a00: 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 globalexitstatus
0a10: 2a 20 20 30 29 20 3b 3b 20 61 74 74 65 6d 70 74 * 0) ;; attempt
0a20: 20 74 6f 20 77 6f 72 6b 20 61 72 6f 75 6e 64 20 to work around
0a30: 70 6f 73 73 69 62 6c 65 20 74 68 72 65 61 64 20 possible thread
0a40: 69 73 73 75 65 73 0a 28 64 65 66 69 6e 65 20 2a issues.(define *
0a50: 70 61 73 73 6e 75 6d 2a 20 20 20 20 20 20 20 20 passnum*
0a60: 20 20 20 30 29 20 3b 3b 20 77 68 65 6e 20 72 75 0) ;; when ru
0a70: 6e 6e 69 6e 67 20 74 72 61 63 6b 20 63 61 6c 6c nning track call
0a80: 73 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 6f s to run-tests o
0a90: 72 20 73 69 6d 69 6c 61 72 0a 28 64 65 66 69 6e r similar.(defin
0aa0: 65 20 2a 61 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a e *alt-log-file*
0ab0: 20 23 66 29 20 20 3b 3b 20 75 73 65 64 20 62 79 #f) ;; used by
0ac0: 20 2d 6c 6f 67 0a 28 64 65 66 69 6e 65 20 2a 63 -log.(define *c
0ad0: 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 20 ommon:denoise*
0ae0: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
0af0: 6c 65 29 29 20 3b 3b 20 66 6f 72 20 6c 6f 77 20 le)) ;; for low
0b00: 6e 6f 69 73 65 20 70 72 69 6e 74 69 6e 67 0a 28 noise printing.(
0b10: 64 65 66 69 6e 65 20 2a 64 65 66 61 75 6c 74 2d define *default-
0b20: 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 63 75 72 72 log-port* (curr
0b30: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
0b40: 0a 28 64 65 66 69 6e 65 20 2a 74 69 6d 65 2d 7a .(define *time-z
0b50: 65 72 6f 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 ero* (current-se
0b60: 63 6f 6e 64 73 29 29 20 3b 3b 20 66 6f 72 20 74 conds)) ;; for t
0b70: 68 65 20 77 61 74 63 68 64 6f 67 0a 0a 3b 3b 20 he watchdog..;;
0b80: 44 41 54 41 42 41 53 45 0a 28 64 65 66 69 6e 65 DATABASE.(define
0b90: 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 20 *dbstruct-db*
0ba0: 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 75 73 #f) ;; us
0bb0: 65 64 20 74 6f 20 63 61 63 68 65 20 74 68 65 20 ed to cache the
0bc0: 64 62 73 74 72 75 63 74 20 69 6e 20 64 62 3a 73 dbstruct in db:s
0bd0: 65 74 75 70 2e 20 47 6f 61 6c 20 69 73 20 74 6f etup. Goal is to
0be0: 20 72 65 6d 6f 76 65 20 74 68 69 73 2e 0a 3b 3b remove this..;;
0bf0: 20 64 62 20 73 74 61 74 73 0a 28 64 65 66 69 6e db stats.(defin
0c00: 65 20 2a 64 62 2d 73 74 61 74 73 2a 20 20 20 20 e *db-stats*
0c10: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
0c20: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 61 sh-table)) ;; ha
0c30: 73 68 20 6f 66 20 76 65 63 74 6f 72 73 20 3c 20 sh of vectors <
0c40: 63 6f 75 6e 74 20 64 75 72 61 74 69 6f 6e 2d 74 count duration-t
0c50: 6f 74 61 6c 20 3e 0a 28 64 65 66 69 6e 65 20 2a otal >.(define *
0c60: 64 62 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 20 db-stats-mutex*
0c70: 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 (make-mutex
0c80: 29 29 0a 3b 3b 20 64 62 20 61 63 63 65 73 73 0a )).;; db access.
0c90: 28 64 65 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 (define *db-last
0ca0: 2d 61 63 63 65 73 73 2a 20 20 20 20 20 20 28 63 -access* (c
0cb0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
0cc0: 20 3b 3b 20 6c 61 73 74 20 64 62 20 61 63 63 65 ;; last db acce
0cd0: 73 73 2c 20 75 73 65 64 20 69 6e 20 73 65 72 76 ss, used in serv
0ce0: 65 72 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 77 er.(define *db-w
0cf0: 72 69 74 65 2d 61 63 63 65 73 73 2a 20 20 20 20 rite-access*
0d00: 20 23 74 29 0a 3b 3b 20 64 62 20 73 79 6e 63 0a #t).;; db sync.
0d10: 28 64 65 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 (define *db-last
0d20: 2d 77 72 69 74 65 2a 20 20 20 20 20 20 20 30 29 -write* 0)
0d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d40: 20 3b 3b 20 75 73 65 64 20 74 6f 20 72 65 63 6f ;; used to reco
0d50: 72 64 20 6c 61 73 74 20 74 6f 75 63 68 20 6f 66 rd last touch of
0d60: 20 64 62 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d db.(define *db-
0d70: 6c 61 73 74 2d 73 79 6e 63 2a 20 20 20 20 20 20 last-sync*
0d80: 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 0)
0d90: 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 74 69 6d ;; last tim
0da0: 65 20 74 68 65 20 73 79 6e 63 20 74 6f 20 6d 65 e the sync to me
0db0: 67 61 74 65 73 74 2e 64 62 20 68 61 70 70 65 6e gatest.db happen
0dc0: 65 64 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 ed.(define *db-s
0dd0: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a ync-in-progress*
0de0: 20 23 66 29 20 20 20 20 20 20 20 20 20 20 20 20 #f)
0df0: 20 20 20 20 3b 3b 20 69 66 20 74 68 65 72 65 20 ;; if there
0e00: 69 73 20 61 20 73 79 6e 63 20 69 6e 20 70 72 6f is a sync in pro
0e10: 67 72 65 73 73 20 64 6f 20 6e 6f 74 20 74 72 79 gress do not try
0e20: 20 74 6f 20 73 74 61 72 74 20 61 6e 6f 74 68 65 to start anothe
0e30: 72 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6d 75 r.(define *db-mu
0e40: 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 20 lti-sync-mutex*
0e50: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 20 20 (make-mutex))
0e60: 20 20 20 3b 3b 20 70 72 6f 74 65 63 74 20 61 63 ;; protect ac
0e70: 63 65 73 73 20 74 6f 20 2a 64 62 2d 73 79 6e 63 cess to *db-sync
0e80: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 2c 20 2a -in-progress*, *
0e90: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 61 6e db-last-sync* an
0ea0: 64 20 2a 64 62 2d 6c 61 73 74 2d 77 72 69 74 65 d *db-last-write
0eb0: 2a 0a 3b 3b 20 74 61 73 6b 20 64 62 0a 28 64 65 *.;; task db.(de
0ec0: 66 69 6e 65 20 2a 74 61 73 6b 2d 64 62 2a 20 20 fine *task-db*
0ed0: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 3b #f) ;
0ee0: 3b 20 28 76 65 63 74 6f 72 20 64 62 20 70 61 74 ; (vector db pat
0ef0: 68 2d 74 6f 2d 64 62 29 0a 28 64 65 66 69 6e 65 h-to-db).(define
0f00: 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f *db-access-allo
0f10: 77 65 64 2a 20 20 20 23 74 29 20 3b 3b 20 66 6c wed* #t) ;; fl
0f20: 61 67 20 74 6f 20 61 6c 6c 6f 77 20 61 63 63 65 ag to allow acce
0f30: 73 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 61 ss.(define *db-a
0f40: 63 63 65 73 73 2d 6d 75 74 65 78 2a 20 20 20 20 ccess-mutex*
0f50: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 (make-mutex)).(
0f60: 64 65 66 69 6e 65 20 2a 64 62 2d 63 61 63 68 65 define *db-cache
0f70: 2d 70 61 74 68 2a 20 20 20 20 20 20 20 23 66 29 -path* #f)
0f80: 0a 0a 3b 3b 20 53 45 52 56 45 52 0a 28 64 65 66 ..;; SERVER.(def
0f90: 69 6e 65 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 ine *my-client-s
0fa0: 69 67 6e 61 74 75 72 65 2a 20 23 66 29 0a 28 64 ignature* #f).(d
0fb0: 65 66 69 6e 65 20 2a 74 72 61 6e 73 70 6f 72 74 efine *transport
0fc0: 2d 74 79 70 65 2a 20 20 20 20 27 68 74 74 70 29 -type* 'http)
0fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
0fe0: 6f 76 65 72 72 69 64 65 20 77 69 74 68 20 5b 73 override with [s
0ff0: 65 72 76 65 72 5d 20 74 72 61 6e 73 70 6f 72 74 erver] transport
1000: 20 68 74 74 70 7c 72 70 63 7c 6e 6d 73 67 0a 28 http|rpc|nmsg.(
1010: 64 65 66 69 6e 65 20 2a 72 75 6e 72 65 6d 6f 74 define *runremot
1020: 65 2a 20 20 20 20 20 20 20 20 20 23 66 29 20 20 e* #f)
1030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
1040: 20 69 66 20 73 65 74 20 75 70 20 66 6f 72 20 73 if set up for s
1050: 65 72 76 65 72 20 63 6f 6d 6d 75 6e 69 63 61 74 erver communicat
1060: 69 6f 6e 20 74 68 69 73 20 77 69 6c 6c 20 68 6f ion this will ho
1070: 6c 64 20 3c 68 6f 73 74 20 70 6f 72 74 3e 0a 28 ld <host port>.(
1080: 64 65 66 69 6e 65 20 2a 6d 61 78 2d 63 61 63 68 define *max-cach
1090: 65 2d 73 69 7a 65 2a 20 20 20 20 30 29 0a 28 64 e-size* 0).(d
10a0: 65 66 69 6e 65 20 2a 6c 6f 67 67 65 64 2d 69 6e efine *logged-in
10b0: 2d 63 6c 69 65 6e 74 73 2a 20 28 6d 61 6b 65 2d -clients* (make-
10c0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 hash-table)).(de
10d0: 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 64 2a fine *server-id*
10e0: 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 #f).(de
10f0: 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 fine *server-inf
1100: 6f 2a 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 o* #f).(de
1110: 66 69 6e 65 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 fine *time-to-ex
1120: 69 74 2a 20 20 20 20 20 20 23 66 29 0a 28 64 65 it* #f).(de
1130: 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 72 75 6e fine *server-run
1140: 2a 20 20 20 20 20 20 20 20 23 74 29 0a 28 64 65 * #t).(de
1150: 66 69 6e 65 20 2a 72 75 6e 2d 69 64 2a 20 20 20 fine *run-id*
1160: 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 #f).(de
1170: 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 6b 69 6e fine *server-kin
1180: 64 2d 72 75 6e 2a 20 20 20 28 6d 61 6b 65 2d 68 d-run* (make-h
1190: 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 ash-table)).(def
11a0: 69 6e 65 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 ine *home-host*
11b0: 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 #f).(def
11c0: 69 6e 65 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 ine *total-non-w
11d0: 72 69 74 65 2d 64 65 6c 61 79 2a 20 30 29 0a 28 rite-delay* 0).(
11e0: 64 65 66 69 6e 65 20 2a 68 65 61 72 74 62 65 61 define *heartbea
11f0: 74 2d 6d 75 74 65 78 2a 20 20 20 28 6d 61 6b 65 t-mutex* (make
1200: 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b 20 52 50 43 -mutex))..;; RPC
1210: 20 74 72 61 6e 73 70 6f 72 74 0a 28 64 65 66 69 transport.(defi
1220: 6e 65 20 2a 72 70 63 3a 6c 69 73 74 65 6e 65 72 ne *rpc:listener
1230: 2a 20 20 20 20 20 20 23 66 29 0a 0a 3b 3b 20 4b * #f)..;; K
1240: 45 59 20 69 6e 66 6f 0a 28 64 65 66 69 6e 65 20 EY info.(define
1250: 2a 74 61 72 67 65 74 2a 20 20 20 20 20 20 20 20 *target*
1260: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1270: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
1280: 74 68 65 20 74 61 72 67 65 74 20 68 65 72 65 3b the target here;
1290: 20 74 61 72 67 65 74 20 69 73 20 6b 65 79 76 61 target is keyva
12a0: 6c 31 2f 6b 65 79 76 61 6c 32 2f 2e 2e 2e 2f 6b l1/keyval2/.../k
12b0: 65 79 76 61 6c 4e 0a 28 64 65 66 69 6e 65 20 2a eyvalN.(define *
12c0: 6b 65 79 73 2a 20 20 20 20 20 20 20 20 20 20 20 keys*
12d0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
12e0: 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 ble)) ;; cache t
12f0: 68 65 20 6b 65 79 73 20 68 65 72 65 0a 28 64 65 he keys here.(de
1300: 66 69 6e 65 20 2a 6b 65 79 76 61 6c 73 2a 20 20 fine *keyvals*
1310: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1320: 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 ash-table)).(def
1330: 69 6e 65 20 2a 74 6f 70 74 65 73 74 2d 70 61 74 ine *toptest-pat
1340: 68 73 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 hs* (make-ha
1350: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 sh-table)) ;; ca
1360: 63 68 65 20 74 6f 70 74 65 73 74 20 70 61 74 68 che toptest path
1370: 20 73 65 74 74 69 6e 67 73 20 68 65 72 65 0a 28 settings here.(
1380: 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 70 61 74 define *test-pat
1390: 68 73 2a 20 20 20 20 20 20 20 20 28 6d 61 6b 65 hs* (make
13a0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
13b0: 20 63 61 63 68 65 20 74 65 73 74 2d 69 64 20 74 cache test-id t
13c0: 6f 20 74 65 73 74 20 72 75 6e 20 70 61 74 68 73 o test run paths
13d0: 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 74 here.(define *t
13e0: 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 20 20 est-ids*
13f0: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
1400: 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 72 75 le)) ;; cache ru
1410: 6e 2d 69 64 2c 20 74 65 73 74 6e 61 6d 65 2c 20 n-id, testname,
1420: 61 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 3d 3e and item-path =>
1430: 20 74 65 73 74 2d 69 64 0a 28 64 65 66 69 6e 65 test-id.(define
1440: 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 20 20 *test-info*
1450: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1460: 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 table)) ;; cache
1470: 20 74 68 65 20 74 65 73 74 20 69 6e 66 6f 20 72 the test info r
1480: 65 63 6f 72 64 73 2c 20 75 70 64 61 74 65 20 74 ecords, update t
1490: 68 65 20 73 74 61 74 65 2c 20 73 74 61 74 75 73 he state, status
14a0: 2c 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 65 , run_duration e
14b0: 74 63 2e 20 66 72 6f 6d 20 74 65 73 74 64 61 74 tc. from testdat
14c0: 2e 64 62 0a 0a 28 64 65 66 69 6e 65 20 2a 72 75 .db..(define *ru
14d0: 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 20 20 n-info-cache*
14e0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
14f0: 65 29 29 20 3b 3b 20 72 75 6e 20 69 6e 66 6f 20 e)) ;; run info
1500: 69 73 20 73 74 61 62 6c 65 2c 20 6e 6f 20 6e 65 is stable, no ne
1510: 65 64 20 74 6f 20 72 65 67 65 74 0a 28 64 65 66 ed to reget.(def
1520: 69 6e 65 20 2a 6c 61 75 6e 63 68 2d 73 65 74 75 ine *launch-setu
1530: 70 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d p-mutex* (make-m
1540: 75 74 65 78 29 29 20 20 20 20 20 3b 3b 20 6e 65 utex)) ;; ne
1550: 65 64 20 74 6f 20 62 65 20 61 62 6c 65 20 74 6f ed to be able to
1560: 20 63 61 6c 6c 20 6c 61 75 6e 63 68 3a 73 65 74 call launch:set
1570: 75 70 20 6f 66 74 65 6e 20 73 6f 20 6d 75 74 65 up often so mute
1580: 78 20 69 74 20 61 6e 64 20 72 65 2d 63 61 6c 6c x it and re-call
1590: 20 74 68 65 20 72 65 61 6c 20 64 65 61 6c 20 6f the real deal o
15a0: 6e 6c 79 20 69 66 20 2a 74 6f 70 70 61 74 68 2a nly if *toppath*
15b0: 20 6e 6f 74 20 73 65 74 0a 28 64 65 66 69 6e 65 not set.(define
15c0: 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 *homehost-mutex
15d0: 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 * (make-mute
15e0: 78 29 29 0a 3b 3b 20 41 77 66 75 6c 2e 20 50 6c x)).;; Awful. Pl
15f0: 65 61 73 65 20 46 49 58 4d 45 0a 28 64 65 66 69 ease FIXME.(defi
1600: 6e 65 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d ne *env-vars-by-
1610: 72 75 6e 2d 69 64 2a 20 28 6d 61 6b 65 2d 68 61 run-id* (make-ha
1620: 73 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 54 sh-table))..;; T
1630: 65 73 74 63 6f 6e 66 69 67 20 61 6e 64 20 72 75 estconfig and ru
1640: 6e 63 6f 6e 66 69 67 20 63 61 63 68 65 73 2e 20 nconfig caches.
1650: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 63 6f .(define *testco
1660: 6e 66 69 67 73 2a 20 20 20 20 20 20 20 28 6d 61 nfigs* (ma
1670: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1680: 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 ;; test-name =>
1690: 74 65 73 74 63 6f 6e 66 69 67 0a 28 64 65 66 69 testconfig.(defi
16a0: 6e 65 20 2a 72 75 6e 63 6f 6e 66 69 67 73 2a 20 ne *runconfigs*
16b0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
16c0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 61 72 h-table)) ;; tar
16d0: 67 65 74 20 20 20 20 3d 3e 20 72 75 6e 63 6f 6e get => runcon
16e0: 66 69 67 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 fig..;; This is
16f0: 61 20 63 61 63 68 65 20 6f 66 20 70 72 65 2d 72 a cache of pre-r
1700: 65 71 73 20 6d 65 74 2c 20 64 6f 6e 27 74 20 72 eqs met, don't r
1710: 65 2d 63 61 6c 63 20 69 6e 20 63 61 73 65 73 20 e-calc in cases
1720: 77 68 65 72 65 20 63 61 6c 6c 65 64 20 77 69 74 where called wit
1730: 68 20 73 61 6d 65 20 70 61 72 61 6d 73 20 6c 65 h same params le
1740: 73 73 20 74 68 61 6e 0a 3b 3b 20 66 69 76 65 20 ss than.;; five
1750: 73 65 63 6f 6e 64 73 20 61 67 6f 0a 28 64 65 66 seconds ago.(def
1760: 69 6e 65 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 ine *pre-reqs-me
1770: 74 2d 63 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 t-cache* (make-h
1780: 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 ash-table))..;;
1790: 63 61 63 68 65 20 6f 66 20 76 65 72 62 6f 73 69 cache of verbosi
17a0: 74 79 20 67 69 76 65 6e 20 73 74 72 69 6e 67 0a ty given string.
17b0: 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 ;;.(define *verb
17c0: 6f 73 69 74 79 2d 63 61 63 68 65 2a 20 28 6d 61 osity-cache* (ma
17d0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
17e0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
17f0: 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 0a 20 :clear-caches).
1800: 20 28 73 65 74 21 20 2a 74 61 72 67 65 74 2a 20 (set! *target*
1810: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1820: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1830: 20 28 73 65 74 21 20 2a 6b 65 79 73 2a 20 20 20 (set! *keys*
1840: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1850: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1860: 20 28 73 65 74 21 20 2a 6b 65 79 76 61 6c 73 2a (set! *keyvals*
1870: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1880: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1890: 20 28 73 65 74 21 20 2a 74 6f 70 74 65 73 74 2d (set! *toptest-
18a0: 70 61 74 68 73 2a 20 20 20 20 20 20 28 6d 61 6b paths* (mak
18b0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
18c0: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 70 61 74 (set! *test-pat
18d0: 68 73 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b hs* (mak
18e0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
18f0: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 73 (set! *test-ids
1900: 2a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b * (mak
1910: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1920: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 6e 66 (set! *test-inf
1930: 6f 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b o* (mak
1940: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1950: 20 28 73 65 74 21 20 2a 72 75 6e 2d 69 6e 66 6f (set! *run-info
1960: 2d 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 6b -cache* (mak
1970: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1980: 20 28 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 (set! *env-vars
1990: 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 6b -by-run-id* (mak
19a0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
19b0: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 2d (set! *test-id-
19c0: 63 61 63 68 65 2a 20 20 20 20 20 20 28 6d 61 6b cache* (mak
19d0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
19e0: 0a 3b 3b 20 47 65 6e 65 72 69 63 20 73 74 72 69 .;; Generic stri
19f0: 6e 67 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 ng database.(def
1a00: 69 6e 65 20 73 64 62 3a 71 72 79 20 23 66 29 20 ine sdb:qry #f)
1a10: 3b 3b 20 28 6d 61 6b 65 2d 73 64 62 3a 71 72 79 ;; (make-sdb:qry
1a20: 29 29 20 3b 3b 20 20 27 69 6e 69 74 20 23 66 29 )) ;; 'init #f)
1a30: 0a 3b 3b 20 47 65 6e 65 72 69 63 20 70 61 74 68 .;; Generic path
1a40: 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e database.(defin
1a50: 65 20 2a 66 64 62 2a 20 23 66 29 0a 0a 28 64 65 e *fdb* #f)..(de
1a60: 66 69 6e 65 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 fine *last-launc
1a70: 68 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f h* (current-seco
1a80: 6e 64 73 29 29 20 3b 3b 20 75 73 65 20 66 6f 72 nds)) ;; use for
1a90: 20 74 68 72 6f 74 74 6c 69 6e 67 20 74 68 65 20 throttling the
1aa0: 6c 61 75 6e 63 68 20 72 61 74 65 2e 20 57 6f 75 launch rate. Wou
1ab0: 6c 64 20 62 65 20 62 65 74 74 65 72 20 74 6f 20 ld be better to
1ac0: 75 73 65 20 74 68 65 20 64 62 20 61 6e 64 20 6c use the db and l
1ad0: 61 73 74 20 74 69 6d 65 20 6f 66 20 61 20 74 65 ast time of a te
1ae0: 73 74 20 69 6e 20 4c 41 55 4e 43 48 45 44 20 73 st in LAUNCHED s
1af0: 74 61 74 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d tate...;;=======
1b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1b40: 3b 3b 20 56 20 45 20 52 20 53 20 49 20 4f 20 4e ;; V E R S I O N
1b50: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
1ba0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 ne (common:get-f
1bb0: 75 6c 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 ull-version). (
1bc0: 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 conc megatest-ve
1bd0: 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 rsion "-" megate
1be0: 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 st-fossil-hash))
1bf0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (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 0a 20 20 28 63 6f 6e 63 20 6d 65 67 ure). (conc meg
1c20: 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d atest-version "-
1c30: 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d 65 67 " (substring meg
1c40: 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 atest-fossil-has
1c50: 68 20 30 20 34 29 29 29 0a 0a 3b 3b 20 66 72 6f h 0 4)))..;; fro
1c60: 6d 20 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 70 m metadat lookup
1c70: 20 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f MEGATEST_VERSIO
1c80: 4e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f N.;;.(define (co
1c90: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
1ca0: 6e 2d 76 65 72 73 69 6f 6e 29 20 3b 3b 20 52 41 n-version) ;; RA
1cb0: 44 54 20 3d 3e 20 48 6f 77 20 64 6f 65 73 20 74 DT => How does t
1cc0: 68 69 73 20 77 6f 72 6b 20 69 6e 20 73 65 6e 64 his work in send
1cd0: 2d 72 65 63 65 69 76 65 20 66 75 6e 63 74 69 6f -receive functio
1ce0: 6e 3f 3f 3b 20 61 73 73 75 6d 65 20 69 74 20 69 n??; assume it i
1cf0: 73 20 74 68 65 20 76 61 6c 75 65 20 73 61 76 65 s the value save
1d00: 64 20 69 6e 20 73 6f 6d 65 20 44 42 0a 20 20 28 d in some DB. (
1d10: 72 6d 74 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 rmt:get-var "MEG
1d20: 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 29 29 ATEST_VERSION"))
1d30: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
1d40: 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:get-last-run-v
1d50: 65 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 ersion-number).
1d60: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
1d70: 20 0a 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 . (substring
1d80: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 (common:get-last
1d90: 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 30 20 -run-version) 0
1da0: 36 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6)))..(define (c
1db0: 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 ommon:set-last-r
1dc0: 75 6e 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 72 un-version). (r
1dd0: 6d 74 3a 73 65 74 2d 76 61 72 20 22 4d 45 47 41 mt:set-var "MEGA
1de0: 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 20 28 63 TEST_VERSION" (c
1df0: 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 ommon:version-si
1e00: 67 6e 61 74 75 72 65 29 29 29 0a 0a 28 64 65 66 gnature)))..(def
1e10: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 ine (common:vers
1e20: 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 ion-changed?).
1e30: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 63 6f (not (equal? (co
1e40: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
1e50: 6e 2d 76 65 72 73 69 6f 6e 29 0a 09 20 20 20 20 n-version)..
1e60: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 (common:versi
1e70: 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 29 29 on-signature))))
1e80: 0a 0a 3b 3b 20 4d 6f 76 65 20 6d 65 20 65 6c 73 ..;; Move me els
1e90: 65 77 68 65 72 65 20 2e 2e 2e 0a 3b 3b 20 52 41 ewhere ....;; RA
1ea0: 44 54 20 3d 3e 20 57 68 79 20 64 6f 20 77 65 20 DT => Why do we
1eb0: 6d 65 65 64 20 74 68 65 20 76 65 72 73 69 6f 6e meed the version
1ec0: 20 63 68 65 63 6b 20 68 65 72 65 2c 20 74 68 69 check here, thi
1ed0: 73 20 69 73 20 63 61 6c 6c 65 64 20 6f 6e 6c 79 s is called only
1ee0: 20 69 66 20 76 65 72 73 69 6f 6e 20 6d 69 73 6d if version mism
1ef0: 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f a.;;.(define (co
1f00: 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 70 2d 64 62 20 mmon:cleanup-db
1f10: 64 62 73 74 72 75 63 74 29 0a 20 20 28 64 62 3a dbstruct). (db:
1f20: 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 0a 20 multi-db-sync .
1f30: 20 20 64 62 73 74 72 75 63 74 0a 20 20 20 3b 3b dbstruct. ;;
1f40: 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 27 6b 69 'new2old. 'ki
1f50: 6c 6c 73 65 72 76 65 72 73 0a 20 20 20 27 64 65 llservers. 'de
1f60: 6a 75 6e 6b 0a 20 20 20 3b 3b 20 27 61 64 6a 2d junk. ;; 'adj-
1f70: 74 65 73 74 69 64 73 0a 20 20 20 3b 3b 20 27 6f testids. ;; 'o
1f80: 6c 64 32 6e 65 77 0a 20 20 20 27 6e 65 77 32 6f ld2new. 'new2o
1f90: 6c 64 0a 20 20 20 27 73 63 68 65 6d 61 29 0a 20 ld. 'schema).
1fa0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 (if (common:ver
1fb0: 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 sion-changed?).
1fc0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 (common:set
1fd0: 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f -last-run-versio
1fe0: 6e 29 29 29 0a 0a 3b 3b 20 52 6f 74 61 74 65 20 n)))..;; Rotate
1ff0: 6c 6f 67 73 2c 20 6c 6f 67 69 63 3a 20 0a 3b 3b logs, logic: .;;
2000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2010: 20 69 66 20 3e 20 35 30 30 6b 20 61 6e 64 20 6f if > 500k and o
2020: 6c 64 65 72 20 74 68 61 6e 20 31 20 77 65 65 6b lder than 1 week
2030: 3a 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 :.;;
2040: 20 20 20 20 20 20 20 20 20 72 65 6d 6f 76 65 20 remove
2050: 70 72 65 76 69 6f 75 73 20 63 6f 6d 70 72 65 73 previous compres
2060: 73 65 64 20 6c 6f 67 20 61 6e 64 20 63 6f 6d 70 sed log and comp
2070: 72 65 73 73 20 74 68 69 73 20 6c 6f 67 0a 3b 3b ress this log.;;
2080: 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 73 20 70 WARNING: This p
2090: 72 6f 63 20 6f 70 65 72 61 74 65 73 20 61 73 73 roc operates ass
20a0: 75 6d 69 6e 67 20 74 68 61 74 20 69 74 20 69 73 uming that it is
20b0: 20 69 6e 20 74 68 65 20 64 69 72 65 63 74 6f 72 in the director
20c0: 79 20 61 62 6f 76 65 20 74 68 65 0a 3b 3b 20 20 y above the.;;
20d0: 20 20 20 20 20 20 20 20 6c 6f 67 73 20 64 69 72 logs dir
20e0: 65 63 74 6f 72 79 20 79 6f 75 20 77 69 73 68 20 ectory you wish
20f0: 74 6f 20 6c 6f 67 2d 72 6f 74 61 74 65 2e 0a 3b to log-rotate..;
2100: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2110: 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 29 0a 20 n:rotate-logs).
2120: 20 28 69 66 20 28 6e 6f 74 20 28 64 69 72 65 63 (if (not (direc
2130: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 22 6c 6f tory-exists? "lo
2140: 67 73 22 29 29 28 63 72 65 61 74 65 2d 64 69 72 gs"))(create-dir
2150: 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 29 29 0a ectory "logs")).
2160: 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c (directory-fol
2170: 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 66 d . (lambda (f
2180: 69 6c 65 20 72 65 6d 29 0a 20 20 20 20 20 28 69 ile rem). (i
2190: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 2d 6d f (and (string-m
21a0: 61 74 63 68 20 22 5e 2e 2a 2e 6c 6f 67 22 20 66 atch "^.*.log" f
21b0: 69 6c 65 29 0a 09 20 20 20 20 20 20 28 3e 20 28 ile).. (> (
21c0: 66 69 6c 65 2d 73 69 7a 65 20 28 63 6f 6e 63 20 file-size (conc
21d0: 22 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 20 32 "logs/" file)) 2
21e0: 30 30 30 30 30 29 29 0a 09 20 28 6c 65 74 20 28 00000)).. (let (
21f0: 28 67 7a 66 69 6c 65 20 28 63 6f 6e 63 20 22 6c (gzfile (conc "l
2200: 6f 67 73 2f 22 20 66 69 6c 65 20 22 2e 67 7a 22 ogs/" file ".gz"
2210: 29 29 29 0a 09 20 20 20 28 69 66 20 28 66 69 6c ))).. (if (fil
2220: 65 2d 65 78 69 73 74 73 3f 20 67 7a 66 69 6c 65 e-exists? gzfile
2230: 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ).. (begin
2240: 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
2250: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
2260: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 6d 6f -log-port* "remo
2270: 76 69 6e 67 20 22 20 67 7a 66 69 6c 65 29 0a 09 ving " gzfile)..
2280: 09 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 67 . (delete-file g
2290: 7a 66 69 6c 65 29 29 29 0a 09 20 20 20 28 64 65 zfile))).. (de
22a0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
22b0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
22c0: 72 74 2a 20 22 63 6f 6d 70 72 65 73 73 69 6e 67 rt* "compressing
22d0: 20 22 20 66 69 6c 65 29 0a 09 20 20 20 28 73 79 " file).. (sy
22e0: 73 74 65 6d 20 28 63 6f 6e 63 20 22 67 7a 69 70 stem (conc "gzip
22f0: 20 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 29 29 logs/" file))))
2300: 29 0a 20 20 20 27 28 29 0a 20 20 20 22 6c 6f 67 ). '(). "log
2310: 73 22 29 29 0a 0a 3b 3b 20 46 6f 72 63 65 20 61 s"))..;; Force a
2320: 20 6d 65 67 61 74 65 73 74 20 63 6c 65 61 6e 75 megatest cleanu
2330: 70 2d 64 62 20 69 66 20 76 65 72 73 69 6f 6e 20 p-db if version
2340: 69 73 20 63 68 61 6e 67 65 64 20 61 6e 64 20 73 is changed and s
2350: 6b 69 70 2d 76 65 72 73 69 6f 6e 2d 63 68 65 63 kip-version-chec
2360: 6b 20 6e 6f 74 20 73 70 65 63 69 66 69 65 64 0a k not specified.
2370: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
2380: 6f 6e 3a 65 78 69 74 2d 6f 6e 2d 76 65 72 73 69 on:exit-on-versi
2390: 6f 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 69 on-changed). (i
23a0: 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f f (common:versio
23b0: 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 20 20 n-changed?).
23c0: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e (if (common:on
23d0: 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 20 28 -homehost?).. (
23e0: 6c 65 74 20 28 28 6d 74 63 6f 6e 66 20 28 63 6f let ((mtconf (co
23f0: 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d nc (get-environm
2400: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 ent-variable "MT
2410: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 _RUN_AREA_HOME")
2420: 20 22 2f 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 "/megatest.conf
2430: 69 67 22 29 29 0a 09 09 28 64 62 73 74 72 75 63 ig"))...(dbstruc
2440: 74 20 28 64 62 3a 73 65 74 75 70 29 29 29 0a 09 t (db:setup)))..
2450: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2460: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2470: 70 6f 72 74 2a 0a 09 09 09 20 22 57 41 52 4e 49 port*.... "WARNI
2480: 4e 47 3a 20 56 65 72 73 69 6f 6e 20 6d 69 73 6d NG: Version mism
2490: 61 74 63 68 21 5c 6e 22 0a 09 09 09 20 22 20 20 atch!\n".... "
24a0: 20 65 78 70 65 63 74 65 64 3a 20 22 20 28 63 6f expected: " (co
24b0: 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 mmon:version-sig
24c0: 6e 61 74 75 72 65 29 20 22 5c 6e 22 0a 09 09 09 nature) "\n"....
24d0: 20 22 20 20 20 67 6f 74 3a 20 20 20 20 20 20 22 " got: "
24e0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
24f0: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 29 0a t-run-version)).
2500: 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 . (if (and (f
2510: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 63 6f ile-exists? mtco
2520: 6e 66 29 0a 09 09 20 20 20 20 20 28 65 71 3f 20 nf)... (eq?
2530: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 (current-user-id
2540: 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 )(file-owner mtc
2550: 6f 6e 66 29 29 29 20 3b 3b 20 73 61 66 65 20 74 onf))) ;; safe t
2560: 6f 20 72 75 6e 20 2d 63 6c 65 61 6e 75 70 2d 64 o run -cleanup-d
2570: 62 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 b...(begin... (
2580: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2590: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
25a0: 20 22 20 20 20 49 20 73 65 65 20 79 6f 75 20 61 " I see you a
25b0: 72 65 20 74 68 65 20 6f 77 6e 65 72 20 6f 66 20 re the owner of
25c0: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 2c megatest.config,
25d0: 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 attempting to c
25e0: 6c 65 61 6e 75 70 20 61 6e 64 20 72 65 73 65 74 leanup and reset
25f0: 20 74 6f 20 6e 65 77 20 76 65 72 73 69 6f 6e 22 to new version"
2600: 29 0a 09 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 )... (handle-ex
2610: 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 65 78 ceptions... ex
2620: 6e 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 n... (begin...
2630: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
2640: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
2650: 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 74 -port* "Failed t
2660: 6f 20 73 77 69 74 63 68 20 76 65 72 73 69 6f 6e o switch version
2670: 73 2e 22 29 0a 09 09 20 20 20 20 20 28 64 65 62 s.")... (deb
2680: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
2690: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
26a0: 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
26b0: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
26c0: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
26d0: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 essage) exn))...
26e0: 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c (print-call
26f0: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
2700: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 09 20 error-port))...
2710: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 09 (exit 1))...
2720: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e (common:clean
2730: 75 70 2d 64 62 20 64 62 73 74 72 75 63 74 29 29 up-db dbstruct))
2740: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
2750: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2760: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2770: 20 22 20 74 6f 20 73 77 69 74 63 68 20 76 65 72 " to switch ver
2780: 73 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 72 75 sions you can ru
2790: 6e 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 2d 63 n: \"megatest -c
27a0: 6c 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a 09 09 leanup-db\"")...
27b0: 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 (exit 1))))..
27c0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 (begin.. (de
27d0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
27e0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
27f0: 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 6d 69 ERROR: cannot mi
2800: 67 72 61 74 65 20 76 65 72 73 69 6f 6e 20 75 6e grate version un
2810: 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 less on homehost
2820: 2e 20 45 78 69 74 69 6e 67 2e 22 29 0a 09 20 20 . Exiting.")..
2830: 20 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 0a (exit 1)))))..
2840: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
2850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2880: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 50 20 ========.;; S P
2890: 41 20 52 20 53 20 45 20 20 20 41 20 52 20 52 20 A R S E A R R
28a0: 41 20 59 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d A Y S.;;========
28b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
28e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
28f0: 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 70 (define (make-sp
2900: 61 72 73 65 2d 61 72 72 61 79 29 0a 20 20 28 6c arse-array). (l
2910: 65 74 20 28 28 61 20 28 6d 61 6b 65 2d 73 70 61 et ((a (make-spa
2920: 72 73 65 2d 76 65 63 74 6f 72 29 29 29 0a 20 20 rse-vector))).
2930: 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 (sparse-vector
2940: 2d 73 65 74 21 20 61 20 30 20 28 6d 61 6b 65 2d -set! a 0 (make-
2950: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 0a sparse-vector)).
2960: 20 20 20 20 61 29 29 0a 0a 28 64 65 66 69 6e 65 a))..(define
2970: 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 3f 20 (sparse-array?
2980: 61 29 0a 20 20 28 61 6e 64 20 28 73 70 61 72 73 a). (and (spars
2990: 65 2d 76 65 63 74 6f 72 3f 20 61 29 0a 20 20 20 e-vector? a).
29a0: 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 (sparse-vect
29b0: 6f 72 3f 20 28 73 70 61 72 73 65 2d 76 65 63 74 or? (sparse-vect
29c0: 6f 72 2d 72 65 66 20 61 20 30 29 29 29 29 0a 0a or-ref a 0))))..
29d0: 28 64 65 66 69 6e 65 20 28 73 70 61 72 73 65 2d (define (sparse-
29e0: 61 72 72 61 79 2d 72 65 66 20 61 20 78 20 79 29 array-ref a x y)
29f0: 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 . (let ((row (s
2a00: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 parse-vector-ref
2a10: 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 a x))). (if
2a20: 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 row..(sparse-vec
2a30: 74 6f 72 2d 72 65 66 20 72 6f 77 20 79 29 0a 09 tor-ref row y)..
2a40: 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)))..(define (
2a50: 73 70 61 72 73 65 2d 61 72 72 61 79 2d 73 65 74 sparse-array-set
2a60: 21 20 61 20 78 20 79 20 76 61 6c 29 0a 20 20 28 ! a x y val). (
2a70: 6c 65 74 20 28 28 72 6f 77 20 28 73 70 61 72 73 let ((row (spars
2a80: 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 78 e-vector-ref a x
2a90: 29 29 29 0a 20 20 20 20 28 69 66 20 72 6f 77 0a ))). (if row.
2aa0: 09 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d .(sparse-vector-
2ab0: 73 65 74 21 20 72 6f 77 20 79 20 76 61 6c 29 0a set! row y val).
2ac0: 09 28 6c 65 74 20 28 28 6e 65 77 2d 72 6f 77 20 .(let ((new-row
2ad0: 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 (make-sparse-vec
2ae0: 74 6f 72 29 29 29 0a 09 20 20 28 73 70 61 72 73 tor))).. (spars
2af0: 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 61 20 e-vector-set! a
2b00: 78 20 6e 65 77 2d 72 6f 77 29 0a 09 20 20 28 73 x new-row).. (s
2b10: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 parse-vector-set
2b20: 21 20 6e 65 77 2d 72 6f 77 20 79 20 76 61 6c 29 ! new-row y val)
2b30: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
2b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
2b80: 3b 20 4c 20 4f 20 43 20 4b 20 45 20 52 20 53 20 ; L O C K E R S
2b90: 20 20 41 20 4e 20 44 20 20 20 42 20 4c 20 4f 20 A N D B L O
2ba0: 43 20 4b 20 45 20 52 20 53 20 0a 3b 3b 3d 3d 3d C K E R S .;;===
2bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bf0: 3d 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 6b 20 66 75 ===..;; block fu
2c00: 72 74 68 65 72 20 61 63 63 65 73 73 65 73 20 74 rther accesses t
2c10: 6f 20 64 61 74 61 62 61 73 65 73 2e 20 43 61 6c o databases. Cal
2c20: 6c 20 74 68 69 73 20 62 65 66 6f 72 65 20 73 68 l this before sh
2c30: 75 74 74 69 6e 67 20 64 62 20 64 6f 77 6e 0a 28 utting db down.(
2c40: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 define (common:d
2c50: 62 2d 62 6c 6f 63 6b 2d 66 75 72 74 68 65 72 2d b-block-further-
2c60: 71 75 65 72 69 65 73 29 0a 20 20 28 6d 75 74 65 queries). (mute
2c70: 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 x-lock! *db-acce
2c80: 73 73 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 65 ss-mutex*). (se
2c90: 74 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c t! *db-access-al
2ca0: 6c 6f 77 65 64 2a 20 23 66 29 0a 20 20 28 6d 75 lowed* #f). (mu
2cb0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d tex-unlock! *db-
2cc0: 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 29 0a access-mutex*)).
2cd0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
2ce0: 3a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 :db-access-allow
2cf0: 65 64 3f 29 0a 20 20 28 6c 65 74 20 28 28 76 61 ed?). (let ((va
2d00: 6c 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 l (begin..
2d10: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 (mutex-lock! *d
2d20: 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 b-access-mutex*)
2d30: 0a 09 20 20 20 20 20 20 20 2a 64 62 2d 61 63 63 .. *db-acc
2d40: 65 73 73 2d 61 6c 6c 6f 77 65 64 2a 0a 09 20 20 ess-allowed*..
2d50: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
2d60: 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d ck! *db-access-m
2d70: 75 74 65 78 2a 29 29 29 29 0a 20 20 20 20 76 61 utex*)))). va
2d80: 6c 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d l))..;;=========
2d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
2dd0: 20 55 20 53 20 45 20 46 20 55 20 4c 20 20 20 53 U S E F U L S
2de0: 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d T U F F.;;=====
2df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e30: 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 74 68 =..;; convert th
2e40: 69 6e 67 73 20 74 6f 20 61 6e 20 61 6c 69 73 74 ings to an alist
2e50: 20 6f 72 20 61 73 73 6f 63 20 6c 69 73 74 2c 20 or assoc list,
2e60: 23 66 20 67 65 74 73 20 63 6f 6e 76 65 72 74 65 #f gets converte
2e70: 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 65 66 69 d to "".;;.(defi
2e80: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c ne (common:to-al
2e90: 69 73 74 20 64 61 74 29 0a 20 20 28 63 6f 6e 64 ist dat). (cond
2ea0: 0a 20 20 20 28 28 6c 69 73 74 3f 20 64 61 74 29 . ((list? dat)
2eb0: 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 (map common:t
2ec0: 6f 2d 61 6c 69 73 74 20 64 61 74 29 29 0a 20 20 o-alist dat)).
2ed0: 20 28 28 76 65 63 74 6f 72 3f 20 64 61 74 29 0a ((vector? dat).
2ee0: 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a (map common:
2ef0: 74 6f 2d 61 6c 69 73 74 20 28 76 65 63 74 6f 72 to-alist (vector
2f00: 2d 3e 6c 69 73 74 20 64 61 74 29 29 29 0a 20 20 ->list dat))).
2f10: 20 28 28 70 61 69 72 3f 20 64 61 74 29 0a 20 20 ((pair? dat).
2f20: 20 20 28 63 6f 6e 73 20 28 63 6f 6d 6d 6f 6e 3a (cons (common:
2f30: 74 6f 2d 61 6c 69 73 74 20 28 63 61 72 20 64 61 to-alist (car da
2f40: 74 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 74 t)).. (common:t
2f50: 6f 2d 61 6c 69 73 74 20 28 63 64 72 20 64 61 74 o-alist (cdr dat
2f60: 29 29 29 29 0a 20 20 20 28 28 68 61 73 68 2d 74 )))). ((hash-t
2f70: 61 62 6c 65 3f 20 64 61 74 29 0a 20 20 20 20 28 able? dat). (
2f80: 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c map common:to-al
2f90: 69 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ist (hash-table-
2fa0: 3e 61 6c 69 73 74 20 64 61 74 29 29 29 0a 20 20 >alist dat))).
2fb0: 20 28 65 6c 73 65 0a 20 20 20 20 28 69 66 20 64 (else. (if d
2fc0: 61 74 0a 09 64 61 74 0a 09 22 22 29 29 29 29 0a at..dat.."")))).
2fd0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
2fe0: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
2ff0: 20 77 61 69 74 76 61 6c 20 2e 20 6b 65 79 73 29 waitval . keys)
3000: 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 . (let* ((key
3010: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
3020: 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e rsperse (map con
3030: 63 20 6b 65 79 73 29 20 22 2d 22 20 29 29 0a 09 c keys) "-" ))..
3040: 20 28 6c 61 73 74 74 69 6d 65 20 28 68 61 73 68 (lasttime (hash
3050: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
3060: 6c 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 lt *common:denoi
3070: 73 65 2a 20 6b 65 79 20 30 29 29 0a 09 20 28 63 se* key 0)).. (c
3080: 75 72 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 urrtime (current
3090: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 -seconds))).
30a0: 28 69 66 20 28 3e 20 28 2d 20 63 75 72 72 74 69 (if (> (- currti
30b0: 6d 65 20 6c 61 73 74 74 69 6d 65 29 20 77 61 69 me lasttime) wai
30c0: 74 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 tval)..(begin..
30d0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
30e0: 21 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 ! *common:denois
30f0: 65 2a 20 6b 65 79 20 63 75 72 72 74 69 6d 65 29 e* key currtime)
3100: 0a 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a .. #t)..#f)))..
3110: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
3120: 67 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 get-megatest-exe
3130: 29 0a 20 20 28 6f 72 20 28 67 65 74 65 6e 76 20 ). (or (getenv
3140: 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 29 20 22 "MT_MEGATEST") "
3150: 6d 65 67 61 74 65 73 74 22 29 29 0a 0a 28 64 65 megatest"))..(de
3160: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 fine (common:rea
3170: 64 2d 65 6e 63 6f 64 65 64 2d 73 74 72 69 6e 67 d-encoded-string
3180: 20 69 6e 73 74 72 29 0a 20 20 28 68 61 6e 64 6c instr). (handl
3190: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
31a0: 65 78 6e 0a 20 20 20 28 68 61 6e 64 6c 65 2d 65 exn. (handle-e
31b0: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 65 78 xceptions. ex
31c0: 6e 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 n. (begin.
31d0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
31e0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
31f0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 65 -log-port* "rece
3200: 69 76 65 64 20 62 61 64 20 65 6e 63 6f 64 65 64 ived bad encoded
3210: 20 73 74 72 69 6e 67 20 5c 22 22 20 69 6e 73 74 string \"" inst
3220: 72 20 22 5c 22 2c 20 6d 65 73 73 61 67 65 3a 20 r "\", message:
3230: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
3240: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
3250: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
3260: 78 6e 29 29 0a 20 20 20 20 20 20 28 70 72 69 6e xn)). (prin
3270: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
3280: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
3290: 29 29 0a 20 20 20 20 20 20 23 66 29 0a 20 20 20 )). #f).
32a0: 20 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 (read (open-inp
32b0: 75 74 2d 73 74 72 69 6e 67 20 28 62 61 73 65 36 ut-string (base6
32c0: 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 4:base64-decode
32d0: 69 6e 73 74 72 29 29 29 29 0a 20 20 20 28 72 65 instr)))). (re
32e0: 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 ad (open-input-s
32f0: 74 72 69 6e 67 20 28 7a 33 3a 64 65 63 6f 64 65 tring (z3:decode
3300: 2d 62 75 66 66 65 72 20 28 62 61 73 65 36 34 3a -buffer (base64:
3310: 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 6e base64-decode in
3320: 73 74 72 29 29 29 29 29 29 0a 0a 3b 3b 20 64 6f str))))))..;; do
3330: 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 20 73 65 t-locking egg se
3340: 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c ems not to work,
3350: 20 75 73 69 6e 67 20 74 68 69 73 20 66 6f 72 20 using this for
3360: 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 now.;; if lock i
3370: 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 65 78 70 s older than exp
3380: 69 72 65 2d 74 69 6d 65 20 74 68 65 6e 20 72 65 ire-time then re
3390: 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 72 79 20 move it and try
33a0: 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 again.;; to get
33b0: 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 the lock.;;.(def
33c0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 ine (common:simp
33d0: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 le-file-lock fna
33e0: 6d 65 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 me #!key (expire
33f0: 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 69 -time 300)). (i
3400: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
3410: 66 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 69 66 fname). (if
3420: 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (> (- (current-
3430: 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f seconds)(file-mo
3440: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
3450: 66 6e 61 6d 65 29 29 20 65 78 70 69 72 65 2d 74 fname)) expire-t
3460: 69 6d 65 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 ime).. (begin..
3470: 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 (delete-file
3480: 2a 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 28 63 * fname).. (c
3490: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
34a0: 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 e-lock fname exp
34b0: 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 ire-time: expire
34c0: 2d 74 69 6d 65 29 29 0a 09 20 20 23 66 29 0a 20 -time)).. #f).
34d0: 20 20 20 20 20 28 6c 65 74 20 28 28 6b 65 79 2d (let ((key-
34e0: 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 67 65 string (conc (ge
34f0: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d 22 t-host-name) "-"
3500: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
3510: 73 2d 69 64 29 29 29 29 0a 09 28 77 69 74 68 2d s-id))))..(with-
3520: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 output-to-file f
3530: 6e 61 6d 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 name.. (lambda
3540: 28 29 0a 09 20 20 20 20 28 70 72 69 6e 74 20 6b ().. (print k
3550: 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 28 74 ey-string)))..(t
3560: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 hread-sleep! 0.2
3570: 35 29 0a 09 28 69 66 20 28 66 69 6c 65 2d 65 78 5)..(if (file-ex
3580: 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 20 20 ists? fname)..
3590: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
35a0: 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 om-file fname..
35b0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
35c0: 09 09 28 65 71 75 61 6c 3f 20 6b 65 79 2d 73 74 ..(equal? key-st
35d0: 72 69 6e 67 20 28 72 65 61 64 2d 6c 69 6e 65 29 ring (read-line)
35e0: 29 29 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a ))).. #f)))).
35f0: 09 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
3600: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 n:simple-file-re
3610: 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 lease-lock fname
3620: 29 0a 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 ). (delete-file
3630: 2a 20 66 6e 61 6d 65 29 29 0a 0a 3b 3b 3d 3d 3d * fname))..;;===
3640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3680: 3d 3d 3d 0a 3b 3b 20 53 20 54 20 41 20 54 20 45 ===.;; S T A T E
3690: 20 53 20 20 20 41 20 4e 20 44 20 20 20 53 20 54 S A N D S T
36a0: 20 41 20 54 20 55 20 53 20 45 20 53 0a 3b 3b 3d A T U S E S.;;=
36b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
36f0: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a =====..(define *
3700: 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 65 common:std-state
3710: 73 2a 20 20 20 0a 20 20 27 28 28 30 20 22 41 52 s* . '((0 "AR
3720: 43 48 49 56 45 44 22 29 0a 20 20 20 20 28 31 20 CHIVED"). (1
3730: 22 53 54 55 43 4b 22 29 0a 20 20 20 20 28 32 20 "STUCK"). (2
3740: 22 4b 49 4c 4c 52 45 51 22 29 0a 20 20 20 20 28 "KILLREQ"). (
3750: 33 20 22 4b 49 4c 4c 45 44 22 29 0a 20 20 20 20 3 "KILLED").
3760: 28 34 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 (4 "NOT_STARTED"
3770: 29 0a 20 20 20 20 28 35 20 22 43 4f 4d 50 4c 45 ). (5 "COMPLE
3780: 54 45 44 22 29 0a 20 20 20 20 28 36 20 22 4c 41 TED"). (6 "LA
3790: 55 4e 43 48 45 44 22 29 0a 20 20 20 20 28 37 20 UNCHED"). (7
37a0: 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 "REMOTEHOSTSTART
37b0: 22 29 0a 20 20 20 20 28 38 20 22 52 55 4e 4e 49 "). (8 "RUNNI
37c0: 4e 47 22 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 NG"). ))..(de
37d0: 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 fine *common:std
37e0: 2d 73 74 61 74 75 73 65 73 2a 0a 20 20 27 28 3b -statuses*. '(;
37f0: 3b 20 28 30 20 22 44 45 4c 45 54 45 44 22 29 0a ; (0 "DELETED").
3800: 20 20 20 20 28 31 20 22 6e 2f 61 22 29 0a 20 20 (1 "n/a").
3810: 20 20 28 32 20 22 50 41 53 53 22 29 0a 20 20 20 (2 "PASS").
3820: 20 28 33 20 22 43 48 45 43 4b 22 29 0a 20 20 20 (3 "CHECK").
3830: 20 28 34 20 22 53 4b 49 50 22 29 0a 20 20 20 20 (4 "SKIP").
3840: 28 35 20 22 57 41 52 4e 22 29 0a 20 20 20 20 28 (5 "WARN"). (
3850: 36 20 22 57 41 49 56 45 44 22 29 0a 20 20 20 20 6 "WAIVED").
3860: 28 37 20 22 53 54 55 43 4b 2f 44 45 41 44 22 29 (7 "STUCK/DEAD")
3870: 0a 20 20 20 20 28 38 20 22 46 41 49 4c 22 29 0a . (8 "FAIL").
3880: 20 20 20 20 28 39 20 22 41 42 4f 52 54 22 29 29 (9 "ABORT"))
3890: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d )..(define *comm
38a0: 6f 6e 3a 65 6e 64 65 64 2d 73 74 61 74 65 73 2a on:ended-states*
38b0: 20 3b 3b 20 73 74 61 74 65 73 20 77 68 69 63 68 ;; states which
38c0: 20 69 6e 64 69 63 61 74 65 20 74 68 65 20 74 65 indicate the te
38d0: 73 74 20 69 73 20 73 74 6f 70 70 65 64 20 61 6e st is stopped an
38e0: 64 20 77 69 6c 6c 20 6e 6f 74 20 70 72 6f 63 65 d will not proce
38f0: 65 64 0a 20 20 27 28 22 43 4f 4d 50 4c 45 54 45 ed. '("COMPLETE
3900: 44 22 20 22 41 52 43 48 49 56 45 44 22 20 22 4b D" "ARCHIVED" "K
3910: 49 4c 4c 45 44 22 20 22 4b 49 4c 4c 52 45 51 22 ILLED" "KILLREQ"
3920: 20 22 53 54 55 43 4b 22 20 22 49 4e 43 4f 4d 50 "STUCK" "INCOMP
3930: 4c 45 54 45 22 29 29 0a 0a 28 64 65 66 69 6e 65 LETE"))..(define
3940: 20 2a 63 6f 6d 6d 6f 6e 3a 62 61 64 6c 79 2d 65 *common:badly-e
3950: 6e 64 65 64 2d 73 74 61 74 65 73 2a 20 3b 3b 20 nded-states* ;;
3960: 74 68 65 73 65 20 72 6f 6c 6c 20 75 70 20 61 73 these roll up as
3970: 20 43 48 45 43 4b 2c 20 69 2e 65 2e 20 72 65 73 CHECK, i.e. res
3980: 75 6c 74 73 20 6e 65 65 64 20 74 6f 20 62 65 20 ults need to be
3990: 63 68 65 63 6b 65 64 0a 20 20 27 28 22 4b 49 4c checked. '("KIL
39a0: 4c 45 44 22 20 22 4b 49 4c 4c 52 45 51 22 20 22 LED" "KILLREQ" "
39b0: 53 54 55 43 4b 22 20 22 49 4e 43 4f 4d 50 4c 45 STUCK" "INCOMPLE
39c0: 54 45 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 TE"))..(define (
39d0: 63 6f 6d 6d 6f 6e 3a 73 70 65 63 69 61 6c 2d 73 common:special-s
39e0: 6f 72 74 20 69 74 65 6d 73 20 6f 72 64 65 72 20 ort items order
39f0: 63 6f 6d 70 29 0a 20 20 28 6c 65 74 20 28 28 69 comp). (let ((i
3a00: 74 65 6d 73 2d 6f 72 64 65 72 20 28 6d 61 70 20 tems-order (map
3a10: 72 65 76 65 72 73 65 20 6f 72 64 65 72 29 29 0a reverse order)).
3a20: 20 20 20 20 20 20 20 20 28 61 63 6f 6d 70 20 20 (acomp
3a30: 20 20 20 20 20 28 6f 72 20 63 6f 6d 70 20 3e 29 (or comp >)
3a40: 29 29 0a 20 20 20 20 28 73 6f 72 74 20 69 74 65 )). (sort ite
3a50: 6d 73 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 ms. (lamb
3a60: 64 61 20 28 61 20 62 29 0a 20 20 20 20 20 20 20 da (a b).
3a70: 20 20 20 28 6c 65 74 20 28 28 61 2d 6e 75 6d 20 (let ((a-num
3a80: 28 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f 63 (cadr (or (assoc
3a90: 20 61 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 20 a items-order)
3aa0: 27 28 30 20 30 29 29 29 29 0a 20 20 20 20 20 20 '(0 0)))).
3ab0: 20 20 20 20 20 20 20 20 20 20 28 62 2d 6e 75 6d (b-num
3ac0: 20 28 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f (cadr (or (asso
3ad0: 63 20 62 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 c b items-order)
3ae0: 20 27 28 30 20 30 29 29 29 29 29 0a 20 20 20 20 '(0 0))))).
3af0: 20 20 20 20 20 20 20 20 28 61 63 6f 6d 70 20 61 (acomp a
3b00: 2d 6e 75 6d 20 62 2d 6e 75 6d 29 29 29 29 29 29 -num b-num))))))
3b10: 0a 0a 3b 3b 20 54 68 65 73 65 20 61 72 65 20 73 ..;; These are s
3b20: 74 6f 70 70 69 6e 67 20 63 6f 6e 64 69 74 69 6f topping conditio
3b30: 6e 73 20 74 68 61 74 20 70 72 65 76 65 6e 74 20 ns that prevent
3b40: 61 20 74 65 73 74 20 66 72 6f 6d 20 62 65 69 6e a test from bein
3b50: 67 20 72 75 6e 0a 28 64 65 66 69 6e 65 20 2a 63 g run.(define *c
3b60: 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 ommon:cant-run-s
3b70: 74 61 74 65 73 2d 73 79 6d 2a 20 0a 20 20 27 28 tates-sym* . '(
3b80: 43 4f 4d 50 4c 45 54 45 44 20 4b 49 4c 4c 45 44 COMPLETED KILLED
3b90: 20 57 41 49 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 WAIVED UNKNOWN
3ba0: 49 4e 43 4f 4d 50 4c 45 54 45 20 41 42 4f 52 54 INCOMPLETE ABORT
3bb0: 20 41 52 43 48 49 56 45 44 29 29 0a 0a 3b 3b 20 ARCHIVED))..;;
3bc0: 67 69 76 65 6e 20 61 20 74 6f 70 6c 65 76 65 6c given a toplevel
3bd0: 20 77 69 74 68 20 63 75 72 72 73 74 61 74 65 2c with currstate,
3be0: 20 63 75 72 72 73 74 61 74 75 73 20 61 70 70 6c currstatus appl
3bf0: 79 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 y state and stat
3c00: 75 73 0a 3b 3b 20 20 3d 3e 20 28 6e 65 77 73 74 us.;; => (newst
3c10: 61 74 65 20 2e 20 6e 65 77 73 74 61 74 75 73 29 ate . newstatus)
3c20: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
3c30: 3a 61 70 70 6c 79 2d 73 74 61 74 65 2d 73 74 61 :apply-state-sta
3c40: 74 75 73 20 63 75 72 72 73 74 61 74 65 20 63 75 tus currstate cu
3c50: 72 72 73 74 61 74 75 73 20 73 74 61 74 65 20 73 rrstatus state s
3c60: 74 61 74 75 73 29 0a 20 20 28 6c 65 74 2a 20 28 tatus). (let* (
3c70: 28 63 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 (cstate (string
3c80: 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 ->symbol (string
3c90: 2d 64 6f 77 6e 63 61 73 65 20 63 75 72 72 73 74 -downcase currst
3ca0: 61 74 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 ate))).
3cb0: 28 63 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 (cstatus (string
3cc0: 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 ->symbol (string
3cd0: 2d 64 6f 77 6e 63 61 73 65 20 63 75 72 72 73 74 -downcase currst
3ce0: 61 74 75 73 29 29 29 0a 20 20 20 20 20 20 20 20 atus))).
3cf0: 20 28 73 73 74 61 74 65 20 20 28 73 74 72 69 6e (sstate (strin
3d00: 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e g->symbol (strin
3d10: 67 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 65 g-downcase state
3d20: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 73 ))). (ss
3d30: 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 tatus (string->s
3d40: 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f ymbol (string-do
3d50: 77 6e 63 61 73 65 20 73 74 61 74 75 73 29 29 29 wncase status)))
3d60: 0a 20 20 20 20 20 20 20 20 20 28 6e 73 74 61 74 . (nstat
3d70: 65 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 e #f).
3d80: 28 6e 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 (nstatus #f)).
3d90: 20 20 28 73 65 74 21 20 6e 73 74 61 74 65 0a 20 (set! nstate.
3da0: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 63 (case c
3db0: 73 74 61 74 65 0a 20 20 20 20 20 20 20 20 20 20 state.
3dc0: 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6e 6f ((completed no
3dd0: 74 5f 73 74 61 72 74 65 64 20 6b 69 6c 6c 65 64 t_started killed
3de0: 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 killreq stuck a
3df0: 72 63 68 69 76 65 64 29 20 0a 20 20 20 20 20 20 rchived) .
3e00: 20 20 20 20 20 20 20 28 63 61 73 65 20 73 73 74 (case sst
3e10: 61 74 65 20 3b 3b 20 63 6f 6d 70 6c 65 74 65 64 ate ;; completed
3e20: 20 2d 3e 20 73 73 74 61 74 65 0a 20 20 20 20 20 -> sstate.
3e30: 20 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 ((comp
3e40: 6c 65 74 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c leted killed kil
3e50: 6c 72 65 71 20 73 74 75 63 6b 20 61 72 63 68 69 lreq stuck archi
3e60: 76 65 64 29 20 63 6f 6d 70 6c 65 74 65 64 29 0a ved) completed).
3e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3e80: 28 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 (running remoteh
3e90: 6f 73 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 oststart launche
3ea0: 64 29 20 20 20 20 20 20 20 20 72 75 6e 6e 69 6e d) runnin
3eb0: 67 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 g).
3ec0: 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 (else
3ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 75 6e 6b unk
3ef0: 6e 6f 77 6e 2d 65 72 72 6f 72 2d 31 29 29 29 0a nown-error-1))).
3f00: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 72 75 ((ru
3f10: 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 nning remotehost
3f20: 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 0a start launched).
3f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
3f40: 73 65 20 73 73 74 61 74 65 0a 20 20 20 20 20 20 se sstate.
3f50: 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c ((compl
3f60: 65 74 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c eted killed kill
3f70: 72 65 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 req stuck archiv
3f80: 65 64 29 20 23 66 29 20 3b 3b 20 6e 65 65 64 20 ed) #f) ;; need
3f90: 74 6f 20 6c 6f 6f 6b 20 61 74 20 61 6c 6c 20 69 to look at all i
3fa0: 74 65 6d 73 0a 20 20 20 20 20 20 20 20 20 20 20 tems.
3fb0: 20 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 65 ((running re
3fc0: 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 20 6c 61 motehoststart la
3fd0: 75 6e 63 68 65 64 29 20 20 20 20 20 20 20 20 72 unched) r
3fe0: 75 6e 6e 69 6e 67 29 0a 20 20 20 20 20 20 20 20 unning).
3ff0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
4000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4020: 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d unknown-error-
4030: 32 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 2))).
4040: 20 28 65 6c 73 65 20 75 6e 6b 6e 6f 77 6e 2d 65 (else unknown-e
4050: 72 72 6f 72 2d 33 29 29 29 0a 20 20 20 20 28 73 rror-3))). (s
4060: 65 74 21 20 6e 73 74 61 74 75 73 0a 20 20 20 20 et! nstatus.
4070: 20 20 20 20 20 20 28 63 61 73 65 20 73 73 74 61 (case ssta
4080: 74 75 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 tus.
4090: 28 28 70 61 73 73 29 0a 20 20 20 20 20 20 20 20 ((pass).
40a0: 20 20 20 20 20 28 63 61 73 65 20 6e 73 74 61 74 (case nstat
40b0: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e.
40c0: 20 28 28 70 61 73 73 20 6e 2f 61 20 64 65 6c 65 ((pass n/a dele
40d0: 74 65 64 29 20 20 20 20 20 70 61 73 73 29 0a 20 ted) pass).
40e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
40f0: 77 61 72 6e 29 20 20 20 20 20 20 20 20 20 20 20 warn)
4100: 20 20 20 20 20 20 77 61 72 6e 29 0a 20 20 20 20 warn).
4110: 20 20 20 20 20 20 20 20 20 20 20 28 28 66 61 69 ((fai
4120: 6c 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 l)
4130: 20 20 20 66 61 69 6c 29 0a 20 20 20 20 20 20 20 fail).
4140: 20 20 20 20 20 20 20 20 28 28 63 68 65 63 6b 29 ((check)
4150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 c
4160: 68 65 63 6b 29 0a 20 20 20 20 20 20 20 20 20 20 heck).
4170: 20 20 20 20 20 28 28 77 61 69 76 65 64 29 20 20 ((waived)
4180: 20 20 20 20 20 20 20 20 20 20 20 77 61 69 76 65 waive
4190: 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d).
41a0: 20 20 28 28 73 6b 69 70 29 20 20 20 20 20 20 20 ((skip)
41b0: 20 20 20 20 20 20 20 20 20 20 73 6b 69 70 29 0a skip).
41c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
41d0: 28 73 74 75 63 6b 2f 64 65 61 64 29 20 20 20 20 (stuck/dead)
41e0: 20 20 20 20 20 20 73 74 75 63 6b 29 0a 20 20 20 stuck).
41f0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 62 ((ab
4200: 6f 72 74 29 20 20 20 20 20 20 20 20 20 20 20 20 ort)
4210: 20 20 20 61 62 6f 72 74 29 0a 20 20 20 20 20 20 abort).
4220: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 (else
4230: 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 unknown-er
4240: 72 6f 72 2d 34 29 29 29 0a 20 20 20 20 20 20 20 ror-4))).
4250: 20 20 20 20 20 28 28 77 61 72 6e 29 0a 20 20 20 ((warn).
4260: 20 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 (case
4270: 6e 73 74 61 74 65 0a 20 20 20 20 20 20 20 20 20 nstate.
4280: 20 20 20 20 20 20 28 28 70 61 73 73 20 77 61 72 ((pass war
4290: 6e 20 6e 2f 61 20 73 6b 69 70 20 64 65 6c 65 74 n n/a skip delet
42a0: 65 64 29 20 20 20 77 61 72 6e 29 0a 20 20 20 20 ed) warn).
42b0: 20 20 20 20 20 20 20 20 20 20 20 28 28 66 61 69 ((fai
42c0: 6c 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 l)
42d0: 20 20 20 20 20 20 20 20 20 20 20 66 61 69 6c 29 fail)
42e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
42f0: 28 28 63 68 65 63 6b 29 20 20 20 20 20 20 20 20 ((check)
4300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 c
4310: 68 65 63 6b 29 0a 20 20 20 20 20 20 20 20 20 20 heck).
4320: 20 20 20 20 20 28 28 77 61 69 76 65 64 29 20 20 ((waived)
4330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4340: 20 20 20 77 61 69 76 65 64 29 0a 20 20 20 20 20 waived).
4350: 20 20 20 20 20 20 20 20 20 20 28 28 73 74 75 63 ((stuc
4360: 6b 2f 64 65 61 64 29 20 20 20 20 20 20 20 20 20 k/dead)
4370: 20 20 20 20 20 20 20 20 20 73 74 75 63 6b 29 0a stuck).
4380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4390: 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 else
43a0: 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f unknown-erro
43b0: 72 2d 35 29 29 29 0a 20 20 20 20 20 20 20 20 20 r-5))).
43c0: 20 20 20 28 28 66 61 69 6c 29 0a 20 20 20 20 20 ((fail).
43d0: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 (case ns
43e0: 74 61 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 tate.
43f0: 20 20 20 20 28 28 70 61 73 73 20 77 61 72 6e 20 ((pass warn
4400: 66 61 69 6c 20 63 68 65 63 6b 20 6e 2f 61 20 77 fail check n/a w
4410: 61 69 76 65 64 20 73 6b 69 70 20 64 65 6c 65 74 aived skip delet
4420: 65 64 20 73 74 75 63 6b 2f 64 65 61 64 20 73 74 ed stuck/dead st
4430: 75 63 6b 29 20 20 66 61 69 6c 29 0a 20 20 20 20 uck) fail).
4440: 20 20 20 20 20 20 20 20 20 20 20 28 28 61 62 6f ((abo
4450: 72 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 rt)
4460: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4480: 20 20 20 20 20 20 20 20 20 20 20 20 61 62 6f 72 abor
4490: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
44a0: 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 (else
44b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44d0: 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e unknown
44e0: 2d 65 72 72 6f 72 2d 36 29 29 29 0a 20 20 20 20 -error-6))).
44f0: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 (else
4500: 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 37 unknown-error-7
4510: 29 29 29 0a 20 20 20 20 28 63 6f 6e 73 20 0a 20 ))). (cons .
4520: 20 20 20 20 28 69 66 20 6e 73 74 61 74 65 20 20 (if nstate
4530: 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 (symbol->string
4540: 6e 73 74 61 74 65 29 20 20 6e 73 74 61 74 65 29 nstate) nstate)
4550: 0a 20 20 20 20 20 28 69 66 20 6e 73 74 61 74 75 . (if nstatu
4560: 73 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e s (symbol->strin
4570: 67 20 6e 73 74 61 74 75 73 29 20 6e 73 74 61 74 g nstatus) nstat
4580: 75 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 us)))).
4590: 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d .;;=======
45a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
45d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
45e0: 3b 3b 20 44 20 45 20 42 20 55 20 47 20 47 20 49 ;; D E B U G G I
45f0: 20 4e 20 47 20 20 20 53 20 54 20 55 20 46 20 46 N G S T U F F
4600: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
4610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
4650: 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 ine *verbosity*
4660: 20 20 20 20 20 20 20 20 31 29 0a 28 64 65 66 69 1).(defi
4670: 6e 65 20 2a 6c 6f 67 67 69 6e 67 2a 20 20 20 20 ne *logging*
4680: 20 20 20 20 20 20 20 23 66 29 0a 0a 28 64 65 66 #f)..(def
4690: 69 6e 65 20 28 67 65 74 2d 77 69 74 68 2d 64 65 ine (get-with-de
46a0: 66 61 75 6c 74 20 76 61 6c 20 64 65 66 61 75 6c fault val defaul
46b0: 74 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 t). (let ((val
46c0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 76 61 (args:get-arg va
46d0: 6c 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c l))). (if val
46e0: 20 76 61 6c 20 64 65 66 61 75 6c 74 29 29 29 0a val default))).
46f0: 0a 28 64 65 66 69 6e 65 20 28 61 73 73 6f 63 2f .(define (assoc/
4700: 64 65 66 61 75 6c 74 20 6b 65 79 20 6c 73 74 20 default key lst
4710: 2e 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 . default). (le
4720: 74 20 28 28 72 65 73 20 28 61 73 73 6f 63 20 6b t ((res (assoc k
4730: 65 79 20 6c 73 74 29 29 29 0a 20 20 20 20 28 69 ey lst))). (i
4740: 66 20 72 65 73 20 28 63 61 64 72 20 72 65 73 29 f res (cadr res)
4750: 28 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 75 (if (null? defau
4760: 6c 74 29 20 23 66 20 28 63 61 72 20 64 65 66 61 lt) #f (car defa
4770: 75 6c 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ult)))))..(defin
4780: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 e (common:get-te
4790: 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a 20 20 stsuite-name).
47a0: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
47b0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
47c0: 22 73 65 74 75 70 22 20 22 74 65 73 74 73 75 69 "setup" "testsui
47d0: 74 65 22 20 29 0a 20 20 20 20 20 20 28 69 66 20 te" ). (if
47e0: 2a 74 6f 70 70 61 74 68 2a 20 0a 20 20 20 20 20 *toppath* .
47f0: 20 20 20 20 20 28 70 61 74 68 6e 61 6d 65 2d 66 (pathname-f
4800: 69 6c 65 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 ile *toppath*).
4810: 20 20 20 20 20 20 20 20 20 28 70 61 74 68 6e 61 (pathna
4820: 6d 65 2d 66 69 6c 65 20 28 63 75 72 72 65 6e 74 me-file (current
4830: 2d 64 69 72 65 63 74 6f 72 79 29 29 29 29 29 0a -directory))))).
4840: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
4850: 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 :get-db-tmp-area
4860: 29 0a 20 20 28 69 66 20 2a 64 62 2d 63 61 63 68 ). (if *db-cach
4870: 65 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 2a 64 e-path*. *d
4880: 62 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 20 b-cache-path*.
4890: 20 20 20 20 28 6c 65 74 20 28 28 64 62 70 61 74 (let ((dbpat
48a0: 68 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 h (create-direct
48b0: 6f 72 79 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f ory (conc "/tmp/
48c0: 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d " (current-user-
48d0: 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 20 22 name)...... "
48e0: 2f 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c 64 /megatest_locald
48f0: 62 2f 22 0a 09 09 09 09 09 20 20 20 20 28 63 6f b/"...... (co
4900: 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 mmon:get-testsui
4910: 74 65 2d 6e 61 6d 65 29 20 22 2f 22 0a 09 09 09 te-name) "/"....
4920: 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 74 72 .. (string-tr
4930: 61 6e 73 6c 61 74 65 20 2a 74 6f 70 70 61 74 68 anslate *toppath
4940: 2a 20 22 2f 22 20 22 2e 22 29 29 20 23 74 29 29 * "/" ".")) #t))
4950: 29 0a 09 28 73 65 74 21 20 2a 64 62 2d 63 61 63 )..(set! *db-cac
4960: 68 65 2d 70 61 74 68 2a 20 64 62 70 61 74 68 29 he-path* dbpath)
4970: 0a 09 64 62 70 61 74 68 29 29 29 0a 0a 28 64 65 ..dbpath)))..(de
4980: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
4990: 2d 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e 61 -area-path-signa
49a0: 74 75 72 65 29 0a 20 20 28 6d 65 73 73 61 67 65 ture). (message
49b0: 2d 64 69 67 65 73 74 2d 73 74 72 69 6e 67 20 28 -digest-string (
49c0: 6d 64 35 2d 70 72 69 6d 69 74 69 76 65 29 20 2a md5-primitive) *
49d0: 74 6f 70 70 61 74 68 2a 29 29 0a 0a 3b 3b 3d 3d toppath*))..;;==
49e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a20: 3d 3d 3d 3d 0a 3b 3b 20 45 20 58 20 49 20 54 20 ====.;; E X I T
4a30: 20 20 48 20 41 20 4e 20 44 20 4c 20 49 20 4e 20 H A N D L I N
4a40: 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d G.;;============
4a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
4a90: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d ine (common:run-
4aa0: 73 79 6e 63 3f 29 0a 20 20 28 6c 65 74 20 28 28 sync?). (let ((
4ab0: 6f 68 68 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 ohh (common:on-h
4ac0: 6f 6d 65 68 6f 73 74 3f 29 29 0a 09 28 73 72 76 omehost?))..(srv
4ad0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
4ae0: 2d 73 65 72 76 65 72 22 29 29 29 0a 20 20 20 20 -server"))).
4af0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4b00: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
4b10: 2d 70 6f 72 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 -port* "common:r
4b20: 75 6e 2d 73 79 6e 63 3f 20 6f 68 68 3d 22 20 6f un-sync? ohh=" o
4b30: 68 68 20 22 2c 20 73 72 76 3d 22 20 73 72 76 29 hh ", srv=" srv)
4b40: 0a 20 20 20 20 28 61 6e 64 20 28 63 6f 6d 6d 6f . (and (commo
4b50: 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a n:on-homehost?).
4b60: 09 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 . (args:get-arg
4b70: 22 2d 73 65 72 76 65 72 22 29 29 29 29 0a 0a 3b "-server"))))..;
4b80: 3b 3b 3b 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 20 ;;; run-ids.;;
4b90: 20 20 69 66 20 23 66 20 75 73 65 20 2a 64 62 2d if #f use *db-
4ba0: 6c 6f 63 61 6c 2d 73 79 6e 63 2a 20 3a 20 6f 72 local-sync* : or
4bb0: 20 27 6c 6f 63 61 6c 2d 73 79 6e 63 2d 66 6c 61 'local-sync-fla
4bc0: 67 73 0a 3b 3b 20 20 20 20 69 66 20 23 74 20 75 gs.;; if #t u
4bd0: 73 65 20 74 69 6d 65 73 74 61 6d 70 73 20 20 20 se timestamps
4be0: 20 20 20 3a 20 6f 72 20 27 74 69 6d 65 73 74 61 : or 'timesta
4bf0: 6d 70 73 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d mps.(define (com
4c00: 6d 6f 6e 3a 73 79 6e 63 2d 74 6f 2d 6d 65 67 61 mon:sync-to-mega
4c10: 74 65 73 74 2e 64 62 20 64 62 73 74 72 75 63 74 test.db dbstruct
4c20: 29 20 0a 20 20 28 6c 65 74 20 28 28 73 74 61 72 ) . (let ((star
4c30: 74 2d 74 69 6d 65 20 20 20 20 20 20 20 20 20 28 t-time (
4c40: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
4c50: 29 0a 09 28 72 65 73 20 20 20 20 20 20 20 20 20 )..(res
4c60: 20 20 20 20 20 20 20 28 64 62 3a 6d 75 6c 74 69 (db:multi
4c70: 2d 64 62 2d 73 79 6e 63 20 64 62 73 74 72 75 63 -db-sync dbstruc
4c80: 74 20 27 6e 65 77 32 6f 6c 64 29 29 29 0a 20 20 t 'new2old))).
4c90: 20 20 28 6c 65 74 20 28 28 73 79 6e 63 2d 74 69 (let ((sync-ti
4ca0: 6d 65 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 me (- (current-s
4cb0: 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 69 econds) start-ti
4cc0: 6d 65 29 29 29 0a 20 20 20 20 20 20 28 64 65 62 me))). (deb
4cd0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 20 ug:print-info 3
4ce0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
4cf0: 74 2a 20 22 53 79 6e 63 20 6f 66 20 6e 65 77 64 t* "Sync of newd
4d00: 62 20 74 6f 20 6f 6c 64 64 62 20 63 6f 6d 70 6c b to olddb compl
4d10: 65 74 65 64 20 69 6e 20 22 20 73 79 6e 63 2d 74 eted in " sync-t
4d20: 69 6d 65 20 22 20 73 65 63 6f 6e 64 73 22 29 0a ime " seconds").
4d30: 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f (if (commo
4d40: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
4d50: 74 20 33 30 20 22 73 79 6e 63 20 6e 65 77 20 74 t 30 "sync new t
4d60: 6f 20 6f 6c 64 22 29 0a 09 20 20 28 64 65 62 75 o old").. (debu
4d70: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
4d80: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4d90: 2a 20 22 53 79 6e 63 20 6f 66 20 6e 65 77 64 62 * "Sync of newdb
4da0: 20 74 6f 20 6f 6c 64 64 62 20 63 6f 6d 70 6c 65 to olddb comple
4db0: 74 65 64 20 69 6e 20 22 20 73 79 6e 63 2d 74 69 ted in " sync-ti
4dc0: 6d 65 20 22 20 73 65 63 6f 6e 64 73 22 29 29 29 me " seconds")))
4dd0: 0a 20 20 20 20 72 65 73 29 29 0a 0a 3b 3b 20 63 . res))..;; c
4de0: 75 72 72 65 6e 74 6c 79 20 74 68 65 20 70 72 69 urrently the pri
4df0: 6d 61 72 79 20 6a 6f 62 20 6f 66 20 74 68 65 20 mary job of the
4e00: 77 61 74 63 68 64 6f 67 20 69 73 20 74 6f 20 72 watchdog is to r
4e10: 75 6e 20 74 68 65 20 73 79 6e 63 20 62 61 63 6b un the sync back
4e20: 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 to megatest.db
4e30: 66 72 6f 6d 20 74 68 65 20 64 62 20 69 6e 20 2f from the db in /
4e40: 74 6d 70 0a 3b 3b 20 69 66 20 77 65 20 61 72 65 tmp.;; if we are
4e50: 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 on the homehost
4e60: 20 61 6e 64 20 77 65 20 61 72 65 20 61 20 73 65 and we are a se
4e70: 72 76 65 72 20 28 62 79 20 64 65 66 69 6e 69 74 rver (by definit
4e80: 69 6f 6e 20 77 65 20 61 72 65 20 6f 6e 20 74 68 ion we are on th
4e90: 65 20 68 6f 6d 65 68 6f 73 74 20 69 66 20 77 65 e homehost if we
4ea0: 20 61 72 65 20 61 20 73 65 72 76 65 72 29 0a 3b are a server).;
4eb0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
4ec0: 6e 3a 77 61 74 63 68 64 6f 67 29 0a 20 20 28 74 n:watchdog). (t
4ed0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 hread-sleep! 0.0
4ee0: 35 29 20 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 5) ;; delay for
4ef0: 73 74 61 72 74 75 70 0a 20 20 28 6c 65 74 20 28 startup. (let (
4f00: 28 6c 65 67 61 63 79 2d 73 79 6e 63 20 28 63 6f (legacy-sync (co
4f10: 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 6e 63 3f 29 29 mmon:run-sync?))
4f20: 0a 09 28 64 65 62 75 67 2d 6d 6f 64 65 20 20 28 ..(debug-mode (
4f30: 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 debug:debug-mode
4f40: 20 31 29 29 0a 09 28 6c 61 73 74 2d 74 69 6d 65 1))..(last-time
4f50: 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (current-seco
4f60: 6e 64 73 29 29 29 0a 20 20 20 20 28 64 65 62 75 nds))). (debu
4f70: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
4f80: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
4f90: 2a 20 22 77 61 74 63 68 64 6f 67 20 73 74 61 72 * "watchdog star
4fa0: 74 69 6e 67 2e 20 6c 65 67 61 63 79 2d 73 79 6e ting. legacy-syn
4fb0: 63 20 69 73 20 22 20 6c 65 67 61 63 79 2d 73 79 c is " legacy-sy
4fc0: 6e 63 29 0a 20 20 20 20 28 69 66 20 6c 65 67 61 nc). (if lega
4fd0: 63 79 2d 73 79 6e 63 0a 09 28 6c 65 74 20 28 28 cy-sync..(let ((
4fe0: 64 62 73 74 72 75 63 74 20 28 64 62 3a 73 65 74 dbstruct (db:set
4ff0: 75 70 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a up))).. (debug:
5000: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5010: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5020: 22 53 65 72 76 65 72 20 72 75 6e 6e 69 6e 67 2c "Server running,
5030: 20 70 65 72 69 6f 64 69 63 20 73 79 6e 63 20 73 periodic sync s
5040: 74 61 72 74 65 64 2e 22 29 0a 09 20 20 28 6c 65 tarted.").. (le
5050: 74 20 6c 6f 6f 70 20 28 29 0a 09 20 20 20 20 3b t loop ().. ;
5060: 3b 20 73 79 6e 63 20 66 6f 72 20 66 69 6c 65 73 ; sync for files
5070: 79 73 74 65 6d 20 6c 6f 63 61 6c 20 64 62 20 77 ystem local db w
5080: 72 69 74 65 73 0a 09 20 20 20 20 3b 3b 0a 09 20 rites.. ;;..
5090: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
50a0: 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d *db-multi-sync-m
50b0: 75 74 65 78 2a 29 0a 09 20 20 20 20 28 6c 65 74 utex*).. (let
50c0: 2a 20 28 28 6e 65 65 64 2d 73 79 6e 63 20 20 20 * ((need-sync
50d0: 20 20 20 20 20 28 3e 3d 20 2a 64 62 2d 6c 61 73 (>= *db-las
50e0: 74 2d 77 72 69 74 65 2a 20 2a 64 62 2d 6c 61 73 t-write* *db-las
50f0: 74 2d 73 79 6e 63 2a 29 29 20 3b 3b 20 6e 6f 20 t-sync*)) ;; no
5100: 73 79 6e 63 20 73 69 6e 63 65 20 6c 61 73 74 20 sync since last
5110: 77 72 69 74 65 0a 09 09 20 20 20 28 73 79 6e 63 write... (sync
5120: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 20 2a 64 62 -in-progress *db
5130: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
5140: 73 2a 29 0a 09 09 20 20 20 28 73 68 6f 75 6c 64 s*)... (should
5150: 2d 73 79 6e 63 20 20 20 20 20 20 28 3e 20 28 2d -sync (> (-
5160: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
5170: 73 29 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 s) *db-last-sync
5180: 2a 29 20 35 29 29 20 3b 3b 20 73 79 6e 63 20 65 *) 5)) ;; sync e
5190: 76 65 72 79 20 66 69 76 65 20 73 65 63 6f 6e 64 very five second
51a0: 73 20 6d 69 6e 69 6d 75 6d 0a 09 09 20 20 20 28 s minimum... (
51b0: 77 69 6c 6c 2d 73 79 6e 63 20 20 20 20 20 20 20 will-sync
51c0: 20 28 61 6e 64 20 28 6f 72 20 6e 65 65 64 2d 73 (and (or need-s
51d0: 79 6e 63 20 73 68 6f 75 6c 64 2d 73 79 6e 63 29 ync should-sync)
51e0: 0a 09 09 09 09 09 20 20 28 6e 6f 74 20 73 79 6e ...... (not syn
51f0: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 29 29 29 c-in-progress)))
5200: 0a 09 09 20 20 20 28 73 74 61 72 74 2d 74 69 6d ... (start-tim
5210: 65 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 e (current
5220: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 20 20 -seconds)))..
5230: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
5240: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
5250: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 65 lt-log-port* "ne
5260: 65 64 2d 73 79 6e 63 3a 20 22 20 6e 65 65 64 2d ed-sync: " need-
5270: 73 79 6e 63 20 22 20 73 79 6e 63 2d 69 6e 2d 70 sync " sync-in-p
5280: 72 6f 67 72 65 73 73 3a 20 22 20 73 79 6e 63 2d rogress: " sync-
5290: 69 6e 2d 70 72 6f 67 72 65 73 73 20 22 20 73 68 in-progress " sh
52a0: 6f 75 6c 64 2d 73 79 6e 63 3a 20 22 20 73 68 6f ould-sync: " sho
52b0: 75 6c 64 2d 73 79 6e 63 20 22 20 77 69 6c 6c 2d uld-sync " will-
52c0: 73 79 6e 63 3a 20 22 20 77 69 6c 6c 2d 73 79 6e sync: " will-syn
52d0: 63 29 0a 09 20 20 20 20 20 20 28 69 66 20 77 69 c).. (if wi
52e0: 6c 6c 2d 73 79 6e 63 20 28 73 65 74 21 20 2a 64 ll-sync (set! *d
52f0: 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 b-sync-in-progre
5300: 73 73 2a 20 23 74 29 29 0a 09 20 20 20 20 20 20 ss* #t))..
5310: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
5320: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
5330: 74 65 78 2a 29 0a 09 20 20 20 20 20 20 28 69 66 tex*).. (if
5340: 20 77 69 6c 6c 2d 73 79 6e 63 0a 09 09 20 20 28 will-sync... (
5350: 6c 65 74 20 28 28 72 65 73 20 28 63 6f 6d 6d 6f let ((res (commo
5360: 6e 3a 73 79 6e 63 2d 74 6f 2d 6d 65 67 61 74 65 n:sync-to-megate
5370: 73 74 2e 64 62 20 64 62 73 74 72 75 63 74 29 29 st.db dbstruct))
5380: 29 20 3b 3b 20 64 69 64 20 77 65 20 73 79 6e 63 ) ;; did we sync
5390: 20 61 6e 79 20 64 61 74 61 3f 20 49 66 20 73 6f any data? If so
53a0: 20 6e 65 65 64 20 74 6f 20 73 65 74 20 74 68 65 need to set the
53b0: 20 64 62 20 74 6f 75 63 68 65 64 20 66 6c 61 67 db touched flag
53c0: 20 74 6f 20 6b 65 65 70 20 74 68 65 20 73 65 72 to keep the ser
53d0: 76 65 72 20 61 6c 69 76 65 0a 09 09 20 20 20 20 ver alive...
53e0: 28 69 66 20 28 3e 20 72 65 73 20 30 29 20 3b 3b (if (> res 0) ;;
53f0: 20 73 6f 6d 65 20 72 65 63 6f 72 64 73 20 77 65 some records we
5400: 72 65 20 74 72 61 6e 73 66 65 72 72 65 64 2c 20 re transferred,
5410: 6b 65 65 70 20 74 68 65 20 64 62 20 61 6c 69 76 keep the db aliv
5420: 65 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 e....(begin....
5430: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
5440: 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 eartbeat-mutex*)
5450: 0a 09 09 09 20 20 28 73 65 74 21 20 2a 64 62 2d .... (set! *db-
5460: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 28 63 75 last-access* (cu
5470: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
5480: 09 09 09 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f ... (mutex-unlo
5490: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
54a0: 75 74 65 78 2a 29 0a 09 09 09 20 20 28 64 65 62 utex*).... (deb
54b0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
54c0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
54d0: 74 2a 20 22 73 79 6e 63 20 63 61 6c 6c 65 64 2c t* "sync called,
54e0: 20 22 20 72 65 73 20 22 20 72 65 63 6f 72 64 73 " res " records
54f0: 20 74 72 61 6e 73 66 65 72 72 65 64 2e 22 29 29 transferred."))
5500: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
5510: 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 -info 2 *default
5520: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 79 6e 63 -log-port* "sync
5530: 20 63 61 6c 6c 65 64 20 62 75 74 20 7a 65 72 6f called but zero
5540: 20 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 65 records transfe
5550: 72 72 65 64 22 29 29 29 29 0a 09 20 20 20 20 20 rred"))))..
5560: 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 0a 09 (if will-sync..
5570: 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 . (begin...
5580: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 (mutex-lock! *db
5590: 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 -multi-sync-mute
55a0: 78 2a 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 x*)... (set!
55b0: 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 *db-sync-in-prog
55c0: 72 65 73 73 2a 20 23 66 29 0a 09 09 20 20 20 20 ress* #f)...
55d0: 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 73 (set! *db-last-s
55e0: 79 6e 63 2a 20 73 74 61 72 74 2d 74 69 6d 65 29 ync* start-time)
55f0: 0a 09 09 20 20 20 20 28 6d 75 74 65 78 2d 75 6e ... (mutex-un
5600: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
5610: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 29 29 0a 09 sync-mutex*)))..
5620: 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 64 (if (and d
5630: 65 62 75 67 2d 6d 6f 64 65 0a 09 09 20 20 20 20 ebug-mode...
5640: 20 20 20 28 3e 20 28 2d 20 73 74 61 72 74 2d 74 (> (- start-t
5650: 69 6d 65 20 6c 61 73 74 2d 74 69 6d 65 29 20 36 ime last-time) 6
5660: 30 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 0))... (begin..
5670: 09 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 2d . (set! last-
5680: 74 69 6d 65 20 73 74 61 72 74 2d 74 69 6d 65 29 time start-time)
5690: 0a 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ... (debug:pr
56a0: 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 int-info 4 *defa
56b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 ult-log-port* "t
56c0: 69 6d 65 73 74 61 6d 70 20 2d 3e 20 22 20 28 73 imestamp -> " (s
56d0: 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 econds->time-str
56e0: 69 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ing (current-sec
56f0: 6f 6e 64 73 29 29 20 22 2c 20 74 69 6d 65 20 73 onds)) ", time s
5700: 69 6e 63 65 20 73 74 61 72 74 20 2d 3e 20 22 20 ince start -> "
5710: 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e (seconds->hr-min
5720: 2d 73 65 63 20 28 2d 20 28 63 75 72 72 65 6e 74 -sec (- (current
5730: 2d 73 65 63 6f 6e 64 73 29 20 2a 74 69 6d 65 2d -seconds) *time-
5740: 7a 65 72 6f 2a 29 29 29 29 29 29 0a 09 20 20 20 zero*))))))..
5750: 20 0a 09 20 20 20 20 3b 3b 20 6b 65 65 70 20 67 .. ;; keep g
5760: 6f 69 6e 67 20 75 6e 6c 65 73 73 20 74 69 6d 65 oing unless time
5770: 20 74 6f 20 65 78 69 74 0a 09 20 20 20 20 3b 3b to exit.. ;;
5780: 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 2a .. (if (not *
5790: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 time-to-exit*)..
57a0: 09 28 6c 65 74 20 64 65 6c 61 79 2d 6c 6f 6f 70 .(let delay-loop
57b0: 20 28 28 63 6f 75 6e 74 20 30 29 29 0a 09 09 20 ((count 0))...
57c0: 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 2a (if (and (not *
57d0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 time-to-exit*)..
57e0: 09 09 20 20 20 28 3c 20 63 6f 75 6e 74 20 34 29 .. (< count 4)
57f0: 29 20 3b 3b 20 77 61 73 20 31 31 2c 20 63 68 61 ) ;; was 11, cha
5800: 6e 67 69 6e 67 20 74 6f 20 34 2e 20 0a 09 09 20 nging to 4. ...
5810: 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 28 (begin....(
5820: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 29 thread-sleep! 1)
5830: 0a 09 09 09 28 64 65 6c 61 79 2d 6c 6f 6f 70 20 ....(delay-loop
5840: 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 29 0a 09 (+ count 1))))..
5850: 09 20 20 28 6c 6f 6f 70 29 29 29 0a 09 20 20 20 . (loop)))..
5860: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (if (common:low
5870: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 29 -noise-print 30)
5880: 0a 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
5890: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
58a0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 log-port* "Exiti
58b0: 6e 67 20 77 61 74 63 68 64 6f 67 20 74 69 6d 65 ng watchdog time
58c0: 72 2c 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 r, *time-to-exit
58d0: 2a 20 3d 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 * = " *time-to-e
58e0: 78 69 74 2a 29 29 29 29 29 29 29 0a 0a 28 64 65 xit*)))))))..(de
58f0: 66 69 6e 65 20 28 73 74 64 2d 65 78 69 74 2d 70 fine (std-exit-p
5900: 72 6f 63 65 64 75 72 65 29 0a 20 20 28 6c 65 74 rocedure). (let
5910: 20 28 28 6e 6f 2d 68 75 72 72 79 20 20 28 69 66 ((no-hurry (if
5920: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 *time-to-exit*
5930: 3b 3b 20 68 75 72 72 79 20 75 70 0a 09 09 20 20 ;; hurry up...
5940: 20 20 20 20 20 23 66 0a 09 09 20 20 20 20 20 20 #f...
5950: 20 28 62 65 67 69 6e 0a 09 09 09 20 28 73 65 74 (begin.... (set
5960: 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a ! *time-to-exit*
5970: 20 23 74 29 0a 09 09 09 20 23 74 29 29 29 29 0a #t).... #t)))).
5980: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5990: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
59a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 61 72 -log-port* "star
59b0: 74 69 6e 67 20 65 78 69 74 20 70 72 6f 63 65 73 ting exit proces
59c0: 73 2c 20 66 69 6e 61 6c 69 7a 69 6e 67 20 64 61 s, finalizing da
59d0: 74 61 62 61 73 65 73 2e 22 29 0a 20 20 20 20 28 tabases."). (
59e0: 69 66 20 28 61 6e 64 20 6e 6f 2d 68 75 72 72 79 if (and no-hurry
59f0: 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f (debug:debug-mo
5a00: 64 65 20 31 38 29 29 0a 09 28 72 6d 74 3a 70 72 de 18))..(rmt:pr
5a10: 69 6e 74 2d 64 62 2d 73 74 61 74 73 29 29 0a 20 int-db-stats)).
5a20: 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d (let ((th1 (m
5a30: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
5a40: 64 61 20 28 29 20 3b 3b 20 74 68 72 65 61 64 20 da () ;; thread
5a50: 66 6f 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 2c for cleaning up,
5a60: 20 67 69 76 65 20 69 74 20 66 69 76 65 20 73 65 give it five se
5a70: 63 6f 6e 64 73 0a 09 09 09 20 20 20 20 20 20 28 conds.... (
5a80: 69 66 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a if *dbstruct-db*
5a90: 20 28 64 62 3a 63 6c 6f 73 65 2d 61 6c 6c 20 2a (db:close-all *
5aa0: 64 62 73 74 72 75 63 74 2d 64 62 2a 29 29 20 3b dbstruct-db*)) ;
5ab0: 3b 20 6f 6e 65 20 73 65 63 6f 6e 64 20 61 6c 6c ; one second all
5ac0: 6f 63 61 74 65 64 0a 09 09 09 20 20 20 20 20 20 ocated....
5ad0: 28 69 66 20 2a 74 61 73 6b 2d 64 62 2a 20 20 20 (if *task-db*
5ae0: 20 0a 09 09 09 09 20 20 28 6c 65 74 20 28 28 64 ..... (let ((d
5af0: 62 20 28 63 64 72 20 2a 74 61 73 6b 2d 64 62 2a b (cdr *task-db*
5b00: 29 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 )))..... (if
5b10: 28 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 (sqlite3:databas
5b20: 65 3f 20 64 62 29 0a 09 09 09 09 09 28 62 65 67 e? db)......(beg
5b30: 69 6e 0a 09 09 09 09 09 20 20 28 73 71 6c 69 74 in...... (sqlit
5b40: 65 33 3a 69 6e 74 65 72 72 75 70 74 21 20 64 62 e3:interrupt! db
5b50: 29 0a 09 09 09 09 09 20 20 28 73 71 6c 69 74 65 )...... (sqlite
5b60: 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 20 23 3:finalize! db #
5b70: 74 29 0a 09 09 09 09 09 20 20 28 76 65 63 74 6f t)...... (vecto
5b80: 72 2d 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a r-set! *task-db*
5b90: 20 30 20 23 66 29 29 29 29 29 0a 09 09 09 20 20 0 #f)))))....
5ba0: 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 (close-outpu
5bb0: 74 2d 70 6f 72 74 20 2a 64 65 66 61 75 6c 74 2d t-port *default-
5bc0: 6c 6f 67 2d 70 6f 72 74 2a 29 0a 09 09 09 20 20 log-port*)....
5bd0: 20 20 20 20 28 73 65 74 21 20 2a 64 65 66 61 75 (set! *defau
5be0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 lt-log-port* (cu
5bf0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
5c00: 29 29 29 20 22 43 6c 65 61 6e 75 70 20 64 62 20 ))) "Cleanup db
5c10: 65 78 69 74 20 74 68 72 65 61 64 22 29 29 0a 09 exit thread"))..
5c20: 20 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 (th2 (make-thr
5c30: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 ead (lambda ()..
5c40: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
5c50: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
5c60: 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d log-port* "Attem
5c70: 70 74 69 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 pting clean exit
5c80: 2e 20 50 6c 65 61 73 65 20 62 65 20 70 61 74 69 . Please be pati
5c90: 65 6e 74 20 61 6e 64 20 77 61 69 74 20 61 20 66 ent and wait a f
5ca0: 65 77 20 73 65 63 6f 6e 64 73 2e 2e 2e 22 29 0a ew seconds...").
5cb0: 09 09 09 20 20 20 20 20 20 28 69 66 20 6e 6f 2d ... (if no-
5cc0: 68 75 72 72 79 0a 09 09 09 09 20 20 28 74 68 72 hurry..... (thr
5cd0: 65 61 64 2d 73 6c 65 65 70 21 20 35 29 20 3b 3b ead-sleep! 5) ;;
5ce0: 20 67 69 76 65 20 74 68 65 20 63 6c 65 61 6e 20 give the clean
5cf0: 75 70 20 66 65 77 20 73 65 63 6f 6e 64 73 20 74 up few seconds t
5d00: 6f 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a o do it's stuff.
5d10: 09 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c .... (thread-sl
5d20: 65 65 70 21 20 32 29 29 0a 09 09 09 20 20 20 20 eep! 2))....
5d30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 (debug:print 4
5d40: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5d50: 72 74 2a 20 22 20 2e 2e 2e 20 64 6f 6e 65 22 29 rt* " ... done")
5d60: 0a 09 09 09 20 20 20 20 20 20 29 0a 09 09 09 20 .... )....
5d70: 20 20 20 22 63 6c 65 61 6e 20 65 78 69 74 22 29 "clean exit")
5d80: 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 )). (thread
5d90: 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 -start! th1).
5da0: 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 (thread-start
5db0: 21 20 74 68 32 29 0a 20 20 20 20 20 20 28 74 68 ! th2). (th
5dc0: 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 read-join! th1))
5dd0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 64 ))..(define (std
5de0: 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 -signal-handler
5df0: 73 69 67 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 signum). ;; (si
5e00: 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 gnal-mask! signu
5e10: 6d 29 0a 20 20 28 73 65 74 21 20 2a 74 69 6d 65 m). (set! *time
5e20: 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 -to-exit* #t).
5e30: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
5e40: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
5e50: 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 76 65 g-port* "Receive
5e60: 64 20 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 d signal " signu
5e70: 6d 20 22 20 65 78 69 74 69 6e 67 20 70 72 6f 6d m " exiting prom
5e80: 70 74 6c 79 22 29 0a 20 20 3b 3b 20 28 73 74 64 ptly"). ;; (std
5e90: 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 72 65 29 -exit-procedure)
5ea0: 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 20 6e 65 ;; shouldn't ne
5eb0: 65 64 20 74 68 69 73 20 73 69 6e 63 65 20 77 65 ed this since we
5ec0: 20 61 72 65 20 65 78 69 74 69 6e 67 20 61 6e 64 are exiting and
5ed0: 20 69 74 20 77 69 6c 6c 20 62 65 20 63 61 6c 6c it will be call
5ee0: 65 64 20 61 6e 79 77 61 79 0a 20 20 28 65 78 69 ed anyway. (exi
5ef0: 74 29 29 0a 0a 28 73 65 74 2d 73 69 67 6e 61 6c t))..(set-signal
5f00: 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c -handler! signal
5f10: 2f 69 6e 74 20 20 73 74 64 2d 73 69 67 6e 61 6c /int std-signal
5f20: 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 43 -handler) ;; ^C
5f30: 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e .(set-signal-han
5f40: 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 dler! signal/ter
5f50: 6d 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e m std-signal-han
5f60: 64 6c 65 72 29 0a 3b 3b 20 28 73 65 74 2d 73 69 dler).;; (set-si
5f70: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 gnal-handler! si
5f80: 67 6e 61 6c 2f 73 74 6f 70 20 73 74 64 2d 73 69 gnal/stop std-si
5f90: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b gnal-handler) ;
5fa0: 3b 20 5e 5a 20 4e 4f 2c 20 64 6f 20 4e 4f 54 20 ; ^Z NO, do NOT
5fb0: 68 61 6e 64 6c 65 20 5e 5a 21 0a 0a 3b 3b 3d 3d handle ^Z!..;;==
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 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6000: 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 43 20 ====.;; M I S C
6010: 20 20 55 20 54 20 49 20 4c 20 53 0a 3b 3b 3d 3d U T I L S.;;==
6020: 3d 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 0a 0a 3b 3b 20 6f 6e 65 2d 6f 66 20 ====..;; one-of
6070: 61 72 67 73 20 64 65 66 69 6e 65 64 0a 28 64 65 args defined.(de
6080: 66 69 6e 65 20 28 61 72 67 73 2d 64 65 66 69 6e fine (args-defin
6090: 65 64 3f 20 2e 20 70 61 72 61 6d 29 0a 20 20 28 ed? . param). (
60a0: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 let ((res #f)).
60b0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
60c0: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 72 67 29 (lambda (arg)
60d0: 0a 20 20 20 20 20 20 20 28 69 66 20 28 61 72 67 . (if (arg
60e0: 73 3a 67 65 74 2d 61 72 67 20 61 72 67 29 28 73 s:get-arg arg)(s
60f0: 65 74 21 20 72 65 73 20 23 74 29 29 29 0a 20 20 et! res #t))).
6100: 20 20 20 70 61 72 61 6d 29 0a 20 20 20 20 72 65 param). re
6110: 73 29 29 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 s))..;; convert
6120: 73 74 75 66 66 20 74 6f 20 61 20 6e 75 6d 62 65 stuff to a numbe
6130: 72 20 69 66 20 70 6f 73 73 69 62 6c 65 0a 28 64 r if possible.(d
6140: 65 66 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 efine (any->numb
6150: 65 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 20 er val). (cond
6160: 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 . ((number? va
6170: 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 73 74 72 l) val). ((str
6180: 69 6e 67 3f 20 76 61 6c 29 20 28 73 74 72 69 6e ing? val) (strin
6190: 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a g->number val)).
61a0: 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c ((symbol? val
61b0: 29 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 ) (any->number (
61c0: 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 symbol->string v
61d0: 61 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 20 23 al))). (else #
61e0: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 f)))..(define (a
61f0: 6e 79 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 6f ny->number-if-po
6200: 73 73 69 62 6c 65 20 76 61 6c 29 0a 20 20 28 6c ssible val). (l
6210: 65 74 20 28 28 6e 75 6d 20 28 61 6e 79 2d 3e 6e et ((num (any->n
6220: 75 6d 62 65 72 20 76 61 6c 29 29 29 0a 20 20 20 umber val))).
6230: 20 28 69 66 20 6e 75 6d 20 6e 75 6d 20 76 61 6c (if num num val
6240: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 )))..(define (pa
6250: 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 69 74 tt-list-match it
6260: 65 6d 20 70 61 74 74 73 29 0a 20 20 28 64 65 62 em patts). (deb
6270: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 ug:print-info 8
6280: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6290: 74 2a 20 22 70 61 74 74 2d 6c 69 73 74 2d 6d 61 t* "patt-list-ma
62a0: 74 63 68 20 69 74 65 6d 3d 22 20 69 74 65 6d 20 tch item=" item
62b0: 22 20 70 61 74 74 73 3d 22 20 70 61 74 74 73 29 " patts=" patts)
62c0: 0a 20 20 28 69 66 20 28 61 6e 64 20 69 74 65 6d . (if (and item
62d0: 20 70 61 74 74 73 29 20 20 3b 3b 20 68 65 72 65 patts) ;; here
62e0: 20 77 65 20 61 72 65 20 66 69 6c 74 65 72 69 6e we are filterin
62f0: 67 20 66 6f 72 20 6d 61 74 63 68 65 73 20 77 69 g for matches wi
6300: 74 68 20 69 74 65 6d 20 70 61 74 74 65 72 6e 73 th item patterns
6310: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
6320: 73 20 23 66 29 29 20 20 20 3b 3b 20 6c 6f 6f 6b s #f)) ;; look
6330: 20 74 68 72 6f 75 67 68 20 61 6c 6c 20 74 68 65 through all the
6340: 20 69 74 65 6d 2d 70 61 74 74 73 20 69 66 20 64 item-patts if d
6350: 65 66 69 6e 65 64 2c 20 66 6f 72 6d 61 74 20 69 efined, format i
6360: 73 20 70 61 74 74 31 2c 70 61 74 74 32 2c 70 61 s patt1,patt2,pa
6370: 74 74 33 20 2e 2e 2e 20 77 69 6c 64 63 61 72 64 tt3 ... wildcard
6380: 20 69 73 20 25 0a 09 28 66 6f 72 2d 65 61 63 68 is %..(for-each
6390: 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 70 61 74 .. (lambda (pat
63a0: 74 29 0a 09 20 20 20 28 6c 65 74 20 28 28 6d 6f t).. (let ((mo
63b0: 64 70 61 74 74 20 28 73 74 72 69 6e 67 2d 73 75 dpatt (string-su
63c0: 62 73 74 69 74 75 74 65 20 22 25 22 20 22 2e 2a bstitute "%" ".*
63d0: 22 20 70 61 74 74 20 23 74 29 29 29 0a 09 20 20 " patt #t)))..
63e0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
63f0: 69 6e 66 6f 20 31 30 20 2a 64 65 66 61 75 6c 74 info 10 *default
6400: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 -log-port* "patt
6410: 20 22 20 70 61 74 74 20 22 20 6d 6f 64 70 61 74 " patt " modpat
6420: 74 20 22 20 6d 6f 64 70 61 74 74 29 0a 09 20 20 t " modpatt)..
6430: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d (if (string-m
6440: 61 74 63 68 20 28 72 65 67 65 78 70 20 6d 6f 64 atch (regexp mod
6450: 70 61 74 74 29 20 69 74 65 6d 29 0a 09 09 20 28 patt) item)... (
6460: 73 65 74 21 20 72 65 73 20 23 74 29 29 29 29 0a set! res #t)))).
6470: 09 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 . (string-split
6480: 70 61 74 74 73 20 22 2c 22 29 29 0a 09 72 65 73 patts ","))..res
6490: 29 0a 20 20 20 20 20 20 23 74 29 29 0a 0a 3b 3b ). #t))..;;
64a0: 20 28 6d 61 70 20 70 72 69 6e 74 20 28 6d 61 70 (map print (map
64b0: 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 6c 65 car (hash-table
64c0: 2d 3e 61 6c 69 73 74 20 28 72 65 61 64 2d 63 6f ->alist (read-co
64d0: 6e 66 69 67 20 22 72 75 6e 63 6f 6e 66 69 67 73 nfig "runconfigs
64e0: 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 74 29 29 .config" #f #t))
64f0: 29 29 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )).(define (comm
6500: 6f 6e 3a 67 65 74 2d 72 75 6e 63 6f 6e 66 69 67 on:get-runconfig
6510: 2d 74 61 72 67 65 74 73 20 23 21 6b 65 79 20 28 -targets #!key (
6520: 63 6f 6e 66 69 67 66 20 23 66 29 29 0a 20 20 28 configf #f)). (
6530: 6c 65 74 20 28 28 74 61 72 67 73 20 20 20 20 20 let ((targs
6540: 20 20 28 73 6f 72 74 20 28 6d 61 70 20 63 61 72 (sort (map car
6550: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
6560: 69 73 74 0a 09 09 09 09 20 20 20 20 20 28 6f 72 ist..... (or
6570: 20 63 6f 6e 66 69 67 66 0a 09 09 09 09 09 20 28 configf...... (
6580: 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e read-config (con
6590: 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 c *toppath* "/ru
65a0: 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 nconfigs.config"
65b0: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 )....... #f
65c0: 20 23 74 29 0a 09 09 09 09 09 20 28 6d 61 6b 65 #t)...... (make
65d0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a -hash-table)))).
65e0: 09 09 09 20 20 20 73 74 72 69 6e 67 3c 3f 29 29 ... string<?))
65f0: 0a 09 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 ..(target-patt (
6600: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
6610: 61 72 67 65 74 22 29 29 29 0a 20 20 20 20 28 69 arget"))). (i
6620: 66 20 74 61 72 67 65 74 2d 70 61 74 74 0a 09 28 f target-patt..(
6630: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
6640: 78 29 0a 09 09 20 20 28 70 61 74 74 2d 6c 69 73 x)... (patt-lis
6650: 74 2d 6d 61 74 63 68 20 78 20 74 61 72 67 65 74 t-match x target
6660: 2d 70 61 74 74 29 29 0a 09 09 74 61 72 67 73 29 -patt))...targs)
6670: 0a 09 74 61 72 67 73 29 29 29 0a 0a 3b 3b 20 27 ..targs)))..;; '
6680: 28 70 72 69 6e 74 20 28 73 74 72 69 6e 67 2d 69 (print (string-i
6690: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
66a0: 63 61 64 72 20 28 68 61 73 68 2d 74 61 62 6c 65 cadr (hash-table
66b0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 72 65 -ref/default (re
66c0: 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 ad-config "megat
66d0: 65 73 74 2e 63 6f 6e 66 69 67 22 20 5c 23 66 20 est.config" \#f
66e0: 5c 23 74 29 20 22 64 69 73 6b 73 22 20 27 22 27 \#t) "disks" '"'
66f0: 22 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 20 "'("none" "")))
6700: 22 5c 6e 22 29 29 27 0a 28 64 65 66 69 6e 65 20 "\n"))'.(define
6710: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b (common:get-disk
6720: 73 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 s #!key (configf
6730: 20 23 66 29 29 0a 20 20 28 68 61 73 68 2d 74 61 #f)). (hash-ta
6740: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
6750: 0a 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 20 . (or configf
6760: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 (read-config "me
6770: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 23 gatest.config" #
6780: 66 20 23 74 29 29 0a 20 20 20 22 64 69 73 6b 73 f #t)). "disks
6790: 22 20 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 " '("none" "")))
67a0: 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 73 ..;; return firs
67b0: 74 20 63 6f 6d 6d 61 6e 64 20 74 68 61 74 20 65 t command that e
67c0: 78 69 73 74 73 2c 20 65 6c 73 65 20 23 66 0a 3b xists, else #f.;
67d0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
67e0: 6e 3a 77 68 69 63 68 20 63 6d 64 73 29 0a 20 20 n:which cmds).
67f0: 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 (if (null? cmds)
6800: 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 . #f.
6810: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
6820: 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 20 28 (car cmds))... (
6830: 74 61 6c 20 28 63 64 72 20 63 6d 64 73 29 29 29 tal (cdr cmds)))
6840: 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 ..(let ((res (wi
6850: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
6860: 70 65 20 28 63 6f 6e 63 20 22 77 68 69 63 68 20 pe (conc "which
6870: 22 20 68 65 64 29 20 72 65 61 64 2d 6c 69 6e 65 " hed) read-line
6880: 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ))).. (if (and
6890: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 (string? res)...
68a0: 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f (file-exists?
68b0: 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 res)).. re
68c0: 73 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 s.. (if (nu
68d0: 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a ll? tal)... #f.
68e0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 .. (loop (car t
68f0: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
6900: 29 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 ))). .(define (
6910: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 common:get-insta
6920: 6c 6c 2d 61 72 65 61 29 0a 20 20 28 6c 65 74 20 ll-area). (let
6930: 28 28 65 78 65 2d 70 61 74 68 20 28 63 61 72 20 ((exe-path (car
6940: 28 61 72 67 76 29 29 29 29 0a 20 20 20 20 28 69 (argv)))). (i
6950: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
6960: 65 78 65 2d 70 61 74 68 29 0a 09 28 68 61 6e 64 exe-path)..(hand
6970: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 le-exceptions..
6980: 65 78 6e 0a 09 20 23 66 0a 09 20 28 70 61 74 68 exn.. #f.. (path
6990: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 0a 09 name-directory..
69a0: 20 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 (pathname-dire
69b0: 63 74 6f 72 79 20 0a 09 20 20 20 28 70 61 74 68 ctory .. (path
69c0: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 65 name-directory e
69d0: 78 65 2d 70 61 74 68 29 29 29 29 0a 09 23 66 29 xe-path))))..#f)
69e0: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 ))..;; return fi
69f0: 72 73 74 20 70 61 74 68 20 74 68 61 74 20 63 61 rst path that ca
6a00: 6e 20 62 65 20 63 72 65 61 74 65 64 20 6f 72 20 n be created or
6a10: 61 6c 72 65 61 64 79 20 65 78 69 73 74 73 20 61 already exists a
6a20: 6e 64 20 69 73 20 77 72 69 74 61 62 6c 65 0a 3b nd is writable.;
6a30: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
6a40: 6e 3a 67 65 74 2d 63 72 65 61 74 65 2d 77 72 69 n:get-create-wri
6a50: 74 65 61 62 6c 65 2d 64 69 72 20 64 69 72 73 29 teable-dir dirs)
6a60: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 69 . (if (null? di
6a70: 72 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 rs). #f.
6a80: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
6a90: 65 64 20 28 63 61 72 20 64 69 72 73 29 29 0a 09 ed (car dirs))..
6aa0: 09 20 28 74 61 6c 20 28 63 64 72 20 64 69 72 73 . (tal (cdr dirs
6ab0: 29 29 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 )))..(let ((res
6ac0: 28 6f 72 20 28 61 6e 64 20 28 64 69 72 65 63 74 (or (and (direct
6ad0: 6f 72 79 3f 20 68 65 64 29 0a 09 09 09 20 20 20 ory? hed)....
6ae0: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
6af0: 65 73 73 3f 20 68 65 64 29 0a 09 09 09 20 20 20 ess? hed)....
6b00: 20 68 65 64 29 0a 09 09 20 20 20 20 20 20 20 28 hed)... (
6b10: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
6b20: 73 0a 09 09 09 65 78 6e 0a 09 09 09 23 66 0a 09 s....exn....#f..
6b30: 09 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 ..(create-direct
6b40: 6f 72 79 20 68 65 64 20 23 74 29 29 29 29 29 0a ory hed #t))))).
6b50: 09 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 . (if (and (str
6b60: 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 28 ing? res)... (
6b70: 64 69 72 65 63 74 6f 72 79 3f 20 72 65 73 29 29 directory? res))
6b80: 0a 09 20 20 20 20 20 20 72 65 73 0a 09 20 20 20 .. res..
6b90: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
6ba0: 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 20 28 6c l)... #f... (l
6bb0: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
6bc0: 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a 20 20 r tal)))))))).
6bd0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
6be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 =========.;; T A
6c20: 20 52 20 47 20 45 20 54 20 53 20 20 2c 20 20 20 R G E T S ,
6c30: 53 20 54 20 41 20 54 20 45 20 2c 20 20 20 53 20 S T A T E , S
6c40: 54 20 41 20 54 20 55 20 53 20 2c 20 20 20 0a 3b T A T U S , .;
6c50: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
6c60: 20 20 20 20 20 52 20 55 20 4e 20 4e 20 41 20 4d R U N N A M
6c70: 20 45 20 20 20 20 41 20 4e 20 44 20 20 20 54 20 E A N D T
6c80: 45 20 53 20 54 20 50 20 41 20 54 20 54 0a 3b 3b E S T P A T T.;;
6c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6cd0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4c 6f 6f 6b 75 ======..;; Looku
6ce0: 70 20 61 20 76 61 6c 75 65 20 69 6e 20 72 75 6e p a value in run
6cf0: 63 6f 6e 66 69 67 73 20 62 61 73 65 64 20 6f 6e configs based on
6d00: 20 2d 72 65 71 74 61 72 67 20 6f 72 20 2d 74 61 -reqtarg or -ta
6d10: 72 67 65 74 0a 28 64 65 66 69 6e 65 20 28 72 75 rget.(define (ru
6d20: 6e 63 6f 6e 66 69 67 73 2d 67 65 74 20 63 6f 6e nconfigs-get con
6d30: 66 69 67 20 76 61 72 29 0a 20 20 28 6c 65 74 20 fig var). (let
6d40: 28 28 74 61 72 67 20 28 63 6f 6d 6d 6f 6e 3a 61 ((targ (common:a
6d50: 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 29 29 rgs-get-target))
6d60: 29 20 3b 3b 20 28 6f 72 20 28 61 72 67 73 3a 67 ) ;; (or (args:g
6d70: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
6d80: 22 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ")(args:get-arg
6d90: 22 2d 74 61 72 67 65 74 22 29 28 67 65 74 65 6e "-target")(geten
6da0: 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 29 v "MT_TARGET")))
6db0: 29 0a 20 20 20 20 28 69 66 20 74 61 72 67 0a 09 ). (if targ..
6dc0: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
6dd0: 6b 75 70 20 63 6f 6e 66 69 67 20 74 61 72 67 20 kup config targ
6de0: 76 61 72 29 0a 09 20 20 20 20 28 63 6f 6e 66 69 var).. (confi
6df0: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
6e00: 20 22 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 "default" var))
6e10: 0a 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ..(configf:looku
6e20: 70 20 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c p config "defaul
6e30: 74 22 20 76 61 72 29 29 29 29 0a 0a 28 64 65 66 t" var))))..(def
6e40: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 ine (common:args
6e50: 2d 67 65 74 2d 73 74 61 74 65 29 0a 20 20 28 6f -get-state). (o
6e60: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
6e70: 22 2d 73 74 61 74 65 22 29 28 61 72 67 73 3a 67 "-state")(args:g
6e80: 65 74 2d 61 72 67 20 22 3a 73 74 61 74 65 22 29 et-arg ":state")
6e90: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
6ea0: 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 mon:args-get-sta
6eb0: 74 75 73 29 0a 20 20 28 6f 72 20 28 61 72 67 73 tus). (or (args
6ec0: 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 61 74 75 :get-arg "-statu
6ed0: 73 22 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 s")(args:get-arg
6ee0: 20 22 3a 73 74 61 74 75 73 22 29 29 29 0a 0a 28 ":status")))..(
6ef0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 define (common:a
6f00: 72 67 73 2d 67 65 74 2d 74 65 73 74 70 61 74 74 rgs-get-testpatt
6f10: 20 72 63 6f 6e 66 29 0a 20 20 28 6c 65 74 2a 20 rconf). (let*
6f20: 28 28 72 74 65 73 74 70 61 74 74 20 20 20 20 20 ((rtestpatt
6f30: 28 69 66 20 72 63 6f 6e 66 20 28 72 75 6e 63 6f (if rconf (runco
6f40: 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 20 nfigs-get rconf
6f50: 22 54 45 53 54 50 41 54 54 22 29 20 23 66 29 29 "TESTPATT") #f))
6f60: 0a 09 20 28 61 72 67 73 2d 74 65 73 74 70 61 74 .. (args-testpat
6f70: 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d t (or (args:get-
6f80: 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 arg "-testpatt")
6f90: 0a 09 09 09 20 20 20 20 28 61 72 67 73 3a 67 65 .... (args:ge
6fa0: 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 t-arg "-runtests
6fb0: 22 29 0a 09 09 09 20 20 20 20 22 25 22 29 29 0a ").... "%")).
6fc0: 09 20 28 74 65 73 74 70 61 74 74 20 20 20 20 28 . (testpatt (
6fd0: 6f 72 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 or (and (equal?
6fe0: 61 72 67 73 2d 74 65 73 74 70 61 74 74 20 22 25 args-testpatt "%
6ff0: 22 29 0a 09 09 09 20 20 20 20 20 20 20 72 74 65 ").... rte
7000: 73 74 70 61 74 74 29 0a 09 09 09 20 20 61 72 67 stpatt).... arg
7010: 73 2d 74 65 73 74 70 61 74 74 29 29 29 0a 20 20 s-testpatt))).
7020: 20 20 28 69 66 20 72 74 65 73 74 70 61 74 74 20 (if rtestpatt
7030: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7040: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
7050: 2d 70 6f 72 74 2a 20 22 54 45 53 54 50 41 54 54 -port* "TESTPATT
7060: 20 66 72 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 from runconfigs
7070: 3a 20 22 20 72 74 65 73 74 70 61 74 74 29 29 0a : " rtestpatt)).
7080: 20 20 20 20 74 65 73 74 70 61 74 74 29 29 0a 0a testpatt))..
7090: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
70a0: 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 20 get-linktree).
70b0: 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (or (getenv "MT_
70c0: 4c 49 4e 4b 54 52 45 45 22 29 0a 20 20 20 20 20 LINKTREE").
70d0: 20 28 69 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a (if *configdat*
70e0: 0a 09 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f .. (configf:loo
70f0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
7100: 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 "setup" "linktre
7110: 65 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 e"))))..(define
7120: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
7130: 2d 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 -runname). (let
7140: 20 28 28 72 65 73 20 28 6f 72 20 28 61 72 67 73 ((res (or (args
7150: 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 :get-arg "-runna
7160: 6d 65 22 29 0a 09 09 20 28 61 72 67 73 3a 67 65 me")... (args:ge
7170: 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 t-arg ":runname"
7180: 29 0a 09 09 20 28 67 65 74 65 6e 76 20 22 4d 54 )... (getenv "MT
7190: 5f 52 55 4e 4e 41 4d 45 22 29 29 29 29 0a 20 20 _RUNNAME")))).
71a0: 20 20 3b 3b 20 28 69 66 20 72 65 73 20 28 73 65 ;; (if res (se
71b0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
71c0: 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 4e 41 riable "MT_RUNNA
71d0: 4d 45 22 20 72 65 73 29 29 20 3b 3b 20 6e 6f 74 ME" res)) ;; not
71e0: 20 73 75 72 65 20 69 66 20 74 68 69 73 20 69 73 sure if this is
71f0: 20 61 20 67 6f 6f 64 20 69 64 65 61 2e 20 73 69 a good idea. si
7200: 64 65 20 65 66 66 65 63 74 20 61 6e 64 20 61 6c de effect and al
7210: 6c 20 2e 2e 2e 0a 20 20 20 20 72 65 73 29 29 0a l .... res)).
7220: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
7230: 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 :args-get-target
7240: 20 23 21 6b 65 79 20 28 73 70 6c 69 74 20 23 66 #!key (split #f
7250: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 )). (let* ((key
7260: 73 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 s (if (hash-t
7270: 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 61 74 able? *configdat
7280: 2a 29 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d *) (keys:config-
7290: 67 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 get-fields *conf
72a0: 69 67 64 61 74 2a 29 20 27 28 29 29 29 0a 09 20 igdat*) '()))..
72b0: 28 6e 75 6d 6b 65 79 73 20 28 6c 65 6e 67 74 68 (numkeys (length
72c0: 20 6b 65 79 73 29 29 0a 09 20 28 74 61 72 67 65 keys)).. (targe
72d0: 74 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 t (or (args:get
72e0: 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 -arg "-reqtarg")
72f0: 0a 09 09 20 20 20 20 20 20 28 61 72 67 73 3a 67 ... (args:g
7300: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
7310: 29 0a 09 09 20 20 20 20 20 20 28 67 65 74 65 6e )... (geten
7320: 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 29 v "MT_TARGET")))
7330: 0a 09 20 28 74 6c 69 73 74 20 20 20 28 69 66 20 .. (tlist (if
7340: 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 2d 73 target (string-s
7350: 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 20 plit target "/"
7360: 23 74 29 20 27 28 29 29 29 0a 09 20 28 76 61 6c #t) '())).. (val
7370: 69 64 20 20 20 28 69 66 20 74 61 72 67 65 74 0a id (if target.
7380: 09 09 20 20 20 20 20 20 28 6f 72 20 28 6e 75 6c .. (or (nul
7390: 6c 3f 20 6b 65 79 73 29 20 3b 3b 20 70 72 6f 62 l? keys) ;; prob
73a0: 61 62 6c 79 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 ably don't know
73b0: 6f 75 72 20 6b 65 79 73 20 79 65 74 0a 09 09 09 our keys yet....
73c0: 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c (and (not (nul
73d0: 6c 3f 20 74 6c 69 73 74 29 29 0a 09 09 09 20 20 l? tlist))....
73e0: 20 20 20 20 20 28 65 71 3f 20 6e 75 6d 6b 65 79 (eq? numkey
73f0: 73 20 28 6c 65 6e 67 74 68 20 74 6c 69 73 74 29 s (length tlist)
7400: 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e 75 6c ).... (nul
7410: 6c 3f 20 28 66 69 6c 74 65 72 20 73 74 72 69 6e l? (filter strin
7420: 67 2d 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 29 29 g-null? tlist)))
7430: 29 0a 09 09 20 20 20 20 20 20 23 66 29 29 29 0a )... #f))).
7440: 20 20 20 20 28 69 66 20 76 61 6c 69 64 0a 09 28 (if valid..(
7450: 69 66 20 73 70 6c 69 74 0a 09 20 20 20 20 74 6c if split.. tl
7460: 69 73 74 0a 09 20 20 20 20 74 61 72 67 65 74 29 ist.. target)
7470: 0a 09 28 69 66 20 74 61 72 67 65 74 0a 09 20 20 ..(if target..
7480: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
7490: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
74a0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
74b0: 67 2d 70 6f 72 74 2a 20 22 49 6e 76 61 6c 69 64 g-port* "Invalid
74c0: 20 74 61 72 67 65 74 2c 20 73 70 61 63 65 73 20 target, spaces
74d0: 6f 72 20 62 6c 61 6e 6b 73 20 6e 6f 74 20 61 6c or blanks not al
74e0: 6c 6f 77 65 64 20 5c 22 22 20 74 61 72 67 65 74 lowed \"" target
74f0: 20 22 5c 22 2c 20 74 61 72 67 65 74 20 73 68 6f "\", target sho
7500: 75 6c 64 20 62 65 3a 20 22 20 28 73 74 72 69 6e uld be: " (strin
7510: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6b 65 g-intersperse ke
7520: 79 73 20 22 2f 22 29 20 22 2c 20 68 61 76 65 20 ys "/") ", have
7530: 22 20 74 6c 69 73 74 20 22 20 66 6f 72 20 65 6c " tlist " for el
7540: 65 6d 65 6e 74 73 22 29 0a 09 20 20 20 20 20 20 ements")..
7550: 23 66 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a #f).. #f)))).
7560: 0a 3b 3b 20 6c 6f 67 69 63 20 66 6f 72 20 67 65 .;; logic for ge
7570: 74 74 69 6e 67 20 68 6f 6d 65 68 6f 73 74 2e 20 tting homehost.
7580: 52 65 74 75 72 6e 73 20 28 68 6f 73 74 20 2e 20 Returns (host .
7590: 61 74 2d 68 6f 6d 65 29 0a 3b 3b 20 49 46 20 2a at-home).;; IF *
75a0: 74 6f 70 70 61 74 68 2a 20 69 73 20 6e 6f 74 20 toppath* is not
75b0: 73 65 74 2c 20 77 61 69 74 20 75 70 20 74 6f 20 set, wait up to
75c0: 66 69 76 65 20 73 65 63 6f 6e 64 73 20 74 72 79 five seconds try
75d0: 69 6e 67 20 65 76 65 72 79 20 74 77 6f 20 73 65 ing every two se
75e0: 63 6f 6e 64 73 0a 3b 3b 20 28 74 68 69 73 20 69 conds.;; (this i
75f0: 73 20 74 6f 20 61 63 63 6f 6d 6f 64 61 74 65 20 s to accomodate
7600: 74 68 65 20 77 61 74 63 68 64 6f 67 29 0a 3b 3b the watchdog).;;
7610: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
7620: 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 20 23 21 :get-homehost #!
7630: 6b 65 79 20 28 74 72 79 6e 75 6d 20 35 29 29 0a key (trynum 5)).
7640: 20 20 3b 3b 20 63 61 6c 6c 65 64 20 6f 66 74 65 ;; called ofte
7650: 6e 20 65 73 70 65 63 69 61 6c 6c 79 20 61 74 20 n especially at
7660: 73 74 61 72 74 20 75 70 2e 20 75 73 65 20 74 68 start up. use th
7670: 65 20 6c 61 75 6e 63 68 20 73 65 74 75 70 20 6d e launch setup m
7680: 75 74 65 78 20 74 6f 20 65 6c 69 6d 69 6e 61 74 utex to eliminat
7690: 65 20 63 6f 6c 6c 69 73 69 6f 6e 73 0a 20 20 28 e collisions. (
76a0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 6f 6d mutex-lock! *hom
76b0: 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 ehost-mutex*).
76c0: 28 63 6f 6e 64 0a 20 20 20 28 2a 68 6f 6d 65 2d (cond. (*home-
76d0: 68 6f 73 74 2a 0a 20 20 20 20 28 6d 75 74 65 78 host*. (mutex
76e0: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f -unlock! *homeho
76f0: 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 2a st-mutex*). *
7700: 68 6f 6d 65 2d 68 6f 73 74 2a 29 0a 20 20 20 28 home-host*). (
7710: 28 6e 6f 74 20 2a 74 6f 70 70 61 74 68 2a 29 0a (not *toppath*).
7720: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
7730: 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 k! *homehost-mut
7740: 65 78 2a 29 0a 20 20 20 20 28 6c 61 75 6e 63 68 ex*). (launch
7750: 3a 73 65 74 75 70 29 20 3b 3b 20 73 61 66 65 6c :setup) ;; safel
7760: 79 20 6d 75 74 65 78 65 64 20 6e 6f 77 0a 20 20 y mutexed now.
7770: 20 20 28 69 66 20 28 3e 20 74 72 79 6e 75 6d 20 (if (> trynum
7780: 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 74 0)..(begin.. (t
7790: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a hread-sleep! 2).
77a0: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 . (common:get-h
77b0: 6f 6d 65 68 6f 73 74 20 74 72 79 6e 75 6d 3a 20 omehost trynum:
77c0: 28 2d 20 74 72 79 6e 75 6d 20 31 29 29 29 0a 09 (- trynum 1)))..
77d0: 23 66 29 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 #f)). (else.
77e0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
77f0: 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 *homehost-mutex
7800: 2a 29 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 63 *). (let* ((c
7810: 75 72 72 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 urrhost (get-hos
7820: 74 2d 6e 61 6d 65 29 29 0a 09 20 20 20 28 62 65 t-name)).. (be
7830: 73 74 61 64 72 73 20 28 73 65 72 76 65 72 3a 67 stadrs (server:g
7840: 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
7850: 64 72 65 73 73 20 63 75 72 72 68 6f 73 74 29 29 dress currhost))
7860: 0a 09 20 20 20 3b 3b 20 66 69 72 73 74 20 6c 6f .. ;; first lo
7870: 6f 6b 20 69 6e 20 63 6f 6e 66 69 67 2c 20 74 68 ok in config, th
7880: 65 6e 20 6c 6f 6f 6b 20 69 6e 20 66 69 6c 65 20 en look in file
7890: 2e 68 6f 6d 65 68 6f 73 74 2c 20 63 72 65 61 74 .homehost, creat
78a0: 65 20 69 74 20 69 66 20 6e 6f 74 20 66 6f 75 6e e it if not foun
78b0: 64 0a 09 20 20 20 28 68 6f 6d 65 68 6f 73 74 20 d.. (homehost
78c0: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
78d0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
78e0: 22 73 65 72 76 65 72 22 20 22 68 6f 6d 65 68 6f "server" "homeho
78f0: 73 74 22 20 29 0a 09 09 09 20 28 6c 65 74 20 28 st" ).... (let (
7900: 28 68 68 66 20 28 63 6f 6e 63 20 2a 74 6f 70 70 (hhf (conc *topp
7910: 61 74 68 2a 20 22 2f 2e 68 6f 6d 65 68 6f 73 74 ath* "/.homehost
7920: 22 29 29 29 0a 09 09 09 20 20 20 28 69 66 20 28 "))).... (if (
7930: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 68 66 file-exists? hhf
7940: 29 0a 09 09 09 20 20 20 20 20 20 20 28 77 69 74 ).... (wit
7950: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c h-input-from-fil
7960: 65 20 68 68 66 20 72 65 61 64 2d 6c 69 6e 65 29 e hhf read-line)
7970: 0a 09 09 09 20 20 20 20 20 20 20 28 69 66 20 28 .... (if (
7980: 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 file-write-acces
7990: 73 3f 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 s? *toppath*)...
79a0: 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 .. (begin.....
79b0: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
79c0: 74 2d 74 6f 2d 66 69 6c 65 20 68 68 66 0a 09 09 t-to-file hhf...
79d0: 09 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .. (lambda
79e0: 20 28 29 0a 09 09 09 09 09 20 28 70 72 69 6e 74 ()...... (print
79f0: 20 62 65 73 74 61 64 72 73 29 29 29 0a 09 09 09 bestadrs)))....
7a00: 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 . (common:ge
7a10: 74 2d 68 6f 6d 65 68 6f 73 74 29 29 0a 09 09 09 t-homehost))....
7a20: 09 20 20 20 23 66 29 29 29 29 29 0a 09 20 20 20 . #f)))))..
7a30: 28 61 74 2d 68 6f 6d 65 20 20 28 6f 72 20 28 65 (at-home (or (e
7a40: 71 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 63 qual? homehost c
7a50: 75 72 72 68 6f 73 74 29 0a 09 09 09 20 28 65 71 urrhost).... (eq
7a60: 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 62 65 ual? homehost be
7a70: 73 74 61 64 72 73 29 29 29 29 0a 20 20 20 20 20 stadrs)))).
7a80: 20 28 73 65 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 (set! *home-hos
7a90: 74 2a 20 28 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 t* (cons homehos
7aa0: 74 20 61 74 2d 68 6f 6d 65 29 29 0a 20 20 20 20 t at-home)).
7ab0: 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 29 29 29 *home-host*)))
7ac0: 29 0a 0a 3b 3b 20 61 6d 20 49 20 6f 6e 20 74 68 )..;; am I on th
7ad0: 65 20 68 6f 6d 65 68 6f 73 74 3f 0a 3b 3b 0a 28 e homehost?.;;.(
7ae0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6f define (common:o
7af0: 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 20 20 28 n-homehost?). (
7b00: 6c 65 74 20 28 28 68 68 20 28 63 6f 6d 6d 6f 6e let ((hh (common
7b10: 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 29 :get-homehost)))
7b20: 0a 20 20 20 20 28 69 66 20 68 68 0a 09 28 63 64 . (if hh..(cd
7b30: 72 20 68 68 29 0a 09 23 66 29 29 29 0a 0a 3b 3b r hh)..#f)))..;;
7b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b80: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 ======.;; M I S
7b90: 43 20 20 20 4c 20 49 20 53 20 54 20 53 0a 3b 3b C L I S T S.;;
7ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7be0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 74 65 6d 73 ======..;; items
7bf0: 20 69 6e 20 6c 69 73 74 61 20 61 72 65 20 6d 61 in lista are ma
7c00: 74 63 68 65 64 20 76 61 6c 75 65 20 61 6e 64 20 tched value and
7c10: 70 6f 73 69 74 69 6f 6e 20 69 6e 20 6c 69 73 74 position in list
7c20: 62 0a 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 20 b.;; return the
7c30: 72 65 6d 61 69 6e 69 6e 67 20 69 74 65 6d 73 20 remaining items
7c40: 69 6e 20 6c 69 73 74 62 20 6f 72 20 23 66 0a 3b in listb or #f.;
7c50: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
7c60: 6e 3a 6c 69 73 74 2d 69 73 2d 73 75 62 6c 69 73 n:list-is-sublis
7c70: 74 20 6c 69 73 74 61 20 6c 69 73 74 62 29 0a 20 t lista listb).
7c80: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 69 73 74 (if (null? list
7c90: 61 29 0a 20 20 20 20 20 20 6c 69 73 74 62 20 3b a). listb ;
7ca0: 3b 20 61 6c 6c 20 69 74 65 6d 73 20 69 6e 20 6c ; all items in l
7cb0: 69 73 74 62 20 61 72 65 20 22 72 65 6d 61 69 6e istb are "remain
7cc0: 69 6e 67 22 0a 20 20 20 20 20 20 28 69 66 20 28 ing". (if (
7cd0: 3e 20 28 6c 65 6e 67 74 68 20 6c 69 73 74 61 29 > (length lista)
7ce0: 28 6c 65 6e 67 74 68 20 6c 69 73 74 62 29 29 20 (length listb))
7cf0: 0a 09 20 20 23 66 0a 09 20 20 28 6c 65 74 20 6c .. #f.. (let l
7d00: 6f 6f 70 20 28 28 68 65 64 61 20 28 63 61 72 20 oop ((heda (car
7d10: 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 20 28 lista))... (
7d20: 74 61 6c 61 20 28 63 64 72 20 6c 69 73 74 61 29 tala (cdr lista)
7d30: 29 0a 09 09 20 20 20 20 20 28 68 65 64 62 20 28 )... (hedb (
7d40: 63 61 72 20 6c 69 73 74 62 29 29 0a 09 09 20 20 car listb))...
7d50: 20 20 20 28 74 61 6c 62 20 28 63 64 72 20 6c 69 (talb (cdr li
7d60: 73 74 62 29 29 29 0a 09 20 20 20 20 28 69 66 20 stb))).. (if
7d70: 28 65 71 75 61 6c 3f 20 68 65 64 61 20 68 65 64 (equal? heda hed
7d80: 62 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 b)...(if (null?
7d90: 74 61 6c 61 29 20 3b 3b 20 77 65 20 61 72 65 20 tala) ;; we are
7da0: 64 6f 6e 65 0a 09 09 20 20 20 20 74 61 6c 62 0a done... talb.
7db0: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
7dc0: 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 64 72 tala).... (cdr
7dd0: 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 61 72 tala).... (car
7de0: 20 74 61 6c 62 29 0a 09 09 09 20 20 0a 09 09 09 talb).... ....
7df0: 20 20 28 63 64 72 20 74 61 6c 62 29 29 29 0a 09 (cdr talb)))..
7e00: 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 4e 65 65 .#f)))))..;; Nee
7e10: 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 6c 69 73 ded for long lis
7e20: 74 73 20 74 6f 20 62 65 20 73 6f 72 74 65 64 20 ts to be sorted
7e30: 77 68 65 72 65 20 28 61 70 70 6c 79 20 6d 61 78 where (apply max
7e40: 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b 3b 0a 28 ... ) dies.;;.(
7e50: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d define (common:m
7e60: 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 6c 65 74 ax inlst). (let
7e70: 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 61 6c 20 loop ((max-val
7e80: 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 (car inlst))..
7e90: 20 20 20 28 68 65 64 20 20 20 20 20 28 63 61 72 (hed (car
7ea0: 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 20 20 28 inlst)).. (
7eb0: 74 61 6c 20 20 20 20 20 28 63 64 72 20 69 6e 6c tal (cdr inl
7ec0: 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e st))). (if (n
7ed0: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a ot (null? tal)).
7ee0: 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 65 64 20 .(loop (max hed
7ef0: 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 20 20 20 max-val)..
7f00: 28 63 61 72 20 74 61 6c 29 0a 09 20 20 20 20 20 (car tal)..
7f10: 20 28 63 64 72 20 74 61 6c 29 29 0a 09 28 6d 61 (cdr tal))..(ma
7f20: 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 29 29 x hed max-val)))
7f30: 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e 20 6f 72 )..;; get min or
7f40: 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 6f 72 20 max, use > for
7f50: 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 20 6d 69 max and < for mi
7f60: 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 20 61 72 n, this works ar
7f70: 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 74 73 20 ound the limits
7f80: 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 64 65 66 on apply.;;.(def
7f90: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d 69 6e 2d ine (common:min-
7fa0: 6d 61 78 20 63 6f 6d 70 20 6c 73 74 29 0a 20 20 max comp lst).
7fb0: 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 29 0a (if (null? lst).
7fc0: 20 20 20 20 20 20 23 66 20 3b 3b 20 62 65 74 74 #f ;; bett
7fd0: 65 72 20 74 68 61 6e 20 61 6e 20 65 78 63 65 70 er than an excep
7fe0: 74 69 6f 6e 20 66 6f 72 20 6d 79 20 6e 65 65 64 tion for my need
7ff0: 73 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c s. (fold (l
8000: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 20 20 ambda (a b)..
8010: 20 20 20 28 69 66 20 28 63 6f 6d 70 20 61 20 62 (if (comp a b
8020: 29 20 61 20 62 29 29 0a 09 20 20 20 20 28 63 61 ) a b)).. (ca
8030: 72 20 6c 73 74 29 0a 09 20 20 20 20 6c 73 74 29 r lst).. lst)
8040: 29 29 0a 0a 3b 3b 20 70 61 74 68 20 6c 69 73 74 ))..;; path list
8050: 20 74 6f 20 68 61 73 68 2d 74 61 62 6c 65 20 74 to hash-table t
8060: 72 65 65 0a 3b 3b 20 20 20 28 28 61 20 62 20 63 ree.;; ((a b c
8070: 29 28 61 20 62 20 64 29 28 65 20 62 20 63 29 29 )(a b d)(e b c))
8080: 20 3d 3e 20 28 28 61 20 28 62 20 28 64 29 20 28 => ((a (b (d) (
8090: 63 29 29 29 20 28 65 20 28 62 20 28 63 29 29 29 c))) (e (b (c)))
80a0: 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ).;;.(define (co
80b0: 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 65 65 mmon:list->htree
80c0: 20 6c 73 74 29 0a 20 20 28 6c 65 74 20 28 28 72 lst). (let ((r
80d0: 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 esh (make-hash-t
80e0: 61 62 6c 65 29 29 29 0a 20 20 20 20 28 66 6f 72 able))). (for
80f0: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
8100: 64 61 20 28 69 6e 6c 73 74 29 0a 20 20 20 20 20 da (inlst).
8110: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 74 (let loop ((ht
8120: 20 20 72 65 73 68 29 0a 09 09 20 20 28 68 65 64 resh)... (hed
8130: 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 09 (car inlst))...
8140: 20 20 28 74 61 6c 20 28 63 64 72 20 69 6e 6c 73 (tal (cdr inls
8150: 74 29 29 29 0a 09 20 28 69 66 20 28 68 61 73 68 t))).. (if (hash
8160: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
8170: 6c 74 20 68 74 20 68 65 64 20 23 66 29 0a 09 20 lt ht hed #f)..
8180: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 (if (not (nu
8190: 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 28 6c 6f ll? tal))... (lo
81a0: 6f 70 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 op (hash-table-r
81b0: 65 66 20 68 74 20 68 65 64 29 0a 09 09 20 20 20 ef ht hed)...
81c0: 20 20 20 20 28 63 61 72 20 74 61 6c 29 0a 09 09 (car tal)...
81d0: 20 20 20 20 20 20 20 28 63 64 72 20 74 61 6c 29 (cdr tal)
81e0: 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a )).. (begin.
81f0: 09 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 . (hash-ta
8200: 62 6c 65 2d 73 65 74 21 20 68 74 20 68 65 64 20 ble-set! ht hed
8210: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
8220: 29 29 0a 09 20 20 20 20 20 20 20 28 6c 6f 6f 70 )).. (loop
8230: 20 68 74 20 68 65 64 20 74 61 6c 29 29 29 29 29 ht hed tal)))))
8240: 0a 20 20 20 20 20 6c 73 74 29 0a 20 20 20 20 72 . lst). r
8250: 65 73 68 29 29 0a 0a 3b 3b 20 68 61 73 68 2d 74 esh))..;; hash-t
8260: 61 62 6c 65 20 74 72 65 65 20 74 6f 20 68 74 6d able tree to htm
8270: 6c 20 6c 69 73 74 20 74 72 65 65 0a 3b 3b 0a 3b l list tree.;;.;
8280: 3b 20 20 20 74 69 70 66 75 6e 63 20 74 61 6b 65 ; tipfunc take
8290: 73 20 74 77 6f 20 70 61 72 61 6d 65 74 65 72 73 s two parameters
82a0: 3a 20 79 20 74 68 65 20 74 69 70 20 76 61 6c 75 : y the tip valu
82b0: 65 20 61 6e 64 20 70 61 74 68 20 74 68 65 20 70 e and path the p
82c0: 61 74 68 20 74 6f 20 74 68 61 74 20 70 6f 69 6e ath to that poin
82d0: 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f t.;;.(define (co
82e0: 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c mmon:htree->html
82f0: 20 68 74 20 70 61 74 68 20 74 69 70 66 75 6e 63 ht path tipfunc
8300: 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 6c 69 ). (let ((datli
8310: 73 74 20 09 28 73 6f 72 74 20 28 68 61 73 68 2d st .(sort (hash-
8320: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 74 29 table->alist ht)
8330: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
8340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
8350: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 20 20 lambda (a b).
8360: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8370: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
8380: 72 69 6e 67 3c 20 28 63 61 72 20 61 29 28 63 61 ring< (car a)(ca
8390: 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 28 69 r b)))))). (i
83a0: 66 20 28 6e 75 6c 6c 3f 20 64 61 74 6c 69 73 74 f (null? datlist
83b0: 29 0a 20 20 20 20 09 28 74 69 70 66 75 6e 63 20 ). .(tipfunc
83c0: 23 66 20 70 61 74 68 29 20 3b 3b 20 72 65 61 6c #f path) ;; real
83d0: 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 67 65 74 ly shouldn't get
83e0: 20 68 65 72 65 0a 09 28 73 3a 75 6c 0a 09 20 28 here..(s:ul.. (
83f0: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
8400: 09 09 28 6c 65 74 2a 20 28 28 6c 65 76 65 6c 6e ..(let* ((leveln
8410: 61 6d 65 20 28 63 61 72 20 78 29 29 0a 09 09 20 ame (car x))...
8420: 20 20 20 20 20 20 28 79 20 20 20 20 20 20 20 20 (y
8430: 20 28 63 64 72 20 78 29 29 0a 09 09 20 20 20 20 (cdr x))...
8440: 20 20 20 28 6e 65 77 70 61 74 68 20 20 20 28 61 (newpath (a
8450: 70 70 65 6e 64 20 70 61 74 68 20 28 6c 69 73 74 ppend path (list
8460: 20 6c 65 76 65 6c 6e 61 6d 65 29 29 29 0a 09 09 levelname)))...
8470: 20 20 20 20 20 20 20 28 6c 65 61 66 20 20 20 20 (leaf
8480: 20 20 28 6f 72 20 28 6e 6f 74 20 28 68 61 73 68 (or (not (hash
8490: 2d 74 61 62 6c 65 3f 20 79 29 29 0a 09 09 09 09 -table? y)).....
84a0: 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 28 68 61 (null? (ha
84b0: 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 79 29 sh-table-keys y)
84c0: 29 29 29 29 0a 09 09 20 20 28 69 66 20 6c 65 61 ))))... (if lea
84d0: 66 0a 09 09 20 20 20 20 20 20 28 73 3a 6c 69 20 f... (s:li
84e0: 28 74 69 70 66 75 6e 63 20 79 20 6e 65 77 70 61 (tipfunc y newpa
84f0: 74 68 29 29 0a 09 09 20 20 20 20 20 20 28 73 3a th))... (s:
8500: 6c 69 0a 09 09 20 20 20 20 20 20 20 28 6c 69 73 li... (lis
8510: 74 20 0a 09 09 09 6c 65 76 65 6c 6e 61 6d 65 0a t ....levelname.
8520: 09 09 09 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 ...(common:htree
8530: 2d 3e 68 74 6d 6c 20 79 20 6e 65 77 70 61 74 68 ->html y newpath
8540: 20 74 69 70 66 75 6e 63 29 29 29 29 29 29 0a 09 tipfunc))))))..
8550: 20 20 20 20 20 20 64 61 74 6c 69 73 74 29 29 29 datlist)))
8560: 29 29 0a 0a 3b 3b 20 68 61 73 68 2d 74 61 62 6c ))..;; hash-tabl
8570: 65 20 74 72 65 65 20 74 6f 20 61 6c 69 73 74 20 e tree to alist
8580: 74 72 65 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 tree.;;.(define
8590: 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 61 (common:htree->a
85a0: 74 72 65 65 20 68 74 29 0a 20 20 28 6d 61 70 20 tree ht). (map
85b0: 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 20 28 63 (lambda (x).. (c
85c0: 6f 6e 73 20 28 63 61 72 20 78 29 0a 09 20 20 20 ons (car x)..
85d0: 20 20 20 20 28 6c 65 74 20 28 28 79 20 28 63 64 (let ((y (cd
85e0: 72 20 78 29 29 29 0a 09 09 20 28 69 66 20 28 68 r x)))... (if (h
85f0: 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 0a 09 09 ash-table? y)...
8600: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 (common:htr
8610: 65 65 2d 3e 61 74 72 65 65 20 79 29 0a 09 09 20 ee->atree y)...
8620: 20 20 20 20 79 29 29 29 29 0a 20 20 20 20 20 20 y)))).
8630: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
8640: 69 73 74 20 68 74 29 29 29 0a 0a 3b 3b 3d 3d 3d ist ht)))..;;===
8650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8690: 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4e 20 47 20 45 ===.;; M U N G E
86a0: 20 20 20 44 20 41 20 54 20 41 20 20 20 49 20 4e D A T A I N
86b0: 20 54 20 4f 20 20 20 4e 20 49 20 43 20 45 20 20 T O N I C E
86c0: 20 46 20 4f 20 52 20 4d 20 53 0a 3b 3b 3d 3d 3d F O R M S.;;===
86d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8710: 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 72 61 74 65 ===..;; Generate
8720: 20 61 6e 20 69 6e 64 65 78 20 66 6f 72 20 61 20 an index for a
8730: 73 70 61 72 73 65 20 6c 69 73 74 20 6f 66 20 6b sparse list of k
8740: 65 79 20 76 61 6c 75 65 73 0a 3b 3b 20 20 20 28 ey values.;; (
8750: 20 28 72 6f 77 6e 61 6d 65 31 20 63 6f 6c 6e 61 (rowname1 colna
8760: 6d 65 31 20 76 61 6c 31 29 28 72 6f 77 6e 61 6d me1 val1)(rownam
8770: 65 32 20 63 6f 6c 6e 61 6d 65 32 20 76 61 6c 32 e2 colname2 val2
8780: 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e 20 0a 3b 3b ) ).;;.;; => .;;
8790: 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e 61 6d 65 .;; ( (rowname
87a0: 31 20 30 29 28 72 6f 77 6e 61 6d 65 32 20 31 29 1 0)(rowname2 1)
87b0: 29 20 20 20 20 3b 3b 20 72 6f 77 6e 61 6d 65 73 ) ;; rownames
87c0: 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 20 20 20 28 -> num.;; (
87d0: 63 6f 6c 6e 61 6d 65 31 20 30 29 28 63 6f 6c 6e colname1 0)(coln
87e0: 61 6d 65 32 20 31 29 29 20 29 20 20 3b 3b 20 63 ame2 1)) ) ;; c
87f0: 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b olnames -> num.;
8800: 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e 61 6c 20 61 ; .;; optional a
8810: 70 70 6c 79 20 70 72 6f 63 20 74 6f 20 72 6f 77 pply proc to row
8820: 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 61 6c 75 65 num colnum value
8830: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
8840: 3a 73 70 61 72 73 65 2d 6c 69 73 74 2d 67 65 6e :sparse-list-gen
8850: 65 72 61 74 65 2d 69 6e 64 65 78 20 64 61 74 61 erate-index data
8860: 20 23 21 6b 65 79 20 28 70 72 6f 63 20 23 66 29 #!key (proc #f)
8870: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 ). (if (null? d
8880: 61 74 61 29 0a 20 20 20 20 20 20 28 6c 69 73 74 ata). (list
8890: 20 27 28 29 20 27 28 29 29 0a 20 20 20 20 20 20 '() '()).
88a0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
88b0: 28 63 61 72 20 64 61 74 61 29 29 0a 09 09 20 28 (car data))... (
88c0: 74 61 6c 20 28 63 64 72 20 64 61 74 61 29 29 0a tal (cdr data)).
88d0: 09 09 20 28 72 6f 77 6e 61 6d 65 73 20 27 28 29 .. (rownames '()
88e0: 29 0a 09 09 20 28 63 6f 6c 6e 61 6d 65 73 20 27 )... (colnames '
88f0: 28 29 29 0a 09 09 20 28 72 6f 77 6e 75 6d 20 20 ())... (rownum
8900: 20 30 29 0a 09 09 20 28 63 6f 6c 6e 75 6d 20 20 0)... (colnum
8910: 20 30 29 29 0a 09 28 6c 65 74 2a 20 28 28 72 6f 0))..(let* ((ro
8920: 77 6b 65 79 20 20 20 20 20 20 20 20 20 20 28 63 wkey (c
8930: 61 72 20 20 20 68 65 64 29 29 0a 09 20 20 20 20 ar hed))..
8940: 20 20 20 28 63 6f 6c 6b 65 79 20 20 20 20 20 20 (colkey
8950: 20 20 20 20 28 63 61 64 72 20 20 68 65 64 29 29 (cadr hed))
8960: 0a 09 20 20 20 20 20 20 20 28 76 61 6c 75 65 20 .. (value
8970: 20 20 20 20 20 20 20 20 20 20 28 63 61 64 64 72 (caddr
8980: 20 68 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 hed)).. (
8990: 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 20 existing-rowdat
89a0: 28 61 73 73 6f 63 20 72 6f 77 6b 65 79 20 72 6f (assoc rowkey ro
89b0: 77 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 20 20 wnames))..
89c0: 20 28 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 (existing-colda
89d0: 74 20 28 61 73 73 6f 63 20 63 6f 6c 6b 65 79 20 t (assoc colkey
89e0: 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 colnames))..
89f0: 20 20 20 28 63 75 72 72 2d 72 6f 77 6e 75 6d 20 (curr-rownum
8a00: 20 20 20 20 28 69 66 20 65 78 69 73 74 69 6e 67 (if existing
8a10: 2d 72 6f 77 64 61 74 20 72 6f 77 6e 75 6d 20 28 -rowdat rownum (
8a20: 2b 20 72 6f 77 6e 75 6d 20 31 29 29 29 0a 09 20 + rownum 1)))..
8a30: 20 20 20 20 20 20 28 63 75 72 72 2d 63 6f 6c 6e (curr-coln
8a40: 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 74 um (if exist
8a50: 69 6e 67 2d 63 6f 6c 64 61 74 20 63 6f 6c 6e 75 ing-coldat colnu
8a60: 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 31 29 29 29 m (+ colnum 1)))
8a70: 0a 09 20 20 20 20 20 20 20 28 6e 65 77 2d 72 6f .. (new-ro
8a80: 77 6e 61 6d 65 73 20 20 20 20 28 69 66 20 65 78 wnames (if ex
8a90: 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f isting-rowdat ro
8aa0: 77 6e 61 6d 65 73 20 28 63 6f 6e 73 20 28 6c 69 wnames (cons (li
8ab0: 73 74 20 72 6f 77 6b 65 79 20 63 75 72 72 2d 72 st rowkey curr-r
8ac0: 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 6d 65 73 29 ownum) rownames)
8ad0: 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 77 2d )).. (new-
8ae0: 63 6f 6c 6e 61 6d 65 73 20 20 20 20 28 69 66 20 colnames (if
8af0: 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 existing-coldat
8b00: 63 6f 6c 6e 61 6d 65 73 20 28 63 6f 6e 73 20 28 colnames (cons (
8b10: 6c 69 73 74 20 63 6f 6c 6b 65 79 20 63 75 72 72 list colkey curr
8b20: 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c 6e 61 6d 65 -colnum) colname
8b30: 73 29 29 29 29 0a 09 20 20 3b 3b 20 28 64 65 62 s)))).. ;; (deb
8b40: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
8b50: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8b60: 74 2a 20 22 50 72 6f 63 65 73 73 69 6e 67 20 72 t* "Processing r
8b70: 65 63 6f 72 64 3a 20 22 20 68 65 64 20 29 0a 09 ecord: " hed )..
8b80: 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 6f 63 (if proc (proc
8b90: 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 63 75 72 curr-rownum cur
8ba0: 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 6b 65 79 20 r-colnum rowkey
8bb0: 63 6f 6c 6b 65 79 20 76 61 6c 75 65 29 29 0a 09 colkey value))..
8bc0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
8bd0: 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 20 6e ).. (list n
8be0: 65 77 2d 72 6f 77 6e 61 6d 65 73 20 6e 65 77 2d ew-rownames new-
8bf0: 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 20 20 20 20 colnames)..
8c00: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
8c10: 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 6c 29 ... (cdr tal)
8c20: 0a 09 09 20 20 20 20 6e 65 77 2d 72 6f 77 6e 61 ... new-rowna
8c30: 6d 65 73 0a 09 09 20 20 20 20 6e 65 77 2d 63 6f mes... new-co
8c40: 6c 6e 61 6d 65 73 0a 09 09 20 20 20 20 28 69 66 lnames... (if
8c50: 20 28 3e 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 (> curr-rownum
8c60: 72 6f 77 6e 75 6d 29 20 63 75 72 72 2d 72 6f 77 rownum) curr-row
8c70: 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a 09 09 20 20 num rownum)...
8c80: 20 20 28 69 66 20 28 3e 20 63 75 72 72 2d 63 6f (if (> curr-co
8c90: 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 20 63 75 72 lnum colnum) cur
8ca0: 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 r-colnum colnum)
8cb0: 0a 09 09 20 20 20 20 29 29 29 29 29 29 0a 0a 3b ... ))))))..;
8cc0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
8cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d00: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 59 20 53 =======.;; S Y S
8d10: 20 54 20 45 20 4d 20 20 20 53 20 54 20 55 20 46 T E M S T U F
8d20: 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F.;;===========
8d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
8d70: 6c 61 7a 79 2d 73 61 66 65 20 67 65 74 20 66 69 lazy-safe get fi
8d80: 6c 65 20 6d 6f 64 20 74 69 6d 65 2e 20 6f 6e 20 le mod time. on
8d90: 61 6e 79 20 65 72 72 6f 72 20 28 66 69 6c 65 20 any error (file
8da0: 6e 6f 74 20 65 78 69 73 74 69 6e 67 20 65 74 63 not existing etc
8db0: 2e 29 20 72 65 74 75 72 6e 20 30 0a 3b 3b 0a 28 .) return 0.;;.(
8dc0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c define (common:l
8dd0: 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e azy-modification
8de0: 2d 74 69 6d 65 20 66 70 61 74 68 29 0a 20 20 28 -time fpath). (
8df0: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
8e00: 73 0a 20 20 20 65 78 6e 0a 20 20 20 30 0a 20 20 s. exn. 0.
8e10: 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 (file-modificat
8e20: 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 29 ion-time fpath))
8e30: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 61 20 6e )..;; return a n
8e40: 69 63 65 20 63 6c 65 61 6e 20 70 61 74 68 6e 61 ice clean pathna
8e50: 6d 65 20 6d 61 64 65 20 61 62 73 6f 6c 75 74 65 me made absolute
8e60: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
8e70: 3a 6e 69 63 65 2d 70 61 74 68 20 64 69 72 29 0a :nice-path dir).
8e80: 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 (let ((match (
8e90: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 28 string-match "^(
8ea0: 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 2e 2a 7c ~[^\\/]*)(\\/.*|
8eb0: 29 24 22 20 64 69 72 29 29 29 0a 20 20 20 20 28 )$" dir))). (
8ec0: 69 66 20 6d 61 74 63 68 20 3b 3b 20 75 73 69 6e if match ;; usin
8ed0: 67 20 7e 20 66 6f 72 20 68 6f 6d 65 3f 0a 09 28 g ~ for home?..(
8ee0: 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 common:nice-path
8ef0: 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 72 (conc (common:r
8f00: 65 61 64 2d 6c 69 6e 6b 2d 66 20 28 63 61 64 72 ead-link-f (cadr
8f10: 20 6d 61 74 63 68 29 29 20 22 2f 22 20 28 63 61 match)) "/" (ca
8f20: 64 64 72 20 6d 61 74 63 68 29 29 29 0a 09 28 6e ddr match)))..(n
8f30: 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 68 6e 61 6d ormalize-pathnam
8f40: 65 20 28 69 66 20 28 61 62 73 6f 6c 75 74 65 2d e (if (absolute-
8f50: 70 61 74 68 6e 61 6d 65 3f 20 64 69 72 29 0a 09 pathname? dir)..
8f60: 09 09 09 64 69 72 0a 09 09 09 09 28 63 6f 6e 63 ...dir.....(conc
8f70: 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
8f80: 6f 72 79 29 20 22 2f 22 20 64 69 72 29 29 29 29 ory) "/" dir))))
8f90: 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 22 6e 69 63 ))..;; make "nic
8fa0: 65 2d 70 61 74 68 22 20 61 76 61 69 6c 61 62 6c e-path" availabl
8fb0: 65 20 69 6e 20 63 6f 6e 66 69 67 20 66 69 6c 65 e in config file
8fc0: 73 20 61 6e 64 20 74 68 65 20 72 65 70 6c 0a 28 s and the repl.(
8fd0: 64 65 66 69 6e 65 20 6e 69 63 65 2d 70 61 74 68 define nice-path
8fe0: 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 common:nice-pat
8ff0: 68 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d h)..(define (com
9000: 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 mon:read-link-f
9010: 70 61 74 68 29 0a 20 20 28 68 61 6e 64 6c 65 2d path). (handle-
9020: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
9030: 20 65 78 6e 0a 20 20 20 20 20 20 28 62 65 67 69 exn. (begi
9040: 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d n..(debug:print-
9050: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
9060: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d 6d -log-port* "comm
9070: 61 6e 64 20 5c 22 2f 62 69 6e 2f 72 65 61 64 6c and \"/bin/readl
9080: 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 20 22 5c ink -f " path "\
9090: 22 20 66 61 69 6c 65 64 2e 22 29 0a 09 70 61 74 " failed.")..pat
90a0: 68 29 20 3b 3b 20 6a 75 73 74 20 67 69 76 65 20 h) ;; just give
90b0: 75 70 0a 20 20 20 20 28 77 69 74 68 2d 69 6e 70 up. (with-inp
90c0: 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 28 63 ut-from-pipe..(c
90d0: 6f 6e 63 20 22 2f 62 69 6e 2f 72 65 61 64 6c 69 onc "/bin/readli
90e0: 6e 6b 20 2d 66 20 22 20 70 61 74 68 29 0a 20 20 nk -f " path).
90f0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
9100: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a (read-line))))).
9110: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 63 70 .(define (get-cp
9120: 75 2d 6c 6f 61 64 20 23 21 6b 65 79 20 28 72 65 u-load #!key (re
9130: 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 mote-host #f)).
9140: 20 28 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (car (common:ge
9150: 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 t-cpu-load remot
9160: 65 2d 68 6f 73 74 29 29 29 0a 3b 3b 20 20 20 28 e-host))).;; (
9170: 6c 65 74 2a 20 28 28 6c 6f 61 64 2d 72 65 73 20 let* ((load-res
9180: 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e (process:cmd-run
9190: 2d 3e 6c 69 73 74 20 22 75 70 74 69 6d 65 22 29 ->list "uptime")
91a0: 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 2d 72 78 20 ).;; . (load-rx
91b0: 20 28 72 65 67 65 78 70 20 22 6c 6f 61 64 20 61 (regexp "load a
91c0: 76 65 72 61 67 65 3a 5c 5c 73 2b 28 5c 5c 64 2b verage:\\s+(\\d+
91d0: 29 22 29 29 0a 3b 3b 20 09 20 28 63 70 75 2d 6c )")).;; . (cpu-l
91e0: 6f 61 64 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 oad #f)).;;
91f0: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
9200: 61 20 28 6c 29 0a 3b 3b 20 09 09 28 6c 65 74 20 a (l).;; ..(let
9210: 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d ((match (string-
9220: 73 65 61 72 63 68 20 6c 6f 61 64 2d 72 78 20 6c search load-rx l
9230: 29 29 29 0a 3b 3b 20 09 09 20 20 28 69 66 20 6d ))).;; .. (if m
9240: 61 74 63 68 0a 3b 3b 20 09 09 20 20 20 20 20 20 atch.;; ..
9250: 28 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 (let ((newval (s
9260: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 tring->number (c
9270: 61 64 72 20 6d 61 74 63 68 29 29 29 29 0a 3b 3b adr match)))).;;
9280: 20 09 09 09 28 69 66 20 28 6e 75 6d 62 65 72 3f ...(if (number?
9290: 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 09 09 09 20 newval).;; ...
92a0: 20 20 20 28 73 65 74 21 20 63 70 75 2d 6c 6f 61 (set! cpu-loa
92b0: 64 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a 3b d newval)))))).;
92c0: 3b 20 09 20 20 20 20 20 20 28 63 61 72 20 6c 6f ; . (car lo
92d0: 61 64 2d 72 65 73 29 29 0a 3b 3b 20 20 20 20 20 ad-res)).;;
92e0: 63 70 75 2d 6c 6f 61 64 29 29 0a 0a 3b 3b 20 67 cpu-load))..;; g
92f0: 65 74 20 63 70 75 20 6c 6f 61 64 20 62 79 20 72 et cpu load by r
9300: 65 61 64 69 6e 67 20 66 72 6f 6d 20 2f 70 72 6f eading from /pro
9310: 63 2f 6c 6f 61 64 61 76 67 2c 20 72 65 74 75 72 c/loadavg, retur
9320: 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 61 6c 75 n all three valu
9330: 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 es.;;.(define (c
9340: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f ommon:get-cpu-lo
9350: 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a ad remote-host).
9360: 20 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f 73 (if remote-hos
9370: 74 0a 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 t. (map (la
9380: 6d 62 64 61 20 28 72 65 73 29 0a 09 20 20 20 20 mbda (res)..
9390: 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (if (eof-object
93a0: 3f 20 72 65 73 29 20 39 65 39 39 20 72 65 73 29 ? res) 9e99 res)
93b0: 29 0a 09 20 20 20 28 77 69 74 68 2d 69 6e 70 75 ).. (with-inpu
93c0: 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 20 20 t-from-pipe ..
93d0: 20 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 72 (conc "ssh " r
93e0: 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 74 emote-host " cat
93f0: 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 29 /proc/loadavg")
9400: 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 .. (lambda ()
9410: 28 6c 69 73 74 20 28 72 65 61 64 29 28 72 65 61 (list (read)(rea
9420: 64 29 28 72 65 61 64 29 29 29 29 29 0a 20 20 20 d)(read))))).
9430: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
9440: 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f rom-file "/proc/
9450: 6c 6f 61 64 61 76 67 22 20 0a 09 28 6c 61 6d 62 loadavg" ..(lamb
9460: 64 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 da ()(list (read
9470: 29 28 72 65 61 64 29 28 72 65 61 64 29 29 29 29 )(read)(read))))
9480: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
9490: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 mon:wait-for-cpu
94a0: 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d load maxload num
94b0: 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 20 23 cpus waitdelay #
94c0: 21 6b 65 79 20 28 63 6f 75 6e 74 20 31 30 30 30 !key (count 1000
94d0: 29 20 28 6d 73 67 20 23 66 29 28 72 65 6d 6f 74 ) (msg #f)(remot
94e0: 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 20 28 6c e-host #f)). (l
94f0: 65 74 2a 20 28 28 6c 6f 61 64 61 76 67 20 28 63 et* ((loadavg (c
9500: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f ommon:get-cpu-lo
9510: 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 ad remote-host))
9520: 0a 09 20 28 66 69 72 73 74 20 20 20 28 63 61 72 .. (first (car
9530: 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 6e 65 loadavg)).. (ne
9540: 78 74 20 20 20 20 28 63 61 64 72 20 6c 6f 61 64 xt (cadr load
9550: 61 76 67 29 29 0a 09 20 28 61 64 6a 6c 6f 61 64 avg)).. (adjload
9560: 20 28 2a 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 (* maxload numc
9570: 70 75 73 29 29 0a 09 20 28 6c 6f 61 64 6a 6d 70 pus)).. (loadjmp
9580: 20 28 2d 20 66 69 72 73 74 20 6e 65 78 74 29 29 (- first next))
9590: 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
95a0: 20 28 28 61 6e 64 20 28 3e 20 66 69 72 73 74 20 ((and (> first
95b0: 61 64 6a 6c 6f 61 64 29 0a 09 20 20 20 28 3e 20 adjload).. (>
95c0: 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 20 count 0)).
95d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
95e0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
95f0: 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 6e 67 20 -port* "waiting
9600: 22 20 77 61 69 74 64 65 6c 61 79 20 22 20 73 65 " waitdelay " se
9610: 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f 61 conds due to loa
9620: 64 20 22 20 66 69 72 73 74 20 22 20 65 78 63 65 d " first " exce
9630: 65 64 69 6e 67 20 6d 61 78 20 6f 66 20 22 20 61 eding max of " a
9640: 64 6a 6c 6f 61 64 20 28 69 66 20 6d 73 67 20 6d djload (if msg m
9650: 73 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 sg "")). (t
9660: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 77 61 69 hread-sleep! wai
9670: 74 64 65 6c 61 79 29 0a 20 20 20 20 20 20 28 63 tdelay). (c
9680: 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 ommon:wait-for-c
9690: 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e puload maxload n
96a0: 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 umcpus waitdelay
96b0: 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 count: (- count
96c0: 20 31 29 29 29 0a 20 20 20 20 20 28 28 61 6e 64 1))). ((and
96d0: 20 28 3e 20 6c 6f 61 64 6a 6d 70 20 6e 75 6d 63 (> loadjmp numc
96e0: 70 75 73 29 0a 09 20 20 20 28 3e 20 63 6f 75 6e pus).. (> coun
96f0: 74 20 30 29 29 0a 20 20 20 20 20 20 28 64 65 62 t 0)). (deb
9700: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
9710: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
9720: 74 2a 20 22 77 61 69 74 69 6e 67 20 22 20 77 61 t* "waiting " wa
9730: 69 74 64 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 itdelay " second
9740: 73 20 64 75 65 20 74 6f 20 6c 6f 61 64 20 6a 75 s due to load ju
9750: 6d 70 20 22 20 6c 6f 61 64 6a 6d 70 20 22 20 3e mp " loadjmp " >
9760: 20 6e 75 6d 63 70 75 73 20 22 20 6e 75 6d 63 70 numcpus " numcp
9770: 75 73 20 28 69 66 20 6d 73 67 20 6d 73 67 20 22 us (if msg msg "
9780: 22 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 ")). (threa
9790: 64 2d 73 6c 65 65 70 21 20 77 61 69 74 64 65 6c d-sleep! waitdel
97a0: 61 79 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f ay). (commo
97b0: 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f n:wait-for-cpulo
97c0: 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 ad maxload numcp
97d0: 75 73 20 77 61 69 74 64 65 6c 61 79 20 63 6f 75 us waitdelay cou
97e0: 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 20 31 29 29 nt: (- count 1))
97f0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
9800: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 ommon:get-num-cp
9810: 75 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a us remote-host).
9820: 20 20 28 6c 65 74 20 28 28 70 72 6f 63 20 28 6c (let ((proc (l
9830: 61 6d 62 64 61 20 28 29 0a 09 09 28 6c 65 74 20 ambda ()...(let
9840: 6c 6f 6f 70 20 28 28 6e 75 6d 63 70 75 20 30 29 loop ((numcpu 0)
9850: 0a 09 09 09 20 20 20 28 69 6e 6c 20 20 20 20 28 .... (inl (
9860: 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 09 20 read-line)))...
9870: 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (if (eof-object
9880: 3f 20 69 6e 6c 29 0a 09 09 20 20 20 20 20 20 6e ? inl)... n
9890: 75 6d 63 70 75 0a 09 09 20 20 20 20 20 20 28 6c umcpu... (l
98a0: 6f 6f 70 20 28 69 66 20 28 73 74 72 69 6e 67 2d oop (if (string-
98b0: 6d 61 74 63 68 20 22 5e 70 72 6f 63 65 73 73 6f match "^processo
98c0: 72 5c 5c 73 2b 3a 5c 5c 73 2b 5c 5c 64 2b 24 22 r\\s+:\\s+\\d+$"
98d0: 20 69 6e 6c 29 0a 09 09 09 09 28 2b 20 6e 75 6d inl).....(+ num
98e0: 63 70 75 20 31 29 0a 09 09 09 09 6e 75 6d 63 70 cpu 1).....numcp
98f0: 75 29 0a 09 09 09 20 20 20 20 28 72 65 61 64 2d u).... (read-
9900: 6c 69 6e 65 29 29 29 29 29 29 29 0a 20 20 20 20 line))))))).
9910: 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f 73 74 0a (if remote-host.
9920: 09 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f .(with-input-fro
9930: 6d 2d 70 69 70 65 20 0a 09 20 28 63 6f 6e 63 20 m-pipe .. (conc
9940: 22 73 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f "ssh " remote-ho
9950: 73 74 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 63 st " cat /proc/c
9960: 70 75 69 6e 66 6f 22 29 0a 09 20 70 72 6f 63 29 puinfo").. proc)
9970: 0a 09 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 ..(with-input-fr
9980: 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 63 om-file "/proc/c
9990: 70 75 69 6e 66 6f 22 20 70 72 6f 63 29 29 29 29 puinfo" proc))))
99a0: 0a 0a 3b 3b 20 77 61 69 74 20 66 6f 72 20 6e 6f ..;; wait for no
99b0: 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f 61 rmalized cpu loa
99c0: 64 20 74 6f 20 64 72 6f 70 20 62 65 6c 6f 77 20 d to drop below
99d0: 6d 61 78 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 maxload.;;.(defi
99e0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d ne (common:wait-
99f0: 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c for-normalized-l
9a00: 6f 61 64 20 6d 61 78 6c 6f 61 64 20 23 21 6b 65 oad maxload #!ke
9a10: 79 20 28 6d 73 67 20 23 66 29 28 72 65 6d 6f 74 y (msg #f)(remot
9a20: 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 20 28 6c e-host #f)). (l
9a30: 65 74 20 28 28 6e 75 6d 2d 63 70 75 73 20 28 63 et ((num-cpus (c
9a40: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 ommon:get-num-cp
9a50: 75 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 us remote-host))
9a60: 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 ). (common:wa
9a70: 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d it-for-cpuload m
9a80: 61 78 6c 6f 61 64 20 6e 75 6d 2d 63 70 75 73 20 axload num-cpus
9a90: 31 35 20 6d 73 67 3a 20 6d 73 67 29 29 29 0a 0a 15 msg: msg)))..
9aa0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 75 6e 61 (define (get-una
9ab0: 6d 65 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 me . params). (
9ac0: 6c 65 74 2a 20 28 28 75 6e 61 6d 65 2d 72 65 73 let* ((uname-res
9ad0: 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 (process:cmd-ru
9ae0: 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 n->list (conc "u
9af0: 6e 61 6d 65 20 22 20 28 69 66 20 28 6e 75 6c 6c name " (if (null
9b00: 3f 20 70 61 72 61 6d 73 29 20 22 2d 61 22 20 28 ? params) "-a" (
9b10: 63 61 72 20 70 61 72 61 6d 73 29 29 29 29 29 0a car params))))).
9b20: 09 20 28 75 6e 61 6d 65 20 23 66 29 29 0a 20 20 . (uname #f)).
9b30: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 61 (if (null? (ca
9b40: 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 0a 09 22 r uname-res)).."
9b50: 75 6e 6b 6e 6f 77 6e 22 0a 09 28 63 61 61 72 20 unknown"..(caar
9b60: 75 6e 61 6d 65 2d 72 65 73 29 29 29 29 0a 0a 3b uname-res))))..;
9b70: 3b 20 66 6f 72 20 72 65 61 73 6f 6e 73 20 49 20 ; for reasons I
9b80: 64 6f 6e 27 74 20 75 6e 64 65 72 73 74 61 6e 64 don't understand
9b90: 20 6d 75 6c 74 69 70 6c 65 20 63 61 6c 6c 73 20 multiple calls
9ba0: 74 6f 20 72 65 61 6c 2d 70 61 74 68 20 69 6e 20 to real-path in
9bb0: 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 73 parallel threads
9bc0: 0a 3b 3b 20 6d 75 73 74 20 62 65 20 70 72 6f 74 .;; must be prot
9bd0: 65 63 74 65 64 20 62 79 20 6d 75 74 65 78 65 73 ected by mutexes
9be0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
9bf0: 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 68 20 69 6e mon:real-path in
9c00: 70 61 74 68 29 0a 20 20 3b 3b 20 28 70 72 6f 63 path). ;; (proc
9c10: 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 68 ess:cmd-run-with
9c20: 2d 73 74 64 65 72 72 2d 3e 6c 69 73 74 20 22 72 -stderr->list "r
9c30: 65 61 64 6c 69 6e 6b 22 20 22 2d 66 22 20 69 6e eadlink" "-f" in
9c40: 70 61 74 68 29 29 20 3b 3b 20 63 6d 64 20 2e 20 path)) ;; cmd .
9c50: 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 6c 65 params). ;; (le
9c60: 74 2d 76 61 6c 75 65 73 20 0a 20 20 3b 3b 20 20 t-values . ;;
9c70: 28 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 20 (((inp oup pid)
9c80: 28 70 72 6f 63 65 73 73 20 22 72 65 61 64 6c 69 (process "readli
9c90: 6e 6b 22 20 28 6c 69 73 74 20 22 2d 66 22 20 69 nk" (list "-f" i
9ca0: 6e 70 61 74 68 29 29 29 29 0a 20 20 3b 3b 20 20 npath)))). ;;
9cb0: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
9cc0: 2d 70 6f 72 74 20 69 6e 70 0a 20 20 3b 3b 20 20 -port inp. ;;
9cd0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e (let loop ((in
9ce0: 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 20 l (read-line)).
9cf0: 20 3b 3b 20 20 20 20 20 20 20 09 28 72 65 73 20 ;; .(res
9d00: 23 66 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 28 #f)). ;; (
9d10: 70 72 69 6e 74 20 22 69 6e 6c 3d 22 20 69 6e 6c print "inl=" inl
9d20: 29 0a 20 20 3b 3b 20 20 20 20 20 20 28 69 66 20 ). ;; (if
9d30: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c (eof-object? inl
9d40: 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ). ;;
9d50: 28 62 65 67 69 6e 0a 20 20 3b 3b 20 20 20 20 20 (begin. ;;
9d60: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e (close-in
9d70: 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 20 20 put-port inp).
9d80: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 63 ;; (c
9d90: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
9da0: 20 6f 75 70 29 0a 20 20 3b 3b 20 20 20 20 20 20 oup). ;;
9db0: 20 20 20 20 20 20 3b 3b 20 28 70 72 6f 63 65 73 ;; (proces
9dc0: 73 2d 77 61 69 74 20 70 69 64 29 0a 20 20 3b 3b s-wait pid). ;;
9dd0: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 29 res)
9de0: 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 . ;; (
9df0: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
9e00: 20 69 6e 6c 29 29 29 29 29 29 0a 20 20 28 77 69 inl)))))). (wi
9e10: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
9e20: 70 65 20 28 63 6f 6e 63 20 22 72 65 61 64 6c 69 pe (conc "readli
9e30: 6e 6b 20 2d 66 20 22 20 69 6e 70 61 74 68 29 20 nk -f " inpath)
9e40: 72 65 61 64 2d 6c 69 6e 65 29 29 0a 0a 3b 3b 3d read-line))..;;=
9e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e90: 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 20 53 20 4b =====.;; D I S K
9ea0: 20 20 20 53 20 50 20 41 20 43 20 45 20 0a 3b 3b S P A C E .;;
9eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ef0: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
9f00: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b (common:get-disk
9f10: 2d 73 70 61 63 65 2d 75 73 65 64 20 66 70 61 74 -space-used fpat
9f20: 68 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 h). (with-input
9f30: 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 -from-pipe (conc
9f40: 20 22 2f 75 73 72 2f 62 69 6e 2f 64 75 20 2d 73 "/usr/bin/du -s
9f50: 20 22 20 66 70 61 74 68 29 20 72 65 61 64 29 29 " fpath) read))
9f60: 0a 0a 3b 3b 20 67 69 76 65 6e 20 70 61 74 68 20 ..;; given path
9f70: 67 65 74 20 66 72 65 65 20 73 70 61 63 65 2c 20 get free space,
9f80: 61 6c 6c 6f 77 73 20 6f 76 65 72 72 69 64 65 20 allows override
9f90: 69 6e 20 5b 73 65 74 75 70 5d 0a 3b 3b 20 77 69 in [setup].;; wi
9fa0: 74 68 20 66 72 65 65 2d 73 70 61 63 65 2d 73 63 th free-space-sc
9fb0: 72 69 70 74 20 2f 70 61 74 68 2f 74 6f 2f 73 6f ript /path/to/so
9fc0: 6d 65 2f 73 63 72 69 70 74 2e 73 68 0a 3b 3b 0a me/script.sh.;;.
9fd0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 64 66 20 (define (get-df
9fe0: 70 61 74 68 29 0a 20 20 28 69 66 20 28 63 6f 6e path). (if (con
9ff0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
a000: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
a010: 22 66 72 65 65 2d 73 70 61 63 65 2d 73 63 72 69 "free-space-scri
a020: 70 74 22 29 0a 20 20 20 20 20 20 28 77 69 74 68 pt"). (with
a030: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
a040: 20 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 28 . (conc (
a050: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
a060: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
a070: 70 22 20 22 66 72 65 65 2d 73 70 61 63 65 2d 73 p" "free-space-s
a080: 63 72 69 70 74 22 29 20 22 20 22 20 70 61 74 68 cript") " " path
a090: 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ). (lambda
a0a0: 20 28 29 0a 09 20 28 6c 65 74 20 28 28 72 65 73 ().. (let ((res
a0b0: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 (read-line)))..
a0c0: 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 (if (string?
a0d0: 72 65 73 29 0a 09 20 20 20 20 20 20 20 28 73 74 res).. (st
a0e0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 ring->number res
a0f0: 29 29 29 29 29 0a 20 20 20 20 20 20 28 67 65 74 ))))). (get
a100: 2d 75 6e 69 78 2d 64 66 20 70 61 74 68 29 29 29 -unix-df path)))
a110: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 75 ..(define (get-u
a120: 6e 69 78 2d 64 66 20 70 61 74 68 29 0a 20 20 28 nix-df path). (
a130: 6c 65 74 2a 20 28 28 64 66 2d 72 65 73 75 6c 74 let* ((df-result
a140: 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 s (process:cmd-r
a150: 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 un->list (conc "
a160: 64 66 20 22 20 70 61 74 68 29 29 29 0a 09 20 28 df " path))).. (
a170: 73 70 61 63 65 2d 72 78 20 20 20 28 72 65 67 65 space-rx (rege
a180: 78 70 20 22 28 5b 30 2d 39 5d 2b 29 5c 5c 73 2b xp "([0-9]+)\\s+
a190: 28 5b 30 2d 39 5d 2b 29 25 22 29 29 0a 09 20 28 ([0-9]+)%")).. (
a1a0: 66 72 65 65 73 70 63 20 20 20 20 23 66 29 29 0a freespc #f)).
a1b0: 20 20 20 20 3b 3b 20 28 77 72 69 74 65 20 64 66 ;; (write df
a1c0: 2d 72 65 73 75 6c 74 73 29 0a 20 20 20 20 28 66 -results). (f
a1d0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
a1e0: 28 6c 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 74 (l)...(let ((mat
a1f0: 63 68 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 ch (string-searc
a200: 68 20 73 70 61 63 65 2d 72 78 20 6c 29 29 29 0a h space-rx l))).
a210: 09 09 20 20 28 69 66 20 6d 61 74 63 68 20 0a 09 .. (if match ..
a220: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 . (let ((ne
a230: 77 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 wval (string->nu
a240: 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 mber (cadr match
a250: 29 29 29 29 0a 09 09 09 28 69 66 20 28 6e 75 6d ))))....(if (num
a260: 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 09 ber? newval)....
a270: 20 20 20 20 28 73 65 74 21 20 66 72 65 65 73 70 (set! freesp
a280: 63 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a 09 c newval))))))..
a290: 20 20 20 20 20 20 28 63 61 72 20 64 66 2d 72 65 (car df-re
a2a0: 73 75 6c 74 73 29 29 0a 20 20 20 20 66 72 65 65 sults)). free
a2b0: 73 70 63 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 spc))..(define (
a2c0: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 common:check-spa
a2d0: 63 65 2d 69 6e 2d 64 69 72 20 64 69 72 70 61 74 ce-in-dir dirpat
a2e0: 68 20 72 65 71 75 69 72 65 64 29 0a 20 20 28 6c h required). (l
a2f0: 65 74 2a 20 28 28 64 62 73 70 61 63 65 20 20 28 et* ((dbspace (
a300: 69 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 64 if (directory? d
a310: 69 72 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 irpath)...
a320: 20 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 (get-df dirpath
a330: 29 0a 09 09 20 20 20 20 20 20 20 30 29 29 29 0a )... 0))).
a340: 20 20 20 20 28 6c 69 73 74 20 28 3e 20 64 62 73 (list (> dbs
a350: 70 61 63 65 20 72 65 71 75 69 72 65 64 29 0a 09 pace required)..
a360: 20 20 64 62 73 70 61 63 65 0a 09 20 20 72 65 71 dbspace.. req
a370: 75 69 72 65 64 0a 09 20 20 64 69 72 70 61 74 68 uired.. dirpath
a380: 29 29 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 73 70 )))..;; check sp
a390: 61 63 65 20 69 6e 20 64 62 64 69 72 20 61 6e 64 ace in dbdir and
a3a0: 20 69 6e 20 6d 65 67 61 74 65 73 74 20 64 69 72 in megatest dir
a3b0: 0a 3b 3b 20 72 65 74 75 72 6e 73 3a 20 6f 6b 2f .;; returns: ok/
a3c0: 6e 6f 74 20 64 62 73 70 61 63 65 20 72 65 71 75 not dbspace requ
a3d0: 69 72 65 64 2d 73 70 61 63 65 0a 3b 3b 0a 28 64 ired-space.;;.(d
a3e0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 efine (common:ch
a3f0: 65 63 6b 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 eck-db-dir-space
a400: 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 71 75 ). (let* ((requ
a410: 69 72 65 64 20 28 73 74 72 69 6e 67 2d 3e 6e 75 ired (string->nu
a420: 6d 62 65 72 20 0a 09 09 20 20 20 20 28 6f 72 20 mber ... (or
a430: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
a440: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
a450: 75 70 22 20 22 64 62 64 69 72 2d 73 70 61 63 65 up" "dbdir-space
a460: 2d 72 65 71 75 69 72 65 64 22 29 0a 09 09 09 22 -required")...."
a470: 31 30 30 30 30 30 22 29 29 29 0a 09 20 28 64 62 100000"))).. (db
a480: 64 69 72 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 dir (common:g
a490: 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 et-db-tmp-area))
a4a0: 20 3b 3b 20 28 64 62 3a 67 65 74 2d 64 62 64 69 ;; (db:get-dbdi
a4b0: 72 29 29 0a 09 20 28 74 64 62 73 70 61 63 65 20 r)).. (tdbspace
a4c0: 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 (common:check-sp
a4d0: 61 63 65 2d 69 6e 2d 64 69 72 20 64 62 64 69 72 ace-in-dir dbdir
a4e0: 20 72 65 71 75 69 72 65 64 29 29 0a 09 20 28 6d required)).. (m
a4f0: 64 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a dbspace (common:
a500: 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 check-space-in-d
a510: 69 72 20 2a 74 6f 70 70 61 74 68 2a 20 72 65 71 ir *toppath* req
a520: 75 69 72 65 64 29 29 29 0a 20 20 20 20 28 73 6f uired))). (so
a530: 72 74 20 28 6c 69 73 74 20 74 64 62 73 70 61 63 rt (list tdbspac
a540: 65 20 6d 64 62 73 70 61 63 65 29 20 28 6c 61 6d e mdbspace) (lam
a550: 62 64 61 20 28 61 20 62 29 0a 09 09 09 09 20 20 bda (a b).....
a560: 20 20 20 28 3c 20 28 63 61 64 72 20 61 29 28 63 (< (cadr a)(c
a570: 61 64 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 adr b)))))).
a580: 0a 3b 3b 20 63 68 65 63 6b 20 61 76 61 69 6c 61 .;; check availa
a590: 62 6c 65 20 73 70 61 63 65 20 69 6e 20 64 62 64 ble space in dbd
a5a0: 69 72 2c 20 65 78 69 74 20 69 66 20 69 6e 73 75 ir, exit if insu
a5b0: 66 66 69 63 69 65 6e 74 0a 3b 3b 0a 28 64 65 66 fficient.;;.(def
a5c0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 ine (common:chec
a5d0: 6b 2d 64 62 2d 64 69 72 2d 61 6e 64 2d 65 78 69 k-db-dir-and-exi
a5e0: 74 2d 69 66 2d 69 6e 73 75 66 66 69 63 69 65 6e t-if-insufficien
a5f0: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 70 61 t). (let* ((spa
a600: 63 65 64 61 74 20 28 63 61 72 20 28 63 6f 6d 6d cedat (car (comm
a610: 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d on:check-db-dir-
a620: 73 70 61 63 65 29 29 29 20 3b 3b 20 6c 6f 6f 6b space))) ;; look
a630: 20 6f 6e 6c 79 20 61 74 20 77 6f 72 73 74 20 66 only at worst f
a640: 6f 72 20 6e 6f 77 0a 09 20 28 69 73 2d 6f 6b 20 or now.. (is-ok
a650: 20 20 20 28 63 61 72 20 73 70 61 63 65 64 61 74 (car spacedat
a660: 29 29 0a 09 20 28 64 62 73 70 61 63 65 20 20 28 )).. (dbspace (
a670: 63 61 64 72 20 73 70 61 63 65 64 61 74 29 29 0a cadr spacedat)).
a680: 09 20 28 72 65 71 75 69 72 65 64 20 28 63 61 64 . (required (cad
a690: 64 72 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 dr spacedat))..
a6a0: 28 64 62 64 69 72 20 20 20 20 28 63 61 64 64 64 (dbdir (caddd
a6b0: 72 20 73 70 61 63 65 64 61 74 29 29 29 0a 20 20 r spacedat))).
a6c0: 20 20 28 69 66 20 28 6e 6f 74 20 69 73 2d 6f 6b (if (not is-ok
a6d0: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 )..(begin.. (de
a6e0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
a6f0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
a700: 6f 72 74 2a 20 22 49 6e 73 75 66 66 69 63 69 65 ort* "Insufficie
a710: 6e 74 20 73 70 61 63 65 20 69 6e 20 22 20 64 62 nt space in " db
a720: 64 69 72 20 22 2c 20 72 65 71 75 69 72 65 20 22 dir ", require "
a730: 20 72 65 71 75 69 72 65 64 20 22 2c 20 68 61 76 required ", hav
a740: 65 20 22 20 64 62 73 70 61 63 65 20 20 22 2c 20 e " dbspace ",
a750: 65 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 exiting now.")..
a760: 20 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 20 (exit 1))))).
a770: 20 0a 3b 3b 20 70 61 74 68 73 20 69 73 20 6c 69 .;; paths is li
a780: 73 74 20 6f 66 20 6c 69 73 74 73 20 28 28 6e 61 st of lists ((na
a790: 6d 65 20 70 61 74 68 29 20 2e 2e 2e 20 29 0a 3b me path) ... ).;
a7a0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
a7b0: 6e 3a 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d n:get-disk-with-
a7c0: 6d 6f 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 most-free-space
a7d0: 64 69 73 6b 73 20 6d 69 6e 73 69 7a 65 29 0a 20 disks minsize).
a7e0: 20 28 6c 65 74 20 28 28 62 65 73 74 20 20 20 20 (let ((best
a7f0: 20 23 66 29 0a 09 28 62 65 73 74 73 69 7a 65 20 #f)..(bestsize
a800: 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 0)). (for-eac
a810: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
a820: 28 64 69 73 6b 2d 6e 75 6d 29 0a 20 20 20 20 20 (disk-num).
a830: 20 20 28 6c 65 74 2a 20 28 28 64 69 72 70 61 74 (let* ((dirpat
a840: 68 20 20 20 20 28 63 61 64 72 20 28 61 73 73 6f h (cadr (asso
a850: 63 20 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 c disk-num disks
a860: 29 29 29 0a 09 20 20 20 20 20 20 28 66 72 65 65 ))).. (free
a870: 73 70 63 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 spc (cond....
a880: 20 20 20 28 28 6e 6f 74 20 28 64 69 72 65 63 74 ((not (direct
a890: 6f 72 79 3f 20 64 69 72 70 61 74 68 29 29 0a 09 ory? dirpath))..
a8a0: 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f .. (if (commo
a8b0: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
a8c0: 74 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 t 300 "disks not
a8d0: 20 61 20 64 69 72 20 22 20 64 69 73 6b 2d 6e 75 a dir " disk-nu
a8e0: 6d 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 m).....(debug:pr
a8f0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
a900: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
a910: 47 3a 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e G: disk " disk-n
a920: 75 6d 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 um " at path \""
a930: 20 64 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 dirpath "\" is
a940: 6e 6f 74 20 61 20 64 69 72 65 63 74 6f 72 79 20 not a directory
a950: 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 - ignoring it.")
a960: 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 ).... -1)....
a970: 20 20 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 ((not (file-w
a980: 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 69 72 rite-access? dir
a990: 70 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 path)).... (i
a9a0: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
a9b0: 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 ise-print 300 "d
a9c0: 69 73 6b 73 20 6e 6f 74 20 77 72 69 74 65 61 62 isks not writeab
a9d0: 6c 65 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 le " disk-num)..
a9e0: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
a9f0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
aa00: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 ort* "WARNING: d
aa10: 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 isk " disk-num "
aa20: 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 69 72 at path \"" dir
aa30: 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 path "\" is not
aa40: 77 72 69 74 65 61 62 6c 65 20 2d 20 69 67 6e 6f writeable - igno
aa50: 72 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 ring it."))....
aa60: 20 20 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e -1).... ((n
aa70: 6f 74 20 28 65 71 3f 20 28 73 74 72 69 6e 67 2d ot (eq? (string-
aa80: 72 65 66 20 64 69 72 70 61 74 68 20 30 29 20 23 ref dirpath 0) #
aa90: 5c 2f 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 \/)).... (if
aaa0: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
aab0: 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 73 e-print 300 "dis
aac0: 6b 73 20 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 ks not a proper
aad0: 70 61 74 68 20 22 20 64 69 73 6b 2d 6e 75 6d 29 path " disk-num)
aae0: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
aaf0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
ab00: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
ab10: 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d disk " disk-num
ab20: 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 " at path \"" d
ab30: 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f irpath "\" is no
ab40: 74 20 61 20 66 75 6c 6c 79 20 71 75 61 6c 69 66 t a fully qualif
ab50: 69 65 64 20 70 61 74 68 20 2d 20 69 67 6e 6f 72 ied path - ignor
ab60: 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 ing it."))....
ab70: 20 20 2d 31 29 0a 09 09 09 20 20 20 28 65 6c 73 -1).... (els
ab80: 65 0a 09 09 09 20 20 20 20 28 67 65 74 2d 64 66 e.... (get-df
ab90: 20 64 69 72 70 61 74 68 29 29 29 29 29 0a 09 20 dirpath)))))..
aba0: 28 69 66 20 28 3e 20 66 72 65 65 73 70 63 20 62 (if (> freespc b
abb0: 65 73 74 73 69 7a 65 29 0a 09 20 20 20 20 20 28 estsize).. (
abc0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 73 begin.. (s
abd0: 65 74 21 20 62 65 73 74 20 20 20 20 20 28 63 6f et! best (co
abe0: 6e 73 20 64 69 73 6b 2d 6e 75 6d 20 64 69 72 70 ns disk-num dirp
abf0: 61 74 68 29 29 0a 09 20 20 20 20 20 20 20 28 73 ath)).. (s
ac00: 65 74 21 20 62 65 73 74 73 69 7a 65 20 66 72 65 et! bestsize fre
ac10: 65 73 70 63 29 29 29 29 29 0a 20 20 20 20 20 28 espc))))). (
ac20: 6d 61 70 20 63 61 72 20 64 69 73 6b 73 29 29 0a map car disks)).
ac30: 20 20 20 20 28 69 66 20 28 61 6e 64 20 62 65 73 (if (and bes
ac40: 74 20 28 3e 20 62 65 73 74 73 69 7a 65 20 6d 69 t (> bestsize mi
ac50: 6e 73 69 7a 65 29 29 0a 09 62 65 73 74 0a 09 23 nsize))..best..#
ac60: 66 29 29 29 20 3b 3b 20 23 66 20 6d 65 61 6e 73 f))) ;; #f means
ac70: 20 6e 6f 20 64 69 73 6b 20 63 61 6e 64 69 64 61 no disk candida
ac80: 74 65 20 66 6f 75 6e 64 0a 0a 3b 3b 3d 3d 3d 3d te found..;;====
ac90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
acd0: 3d 3d 0a 3b 3b 20 45 20 4e 20 56 20 49 20 52 20 ==.;; E N V I R
ace0: 4f 20 4e 20 4d 20 45 20 4e 20 54 20 20 20 56 20 O N M E N T V
acf0: 41 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d A R S.;;========
ad00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 09 ==============..
ad40: 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 .(define (
ad50: 73 61 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 save-environment
ad60: 2d 61 73 2d 66 69 6c 65 73 20 66 6e 61 6d 65 20 -as-files fname
ad70: 23 21 6b 65 79 20 28 69 67 6e 6f 72 65 76 61 72 #!key (ignorevar
ad80: 73 20 28 6c 69 73 74 20 22 55 53 45 52 22 20 22 s (list "USER" "
ad90: 48 4f 4d 45 22 20 22 44 49 53 50 4c 41 59 22 20 HOME" "DISPLAY"
ada0: 22 4c 53 5f 43 4f 4c 4f 52 53 22 20 22 58 4b 45 "LS_COLORS" "XKE
adb0: 59 53 59 4d 44 42 22 20 22 45 44 49 54 4f 52 22 YSYMDB" "EDITOR"
adc0: 20 22 4d 41 4b 45 46 4c 41 47 53 22 20 22 4d 41 "MAKEFLAGS" "MA
add0: 4b 45 46 22 20 22 4d 41 4b 45 4f 56 45 52 52 49 KEF" "MAKEOVERRI
ade0: 44 45 53 22 29 29 29 0a 20 20 28 6c 65 74 20 28 DES"))). (let (
adf0: 28 65 6e 76 76 61 72 73 20 28 67 65 74 2d 65 6e (envvars (get-en
ae00: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
ae10: 6c 65 73 29 29 0a 20 20 20 20 20 20 20 20 28 77 les)). (w
ae20: 68 69 74 65 73 70 20 28 72 65 67 65 78 70 20 22 hitesp (regexp "
ae30: 5b 5e 61 2d 7a 41 2d 5a 30 2d 39 5f 5c 5c 2d 3a [^a-zA-Z0-9_\\-:
ae40: 2c 2e 5c 5c 2f 25 24 5d 22 29 29 0a 09 28 6d 75 ,.\\/%$]"))..(mu
ae50: 6e 67 65 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 ngeval (lambda (
ae60: 76 61 6c 29 0a 09 09 20 20 20 20 28 63 6f 6e 64 val)... (cond
ae70: 0a 09 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 ... ((eq? va
ae80: 6c 20 23 74 29 20 22 22 29 20 3b 3b 20 63 6f 6e l #t) "") ;; con
ae90: 76 65 72 74 20 23 74 20 74 6f 20 65 6d 70 74 79 vert #t to empty
aea0: 20 73 74 72 69 6e 67 0a 09 09 20 20 20 20 20 28 string... (
aeb0: 28 65 71 3f 20 76 61 6c 20 23 66 29 20 23 66 29 (eq? val #f) #f)
aec0: 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 66 20 74 ;; convert #f t
aed0: 6f 20 69 74 73 65 6c 66 20 28 73 74 69 6c 6c 20 o itself (still
aee0: 74 68 69 6e 6b 69 6e 67 20 61 62 6f 75 74 20 74 thinking about t
aef0: 68 69 73 20 6f 6e 65 0a 09 09 20 20 20 20 20 28 his one... (
af00: 65 6c 73 65 20 76 61 6c 29 29 29 29 29 0a 20 20 else val))))).
af10: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
af20: 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e to-file (conc fn
af30: 61 6d 65 20 22 2e 63 73 68 22 29 0a 20 20 20 20 ame ".csh").
af40: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
af50: 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 (for-eac
af60: 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 h (lambda (keyva
af70: 6c 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a l)... (let*
af80: 20 28 28 6b 65 79 20 20 20 28 63 61 72 20 6b 65 ((key (car ke
af90: 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 yval)).... (
afa0: 76 61 6c 20 20 20 28 63 64 72 20 6b 65 79 76 61 val (cdr keyva
afb0: 6c 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 6c l)).... (del
afc0: 69 6d 20 28 69 66 20 28 73 74 72 69 6e 67 2d 73 im (if (string-s
afd0: 65 61 72 63 68 20 77 68 69 74 65 73 70 20 76 61 earch whitesp va
afe0: 6c 29 20 0a 09 09 09 09 09 22 5c 22 22 0a 09 09 l) ......"\""...
aff0: 09 09 09 22 22 29 29 29 0a 09 09 09 28 70 72 69 ..."")))....(pri
b000: 6e 74 20 28 69 66 20 28 6d 65 6d 62 65 72 20 6b nt (if (member k
b010: 65 79 20 69 67 6e 6f 72 65 76 61 72 73 29 0a 09 ey ignorevars)..
b020: 09 09 09 20 20 20 22 23 20 73 65 74 65 6e 76 20 ... "# setenv
b030: 22 0a 09 09 09 09 20 20 20 22 73 65 74 65 6e 76 "..... "setenv
b040: 20 22 29 0a 09 09 09 20 20 20 20 20 20 20 6b 65 ").... ke
b050: 79 20 22 20 22 20 64 65 6c 69 6d 20 28 6d 75 6e y " " delim (mun
b060: 67 65 76 61 6c 20 76 61 6c 29 20 64 65 6c 69 6d geval val) delim
b070: 29 29 29 0a 09 09 20 20 20 20 65 6e 76 76 61 72 )))... envvar
b080: 73 29 29 29 0a 20 20 20 20 20 28 77 69 74 68 2d s))). (with-
b090: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 output-to-file (
b0a0: 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 73 68 22 conc fname ".sh"
b0b0: 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ). (lambda
b0c0: 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 28 66 (). (f
b0d0: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
b0e0: 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 20 20 20 (keyval)...
b0f0: 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 28 63 61 (let* ((key (ca
b100: 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 r keyval))....
b110: 20 20 20 28 76 61 6c 20 28 63 64 72 20 6b 65 79 (val (cdr key
b120: 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 64 val)).... (d
b130: 65 6c 69 6d 20 28 69 66 20 28 73 74 72 69 6e 67 elim (if (string
b140: 2d 73 65 61 72 63 68 20 77 68 69 74 65 73 70 20 -search whitesp
b150: 76 61 6c 29 20 0a 09 09 09 09 09 22 5c 22 22 0a val) ......"\"".
b160: 09 09 09 09 09 22 22 29 29 29 0a 09 09 09 28 70 ....."")))....(p
b170: 72 69 6e 74 20 28 69 66 20 28 6d 65 6d 62 65 72 rint (if (member
b180: 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 72 73 29 key ignorevars)
b190: 0a 09 09 09 09 20 20 20 22 23 20 65 78 70 6f 72 ..... "# expor
b1a0: 74 20 22 0a 09 09 09 09 20 20 20 22 65 78 70 6f t "..... "expo
b1b0: 72 74 20 22 29 0a 09 09 09 20 20 20 20 20 20 20 rt ")....
b1c0: 6b 65 79 20 22 3d 22 20 64 65 6c 69 6d 20 28 6d key "=" delim (m
b1d0: 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 64 65 6c ungeval val) del
b1e0: 69 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 im))).
b1f0: 20 20 20 20 20 20 20 20 20 20 65 6e 76 76 61 72 envvar
b200: 73 29 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 73 s)))))..;; set s
b210: 6f 6d 65 20 65 6e 76 20 76 61 72 73 20 66 72 6f ome env vars fro
b220: 6d 20 61 6e 20 61 6c 69 73 74 2c 20 72 65 74 75 m an alist, retu
b230: 72 6e 20 61 6e 20 61 6c 69 73 74 20 77 69 74 68 rn an alist with
b240: 20 6f 72 69 67 69 6e 61 6c 20 76 61 6c 75 65 73 original values
b250: 0a 3b 3b 20 28 28 22 56 41 52 22 20 22 76 61 6c .;; (("VAR" "val
b260: 75 65 22 29 20 2e 2e 2e 29 0a 28 64 65 66 69 6e ue") ...).(defin
b270: 65 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 e (alist->env-va
b280: 72 73 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6c rs lst). (if (l
b290: 69 73 74 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 ist? lst).
b2a0: 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 29 (let ((res '()))
b2b0: 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d ..(for-each (lam
b2c0: 62 64 61 20 28 70 29 0a 09 09 20 20 20 20 28 6c bda (p)... (l
b2d0: 65 74 2a 20 28 28 76 61 72 20 28 63 61 72 20 20 et* ((var (car
b2e0: 70 29 29 0a 09 09 09 20 20 20 28 76 61 6c 20 28 p)).... (val (
b2f0: 63 61 64 72 20 70 29 29 0a 09 09 09 20 20 20 28 cadr p)).... (
b300: 70 72 76 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e prv (get-environ
b310: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 76 61 ment-variable va
b320: 72 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 65 r)))... (se
b330: 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c 69 t! res (cons (li
b340: 73 74 20 76 61 72 20 70 72 76 29 20 72 65 73 29 st var prv) res)
b350: 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 76 61 )... (if va
b360: 6c 20 0a 09 09 09 20 20 28 73 65 74 65 6e 76 20 l .... (setenv
b370: 76 61 72 20 28 2d 3e 73 74 72 69 6e 67 20 76 61 var (->string va
b380: 6c 29 29 0a 09 09 09 20 20 28 75 6e 73 65 74 65 l)).... (unsete
b390: 6e 76 20 76 61 72 29 29 29 29 0a 09 09 20 20 6c nv var))))... l
b3a0: 73 74 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 st)..res).
b3b0: 27 28 29 29 29 0a 0a 3b 3b 20 63 6c 65 61 72 20 '()))..;; clear
b3c0: 76 61 72 73 20 6d 61 74 63 68 69 6e 67 20 70 61 vars matching pa
b3d0: 74 74 65 72 6e 2c 20 72 75 6e 20 70 72 6f 63 2c ttern, run proc,
b3e0: 20 73 65 74 20 76 61 72 73 20 62 61 63 6b 0a 3b set vars back.;
b3f0: 3b 20 69 66 20 70 72 6f 63 20 69 73 20 61 20 73 ; if proc is a s
b400: 74 72 69 6e 67 20 72 75 6e 20 74 68 61 74 20 73 tring run that s
b410: 74 72 69 6e 67 20 61 73 20 61 20 63 6f 6d 6d 61 tring as a comma
b420: 6e 64 20 77 69 74 68 0a 3b 3b 20 73 79 73 74 65 nd with.;; syste
b430: 6d 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 m..;;.(define (c
b440: 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 ommon:without-va
b450: 72 73 20 70 72 6f 63 20 2e 20 76 61 72 2d 70 61 rs proc . var-pa
b460: 74 74 73 29 0a 20 20 28 6c 65 74 20 28 28 76 61 tts). (let ((va
b470: 72 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 rs (make-hash-ta
b480: 62 6c 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d ble))). (for-
b490: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
b4a0: 61 20 28 76 61 72 64 61 74 29 20 3b 3b 20 65 61 a (vardat) ;; ea
b4b0: 63 68 20 65 6e 76 20 76 61 72 0a 20 20 20 20 20 ch env var.
b4c0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 (for-each..(la
b4d0: 6d 62 64 61 20 28 76 61 72 2d 70 61 74 74 29 0a mbda (var-patt).
b4e0: 09 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d . (if (string-m
b4f0: 61 74 63 68 20 76 61 72 2d 70 61 74 74 20 28 63 atch var-patt (c
b500: 61 72 20 76 61 72 64 61 74 29 29 0a 09 20 20 20 ar vardat))..
b510: 20 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 (let ((var (c
b520: 61 72 20 76 61 72 64 61 74 29 29 0a 09 09 20 20 ar vardat))...
b530: 20 20 28 76 61 6c 20 28 63 64 72 20 76 61 72 64 (val (cdr vard
b540: 61 74 29 29 29 0a 09 09 28 68 61 73 68 2d 74 61 at)))...(hash-ta
b550: 62 6c 65 2d 73 65 74 21 20 76 61 72 73 20 76 61 ble-set! vars va
b560: 72 20 76 61 6c 29 0a 09 09 28 75 6e 73 65 74 65 r val)...(unsete
b570: 6e 76 20 76 61 72 29 29 29 29 0a 09 76 61 72 2d nv var))))..var-
b580: 70 61 74 74 73 29 29 0a 20 20 20 20 20 28 67 65 patts)). (ge
b590: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
b5a0: 72 69 61 62 6c 65 73 29 29 0a 20 20 20 20 28 63 riables)). (c
b5b0: 6f 6e 64 0a 20 20 20 20 20 28 28 73 74 72 69 6e ond. ((strin
b5c0: 67 3f 20 70 72 6f 63 29 28 73 79 73 74 65 6d 20 g? proc)(system
b5d0: 70 72 6f 63 29 29 0a 20 20 20 20 20 28 70 72 6f proc)). (pro
b5e0: 63 20 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 c (proc
b5f0: 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 ))). (hash-ta
b600: 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 ble-for-each.
b610: 20 20 76 61 72 73 0a 20 20 20 20 20 28 6c 61 6d vars. (lam
b620: 62 64 61 20 28 76 61 72 20 76 61 6c 29 0a 20 20 bda (var val).
b630: 20 20 20 20 20 28 73 65 74 65 6e 76 20 76 61 72 (setenv var
b640: 20 76 61 6c 29 29 29 0a 20 20 20 20 76 61 72 73 val))). vars
b650: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
b660: 6d 6f 6e 3a 72 75 6e 2d 61 2d 63 6f 6d 6d 61 6e mon:run-a-comman
b670: 64 20 63 6d 64 20 23 21 6b 65 79 20 28 77 69 74 d cmd #!key (wit
b680: 68 2d 76 61 72 73 20 23 66 29 29 0a 20 20 28 6c h-vars #f)). (l
b690: 65 74 2a 20 28 28 70 72 65 2d 63 6d 64 20 20 28 et* ((pre-cmd (
b6a0: 64 74 65 73 74 73 3a 67 65 74 2d 70 72 65 2d 63 dtests:get-pre-c
b6b0: 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 20 20 20 20 ommand)).
b6c0: 20 20 28 70 6f 73 74 2d 63 6d 64 20 28 64 74 65 (post-cmd (dte
b6d0: 73 74 73 3a 67 65 74 2d 70 6f 73 74 2d 63 6f 6d sts:get-post-com
b6e0: 6d 61 6e 64 29 29 0a 20 20 20 20 20 20 20 20 20 mand)).
b6f0: 28 66 75 6c 6c 63 6d 64 20 20 28 69 66 20 28 6f (fullcmd (if (o
b700: 72 20 70 72 65 2d 63 6d 64 20 70 6f 73 74 2d 63 r pre-cmd post-c
b710: 6d 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 md).
b720: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 (conc
b730: 20 70 72 65 2d 63 6d 64 20 63 6d 64 20 70 6f 73 pre-cmd cmd pos
b740: 74 2d 63 6d 64 29 0a 20 20 20 20 20 20 20 20 20 t-cmd).
b750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
b760: 6f 6e 63 20 22 76 69 65 77 73 63 72 65 65 6e 20 onc "viewscreen
b770: 22 20 63 6d 64 29 29 29 29 0a 20 20 20 20 28 64 " cmd)))). (d
b780: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
b790: 30 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 02 *default-log-
b7a0: 70 6f 72 74 2a 20 22 52 75 6e 6e 69 6e 67 20 63 port* "Running c
b7b0: 6f 6d 6d 61 6e 64 3a 20 22 20 66 75 6c 6c 63 6d ommand: " fullcm
b7c0: 64 29 0a 20 20 20 20 28 69 66 20 77 69 74 68 2d d). (if with-
b7d0: 76 61 72 73 0a 20 20 20 20 20 20 20 20 28 63 6f vars. (co
b7e0: 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 mmon:without-var
b7f0: 73 20 63 6d 64 29 0a 20 20 20 20 20 20 20 20 28 s cmd). (
b800: 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 common:without-v
b810: 61 72 73 20 66 75 6c 6c 63 6d 64 20 22 4d 54 5f ars fullcmd "MT_
b820: 2e 2a 22 29 29 29 29 0a 09 09 20 20 0a 3b 3b 3d .*"))))... .;;=
b830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b870: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 49 20 4d 20 45 =====.;; T I M E
b880: 20 20 20 41 20 4e 20 44 20 20 20 44 20 41 20 54 A N D D A T
b890: 20 45 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E.;;===========
b8a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b8b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b8c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b8d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
b8e0: 43 6f 6e 76 65 72 74 20 73 74 72 69 6e 67 73 20 Convert strings
b8f0: 6c 69 6b 65 20 22 35 73 20 32 68 20 33 6d 22 20 like "5s 2h 3m"
b900: 3d 3e 20 36 30 78 36 30 78 32 20 2b 20 33 78 36 => 60x60x2 + 3x6
b910: 30 20 2b 20 35 0a 28 64 65 66 69 6e 65 20 28 63 0 + 5.(define (c
b920: 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 ommon:hms-string
b930: 2d 3e 73 65 63 6f 6e 64 73 20 74 73 74 72 29 0a ->seconds tstr).
b940: 20 20 28 6c 65 74 20 28 28 70 61 72 74 73 20 20 (let ((parts
b950: 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 (string-split
b960: 20 74 73 74 72 29 29 0a 09 28 74 69 6d 65 2d 73 tstr))..(time-s
b970: 65 63 73 20 30 29 0a 09 3b 3b 20 73 3d 73 65 63 ecs 0)..;; s=sec
b980: 6f 6e 64 73 2c 20 6d 3d 6d 69 6e 75 74 65 73 2c onds, m=minutes,
b990: 20 68 3d 68 6f 75 72 73 2c 20 64 3d 64 61 79 73 h=hours, d=days
b9a0: 0a 09 28 74 72 78 20 20 20 20 20 20 20 28 72 65 ..(trx (re
b9b0: 67 65 78 70 20 22 28 5c 5c 64 2b 29 28 5b 73 6d gexp "(\\d+)([sm
b9c0: 68 64 5d 29 22 29 29 29 0a 20 20 20 20 28 66 6f hd])"))). (fo
b9d0: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
b9e0: 70 61 72 74 29 0a 09 09 28 6c 65 74 20 28 28 6d part)...(let ((m
b9f0: 61 74 63 68 20 20 28 73 74 72 69 6e 67 2d 6d 61 atch (string-ma
ba00: 74 63 68 20 74 72 78 20 70 61 72 74 29 29 29 0a tch trx part))).
ba10: 09 09 20 20 28 69 66 20 6d 61 74 63 68 0a 09 09 .. (if match...
ba20: 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c (let ((val
ba30: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
ba40: 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 0a (cadr match))).
ba50: 09 09 09 20 20 20 20 28 75 6e 74 20 28 63 61 64 ... (unt (cad
ba60: 64 72 20 6d 61 74 63 68 29 29 29 0a 09 09 09 28 dr match)))....(
ba70: 69 66 20 76 61 6c 20 0a 09 09 09 20 20 20 20 28 if val .... (
ba80: 73 65 74 21 20 74 69 6d 65 2d 73 65 63 73 20 28 set! time-secs (
ba90: 2b 20 74 69 6d 65 2d 73 65 63 73 20 28 2a 20 76 + time-secs (* v
baa0: 61 6c 0a 09 09 09 09 09 09 09 20 20 20 20 28 63 al........ (c
bab0: 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ase (string->sym
bac0: 62 6f 6c 20 75 6e 74 29 0a 09 09 09 09 09 09 09 bol unt)........
bad0: 20 20 20 20 20 20 28 28 73 29 20 31 29 0a 09 09 ((s) 1)...
bae0: 09 09 09 09 09 20 20 20 20 20 20 28 28 6d 29 20 ..... ((m)
baf0: 36 30 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 60)........
bb00: 20 28 28 68 29 20 28 2a 20 36 30 20 36 30 29 29 ((h) (* 60 60))
bb10: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 ........ ((
bb20: 64 29 20 28 2a 20 32 34 20 36 30 20 36 30 29 29 d) (* 24 60 60))
bb30: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 65 ........ (e
bb40: 6c 73 65 20 30 29 29 29 29 29 29 29 29 29 29 0a lse 0)))))))))).
bb50: 09 20 20 20 20 20 20 70 61 72 74 73 29 0a 20 20 . parts).
bb60: 20 20 74 69 6d 65 2d 73 65 63 73 29 29 0a 09 09 time-secs))...
bb70: 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 .(define
bb80: 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e (seconds->hr-min
bb90: 2d 73 65 63 20 73 65 63 73 29 0a 20 20 28 6c 65 -sec secs). (le
bba0: 74 2a 20 28 28 68 72 73 20 28 71 75 6f 74 69 65 t* ((hrs (quotie
bbb0: 6e 74 20 73 65 63 73 20 33 36 30 30 29 29 0a 09 nt secs 3600))..
bbc0: 20 28 6d 69 6e 20 28 71 75 6f 74 69 65 6e 74 20 (min (quotient
bbd0: 28 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 33 (- secs (* hrs 3
bbe0: 36 30 30 29 29 20 36 30 29 29 0a 09 20 28 73 65 600)) 60)).. (se
bbf0: 63 20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 73 c (- secs (* hrs
bc00: 20 33 36 30 30 29 28 2a 20 6d 69 6e 20 36 30 29 3600)(* min 60)
bc10: 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 69 ))). (conc (i
bc20: 66 20 28 3e 20 68 72 73 20 30 29 28 63 6f 6e 63 f (> hrs 0)(conc
bc30: 20 68 72 73 20 22 68 72 20 22 29 20 22 22 29 0a hrs "hr ") "").
bc40: 09 20 20 28 69 66 20 28 3e 20 6d 69 6e 20 30 29 . (if (> min 0)
bc50: 28 63 6f 6e 63 20 6d 69 6e 20 22 6d 20 22 29 20 (conc min "m ")
bc60: 20 22 22 29 0a 09 20 20 73 65 63 20 22 73 22 29 "").. sec "s")
bc70: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ))..(define (sec
bc80: 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e onds->time-strin
bc90: 67 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e g sec). (time->
bca0: 73 74 72 69 6e 67 20 0a 20 20 20 28 73 65 63 6f string . (seco
bcb0: 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 nds->local-time
bcc0: 73 65 63 29 20 22 25 48 3a 25 4d 3a 25 53 22 29 sec) "%H:%M:%S")
bcd0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
bce0: 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 nds->work-week/d
bcf0: 61 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 28 ay-time sec). (
bd00: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 time->string.
bd10: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
bd20: 74 69 6d 65 20 73 65 63 29 20 22 77 77 25 56 2e time sec) "ww%V.
bd30: 25 75 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 %u %H:%M"))..(de
bd40: 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 fine (seconds->w
bd50: 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 20 73 65 63 ork-week/day sec
bd60: 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e ). (time->strin
bd70: 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c g. (seconds->l
bd80: 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 ocal-time sec) "
bd90: 77 77 25 56 2e 25 75 22 29 29 0a 0a 28 64 65 66 ww%V.%u"))..(def
bda0: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 ine (seconds->ye
bdb0: 61 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 ar-work-week/day
bdc0: 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
bdd0: 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 tring. (second
bde0: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
bdf0: 63 29 20 22 25 79 77 77 25 56 2e 25 77 22 29 29 c) "%yww%V.%w"))
be00: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e ..(define (secon
be10: 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 ds->year-work-we
be20: 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 ek/day-time sec)
be30: 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 . (time->string
be40: 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
be50: 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 cal-time sec) "%
be60: 59 77 77 25 56 2e 25 77 20 25 48 3a 25 4d 22 29 Yww%V.%w %H:%M")
be70: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
be80: 6e 64 73 2d 3e 79 65 61 72 2d 77 65 65 6b 2f 64 nds->year-week/d
be90: 61 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 28 ay-time sec). (
bea0: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 time->string.
beb0: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
bec0: 74 69 6d 65 20 73 65 63 29 20 22 25 59 77 25 56 time sec) "%Yw%V
bed0: 2e 25 77 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 .%w %H:%M"))..(d
bee0: 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e efine (seconds->
bef0: 71 75 61 72 74 65 72 20 73 65 63 29 0a 20 20 28 quarter sec). (
bf00: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 6e 75 case (string->nu
bf10: 6d 62 65 72 0a 09 20 28 74 69 6d 65 2d 3e 73 74 mber.. (time->st
bf20: 72 69 6e 67 20 0a 09 20 20 28 73 65 63 6f 6e 64 ring .. (second
bf30: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
bf40: 63 29 0a 09 20 20 22 25 6d 22 29 29 0a 20 20 20 c).. "%m")).
bf50: 20 28 28 31 20 32 20 33 29 20 31 29 0a 20 20 20 ((1 2 3) 1).
bf60: 20 28 28 34 20 35 20 36 29 20 32 29 0a 20 20 20 ((4 5 6) 2).
bf70: 20 28 28 37 20 38 20 39 29 20 33 29 0a 20 20 20 ((7 8 9) 3).
bf80: 20 28 28 31 30 20 31 31 20 31 32 29 20 34 29 0a ((10 11 12) 4).
bf90: 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 0a (else #f))).
bfa0: 0a 3b 3b 20 67 69 76 65 6e 20 73 70 61 6e 20 6f .;; given span o
bfb0: 66 20 73 65 63 6f 6e 64 73 20 74 73 74 61 72 74 f seconds tstart
bfc0: 20 74 6f 20 74 65 6e 64 0a 3b 3b 20 66 69 6e 64 to tend.;; find
bfd0: 20 73 74 61 72 74 20 74 69 6d 65 20 74 6f 20 6d start time to m
bfe0: 61 72 6b 20 61 6e 64 20 6d 61 72 6b 20 64 65 6c ark and mark del
bff0: 74 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ta.;;.(define (c
c000: 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 73 74 61 72 74 ommon:find-start
c010: 2d 6d 61 72 6b 2d 61 6e 64 2d 6d 61 72 6b 2d 64 -mark-and-mark-d
c020: 65 6c 74 61 20 74 73 74 61 72 74 20 74 65 6e 64 elta tstart tend
c030: 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 65 6c 74 ). (let* ((delt
c040: 61 74 20 20 20 28 2d 20 28 6d 61 78 20 74 65 6e at (- (max ten
c050: 64 20 28 2b 20 74 65 6e 64 20 31 30 29 29 20 74 d (+ tend 10)) t
c060: 73 74 61 72 74 29 29 20 3b 3b 20 63 61 6e 27 74 start)) ;; can't
c070: 20 68 61 6e 64 6c 65 20 72 75 6e 73 20 6f 66 20 handle runs of
c080: 6c 65 73 73 20 74 68 61 6e 20 34 20 73 65 63 6f less than 4 seco
c090: 6e 64 73 2e 20 50 61 64 20 69 74 20 74 6f 20 31 nds. Pad it to 1
c0a0: 30 20 73 65 63 6f 6e 64 73 20 2e 2e 2e 0a 09 20 0 seconds .....
c0b0: 28 72 65 73 75 6c 74 20 20 20 23 66 29 0a 09 20 (result #f)..
c0c0: 28 6d 69 6e 20 20 20 20 20 20 36 30 29 0a 09 20 (min 60)..
c0d0: 28 68 72 20 20 20 20 20 20 20 28 2a 20 36 30 20 (hr (* 60
c0e0: 36 30 29 29 0a 09 20 28 64 61 79 20 20 20 20 20 60)).. (day
c0f0: 20 28 2a 20 32 34 20 68 72 29 29 0a 09 20 28 79 (* 24 hr)).. (y
c100: 72 20 20 20 20 20 20 20 28 2a 20 33 36 35 20 64 r (* 365 d
c110: 61 79 29 29 20 3b 3b 20 79 65 61 72 0a 09 20 28 ay)) ;; year.. (
c120: 6d 6f 20 20 20 20 20 20 20 28 2f 20 79 72 20 31 mo (/ yr 1
c130: 32 29 29 0a 09 20 28 77 6b 20 20 20 20 20 20 20 2)).. (wk
c140: 28 2a 20 64 61 79 20 37 29 29 29 0a 20 20 20 20 (* day 7))).
c150: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
c160: 6c 61 6d 62 64 61 20 28 6d 61 78 2d 62 6c 6b 73 lambda (max-blks
c170: 29 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 ). (for-ea
c180: 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 73 70 61 ch..(lambda (spa
c190: 6e 29 20 3b 3b 20 35 20 32 20 31 0a 09 20 20 28 n) ;; 5 2 1.. (
c1a0: 69 66 20 28 6e 6f 74 20 72 65 73 75 6c 74 29 0a if (not result).
c1b0: 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 . (for-each
c1c0: 20 0a 09 20 20 20 20 20 20 20 28 6c 61 6d 62 64 .. (lambd
c1d0: 61 20 28 74 69 6d 65 75 6e 69 74 20 74 69 6d 65 a (timeunit time
c1e0: 73 79 6d 29 20 3b 3b 20 79 65 61 72 20 6d 6f 6e sym) ;; year mon
c1f0: 74 68 20 64 61 79 20 68 72 20 6d 69 6e 20 73 65 th day hr min se
c200: 63 0a 09 09 20 28 69 66 20 28 6e 6f 74 20 72 65 c... (if (not re
c210: 73 75 6c 74 29 0a 09 09 20 20 20 20 20 28 6c 65 sult)... (le
c220: 74 2a 20 28 28 74 69 6d 65 2d 62 6c 6b 20 28 2a t* ((time-blk (*
c230: 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 29 29 span timeunit))
c240: 0a 09 09 09 20 20 20 20 28 6e 75 6d 2d 62 6c 6b .... (num-blk
c250: 73 20 28 71 75 6f 74 69 65 6e 74 20 64 65 6c 74 s (quotient delt
c260: 61 74 20 74 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 at time-blk)))..
c270: 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 . (if (and
c280: 20 28 3e 20 6e 75 6d 2d 62 6c 6b 73 20 34 29 28 (> num-blks 4)(
c290: 3c 20 6e 75 6d 2d 62 6c 6b 73 20 6d 61 78 2d 62 < num-blks max-b
c2a0: 6c 6b 73 29 29 0a 09 09 09 20 20 20 28 6c 65 74 lks)).... (let
c2b0: 20 28 28 66 69 72 73 74 20 28 2a 20 28 71 75 6f ((first (* (quo
c2c0: 74 69 65 6e 74 20 74 73 74 61 72 74 20 74 69 6d tient tstart tim
c2d0: 65 2d 62 6c 6b 29 20 74 69 6d 65 2d 62 6c 6b 29 e-blk) time-blk)
c2e0: 29 29 0a 09 09 09 20 20 20 20 20 28 73 65 74 21 )).... (set!
c2f0: 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 73 70 result (list sp
c300: 61 6e 20 74 69 6d 65 75 6e 69 74 20 74 69 6d 65 an timeunit time
c310: 2d 62 6c 6b 20 66 69 72 73 74 20 74 69 6d 65 73 -blk first times
c320: 79 6d 29 29 0a 09 09 09 20 20 20 20 20 29 29 29 ym)).... )))
c330: 29 29 0a 09 20 20 20 20 20 20 20 28 6c 69 73 74 )).. (list
c340: 20 79 72 20 6d 6f 20 77 6b 20 64 61 79 20 68 72 yr mo wk day hr
c350: 20 6d 69 6e 20 31 29 0a 09 20 20 20 20 20 20 20 min 1)..
c360: 27 28 20 20 20 20 20 79 20 20 6d 6f 20 77 20 20 '( y mo w
c370: 64 20 20 20 68 20 20 6d 20 20 20 73 29 29 29 29 d h m s))))
c380: 0a 09 28 6c 69 73 74 20 38 20 36 20 35 20 32 20 ..(list 8 6 5 2
c390: 31 29 29 29 0a 20 20 20 20 20 27 28 35 20 31 30 1))). '(5 10
c3a0: 20 31 35 20 32 30 20 33 30 20 34 30 20 35 30 20 15 20 30 40 50
c3b0: 35 30 30 29 29 0a 20 20 20 20 28 69 66 20 76 61 500)). (if va
c3c0: 6c 75 65 73 0a 09 28 61 70 70 6c 79 20 76 61 6c lues..(apply val
c3d0: 75 65 73 20 72 65 73 75 6c 74 29 0a 09 28 76 61 ues result)..(va
c3e0: 6c 75 65 73 20 30 20 64 61 79 20 31 20 30 20 27 lues 0 day 1 0 '
c3f0: 64 29 29 29 29 0a 09 20 20 20 20 0a 09 20 20 0a d)))).. .. .
c400: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
c410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4f =========.;; C O
c450: 20 4c 20 4f 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d L O R S.;;=====
c460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c4a0: 3d 0a 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 =. .(define
c4b0: 20 28 63 6f 6d 6d 6f 6e 3a 6e 61 6d 65 2d 3e 69 (common:name->i
c4c0: 75 70 2d 63 6f 6c 6f 72 20 6e 61 6d 65 29 0a 20 up-color name).
c4d0: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
c4e0: 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 symbol (string-d
c4f0: 6f 77 6e 63 61 73 65 20 6e 61 6d 65 29 29 0a 20 owncase name)).
c500: 20 20 20 28 28 72 65 64 29 20 20 20 20 22 32 32 ((red) "22
c510: 33 20 33 33 20 34 39 22 29 0a 20 20 20 20 28 28 3 33 49"). ((
c520: 67 72 65 79 29 20 20 20 22 31 39 32 20 31 39 32 grey) "192 192
c530: 20 31 39 32 22 29 0a 20 20 20 20 28 28 6f 72 61 192"). ((ora
c540: 6e 67 65 29 20 22 32 35 35 20 31 37 32 20 31 33 nge) "255 172 13
c550: 22 29 0a 20 20 20 20 28 28 70 75 72 70 6c 65 29 "). ((purple)
c560: 20 22 54 68 69 73 20 69 73 20 75 6e 66 69 6e 69 "This is unfini
c570: 73 68 65 64 20 2e 2e 2e 22 29 29 29 0a 0a 3b 3b shed ...")))..;;
c580: 20 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e (define (common
c590: 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 6f 72 2d 73 :get-color-for-s
c5a0: 74 61 74 65 2d 73 74 61 74 75 73 20 73 74 61 74 tate-status stat
c5b0: 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 28 e status).;; (
c5c0: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
c5d0: 6d 62 6f 6c 20 73 74 61 74 65 29 0a 3b 3b 20 20 mbol state).;;
c5e0: 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 29 0a ((COMPLETED).
c5f0: 3b 3b 20 20 20 20 20 20 28 63 61 73 65 20 28 73 ;; (case (s
c600: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 tring->symbol st
c610: 61 74 75 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 atus).;;
c620: 28 28 50 41 53 53 29 20 20 20 20 20 20 20 20 22 ((PASS) "
c630: 37 30 20 20 32 34 39 20 37 33 22 29 0a 3b 3b 20 70 249 73").;;
c640: 20 20 20 20 20 20 20 28 28 57 41 52 4e 20 57 41 ((WARN WA
c650: 49 56 45 44 29 20 22 32 35 35 20 31 37 32 20 31 IVED) "255 172 1
c660: 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 3").;; ((
c670: 53 4b 49 50 29 20 20 20 20 20 20 20 20 22 32 33 SKIP) "23
c680: 30 20 32 33 30 20 30 22 29 0a 3b 3b 20 20 20 20 0 230 0").;;
c690: 20 20 20 20 28 65 6c 73 65 20 22 32 32 33 20 33 (else "223 3
c6a0: 33 20 34 39 22 29 29 29 0a 3b 3b 20 20 20 20 20 3 49"))).;;
c6b0: 28 28 4c 41 55 4e 43 48 45 44 29 20 20 20 20 20 ((LAUNCHED)
c6c0: 20 20 20 20 22 31 30 31 20 31 32 33 20 31 34 32 "101 123 142
c6d0: 22 29 0a 3b 3b 20 20 20 20 20 28 28 43 48 45 43 ").;; ((CHEC
c6e0: 4b 29 20 20 20 20 20 20 20 20 20 20 20 20 22 32 K) "2
c6f0: 35 35 20 31 30 30 20 35 30 22 29 0a 3b 3b 20 20 55 100 50").;;
c700: 20 20 20 28 28 52 45 4d 4f 54 45 48 4f 53 54 53 ((REMOTEHOSTS
c710: 54 41 52 54 29 20 20 22 35 30 20 20 31 33 30 20 TART) "50 130
c720: 31 39 35 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 195").;; ((R
c730: 55 4e 4e 49 4e 47 29 20 20 20 20 20 20 20 20 20 UNNING)
c740: 20 22 39 20 20 20 31 33 31 20 32 33 32 22 29 0a "9 131 232").
c750: 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c 52 45 51 ;; ((KILLREQ
c760: 29 20 20 20 20 20 20 20 20 20 20 22 33 39 20 20 ) "39
c770: 38 32 20 20 32 30 36 22 29 0a 3b 3b 20 20 20 20 82 206").;;
c780: 20 28 28 4b 49 4c 4c 45 44 29 20 20 20 20 20 20 ((KILLED)
c790: 20 20 20 20 20 22 32 33 34 20 31 30 31 20 31 37 "234 101 17
c7a0: 22 29 0a 3b 3b 20 20 20 20 20 28 28 4e 4f 54 5f ").;; ((NOT_
c7b0: 53 54 41 52 54 45 44 29 20 20 20 20 20 20 22 32 STARTED) "2
c7c0: 34 30 20 32 34 30 20 32 34 30 22 29 0a 3b 3b 20 40 240 240").;;
c7d0: 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 (else
c7e0: 20 20 20 20 20 20 20 20 22 31 39 32 20 31 39 32 "192 192
c7f0: 20 31 39 32 22 29 29 29 0a 0a 28 64 65 66 69 6e 192")))..(defin
c800: 65 20 28 63 6f 6d 6d 6f 6e 3a 69 75 70 2d 63 6f e (common:iup-co
c810: 6c 6f 72 2d 3e 72 67 62 2d 68 65 78 20 69 6e 73 lor->rgb-hex ins
c820: 74 72 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e tr). (string-in
c830: 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 6d tersperse . (m
c840: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 ap (lambda (x).
c850: 20 20 20 20 20 20 20 20 20 28 6e 75 6d 62 65 72 (number
c860: 2d 3e 73 74 72 69 6e 67 20 78 20 31 36 29 29 0a ->string x 16)).
c870: 20 20 20 20 20 20 20 20 28 6d 61 70 20 73 74 72 (map str
c880: 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 20 20 20 20 ing->number.
c890: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
c8a0: 2d 73 70 6c 69 74 20 69 6e 73 74 72 29 29 29 0a -split instr))).
c8b0: 20 20 20 22 2f 22 29 29 0a 0a 28 64 65 66 69 6e "/"))..(defin
c8c0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f e (common:get-co
c8d0: 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 lor-from-status
c8e0: 73 74 61 74 75 73 29 0a 20 20 28 63 6f 6e 64 0a status). (cond.
c8f0: 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
c900: 75 73 20 22 50 41 53 53 22 29 20 20 20 20 22 67 us "PASS") "g
c910: 72 65 65 6e 22 29 0a 20 20 20 28 28 65 71 75 61 reen"). ((equa
c920: 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 l? status "FAIL"
c930: 29 20 20 20 20 22 72 65 64 22 29 0a 20 20 20 28 ) "red"). (
c940: 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
c950: 57 41 52 4e 22 29 20 20 20 20 22 6f 72 61 6e 67 WARN") "orang
c960: 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
c970: 73 74 61 74 75 73 20 22 4b 49 4c 4c 45 44 22 29 status "KILLED")
c980: 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 "orange"). (
c990: 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
c9a0: 4b 49 4c 4c 52 45 51 22 29 20 22 70 75 72 70 6c KILLREQ") "purpl
c9b0: 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
c9c0: 73 74 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 status "RUNNING"
c9d0: 29 20 22 62 6c 75 65 22 29 0a 20 20 20 28 28 65 ) "blue"). ((e
c9e0: 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 41 42 qual? status "AB
c9f0: 4f 52 54 22 29 20 20 20 22 62 72 6f 77 6e 22 29 ORT") "brown")
ca00: 0a 20 20 20 28 65 6c 73 65 20 22 62 6c 61 63 6b . (else "black
ca10: 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ")))..;;========
ca20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
ca60: 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 53 20 47 20 ; N A N O M S G
ca70: 20 20 43 20 4c 20 49 20 45 20 4e 20 54 0a 3b 3b C L I E N T.;;
ca80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
caa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cac0: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
cad0: 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
cae0: 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 -guess-address h
caf0: 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 ostname). (let
cb00: 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 ((res #f)). (
cb10: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
cb20: 6c 61 6d 62 64 61 20 28 61 64 72 29 0a 20 20 20 lambda (adr).
cb30: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
cb40: 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 65 66 20 ? (u8vector-ref
cb50: 61 64 72 20 30 29 20 31 32 37 29 29 0a 09 20 20 adr 0) 127))..
cb60: 20 28 73 65 74 21 20 72 65 73 20 61 64 72 29 29 (set! res adr))
cb70: 29 0a 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 ). ;; NOTE:
cb80: 54 68 69 73 20 63 61 6e 20 66 61 69 6c 20 77 68 This can fail wh
cb90: 65 6e 20 74 68 65 72 65 20 69 73 20 6e 6f 20 6d en there is no m
cba0: 65 6e 74 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f ention of the ho
cbb0: 73 74 20 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 st in /etc/hosts
cbc0: 2e 20 46 49 58 4d 45 0a 20 20 20 20 20 28 76 65 . FIXME. (ve
cbd0: 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 ctor->list (host
cbe0: 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 info-addresses (
cbf0: 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e hostname->hostin
cc00: 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a fo hostname)))).
cc10: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
cc20: 72 73 70 65 72 73 65 20 0a 20 20 20 20 20 28 6d rsperse . (m
cc30: 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e ap number->strin
cc40: 67 0a 09 20 20 28 75 38 76 65 63 74 6f 72 2d 3e g.. (u8vector->
cc50: 6c 69 73 74 0a 09 20 20 20 28 69 66 20 72 65 73 list.. (if res
cc60: 20 72 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e res (hostname->
cc70: 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 ip hostname))))
cc80: 22 2e 22 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 ".")))...(define
cc90: 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e 64 2d 64 62 (common:send-db
cca0: 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 61 6e 67 65 oard-main-change
ccb0: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 61 73 d). (let* ((das
ccc0: 68 62 6f 61 72 64 2d 69 70 73 20 28 6d 64 64 62 hboard-ips (mddb
ccd0: 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 64 73 29 :get-dashboards)
cce0: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
ccf0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 . (lambda (i
cd00: 70 61 64 72 29 0a 20 20 20 20 20 20 20 28 6c 65 padr). (le
cd10: 74 2a 20 28 28 73 6f 63 20 28 63 6f 6d 6d 6f 6e t* ((soc (common
cd20: 3a 6f 70 65 6e 2d 6e 6d 2d 72 65 71 20 28 63 6f :open-nm-req (co
cd30: 6e 63 20 22 74 63 70 3a 2f 2f 22 20 69 70 61 64 nc "tcp://" ipad
cd40: 72 29 29 29 0a 09 20 20 20 20 20 20 28 6d 73 67 r))).. (msg
cd50: 20 28 63 6f 6e 63 20 22 6d 61 69 6e 20 22 20 2a (conc "main " *
cd60: 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 20 20 20 toppath*))..
cd70: 20 20 28 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a 6e (res (common:n
cd80: 6d 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 74 m-send-receive-t
cd90: 69 6d 65 6f 75 74 20 73 6f 63 20 6d 73 67 29 29 imeout soc msg))
cda0: 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 72 65 73 ).. (if (not res
cdb0: 29 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 65 ) ;; couldn't re
cdc0: 61 63 68 20 74 68 61 74 20 64 61 73 68 62 6f 61 ach that dashboa
cdd0: 72 64 20 2d 20 72 65 6d 6f 76 65 20 69 74 20 66 rd - remove it f
cde0: 72 6f 6d 20 64 62 0a 09 20 20 20 20 20 28 70 72 rom db.. (pr
cdf0: 69 6e 74 20 22 45 52 52 4f 52 3a 20 63 6f 75 6c int "ERROR: coul
ce00: 64 6e 27 74 20 72 65 61 63 68 20 64 61 73 68 62 dn't reach dashb
ce10: 6f 61 72 64 20 22 20 69 70 61 64 72 29 29 0a 09 oard " ipadr))..
ce20: 20 72 65 73 29 29 0a 20 20 20 20 20 64 61 73 68 res)). dash
ce30: 62 6f 61 72 64 2d 69 70 73 29 29 29 0a 20 20 20 board-ips))).
ce40: 20 0a 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d . .;;=======
ce50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ce60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ce70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ce80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
ce90: 3b 3b 20 44 20 41 20 53 20 48 20 42 20 4f 20 41 ;; D A S H B O A
cea0: 20 52 20 44 20 20 20 44 20 42 20 0a 3b 3b 3d 3d R D D B .;;==
ceb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ced0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cef0: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d ====..(define (m
cf00: 64 64 62 3a 6f 70 65 6e 2d 64 62 29 0a 20 20 28 ddb:open-db). (
cf10: 6c 65 74 2a 20 28 28 64 62 20 28 6f 70 65 6e 2d let* ((db (open-
cf20: 64 61 74 61 62 61 73 65 20 28 63 6f 6e 63 20 28 database (conc (
cf30: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
cf40: 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 variable "HOME")
cf50: 20 22 2f 2e 64 61 73 68 62 6f 61 72 64 2e 64 62 "/.dashboard.db
cf60: 22 29 29 29 29 0a 20 20 20 20 28 73 65 74 2d 62 ")))). (set-b
cf70: 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 usy-handler! db
cf80: 28 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 30 (busy-timeout 10
cf90: 30 30 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 000)). (for-e
cfa0: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
cfb0: 20 28 71 72 79 29 0a 20 20 20 20 20 20 20 28 65 (qry). (e
cfc0: 78 65 63 20 28 73 71 6c 20 64 62 20 71 72 79 29 xec (sql db qry)
cfd0: 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 0a 20 )). (list .
cfe0: 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 "CREATE TAB
cff0: 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 LE IF NOT EXISTS
d000: 20 76 61 72 73 20 20 20 20 20 20 20 28 69 64 20 vars (id
d010: 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
d020: 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 20 76 61 KEY,key TEXT, va
d030: 6c 20 54 45 58 54 2c 20 43 4f 4e 53 54 52 41 49 l TEXT, CONSTRAI
d040: 4e 54 20 76 61 72 73 63 6f 6e 73 74 72 61 69 6e NT varsconstrain
d050: 74 20 55 4e 49 51 55 45 20 28 6b 65 79 29 29 3b t UNIQUE (key));
d060: 22 0a 20 20 20 20 20 20 22 43 52 45 41 54 45 20 ". "CREATE
d070: 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 TABLE IF NOT EXI
d080: 53 54 53 20 64 61 73 68 62 6f 61 72 64 73 20 28 STS dashboards (
d090: 0a 20 20 20 20 20 20 20 20 20 20 69 64 20 20 20 . id
d0a0: 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 52 INTEGER PR
d0b0: 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 IMARY KEY,.
d0c0: 20 20 20 20 20 70 69 64 20 20 20 20 20 20 20 20 pid
d0d0: 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 INTEGER,.
d0e0: 20 20 20 75 73 65 72 6e 61 6d 65 20 20 20 54 45 username TE
d0f0: 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 68 6f XT,. ho
d100: 73 74 6e 61 6d 65 20 20 20 54 45 58 54 2c 0a 20 stname TEXT,.
d110: 20 20 20 20 20 20 20 20 20 69 70 61 64 64 72 20 ipaddr
d120: 20 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 20 TEXT,.
d130: 20 20 20 20 70 6f 72 74 6e 75 6d 20 20 20 20 49 portnum I
d140: 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 NTEGER,.
d150: 20 20 73 74 61 72 74 5f 74 69 6d 65 20 54 49 4d start_time TIM
d160: 45 53 54 41 4d 50 20 44 45 46 41 55 4c 54 20 28 ESTAMP DEFAULT (
d170: 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
d180: 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 20 20 20 ow')),.
d190: 20 20 20 20 43 4f 4e 53 54 52 41 49 4e 54 20 68 CONSTRAINT h
d1a0: 6f 73 74 70 6f 72 74 20 55 4e 49 51 55 45 20 28 ostport UNIQUE (
d1b0: 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 6e 75 6d hostname,portnum
d1c0: 29 0a 20 20 20 20 20 20 20 20 29 3b 22 0a 20 20 ). );".
d1d0: 20 20 20 20 29 29 0a 20 20 20 20 64 62 29 29 0a )). db)).
d1e0: 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 64 .;; register a d
d1f0: 61 73 68 62 6f 61 72 64 20 0a 3b 3b 0a 28 64 65 ashboard .;;.(de
d200: 66 69 6e 65 20 28 6d 64 64 62 3a 72 65 67 69 73 fine (mddb:regis
d210: 74 65 72 2d 64 61 73 68 62 6f 61 72 64 20 70 6f ter-dashboard po
d220: 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 69 rt). (let* ((pi
d230: 64 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d d (current-
d240: 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 09 20 28 process-id)).. (
d250: 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f hostname (get-ho
d260: 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 st-name)).. (ipa
d270: 64 64 72 20 20 20 28 73 65 72 76 65 72 3a 67 65 ddr (server:ge
d280: 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 t-best-guess-add
d290: 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 29 0a ress hostname)).
d2a0: 09 20 28 75 73 65 72 6e 61 6d 65 20 28 63 75 72 . (username (cur
d2b0: 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 rent-user-name))
d2c0: 20 3b 3b 20 28 63 61 72 20 75 73 65 72 69 6e 66 ;; (car userinf
d2d0: 6f 29 29 29 0a 09 20 28 64 62 20 20 20 20 20 20 o))).. (db
d2e0: 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 (mddb:open-db)))
d2f0: 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 67 . (print "Reg
d300: 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 70 ister monitor, p
d310: 69 64 3a 20 22 20 70 69 64 20 22 2c 20 68 6f 73 id: " pid ", hos
d320: 74 6e 61 6d 65 3a 20 22 20 68 6f 73 74 6e 61 6d tname: " hostnam
d330: 65 20 22 2c 20 70 6f 72 74 3a 20 22 20 70 6f 72 e ", port: " por
d340: 74 20 22 2c 20 75 73 65 72 6e 61 6d 65 3a 20 22 t ", username: "
d350: 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 20 28 username). (
d360: 65 78 65 63 20 28 73 71 6c 20 64 62 20 22 49 4e exec (sql db "IN
d370: 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 SERT OR REPLACE
d380: 49 4e 54 4f 20 64 61 73 68 62 6f 61 72 64 73 20 INTO dashboards
d390: 28 70 69 64 2c 75 73 65 72 6e 61 6d 65 2c 68 6f (pid,username,ho
d3a0: 73 74 6e 61 6d 65 2c 69 70 61 64 64 72 2c 70 6f stname,ipaddr,po
d3b0: 72 74 6e 75 6d 29 20 56 41 4c 55 45 53 20 28 3f rtnum) VALUES (?
d3c0: 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 ,?,?,?,?);")..
d3d0: 20 70 69 64 20 75 73 65 72 6e 61 6d 65 20 68 6f pid username ho
d3e0: 73 74 6e 61 6d 65 20 69 70 61 64 64 72 20 70 6f stname ipaddr po
d3f0: 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 64 rt). (close-d
d400: 61 74 61 62 61 73 65 20 64 62 29 29 29 0a 0a 3b atabase db)))..;
d410: 3b 20 75 6e 72 65 67 69 73 74 65 72 20 61 20 6d ; unregister a m
d420: 6f 6e 69 74 6f 72 0a 3b 3b 0a 28 64 65 66 69 6e onitor.;;.(defin
d430: 65 20 28 6d 64 64 62 3a 75 6e 72 65 67 69 73 74 e (mddb:unregist
d440: 65 72 2d 64 61 73 68 62 6f 61 72 64 20 68 6f 73 er-dashboard hos
d450: 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 t port). (let*
d460: 28 28 64 62 20 20 20 20 20 20 28 6d 64 64 62 3a ((db (mddb:
d470: 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 open-db))). (
d480: 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 20 print "Register
d490: 75 6e 72 65 67 69 73 74 65 72 20 6d 6f 6e 69 74 unregister monit
d4a0: 6f 72 2c 20 68 6f 73 74 3a 70 6f 72 74 3d 22 20 or, host:port="
d4b0: 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 0a 20 host ":" port).
d4c0: 20 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 (exec (sql db
d4d0: 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 64 61 "DELETE FROM da
d4e0: 73 68 62 6f 61 72 64 73 20 57 48 45 52 45 20 68 shboards WHERE h
d4f0: 6f 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 70 6f ostname=? AND po
d500: 72 74 6e 75 6d 3d 3f 3b 22 29 20 68 6f 73 74 20 rtnum=?;") host
d510: 70 6f 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 65 port). (close
d520: 2d 64 61 74 61 62 61 73 65 20 64 62 29 29 29 0a -database db))).
d530: 0a 3b 3b 20 67 65 74 20 72 65 67 69 73 74 65 72 .;; get register
d540: 65 64 20 64 61 73 68 62 6f 61 72 64 73 0a 3b 3b ed dashboards.;;
d550: 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 67 .(define (mddb:g
d560: 65 74 2d 64 61 73 68 62 6f 61 72 64 73 29 0a 20 et-dashboards).
d570: 20 28 6c 65 74 20 28 28 64 62 20 28 6d 64 64 62 (let ((db (mddb
d580: 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 :open-db))).
d590: 28 71 75 65 72 79 20 66 65 74 63 68 2d 63 6f 6c (query fetch-col
d5a0: 75 6d 6e 0a 09 20 20 20 28 73 71 6c 20 64 62 20 umn.. (sql db
d5b0: 22 53 45 4c 45 43 54 20 69 70 61 64 64 72 20 7c "SELECT ipaddr |
d5c0: 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 74 6e 75 6d | ':' || portnum
d5d0: 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 73 FROM dashboards
d5e0: 3b 22 29 29 29 29 0a 20 20 20 20 0a 3b 3b 3d 3d ;")))). .;;==
d5f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d630: 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 ====.;; T E S T
d640: 20 20 20 4c 20 41 20 55 20 4e 20 43 20 48 20 49 L A U N C H I
d650: 20 4e 20 47 20 20 20 50 20 45 20 52 20 20 20 49 N G P E R I
d660: 20 54 20 45 20 4d 20 20 20 57 20 49 20 54 20 48 T E M W I T H
d670: 20 20 20 48 20 4f 20 53 20 54 20 20 20 54 20 59 H O S T T Y
d680: 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d P E S.;;=======
d690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d6b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d6c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
d6d0: 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 2d 74 79 70 ;; .;; [host-typ
d6e0: 65 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 73 es].;; general s
d6f0: 73 68 20 23 7b 67 65 74 62 67 65 73 74 68 6f 73 sh #{getbgesthos
d700: 74 20 67 65 6e 65 72 61 6c 7d 0a 3b 3b 20 6e 62 t general}.;; nb
d710: 67 65 6e 65 72 61 6c 20 6e 62 6a 6f 62 20 72 75 general nbjob ru
d720: 6e 20 4a 4f 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f n JOBCOMMAND -lo
d730: 67 20 24 4d 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 g $MT_LINKTREE/$
d740: 4d 54 5f 54 41 52 47 45 54 2f 24 4d 54 5f 52 55 MT_TARGET/$MT_RU
d750: 4e 4e 41 4d 45 2e 24 4d 54 5f 54 45 53 54 4e 41 NNAME.$MT_TESTNA
d760: 4d 45 2d 24 4d 54 5f 49 54 45 4d 5f 50 41 54 48 ME-$MT_ITEM_PATH
d770: 2e 6c 67 6f 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 .lgo.;; .;; [hos
d780: 74 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 63 ts].;; general c
d790: 75 62 69 61 6e 20 78 65 6e 61 0a 3b 3b 20 0a 3b ubian xena.;; .;
d7a0: 3b 20 5b 6c 61 75 6e 63 68 65 72 73 5d 0a 3b 3b ; [launchers].;;
d7b0: 20 65 6e 76 73 65 74 75 70 20 67 65 6e 65 72 61 envsetup genera
d7c0: 6c 0a 3b 3b 20 78 6f 72 2f 25 2f 6e 20 34 43 31 l.;; xor/%/n 4C1
d7d0: 36 47 0a 3b 3b 20 25 20 6e 62 67 65 6e 65 72 61 6G.;; % nbgenera
d7e0: 6c 0a 3b 3b 20 0a 3b 3b 20 5b 6a 6f 62 74 6f 6f l.;; .;; [jobtoo
d7f0: 6c 73 5d 0a 3b 3b 20 6c 61 75 6e 63 68 65 72 20 ls].;; launcher
d800: 62 73 75 62 0a 3b 3b 20 23 20 69 66 20 64 65 66 bsub.;; # if def
d810: 69 6e 65 64 20 61 6e 64 20 6e 6f 74 20 22 6e 6f ined and not "no
d820: 22 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 " flexi-launcher
d830: 20 77 69 6c 6c 20 62 79 70 61 73 73 20 6c 61 75 will bypass lau
d840: 6e 63 68 65 72 20 75 6e 6c 65 73 73 20 74 68 65 ncher unless the
d850: 72 65 20 69 73 20 6e 6f 0a 3b 3b 20 23 20 6d 61 re is no.;; # ma
d860: 74 63 68 2e 0a 3b 3b 20 66 6c 65 78 69 2d 6c 61 tch..;; flexi-la
d870: 75 6e 63 68 65 72 20 79 65 73 20 20 0a 0a 28 64 uncher yes ..(d
d880: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
d890: 74 2d 6c 61 75 6e 63 68 65 72 20 63 6f 6e 66 69 t-launcher confi
d8a0: 67 64 61 74 20 74 65 73 74 6e 61 6d 65 20 69 74 gdat testname it
d8b0: 65 6d 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 empath). (let (
d8c0: 28 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 (fallback-launch
d8d0: 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b er (configf:look
d8e0: 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f up configdat "jo
d8f0: 62 74 6f 6f 6c 73 22 20 22 6c 61 75 6e 63 68 65 btools" "launche
d900: 72 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 r"))). (if (a
d910: 6e 64 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b nd (configf:look
d920: 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f up configdat "jo
d930: 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c btools" "flexi-l
d940: 61 75 6e 63 68 65 72 22 29 20 3b 3b 20 6f 76 65 auncher") ;; ove
d950: 72 72 69 64 65 73 20 6c 61 75 6e 63 68 65 72 0a rrides launcher.
d960: 09 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 . (not (equa
d970: 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b l? (configf:look
d980: 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f up configdat "jo
d990: 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c btools" "flexi-l
d9a0: 61 75 6e 63 68 65 72 22 29 20 22 6e 6f 22 29 29 auncher") "no"))
d9b0: 29 0a 09 28 6c 65 74 2a 20 28 28 6c 61 75 6e 63 )..(let* ((launc
d9c0: 68 65 72 73 20 20 20 20 20 20 20 20 20 28 68 61 hers (ha
d9d0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
d9e0: 61 75 6c 74 20 63 6f 6e 66 69 67 64 61 74 20 22 ault configdat "
d9f0: 6c 61 75 6e 63 68 65 72 73 22 20 27 28 29 29 29 launchers" '()))
da00: 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ).. (if (null?
da10: 6c 61 75 6e 63 68 65 72 73 29 0a 09 20 20 20 20 launchers)..
da20: 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 fallback-launc
da30: 68 65 72 0a 09 20 20 20 20 20 20 28 6c 65 74 20 her.. (let
da40: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
da50: 6c 61 75 6e 63 68 65 72 73 29 29 0a 09 09 09 20 launchers))....
da60: 28 74 61 6c 20 28 63 64 72 20 6c 61 75 6e 63 68 (tal (cdr launch
da70: 65 72 73 29 29 29 0a 09 09 28 6c 65 74 20 28 28 ers)))...(let ((
da80: 70 61 74 74 20 20 20 20 20 20 28 63 61 72 20 68 patt (car h
da90: 65 64 29 29 0a 09 09 20 20 20 20 20 20 28 68 6f ed))... (ho
daa0: 73 74 2d 74 79 70 65 20 28 63 61 64 72 20 68 65 st-type (cadr he
dab0: 64 29 29 29 0a 09 09 20 20 28 69 66 20 28 74 65 d)))... (if (te
dac0: 73 74 73 3a 6d 61 74 63 68 20 70 61 74 74 20 74 sts:match patt t
dad0: 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 estname itempath
dae0: 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e )... (begin
daf0: 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
db00: 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 -info 2 *default
db10: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 48 61 76 65 -log-port* "Have
db20: 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 flexi-launcher
db30: 6d 61 74 63 68 20 66 6f 72 20 22 20 74 65 73 74 match for " test
db40: 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 74 name "/" itempat
db50: 68 20 22 20 3d 20 22 20 68 6f 73 74 2d 74 79 70 h " = " host-typ
db60: 65 29 0a 09 09 09 28 6c 65 74 20 28 28 6c 61 75 e)....(let ((lau
db70: 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c ncher (configf:l
db80: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 ookup configdat
db90: 22 68 6f 73 74 2d 74 79 70 65 73 22 20 68 6f 73 "host-types" hos
dba0: 74 2d 74 79 70 65 29 29 29 0a 09 09 09 20 20 28 t-type))).... (
dbb0: 69 66 20 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 if launcher....
dbc0: 20 20 20 20 20 6c 61 75 6e 63 68 65 72 0a 09 09 launcher...
dbd0: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
dbe0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
dbf0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
dc00: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
dc10: 47 3a 20 6e 6f 20 6c 61 75 6e 63 68 65 72 20 66 G: no launcher f
dc20: 6f 75 6e 64 20 66 6f 72 20 68 6f 73 74 2d 74 79 ound for host-ty
dc30: 70 65 20 22 20 68 6f 73 74 2d 74 79 70 65 29 0a pe " host-type).
dc40: 09 09 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 ....(if (null? t
dc50: 61 6c 29 0a 09 09 09 09 20 20 20 20 66 61 6c 6c al)..... fall
dc60: 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 09 back-launcher...
dc70: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
dc80: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
dc90: 29 29 29 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 ))))... ;;
dca0: 6e 6f 20 6d 61 74 63 68 2c 20 74 72 79 20 61 67 no match, try ag
dcb0: 61 69 6e 0a 09 09 20 20 20 20 20 20 28 69 66 20 ain... (if
dcc0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 (null? tal)....
dcd0: 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 fallback-launch
dce0: 65 72 0a 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 er.... (loop (c
dcf0: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
dd00: 29 29 29 29 29 29 29 0a 09 66 61 6c 6c 62 61 63 )))))))..fallbac
dd10: 6b 2d 6c 61 75 6e 63 68 65 72 29 29 29 0a 20 20 k-launcher))).
dd20: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
dd30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dd40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dd50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dd60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 =========.;; D A
dd70: 20 53 20 48 20 42 20 4f 20 41 20 52 20 44 20 20 S H B O A R D
dd80: 20 55 20 53 20 45 20 52 20 20 20 56 20 49 20 45 U S E R V I E
dd90: 20 57 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d W S.;;=========
dda0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ddb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ddc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ddd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
dde0: 3b 20 66 69 72 73 74 20 72 65 61 64 20 7e 2f 76 ; first read ~/v
ddf0: 69 65 77 73 2e 63 6f 6e 66 69 67 20 69 66 20 69 iews.config if i
de00: 74 20 65 78 69 73 74 73 2c 20 74 68 65 6e 20 72 t exists, then r
de10: 65 61 64 20 24 4d 54 52 41 48 2f 76 69 65 77 73 ead $MTRAH/views
de20: 2e 63 6f 6e 66 69 67 20 69 66 20 69 74 20 65 78 .config if it ex
de30: 69 73 74 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ists.;;.(define
de40: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 61 64 2d 76 69 65 (common:load-vie
de50: 77 73 2d 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 ws-config). (le
de60: 74 2a 20 28 28 76 69 65 77 2d 63 66 67 64 61 74 t* ((view-cfgdat
de70: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
de80: 61 62 6c 65 29 29 0a 09 20 28 68 6f 6d 65 2d 63 able)).. (home-c
de90: 66 67 66 69 6c 65 20 20 20 28 63 6f 6e 63 20 28 fgfile (conc (
dea0: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
deb0: 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 variable "HOME")
dec0: 20 22 2f 2e 6d 74 76 69 65 77 73 2e 63 6f 6e 66 "/.mtviews.conf
ded0: 69 67 22 29 29 0a 09 20 28 6d 74 68 6f 6d 65 2d ig")).. (mthome-
dee0: 63 66 67 66 69 6c 65 20 28 63 6f 6e 63 20 2a 74 cfgfile (conc *t
def0: 6f 70 70 61 74 68 2a 20 22 2f 2e 6d 74 76 69 65 oppath* "/.mtvie
df00: 77 73 2e 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 ws.config"))).
df10: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
df20: 74 73 3f 20 6d 74 68 6f 6d 65 2d 63 66 67 66 69 ts? mthome-cfgfi
df30: 6c 65 29 0a 09 28 72 65 61 64 2d 63 6f 6e 66 69 le)..(read-confi
df40: 67 20 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 g mthome-cfgfile
df50: 20 76 69 65 77 2d 63 66 67 64 61 74 20 23 74 29 view-cfgdat #t)
df60: 29 0a 20 20 20 20 3b 3b 20 77 65 20 6c 6f 61 64 ). ;; we load
df70: 20 74 68 65 20 68 6f 6d 65 20 64 69 72 20 66 69 the home dir fi
df80: 6c 65 20 41 46 54 45 52 20 74 68 65 20 4d 54 52 le AFTER the MTR
df90: 41 48 20 66 69 6c 65 20 73 6f 20 74 68 65 20 75 AH file so the u
dfa0: 73 65 72 20 63 61 6e 20 63 6c 6f 62 62 65 72 20 ser can clobber
dfb0: 73 65 74 74 69 6e 67 73 20 77 68 65 6e 20 72 75 settings when ru
dfc0: 6e 6e 69 6e 67 20 74 68 65 20 64 61 73 68 62 6f nning the dashbo
dfd0: 61 72 64 20 69 6e 20 72 65 61 64 2d 6f 6e 6c 79 ard in read-only
dfe0: 20 61 72 65 61 73 0a 20 20 20 20 28 69 66 20 28 areas. (if (
dff0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 68 6f 6d file-exists? hom
e000: 65 2d 63 66 67 66 69 6c 65 29 0a 09 28 72 65 61 e-cfgfile)..(rea
e010: 64 2d 63 6f 6e 66 69 67 20 68 6f 6d 65 2d 63 66 d-config home-cf
e020: 67 66 69 6c 65 20 76 69 65 77 2d 63 66 67 64 61 gfile view-cfgda
e030: 74 20 23 74 29 29 0a 20 20 20 20 76 69 65 77 2d t #t)). view-
e040: 63 66 67 64 61 74 29 29 0a 0a cfgdat))..