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 0a 3b 3b 20 ed to reget..;;
1520: 41 77 66 75 6c 2e 20 50 6c 65 61 73 65 20 46 49 Awful. Please FI
1530: 58 4d 45 0a 28 64 65 66 69 6e 65 20 2a 65 6e 76 XME.(define *env
1540: 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a -vars-by-run-id*
1550: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1560: 65 29 29 0a 0a 3b 3b 20 54 65 73 74 63 6f 6e 66 e))..;; Testconf
1570: 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e 66 69 67 ig and runconfig
1580: 20 63 61 63 68 65 73 2e 20 0a 28 64 65 66 69 6e caches. .(defin
1590: 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 e *testconfigs*
15a0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
15b0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 65 73 74 -table)) ;; test
15c0: 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 63 6f 6e -name => testcon
15d0: 66 69 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e fig.(define *run
15e0: 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 20 20 20 configs*
15f0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1600: 29 29 20 3b 3b 20 74 61 72 67 65 74 20 20 20 20 )) ;; target
1610: 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 0a 0a 3b 3b => runconfig..;;
1620: 20 54 68 69 73 20 69 73 20 61 20 63 61 63 68 65 This is a cache
1630: 20 6f 66 20 70 72 65 2d 72 65 71 73 20 6d 65 74 of pre-reqs met
1640: 2c 20 64 6f 6e 27 74 20 72 65 2d 63 61 6c 63 20 , don't re-calc
1650: 69 6e 20 63 61 73 65 73 20 77 68 65 72 65 20 63 in cases where c
1660: 61 6c 6c 65 64 20 77 69 74 68 20 73 61 6d 65 20 alled with same
1670: 70 61 72 61 6d 73 20 6c 65 73 73 20 74 68 61 6e params less than
1680: 0a 3b 3b 20 66 69 76 65 20 73 65 63 6f 6e 64 73 .;; five seconds
1690: 20 61 67 6f 0a 28 64 65 66 69 6e 65 20 2a 70 72 ago.(define *pr
16a0: 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 63 68 65 e-reqs-met-cache
16b0: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
16c0: 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 65 20 6f le))..;; cache o
16d0: 66 20 76 65 72 62 6f 73 69 74 79 20 67 69 76 65 f verbosity give
16e0: 6e 20 73 74 72 69 6e 67 0a 3b 3b 0a 28 64 65 66 n string.;;.(def
16f0: 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 2d 63 ine *verbosity-c
1700: 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 ache* (make-hash
1710: 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 66 69 6e -table))..(defin
1720: 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d e (common:clear-
1730: 63 61 63 68 65 73 29 0a 20 20 28 73 65 74 21 20 caches). (set!
1740: 2a 74 61 72 67 65 74 2a 20 20 20 20 20 20 20 20 *target*
1750: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1760: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
1770: 2a 6b 65 79 73 2a 20 20 20 20 20 20 20 20 20 20 *keys*
1780: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1790: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
17a0: 2a 6b 65 79 76 61 6c 73 2a 20 20 20 20 20 20 20 *keyvals*
17b0: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
17c0: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
17d0: 2a 74 6f 70 74 65 73 74 2d 70 61 74 68 73 2a 20 *toptest-paths*
17e0: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
17f0: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
1800: 2a 74 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 *test-paths*
1810: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1820: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
1830: 2a 74 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 *test-ids*
1840: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1850: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
1860: 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 20 20 20 *test-info*
1870: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1880: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
1890: 2a 72 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a *run-info-cache*
18a0: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
18b0: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
18c0: 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e *env-vars-by-run
18d0: 2d 69 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d -id* (make-hash-
18e0: 74 61 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 table)). (set!
18f0: 2a 74 65 73 74 2d 69 64 2d 63 61 63 68 65 2a 20 *test-id-cache*
1900: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1910: 74 61 62 6c 65 29 29 29 0a 0a 3b 3b 20 47 65 6e table)))..;; Gen
1920: 65 72 69 63 20 73 74 72 69 6e 67 20 64 61 74 61 eric string data
1930: 62 61 73 65 0a 28 64 65 66 69 6e 65 20 73 64 62 base.(define sdb
1940: 3a 71 72 79 20 23 66 29 20 3b 3b 20 28 6d 61 6b :qry #f) ;; (mak
1950: 65 2d 73 64 62 3a 71 72 79 29 29 20 3b 3b 20 20 e-sdb:qry)) ;;
1960: 27 69 6e 69 74 20 23 66 29 0a 3b 3b 20 47 65 6e 'init #f).;; Gen
1970: 65 72 69 63 20 70 61 74 68 20 64 61 74 61 62 61 eric path databa
1980: 73 65 0a 28 64 65 66 69 6e 65 20 2a 66 64 62 2a se.(define *fdb*
1990: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 2a 6c #f)..(define *l
19a0: 61 73 74 2d 6c 61 75 6e 63 68 2a 20 28 63 75 72 ast-launch* (cur
19b0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b rent-seconds)) ;
19c0: 3b 20 75 73 65 20 66 6f 72 20 74 68 72 6f 74 74 ; use for thrott
19d0: 6c 69 6e 67 20 74 68 65 20 6c 61 75 6e 63 68 20 ling the launch
19e0: 72 61 74 65 2e 20 57 6f 75 6c 64 20 62 65 20 62 rate. Would be b
19f0: 65 74 74 65 72 20 74 6f 20 75 73 65 20 74 68 65 etter to use the
1a00: 20 64 62 20 61 6e 64 20 6c 61 73 74 20 74 69 6d db and last tim
1a10: 65 20 6f 66 20 61 20 74 65 73 74 20 69 6e 20 4c e of a test in L
1a20: 41 55 4e 43 48 45 44 20 73 74 61 74 65 2e 0a 0a AUNCHED state...
1a30: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
1a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1a70: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 56 20 45 20 ========.;; V E
1a80: 52 20 53 20 49 20 4f 20 4e 0a 3b 3b 3d 3d 3d 3d R S I O N.;;====
1a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ad0: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ==..(define (com
1ae0: 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c 2d 76 65 72 mon:get-full-ver
1af0: 73 69 6f 6e 29 0a 20 20 28 63 6f 6e 63 20 6d 65 sion). (conc me
1b00: 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 gatest-version "
1b10: 2d 22 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 -" megatest-foss
1b20: 69 6c 2d 68 61 73 68 29 29 0a 0a 28 64 65 66 69 il-hash))..(defi
1b30: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 ne (common:versi
1b40: 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 on-signature).
1b50: 28 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 (conc megatest-v
1b60: 65 72 73 69 6f 6e 20 22 2d 22 20 28 73 75 62 73 ersion "-" (subs
1b70: 74 72 69 6e 67 20 6d 65 67 61 74 65 73 74 2d 66 tring megatest-f
1b80: 6f 73 73 69 6c 2d 68 61 73 68 20 30 20 34 29 29 ossil-hash 0 4))
1b90: 29 0a 0a 3b 3b 20 66 72 6f 6d 20 6d 65 74 61 64 )..;; from metad
1ba0: 61 74 20 6c 6f 6f 6b 75 70 20 4d 45 47 41 54 45 at lookup MEGATE
1bb0: 53 54 5f 56 45 52 53 49 4f 4e 0a 3b 3b 0a 28 64 ST_VERSION.;;.(d
1bc0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
1bd0: 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 t-last-run-versi
1be0: 6f 6e 29 20 3b 3b 20 52 41 44 54 20 3d 3e 20 48 on) ;; RADT => H
1bf0: 6f 77 20 64 6f 65 73 20 74 68 69 73 20 77 6f 72 ow does this wor
1c00: 6b 20 69 6e 20 73 65 6e 64 2d 72 65 63 65 69 76 k in send-receiv
1c10: 65 20 66 75 6e 63 74 69 6f 6e 3f 3f 3b 20 61 73 e function??; as
1c20: 73 75 6d 65 20 69 74 20 69 73 20 74 68 65 20 76 sume it is the v
1c30: 61 6c 75 65 20 73 61 76 65 64 20 69 6e 20 73 6f alue saved in so
1c40: 6d 65 20 44 42 0a 20 20 28 72 6d 74 3a 67 65 74 me DB. (rmt:get
1c50: 2d 76 61 72 20 22 4d 45 47 41 54 45 53 54 5f 56 -var "MEGATEST_V
1c60: 45 52 53 49 4f 4e 22 29 29 0a 0a 28 64 65 66 69 ERSION"))..(defi
1c70: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c ne (common:get-l
1c80: 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 2d ast-run-version-
1c90: 6e 75 6d 62 65 72 29 0a 20 20 28 73 74 72 69 6e number). (strin
1ca0: 67 2d 3e 6e 75 6d 62 65 72 20 0a 20 20 20 28 73 g->number . (s
1cb0: 75 62 73 74 72 69 6e 67 20 28 63 6f 6d 6d 6f 6e ubstring (common
1cc0: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
1cd0: 72 73 69 6f 6e 29 20 30 20 36 29 29 29 0a 0a 28 rsion) 0 6)))..(
1ce0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
1cf0: 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 et-last-run-vers
1d00: 69 6f 6e 29 0a 20 20 28 72 6d 74 3a 73 65 74 2d ion). (rmt:set-
1d10: 76 61 72 20 22 4d 45 47 41 54 45 53 54 5f 56 45 var "MEGATEST_VE
1d20: 52 53 49 4f 4e 22 20 28 63 6f 6d 6d 6f 6e 3a 76 RSION" (common:v
1d30: 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 ersion-signature
1d40: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
1d50: 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 63 68 61 mmon:version-cha
1d60: 6e 67 65 64 3f 29 0a 20 20 28 6e 6f 74 20 28 65 nged?). (not (e
1d70: 71 75 61 6c 3f 20 28 63 6f 6d 6d 6f 6e 3a 67 65 qual? (common:ge
1d80: 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 t-last-run-versi
1d90: 6f 6e 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6d on).. (com
1da0: 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e mon:version-sign
1db0: 61 74 75 72 65 29 29 29 29 0a 0a 3b 3b 20 4d 6f ature))))..;; Mo
1dc0: 76 65 20 6d 65 20 65 6c 73 65 77 68 65 72 65 20 ve me elsewhere
1dd0: 2e 2e 2e 0a 3b 3b 20 52 41 44 54 20 3d 3e 20 57 ....;; RADT => W
1de0: 68 79 20 64 6f 20 77 65 20 6d 65 65 64 20 74 68 hy do we meed th
1df0: 65 20 76 65 72 73 69 6f 6e 20 63 68 65 63 6b 20 e version check
1e00: 68 65 72 65 2c 20 74 68 69 73 20 69 73 20 63 61 here, this is ca
1e10: 6c 6c 65 64 20 6f 6e 6c 79 20 69 66 20 76 65 72 lled only if ver
1e20: 73 69 6f 6e 20 6d 69 73 6d 61 0a 3b 3b 0a 28 64 sion misma.;;.(d
1e30: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c efine (common:cl
1e40: 65 61 6e 75 70 2d 64 62 20 64 62 73 74 72 75 63 eanup-db dbstruc
1e50: 74 29 0a 20 20 28 64 62 3a 6d 75 6c 74 69 2d 64 t). (db:multi-d
1e60: 62 2d 73 79 6e 63 20 0a 20 20 20 64 62 73 74 72 b-sync . dbstr
1e70: 75 63 74 0a 20 20 20 3b 3b 20 27 6e 65 77 32 6f uct. ;; 'new2o
1e80: 6c 64 0a 20 20 20 27 6b 69 6c 6c 73 65 72 76 65 ld. 'killserve
1e90: 72 73 0a 20 20 20 27 64 65 6a 75 6e 6b 0a 20 20 rs. 'dejunk.
1ea0: 20 3b 3b 20 27 61 64 6a 2d 74 65 73 74 69 64 73 ;; 'adj-testids
1eb0: 0a 20 20 20 3b 3b 20 27 6f 6c 64 32 6e 65 77 0a . ;; 'old2new.
1ec0: 20 20 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 27 'new2old. '
1ed0: 73 63 68 65 6d 61 29 0a 20 20 28 69 66 20 28 63 schema). (if (c
1ee0: 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 63 68 ommon:version-ch
1ef0: 61 6e 67 65 64 3f 29 0a 20 20 20 20 20 20 28 63 anged?). (c
1f00: 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 ommon:set-last-r
1f10: 75 6e 2d 76 65 72 73 69 6f 6e 29 29 29 0a 0a 3b un-version)))..;
1f20: 3b 20 52 6f 74 61 74 65 20 6c 6f 67 73 2c 20 6c ; Rotate logs, l
1f30: 6f 67 69 63 3a 20 0a 3b 3b 20 20 20 20 20 20 20 ogic: .;;
1f40: 20 20 20 20 20 20 20 20 20 20 69 66 20 3e 20 35 if > 5
1f50: 30 30 6b 20 61 6e 64 20 6f 6c 64 65 72 20 74 68 00k and older th
1f60: 61 6e 20 31 20 77 65 65 6b 3a 0a 3b 3b 20 20 20 an 1 week:.;;
1f70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1f80: 20 20 72 65 6d 6f 76 65 20 70 72 65 76 69 6f 75 remove previou
1f90: 73 20 63 6f 6d 70 72 65 73 73 65 64 20 6c 6f 67 s compressed log
1fa0: 20 61 6e 64 20 63 6f 6d 70 72 65 73 73 20 74 68 and compress th
1fb0: 69 73 20 6c 6f 67 0a 3b 3b 20 57 41 52 4e 49 4e is log.;; WARNIN
1fc0: 47 3a 20 54 68 69 73 20 70 72 6f 63 20 6f 70 65 G: This proc ope
1fd0: 72 61 74 65 73 20 61 73 73 75 6d 69 6e 67 20 74 rates assuming t
1fe0: 68 61 74 20 69 74 20 69 73 20 69 6e 20 74 68 65 hat it is in the
1ff0: 20 64 69 72 65 63 74 6f 72 79 20 61 62 6f 76 65 directory above
2000: 20 74 68 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 the.;;
2010: 20 6c 6f 67 73 20 64 69 72 65 63 74 6f 72 79 20 logs directory
2020: 79 6f 75 20 77 69 73 68 20 74 6f 20 6c 6f 67 2d you wish to log-
2030: 72 6f 74 61 74 65 2e 0a 3b 3b 0a 28 64 65 66 69 rotate..;;.(defi
2040: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 6f 74 61 74 ne (common:rotat
2050: 65 2d 6c 6f 67 73 29 0a 20 20 28 69 66 20 28 6e e-logs). (if (n
2060: 6f 74 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 ot (directory-ex
2070: 69 73 74 73 3f 20 22 6c 6f 67 73 22 29 29 28 63 ists? "logs"))(c
2080: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
2090: 22 6c 6f 67 73 22 29 29 0a 20 20 28 64 69 72 65 "logs")). (dire
20a0: 63 74 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 28 ctory-fold . (
20b0: 6c 61 6d 62 64 61 20 28 66 69 6c 65 20 72 65 6d lambda (file rem
20c0: 29 0a 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 ). (if (and
20d0: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e (string-match "^
20e0: 2e 2a 2e 6c 6f 67 22 20 66 69 6c 65 29 0a 09 20 .*.log" file)..
20f0: 20 20 20 20 20 28 3e 20 28 66 69 6c 65 2d 73 69 (> (file-si
2100: 7a 65 20 28 63 6f 6e 63 20 22 6c 6f 67 73 2f 22 ze (conc "logs/"
2110: 20 66 69 6c 65 29 29 20 32 30 30 30 30 30 29 29 file)) 200000))
2120: 0a 09 20 28 6c 65 74 20 28 28 67 7a 66 69 6c 65 .. (let ((gzfile
2130: 20 28 63 6f 6e 63 20 22 6c 6f 67 73 2f 22 20 66 (conc "logs/" f
2140: 69 6c 65 20 22 2e 67 7a 22 29 29 29 0a 09 20 20 ile ".gz")))..
2150: 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 (if (file-exist
2160: 73 3f 20 67 7a 66 69 6c 65 29 0a 09 20 20 20 20 s? gzfile)..
2170: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 28 64 65 (begin... (de
2180: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
2190: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
21a0: 72 74 2a 20 22 72 65 6d 6f 76 69 6e 67 20 22 20 rt* "removing "
21b0: 67 7a 66 69 6c 65 29 0a 09 09 20 28 64 65 6c 65 gzfile)... (dele
21c0: 74 65 2d 66 69 6c 65 20 67 7a 66 69 6c 65 29 29 te-file gzfile))
21d0: 29 0a 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 ).. (debug:pri
21e0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
21f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f lt-log-port* "co
2200: 6d 70 72 65 73 73 69 6e 67 20 22 20 66 69 6c 65 mpressing " file
2210: 29 0a 09 20 20 20 28 73 79 73 74 65 6d 20 28 63 ).. (system (c
2220: 6f 6e 63 20 22 67 7a 69 70 20 6c 6f 67 73 2f 22 onc "gzip logs/"
2230: 20 66 69 6c 65 29 29 29 29 29 0a 20 20 20 27 28 file))))). '(
2240: 29 0a 20 20 20 22 6c 6f 67 73 22 29 29 0a 20 20 ). "logs")).
2250: 20 20 0a 0a 0a 3b 3b 20 46 6f 72 63 65 20 61 20 ...;; Force a
2260: 6d 65 67 61 74 65 73 74 20 63 6c 65 61 6e 75 70 megatest cleanup
2270: 2d 64 62 20 69 66 20 76 65 72 73 69 6f 6e 20 69 -db if version i
2280: 73 20 63 68 61 6e 67 65 64 20 61 6e 64 20 73 6b s changed and sk
2290: 69 70 2d 76 65 72 73 69 6f 6e 2d 63 68 65 63 6b ip-version-check
22a0: 20 6e 6f 74 20 73 70 65 63 69 66 69 65 64 0a 3b not specified.;
22b0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
22c0: 6e 3a 65 78 69 74 2d 6f 6e 2d 76 65 72 73 69 6f n:exit-on-versio
22d0: 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 69 66 n-changed). (if
22e0: 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e (common:version
22f0: 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 20 20 20 -changed?).
2300: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d (if (common:on-
2310: 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 20 28 6c homehost?).. (l
2320: 65 74 20 28 28 6d 74 63 6f 6e 66 20 28 63 6f 6e et ((mtconf (con
2330: 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 c (get-environme
2340: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f nt-variable "MT_
2350: 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 20 RUN_AREA_HOME")
2360: 22 2f 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 "/megatest.confi
2370: 67 22 29 29 0a 09 09 28 64 62 73 74 72 75 63 74 g"))...(dbstruct
2380: 20 28 64 62 3a 73 65 74 75 70 29 29 29 0a 09 20 (db:setup)))..
2390: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
23a0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
23b0: 6f 72 74 2a 0a 09 09 09 20 22 57 41 52 4e 49 4e ort*.... "WARNIN
23c0: 47 3a 20 56 65 72 73 69 6f 6e 20 6d 69 73 6d 61 G: Version misma
23d0: 74 63 68 21 5c 6e 22 0a 09 09 09 20 22 20 20 20 tch!\n".... "
23e0: 65 78 70 65 63 74 65 64 3a 20 22 20 28 63 6f 6d expected: " (com
23f0: 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e mon:version-sign
2400: 61 74 75 72 65 29 20 22 5c 6e 22 0a 09 09 09 20 ature) "\n"....
2410: 22 20 20 20 67 6f 74 3a 20 20 20 20 20 20 22 20 " got: "
2420: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 (common:get-last
2430: 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 29 0a 09 -run-version))..
2440: 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 69 (if (and (fi
2450: 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 63 6f 6e le-exists? mtcon
2460: 66 29 0a 09 09 20 20 20 20 20 28 65 71 3f 20 28 f)... (eq? (
2470: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 current-user-id)
2480: 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 6f (file-owner mtco
2490: 6e 66 29 29 29 20 3b 3b 20 73 61 66 65 20 74 6f nf))) ;; safe to
24a0: 20 72 75 6e 20 2d 63 6c 65 61 6e 75 70 2d 64 62 run -cleanup-db
24b0: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 ...(begin... (d
24c0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
24d0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
24e0: 22 20 20 20 49 20 73 65 65 20 79 6f 75 20 61 72 " I see you ar
24f0: 65 20 74 68 65 20 6f 77 6e 65 72 20 6f 66 20 6d e the owner of m
2500: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 2c 20 egatest.config,
2510: 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 6c attempting to cl
2520: 65 61 6e 75 70 20 61 6e 64 20 72 65 73 65 74 20 eanup and reset
2530: 74 6f 20 6e 65 77 20 76 65 72 73 69 6f 6e 22 29 to new version")
2540: 0a 09 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 ... (handle-exc
2550: 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 65 78 6e eptions... exn
2560: 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 ... (begin...
2570: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2580: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2590: 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f port* "Failed to
25a0: 20 73 77 69 74 63 68 20 76 65 72 73 69 6f 6e 73 switch versions
25b0: 2e 22 29 0a 09 09 20 20 20 20 20 28 64 65 62 75 .")... (debu
25c0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
25d0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d lt-log-port* " m
25e0: 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 essage: " ((cond
25f0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
2600: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
2610: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 20 ssage) exn))...
2620: 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d (print-call-
2630: 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 chain (current-e
2640: 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 09 20 20 rror-port))...
2650: 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 09 20 (exit 1))...
2660: 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 (common:cleanu
2670: 70 2d 64 62 20 64 62 73 74 72 75 63 74 29 29 29 p-db dbstruct)))
2680: 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 ...(begin... (d
2690: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
26a0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
26b0: 22 20 74 6f 20 73 77 69 74 63 68 20 76 65 72 73 " to switch vers
26c0: 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 72 75 6e ions you can run
26d0: 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 2d 63 6c : \"megatest -cl
26e0: 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a 09 09 20 eanup-db\"")...
26f0: 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 20 (exit 1))))..
2700: 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 62 (begin.. (deb
2710: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
2720: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
2730: 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 6d 69 67 RROR: cannot mig
2740: 72 61 74 65 20 76 65 72 73 69 6f 6e 20 75 6e 6c rate version unl
2750: 65 73 73 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 2e ess on homehost.
2760: 20 45 78 69 74 69 6e 67 2e 22 29 0a 09 20 20 20 Exiting.")..
2770: 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 0a 3b (exit 1)))))..;
2780: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
2790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
27c0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 50 20 41 =======.;; S P A
27d0: 20 52 20 53 20 45 20 20 20 41 20 52 20 52 20 41 R S E A R R A
27e0: 20 59 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d Y S.;;=========
27f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
2830: 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 70 61 define (make-spa
2840: 72 73 65 2d 61 72 72 61 79 29 0a 20 20 28 6c 65 rse-array). (le
2850: 74 20 28 28 61 20 28 6d 61 6b 65 2d 73 70 61 72 t ((a (make-spar
2860: 73 65 2d 76 65 63 74 6f 72 29 29 29 0a 20 20 20 se-vector))).
2870: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d (sparse-vector-
2880: 73 65 74 21 20 61 20 30 20 28 6d 61 6b 65 2d 73 set! a 0 (make-s
2890: 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 0a 20 parse-vector)).
28a0: 20 20 20 61 29 29 0a 0a 28 64 65 66 69 6e 65 20 a))..(define
28b0: 28 73 70 61 72 73 65 2d 61 72 72 61 79 3f 20 61 (sparse-array? a
28c0: 29 0a 20 20 28 61 6e 64 20 28 73 70 61 72 73 65 ). (and (sparse
28d0: 2d 76 65 63 74 6f 72 3f 20 61 29 0a 20 20 20 20 -vector? a).
28e0: 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f (sparse-vecto
28f0: 72 3f 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f r? (sparse-vecto
2900: 72 2d 72 65 66 20 61 20 30 29 29 29 29 0a 0a 28 r-ref a 0))))..(
2910: 64 65 66 69 6e 65 20 28 73 70 61 72 73 65 2d 61 define (sparse-a
2920: 72 72 61 79 2d 72 65 66 20 61 20 78 20 79 29 0a rray-ref a x y).
2930: 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 70 (let ((row (sp
2940: 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 arse-vector-ref
2950: 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 72 a x))). (if r
2960: 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 74 ow..(sparse-vect
2970: 6f 72 2d 72 65 66 20 72 6f 77 20 79 29 0a 09 23 or-ref row y)..#
2980: 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 f)))..(define (s
2990: 70 61 72 73 65 2d 61 72 72 61 79 2d 73 65 74 21 parse-array-set!
29a0: 20 61 20 78 20 79 20 76 61 6c 29 0a 20 20 28 6c a x y val). (l
29b0: 65 74 20 28 28 72 6f 77 20 28 73 70 61 72 73 65 et ((row (sparse
29c0: 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 78 29 -vector-ref a x)
29d0: 29 29 0a 20 20 20 20 28 69 66 20 72 6f 77 0a 09 )). (if row..
29e0: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 (sparse-vector-s
29f0: 65 74 21 20 72 6f 77 20 79 20 76 61 6c 29 0a 09 et! row y val)..
2a00: 28 6c 65 74 20 28 28 6e 65 77 2d 72 6f 77 20 28 (let ((new-row (
2a10: 6d 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 make-sparse-vect
2a20: 6f 72 29 29 29 0a 09 20 20 28 73 70 61 72 73 65 or))).. (sparse
2a30: 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 61 20 78 -vector-set! a x
2a40: 20 6e 65 77 2d 72 6f 77 29 0a 09 20 20 28 73 70 new-row).. (sp
2a50: 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 arse-vector-set!
2a60: 20 6e 65 77 2d 72 6f 77 20 79 20 76 61 6c 29 29 new-row y val))
2a70: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
2a80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2a90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
2ac0: 20 4c 20 4f 20 43 20 4b 20 45 20 52 20 53 20 20 L O C K E R S
2ad0: 20 41 20 4e 20 44 20 20 20 42 20 4c 20 4f 20 43 A N D B L O C
2ae0: 20 4b 20 45 20 52 20 53 20 0a 3b 3b 3d 3d 3d 3d K E R S .;;====
2af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2b30: 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 6b 20 66 75 72 ==..;; block fur
2b40: 74 68 65 72 20 61 63 63 65 73 73 65 73 20 74 6f ther accesses to
2b50: 20 64 61 74 61 62 61 73 65 73 2e 20 43 61 6c 6c databases. Call
2b60: 20 74 68 69 73 20 62 65 66 6f 72 65 20 73 68 75 this before shu
2b70: 74 74 69 6e 67 20 64 62 20 64 6f 77 6e 0a 28 64 tting db down.(d
2b80: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 efine (common:db
2b90: 2d 62 6c 6f 63 6b 2d 66 75 72 74 68 65 72 2d 71 -block-further-q
2ba0: 75 65 72 69 65 73 29 0a 20 20 28 6d 75 74 65 78 ueries). (mutex
2bb0: 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 -lock! *db-acces
2bc0: 73 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 65 74 s-mutex*). (set
2bd0: 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c ! *db-access-all
2be0: 6f 77 65 64 2a 20 23 66 29 0a 20 20 28 6d 75 74 owed* #f). (mut
2bf0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 ex-unlock! *db-a
2c00: 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 29 0a 0a ccess-mutex*))..
2c10: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
2c20: 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 db-access-allowe
2c30: 64 3f 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c d?). (let ((val
2c40: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
2c50: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 (mutex-lock! *db
2c60: 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a -access-mutex*).
2c70: 09 20 20 20 20 20 20 20 2a 64 62 2d 61 63 63 65 . *db-acce
2c80: 73 73 2d 61 6c 6c 6f 77 65 64 2a 0a 09 20 20 20 ss-allowed*..
2c90: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
2ca0: 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 k! *db-access-mu
2cb0: 74 65 78 2a 29 29 29 29 0a 20 20 20 20 76 61 6c tex*)))). val
2cc0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
2cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
2d10: 55 20 53 20 45 20 46 20 55 20 4c 20 20 20 53 20 U S E F U L S
2d20: 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d T U F F.;;======
2d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d70: 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 74 68 69 ..;; convert thi
2d80: 6e 67 73 20 74 6f 20 61 6e 20 61 6c 69 73 74 20 ngs to an alist
2d90: 6f 72 20 61 73 73 6f 63 20 6c 69 73 74 2c 20 23 or assoc list, #
2da0: 66 20 67 65 74 73 20 63 6f 6e 76 65 72 74 65 64 f gets converted
2db0: 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 65 66 69 6e to "".;;.(defin
2dc0: 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 e (common:to-ali
2dd0: 73 74 20 64 61 74 29 0a 20 20 28 63 6f 6e 64 0a st dat). (cond.
2de0: 20 20 20 28 28 6c 69 73 74 3f 20 64 61 74 29 20 ((list? dat)
2df0: 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f (map common:to
2e00: 2d 61 6c 69 73 74 20 64 61 74 29 29 0a 20 20 20 -alist dat)).
2e10: 28 28 76 65 63 74 6f 72 3f 20 64 61 74 29 0a 20 ((vector? dat).
2e20: 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 (map common:t
2e30: 6f 2d 61 6c 69 73 74 20 28 76 65 63 74 6f 72 2d o-alist (vector-
2e40: 3e 6c 69 73 74 20 64 61 74 29 29 29 0a 20 20 20 >list dat))).
2e50: 28 28 70 61 69 72 3f 20 64 61 74 29 0a 20 20 20 ((pair? dat).
2e60: 20 28 63 6f 6e 73 20 28 63 6f 6d 6d 6f 6e 3a 74 (cons (common:t
2e70: 6f 2d 61 6c 69 73 74 20 28 63 61 72 20 64 61 74 o-alist (car dat
2e80: 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 74 6f )).. (common:to
2e90: 2d 61 6c 69 73 74 20 28 63 64 72 20 64 61 74 29 -alist (cdr dat)
2ea0: 29 29 29 0a 20 20 20 28 28 68 61 73 68 2d 74 61 ))). ((hash-ta
2eb0: 62 6c 65 3f 20 64 61 74 29 0a 20 20 20 20 28 6d ble? dat). (m
2ec0: 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 ap common:to-ali
2ed0: 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e st (hash-table->
2ee0: 61 6c 69 73 74 20 64 61 74 29 29 29 0a 20 20 20 alist dat))).
2ef0: 28 65 6c 73 65 0a 20 20 20 20 28 69 66 20 64 61 (else. (if da
2f00: 74 0a 09 64 61 74 0a 09 22 22 29 29 29 29 0a 0a t..dat..""))))..
2f10: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
2f20: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
2f30: 77 61 69 74 76 61 6c 20 2e 20 6b 65 79 73 29 0a waitval . keys).
2f40: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 (let* ((key
2f50: 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 (string-inter
2f60: 73 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 sperse (map conc
2f70: 20 6b 65 79 73 29 20 22 2d 22 20 29 29 0a 09 20 keys) "-" ))..
2f80: 28 6c 61 73 74 74 69 6d 65 20 28 68 61 73 68 2d (lasttime (hash-
2f90: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
2fa0: 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 t *common:denois
2fb0: 65 2a 20 6b 65 79 20 30 29 29 0a 09 20 28 63 75 e* key 0)).. (cu
2fc0: 72 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d rrtime (current-
2fd0: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 seconds))). (
2fe0: 69 66 20 28 3e 20 28 2d 20 63 75 72 72 74 69 6d if (> (- currtim
2ff0: 65 20 6c 61 73 74 74 69 6d 65 29 20 77 61 69 74 e lasttime) wait
3000: 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 val)..(begin..
3010: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
3020: 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 *common:denoise
3030: 2a 20 6b 65 79 20 63 75 72 72 74 69 6d 65 29 0a * key currtime).
3040: 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 . #t)..#f)))..(
3050: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
3060: 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 et-megatest-exe)
3070: 0a 20 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 . (or (getenv "
3080: 4d 54 5f 4d 45 47 41 54 45 53 54 22 29 20 22 6d MT_MEGATEST") "m
3090: 65 67 61 74 65 73 74 22 29 29 0a 0a 28 64 65 66 egatest"))..(def
30a0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 ine (common:read
30b0: 2d 65 6e 63 6f 64 65 64 2d 73 74 72 69 6e 67 20 -encoded-string
30c0: 69 6e 73 74 72 29 0a 20 20 28 68 61 6e 64 6c 65 instr). (handle
30d0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 -exceptions. e
30e0: 78 6e 0a 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 xn. (handle-ex
30f0: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 65 78 6e ceptions. exn
3100: 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 . (begin.
3110: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
3120: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
3130: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 65 69 log-port* "recei
3140: 76 65 64 20 62 61 64 20 65 6e 63 6f 64 65 64 20 ved bad encoded
3150: 73 74 72 69 6e 67 20 5c 22 22 20 69 6e 73 74 72 string \"" instr
3160: 20 22 5c 22 2c 20 6d 65 73 73 61 67 65 3a 20 22 "\", message: "
3170: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
3180: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
3190: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
31a0: 6e 29 29 0a 20 20 20 20 20 20 28 70 72 69 6e 74 n)). (print
31b0: 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 -call-chain (cur
31c0: 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 rent-error-port)
31d0: 29 0a 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 ). #f).
31e0: 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 (read (open-inpu
31f0: 74 2d 73 74 72 69 6e 67 20 28 62 61 73 65 36 34 t-string (base64
3200: 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 :base64-decode i
3210: 6e 73 74 72 29 29 29 29 0a 20 20 20 28 72 65 61 nstr)))). (rea
3220: 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 d (open-input-st
3230: 72 69 6e 67 20 28 7a 33 3a 64 65 63 6f 64 65 2d ring (z3:decode-
3240: 62 75 66 66 65 72 20 28 62 61 73 65 36 34 3a 62 buffer (base64:b
3250: 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 6e 73 ase64-decode ins
3260: 74 72 29 29 29 29 29 29 0a 0a 3b 3b 20 64 6f 74 tr))))))..;; dot
3270: 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 20 73 65 65 -locking egg see
3280: 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c 20 ms not to work,
3290: 75 73 69 6e 67 20 74 68 69 73 20 66 6f 72 20 6e using this for n
32a0: 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 73 ow.;; if lock is
32b0: 20 6f 6c 64 65 72 20 74 68 61 6e 20 65 78 70 69 older than expi
32c0: 72 65 2d 74 69 6d 65 20 74 68 65 6e 20 72 65 6d re-time then rem
32d0: 6f 76 65 20 69 74 20 61 6e 64 20 74 72 79 20 61 ove it and try a
32e0: 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 74 gain.;; to get t
32f0: 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 he lock.;;.(defi
3300: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c ne (common:simpl
3310: 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d e-file-lock fnam
3320: 65 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d e #!key (expire-
3330: 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 69 66 time 300)). (if
3340: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 (file-exists? f
3350: 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 69 66 20 name). (if
3360: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
3370: 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f 64 econds)(file-mod
3380: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
3390: 6e 61 6d 65 29 29 20 65 78 70 69 72 65 2d 74 69 name)) expire-ti
33a0: 6d 65 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 me).. (begin..
33b0: 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a (delete-file*
33c0: 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 28 63 6f fname).. (co
33d0: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
33e0: 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 -lock fname expi
33f0: 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d re-time: expire-
3400: 74 69 6d 65 29 29 0a 09 20 20 23 66 29 0a 20 20 time)).. #f).
3410: 20 20 20 20 28 6c 65 74 20 28 28 6b 65 79 2d 73 (let ((key-s
3420: 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 67 65 74 tring (conc (get
3430: 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d 22 20 -host-name) "-"
3440: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
3450: 2d 69 64 29 29 29 29 0a 09 28 77 69 74 68 2d 6f -id))))..(with-o
3460: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 6e utput-to-file fn
3470: 61 6d 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 ame.. (lambda (
3480: 29 0a 09 20 20 20 20 28 70 72 69 6e 74 20 6b 65 ).. (print ke
3490: 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 28 74 68 y-string)))..(th
34a0: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 read-sleep! 0.25
34b0: 29 0a 09 28 69 66 20 28 66 69 6c 65 2d 65 78 69 )..(if (file-exi
34c0: 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 20 20 20 sts? fname)..
34d0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
34e0: 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 m-file fname..
34f0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
3500: 09 28 65 71 75 61 6c 3f 20 6b 65 79 2d 73 74 72 .(equal? key-str
3510: 69 6e 67 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 ing (read-line))
3520: 29 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a 09 )).. #f))))..
3530: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
3540: 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c :simple-file-rel
3550: 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 29 ease-lock fname)
3560: 0a 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a . (delete-file*
3570: 20 66 6e 61 6d 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d fname))..;;====
3580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
35c0: 3d 3d 0a 3b 3b 20 53 20 54 20 41 20 54 20 45 20 ==.;; S T A T E
35d0: 53 20 20 20 41 20 4e 20 44 20 20 20 53 20 54 20 S A N D S T
35e0: 41 20 54 20 55 20 53 20 45 20 53 0a 3b 3b 3d 3d A T U S E S.;;==
35f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3630: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 63 ====..(define *c
3640: 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 65 73 ommon:std-states
3650: 2a 20 20 20 0a 20 20 27 28 28 30 20 22 41 52 43 * . '((0 "ARC
3660: 48 49 56 45 44 22 29 0a 20 20 20 20 28 31 20 22 HIVED"). (1 "
3670: 53 54 55 43 4b 22 29 0a 20 20 20 20 28 32 20 22 STUCK"). (2 "
3680: 4b 49 4c 4c 52 45 51 22 29 0a 20 20 20 20 28 33 KILLREQ"). (3
3690: 20 22 4b 49 4c 4c 45 44 22 29 0a 20 20 20 20 28 "KILLED"). (
36a0: 34 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 4 "NOT_STARTED")
36b0: 0a 20 20 20 20 28 35 20 22 43 4f 4d 50 4c 45 54 . (5 "COMPLET
36c0: 45 44 22 29 0a 20 20 20 20 28 36 20 22 4c 41 55 ED"). (6 "LAU
36d0: 4e 43 48 45 44 22 29 0a 20 20 20 20 28 37 20 22 NCHED"). (7 "
36e0: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 REMOTEHOSTSTART"
36f0: 29 0a 20 20 20 20 28 38 20 22 52 55 4e 4e 49 4e ). (8 "RUNNIN
3700: 47 22 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 G"). ))..(def
3710: 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d ine *common:std-
3720: 73 74 61 74 75 73 65 73 2a 0a 20 20 27 28 3b 3b statuses*. '(;;
3730: 20 28 30 20 22 44 45 4c 45 54 45 44 22 29 0a 20 (0 "DELETED").
3740: 20 20 20 28 31 20 22 6e 2f 61 22 29 0a 20 20 20 (1 "n/a").
3750: 20 28 32 20 22 50 41 53 53 22 29 0a 20 20 20 20 (2 "PASS").
3760: 28 33 20 22 43 48 45 43 4b 22 29 0a 20 20 20 20 (3 "CHECK").
3770: 28 34 20 22 53 4b 49 50 22 29 0a 20 20 20 20 28 (4 "SKIP"). (
3780: 35 20 22 57 41 52 4e 22 29 0a 20 20 20 20 28 36 5 "WARN"). (6
3790: 20 22 57 41 49 56 45 44 22 29 0a 20 20 20 20 28 "WAIVED"). (
37a0: 37 20 22 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 7 "STUCK/DEAD").
37b0: 20 20 20 20 28 38 20 22 46 41 49 4c 22 29 0a 20 (8 "FAIL").
37c0: 20 20 20 28 39 20 22 41 42 4f 52 54 22 29 29 29 (9 "ABORT")))
37d0: 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f ..(define *commo
37e0: 6e 3a 65 6e 64 65 64 2d 73 74 61 74 65 73 2a 20 n:ended-states*
37f0: 3b 3b 20 73 74 61 74 65 73 20 77 68 69 63 68 20 ;; states which
3800: 69 6e 64 69 63 61 74 65 20 74 68 65 20 74 65 73 indicate the tes
3810: 74 20 69 73 20 73 74 6f 70 70 65 64 20 61 6e 64 t is stopped and
3820: 20 77 69 6c 6c 20 6e 6f 74 20 70 72 6f 63 65 65 will not procee
3830: 64 0a 20 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 d. '("COMPLETED
3840: 22 20 22 41 52 43 48 49 56 45 44 22 20 22 4b 49 " "ARCHIVED" "KI
3850: 4c 4c 45 44 22 20 22 4b 49 4c 4c 52 45 51 22 20 LLED" "KILLREQ"
3860: 22 53 54 55 43 4b 22 20 22 49 4e 43 4f 4d 50 4c "STUCK" "INCOMPL
3870: 45 54 45 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 ETE"))..(define
3880: 2a 63 6f 6d 6d 6f 6e 3a 62 61 64 6c 79 2d 65 6e *common:badly-en
3890: 64 65 64 2d 73 74 61 74 65 73 2a 20 3b 3b 20 74 ded-states* ;; t
38a0: 68 65 73 65 20 72 6f 6c 6c 20 75 70 20 61 73 20 hese roll up as
38b0: 43 48 45 43 4b 2c 20 69 2e 65 2e 20 72 65 73 75 CHECK, i.e. resu
38c0: 6c 74 73 20 6e 65 65 64 20 74 6f 20 62 65 20 63 lts need to be c
38d0: 68 65 63 6b 65 64 0a 20 20 27 28 22 4b 49 4c 4c hecked. '("KILL
38e0: 45 44 22 20 22 4b 49 4c 4c 52 45 51 22 20 22 53 ED" "KILLREQ" "S
38f0: 54 55 43 4b 22 20 22 49 4e 43 4f 4d 50 4c 45 54 TUCK" "INCOMPLET
3900: 45 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 E"))..(define (c
3910: 6f 6d 6d 6f 6e 3a 73 70 65 63 69 61 6c 2d 73 6f ommon:special-so
3920: 72 74 20 69 74 65 6d 73 20 6f 72 64 65 72 20 63 rt items order c
3930: 6f 6d 70 29 0a 20 20 28 6c 65 74 20 28 28 69 74 omp). (let ((it
3940: 65 6d 73 2d 6f 72 64 65 72 20 28 6d 61 70 20 72 ems-order (map r
3950: 65 76 65 72 73 65 20 6f 72 64 65 72 29 29 0a 20 everse order)).
3960: 20 20 20 20 20 20 20 28 61 63 6f 6d 70 20 20 20 (acomp
3970: 20 20 20 20 28 6f 72 20 63 6f 6d 70 20 3e 29 29 (or comp >))
3980: 29 0a 20 20 20 20 28 73 6f 72 74 20 69 74 65 6d ). (sort item
3990: 73 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 s. (lambd
39a0: 61 20 28 61 20 62 29 0a 20 20 20 20 20 20 20 20 a (a b).
39b0: 20 20 28 6c 65 74 20 28 28 61 2d 6e 75 6d 20 28 (let ((a-num (
39c0: 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f 63 20 cadr (or (assoc
39d0: 61 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 20 27 a items-order) '
39e0: 28 30 20 30 29 29 29 29 0a 20 20 20 20 20 20 20 (0 0)))).
39f0: 20 20 20 20 20 20 20 20 20 28 62 2d 6e 75 6d 20 (b-num
3a00: 28 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f 63 (cadr (or (assoc
3a10: 20 62 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 20 b items-order)
3a20: 27 28 30 20 30 29 29 29 29 29 0a 20 20 20 20 20 '(0 0))))).
3a30: 20 20 20 20 20 20 20 28 61 63 6f 6d 70 20 61 2d (acomp a-
3a40: 6e 75 6d 20 62 2d 6e 75 6d 29 29 29 29 29 29 0a num b-num)))))).
3a50: 0a 3b 3b 20 54 68 65 73 65 20 61 72 65 20 73 74 .;; These are st
3a60: 6f 70 70 69 6e 67 20 63 6f 6e 64 69 74 69 6f 6e opping condition
3a70: 73 20 74 68 61 74 20 70 72 65 76 65 6e 74 20 61 s that prevent a
3a80: 20 74 65 73 74 20 66 72 6f 6d 20 62 65 69 6e 67 test from being
3a90: 20 72 75 6e 0a 28 64 65 66 69 6e 65 20 2a 63 6f run.(define *co
3aa0: 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 mmon:cant-run-st
3ab0: 61 74 65 73 2d 73 79 6d 2a 20 0a 20 20 27 28 43 ates-sym* . '(C
3ac0: 4f 4d 50 4c 45 54 45 44 20 4b 49 4c 4c 45 44 20 OMPLETED KILLED
3ad0: 57 41 49 56 45 44 20 55 4e 4b 4e 4f 57 4e 20 49 WAIVED UNKNOWN I
3ae0: 4e 43 4f 4d 50 4c 45 54 45 20 41 42 4f 52 54 20 NCOMPLETE ABORT
3af0: 41 52 43 48 49 56 45 44 29 29 0a 0a 3b 3b 20 67 ARCHIVED))..;; g
3b00: 69 76 65 6e 20 61 20 74 6f 70 6c 65 76 65 6c 20 iven a toplevel
3b10: 77 69 74 68 20 63 75 72 72 73 74 61 74 65 2c 20 with currstate,
3b20: 63 75 72 72 73 74 61 74 75 73 20 61 70 70 6c 79 currstatus apply
3b30: 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 75 state and statu
3b40: 73 0a 3b 3b 20 20 3d 3e 20 28 6e 65 77 73 74 61 s.;; => (newsta
3b50: 74 65 20 2e 20 6e 65 77 73 74 61 74 75 73 29 0a te . newstatus).
3b60: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
3b70: 61 70 70 6c 79 2d 73 74 61 74 65 2d 73 74 61 74 apply-state-stat
3b80: 75 73 20 63 75 72 72 73 74 61 74 65 20 63 75 72 us currstate cur
3b90: 72 73 74 61 74 75 73 20 73 74 61 74 65 20 73 74 rstatus state st
3ba0: 61 74 75 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 atus). (let* ((
3bb0: 63 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d cstate (string-
3bc0: 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d >symbol (string-
3bd0: 64 6f 77 6e 63 61 73 65 20 63 75 72 72 73 74 61 downcase currsta
3be0: 74 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 te))). (
3bf0: 63 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d cstatus (string-
3c00: 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d >symbol (string-
3c10: 64 6f 77 6e 63 61 73 65 20 63 75 72 72 73 74 61 downcase currsta
3c20: 74 75 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 tus))).
3c30: 28 73 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 (sstate (string
3c40: 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 ->symbol (string
3c50: 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 65 29 -downcase state)
3c60: 29 29 0a 20 20 20 20 20 20 20 20 20 28 73 73 74 )). (sst
3c70: 61 74 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 79 atus (string->sy
3c80: 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 mbol (string-dow
3c90: 6e 63 61 73 65 20 73 74 61 74 75 73 29 29 29 0a ncase status))).
3ca0: 20 20 20 20 20 20 20 20 20 28 6e 73 74 61 74 65 (nstate
3cb0: 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 28 #f). (
3cc0: 6e 73 74 61 74 75 73 20 23 66 29 29 0a 20 20 20 nstatus #f)).
3cd0: 20 28 73 65 74 21 20 6e 73 74 61 74 65 0a 20 20 (set! nstate.
3ce0: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 63 73 (case cs
3cf0: 74 61 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 tate.
3d00: 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6e 6f 74 ((completed not
3d10: 5f 73 74 61 72 74 65 64 20 6b 69 6c 6c 65 64 20 _started killed
3d20: 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 72 killreq stuck ar
3d30: 63 68 69 76 65 64 29 20 0a 20 20 20 20 20 20 20 chived) .
3d40: 20 20 20 20 20 20 28 63 61 73 65 20 73 73 74 61 (case ssta
3d50: 74 65 20 3b 3b 20 63 6f 6d 70 6c 65 74 65 64 20 te ;; completed
3d60: 2d 3e 20 73 73 74 61 74 65 0a 20 20 20 20 20 20 -> sstate.
3d70: 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c ((compl
3d80: 65 74 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c eted killed kill
3d90: 72 65 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 req stuck archiv
3da0: 65 64 29 20 63 6f 6d 70 6c 65 74 65 64 29 0a 20 ed) completed).
3db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
3dc0: 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f running remoteho
3dd0: 73 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 ststart launched
3de0: 29 20 20 20 20 20 20 20 20 72 75 6e 6e 69 6e 67 ) running
3df0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3e00: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 (else
3e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3e20: 20 20 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e unkn
3e30: 6f 77 6e 2d 65 72 72 6f 72 2d 31 29 29 29 0a 20 own-error-1))).
3e40: 20 20 20 20 20 20 20 20 20 20 20 28 28 72 75 6e ((run
3e50: 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 ning remotehosts
3e60: 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 0a 20 tart launched).
3e70: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 (cas
3e80: 65 20 73 73 74 61 74 65 0a 20 20 20 20 20 20 20 e sstate.
3e90: 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c 65 ((comple
3ea0: 74 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 ted killed killr
3eb0: 65 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 65 eq stuck archive
3ec0: 64 29 20 23 66 29 20 3b 3b 20 6e 65 65 64 20 74 d) #f) ;; need t
3ed0: 6f 20 6c 6f 6f 6b 20 61 74 20 61 6c 6c 20 69 74 o look at all it
3ee0: 65 6d 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 ems.
3ef0: 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 65 6d ((running rem
3f00: 6f 74 65 68 6f 73 74 73 74 61 72 74 20 6c 61 75 otehoststart lau
3f10: 6e 63 68 65 64 29 20 20 20 20 20 20 20 20 72 75 nched) ru
3f20: 6e 6e 69 6e 67 29 0a 20 20 20 20 20 20 20 20 20 nning).
3f30: 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 (else
3f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3f60: 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 32 unknown-error-2
3f70: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
3f80: 28 65 6c 73 65 20 75 6e 6b 6e 6f 77 6e 2d 65 72 (else unknown-er
3f90: 72 6f 72 2d 33 29 29 29 0a 20 20 20 20 28 73 65 ror-3))). (se
3fa0: 74 21 20 6e 73 74 61 74 75 73 0a 20 20 20 20 20 t! nstatus.
3fb0: 20 20 20 20 20 28 63 61 73 65 20 73 73 74 61 74 (case sstat
3fc0: 75 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 us. (
3fd0: 28 70 61 73 73 29 0a 20 20 20 20 20 20 20 20 20 (pass).
3fe0: 20 20 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 (case nstate
3ff0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
4000: 28 28 70 61 73 73 20 6e 2f 61 20 64 65 6c 65 74 ((pass n/a delet
4010: 65 64 29 20 20 20 20 20 70 61 73 73 29 0a 20 20 ed) pass).
4020: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 77 ((w
4030: 61 72 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 arn)
4040: 20 20 20 20 20 77 61 72 6e 29 0a 20 20 20 20 20 warn).
4050: 20 20 20 20 20 20 20 20 20 20 28 28 66 61 69 6c ((fail
4060: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
4070: 20 20 66 61 69 6c 29 0a 20 20 20 20 20 20 20 20 fail).
4080: 20 20 20 20 20 20 20 28 28 63 68 65 63 6b 29 20 ((check)
4090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 68 ch
40a0: 65 63 6b 29 0a 20 20 20 20 20 20 20 20 20 20 20 eck).
40b0: 20 20 20 20 28 28 77 61 69 76 65 64 29 20 20 20 ((waived)
40c0: 20 20 20 20 20 20 20 20 20 20 77 61 69 76 65 64 waived
40d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
40e0: 20 28 28 73 6b 69 70 29 20 20 20 20 20 20 20 20 ((skip)
40f0: 20 20 20 20 20 20 20 20 20 73 6b 69 70 29 0a 20 skip).
4100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
4110: 73 74 75 63 6b 2f 64 65 61 64 29 20 20 20 20 20 stuck/dead)
4120: 20 20 20 20 20 73 74 75 63 6b 29 0a 20 20 20 20 stuck).
4130: 20 20 20 20 20 20 20 20 20 20 20 28 28 61 62 6f ((abo
4140: 72 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 rt)
4150: 20 20 61 62 6f 72 74 29 0a 20 20 20 20 20 20 20 abort).
4160: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 (else
4170: 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 unknown-err
4180: 6f 72 2d 34 29 29 29 0a 20 20 20 20 20 20 20 20 or-4))).
4190: 20 20 20 20 28 28 77 61 72 6e 29 0a 20 20 20 20 ((warn).
41a0: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 6e (case n
41b0: 73 74 61 74 65 0a 20 20 20 20 20 20 20 20 20 20 state.
41c0: 20 20 20 20 20 28 28 70 61 73 73 20 77 61 72 6e ((pass warn
41d0: 20 6e 2f 61 20 73 6b 69 70 20 64 65 6c 65 74 65 n/a skip delete
41e0: 64 29 20 20 20 77 61 72 6e 29 0a 20 20 20 20 20 d) warn).
41f0: 20 20 20 20 20 20 20 20 20 20 28 28 66 61 69 6c ((fail
4200: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
4210: 20 20 20 20 20 20 20 20 20 20 66 61 69 6c 29 0a fail).
4220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4230: 28 63 68 65 63 6b 29 20 20 20 20 20 20 20 20 20 (check)
4240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 68 ch
4250: 65 63 6b 29 0a 20 20 20 20 20 20 20 20 20 20 20 eck).
4260: 20 20 20 20 28 28 77 61 69 76 65 64 29 20 20 20 ((waived)
4270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4280: 20 20 77 61 69 76 65 64 29 0a 20 20 20 20 20 20 waived).
4290: 20 20 20 20 20 20 20 20 20 28 28 73 74 75 63 6b ((stuck
42a0: 2f 64 65 61 64 29 20 20 20 20 20 20 20 20 20 20 /dead)
42b0: 20 20 20 20 20 20 20 20 73 74 75 63 6b 29 0a 20 stuck).
42c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
42d0: 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 lse
42e0: 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 unknown-error
42f0: 2d 35 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 -5))).
4300: 20 20 28 28 66 61 69 6c 29 0a 20 20 20 20 20 20 ((fail).
4310: 20 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 74 (case nst
4320: 61 74 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ate.
4330: 20 20 20 28 28 70 61 73 73 20 77 61 72 6e 20 66 ((pass warn f
4340: 61 69 6c 20 63 68 65 63 6b 20 6e 2f 61 20 77 61 ail check n/a wa
4350: 69 76 65 64 20 73 6b 69 70 20 64 65 6c 65 74 65 ived skip delete
4360: 64 20 73 74 75 63 6b 2f 64 65 61 64 20 73 74 75 d stuck/dead stu
4370: 63 6b 29 20 20 66 61 69 6c 29 0a 20 20 20 20 20 ck) fail).
4380: 20 20 20 20 20 20 20 20 20 20 28 28 61 62 6f 72 ((abor
4390: 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t)
43a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43c0: 20 20 20 20 20 20 20 20 20 20 20 61 62 6f 72 74 abort
43d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
43e0: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 (else
43f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4410: 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d unknown-
4420: 65 72 72 6f 72 2d 36 29 29 29 0a 20 20 20 20 20 error-6))).
4430: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
4440: 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 37 29 unknown-error-7)
4450: 29 29 0a 20 20 20 20 28 63 6f 6e 73 20 0a 20 20 )). (cons .
4460: 20 20 20 28 69 66 20 6e 73 74 61 74 65 20 20 28 (if nstate (
4470: 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e symbol->string n
4480: 73 74 61 74 65 29 20 20 6e 73 74 61 74 65 29 0a state) nstate).
4490: 20 20 20 20 20 28 69 66 20 6e 73 74 61 74 75 73 (if nstatus
44a0: 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 (symbol->string
44b0: 20 6e 73 74 61 74 75 73 29 20 6e 73 74 61 74 75 nstatus) nstatu
44c0: 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 s)))).
44d0: 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d .;;========
44e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
44f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
4520: 3b 20 44 20 45 20 42 20 55 20 47 20 47 20 49 20 ; D E B U G G I
4530: 4e 20 47 20 20 20 53 20 54 20 55 20 46 20 46 20 N G S T U F F
4540: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
4550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4580: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
4590: 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 20 ne *verbosity*
45a0: 20 20 20 20 20 20 20 31 29 0a 28 64 65 66 69 6e 1).(defin
45b0: 65 20 2a 6c 6f 67 67 69 6e 67 2a 20 20 20 20 20 e *logging*
45c0: 20 20 20 20 20 20 23 66 29 0a 0a 28 64 65 66 69 #f)..(defi
45d0: 6e 65 20 28 67 65 74 2d 77 69 74 68 2d 64 65 66 ne (get-with-def
45e0: 61 75 6c 74 20 76 61 6c 20 64 65 66 61 75 6c 74 ault val default
45f0: 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 ). (let ((val (
4600: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 76 61 6c args:get-arg val
4610: 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c 20 ))). (if val
4620: 76 61 6c 20 64 65 66 61 75 6c 74 29 29 29 0a 0a val default)))..
4630: 28 64 65 66 69 6e 65 20 28 61 73 73 6f 63 2f 64 (define (assoc/d
4640: 65 66 61 75 6c 74 20 6b 65 79 20 6c 73 74 20 2e efault key lst .
4650: 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 default). (let
4660: 20 28 28 72 65 73 20 28 61 73 73 6f 63 20 6b 65 ((res (assoc ke
4670: 79 20 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 y lst))). (if
4680: 20 72 65 73 20 28 63 61 64 72 20 72 65 73 29 28 res (cadr res)(
4690: 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 75 6c if (null? defaul
46a0: 74 29 20 23 66 20 28 63 61 72 20 64 65 66 61 75 t) #f (car defau
46b0: 6c 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 lt)))))..(define
46c0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 (common:get-tes
46d0: 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a 20 20 28 tsuite-name). (
46e0: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
46f0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
4700: 73 65 74 75 70 22 20 22 74 65 73 74 73 75 69 74 setup" "testsuit
4710: 65 22 20 29 0a 20 20 20 20 20 20 28 69 66 20 2a e" ). (if *
4720: 74 6f 70 70 61 74 68 2a 20 0a 20 20 20 20 20 20 toppath* .
4730: 20 20 20 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 (pathname-fi
4740: 6c 65 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 le *toppath*).
4750: 20 20 20 20 20 20 20 20 28 70 61 74 68 6e 61 6d (pathnam
4760: 65 2d 66 69 6c 65 20 28 63 75 72 72 65 6e 74 2d e-file (current-
4770: 64 69 72 65 63 74 6f 72 79 29 29 29 29 29 0a 0a directory)))))..
4780: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
4790: 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 get-db-tmp-area)
47a0: 0a 20 20 28 69 66 20 2a 64 62 2d 63 61 63 68 65 . (if *db-cache
47b0: 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 2a 64 62 -path*. *db
47c0: 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 20 20 -cache-path*.
47d0: 20 20 20 28 6c 65 74 20 28 28 64 62 70 61 74 68 (let ((dbpath
47e0: 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f (create-directo
47f0: 72 79 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 ry (conc "/tmp/"
4800: 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e (current-user-n
4810: 61 6d 65 29 0a 09 09 09 09 09 20 20 20 20 22 2f ame)...... "/
4820: 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c 64 62 megatest_localdb
4830: 2f 22 0a 09 09 09 09 09 20 20 20 20 28 63 6f 6d /"...... (com
4840: 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 mon:get-testsuit
4850: 65 2d 6e 61 6d 65 29 20 22 2f 22 0a 09 09 09 09 e-name) "/".....
4860: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 74 72 61 . (string-tra
4870: 6e 73 6c 61 74 65 20 2a 74 6f 70 70 61 74 68 2a nslate *toppath*
4880: 20 22 2f 22 20 22 2e 22 29 29 20 23 74 29 29 29 "/" ".")) #t)))
4890: 0a 09 28 73 65 74 21 20 2a 64 62 2d 63 61 63 68 ..(set! *db-cach
48a0: 65 2d 70 61 74 68 2a 20 64 62 70 61 74 68 29 0a e-path* dbpath).
48b0: 09 64 62 70 61 74 68 29 29 29 0a 0a 28 64 65 66 .dbpath)))..(def
48c0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
48d0: 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e 61 74 area-path-signat
48e0: 75 72 65 29 0a 20 20 28 6d 65 73 73 61 67 65 2d ure). (message-
48f0: 64 69 67 65 73 74 2d 73 74 72 69 6e 67 20 28 6d digest-string (m
4900: 64 35 2d 70 72 69 6d 69 74 69 76 65 29 20 2a 74 d5-primitive) *t
4910: 6f 70 70 61 74 68 2a 29 29 0a 0a 3b 3b 3d 3d 3d oppath*))..;;===
4920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4960: 3d 3d 3d 0a 3b 3b 20 45 20 58 20 49 20 54 20 20 ===.;; E X I T
4970: 20 48 20 41 20 4e 20 44 20 4c 20 49 20 4e 20 47 H A N D L I N G
4980: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
4990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
49d0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 ne (common:run-s
49e0: 79 6e 63 3f 29 0a 20 20 28 61 6e 64 20 28 63 6f ync?). (and (co
49f0: 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 mmon:on-homehost
4a00: 3f 29 0a 20 20 20 20 20 20 20 28 61 72 67 73 3a ?). (args:
4a10: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
4a20: 22 29 29 29 0a 0a 3b 3b 3b 3b 20 72 75 6e 2d 69 ")))..;;;; run-i
4a30: 64 73 0a 3b 3b 20 20 20 20 69 66 20 23 66 20 75 ds.;; if #f u
4a40: 73 65 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 79 6e se *db-local-syn
4a50: 63 2a 20 3a 20 6f 72 20 27 6c 6f 63 61 6c 2d 73 c* : or 'local-s
4a60: 79 6e 63 2d 66 6c 61 67 73 0a 3b 3b 20 20 20 20 ync-flags.;;
4a70: 69 66 20 23 74 20 75 73 65 20 74 69 6d 65 73 74 if #t use timest
4a80: 61 6d 70 73 20 20 20 20 20 20 3a 20 6f 72 20 27 amps : or '
4a90: 74 69 6d 65 73 74 61 6d 70 73 0a 28 64 65 66 69 timestamps.(defi
4aa0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d ne (common:sync-
4ab0: 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 62 20 64 to-megatest.db d
4ac0: 62 73 74 72 75 63 74 29 20 0a 20 20 28 6c 65 74 bstruct) . (let
4ad0: 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 20 20 ((start-time
4ae0: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 (current-s
4af0: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 64 econds))). (d
4b00: 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 b:multi-db-sync
4b10: 64 62 73 74 72 75 63 74 20 27 6e 65 77 32 6f 6c dbstruct 'new2ol
4b20: 64 29 0a 20 20 20 20 28 6c 65 74 20 28 28 73 79 d). (let ((sy
4b30: 6e 63 2d 74 69 6d 65 20 28 2d 20 28 63 75 72 72 nc-time (- (curr
4b40: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 ent-seconds) sta
4b50: 72 74 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 20 rt-time))).
4b60: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
4b70: 66 6f 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 3 *default-lo
4b80: 67 2d 70 6f 72 74 2a 20 22 53 79 6e 63 20 6f 66 g-port* "Sync of
4b90: 20 6e 65 77 64 62 20 74 6f 20 6f 6c 64 64 62 20 newdb to olddb
4ba0: 63 6f 6d 70 6c 65 74 65 64 20 69 6e 20 22 20 73 completed in " s
4bb0: 79 6e 63 2d 74 69 6d 65 20 22 20 73 65 63 6f 6e ync-time " secon
4bc0: 64 73 22 29 0a 20 20 20 20 20 20 28 69 66 20 28 ds"). (if (
4bd0: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
4be0: 2d 70 72 69 6e 74 20 33 30 20 22 73 79 6e 63 20 -print 30 "sync
4bf0: 6e 65 77 20 74 6f 20 6f 6c 64 22 29 0a 09 20 20 new to old")..
4c00: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
4c10: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
4c20: 2d 70 6f 72 74 2a 20 22 53 79 6e 63 20 6f 66 20 -port* "Sync of
4c30: 6e 65 77 64 62 20 74 6f 20 6f 6c 64 64 62 20 63 newdb to olddb c
4c40: 6f 6d 70 6c 65 74 65 64 20 69 6e 20 22 20 73 79 ompleted in " sy
4c50: 6e 63 2d 74 69 6d 65 20 22 20 73 65 63 6f 6e 64 nc-time " second
4c60: 73 22 29 29 29 29 29 0a 0a 3b 3b 20 63 75 72 72 s")))))..;; curr
4c70: 65 6e 74 6c 79 20 74 68 65 20 70 72 69 6d 61 72 ently the primar
4c80: 79 20 6a 6f 62 20 6f 66 20 74 68 65 20 77 61 74 y job of the wat
4c90: 63 68 64 6f 67 20 69 73 20 74 6f 20 72 75 6e 20 chdog is to run
4ca0: 74 68 65 20 73 79 6e 63 20 62 61 63 6b 20 74 6f the sync back to
4cb0: 20 6d 65 67 61 74 65 73 74 2e 64 62 20 66 72 6f megatest.db fro
4cc0: 6d 20 74 68 65 20 64 62 20 69 6e 20 2f 74 6d 70 m the db in /tmp
4cd0: 0a 3b 3b 20 69 66 20 77 65 20 61 72 65 20 6f 6e .;; if we are on
4ce0: 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 61 6e the homehost an
4cf0: 64 20 77 65 20 61 72 65 20 61 20 73 65 72 76 65 d we are a serve
4d00: 72 20 28 62 79 20 64 65 66 69 6e 69 74 69 6f 6e r (by definition
4d10: 20 77 65 20 61 72 65 20 6f 6e 20 74 68 65 20 68 we are on the h
4d20: 6f 6d 65 68 6f 73 74 20 69 66 20 77 65 20 61 72 omehost if we ar
4d30: 65 20 61 20 73 65 72 76 65 72 29 0a 3b 3b 0a 28 e a server).;;.(
4d40: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
4d50: 61 74 63 68 64 6f 67 29 0a 20 20 28 74 68 72 65 atchdog). (thre
4d60: 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 20 ad-sleep! 0.05)
4d70: 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 73 74 61 ;; delay for sta
4d80: 72 74 75 70 0a 20 20 28 6c 65 74 20 28 28 6c 65 rtup. (let ((le
4d90: 67 61 63 79 2d 73 79 6e 63 20 28 63 6f 6d 6d 6f gacy-sync (commo
4da0: 6e 3a 72 75 6e 2d 73 79 6e 63 3f 29 29 0a 09 28 n:run-sync?))..(
4db0: 64 65 62 75 67 2d 6d 6f 64 65 20 20 28 64 65 62 debug-mode (deb
4dc0: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 ug:debug-mode 1)
4dd0: 29 0a 09 28 6c 61 73 74 2d 74 69 6d 65 20 20 20 )..(last-time
4de0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
4df0: 29 29 29 0a 20 20 20 20 28 69 66 20 6c 65 67 61 ))). (if lega
4e00: 63 79 2d 73 79 6e 63 0a 09 28 6c 65 74 20 28 28 cy-sync..(let ((
4e10: 64 62 73 74 72 75 63 74 20 28 64 62 3a 73 65 74 dbstruct (db:set
4e20: 75 70 29 29 29 0a 09 20 20 28 6c 65 74 20 6c 6f up))).. (let lo
4e30: 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b 20 73 79 op ().. ;; sy
4e40: 6e 63 20 66 6f 72 20 66 69 6c 65 73 79 73 74 65 nc for filesyste
4e50: 6d 20 6c 6f 63 61 6c 20 64 62 20 77 72 69 74 65 m local db write
4e60: 73 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 s.. ;;.. (
4e70: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
4e80: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
4e90: 2a 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 *).. (let* ((
4ea0: 6e 65 65 64 2d 73 79 6e 63 20 20 20 20 20 20 20 need-sync
4eb0: 20 28 3e 3d 20 2a 64 62 2d 6c 61 73 74 2d 77 72 (>= *db-last-wr
4ec0: 69 74 65 2a 20 2a 64 62 2d 6c 61 73 74 2d 73 79 ite* *db-last-sy
4ed0: 6e 63 2a 29 29 20 3b 3b 20 6e 6f 20 73 79 6e 63 nc*)) ;; no sync
4ee0: 20 73 69 6e 63 65 20 6c 61 73 74 20 77 72 69 74 since last writ
4ef0: 65 0a 09 09 20 20 20 28 73 79 6e 63 2d 69 6e 2d e... (sync-in-
4f00: 70 72 6f 67 72 65 73 73 20 2a 64 62 2d 73 79 6e progress *db-syn
4f10: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 0a c-in-progress*).
4f20: 09 09 20 20 20 28 73 68 6f 75 6c 64 2d 73 79 6e .. (should-syn
4f30: 63 20 20 20 20 20 20 28 3e 20 28 2d 20 28 63 75 c (> (- (cu
4f40: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a rrent-seconds) *
4f50: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 20 35 db-last-sync*) 5
4f60: 29 29 20 3b 3b 20 73 79 6e 63 20 65 76 65 72 79 )) ;; sync every
4f70: 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 6d 69 five seconds mi
4f80: 6e 69 6d 75 6d 0a 09 09 20 20 20 28 77 69 6c 6c nimum... (will
4f90: 2d 73 79 6e 63 20 20 20 20 20 20 20 20 28 61 6e -sync (an
4fa0: 64 20 28 6f 72 20 6e 65 65 64 2d 73 79 6e 63 20 d (or need-sync
4fb0: 73 68 6f 75 6c 64 2d 73 79 6e 63 29 0a 09 09 09 should-sync)....
4fc0: 09 09 20 20 28 6e 6f 74 20 73 79 6e 63 2d 69 6e .. (not sync-in
4fd0: 2d 70 72 6f 67 72 65 73 73 29 29 29 0a 09 09 20 -progress)))...
4fe0: 20 20 28 73 74 61 72 74 2d 74 69 6d 65 20 20 20 (start-time
4ff0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (current-sec
5000: 6f 6e 64 73 29 29 29 0a 09 20 20 20 20 20 20 28 onds))).. (
5010: 69 66 20 77 69 6c 6c 2d 73 79 6e 63 20 28 73 65 if will-sync (se
5020: 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 t! *db-sync-in-p
5030: 72 6f 67 72 65 73 73 2a 20 23 74 29 29 0a 09 20 rogress* #t))..
5040: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
5050: 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 ck! *db-multi-sy
5060: 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 nc-mutex*)..
5070: 20 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 20 (if will-sync
5080: 28 63 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d 74 6f 2d (common:sync-to-
5090: 6d 65 67 61 74 65 73 74 2e 64 62 20 64 62 73 74 megatest.db dbst
50a0: 72 75 63 74 29 29 20 0a 09 20 20 20 20 20 20 28 ruct)) .. (
50b0: 69 66 20 77 69 6c 6c 2d 73 79 6e 63 0a 09 09 20 if will-sync...
50c0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 6d (begin... (m
50d0: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d utex-lock! *db-m
50e0: 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a ulti-sync-mutex*
50f0: 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 64 62 )... (set! db
5100: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
5110: 73 2a 20 23 66 29 0a 09 09 20 20 20 20 28 73 65 s* #f)... (se
5120: 74 21 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 t! *db-last-sync
5130: 2a 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 09 09 * start-time)...
5140: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
5150: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
5160: 63 2d 6d 75 74 65 78 2a 29 29 29 0a 09 20 20 20 c-mutex*)))..
5170: 20 20 20 28 69 66 20 28 61 6e 64 20 64 65 62 75 (if (and debu
5180: 67 2d 6d 6f 64 65 0a 09 09 20 20 20 20 20 20 20 g-mode...
5190: 28 3e 20 28 2d 20 73 74 61 72 74 2d 74 69 6d 65 (> (- start-time
51a0: 20 6c 61 73 74 2d 74 69 6d 65 29 20 36 30 29 29 last-time) 60))
51b0: 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 ... (begin...
51c0: 20 20 28 73 65 74 21 20 6c 61 73 74 2d 74 69 6d (set! last-tim
51d0: 65 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 09 09 e start-time)...
51e0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
51f0: 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 -info 4 *default
5200: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 69 6d 65 -log-port* "time
5210: 73 74 61 6d 70 20 2d 3e 20 22 20 28 73 65 63 6f stamp -> " (seco
5220: 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 nds->time-string
5230: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
5240: 73 29 29 20 22 2c 20 74 69 6d 65 20 73 69 6e 63 s)) ", time sinc
5250: 65 20 73 74 61 72 74 20 2d 3e 20 22 20 28 73 65 e start -> " (se
5260: 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 conds->hr-min-se
5270: 63 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 c (- (current-se
5280: 63 6f 6e 64 73 29 20 2a 74 69 6d 65 2d 7a 65 72 conds) *time-zer
5290: 6f 2a 29 29 29 29 29 29 0a 09 20 20 20 20 0a 09 o*)))))).. ..
52a0: 20 20 20 20 3b 3b 20 6b 65 65 70 20 67 6f 69 6e ;; keep goin
52b0: 67 20 75 6e 6c 65 73 73 20 74 69 6d 65 20 74 6f g unless time to
52c0: 20 65 78 69 74 0a 09 20 20 20 20 3b 3b 0a 09 20 exit.. ;;..
52d0: 20 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 69 6d (if (not *tim
52e0: 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 09 28 6c e-to-exit*)...(l
52f0: 65 74 20 64 65 6c 61 79 2d 6c 6f 6f 70 20 28 28 et delay-loop ((
5300: 63 6f 75 6e 74 20 30 29 29 0a 09 09 20 20 28 69 count 0))... (i
5310: 66 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d f (and (not *tim
5320: 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 09 09 20 e-to-exit*)....
5330: 20 20 28 3c 20 63 6f 75 6e 74 20 34 29 29 20 3b (< count 4)) ;
5340: 3b 20 77 61 73 20 31 31 2c 20 63 68 61 6e 67 69 ; was 11, changi
5350: 6e 67 20 74 6f 20 34 2e 20 0a 09 09 20 20 20 20 ng to 4. ...
5360: 20 20 28 62 65 67 69 6e 0a 09 09 09 28 74 68 72 (begin....(thr
5370: 65 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 ead-sleep! 1)...
5380: 09 28 64 65 6c 61 79 2d 6c 6f 6f 70 20 28 2b 20 .(delay-loop (+
5390: 63 6f 75 6e 74 20 31 29 29 29 29 0a 09 09 20 20 count 1))))...
53a0: 28 6c 6f 6f 70 29 29 29 0a 09 20 20 20 20 28 69 (loop))).. (i
53b0: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
53c0: 69 73 65 2d 70 72 69 6e 74 20 33 30 29 0a 09 09 ise-print 30)...
53d0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
53e0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
53f0: 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 -port* "Exiting
5400: 77 61 74 63 68 64 6f 67 20 74 69 6d 65 72 2c 20 watchdog timer,
5410: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3d *time-to-exit* =
5420: 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 " *time-to-exit
5430: 2a 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e *)))))))..(defin
5440: 65 20 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 e (std-exit-proc
5450: 65 64 75 72 65 29 0a 20 20 28 6c 65 74 20 28 28 edure). (let ((
5460: 6e 6f 2d 68 75 72 72 79 20 20 28 69 66 20 2a 74 no-hurry (if *t
5470: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3b 3b 20 ime-to-exit* ;;
5480: 68 75 72 72 79 20 75 70 0a 09 09 20 20 20 20 20 hurry up...
5490: 20 20 23 66 0a 09 09 20 20 20 20 20 20 20 28 62 #f... (b
54a0: 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 2a egin.... (set! *
54b0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 time-to-exit* #t
54c0: 29 0a 09 09 09 20 23 74 29 29 29 29 0a 20 20 20 ).... #t)))).
54d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
54e0: 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 4 *default-lo
54f0: 67 2d 70 6f 72 74 2a 20 22 73 74 61 72 74 69 6e g-port* "startin
5500: 67 20 65 78 69 74 20 70 72 6f 63 65 73 73 2c 20 g exit process,
5510: 66 69 6e 61 6c 69 7a 69 6e 67 20 64 61 74 61 62 finalizing datab
5520: 61 73 65 73 2e 22 29 0a 20 20 20 20 28 69 66 20 ases."). (if
5530: 28 61 6e 64 20 6e 6f 2d 68 75 72 72 79 20 28 64 (and no-hurry (d
5540: 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 ebug:debug-mode
5550: 31 38 29 29 0a 09 28 72 6d 74 3a 70 72 69 6e 74 18))..(rmt:print
5560: 2d 64 62 2d 73 74 61 74 73 29 29 0a 20 20 20 20 -db-stats)).
5570: 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b 65 (let ((th1 (make
5580: 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 -thread (lambda
5590: 28 29 20 3b 3b 20 74 68 72 65 61 64 20 66 6f 72 () ;; thread for
55a0: 20 63 6c 65 61 6e 69 6e 67 20 75 70 2c 20 67 69 cleaning up, gi
55b0: 76 65 20 69 74 20 66 69 76 65 20 73 65 63 6f 6e ve it five secon
55c0: 64 73 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ds.... (if
55d0: 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 28 64 *dbstruct-db* (d
55e0: 62 3a 63 6c 6f 73 65 2d 61 6c 6c 20 2a 64 62 73 b:close-all *dbs
55f0: 74 72 75 63 74 2d 64 62 2a 29 29 20 3b 3b 20 6f truct-db*)) ;; o
5600: 6e 65 20 73 65 63 6f 6e 64 20 61 6c 6c 6f 63 61 ne second alloca
5610: 74 65 64 0a 09 09 09 20 20 20 20 20 20 28 69 66 ted.... (if
5620: 20 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 0a 09 *task-db* ..
5630: 09 09 09 20 20 28 6c 65 74 20 28 28 64 62 20 28 ... (let ((db (
5640: 63 64 72 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 cdr *task-db*)))
5650: 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 73 71 ..... (if (sq
5660: 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 lite3:database?
5670: 64 62 29 0a 09 09 09 09 09 28 62 65 67 69 6e 0a db)......(begin.
5680: 09 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a ..... (sqlite3:
5690: 69 6e 74 65 72 72 75 70 74 21 20 64 62 29 0a 09 interrupt! db)..
56a0: 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 66 .... (sqlite3:f
56b0: 69 6e 61 6c 69 7a 65 21 20 64 62 20 23 74 29 0a inalize! db #t).
56c0: 09 09 09 09 09 20 20 28 76 65 63 74 6f 72 2d 73 ..... (vector-s
56d0: 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 30 20 et! *task-db* 0
56e0: 23 66 29 29 29 29 29 0a 09 09 09 20 20 20 20 20 #f)))))....
56f0: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
5700: 6f 72 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 ort *default-log
5710: 2d 70 6f 72 74 2a 29 0a 09 09 09 20 20 20 20 20 -port*)....
5720: 20 28 73 65 74 21 20 2a 64 65 66 61 75 6c 74 2d (set! *default-
5730: 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 65 log-port* (curre
5740: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 nt-error-port)))
5750: 20 22 43 6c 65 61 6e 75 70 20 64 62 20 65 78 69 "Cleanup db exi
5760: 74 20 74 68 72 65 61 64 22 29 29 0a 09 20 20 28 t thread")).. (
5770: 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th2 (make-thread
5780: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
5790: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
57a0: 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 4 *default-log
57b0: 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d 70 74 69 -port* "Attempti
57c0: 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e 20 50 ng clean exit. P
57d0: 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 6e 74 lease be patient
57e0: 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 77 20 and wait a few
57f0: 73 65 63 6f 6e 64 73 2e 2e 2e 22 29 0a 09 09 09 seconds...")....
5800: 20 20 20 20 20 20 28 69 66 20 6e 6f 2d 68 75 72 (if no-hur
5810: 72 79 0a 09 09 09 09 20 20 28 74 68 72 65 61 64 ry..... (thread
5820: 2d 73 6c 65 65 70 21 20 35 29 20 3b 3b 20 67 69 -sleep! 5) ;; gi
5830: 76 65 20 74 68 65 20 63 6c 65 61 6e 20 75 70 20 ve the clean up
5840: 66 65 77 20 73 65 63 6f 6e 64 73 20 74 6f 20 64 few seconds to d
5850: 6f 20 69 74 27 73 20 73 74 75 66 66 0a 09 09 09 o it's stuff....
5860: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
5870: 21 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 28 ! 2)).... (
5880: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
5890: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
58a0: 20 22 20 2e 2e 2e 20 64 6f 6e 65 22 29 0a 09 09 " ... done")...
58b0: 09 20 20 20 20 20 20 29 0a 09 09 09 20 20 20 20 . )....
58c0: 22 63 6c 65 61 6e 20 65 78 69 74 22 29 29 29 0a "clean exit"))).
58d0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 (thread-st
58e0: 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 art! th1).
58f0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
5900: 68 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 h2). (threa
5910: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 29 29 0a d-join! th1)))).
5920: 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d 73 69 .(define (std-si
5930: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 gnal-handler sig
5940: 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 6e 61 num). ;; (signa
5950: 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a l-mask! signum).
5960: 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f (set! *time-to
5970: 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 28 64 65 -exit* #t). (de
5980: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
5990: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
59a0: 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 20 73 ort* "Received s
59b0: 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 ignal " signum "
59c0: 20 65 78 69 74 69 6e 67 20 70 72 6f 6d 70 74 6c exiting promptl
59d0: 79 22 29 0a 20 20 3b 3b 20 28 73 74 64 2d 65 78 y"). ;; (std-ex
59e0: 69 74 2d 70 72 6f 63 65 64 75 72 65 29 20 3b 3b it-procedure) ;;
59f0: 20 73 68 6f 75 6c 64 6e 27 74 20 6e 65 65 64 20 shouldn't need
5a00: 74 68 69 73 20 73 69 6e 63 65 20 77 65 20 61 72 this since we ar
5a10: 65 20 65 78 69 74 69 6e 67 20 61 6e 64 20 69 74 e exiting and it
5a20: 20 77 69 6c 6c 20 62 65 20 63 61 6c 6c 65 64 20 will be called
5a30: 61 6e 79 77 61 79 0a 20 20 28 65 78 69 74 29 29 anyway. (exit))
5a40: 0a 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 ..(set-signal-ha
5a50: 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e ndler! signal/in
5a60: 74 20 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 t std-signal-ha
5a70: 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 43 0a 28 73 ndler) ;; ^C.(s
5a80: 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 et-signal-handle
5a90: 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 6d 20 73 r! signal/term s
5aa0: 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 td-signal-handle
5ab0: 72 29 0a 3b 3b 20 28 73 65 74 2d 73 69 67 6e 61 r).;; (set-signa
5ac0: 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 l-handler! signa
5ad0: 6c 2f 73 74 6f 70 20 73 74 64 2d 73 69 67 6e 61 l/stop std-signa
5ae0: 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b 20 5e l-handler) ;; ^
5af0: 5a 20 4e 4f 2c 20 64 6f 20 4e 4f 54 20 68 61 6e Z NO, do NOT han
5b00: 64 6c 65 20 5e 5a 21 0a 0a 3b 3b 3d 3d 3d 3d 3d dle ^Z!..;;=====
5b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b50: 3d 0a 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 55 =.;; M I S C U
5b60: 20 54 20 49 20 4c 20 53 0a 3b 3b 3d 3d 3d 3d 3d T I L S.;;=====
5b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5bb0: 3d 0a 0a 3b 3b 20 6f 6e 65 2d 6f 66 20 61 72 67 =..;; one-of arg
5bc0: 73 20 64 65 66 69 6e 65 64 0a 28 64 65 66 69 6e s defined.(defin
5bd0: 65 20 28 61 72 67 73 2d 64 65 66 69 6e 65 64 3f e (args-defined?
5be0: 20 2e 20 70 61 72 61 6d 29 0a 20 20 28 6c 65 74 . param). (let
5bf0: 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 ((res #f)).
5c00: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
5c10: 28 6c 61 6d 62 64 61 20 28 61 72 67 29 0a 20 20 (lambda (arg).
5c20: 20 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 (if (args:g
5c30: 65 74 2d 61 72 67 20 61 72 67 29 28 73 65 74 21 et-arg arg)(set!
5c40: 20 72 65 73 20 23 74 29 29 29 0a 20 20 20 20 20 res #t))).
5c50: 70 61 72 61 6d 29 0a 20 20 20 20 72 65 73 29 29 param). res))
5c60: 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 73 74 75 ..;; convert stu
5c70: 66 66 20 74 6f 20 61 20 6e 75 6d 62 65 72 20 69 ff to a number i
5c80: 66 20 70 6f 73 73 69 62 6c 65 0a 28 64 65 66 69 f possible.(defi
5c90: 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 ne (any->number
5ca0: 76 61 6c 29 0a 20 20 28 63 6f 6e 64 20 0a 20 20 val). (cond .
5cb0: 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 20 ((number? val)
5cc0: 76 61 6c 29 0a 20 20 20 28 28 73 74 72 69 6e 67 val). ((string
5cd0: 3f 20 76 61 6c 29 20 28 73 74 72 69 6e 67 2d 3e ? val) (string->
5ce0: 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 20 20 number val)).
5cf0: 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 20 28 ((symbol? val) (
5d00: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 73 79 6d any->number (sym
5d10: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 bol->string val)
5d20: 29 29 0a 20 20 20 28 65 6c 73 65 20 23 66 29 29 )). (else #f))
5d30: 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 2d )..(define (any-
5d40: 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 6f 73 73 69 >number-if-possi
5d50: 62 6c 65 20 76 61 6c 29 0a 20 20 28 6c 65 74 20 ble val). (let
5d60: 28 28 6e 75 6d 20 28 61 6e 79 2d 3e 6e 75 6d 62 ((num (any->numb
5d70: 65 72 20 76 61 6c 29 29 29 0a 20 20 20 20 28 69 er val))). (i
5d80: 66 20 6e 75 6d 20 6e 75 6d 20 76 61 6c 29 29 29 f num num val)))
5d90: 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 74 74 2d ..(define (patt-
5da0: 6c 69 73 74 2d 6d 61 74 63 68 20 69 74 65 6d 20 list-match item
5db0: 70 61 74 74 73 29 0a 20 20 28 64 65 62 75 67 3a patts). (debug:
5dc0: 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 print-info 8 *de
5dd0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5de0: 22 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 "patt-list-match
5df0: 20 69 74 65 6d 3d 22 20 69 74 65 6d 20 22 20 70 item=" item " p
5e00: 61 74 74 73 3d 22 20 70 61 74 74 73 29 0a 20 20 atts=" patts).
5e10: 28 69 66 20 28 61 6e 64 20 69 74 65 6d 20 70 61 (if (and item pa
5e20: 74 74 73 29 20 20 3b 3b 20 68 65 72 65 20 77 65 tts) ;; here we
5e30: 20 61 72 65 20 66 69 6c 74 65 72 69 6e 67 20 66 are filtering f
5e40: 6f 72 20 6d 61 74 63 68 65 73 20 77 69 74 68 20 or matches with
5e50: 69 74 65 6d 20 70 61 74 74 65 72 6e 73 0a 20 20 item patterns.
5e60: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 (let ((res #
5e70: 66 29 29 20 20 20 3b 3b 20 6c 6f 6f 6b 20 74 68 f)) ;; look th
5e80: 72 6f 75 67 68 20 61 6c 6c 20 74 68 65 20 69 74 rough all the it
5e90: 65 6d 2d 70 61 74 74 73 20 69 66 20 64 65 66 69 em-patts if defi
5ea0: 6e 65 64 2c 20 66 6f 72 6d 61 74 20 69 73 20 70 ned, format is p
5eb0: 61 74 74 31 2c 70 61 74 74 32 2c 70 61 74 74 33 att1,patt2,patt3
5ec0: 20 2e 2e 2e 20 77 69 6c 64 63 61 72 64 20 69 73 ... wildcard is
5ed0: 20 25 0a 09 28 66 6f 72 2d 65 61 63 68 20 0a 09 %..(for-each ..
5ee0: 20 28 6c 61 6d 62 64 61 20 28 70 61 74 74 29 0a (lambda (patt).
5ef0: 09 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 70 61 . (let ((modpa
5f00: 74 74 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 tt (string-subst
5f10: 69 74 75 74 65 20 22 25 22 20 22 2e 2a 22 20 70 itute "%" ".*" p
5f20: 61 74 74 20 23 74 29 29 29 0a 09 20 20 20 20 20 att #t)))..
5f30: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5f40: 6f 20 31 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f o 10 *default-lo
5f50: 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 20 22 20 g-port* "patt "
5f60: 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 20 22 patt " modpatt "
5f70: 20 6d 6f 64 70 61 74 74 29 0a 09 20 20 20 20 20 modpatt)..
5f80: 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 (if (string-matc
5f90: 68 20 28 72 65 67 65 78 70 20 6d 6f 64 70 61 74 h (regexp modpat
5fa0: 74 29 20 69 74 65 6d 29 0a 09 09 20 28 73 65 74 t) item)... (set
5fb0: 21 20 72 65 73 20 23 74 29 29 29 29 0a 09 20 28 ! res #t)))).. (
5fc0: 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 string-split pat
5fd0: 74 73 20 22 2c 22 29 29 0a 09 72 65 73 29 0a 20 ts ","))..res).
5fe0: 20 20 20 20 20 23 74 29 29 0a 0a 3b 3b 20 28 6d #t))..;; (m
5ff0: 61 70 20 70 72 69 6e 74 20 28 6d 61 70 20 63 61 ap print (map ca
6000: 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 r (hash-table->a
6010: 6c 69 73 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 list (read-confi
6020: 67 20 22 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f g "runconfigs.co
6030: 6e 66 69 67 22 20 23 66 20 23 74 29 29 29 29 0a nfig" #f #t)))).
6040: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
6050: 67 65 74 2d 72 75 6e 63 6f 6e 66 69 67 2d 74 61 get-runconfig-ta
6060: 72 67 65 74 73 20 23 21 6b 65 79 20 28 63 6f 6e rgets #!key (con
6070: 66 69 67 66 20 23 66 29 29 0a 20 20 28 6c 65 74 figf #f)). (let
6080: 20 28 28 74 61 72 67 73 20 20 20 20 20 20 20 28 ((targs (
6090: 73 6f 72 74 20 28 6d 61 70 20 63 61 72 20 28 68 sort (map car (h
60a0: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
60b0: 0a 09 09 09 09 20 20 20 20 20 28 6f 72 20 63 6f ..... (or co
60c0: 6e 66 69 67 66 0a 09 09 09 09 09 20 28 72 65 61 nfigf...... (rea
60d0: 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 2a d-config (conc *
60e0: 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f toppath* "/runco
60f0: 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 0a 09 nfigs.config")..
6100: 09 09 09 09 09 20 20 20 20 20 20 23 66 20 23 74 ..... #f #t
6110: 29 0a 09 09 09 09 09 20 28 6d 61 6b 65 2d 68 61 )...... (make-ha
6120: 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 09 09 sh-table))))....
6130: 20 20 20 73 74 72 69 6e 67 3c 3f 29 29 0a 09 28 string<?))..(
6140: 74 61 72 67 65 74 2d 70 61 74 74 20 28 61 72 67 target-patt (arg
6150: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 s:get-arg "-targ
6160: 65 74 22 29 29 29 0a 20 20 20 20 28 69 66 20 74 et"))). (if t
6170: 61 72 67 65 74 2d 70 61 74 74 0a 09 28 66 69 6c arget-patt..(fil
6180: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
6190: 09 09 20 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d .. (patt-list-m
61a0: 61 74 63 68 20 78 20 74 61 72 67 65 74 2d 70 61 atch x target-pa
61b0: 74 74 29 29 0a 09 09 74 61 72 67 73 29 0a 09 74 tt))...targs)..t
61c0: 61 72 67 73 29 29 29 0a 0a 3b 3b 20 27 28 70 72 args)))..;; '(pr
61d0: 69 6e 74 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 int (string-inte
61e0: 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 64 rsperse (map cad
61f0: 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 r (hash-table-re
6200: 66 2f 64 65 66 61 75 6c 74 20 28 72 65 61 64 2d f/default (read-
6210: 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 73 74 config "megatest
6220: 2e 63 6f 6e 66 69 67 22 20 5c 23 66 20 5c 23 74 .config" \#f \#t
6230: 29 20 22 64 69 73 6b 73 22 20 27 22 27 22 27 28 ) "disks" '"'"'(
6240: 22 6e 6f 6e 65 22 20 22 22 29 29 29 20 22 5c 6e "none" ""))) "\n
6250: 22 29 29 27 0a 28 64 65 66 69 6e 65 20 28 63 6f "))'.(define (co
6260: 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 73 20 23 mmon:get-disks #
6270: 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 !key (configf #f
6280: 29 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 )). (hash-table
6290: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a 20 20 -ref/default .
62a0: 20 28 6f 72 20 63 6f 6e 66 69 67 66 20 28 72 65 (or configf (re
62b0: 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 ad-config "megat
62c0: 65 73 74 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 est.config" #f #
62d0: 74 29 29 0a 20 20 20 22 64 69 73 6b 73 22 20 27 t)). "disks" '
62e0: 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 0a 0a 3b ("none" "")))..;
62f0: 3b 20 72 65 74 75 72 6e 20 66 69 72 73 74 20 63 ; return first c
6300: 6f 6d 6d 61 6e 64 20 74 68 61 74 20 65 78 69 73 ommand that exis
6310: 74 73 2c 20 65 6c 73 65 20 23 66 0a 3b 3b 0a 28 ts, else #f.;;.(
6320: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
6330: 68 69 63 68 20 63 6d 64 73 29 0a 20 20 28 69 66 hich cmds). (if
6340: 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a 20 20 (null? cmds).
6350: 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 6c 65 #f. (le
6360: 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 t loop ((hed (ca
6370: 72 20 63 6d 64 73 29 29 0a 09 09 20 28 74 61 6c r cmds))... (tal
6380: 20 28 63 64 72 20 63 6d 64 73 29 29 29 0a 09 28 (cdr cmds)))..(
6390: 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 68 2d let ((res (with-
63a0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
63b0: 28 63 6f 6e 63 20 22 77 68 69 63 68 20 22 20 68 (conc "which " h
63c0: 65 64 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 29 ed) read-line)))
63d0: 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 .. (if (and (st
63e0: 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 ring? res)...
63f0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 (file-exists? re
6400: 73 29 29 0a 09 20 20 20 20 20 20 72 65 73 0a 09 s)).. res..
6410: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
6420: 20 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 tal)... #f...
6430: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
6440: 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 (cdr tal))))))))
6450: 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d . .(define (com
6460: 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c 6c 2d mon:get-install-
6470: 61 72 65 61 29 0a 20 20 28 6c 65 74 20 28 28 65 area). (let ((e
6480: 78 65 2d 70 61 74 68 20 28 63 61 72 20 28 61 72 xe-path (car (ar
6490: 67 76 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 gv)))). (if (
64a0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 65 78 65 file-exists? exe
64b0: 2d 70 61 74 68 29 0a 09 28 68 61 6e 64 6c 65 2d -path)..(handle-
64c0: 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 65 78 6e exceptions.. exn
64d0: 0a 09 20 23 66 0a 09 20 28 70 61 74 68 6e 61 6d .. #f.. (pathnam
64e0: 65 2d 64 69 72 65 63 74 6f 72 79 0a 09 20 20 28 e-directory.. (
64f0: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
6500: 72 79 20 0a 09 20 20 20 28 70 61 74 68 6e 61 6d ry .. (pathnam
6510: 65 2d 64 69 72 65 63 74 6f 72 79 20 65 78 65 2d e-directory exe-
6520: 70 61 74 68 29 29 29 29 0a 09 23 66 29 29 29 0a path))))..#f))).
6530: 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 73 74 .;; return first
6540: 20 70 61 74 68 20 74 68 61 74 20 63 61 6e 20 62 path that can b
6550: 65 20 63 72 65 61 74 65 64 20 6f 72 20 61 6c 72 e created or alr
6560: 65 61 64 79 20 65 78 69 73 74 73 20 61 6e 64 20 eady exists and
6570: 69 73 20 77 72 69 74 61 62 6c 65 0a 3b 3b 0a 28 is writable.;;.(
6580: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
6590: 65 74 2d 63 72 65 61 74 65 2d 77 72 69 74 65 61 et-create-writea
65a0: 62 6c 65 2d 64 69 72 20 64 69 72 73 29 0a 20 20 ble-dir dirs).
65b0: 28 69 66 20 28 6e 75 6c 6c 3f 20 64 69 72 73 29 (if (null? dirs)
65c0: 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 . #f.
65d0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
65e0: 28 63 61 72 20 64 69 72 73 29 29 0a 09 09 20 28 (car dirs))... (
65f0: 74 61 6c 20 28 63 64 72 20 64 69 72 73 29 29 29 tal (cdr dirs)))
6600: 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 6f 72 ..(let ((res (or
6610: 20 28 61 6e 64 20 28 64 69 72 65 63 74 6f 72 79 (and (directory
6620: 3f 20 68 65 64 29 0a 09 09 09 20 20 20 20 28 66 ? hed).... (f
6630: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
6640: 3f 20 68 65 64 29 0a 09 09 09 20 20 20 20 68 65 ? hed).... he
6650: 64 29 0a 09 09 20 20 20 20 20 20 20 28 68 61 6e d)... (han
6660: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
6670: 09 09 65 78 6e 0a 09 09 09 23 66 0a 09 09 09 28 ..exn....#f....(
6680: 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 create-directory
6690: 20 68 65 64 20 23 74 29 29 29 29 29 0a 09 20 20 hed #t)))))..
66a0: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
66b0: 3f 20 72 65 73 29 0a 09 09 20 20 20 28 64 69 72 ? res)... (dir
66c0: 65 63 74 6f 72 79 3f 20 72 65 73 29 29 0a 09 20 ectory? res))..
66d0: 20 20 20 20 20 72 65 73 0a 09 20 20 20 20 20 20 res..
66e0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
66f0: 09 09 20 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 .. #f... (loop
6700: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
6710: 61 6c 29 29 29 29 29 29 29 29 0a 20 20 0a 3b 3b al)))))))). .;;
6720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6760: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 20 52 20 ======.;; T A R
6770: 47 20 45 20 54 20 53 20 20 2c 20 20 20 53 20 54 G E T S , S T
6780: 20 41 20 54 20 45 20 2c 20 20 20 53 20 54 20 41 A T E , S T A
6790: 20 54 20 55 20 53 20 2c 20 20 20 0a 3b 3b 20 20 T U S , .;;
67a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67b0: 20 20 52 20 55 20 4e 20 4e 20 41 20 4d 20 45 20 R U N N A M E
67c0: 20 20 20 41 20 4e 20 44 20 20 20 54 20 45 20 53 A N D T E S
67d0: 20 54 20 50 20 41 20 54 20 54 0a 3b 3b 3d 3d 3d T P A T T.;;===
67e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
67f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6820: 3d 3d 3d 0a 0a 3b 3b 20 4c 6f 6f 6b 75 70 20 61 ===..;; Lookup a
6830: 20 76 61 6c 75 65 20 69 6e 20 72 75 6e 63 6f 6e value in runcon
6840: 66 69 67 73 20 62 61 73 65 64 20 6f 6e 20 2d 72 figs based on -r
6850: 65 71 74 61 72 67 20 6f 72 20 2d 74 61 72 67 65 eqtarg or -targe
6860: 74 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 63 6f t.(define (runco
6870: 6e 66 69 67 73 2d 67 65 74 20 63 6f 6e 66 69 67 nfigs-get config
6880: 20 76 61 72 29 0a 20 20 28 6c 65 74 20 28 28 74 var). (let ((t
6890: 61 72 67 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 arg (common:args
68a0: 2d 67 65 74 2d 74 61 72 67 65 74 29 29 29 20 3b -get-target))) ;
68b0: 3b 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d ; (or (args:get-
68c0: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 28 arg "-reqtarg")(
68d0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
68e0: 61 72 67 65 74 22 29 28 67 65 74 65 6e 76 20 22 arget")(getenv "
68f0: 4d 54 5f 54 41 52 47 45 54 22 29 29 29 29 0a 20 MT_TARGET")))).
6900: 20 20 20 28 69 66 20 74 61 72 67 0a 09 28 6f 72 (if targ..(or
6910: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
6920: 20 63 6f 6e 66 69 67 20 74 61 72 67 20 76 61 72 config targ var
6930: 29 0a 09 20 20 20 20 28 63 6f 6e 66 69 67 66 3a ).. (configf:
6940: 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 64 lookup config "d
6950: 65 66 61 75 6c 74 22 20 76 61 72 29 29 0a 09 28 efault" var))..(
6960: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 configf:lookup c
6970: 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 20 onfig "default"
6980: 76 61 72 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 var))))..(define
6990: 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 (common:args-ge
69a0: 74 2d 73 74 61 74 65 29 0a 20 20 28 6f 72 20 28 t-state). (or (
69b0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 args:get-arg "-s
69c0: 74 61 74 65 22 29 28 61 72 67 73 3a 67 65 74 2d tate")(args:get-
69d0: 61 72 67 20 22 3a 73 74 61 74 65 22 29 29 29 0a arg ":state"))).
69e0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
69f0: 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 75 73 :args-get-status
6a00: 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 ). (or (args:ge
6a10: 74 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 t-arg "-status")
6a20: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
6a30: 73 74 61 74 75 73 22 29 29 29 0a 0a 28 64 65 66 status")))..(def
6a40: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 ine (common:args
6a50: 2d 67 65 74 2d 74 65 73 74 70 61 74 74 20 72 63 -get-testpatt rc
6a60: 6f 6e 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 onf). (let* ((r
6a70: 74 65 73 74 70 61 74 74 20 20 20 20 20 28 69 66 testpatt (if
6a80: 20 72 63 6f 6e 66 20 28 72 75 6e 63 6f 6e 66 69 rconf (runconfi
6a90: 67 73 2d 67 65 74 20 72 63 6f 6e 66 20 22 54 45 gs-get rconf "TE
6aa0: 53 54 50 41 54 54 22 29 20 23 66 29 29 0a 09 20 STPATT") #f))..
6ab0: 28 61 72 67 73 2d 74 65 73 74 70 61 74 74 20 28 (args-testpatt (
6ac0: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
6ad0: 20 22 2d 74 65 73 74 70 61 74 74 22 29 0a 09 09 "-testpatt")...
6ae0: 09 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 . (args:get-a
6af0: 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 29 0a rg "-runtests").
6b00: 09 09 09 20 20 20 20 22 25 22 29 29 0a 09 20 28 ... "%")).. (
6b10: 74 65 73 74 70 61 74 74 20 20 20 20 28 6f 72 20 testpatt (or
6b20: 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 61 72 67 (and (equal? arg
6b30: 73 2d 74 65 73 74 70 61 74 74 20 22 25 22 29 0a s-testpatt "%").
6b40: 09 09 09 20 20 20 20 20 20 20 72 74 65 73 74 70 ... rtestp
6b50: 61 74 74 29 0a 09 09 09 20 20 61 72 67 73 2d 74 att).... args-t
6b60: 65 73 74 70 61 74 74 29 29 29 0a 20 20 20 20 28 estpatt))). (
6b70: 69 66 20 72 74 65 73 74 70 61 74 74 20 28 64 65 if rtestpatt (de
6b80: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
6b90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6ba0: 72 74 2a 20 22 54 45 53 54 50 41 54 54 20 66 72 rt* "TESTPATT fr
6bb0: 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 3a 20 22 om runconfigs: "
6bc0: 20 72 74 65 73 74 70 61 74 74 29 29 0a 20 20 20 rtestpatt)).
6bd0: 20 74 65 73 74 70 61 74 74 29 29 0a 0a 28 64 65 testpatt))..(de
6be0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
6bf0: 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 20 28 6f 72 -linktree). (or
6c00: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e (getenv "MT_LIN
6c10: 4b 54 52 45 45 22 29 0a 20 20 20 20 20 20 28 69 KTREE"). (i
6c20: 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 20 f *configdat*..
6c30: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
6c40: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
6c50: 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 tup" "linktree")
6c60: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
6c70: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 72 75 mmon:args-get-ru
6c80: 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 nname). (let ((
6c90: 72 65 73 20 28 6f 72 20 28 61 72 67 73 3a 67 65 res (or (args:ge
6ca0: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
6cb0: 29 0a 09 09 20 28 61 72 67 73 3a 67 65 74 2d 61 )... (args:get-a
6cc0: 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 0a 09 rg ":runname")..
6cd0: 09 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 . (getenv "MT_RU
6ce0: 4e 4e 41 4d 45 22 29 29 29 29 0a 20 20 20 20 3b NNAME")))). ;
6cf0: 3b 20 28 69 66 20 72 65 73 20 28 73 65 74 2d 65 ; (if res (set-e
6d00: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
6d10: 62 6c 65 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 ble "MT_RUNNAME"
6d20: 20 72 65 73 29 29 20 3b 3b 20 6e 6f 74 20 73 75 res)) ;; not su
6d30: 72 65 20 69 66 20 74 68 69 73 20 69 73 20 61 20 re if this is a
6d40: 67 6f 6f 64 20 69 64 65 61 2e 20 73 69 64 65 20 good idea. side
6d50: 65 66 66 65 63 74 20 61 6e 64 20 61 6c 6c 20 2e effect and all .
6d60: 2e 2e 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 ... res))..(d
6d70: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 efine (common:ar
6d80: 67 73 2d 67 65 74 2d 74 61 72 67 65 74 20 23 21 gs-get-target #!
6d90: 6b 65 79 20 28 73 70 6c 69 74 20 23 66 29 29 0a key (split #f)).
6da0: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 (let* ((keys
6db0: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
6dc0: 65 3f 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 20 e? *configdat*)
6dd0: 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 (keys:config-get
6de0: 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 -fields *configd
6df0: 61 74 2a 29 20 27 28 29 29 29 0a 09 20 28 6e 75 at*) '())).. (nu
6e00: 6d 6b 65 79 73 20 28 6c 65 6e 67 74 68 20 6b 65 mkeys (length ke
6e10: 79 73 29 29 0a 09 20 28 74 61 72 67 65 74 20 20 ys)).. (target
6e20: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
6e30: 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 g "-reqtarg")...
6e40: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
6e50: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 arg "-target")..
6e60: 09 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 . (getenv "
6e70: 4d 54 5f 54 41 52 47 45 54 22 29 29 29 0a 09 20 MT_TARGET")))..
6e80: 28 74 6c 69 73 74 20 20 20 28 69 66 20 74 61 72 (tlist (if tar
6e90: 67 65 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 get (string-spli
6ea0: 74 20 74 61 72 67 65 74 20 22 2f 22 20 23 74 29 t target "/" #t)
6eb0: 20 27 28 29 29 29 0a 09 20 28 76 61 6c 69 64 20 '())).. (valid
6ec0: 20 20 28 69 66 20 74 61 72 67 65 74 0a 09 09 20 (if target...
6ed0: 20 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 (or (null?
6ee0: 6b 65 79 73 29 20 3b 3b 20 70 72 6f 62 61 62 6c keys) ;; probabl
6ef0: 79 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 6f 75 72 y don't know our
6f00: 20 6b 65 79 73 20 79 65 74 0a 09 09 09 20 20 28 keys yet.... (
6f10: 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 and (not (null?
6f20: 74 6c 69 73 74 29 29 0a 09 09 09 20 20 20 20 20 tlist))....
6f30: 20 20 28 65 71 3f 20 6e 75 6d 6b 65 79 73 20 28 (eq? numkeys (
6f40: 6c 65 6e 67 74 68 20 74 6c 69 73 74 29 29 0a 09 length tlist))..
6f50: 09 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 .. (null?
6f60: 28 66 69 6c 74 65 72 20 73 74 72 69 6e 67 2d 6e (filter string-n
6f70: 75 6c 6c 3f 20 74 6c 69 73 74 29 29 29 29 0a 09 ull? tlist))))..
6f80: 09 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 . #f))).
6f90: 20 28 69 66 20 76 61 6c 69 64 0a 09 28 69 66 20 (if valid..(if
6fa0: 73 70 6c 69 74 0a 09 20 20 20 20 74 6c 69 73 74 split.. tlist
6fb0: 0a 09 20 20 20 20 74 61 72 67 65 74 29 0a 09 28 .. target)..(
6fc0: 69 66 20 74 61 72 67 65 74 0a 09 20 20 20 20 28 if target.. (
6fd0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
6fe0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
6ff0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
7000: 6f 72 74 2a 20 22 49 6e 76 61 6c 69 64 20 74 61 ort* "Invalid ta
7010: 72 67 65 74 2c 20 73 70 61 63 65 73 20 6f 72 20 rget, spaces or
7020: 62 6c 61 6e 6b 73 20 6e 6f 74 20 61 6c 6c 6f 77 blanks not allow
7030: 65 64 20 5c 22 22 20 74 61 72 67 65 74 20 22 5c ed \"" target "\
7040: 22 2c 20 74 61 72 67 65 74 20 73 68 6f 75 6c 64 ", target should
7050: 20 62 65 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 be: " (string-i
7060: 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 73 20 ntersperse keys
7070: 22 2f 22 29 20 22 2c 20 68 61 76 65 20 22 20 74 "/") ", have " t
7080: 6c 69 73 74 20 22 20 66 6f 72 20 65 6c 65 6d 65 list " for eleme
7090: 6e 74 73 22 29 0a 09 20 20 20 20 20 20 23 66 29 nts").. #f)
70a0: 0a 09 20 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b .. #f))))..;;
70b0: 20 6c 6f 67 69 63 20 66 6f 72 20 67 65 74 74 69 logic for getti
70c0: 6e 67 20 68 6f 6d 65 68 6f 73 74 2e 20 52 65 74 ng homehost. Ret
70d0: 75 72 6e 73 20 28 68 6f 73 74 20 2e 20 61 74 2d urns (host . at-
70e0: 68 6f 6d 65 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 home).;;.(define
70f0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d (common:get-hom
7100: 65 68 6f 73 74 29 0a 20 20 28 63 6f 6e 64 0a 20 ehost). (cond.
7110: 20 20 28 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 20 (*home-host*
7120: 20 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 29 0a *home-host*).
7130: 20 20 20 28 28 6e 6f 74 20 2a 74 6f 70 70 61 74 ((not *toppat
7140: 68 2a 29 20 23 66 29 20 20 20 20 20 20 20 20 20 h*) #f)
7150: 20 20 20 3b 3b 20 64 6f 6e 27 74 20 6b 6e 6f 77 ;; don't know
7160: 20 74 6f 70 70 61 74 68 20 79 65 74 3f 20 72 65 toppath yet? re
7170: 74 75 72 6e 20 23 66 0a 20 20 20 28 65 6c 73 65 turn #f. (else
7180: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 63 75 72 . (let* ((cur
7190: 72 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 74 2d rhost (get-host-
71a0: 6e 61 6d 65 29 29 0a 09 20 20 20 28 62 65 73 74 name)).. (best
71b0: 61 64 72 73 20 28 73 65 72 76 65 72 3a 67 65 74 adrs (server:get
71c0: 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 -best-guess-addr
71d0: 65 73 73 20 63 75 72 72 68 6f 73 74 29 29 0a 09 ess currhost))..
71e0: 20 20 20 3b 3b 20 66 69 72 73 74 20 6c 6f 6f 6b ;; first look
71f0: 20 69 6e 20 63 6f 6e 66 69 67 2c 20 74 68 65 6e in config, then
7200: 20 6c 6f 6f 6b 20 69 6e 20 66 69 6c 65 20 2e 68 look in file .h
7210: 6f 6d 65 68 6f 73 74 2c 20 63 72 65 61 74 65 20 omehost, create
7220: 69 74 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a it if not found.
7230: 09 20 20 20 28 68 6f 6d 65 68 6f 73 74 20 28 6f . (homehost (o
7240: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
7250: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
7260: 65 72 76 65 72 22 20 22 68 6f 6d 65 68 6f 73 74 erver" "homehost
7270: 22 20 29 0a 09 09 09 20 28 6c 65 74 20 28 28 68 " ).... (let ((h
7280: 68 66 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 hf (conc *toppat
7290: 68 2a 20 22 2f 2e 68 6f 6d 65 68 6f 73 74 22 29 h* "/.homehost")
72a0: 29 29 0a 09 09 09 20 20 20 28 69 66 20 28 66 69 )).... (if (fi
72b0: 6c 65 2d 65 78 69 73 74 73 3f 20 68 68 66 29 0a le-exists? hhf).
72c0: 09 09 09 20 20 20 20 20 20 20 28 77 69 74 68 2d ... (with-
72d0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
72e0: 68 68 66 20 72 65 61 64 2d 6c 69 6e 65 29 0a 09 hhf read-line)..
72f0: 09 09 20 20 20 20 20 20 20 28 69 66 20 28 66 69 .. (if (fi
7300: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
7310: 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 09 09 *toppath*).....
7320: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 (begin.....
7330: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
7340: 74 6f 2d 66 69 6c 65 20 68 68 66 0a 09 09 09 09 to-file hhf.....
7350: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
7360: 29 0a 09 09 09 09 09 20 28 70 72 69 6e 74 20 62 )...... (print b
7370: 65 73 74 61 64 72 73 29 29 29 0a 09 09 09 09 20 estadrs))).....
7380: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
7390: 68 6f 6d 65 68 6f 73 74 29 29 0a 09 09 09 09 20 homehost)).....
73a0: 20 20 23 66 29 29 29 29 29 0a 09 20 20 20 28 61 #f))))).. (a
73b0: 74 2d 68 6f 6d 65 20 20 28 6f 72 20 28 65 71 75 t-home (or (equ
73c0: 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 63 75 72 al? homehost cur
73d0: 72 68 6f 73 74 29 0a 09 09 09 20 28 65 71 75 61 rhost).... (equa
73e0: 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 62 65 73 74 l? homehost best
73f0: 61 64 72 73 29 29 29 29 0a 20 20 20 20 20 20 28 adrs)))). (
7400: 73 65 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a set! *home-host*
7410: 20 28 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 74 20 (cons homehost
7420: 61 74 2d 68 6f 6d 65 29 29 0a 20 20 20 20 20 20 at-home)).
7430: 2a 68 6f 6d 65 2d 68 6f 73 74 2a 29 29 29 29 0a *home-host*)))).
7440: 0a 3b 3b 20 61 6d 20 49 20 6f 6e 20 74 68 65 20 .;; am I on the
7450: 68 6f 6d 65 68 6f 73 74 3f 0a 3b 3b 0a 28 64 65 homehost?.;;.(de
7460: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d fine (common:on-
7470: 68 6f 6d 65 68 6f 73 74 3f 29 0a 20 20 28 6c 65 homehost?). (le
7480: 74 20 28 28 68 68 20 28 63 6f 6d 6d 6f 6e 3a 67 t ((hh (common:g
7490: 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 29 0a 20 et-homehost))).
74a0: 20 20 20 28 69 66 20 68 68 0a 09 28 63 64 72 20 (if hh..(cdr
74b0: 68 68 29 0a 09 23 66 29 29 29 0a 0a 3b 3b 3d 3d hh)..#f)))..;;==
74c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7500: 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 43 20 ====.;; M I S C
7510: 20 20 4c 20 49 20 53 20 54 20 53 0a 3b 3b 3d 3d L I S T S.;;==
7520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7560: 3d 3d 3d 3d 0a 0a 3b 3b 20 69 74 65 6d 73 20 69 ====..;; items i
7570: 6e 20 6c 69 73 74 61 20 61 72 65 20 6d 61 74 63 n lista are matc
7580: 68 65 64 20 76 61 6c 75 65 20 61 6e 64 20 70 6f hed value and po
7590: 73 69 74 69 6f 6e 20 69 6e 20 6c 69 73 74 62 0a sition in listb.
75a0: 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 20 72 65 ;; return the re
75b0: 6d 61 69 6e 69 6e 67 20 69 74 65 6d 73 20 69 6e maining items in
75c0: 20 6c 69 73 74 62 20 6f 72 20 23 66 0a 3b 3b 0a listb or #f.;;.
75d0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
75e0: 6c 69 73 74 2d 69 73 2d 73 75 62 6c 69 73 74 20 list-is-sublist
75f0: 6c 69 73 74 61 20 6c 69 73 74 62 29 0a 20 20 28 lista listb). (
7600: 69 66 20 28 6e 75 6c 6c 3f 20 6c 69 73 74 61 29 if (null? lista)
7610: 0a 20 20 20 20 20 20 6c 69 73 74 62 20 3b 3b 20 . listb ;;
7620: 61 6c 6c 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 all items in lis
7630: 74 62 20 61 72 65 20 22 72 65 6d 61 69 6e 69 6e tb are "remainin
7640: 67 22 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 g". (if (>
7650: 28 6c 65 6e 67 74 68 20 6c 69 73 74 61 29 28 6c (length lista)(l
7660: 65 6e 67 74 68 20 6c 69 73 74 62 29 29 20 0a 09 ength listb)) ..
7670: 20 20 23 66 0a 09 20 20 28 6c 65 74 20 6c 6f 6f #f.. (let loo
7680: 70 20 28 28 68 65 64 61 20 28 63 61 72 20 6c 69 p ((heda (car li
7690: 73 74 61 29 29 0a 09 09 20 20 20 20 20 28 74 61 sta))... (ta
76a0: 6c 61 20 28 63 64 72 20 6c 69 73 74 61 29 29 0a la (cdr lista)).
76b0: 09 09 20 20 20 20 20 28 68 65 64 62 20 28 63 61 .. (hedb (ca
76c0: 72 20 6c 69 73 74 62 29 29 0a 09 09 20 20 20 20 r listb))...
76d0: 20 28 74 61 6c 62 20 28 63 64 72 20 6c 69 73 74 (talb (cdr list
76e0: 62 29 29 29 0a 09 20 20 20 20 28 69 66 20 28 65 b))).. (if (e
76f0: 71 75 61 6c 3f 20 68 65 64 61 20 68 65 64 62 29 qual? heda hedb)
7700: 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 ...(if (null? ta
7710: 6c 61 29 20 3b 3b 20 77 65 20 61 72 65 20 64 6f la) ;; we are do
7720: 6e 65 0a 09 09 20 20 20 20 74 61 6c 62 0a 09 09 ne... talb...
7730: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
7740: 61 6c 61 29 0a 09 09 09 20 20 28 63 64 72 20 74 ala).... (cdr t
7750: 61 6c 61 29 0a 09 09 09 20 20 28 63 61 72 20 74 ala).... (car t
7760: 61 6c 62 29 0a 09 09 09 20 20 28 63 64 72 20 74 alb).... (cdr t
7770: 61 6c 62 29 29 29 0a 09 09 23 66 29 29 29 29 29 alb)))...#f)))))
7780: 0a 0a 3b 3b 20 4e 65 65 64 65 64 20 66 6f 72 20 ..;; Needed for
7790: 6c 6f 6e 67 20 6c 69 73 74 73 20 74 6f 20 62 65 long lists to be
77a0: 20 73 6f 72 74 65 64 20 77 68 65 72 65 20 28 61 sorted where (a
77b0: 70 70 6c 79 20 6d 61 78 20 2e 2e 2e 20 29 20 64 pply max ... ) d
77c0: 69 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ies.;;.(define (
77d0: 63 6f 6d 6d 6f 6e 3a 6d 61 78 20 69 6e 6c 73 74 common:max inlst
77e0: 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
77f0: 6d 61 78 2d 76 61 6c 20 28 63 61 72 20 69 6e 6c max-val (car inl
7800: 73 74 29 29 0a 09 20 20 20 20 20 28 68 65 64 20 st)).. (hed
7810: 20 20 20 20 28 63 61 72 20 69 6e 6c 73 74 29 29 (car inlst))
7820: 0a 09 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 .. (tal
7830: 28 63 64 72 20 69 6e 6c 73 74 29 29 29 0a 20 20 (cdr inlst))).
7840: 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c (if (not (null
7850: 3f 20 74 61 6c 29 29 0a 09 28 6c 6f 6f 70 20 28 ? tal))..(loop (
7860: 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 max hed max-val)
7870: 0a 09 20 20 20 20 20 20 28 63 61 72 20 74 61 6c .. (car tal
7880: 29 0a 09 20 20 20 20 20 20 28 63 64 72 20 74 61 ).. (cdr ta
7890: 6c 29 29 0a 09 28 6d 61 78 20 68 65 64 20 6d 61 l))..(max hed ma
78a0: 78 2d 76 61 6c 29 29 29 29 0a 0a 3b 3b 20 67 65 x-val))))..;; ge
78b0: 74 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 75 73 t min or max, us
78c0: 65 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e 64 20 e > for max and
78d0: 3c 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 73 20 < for min, this
78e0: 77 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 68 65 works around the
78f0: 20 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 6c 79 limits on apply
7900: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
7910: 6d 6f 6e 3a 6d 69 6e 2d 6d 61 78 20 63 6f 6d 70 mon:min-max comp
7920: 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6e 75 6c lst). (if (nul
7930: 6c 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 23 66 l? lst). #f
7940: 20 3b 3b 20 62 65 74 74 65 72 20 74 68 61 6e 20 ;; better than
7950: 61 6e 20 65 78 63 65 70 74 69 6f 6e 20 66 6f 72 an exception for
7960: 20 6d 79 20 6e 65 65 64 73 0a 20 20 20 20 20 20 my needs.
7970: 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 (fold (lambda (a
7980: 20 62 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 b).. (if (
7990: 63 6f 6d 70 20 61 20 62 29 20 61 20 62 29 29 0a comp a b) a b)).
79a0: 09 20 20 20 20 28 63 61 72 20 6c 73 74 29 0a 09 . (car lst)..
79b0: 20 20 20 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 70 lst)))..;; p
79c0: 61 74 68 20 6c 69 73 74 20 74 6f 20 68 61 73 68 ath list to hash
79d0: 2d 74 61 62 6c 65 20 74 72 65 65 0a 3b 3b 20 20 -table tree.;;
79e0: 20 28 28 61 20 62 20 63 29 28 61 20 62 20 64 29 ((a b c)(a b d)
79f0: 28 65 20 62 20 63 29 29 20 3d 3e 20 28 28 61 20 (e b c)) => ((a
7a00: 28 62 20 28 64 29 20 28 63 29 29 29 20 28 65 20 (b (d) (c))) (e
7a10: 28 62 20 28 63 29 29 29 29 0a 3b 3b 0a 28 64 65 (b (c)))).;;.(de
7a20: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 fine (common:lis
7a30: 74 2d 3e 68 74 72 65 65 20 6c 73 74 29 0a 20 20 t->htree lst).
7a40: 28 6c 65 74 20 28 28 72 65 73 68 20 28 6d 61 6b (let ((resh (mak
7a50: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
7a60: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
7a70: 20 20 20 28 6c 61 6d 62 64 61 20 28 69 6e 6c 73 (lambda (inls
7a80: 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 6c t). (let l
7a90: 6f 6f 70 20 28 28 68 74 20 20 72 65 73 68 29 0a oop ((ht resh).
7aa0: 09 09 20 20 28 68 65 64 20 28 63 61 72 20 69 6e .. (hed (car in
7ab0: 6c 73 74 29 29 0a 09 09 20 20 28 74 61 6c 20 28 lst))... (tal (
7ac0: 63 64 72 20 69 6e 6c 73 74 29 29 29 0a 09 20 28 cdr inlst))).. (
7ad0: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 if (hash-table-r
7ae0: 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 68 65 ef/default ht he
7af0: 64 20 23 66 29 0a 09 20 20 20 20 20 28 69 66 20 d #f).. (if
7b00: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
7b10: 29 0a 09 09 20 28 6c 6f 6f 70 20 28 68 61 73 68 )... (loop (hash
7b20: 2d 74 61 62 6c 65 2d 72 65 66 20 68 74 20 68 65 -table-ref ht he
7b30: 64 29 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 d)... (car
7b40: 20 74 61 6c 29 0a 09 09 20 20 20 20 20 20 20 28 tal)... (
7b50: 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 20 20 cdr tal)))..
7b60: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
7b70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
7b80: 20 68 74 20 68 65 64 20 28 6d 61 6b 65 2d 68 61 ht hed (make-ha
7b90: 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 20 sh-table))..
7ba0: 20 20 20 28 6c 6f 6f 70 20 68 74 20 68 65 64 20 (loop ht hed
7bb0: 74 61 6c 29 29 29 29 29 0a 20 20 20 20 20 6c 73 tal))))). ls
7bc0: 74 29 0a 20 20 20 20 72 65 73 68 29 29 0a 0a 3b t). resh))..;
7bd0: 3b 20 68 61 73 68 2d 74 61 62 6c 65 20 74 72 65 ; hash-table tre
7be0: 65 20 74 6f 20 68 74 6d 6c 20 6c 69 73 74 20 74 e to html list t
7bf0: 72 65 65 0a 3b 3b 0a 3b 3b 20 20 20 74 69 70 66 ree.;;.;; tipf
7c00: 75 6e 63 20 74 61 6b 65 73 20 74 77 6f 20 70 61 unc takes two pa
7c10: 72 61 6d 65 74 65 72 73 3a 20 79 20 74 68 65 20 rameters: y the
7c20: 74 69 70 20 76 61 6c 75 65 20 61 6e 64 20 70 61 tip value and pa
7c30: 74 68 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 th the path to t
7c40: 68 61 74 20 70 6f 69 6e 74 0a 3b 3b 0a 28 64 65 hat point.;;.(de
7c50: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 fine (common:htr
7c60: 65 65 2d 3e 68 74 6d 6c 20 68 74 20 70 61 74 68 ee->html ht path
7c70: 20 74 69 70 66 75 6e 63 29 0a 20 20 28 6c 65 74 tipfunc). (let
7c80: 20 28 28 64 61 74 6c 69 73 74 20 09 28 73 6f 72 ((datlist .(sor
7c90: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 t (hash-table->a
7ca0: 6c 69 73 74 20 68 74 29 0a 20 20 20 20 20 20 20 list ht).
7cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cc0: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
7cd0: 61 20 62 29 0a 20 20 20 20 20 20 20 20 20 20 20 a b).
7ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cf0: 20 20 20 20 20 28 73 74 72 69 6e 67 3c 20 28 63 (string< (c
7d00: 61 72 20 61 29 28 63 61 72 20 62 29 29 29 29 29 ar a)(car b)))))
7d10: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
7d20: 20 64 61 74 6c 69 73 74 29 0a 20 20 20 20 09 28 datlist). .(
7d30: 74 69 70 66 75 6e 63 20 23 66 20 70 61 74 68 29 tipfunc #f path)
7d40: 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f 75 6c ;; really shoul
7d50: 64 6e 27 74 20 67 65 74 20 68 65 72 65 0a 09 28 dn't get here..(
7d60: 73 3a 75 6c 0a 09 20 28 6d 61 70 20 28 6c 61 6d s:ul.. (map (lam
7d70: 62 64 61 20 28 78 29 0a 09 09 28 6c 65 74 2a 20 bda (x)...(let*
7d80: 28 28 6c 65 76 65 6c 6e 61 6d 65 20 28 63 61 72 ((levelname (car
7d90: 20 78 29 29 0a 09 09 20 20 20 20 20 20 20 28 79 x))... (y
7da0: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 78 29 (cdr x)
7db0: 29 0a 09 09 20 20 20 20 20 20 20 28 6e 65 77 70 )... (newp
7dc0: 61 74 68 20 20 20 28 61 70 70 65 6e 64 20 70 61 ath (append pa
7dd0: 74 68 20 28 6c 69 73 74 20 6c 65 76 65 6c 6e 61 th (list levelna
7de0: 6d 65 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 me)))... (
7df0: 6c 65 61 66 20 20 20 20 20 20 28 6f 72 20 28 6e leaf (or (n
7e00: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 ot (hash-table?
7e10: 79 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 6e y))..... (n
7e20: 75 6c 6c 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 ull? (hash-table
7e30: 2d 6b 65 79 73 20 79 29 29 29 29 29 0a 09 09 20 -keys y)))))...
7e40: 20 28 69 66 20 6c 65 61 66 0a 09 09 20 20 20 20 (if leaf...
7e50: 20 20 28 73 3a 6c 69 20 28 74 69 70 66 75 6e 63 (s:li (tipfunc
7e60: 20 79 20 6e 65 77 70 61 74 68 29 29 0a 09 09 20 y newpath))...
7e70: 20 20 20 20 20 28 73 3a 6c 69 0a 09 09 20 20 20 (s:li...
7e80: 20 20 20 20 28 6c 69 73 74 20 0a 09 09 09 6c 65 (list ....le
7e90: 76 65 6c 6e 61 6d 65 0a 09 09 09 28 63 6f 6d 6d velname....(comm
7ea0: 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 79 on:htree->html y
7eb0: 20 6e 65 77 70 61 74 68 20 74 69 70 66 75 6e 63 newpath tipfunc
7ec0: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 64 61 )))))).. da
7ed0: 74 6c 69 73 74 29 29 29 29 29 0a 0a 3b 3b 20 68 tlist)))))..;; h
7ee0: 61 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 ash-table tree t
7ef0: 6f 20 61 6c 69 73 74 20 74 72 65 65 0a 3b 3b 0a o alist tree.;;.
7f00: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
7f10: 68 74 72 65 65 2d 3e 61 74 72 65 65 20 68 74 29 htree->atree ht)
7f20: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
7f30: 28 78 29 0a 09 20 28 63 6f 6e 73 20 28 63 61 72 (x).. (cons (car
7f40: 20 78 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 x).. (let
7f50: 20 28 28 79 20 28 63 64 72 20 78 29 29 29 0a 09 ((y (cdr x)))..
7f60: 09 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c . (if (hash-tabl
7f70: 65 3f 20 79 29 0a 09 09 20 20 20 20 20 28 63 6f e? y)... (co
7f80: 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 61 74 72 65 mmon:htree->atre
7f90: 65 20 79 29 0a 09 09 20 20 20 20 20 79 29 29 29 e y)... y)))
7fa0: 29 0a 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 ). (hash-t
7fb0: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 74 29 29 able->alist ht))
7fc0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
7fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d ===========.;; M
8010: 20 55 20 4e 20 47 20 45 20 20 20 44 20 41 20 54 U N G E D A T
8020: 20 41 20 20 20 49 20 4e 20 54 20 4f 20 20 20 4e A I N T O N
8030: 20 49 20 43 20 45 20 20 20 46 20 4f 20 52 20 4d I C E F O R M
8040: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
8050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
8090: 47 65 6e 65 72 61 74 65 20 61 6e 20 69 6e 64 65 Generate an inde
80a0: 78 20 66 6f 72 20 61 20 73 70 61 72 73 65 20 6c x for a sparse l
80b0: 69 73 74 20 6f 66 20 6b 65 79 20 76 61 6c 75 65 ist of key value
80c0: 73 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e 61 6d s.;; ( (rownam
80d0: 65 31 20 63 6f 6c 6e 61 6d 65 31 20 76 61 6c 31 e1 colname1 val1
80e0: 29 28 72 6f 77 6e 61 6d 65 32 20 63 6f 6c 6e 61 )(rowname2 colna
80f0: 6d 65 32 20 76 61 6c 32 29 20 29 0a 3b 3b 0a 3b me2 val2) ).;;.;
8100: 3b 20 3d 3e 20 0a 3b 3b 0a 3b 3b 20 20 20 28 20 ; => .;;.;; (
8110: 28 72 6f 77 6e 61 6d 65 31 20 30 29 28 72 6f 77 (rowname1 0)(row
8120: 6e 61 6d 65 32 20 31 29 29 20 20 20 20 3b 3b 20 name2 1)) ;;
8130: 72 6f 77 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a rownames -> num.
8140: 3b 3b 20 20 20 20 20 28 63 6f 6c 6e 61 6d 65 31 ;; (colname1
8150: 20 30 29 28 63 6f 6c 6e 61 6d 65 32 20 31 29 29 0)(colname2 1))
8160: 20 29 20 20 3b 3b 20 63 6f 6c 6e 61 6d 65 73 20 ) ;; colnames
8170: 2d 3e 20 6e 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 -> num.;; .;; op
8180: 74 69 6f 6e 61 6c 20 61 70 70 6c 79 20 70 72 6f tional apply pro
8190: 63 20 74 6f 20 72 6f 77 6e 75 6d 20 63 6f 6c 6e c to rownum coln
81a0: 75 6d 20 76 61 6c 75 65 0a 28 64 65 66 69 6e 65 um value.(define
81b0: 20 28 63 6f 6d 6d 6f 6e 3a 73 70 61 72 73 65 2d (common:sparse-
81c0: 6c 69 73 74 2d 67 65 6e 65 72 61 74 65 2d 69 6e list-generate-in
81d0: 64 65 78 20 64 61 74 61 20 23 21 6b 65 79 20 28 dex data #!key (
81e0: 70 72 6f 63 20 23 66 29 29 0a 20 20 28 69 66 20 proc #f)). (if
81f0: 28 6e 75 6c 6c 3f 20 64 61 74 61 29 0a 20 20 20 (null? data).
8200: 20 20 20 28 6c 69 73 74 20 27 28 29 20 27 28 29 (list '() '()
8210: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ). (let loo
8220: 70 20 28 28 68 65 64 20 28 63 61 72 20 64 61 74 p ((hed (car dat
8230: 61 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 a))... (tal (cdr
8240: 20 64 61 74 61 29 29 0a 09 09 20 28 72 6f 77 6e data))... (rown
8250: 61 6d 65 73 20 27 28 29 29 0a 09 09 20 28 63 6f ames '())... (co
8260: 6c 6e 61 6d 65 73 20 27 28 29 29 0a 09 09 20 28 lnames '())... (
8270: 72 6f 77 6e 75 6d 20 20 20 30 29 0a 09 09 20 28 rownum 0)... (
8280: 63 6f 6c 6e 75 6d 20 20 20 30 29 29 0a 09 28 6c colnum 0))..(l
8290: 65 74 2a 20 28 28 72 6f 77 6b 65 79 20 20 20 20 et* ((rowkey
82a0: 20 20 20 20 20 20 28 63 61 72 20 20 20 68 65 64 (car hed
82b0: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6c 6b )).. (colk
82c0: 65 79 20 20 20 20 20 20 20 20 20 20 28 63 61 64 ey (cad
82d0: 72 20 20 68 65 64 29 29 0a 09 20 20 20 20 20 20 r hed))..
82e0: 20 28 76 61 6c 75 65 20 20 20 20 20 20 20 20 20 (value
82f0: 20 20 28 63 61 64 64 72 20 68 65 64 29 29 0a 09 (caddr hed))..
8300: 20 20 20 20 20 20 20 28 65 78 69 73 74 69 6e 67 (existing
8310: 2d 72 6f 77 64 61 74 20 28 61 73 73 6f 63 20 72 -rowdat (assoc r
8320: 6f 77 6b 65 79 20 72 6f 77 6e 61 6d 65 73 29 29 owkey rownames))
8330: 0a 09 20 20 20 20 20 20 20 28 65 78 69 73 74 69 .. (existi
8340: 6e 67 2d 63 6f 6c 64 61 74 20 28 61 73 73 6f 63 ng-coldat (assoc
8350: 20 63 6f 6c 6b 65 79 20 63 6f 6c 6e 61 6d 65 73 colkey colnames
8360: 29 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 )).. (curr
8370: 2d 72 6f 77 6e 75 6d 20 20 20 20 20 28 69 66 20 -rownum (if
8380: 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 20 existing-rowdat
8390: 72 6f 77 6e 75 6d 20 28 2b 20 72 6f 77 6e 75 6d rownum (+ rownum
83a0: 20 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 63 1))).. (c
83b0: 75 72 72 2d 63 6f 6c 6e 75 6d 20 20 20 20 20 28 urr-colnum (
83c0: 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 if existing-cold
83d0: 61 74 20 63 6f 6c 6e 75 6d 20 28 2b 20 63 6f 6c at colnum (+ col
83e0: 6e 75 6d 20 31 29 29 29 0a 09 20 20 20 20 20 20 num 1)))..
83f0: 20 28 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 20 (new-rownames
8400: 20 20 28 69 66 20 65 78 69 73 74 69 6e 67 2d 72 (if existing-r
8410: 6f 77 64 61 74 20 72 6f 77 6e 61 6d 65 73 20 28 owdat rownames (
8420: 63 6f 6e 73 20 28 6c 69 73 74 20 72 6f 77 6b 65 cons (list rowke
8430: 79 20 63 75 72 72 2d 72 6f 77 6e 75 6d 29 20 72 y curr-rownum) r
8440: 6f 77 6e 61 6d 65 73 29 29 29 0a 09 20 20 20 20 ownames)))..
8450: 20 20 20 28 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 (new-colnames
8460: 20 20 20 20 28 69 66 20 65 78 69 73 74 69 6e 67 (if existing
8470: 2d 63 6f 6c 64 61 74 20 63 6f 6c 6e 61 6d 65 73 -coldat colnames
8480: 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 63 6f 6c (cons (list col
8490: 6b 65 79 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 29 key curr-colnum)
84a0: 20 63 6f 6c 6e 61 6d 65 73 29 29 29 29 0a 09 20 colnames))))..
84b0: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
84c0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
84d0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 72 6f 63 -log-port* "Proc
84e0: 65 73 73 69 6e 67 20 72 65 63 6f 72 64 3a 20 22 essing record: "
84f0: 20 68 65 64 20 29 0a 09 20 20 28 69 66 20 70 72 hed ).. (if pr
8500: 6f 63 20 28 70 72 6f 63 20 63 75 72 72 2d 72 6f oc (proc curr-ro
8510: 77 6e 75 6d 20 63 75 72 72 2d 63 6f 6c 6e 75 6d wnum curr-colnum
8520: 20 72 6f 77 6b 65 79 20 63 6f 6c 6b 65 79 20 76 rowkey colkey v
8530: 61 6c 75 65 29 29 0a 09 20 20 28 69 66 20 28 6e alue)).. (if (n
8540: 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 20 ull? tal)..
8550: 20 28 6c 69 73 74 20 6e 65 77 2d 72 6f 77 6e 61 (list new-rowna
8560: 6d 65 73 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 mes new-colnames
8570: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ).. (loop (
8580: 63 61 72 20 74 61 6c 29 0a 09 09 20 20 20 20 28 car tal)... (
8590: 63 64 72 20 74 61 6c 29 0a 09 09 20 20 20 20 6e cdr tal)... n
85a0: 65 77 2d 72 6f 77 6e 61 6d 65 73 0a 09 09 20 20 ew-rownames...
85b0: 20 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 0a 09 new-colnames..
85c0: 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 72 . (if (> curr
85d0: 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 20 -rownum rownum)
85e0: 63 75 72 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e curr-rownum rown
85f0: 75 6d 29 0a 09 09 20 20 20 20 28 69 66 20 28 3e um)... (if (>
8600: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c curr-colnum col
8610: 6e 75 6d 29 20 63 75 72 72 2d 63 6f 6c 6e 75 6d num) curr-colnum
8620: 20 63 6f 6c 6e 75 6d 29 0a 09 09 20 20 20 20 29 colnum)... )
8630: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
8640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a ===============.
8680: 3b 3b 20 53 20 59 20 53 20 54 20 45 20 4d 20 20 ;; S Y S T E M
8690: 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d S T U F F.;;===
86a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86e0: 3d 3d 3d 0a 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 ===..;; lazy-saf
86f0: 65 20 67 65 74 20 66 69 6c 65 20 6d 6f 64 20 74 e get file mod t
8700: 69 6d 65 2e 20 6f 6e 20 61 6e 79 20 65 72 72 6f ime. on any erro
8710: 72 20 28 66 69 6c 65 20 6e 6f 74 20 65 78 69 73 r (file not exis
8720: 74 69 6e 67 20 65 74 63 2e 29 20 72 65 74 75 72 ting etc.) retur
8730: 6e 20 30 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 n 0.;;.(define (
8740: 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 common:lazy-modi
8750: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 fication-time fp
8760: 61 74 68 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 ath). (handle-e
8770: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e xceptions. exn
8780: 0a 20 20 20 30 0a 20 20 20 28 66 69 6c 65 2d 6d . 0. (file-m
8790: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
87a0: 20 66 70 61 74 68 29 29 29 0a 0a 3b 3b 20 72 65 fpath)))..;; re
87b0: 74 75 72 6e 20 61 20 6e 69 63 65 20 63 6c 65 61 turn a nice clea
87c0: 6e 20 70 61 74 68 6e 61 6d 65 20 6d 61 64 65 20 n pathname made
87d0: 61 62 73 6f 6c 75 74 65 0a 28 64 65 66 69 6e 65 absolute.(define
87e0: 20 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 (common:nice-pa
87f0: 74 68 20 64 69 72 29 0a 20 20 28 6c 65 74 20 28 th dir). (let (
8800: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d (match (string-m
8810: 61 74 63 68 20 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a atch "^(~[^\\/]*
8820: 29 28 5c 5c 2f 2e 2a 7c 29 24 22 20 64 69 72 29 )(\\/.*|)$" dir)
8830: 29 29 0a 20 20 20 20 28 69 66 20 6d 61 74 63 68 )). (if match
8840: 20 3b 3b 20 75 73 69 6e 67 20 7e 20 66 6f 72 20 ;; using ~ for
8850: 68 6f 6d 65 3f 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e home?..(common:n
8860: 69 63 65 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 ice-path (conc (
8870: 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b common:read-link
8880: 2d 66 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 -f (cadr match))
8890: 20 22 2f 22 20 28 63 61 64 64 72 20 6d 61 74 63 "/" (caddr matc
88a0: 68 29 29 29 0a 09 28 6e 6f 72 6d 61 6c 69 7a 65 h)))..(normalize
88b0: 2d 70 61 74 68 6e 61 6d 65 20 28 69 66 20 28 61 -pathname (if (a
88c0: 62 73 6f 6c 75 74 65 2d 70 61 74 68 6e 61 6d 65 bsolute-pathname
88d0: 3f 20 64 69 72 29 0a 09 09 09 09 64 69 72 0a 09 ? dir).....dir..
88e0: 09 09 09 28 63 6f 6e 63 20 28 63 75 72 72 65 6e ...(conc (curren
88f0: 74 2d 64 69 72 65 63 74 6f 72 79 29 20 22 2f 22 t-directory) "/"
8900: 20 64 69 72 29 29 29 29 29 29 0a 0a 3b 3b 20 6d dir))))))..;; m
8910: 61 6b 65 20 22 6e 69 63 65 2d 70 61 74 68 22 20 ake "nice-path"
8920: 61 76 61 69 6c 61 62 6c 65 20 69 6e 20 63 6f 6e available in con
8930: 66 69 67 20 66 69 6c 65 73 20 61 6e 64 20 74 68 fig files and th
8940: 65 20 72 65 70 6c 0a 28 64 65 66 69 6e 65 20 6e e repl.(define n
8950: 69 63 65 2d 70 61 74 68 20 63 6f 6d 6d 6f 6e 3a ice-path common:
8960: 6e 69 63 65 2d 70 61 74 68 29 0a 0a 28 64 65 66 nice-path)..(def
8970: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 ine (common:read
8980: 2d 6c 69 6e 6b 2d 66 20 70 61 74 68 29 0a 20 20 -link-f path).
8990: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
89a0: 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 ns. exn.
89b0: 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 (begin..(debu
89c0: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
89d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
89e0: 74 2a 20 22 63 6f 6d 6d 61 6e 64 20 5c 22 2f 62 t* "command \"/b
89f0: 69 6e 2f 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 in/readlink -f "
8a00: 20 70 61 74 68 20 22 5c 22 20 66 61 69 6c 65 64 path "\" failed
8a10: 2e 22 29 0a 09 70 61 74 68 29 20 3b 3b 20 6a 75 .")..path) ;; ju
8a20: 73 74 20 67 69 76 65 20 75 70 0a 20 20 20 20 28 st give up. (
8a30: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
8a40: 70 69 70 65 0a 09 28 63 6f 6e 63 20 22 2f 62 69 pipe..(conc "/bi
8a50: 6e 2f 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 n/readlink -f "
8a60: 70 61 74 68 29 0a 20 20 20 20 20 20 28 6c 61 6d path). (lam
8a70: 62 64 61 20 28 29 0a 09 28 72 65 61 64 2d 6c 69 bda ()..(read-li
8a80: 6e 65 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ne)))))..(define
8a90: 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 23 (get-cpu-load #
8aa0: 21 6b 65 79 20 28 72 65 6d 6f 74 65 2d 68 6f 73 !key (remote-hos
8ab0: 74 20 23 66 29 29 0a 20 20 28 63 61 72 20 28 63 t #f)). (car (c
8ac0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f ommon:get-cpu-lo
8ad0: 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 ad remote-host))
8ae0: 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 6c ).;; (let* ((l
8af0: 6f 61 64 2d 72 65 73 20 28 70 72 6f 63 65 73 73 oad-res (process
8b00: 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 :cmd-run->list "
8b10: 75 70 74 69 6d 65 22 29 29 0a 3b 3b 20 09 20 28 uptime")).;; . (
8b20: 6c 6f 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 load-rx (regexp
8b30: 20 22 6c 6f 61 64 20 61 76 65 72 61 67 65 3a 5c "load average:\
8b40: 5c 73 2b 28 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 \s+(\\d+)")).;;
8b50: 09 20 28 63 70 75 2d 6c 6f 61 64 20 23 66 29 29 . (cpu-load #f))
8b60: 0a 3b 3b 20 20 20 20 20 28 66 6f 72 2d 65 61 63 .;; (for-eac
8b70: 68 20 28 6c 61 6d 62 64 61 20 28 6c 29 0a 3b 3b h (lambda (l).;;
8b80: 20 09 09 28 6c 65 74 20 28 28 6d 61 74 63 68 20 ..(let ((match
8b90: 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 6c (string-search l
8ba0: 6f 61 64 2d 72 78 20 6c 29 29 29 0a 3b 3b 20 09 oad-rx l))).;; .
8bb0: 09 20 20 28 69 66 20 6d 61 74 63 68 0a 3b 3b 20 . (if match.;;
8bc0: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e .. (let ((n
8bd0: 65 77 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e ewval (string->n
8be0: 75 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 umber (cadr matc
8bf0: 68 29 29 29 29 0a 3b 3b 20 09 09 09 28 69 66 20 h)))).;; ...(if
8c00: 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 (number? newval)
8c10: 0a 3b 3b 20 09 09 09 20 20 20 20 28 73 65 74 21 .;; ... (set!
8c20: 20 63 70 75 2d 6c 6f 61 64 20 6e 65 77 76 61 6c cpu-load newval
8c30: 29 29 29 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 )))))).;; .
8c40: 20 28 63 61 72 20 6c 6f 61 64 2d 72 65 73 29 29 (car load-res))
8c50: 0a 3b 3b 20 20 20 20 20 63 70 75 2d 6c 6f 61 64 .;; cpu-load
8c60: 29 29 0a 0a 3b 3b 20 67 65 74 20 63 70 75 20 6c ))..;; get cpu l
8c70: 6f 61 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 oad by reading f
8c80: 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 rom /proc/loadav
8c90: 67 2c 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 g, return all th
8ca0: 72 65 65 20 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 ree values.;;.(d
8cb0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
8cc0: 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 t-cpu-load remot
8cd0: 65 2d 68 6f 73 74 29 0a 20 20 28 69 66 20 72 65 e-host). (if re
8ce0: 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 20 20 20 mote-host.
8cf0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 65 (map (lambda (re
8d00: 73 29 0a 09 20 20 20 20 20 28 69 66 20 28 65 6f s).. (if (eo
8d10: 66 2d 6f 62 6a 65 63 74 3f 20 72 65 73 29 20 39 f-object? res) 9
8d20: 65 39 39 20 72 65 73 29 29 0a 09 20 20 20 28 77 e99 res)).. (w
8d30: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
8d40: 69 70 65 20 0a 09 20 20 20 20 28 63 6f 6e 63 20 ipe .. (conc
8d50: 22 73 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f "ssh " remote-ho
8d60: 73 74 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c st " cat /proc/l
8d70: 6f 61 64 61 76 67 22 29 0a 09 20 20 20 20 28 6c oadavg").. (l
8d80: 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 28 72 ambda ()(list (r
8d90: 65 61 64 29 28 72 65 61 64 29 28 72 65 61 64 29 ead)(read)(read)
8da0: 29 29 29 29 0a 20 20 20 20 20 20 28 77 69 74 68 )))). (with
8db0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
8dc0: 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 "/proc/loadavg"
8dd0: 20 0a 09 28 6c 61 6d 62 64 61 20 28 29 28 6c 69 ..(lambda ()(li
8de0: 73 74 20 28 72 65 61 64 29 28 72 65 61 64 29 28 st (read)(read)(
8df0: 72 65 61 64 29 29 29 29 29 29 0a 0a 28 64 65 66 read))))))..(def
8e00: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 ine (common:wait
8e10: 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 -for-cpuload max
8e20: 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 load numcpus wai
8e30: 74 64 65 6c 61 79 20 23 21 6b 65 79 20 28 63 6f tdelay #!key (co
8e40: 75 6e 74 20 31 30 30 30 29 20 28 6d 73 67 20 23 unt 1000) (msg #
8e50: 66 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 f)(remote-host #
8e60: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f f)). (let* ((lo
8e70: 61 64 61 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 adavg (common:ge
8e80: 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 t-cpu-load remot
8e90: 65 2d 68 6f 73 74 29 29 0a 09 20 28 66 69 72 73 e-host)).. (firs
8ea0: 74 20 20 20 28 63 61 72 20 6c 6f 61 64 61 76 67 t (car loadavg
8eb0: 29 29 0a 09 20 28 6e 65 78 74 20 20 20 20 28 63 )).. (next (c
8ec0: 61 64 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 adr loadavg))..
8ed0: 28 61 64 6a 6c 6f 61 64 20 28 2a 20 6d 61 78 6c (adjload (* maxl
8ee0: 6f 61 64 20 6e 75 6d 63 70 75 73 29 29 0a 09 20 oad numcpus))..
8ef0: 28 6c 6f 61 64 6a 6d 70 20 28 2d 20 66 69 72 73 (loadjmp (- firs
8f00: 74 20 6e 65 78 74 29 29 29 0a 20 20 20 20 28 63 t next))). (c
8f10: 6f 6e 64 0a 20 20 20 20 20 28 28 61 6e 64 20 28 ond. ((and (
8f20: 3e 20 66 69 72 73 74 20 61 64 6a 6c 6f 61 64 29 > first adjload)
8f30: 0a 09 20 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 .. (> count 0)
8f40: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
8f50: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
8f60: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
8f70: 77 61 69 74 69 6e 67 20 22 20 77 61 69 74 64 65 waiting " waitde
8f80: 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 20 64 75 lay " seconds du
8f90: 65 20 74 6f 20 6c 6f 61 64 20 22 20 66 69 72 73 e to load " firs
8fa0: 74 20 22 20 65 78 63 65 65 64 69 6e 67 20 6d 61 t " exceeding ma
8fb0: 78 20 6f 66 20 22 20 61 64 6a 6c 6f 61 64 20 28 x of " adjload (
8fc0: 69 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 0a if msg msg "")).
8fd0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
8fe0: 65 65 70 21 20 77 61 69 74 64 65 6c 61 79 29 0a eep! waitdelay).
8ff0: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 (common:wa
9000: 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d it-for-cpuload m
9010: 61 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 axload numcpus w
9020: 61 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 3a 20 aitdelay count:
9030: 28 2d 20 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 (- count 1))).
9040: 20 20 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 64 ((and (> load
9050: 6a 6d 70 20 6e 75 6d 63 70 75 73 29 0a 09 20 20 jmp numcpus)..
9060: 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 (> count 0)).
9070: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9080: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
9090: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
90a0: 69 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 20 ing " waitdelay
90b0: 22 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f " seconds due to
90c0: 20 6c 6f 61 64 20 6a 75 6d 70 20 22 20 6c 6f 61 load jump " loa
90d0: 64 6a 6d 70 20 22 20 3e 20 6e 75 6d 63 70 75 73 djmp " > numcpus
90e0: 20 22 20 6e 75 6d 63 70 75 73 20 28 69 66 20 6d " numcpus (if m
90f0: 73 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 20 sg msg "")).
9100: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
9110: 20 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 20 waitdelay).
9120: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 (common:wait-f
9130: 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f or-cpuload maxlo
9140: 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 ad numcpus waitd
9150: 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 elay count: (- c
9160: 6f 75 6e 74 20 31 29 29 29 29 29 29 0a 0a 28 64 ount 1))))))..(d
9170: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
9180: 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 t-num-cpus remot
9190: 65 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 20 28 e-host). (let (
91a0: 28 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 29 (proc (lambda ()
91b0: 0a 09 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e ...(let loop ((n
91c0: 75 6d 63 70 75 20 30 29 0a 09 09 09 20 20 20 28 umcpu 0).... (
91d0: 69 6e 6c 20 20 20 20 28 72 65 61 64 2d 6c 69 6e inl (read-lin
91e0: 65 29 29 29 0a 09 09 20 20 28 69 66 20 28 65 6f e)))... (if (eo
91f0: 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 f-object? inl)..
9200: 09 20 20 20 20 20 20 6e 75 6d 63 70 75 0a 09 09 . numcpu...
9210: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 69 66 20 (loop (if
9220: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e (string-match "^
9230: 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c processor\\s+:\\
9240: 73 2b 5c 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 09 s+\\d+$" inl)...
9250: 09 09 28 2b 20 6e 75 6d 63 70 75 20 31 29 0a 09 ..(+ numcpu 1)..
9260: 09 09 09 6e 75 6d 63 70 75 29 0a 09 09 09 20 20 ...numcpu)....
9270: 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 (read-line))))
9280: 29 29 29 0a 20 20 20 20 28 69 66 20 72 65 6d 6f ))). (if remo
9290: 74 65 2d 68 6f 73 74 0a 09 28 77 69 74 68 2d 69 te-host..(with-i
92a0: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a nput-from-pipe .
92b0: 09 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 72 . (conc "ssh " r
92c0: 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 74 emote-host " cat
92d0: 20 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 29 /proc/cpuinfo")
92e0: 0a 09 20 70 72 6f 63 29 0a 09 28 77 69 74 68 2d .. proc)..(with-
92f0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
9300: 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 20 "/proc/cpuinfo"
9310: 70 72 6f 63 29 29 29 29 0a 0a 3b 3b 20 77 61 69 proc))))..;; wai
9320: 74 20 66 6f 72 20 6e 6f 72 6d 61 6c 69 7a 65 64 t for normalized
9330: 20 63 70 75 20 6c 6f 61 64 20 74 6f 20 64 72 6f cpu load to dro
9340: 70 20 62 65 6c 6f 77 20 6d 61 78 6c 6f 61 64 0a p below maxload.
9350: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
9360: 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d on:wait-for-norm
9370: 61 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 6c alized-load maxl
9380: 6f 61 64 20 23 21 6b 65 79 20 28 6d 73 67 20 23 oad #!key (msg #
9390: 66 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 f)(remote-host #
93a0: 66 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d f)). (let ((num
93b0: 2d 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 -cpus (common:ge
93c0: 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 t-num-cpus remot
93d0: 65 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 28 63 e-host))). (c
93e0: 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 ommon:wait-for-c
93f0: 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e puload maxload n
9400: 75 6d 2d 63 70 75 73 20 31 35 20 6d 73 67 3a 20 um-cpus 15 msg:
9410: 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 msg)))..(define
9420: 28 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 61 72 (get-uname . par
9430: 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 ams). (let* ((u
9440: 6e 61 6d 65 2d 72 65 73 20 28 70 72 6f 63 65 73 name-res (proces
9450: 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 s:cmd-run->list
9460: 28 63 6f 6e 63 20 22 75 6e 61 6d 65 20 22 20 28 (conc "uname " (
9470: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 if (null? params
9480: 29 20 22 2d 61 22 20 28 63 61 72 20 70 61 72 61 ) "-a" (car para
9490: 6d 73 29 29 29 29 29 0a 09 20 28 75 6e 61 6d 65 ms))))).. (uname
94a0: 20 23 66 29 29 0a 20 20 20 20 28 69 66 20 28 6e #f)). (if (n
94b0: 75 6c 6c 3f 20 28 63 61 72 20 75 6e 61 6d 65 2d ull? (car uname-
94c0: 72 65 73 29 29 0a 09 22 75 6e 6b 6e 6f 77 6e 22 res)).."unknown"
94d0: 0a 09 28 63 61 61 72 20 75 6e 61 6d 65 2d 72 65 ..(caar uname-re
94e0: 73 29 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 72 65 s))))..;; for re
94f0: 61 73 6f 6e 73 20 49 20 64 6f 6e 27 74 20 75 6e asons I don't un
9500: 64 65 72 73 74 61 6e 64 20 6d 75 6c 74 69 70 6c derstand multipl
9510: 65 20 63 61 6c 6c 73 20 74 6f 20 72 65 61 6c 2d e calls to real-
9520: 70 61 74 68 20 69 6e 20 70 61 72 61 6c 6c 65 6c path in parallel
9530: 20 74 68 72 65 61 64 73 0a 3b 3b 20 6d 75 73 74 threads.;; must
9540: 20 62 65 20 70 72 6f 74 65 63 74 65 64 20 62 79 be protected by
9550: 20 6d 75 74 65 78 65 73 0a 3b 3b 0a 28 64 65 66 mutexes.;;.(def
9560: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c ine (common:real
9570: 2d 70 61 74 68 20 69 6e 70 61 74 68 29 0a 20 20 -path inpath).
9580: 3b 3b 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d ;; (process:cmd-
9590: 72 75 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 2d run-with-stderr-
95a0: 3e 6c 69 73 74 20 22 72 65 61 64 6c 69 6e 6b 22 >list "readlink"
95b0: 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 20 3b "-f" inpath)) ;
95c0: 3b 20 63 6d 64 20 2e 20 70 61 72 61 6d 73 29 0a ; cmd . params).
95d0: 20 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 65 73 ;; (let-values
95e0: 20 0a 20 20 3b 3b 20 20 28 28 28 69 6e 70 20 6f . ;; (((inp o
95f0: 75 70 20 70 69 64 29 20 28 70 72 6f 63 65 73 73 up pid) (process
9600: 20 22 72 65 61 64 6c 69 6e 6b 22 20 28 6c 69 73 "readlink" (lis
9610: 74 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 29 t "-f" inpath)))
9620: 29 0a 20 20 3b 3b 20 20 28 77 69 74 68 2d 69 6e ). ;; (with-in
9630: 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e put-from-port in
9640: 70 0a 20 20 3b 3b 20 20 20 20 28 6c 65 74 20 6c p. ;; (let l
9650: 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 2d oop ((inl (read-
9660: 6c 69 6e 65 29 29 0a 20 20 3b 3b 20 20 20 20 20 line)). ;;
9670: 20 20 09 28 72 65 73 20 23 66 29 29 0a 20 20 3b .(res #f)). ;
9680: 3b 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 69 ; (print "i
9690: 6e 6c 3d 22 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 nl=" inl). ;;
96a0: 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a (if (eof-obj
96b0: 65 63 74 3f 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 ect? inl). ;;
96c0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
96d0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 ;; (
96e0: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
96f0: 20 69 6e 70 29 0a 20 20 3b 3b 20 20 20 20 20 20 inp). ;;
9700: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 (close-out
9710: 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 20 put-port oup).
9720: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;; ;;
9730: 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 (process-wait p
9740: 69 64 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 id). ;;
9750: 20 20 20 20 72 65 73 29 0a 20 20 3b 3b 20 20 20 res). ;;
9760: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 (loop (re
9770: 61 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 29 ad-line) inl))))
9780: 29 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 )). (with-input
9790: 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 -from-pipe (conc
97a0: 20 22 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 "readlink -f "
97b0: 69 6e 70 61 74 68 29 20 72 65 61 64 2d 6c 69 6e inpath) read-lin
97c0: 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d e))..;;=========
97d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
97f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
9810: 20 44 20 49 20 53 20 4b 20 20 20 53 20 50 20 41 D I S K S P A
9820: 20 43 20 45 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d C E .;;========
9830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
9870: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
9880: 67 65 74 2d 64 69 73 6b 2d 73 70 61 63 65 2d 75 get-disk-space-u
9890: 73 65 64 20 66 70 61 74 68 29 0a 20 20 28 77 69 sed fpath). (wi
98a0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
98b0: 70 65 20 28 63 6f 6e 63 20 22 2f 75 73 72 2f 62 pe (conc "/usr/b
98c0: 69 6e 2f 64 75 20 2d 73 20 22 20 66 70 61 74 68 in/du -s " fpath
98d0: 29 20 72 65 61 64 29 29 0a 0a 3b 3b 20 67 69 76 ) read))..;; giv
98e0: 65 6e 20 70 61 74 68 20 67 65 74 20 66 72 65 65 en path get free
98f0: 20 73 70 61 63 65 2c 20 61 6c 6c 6f 77 73 20 6f space, allows o
9900: 76 65 72 72 69 64 65 20 69 6e 20 5b 73 65 74 75 verride in [setu
9910: 70 5d 0a 3b 3b 20 77 69 74 68 20 66 72 65 65 2d p].;; with free-
9920: 73 70 61 63 65 2d 73 63 72 69 70 74 20 2f 70 61 space-script /pa
9930: 74 68 2f 74 6f 2f 73 6f 6d 65 2f 73 63 72 69 70 th/to/some/scrip
9940: 74 2e 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 t.sh.;;.(define
9950: 28 67 65 74 2d 64 66 20 70 61 74 68 29 0a 20 20 (get-df path).
9960: 28 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (if (configf:loo
9970: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
9980: 22 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 70 "setup" "free-sp
9990: 61 63 65 2d 73 63 72 69 70 74 22 29 0a 20 20 20 ace-script").
99a0: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
99b0: 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 20 20 rom-pipe .
99c0: 20 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 66 3a (conc (configf:
99d0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
99e0: 74 2a 20 22 73 65 74 75 70 22 20 22 66 72 65 65 t* "setup" "free
99f0: 2d 73 70 61 63 65 2d 73 63 72 69 70 74 22 29 20 -space-script")
9a00: 22 20 22 20 70 61 74 68 29 0a 20 20 20 20 20 20 " " path).
9a10: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 6c (lambda ().. (l
9a20: 65 74 20 28 28 72 65 73 20 28 72 65 61 64 2d 6c et ((res (read-l
9a30: 69 6e 65 29 29 29 0a 09 20 20 20 28 69 66 20 28 ine))).. (if (
9a40: 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 20 20 string? res)..
9a50: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
9a60: 6d 62 65 72 20 72 65 73 29 29 29 29 29 0a 20 20 mber res))))).
9a70: 20 20 20 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 (get-unix-df
9a80: 20 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e path)))..(defin
9a90: 65 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 70 e (get-unix-df p
9aa0: 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 ath). (let* ((d
9ab0: 66 2d 72 65 73 75 6c 74 73 20 28 70 72 6f 63 65 f-results (proce
9ac0: 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 ss:cmd-run->list
9ad0: 20 28 63 6f 6e 63 20 22 64 66 20 22 20 70 61 74 (conc "df " pat
9ae0: 68 29 29 29 0a 09 20 28 73 70 61 63 65 2d 72 78 h))).. (space-rx
9af0: 20 20 20 28 72 65 67 65 78 70 20 22 28 5b 30 2d (regexp "([0-
9b00: 39 5d 2b 29 5c 5c 73 2b 28 5b 30 2d 39 5d 2b 29 9]+)\\s+([0-9]+)
9b10: 25 22 29 29 0a 09 20 28 66 72 65 65 73 70 63 20 %")).. (freespc
9b20: 20 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 28 #f)). ;; (
9b30: 77 72 69 74 65 20 64 66 2d 72 65 73 75 6c 74 73 write df-results
9b40: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
9b50: 28 6c 61 6d 62 64 61 20 28 6c 29 0a 09 09 28 6c (lambda (l)...(l
9b60: 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 et ((match (stri
9b70: 6e 67 2d 73 65 61 72 63 68 20 73 70 61 63 65 2d ng-search space-
9b80: 72 78 20 6c 29 29 29 0a 09 09 20 20 28 69 66 20 rx l)))... (if
9b90: 6d 61 74 63 68 20 0a 09 09 20 20 20 20 20 20 28 match ... (
9ba0: 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 74 let ((newval (st
9bb0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 ring->number (ca
9bc0: 64 72 20 6d 61 74 63 68 29 29 29 29 0a 09 09 09 dr match))))....
9bd0: 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 65 77 (if (number? new
9be0: 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 74 val).... (set
9bf0: 21 20 66 72 65 65 73 70 63 20 6e 65 77 76 61 6c ! freespc newval
9c00: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 63 )))))).. (c
9c10: 61 72 20 64 66 2d 72 65 73 75 6c 74 73 29 29 0a ar df-results)).
9c20: 20 20 20 20 66 72 65 65 73 70 63 29 29 0a 0a 28 freespc))..(
9c30: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 define (common:c
9c40: 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 heck-space-in-di
9c50: 72 20 64 69 72 70 61 74 68 20 72 65 71 75 69 72 r dirpath requir
9c60: 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 ed). (let* ((db
9c70: 73 70 61 63 65 20 20 28 69 66 20 28 64 69 72 65 space (if (dire
9c80: 63 74 6f 72 79 3f 20 64 69 72 70 61 74 68 29 0a ctory? dirpath).
9c90: 09 09 20 20 20 20 20 20 20 28 67 65 74 2d 64 66 .. (get-df
9ca0: 20 64 69 72 70 61 74 68 29 0a 09 09 20 20 20 20 dirpath)...
9cb0: 20 20 20 30 29 29 29 0a 20 20 20 20 28 6c 69 73 0))). (lis
9cc0: 74 20 28 3e 20 64 62 73 70 61 63 65 20 72 65 71 t (> dbspace req
9cd0: 75 69 72 65 64 29 0a 09 20 20 64 62 73 70 61 63 uired).. dbspac
9ce0: 65 0a 09 20 20 72 65 71 75 69 72 65 64 0a 09 20 e.. required..
9cf0: 20 64 69 72 70 61 74 68 29 29 29 0a 0a 3b 3b 20 dirpath)))..;;
9d00: 63 68 65 63 6b 20 73 70 61 63 65 20 69 6e 20 64 check space in d
9d10: 62 64 69 72 20 61 6e 64 20 69 6e 20 6d 65 67 61 bdir and in mega
9d20: 74 65 73 74 20 64 69 72 0a 3b 3b 20 72 65 74 75 test dir.;; retu
9d30: 72 6e 73 3a 20 6f 6b 2f 6e 6f 74 20 64 62 73 70 rns: ok/not dbsp
9d40: 61 63 65 20 72 65 71 75 69 72 65 64 2d 73 70 61 ace required-spa
9d50: 63 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ce.;;.(define (c
9d60: 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 ommon:check-db-d
9d70: 69 72 2d 73 70 61 63 65 29 0a 20 20 28 6c 65 74 ir-space). (let
9d80: 2a 20 28 28 72 65 71 75 69 72 65 64 20 28 73 74 * ((required (st
9d90: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 09 09 ring->number ...
9da0: 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 (or (configf
9db0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
9dc0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 64 62 64 at* "setup" "dbd
9dd0: 69 72 2d 73 70 61 63 65 2d 72 65 71 75 69 72 65 ir-space-require
9de0: 64 22 29 0a 09 09 09 22 31 30 30 30 30 30 22 29 d")...."100000")
9df0: 29 29 0a 09 20 28 64 62 64 69 72 20 20 20 20 28 )).. (dbdir (
9e00: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d common:get-db-tm
9e10: 70 2d 61 72 65 61 29 29 20 3b 3b 20 28 64 62 3a p-area)) ;; (db:
9e20: 67 65 74 2d 64 62 64 69 72 29 29 0a 09 20 28 74 get-dbdir)).. (t
9e30: 64 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a dbspace (common:
9e40: 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 check-space-in-d
9e50: 69 72 20 64 62 64 69 72 20 72 65 71 75 69 72 65 ir dbdir require
9e60: 64 29 29 0a 09 20 28 6d 64 62 73 70 61 63 65 20 d)).. (mdbspace
9e70: 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 (common:check-sp
9e80: 61 63 65 2d 69 6e 2d 64 69 72 20 2a 74 6f 70 70 ace-in-dir *topp
9e90: 61 74 68 2a 20 72 65 71 75 69 72 65 64 29 29 29 ath* required)))
9ea0: 0a 20 20 20 20 28 73 6f 72 74 20 28 6c 69 73 74 . (sort (list
9eb0: 20 74 64 62 73 70 61 63 65 20 6d 64 62 73 70 61 tdbspace mdbspa
9ec0: 63 65 29 20 28 6c 61 6d 62 64 61 20 28 61 20 62 ce) (lambda (a b
9ed0: 29 0a 09 09 09 09 20 20 20 20 20 28 3c 20 28 63 )..... (< (c
9ee0: 61 64 72 20 61 29 28 63 61 64 72 20 62 29 29 29 adr a)(cadr b)))
9ef0: 29 29 29 0a 20 20 20 20 0a 3b 3b 20 63 68 65 63 ))). .;; chec
9f00: 6b 20 61 76 61 69 6c 61 62 6c 65 20 73 70 61 63 k available spac
9f10: 65 20 69 6e 20 64 62 64 69 72 2c 20 65 78 69 74 e in dbdir, exit
9f20: 20 69 66 20 69 6e 73 75 66 66 69 63 69 65 6e 74 if insufficient
9f30: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
9f40: 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 mon:check-db-dir
9f50: 2d 61 6e 64 2d 65 78 69 74 2d 69 66 2d 69 6e 73 -and-exit-if-ins
9f60: 75 66 66 69 63 69 65 6e 74 29 0a 20 20 28 6c 65 ufficient). (le
9f70: 74 2a 20 28 28 73 70 61 63 65 64 61 74 20 28 63 t* ((spacedat (c
9f80: 61 72 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b ar (common:check
9f90: 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 29 29 29 -db-dir-space)))
9fa0: 20 3b 3b 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 ;; look only at
9fb0: 20 77 6f 72 73 74 20 66 6f 72 20 6e 6f 77 0a 09 worst for now..
9fc0: 20 28 69 73 2d 6f 6b 20 20 20 20 28 63 61 72 20 (is-ok (car
9fd0: 73 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 62 spacedat)).. (db
9fe0: 73 70 61 63 65 20 20 28 63 61 64 72 20 73 70 61 space (cadr spa
9ff0: 63 65 64 61 74 29 29 0a 09 20 28 72 65 71 75 69 cedat)).. (requi
a000: 72 65 64 20 28 63 61 64 64 72 20 73 70 61 63 65 red (caddr space
a010: 64 61 74 29 29 0a 09 20 28 64 62 64 69 72 20 20 dat)).. (dbdir
a020: 20 20 28 63 61 64 64 64 72 20 73 70 61 63 65 64 (cadddr spaced
a030: 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e at))). (if (n
a040: 6f 74 20 69 73 2d 6f 6b 29 0a 09 28 62 65 67 69 ot is-ok)..(begi
a050: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
a060: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
a070: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e lt-log-port* "In
a080: 73 75 66 66 69 63 69 65 6e 74 20 73 70 61 63 65 sufficient space
a090: 20 69 6e 20 22 20 64 62 64 69 72 20 22 2c 20 72 in " dbdir ", r
a0a0: 65 71 75 69 72 65 20 22 20 72 65 71 75 69 72 65 equire " require
a0b0: 64 20 22 2c 20 68 61 76 65 20 22 20 64 62 73 70 d ", have " dbsp
a0c0: 61 63 65 20 20 22 2c 20 65 78 69 74 69 6e 67 20 ace ", exiting
a0d0: 6e 6f 77 2e 22 29 0a 09 20 20 28 65 78 69 74 20 now.").. (exit
a0e0: 31 29 29 29 29 29 0a 20 20 0a 3b 3b 20 70 61 74 1))))). .;; pat
a0f0: 68 73 20 69 73 20 6c 69 73 74 20 6f 66 20 6c 69 hs is list of li
a100: 73 74 73 20 28 28 6e 61 6d 65 20 70 61 74 68 29 sts ((name path)
a110: 20 2e 2e 2e 20 29 0a 3b 3b 0a 28 64 65 66 69 6e ... ).;;.(defin
a120: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 e (common:get-di
a130: 73 6b 2d 77 69 74 68 2d 6d 6f 73 74 2d 66 72 65 sk-with-most-fre
a140: 65 2d 73 70 61 63 65 20 64 69 73 6b 73 20 6d 69 e-space disks mi
a150: 6e 73 69 7a 65 29 0a 20 20 28 6c 65 74 20 28 28 nsize). (let ((
a160: 62 65 73 74 20 20 20 20 20 23 66 29 0a 09 28 62 best #f)..(b
a170: 65 73 74 73 69 7a 65 20 30 29 29 0a 20 20 20 20 estsize 0)).
a180: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
a190: 28 6c 61 6d 62 64 61 20 28 64 69 73 6b 2d 6e 75 (lambda (disk-nu
a1a0: 6d 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 m). (let*
a1b0: 28 28 64 69 72 70 61 74 68 20 20 20 20 28 63 61 ((dirpath (ca
a1c0: 64 72 20 28 61 73 73 6f 63 20 64 69 73 6b 2d 6e dr (assoc disk-n
a1d0: 75 6d 20 64 69 73 6b 73 29 29 29 0a 09 20 20 20 um disks)))..
a1e0: 20 20 20 28 66 72 65 65 73 70 63 20 20 20 20 28 (freespc (
a1f0: 63 6f 6e 64 0a 09 09 09 20 20 20 28 28 6e 6f 74 cond.... ((not
a200: 20 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 72 (directory? dir
a210: 70 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 path)).... (i
a220: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
a230: 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 ise-print 300 "d
a240: 69 73 6b 73 20 6e 6f 74 20 61 20 64 69 72 20 22 isks not a dir "
a250: 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 disk-num).....(
a260: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
a270: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
a280: 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 "WARNING: disk
a290: 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 " disk-num " at
a2a0: 70 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 path \"" dirpath
a2b0: 20 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 64 69 "\" is not a di
a2c0: 72 65 63 74 6f 72 79 20 2d 20 69 67 6e 6f 72 69 rectory - ignori
a2d0: 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 ng it."))....
a2e0: 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 -1).... ((not
a2f0: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
a300: 65 73 73 3f 20 64 69 72 70 61 74 68 29 29 0a 09 ess? dirpath))..
a310: 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f .. (if (commo
a320: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
a330: 74 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 t 300 "disks not
a340: 20 77 72 69 74 65 61 62 6c 65 20 22 20 64 69 73 writeable " dis
a350: 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 75 k-num).....(debu
a360: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
a370: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
a380: 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 RNING: disk " di
a390: 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 68 sk-num " at path
a3a0: 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c 22 \"" dirpath "\"
a3b0: 20 69 73 20 6e 6f 74 20 77 72 69 74 65 61 62 6c is not writeabl
a3c0: 65 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e e - ignoring it.
a3d0: 22 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 ")).... -1)..
a3e0: 09 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 .. ((not (eq?
a3f0: 28 73 74 72 69 6e 67 2d 72 65 66 20 64 69 72 70 (string-ref dirp
a400: 61 74 68 20 30 29 20 23 5c 2f 29 29 0a 09 09 09 ath 0) #\/))....
a410: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
a420: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
a430: 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 61 300 "disks not a
a440: 20 70 72 6f 70 65 72 20 70 61 74 68 20 22 20 64 proper path " d
a450: 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 isk-num).....(de
a460: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
a470: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
a480: 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 WARNING: disk "
a490: 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 disk-num " at pa
a4a0: 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 th \"" dirpath "
a4b0: 5c 22 20 69 73 20 6e 6f 74 20 61 20 66 75 6c 6c \" is not a full
a4c0: 79 20 71 75 61 6c 69 66 69 65 64 20 70 61 74 68 y qualified path
a4d0: 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 - ignoring it."
a4e0: 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 )).... -1)...
a4f0: 09 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 . (else....
a500: 20 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 (get-df dirpath
a510: 29 29 29 29 29 0a 09 20 28 69 66 20 28 3e 20 66 ))))).. (if (> f
a520: 72 65 65 73 70 63 20 62 65 73 74 73 69 7a 65 29 reespc bestsize)
a530: 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
a540: 20 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 (set! best
a550: 20 20 20 20 20 28 63 6f 6e 73 20 64 69 73 6b 2d (cons disk-
a560: 6e 75 6d 20 64 69 72 70 61 74 68 29 29 0a 09 20 num dirpath))..
a570: 20 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 (set! best
a580: 73 69 7a 65 20 66 72 65 65 73 70 63 29 29 29 29 size freespc))))
a590: 29 0a 20 20 20 20 20 28 6d 61 70 20 63 61 72 20 ). (map car
a5a0: 64 69 73 6b 73 29 29 0a 20 20 20 20 28 69 66 20 disks)). (if
a5b0: 28 61 6e 64 20 62 65 73 74 20 28 3e 20 62 65 73 (and best (> bes
a5c0: 74 73 69 7a 65 20 6d 69 6e 73 69 7a 65 29 29 0a tsize minsize)).
a5d0: 09 62 65 73 74 0a 09 23 66 29 29 29 20 3b 3b 20 .best..#f))) ;;
a5e0: 23 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 73 6b #f means no disk
a5f0: 20 63 61 6e 64 69 64 61 74 65 20 66 6f 75 6e 64 candidate found
a600: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
a610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 ==========.;; E
a650: 4e 20 56 20 49 20 52 20 4f 20 4e 20 4d 20 45 20 N V I R O N M E
a660: 4e 20 54 20 20 20 56 20 41 20 52 20 53 0a 3b 3b N T V A R S.;;
a670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a6b0: 3d 3d 3d 3d 3d 3d 0a 09 20 20 20 20 20 20 0a 28 ======.. .(
a6c0: 64 65 66 69 6e 65 20 28 73 61 76 65 2d 65 6e 76 define (save-env
a6d0: 69 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 ironment-as-file
a6e0: 73 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 69 s fname #!key (i
a6f0: 67 6e 6f 72 65 76 61 72 73 20 28 6c 69 73 74 20 gnorevars (list
a700: 22 55 53 45 52 22 20 22 48 4f 4d 45 22 20 22 44 "USER" "HOME" "D
a710: 49 53 50 4c 41 59 22 20 22 4c 53 5f 43 4f 4c 4f ISPLAY" "LS_COLO
a720: 52 53 22 20 22 58 4b 45 59 53 59 4d 44 42 22 20 RS" "XKEYSYMDB"
a730: 22 45 44 49 54 4f 52 22 20 22 4d 41 4b 45 46 4c "EDITOR" "MAKEFL
a740: 41 47 53 22 20 22 4d 41 4b 45 46 22 20 22 4d 41 AGS" "MAKEF" "MA
a750: 4b 45 4f 56 45 52 52 49 44 45 53 22 29 29 29 0a KEOVERRIDES"))).
a760: 20 20 28 6c 65 74 20 28 28 65 6e 76 76 61 72 73 (let ((envvars
a770: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
a780: 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 t-variables)).
a790: 20 20 20 20 20 20 28 77 68 69 74 65 73 70 20 28 (whitesp (
a7a0: 72 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d 5a regexp "[^a-zA-Z
a7b0: 30 2d 39 5f 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 24 5d 0-9_\\-:,.\\/%$]
a7c0: 22 29 29 0a 09 28 6d 75 6e 67 65 76 61 6c 20 28 "))..(mungeval (
a7d0: 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 09 09 20 lambda (val)...
a7e0: 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 (cond...
a7f0: 28 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 22 ((eq? val #t) ""
a800: 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 74 20 ) ;; convert #t
a810: 74 6f 20 65 6d 70 74 79 20 73 74 72 69 6e 67 0a to empty string.
a820: 09 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 6c .. ((eq? val
a830: 20 23 66 29 20 23 66 29 20 3b 3b 20 63 6f 6e 76 #f) #f) ;; conv
a840: 65 72 74 20 23 66 20 74 6f 20 69 74 73 65 6c 66 ert #f to itself
a850: 20 28 73 74 69 6c 6c 20 74 68 69 6e 6b 69 6e 67 (still thinking
a860: 20 61 62 6f 75 74 20 74 68 69 73 20 6f 6e 65 0a about this one.
a870: 09 09 20 20 20 20 20 28 65 6c 73 65 20 76 61 6c .. (else val
a880: 29 29 29 29 29 0a 20 20 20 20 20 28 77 69 74 68 ))))). (with
a890: 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 -output-to-file
a8a0: 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 73 (conc fname ".cs
a8b0: 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 h"). (lamb
a8c0: 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 da ().
a8d0: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
a8e0: 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 20 a (keyval)...
a8f0: 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 (let* ((key
a900: 20 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 (car keyval))..
a910: 09 09 20 20 20 20 20 28 76 61 6c 20 20 20 28 63 .. (val (c
a920: 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 dr keyval))....
a930: 20 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 28 (delim (if (
a940: 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 string-search wh
a950: 69 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 09 itesp val) .....
a960: 09 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 29 ."\""......"")))
a970: 0a 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 28 ....(print (if (
a980: 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 6e 6f 72 member key ignor
a990: 65 76 61 72 73 29 0a 09 09 09 09 20 20 20 22 23 evars)..... "#
a9a0: 20 73 65 74 65 6e 76 20 22 0a 09 09 09 09 20 20 setenv ".....
a9b0: 20 22 73 65 74 65 6e 76 20 22 29 0a 09 09 09 20 "setenv ")....
a9c0: 20 20 20 20 20 20 6b 65 79 20 22 20 22 20 64 65 key " " de
a9d0: 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c 20 76 61 lim (mungeval va
a9e0: 6c 29 20 64 65 6c 69 6d 29 29 29 0a 09 09 20 20 l) delim)))...
a9f0: 20 20 65 6e 76 76 61 72 73 29 29 29 0a 20 20 20 envvars))).
aa00: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
aa10: 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e 61 o-file (conc fna
aa20: 6d 65 20 22 2e 73 68 22 29 0a 20 20 20 20 20 20 me ".sh").
aa30: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
aa40: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 (for-each
aa50: 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 (lambda (keyval)
aa60: 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ... (let* (
aa70: 28 6b 65 79 20 28 63 61 72 20 6b 65 79 76 61 6c (key (car keyval
aa80: 29 29 0a 09 09 09 20 20 20 20 20 28 76 61 6c 20 )).... (val
aa90: 28 63 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 (cdr keyval))...
aaa0: 09 20 20 20 20 20 28 64 65 6c 69 6d 20 28 69 66 . (delim (if
aab0: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
aac0: 77 68 69 74 65 73 70 20 76 61 6c 29 20 0a 09 09 whitesp val) ...
aad0: 09 09 09 22 5c 22 22 0a 09 09 09 09 09 22 22 29 ..."\""......"")
aae0: 29 29 0a 09 09 09 28 70 72 69 6e 74 20 28 69 66 ))....(print (if
aaf0: 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 6e (member key ign
ab00: 6f 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 20 orevars).....
ab10: 22 23 20 65 78 70 6f 72 74 20 22 0a 09 09 09 09 "# export ".....
ab20: 20 20 20 22 65 78 70 6f 72 74 20 22 29 0a 09 09 "export ")...
ab30: 09 20 20 20 20 20 20 20 6b 65 79 20 22 3d 22 20 . key "="
ab40: 64 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c 20 delim (mungeval
ab50: 76 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a 20 20 val) delim))).
ab60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ab70: 20 20 65 6e 76 76 61 72 73 29 29 29 29 29 0a 0a envvars)))))..
ab80: 3b 3b 20 73 65 74 20 73 6f 6d 65 20 65 6e 76 20 ;; set some env
ab90: 76 61 72 73 20 66 72 6f 6d 20 61 6e 20 61 6c 69 vars from an ali
aba0: 73 74 2c 20 72 65 74 75 72 6e 20 61 6e 20 61 6c st, return an al
abb0: 69 73 74 20 77 69 74 68 20 6f 72 69 67 69 6e 61 ist with origina
abc0: 6c 20 76 61 6c 75 65 73 0a 3b 3b 20 28 28 22 56 l values.;; (("V
abd0: 41 52 22 20 22 76 61 6c 75 65 22 29 20 2e 2e 2e AR" "value") ...
abe0: 29 0a 28 64 65 66 69 6e 65 20 28 61 6c 69 73 74 ).(define (alist
abf0: 2d 3e 65 6e 76 2d 76 61 72 73 20 6c 73 74 29 0a ->env-vars lst).
ac00: 20 20 28 69 66 20 28 6c 69 73 74 3f 20 6c 73 74 (if (list? lst
ac10: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 ). (let ((r
ac20: 65 73 20 27 28 29 29 29 0a 09 28 66 6f 72 2d 65 es '()))..(for-e
ac30: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 29 0a ach (lambda (p).
ac40: 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 76 61 .. (let* ((va
ac50: 72 20 28 63 61 72 20 20 70 29 29 0a 09 09 09 20 r (car p))....
ac60: 20 20 28 76 61 6c 20 28 63 61 64 72 20 70 29 29 (val (cadr p))
ac70: 0a 09 09 09 20 20 20 28 70 72 76 20 28 67 65 74 .... (prv (get
ac80: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
ac90: 69 61 62 6c 65 20 76 61 72 29 29 29 0a 09 09 20 iable var)))...
aca0: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 (set! res (
acb0: 63 6f 6e 73 20 28 6c 69 73 74 20 76 61 72 20 70 cons (list var p
acc0: 72 76 29 20 72 65 73 29 29 0a 09 09 20 20 20 20 rv) res))...
acd0: 20 20 28 69 66 20 76 61 6c 20 0a 09 09 09 20 20 (if val ....
ace0: 28 73 65 74 65 6e 76 20 76 61 72 20 28 2d 3e 73 (setenv var (->s
acf0: 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 tring val))....
ad00: 20 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 (unsetenv var))
ad10: 29 29 0a 09 09 20 20 6c 73 74 29 0a 09 72 65 73 ))... lst)..res
ad20: 29 0a 20 20 20 20 20 20 27 28 29 29 29 0a 0a 3b ). '()))..;
ad30: 3b 20 63 6c 65 61 72 20 76 61 72 73 20 6d 61 74 ; clear vars mat
ad40: 63 68 69 6e 67 20 70 61 74 74 65 72 6e 2c 20 72 ching pattern, r
ad50: 75 6e 20 70 72 6f 63 2c 20 73 65 74 20 76 61 72 un proc, set var
ad60: 73 20 62 61 63 6b 0a 3b 3b 20 69 66 20 70 72 6f s back.;; if pro
ad70: 63 20 69 73 20 61 20 73 74 72 69 6e 67 20 72 75 c is a string ru
ad80: 6e 20 74 68 61 74 20 73 74 72 69 6e 67 20 61 73 n that string as
ad90: 20 61 20 63 6f 6d 6d 61 6e 64 20 77 69 74 68 0a a command with.
ada0: 3b 3b 20 73 79 73 74 65 6d 2e 0a 3b 3b 0a 28 64 ;; system..;;.(d
adb0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 efine (common:wi
adc0: 74 68 6f 75 74 2d 76 61 72 73 20 70 72 6f 63 20 thout-vars proc
add0: 2e 20 76 61 72 2d 70 61 74 74 73 29 0a 20 20 28 . var-patts). (
ade0: 6c 65 74 20 28 28 76 61 72 73 20 28 6d 61 6b 65 let ((vars (make
adf0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 -hash-table))).
ae00: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
ae10: 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 64 61 (lambda (varda
ae20: 74 29 20 3b 3b 20 65 61 63 68 20 65 6e 76 20 76 t) ;; each env v
ae30: 61 72 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 ar. (for-e
ae40: 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 76 61 ach..(lambda (va
ae50: 72 2d 70 61 74 74 29 0a 09 20 20 28 69 66 20 28 r-patt).. (if (
ae60: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 76 61 72 string-match var
ae70: 2d 70 61 74 74 20 28 63 61 72 20 76 61 72 64 61 -patt (car varda
ae80: 74 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 t)).. (let
ae90: 28 28 76 61 72 20 28 63 61 72 20 76 61 72 64 61 ((var (car varda
aea0: 74 29 29 0a 09 09 20 20 20 20 28 76 61 6c 20 28 t))... (val (
aeb0: 63 64 72 20 76 61 72 64 61 74 29 29 29 0a 09 09 cdr vardat)))...
aec0: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
aed0: 20 76 61 72 73 20 76 61 72 20 76 61 6c 29 0a 09 vars var val)..
aee0: 09 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 .(unsetenv var))
aef0: 29 29 0a 09 76 61 72 2d 70 61 74 74 73 29 29 0a ))..var-patts)).
af00: 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f (get-enviro
af10: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 nment-variables)
af20: 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
af30: 20 28 28 73 74 72 69 6e 67 3f 20 70 72 6f 63 29 ((string? proc)
af40: 28 73 79 73 74 65 6d 20 70 72 6f 63 29 29 0a 20 (system proc)).
af50: 20 20 20 20 28 70 72 6f 63 20 20 20 20 20 20 20 (proc
af60: 20 20 20 28 70 72 6f 63 29 29 29 0a 20 20 20 20 (proc))).
af70: 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d (hash-table-for-
af80: 65 61 63 68 0a 20 20 20 20 20 76 61 72 73 0a 20 each. vars.
af90: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 (lambda (var
afa0: 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 val). (se
afb0: 74 65 6e 76 20 76 61 72 20 76 61 6c 29 29 29 0a tenv var val))).
afc0: 20 20 20 20 76 61 72 73 29 29 0a 0a 28 64 65 66 vars))..(def
afd0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d ine (common:run-
afe0: 61 2d 63 6f 6d 6d 61 6e 64 20 63 6d 64 20 23 21 a-command cmd #!
aff0: 6b 65 79 20 28 77 69 74 68 2d 76 61 72 73 20 23 key (with-vars #
b000: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 72 f)). (let* ((pr
b010: 65 2d 63 6d 64 20 20 28 64 74 65 73 74 73 3a 67 e-cmd (dtests:g
b020: 65 74 2d 70 72 65 2d 63 6f 6d 6d 61 6e 64 29 29 et-pre-command))
b030: 0a 20 20 20 20 20 20 20 20 20 28 70 6f 73 74 2d . (post-
b040: 63 6d 64 20 28 64 74 65 73 74 73 3a 67 65 74 2d cmd (dtests:get-
b050: 70 6f 73 74 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 post-command)).
b060: 20 20 20 20 20 20 20 20 28 66 75 6c 6c 63 6d 64 (fullcmd
b070: 20 20 28 69 66 20 28 6f 72 20 70 72 65 2d 63 6d (if (or pre-cm
b080: 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 20 d post-cmd).
b090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0a0: 20 20 20 28 63 6f 6e 63 20 70 72 65 2d 63 6d 64 (conc pre-cmd
b0b0: 20 63 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 cmd post-cmd).
b0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0d0: 20 20 20 20 20 20 28 63 6f 6e 63 20 22 76 69 65 (conc "vie
b0e0: 77 73 63 72 65 65 6e 20 22 20 63 6d 64 29 29 29 wscreen " cmd)))
b0f0: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
b100: 6e 74 2d 69 6e 66 6f 20 30 32 20 2a 64 65 66 61 nt-info 02 *defa
b110: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 ult-log-port* "R
b120: 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 3a 20 unning command:
b130: 22 20 66 75 6c 6c 63 6d 64 29 0a 20 20 20 20 28 " fullcmd). (
b140: 69 66 20 77 69 74 68 2d 76 61 72 73 0a 20 20 20 if with-vars.
b150: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 (common:wit
b160: 68 6f 75 74 2d 76 61 72 73 20 63 6d 64 29 0a 20 hout-vars cmd).
b170: 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 (common:w
b180: 69 74 68 6f 75 74 2d 76 61 72 73 20 66 75 6c 6c ithout-vars full
b190: 63 6d 64 20 22 4d 54 5f 2e 2a 22 29 29 29 29 0a cmd "MT_.*")))).
b1a0: 09 09 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .. .;;=========
b1b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b1e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
b1f0: 20 54 20 49 20 4d 20 45 20 20 20 41 20 4e 20 44 T I M E A N D
b200: 20 20 20 44 20 41 20 54 20 45 0a 3b 3b 3d 3d 3d D A T E.;;===
b210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b250: 3d 3d 3d 0a 0a 3b 3b 20 43 6f 6e 76 65 72 74 20 ===..;; Convert
b260: 73 74 72 69 6e 67 73 20 6c 69 6b 65 20 22 35 73 strings like "5s
b270: 20 32 68 20 33 6d 22 20 3d 3e 20 36 30 78 36 30 2h 3m" => 60x60
b280: 78 32 20 2b 20 33 78 36 30 20 2b 20 35 0a 28 64 x2 + 3x60 + 5.(d
b290: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 6d efine (common:hm
b2a0: 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 s-string->second
b2b0: 73 20 74 73 74 72 29 0a 20 20 28 6c 65 74 20 28 s tstr). (let (
b2c0: 28 70 61 72 74 73 20 20 20 20 20 28 73 74 72 69 (parts (stri
b2d0: 6e 67 2d 73 70 6c 69 74 20 74 73 74 72 29 29 0a ng-split tstr)).
b2e0: 09 28 74 69 6d 65 2d 73 65 63 73 20 30 29 0a 09 .(time-secs 0)..
b2f0: 3b 3b 20 73 3d 73 65 63 6f 6e 64 73 2c 20 6d 3d ;; s=seconds, m=
b300: 6d 69 6e 75 74 65 73 2c 20 68 3d 68 6f 75 72 73 minutes, h=hours
b310: 2c 20 64 3d 64 61 79 73 0a 09 28 74 72 78 20 20 , d=days..(trx
b320: 20 20 20 20 20 28 72 65 67 65 78 70 20 22 28 5c (regexp "(\
b330: 5c 64 2b 29 28 5b 73 6d 68 64 5d 29 22 29 29 29 \d+)([smhd])")))
b340: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
b350: 6c 61 6d 62 64 61 20 28 70 61 72 74 29 0a 09 09 lambda (part)...
b360: 28 6c 65 74 20 28 28 6d 61 74 63 68 20 20 28 73 (let ((match (s
b370: 74 72 69 6e 67 2d 6d 61 74 63 68 20 74 72 78 20 tring-match trx
b380: 70 61 72 74 29 29 29 0a 09 09 20 20 28 69 66 20 part)))... (if
b390: 6d 61 74 63 68 0a 09 09 20 20 20 20 20 20 28 6c match... (l
b3a0: 65 74 20 28 28 76 61 6c 20 28 73 74 72 69 6e 67 et ((val (string
b3b0: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d ->number (cadr m
b3c0: 61 74 63 68 29 29 29 0a 09 09 09 20 20 20 20 28 atch))).... (
b3d0: 75 6e 74 20 28 63 61 64 64 72 20 6d 61 74 63 68 unt (caddr match
b3e0: 29 29 29 0a 09 09 09 28 69 66 20 76 61 6c 20 0a )))....(if val .
b3f0: 09 09 09 20 20 20 20 28 73 65 74 21 20 74 69 6d ... (set! tim
b400: 65 2d 73 65 63 73 20 28 2b 20 74 69 6d 65 2d 73 e-secs (+ time-s
b410: 65 63 73 20 28 2a 20 76 61 6c 0a 09 09 09 09 09 ecs (* val......
b420: 09 09 20 20 20 20 28 63 61 73 65 20 28 73 74 72 .. (case (str
b430: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 75 6e 74 29 ing->symbol unt)
b440: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 ........ ((
b450: 73 29 20 31 29 0a 09 09 09 09 09 09 09 20 20 20 s) 1)........
b460: 20 20 20 28 28 6d 29 20 36 30 29 0a 09 09 09 09 ((m) 60).....
b470: 09 09 09 20 20 20 20 20 20 28 28 68 29 20 28 2a ... ((h) (*
b480: 20 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 60 60))........
b490: 20 20 20 20 20 20 28 28 64 29 20 28 2a 20 32 34 ((d) (* 24
b4a0: 20 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 60 60))........
b4b0: 20 20 20 20 20 20 28 65 6c 73 65 20 30 29 29 29 (else 0)))
b4c0: 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 70 ))))))).. p
b4d0: 61 72 74 73 29 0a 20 20 20 20 74 69 6d 65 2d 73 arts). time-s
b4e0: 65 63 73 29 29 0a 09 09 20 20 20 20 20 20 20 0a ecs))... .
b4f0: 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 (define (seconds
b500: 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 63 ->hr-min-sec sec
b510: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 73 s). (let* ((hrs
b520: 20 28 71 75 6f 74 69 65 6e 74 20 73 65 63 73 20 (quotient secs
b530: 33 36 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 71 3600)).. (min (q
b540: 75 6f 74 69 65 6e 74 20 28 2d 20 73 65 63 73 20 uotient (- secs
b550: 28 2a 20 68 72 73 20 33 36 30 30 29 29 20 36 30 (* hrs 3600)) 60
b560: 29 29 0a 09 20 28 73 65 63 20 28 2d 20 73 65 63 )).. (sec (- sec
b570: 73 20 28 2a 20 68 72 73 20 33 36 30 30 29 28 2a s (* hrs 3600)(*
b580: 20 6d 69 6e 20 36 30 29 29 29 29 0a 20 20 20 20 min 60)))).
b590: 28 63 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 73 (conc (if (> hrs
b5a0: 20 30 29 28 63 6f 6e 63 20 68 72 73 20 22 68 72 0)(conc hrs "hr
b5b0: 20 22 29 20 22 22 29 0a 09 20 20 28 69 66 20 28 ") "").. (if (
b5c0: 3e 20 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d 69 > min 0)(conc mi
b5d0: 6e 20 22 6d 20 22 29 20 20 22 22 29 0a 09 20 20 n "m ") "")..
b5e0: 73 65 63 20 22 73 22 29 29 29 0a 0a 28 64 65 66 sec "s")))..(def
b5f0: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 ine (seconds->ti
b600: 6d 65 2d 73 74 72 69 6e 67 20 73 65 63 29 0a 20 me-string sec).
b610: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a (time->string .
b620: 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
b630: 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 48 al-time sec) "%H
b640: 3a 25 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 69 :%M:%S"))..(defi
b650: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 ne (seconds->wor
b660: 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 k-week/day-time
b670: 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
b680: 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
b690: 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
b6a0: 29 20 22 77 77 25 56 2e 25 75 20 25 48 3a 25 4d ) "ww%V.%u %H:%M
b6b0: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
b6c0: 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b conds->work-week
b6d0: 2f 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d /day sec). (tim
b6e0: 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 e->string. (se
b6f0: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
b700: 65 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 22 e sec) "ww%V.%u"
b710: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ))..(define (sec
b720: 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d onds->year-work-
b730: 77 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 week/day sec).
b740: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 (time->string.
b750: 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
b760: 2d 74 69 6d 65 20 73 65 63 29 20 22 25 79 77 77 -time sec) "%yww
b770: 25 56 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 6e %V.%w"))..(defin
b780: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 e (seconds->year
b790: 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 -work-week/day-t
b7a0: 69 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d 65 ime sec). (time
b7b0: 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 ->string. (sec
b7c0: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
b7d0: 20 73 65 63 29 20 22 25 59 77 77 25 56 2e 25 77 sec) "%Yww%V.%w
b7e0: 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 69 %H:%M"))..(defi
b7f0: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 ne (seconds->yea
b800: 72 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 r-week/day-time
b810: 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
b820: 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
b830: 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
b840: 29 20 22 25 59 77 25 56 2e 25 77 20 25 48 3a 25 ) "%Yw%V.%w %H:%
b850: 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 M"))..(define (s
b860: 65 63 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 20 econds->quarter
b870: 73 65 63 29 0a 20 20 28 63 61 73 65 20 28 73 74 sec). (case (st
b880: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 28 ring->number.. (
b890: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 09 20 time->string ..
b8a0: 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
b8b0: 2d 74 69 6d 65 20 73 65 63 29 0a 09 20 20 22 25 -time sec).. "%
b8c0: 6d 22 29 29 0a 20 20 20 20 28 28 31 20 32 20 33 m")). ((1 2 3
b8d0: 29 20 31 29 0a 20 20 20 20 28 28 34 20 35 20 36 ) 1). ((4 5 6
b8e0: 29 20 32 29 0a 20 20 20 20 28 28 37 20 38 20 39 ) 2). ((7 8 9
b8f0: 29 20 33 29 0a 20 20 20 20 28 28 31 30 20 31 31 ) 3). ((10 11
b900: 20 31 32 29 20 34 29 0a 20 20 20 20 28 65 6c 73 12) 4). (els
b910: 65 20 23 66 29 29 29 0a 0a 3b 3b 20 67 69 76 65 e #f)))..;; give
b920: 6e 20 73 70 61 6e 20 6f 66 20 73 65 63 6f 6e 64 n span of second
b930: 73 20 74 73 74 61 72 74 20 74 6f 20 74 65 6e 64 s tstart to tend
b940: 0a 3b 3b 20 66 69 6e 64 20 73 74 61 72 74 20 74 .;; find start t
b950: 69 6d 65 20 74 6f 20 6d 61 72 6b 20 61 6e 64 20 ime to mark and
b960: 6d 61 72 6b 20 64 65 6c 74 61 0a 3b 3b 0a 28 64 mark delta.;;.(d
b970: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 69 efine (common:fi
b980: 6e 64 2d 73 74 61 72 74 2d 6d 61 72 6b 2d 61 6e nd-start-mark-an
b990: 64 2d 6d 61 72 6b 2d 64 65 6c 74 61 20 74 73 74 d-mark-delta tst
b9a0: 61 72 74 20 74 65 6e 64 29 0a 20 20 28 6c 65 74 art tend). (let
b9b0: 2a 20 28 28 64 65 6c 74 61 74 20 20 20 28 2d 20 * ((deltat (-
b9c0: 28 6d 61 78 20 74 65 6e 64 20 28 2b 20 74 65 6e (max tend (+ ten
b9d0: 64 20 31 30 29 29 20 74 73 74 61 72 74 29 29 20 d 10)) tstart))
b9e0: 3b 3b 20 63 61 6e 27 74 20 68 61 6e 64 6c 65 20 ;; can't handle
b9f0: 72 75 6e 73 20 6f 66 20 6c 65 73 73 20 74 68 61 runs of less tha
ba00: 6e 20 34 20 73 65 63 6f 6e 64 73 2e 20 50 61 64 n 4 seconds. Pad
ba10: 20 69 74 20 74 6f 20 31 30 20 73 65 63 6f 6e 64 it to 10 second
ba20: 73 20 2e 2e 2e 0a 09 20 28 72 65 73 75 6c 74 20 s ..... (result
ba30: 20 20 23 66 29 0a 09 20 28 6d 69 6e 20 20 20 20 #f).. (min
ba40: 20 20 36 30 29 0a 09 20 28 68 72 20 20 20 20 20 60).. (hr
ba50: 20 20 28 2a 20 36 30 20 36 30 29 29 0a 09 20 28 (* 60 60)).. (
ba60: 64 61 79 20 20 20 20 20 20 28 2a 20 32 34 20 68 day (* 24 h
ba70: 72 29 29 0a 09 20 28 79 72 20 20 20 20 20 20 20 r)).. (yr
ba80: 28 2a 20 33 36 35 20 64 61 79 29 29 20 3b 3b 20 (* 365 day)) ;;
ba90: 79 65 61 72 0a 09 20 28 6d 6f 20 20 20 20 20 20 year.. (mo
baa0: 20 28 2f 20 79 72 20 31 32 29 29 0a 09 20 28 77 (/ yr 12)).. (w
bab0: 6b 20 20 20 20 20 20 20 28 2a 20 64 61 79 20 37 k (* day 7
bac0: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
bad0: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
bae0: 6d 61 78 2d 62 6c 6b 73 29 0a 20 20 20 20 20 20 max-blks).
baf0: 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 6d (for-each..(lam
bb00: 62 64 61 20 28 73 70 61 6e 29 20 3b 3b 20 35 20 bda (span) ;; 5
bb10: 32 20 31 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 2 1.. (if (not
bb20: 72 65 73 75 6c 74 29 0a 09 20 20 20 20 20 20 28 result).. (
bb30: 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 for-each ..
bb40: 20 20 28 6c 61 6d 62 64 61 20 28 74 69 6d 65 75 (lambda (timeu
bb50: 6e 69 74 20 74 69 6d 65 73 79 6d 29 20 3b 3b 20 nit timesym) ;;
bb60: 79 65 61 72 20 6d 6f 6e 74 68 20 64 61 79 20 68 year month day h
bb70: 72 20 6d 69 6e 20 73 65 63 0a 09 09 20 28 69 66 r min sec... (if
bb80: 20 28 6e 6f 74 20 72 65 73 75 6c 74 29 0a 09 09 (not result)...
bb90: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 69 6d (let* ((tim
bba0: 65 2d 62 6c 6b 20 28 2a 20 73 70 61 6e 20 74 69 e-blk (* span ti
bbb0: 6d 65 75 6e 69 74 29 29 0a 09 09 09 20 20 20 20 meunit))....
bbc0: 28 6e 75 6d 2d 62 6c 6b 73 20 28 71 75 6f 74 69 (num-blks (quoti
bbd0: 65 6e 74 20 64 65 6c 74 61 74 20 74 69 6d 65 2d ent deltat time-
bbe0: 62 6c 6b 29 29 29 0a 09 09 20 20 20 20 20 20 20 blk)))...
bbf0: 28 69 66 20 28 61 6e 64 20 28 3e 20 6e 75 6d 2d (if (and (> num-
bc00: 62 6c 6b 73 20 34 29 28 3c 20 6e 75 6d 2d 62 6c blks 4)(< num-bl
bc10: 6b 73 20 6d 61 78 2d 62 6c 6b 73 29 29 0a 09 09 ks max-blks))...
bc20: 09 20 20 20 28 6c 65 74 20 28 28 66 69 72 73 74 . (let ((first
bc30: 20 28 2a 20 28 71 75 6f 74 69 65 6e 74 20 74 73 (* (quotient ts
bc40: 74 61 72 74 20 74 69 6d 65 2d 62 6c 6b 29 20 74 tart time-blk) t
bc50: 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 09 20 20 ime-blk)))....
bc60: 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 (set! result
bc70: 28 6c 69 73 74 20 73 70 61 6e 20 74 69 6d 65 75 (list span timeu
bc80: 6e 69 74 20 74 69 6d 65 2d 62 6c 6b 20 66 69 72 nit time-blk fir
bc90: 73 74 20 74 69 6d 65 73 79 6d 29 29 0a 09 09 09 st timesym))....
bca0: 20 20 20 20 20 29 29 29 29 29 0a 09 20 20 20 20 )))))..
bcb0: 20 20 20 28 6c 69 73 74 20 79 72 20 6d 6f 20 77 (list yr mo w
bcc0: 6b 20 64 61 79 20 68 72 20 6d 69 6e 20 31 29 0a k day hr min 1).
bcd0: 09 20 20 20 20 20 20 20 27 28 20 20 20 20 20 79 . '( y
bce0: 20 20 6d 6f 20 77 20 20 64 20 20 20 68 20 20 6d mo w d h m
bcf0: 20 20 20 73 29 29 29 29 0a 09 28 6c 69 73 74 20 s))))..(list
bd00: 38 20 36 20 35 20 32 20 31 29 29 29 0a 20 20 20 8 6 5 2 1))).
bd10: 20 20 27 28 35 20 31 30 20 31 35 20 32 30 20 33 '(5 10 15 20 3
bd20: 30 20 34 30 20 35 30 20 35 30 30 29 29 0a 20 20 0 40 50 500)).
bd30: 20 20 28 69 66 20 76 61 6c 75 65 73 0a 09 28 61 (if values..(a
bd40: 70 70 6c 79 20 76 61 6c 75 65 73 20 72 65 73 75 pply values resu
bd50: 6c 74 29 0a 09 28 76 61 6c 75 65 73 20 30 20 64 lt)..(values 0 d
bd60: 61 79 20 31 20 30 20 27 64 29 29 29 29 0a 09 20 ay 1 0 'd))))..
bd70: 20 20 20 0a 09 20 20 0a 0a 3b 3b 3d 3d 3d 3d 3d .. ..;;=====
bd80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bda0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bdb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bdc0: 3d 0a 3b 3b 20 43 20 4f 20 4c 20 4f 20 52 20 53 =.;; C O L O R S
bdd0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
bde0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bdf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
be10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 20 =========.
be20: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
be30: 3a 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f 72 :name->iup-color
be40: 20 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 28 name). (case (
be50: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
be60: 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 string-downcase
be70: 6e 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 64 name)). ((red
be80: 29 20 20 20 20 22 32 32 33 20 33 33 20 34 39 22 ) "223 33 49"
be90: 29 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 20 ). ((grey)
bea0: 22 31 39 32 20 31 39 32 20 31 39 32 22 29 0a 20 "192 192 192").
beb0: 20 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 35 ((orange) "25
bec0: 35 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 28 5 172 13"). (
bed0: 28 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 69 (purple) "This i
bee0: 73 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e 2e s unfinished ...
bef0: 22 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 ")))..;; (define
bf00: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c (common:get-col
bf10: 6f 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 61 or-for-state-sta
bf20: 74 75 73 20 73 74 61 74 65 20 73 74 61 74 75 73 tus state status
bf30: 29 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 73 74 ).;; (case (st
bf40: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 ring->symbol sta
bf50: 74 65 29 0a 3b 3b 20 20 20 20 20 28 28 43 4f 4d te).;; ((COM
bf60: 50 4c 45 54 45 44 29 0a 3b 3b 20 20 20 20 20 20 PLETED).;;
bf70: 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 (case (string->s
bf80: 79 6d 62 6f 6c 20 73 74 61 74 75 73 29 0a 3b 3b ymbol status).;;
bf90: 20 20 20 20 20 20 20 20 28 28 50 41 53 53 29 20 ((PASS)
bfa0: 20 20 20 20 20 20 20 22 37 30 20 20 32 34 39 20 "70 249
bfb0: 37 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 73").;; (
bfc0: 28 57 41 52 4e 20 57 41 49 56 45 44 29 20 22 32 (WARN WAIVED) "2
bfd0: 35 35 20 31 37 32 20 31 33 22 29 0a 3b 3b 20 20 55 172 13").;;
bfe0: 20 20 20 20 20 20 28 28 53 4b 49 50 29 20 20 20 ((SKIP)
bff0: 20 20 20 20 20 22 32 33 30 20 32 33 30 20 30 22 "230 230 0"
c000: 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 65 6c 73 ).;; (els
c010: 65 20 22 32 32 33 20 33 33 20 34 39 22 29 29 29 e "223 33 49")))
c020: 0a 3b 3b 20 20 20 20 20 28 28 4c 41 55 4e 43 48 .;; ((LAUNCH
c030: 45 44 29 20 20 20 20 20 20 20 20 20 22 31 30 31 ED) "101
c040: 20 31 32 33 20 31 34 32 22 29 0a 3b 3b 20 20 20 123 142").;;
c050: 20 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 20 ((CHECK)
c060: 20 20 20 20 20 20 22 32 35 35 20 31 30 30 20 35 "255 100 5
c070: 30 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 45 4d 0").;; ((REM
c080: 4f 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 22 OTEHOSTSTART) "
c090: 35 30 20 20 31 33 30 20 31 39 35 22 29 0a 3b 3b 50 130 195").;;
c0a0: 20 20 20 20 20 28 28 52 55 4e 4e 49 4e 47 29 20 ((RUNNING)
c0b0: 20 20 20 20 20 20 20 20 20 22 39 20 20 20 31 33 "9 13
c0c0: 31 20 32 33 32 22 29 0a 3b 3b 20 20 20 20 20 28 1 232").;; (
c0d0: 28 4b 49 4c 4c 52 45 51 29 20 20 20 20 20 20 20 (KILLREQ)
c0e0: 20 20 20 22 33 39 20 20 38 32 20 20 32 30 36 22 "39 82 206"
c0f0: 29 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c 45 ).;; ((KILLE
c100: 44 29 20 20 20 20 20 20 20 20 20 20 20 22 32 33 D) "23
c110: 34 20 31 30 31 20 31 37 22 29 0a 3b 3b 20 20 20 4 101 17").;;
c120: 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 29 ((NOT_STARTED)
c130: 20 20 20 20 20 20 22 32 34 30 20 32 34 30 20 32 "240 240 2
c140: 34 30 22 29 0a 3b 3b 20 20 20 20 20 28 65 6c 73 40").;; (els
c150: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e
c160: 22 31 39 32 20 31 39 32 20 31 39 32 22 29 29 29 "192 192 192")))
c170: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
c180: 6e 3a 69 75 70 2d 63 6f 6c 6f 72 2d 3e 72 67 62 n:iup-color->rgb
c190: 2d 68 65 78 20 69 6e 73 74 72 29 0a 20 20 28 73 -hex instr). (s
c1a0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
c1b0: 65 20 0a 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 e . (map (lamb
c1c0: 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 da (x).
c1d0: 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 (number->string
c1e0: 20 78 20 31 36 29 29 0a 20 20 20 20 20 20 20 20 x 16)).
c1f0: 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d (map string->num
c200: 62 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 ber.
c210: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 (string-split i
c220: 6e 73 74 72 29 29 29 0a 20 20 20 22 2f 22 29 29 nstr))). "/"))
c230: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
c240: 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d n:get-color-from
c250: 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 0a -status status).
c260: 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 65 71 75 (cond. ((equ
c270: 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 53 al? status "PASS
c280: 22 29 20 20 20 20 22 67 72 65 65 6e 22 29 0a 20 ") "green").
c290: 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 ((equal? statu
c2a0: 73 20 22 46 41 49 4c 22 29 20 20 20 20 22 72 65 s "FAIL") "re
c2b0: 64 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 d"). ((equal?
c2c0: 73 74 61 74 75 73 20 22 57 41 52 4e 22 29 20 20 status "WARN")
c2d0: 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 "orange"). (
c2e0: 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
c2f0: 4b 49 4c 4c 45 44 22 29 20 20 22 6f 72 61 6e 67 KILLED") "orang
c300: 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
c310: 73 74 61 74 75 73 20 22 4b 49 4c 4c 52 45 51 22 status "KILLREQ"
c320: 29 20 22 70 75 72 70 6c 65 22 29 0a 20 20 20 28 ) "purple"). (
c330: 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
c340: 52 55 4e 4e 49 4e 47 22 29 20 22 62 6c 75 65 22 RUNNING") "blue"
c350: 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 ). ((equal? st
c360: 61 74 75 73 20 22 41 42 4f 52 54 22 29 20 20 20 atus "ABORT")
c370: 22 62 72 6f 77 6e 22 29 0a 20 20 20 28 65 6c 73 "brown"). (els
c380: 65 20 22 62 6c 61 63 6b 22 29 29 29 0a 0a 3b 3b e "black")))..;;
c390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c3a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c3b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c3c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c3d0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 20 41 20 4e 20 ======.;; N A N
c3e0: 4f 20 4d 20 53 20 47 20 20 20 43 20 4c 20 49 20 O M S G C L I
c3f0: 45 20 4e 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d E N T.;;========
c400: 3d 3d 3d 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 0a 0a ==============..
c440: 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a (define (server:
c450: 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 get-best-guess-a
c460: 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 ddress hostname)
c470: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 . (let ((res #f
c480: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
c490: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
c4a0: 61 64 72 29 0a 20 20 20 20 20 20 20 28 69 66 20 adr). (if
c4b0: 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 (not (eq? (u8vec
c4c0: 74 6f 72 2d 72 65 66 20 61 64 72 20 30 29 20 31 tor-ref adr 0) 1
c4d0: 32 37 29 29 0a 09 20 20 20 28 73 65 74 21 20 72 27)).. (set! r
c4e0: 65 73 20 61 64 72 29 29 29 0a 20 20 20 20 20 3b es adr))). ;
c4f0: 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 6e ; NOTE: This can
c500: 20 66 61 69 6c 20 77 68 65 6e 20 74 68 65 72 65 fail when there
c510: 20 69 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f is no mention o
c520: 66 20 74 68 65 20 68 6f 73 74 20 69 6e 20 2f 65 f the host in /e
c530: 74 63 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 0a tc/hosts. FIXME.
c540: 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 (vector->li
c550: 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 st (hostinfo-add
c560: 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d 65 resses (hostname
c570: 2d 3e 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 6e ->hostinfo hostn
c580: 61 6d 65 29 29 29 29 0a 20 20 20 20 28 73 74 72 ame)))). (str
c590: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
c5a0: 0a 20 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 65 . (map numbe
c5b0: 72 2d 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 38 r->string.. (u8
c5c0: 76 65 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 vector->list..
c5d0: 20 28 69 66 20 72 65 73 20 72 65 73 20 28 68 6f (if res res (ho
c5e0: 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e stname->ip hostn
c5f0: 61 6d 65 29 29 29 29 20 22 2e 22 29 29 29 0a 0a ame)))) ".")))..
c600: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
c610: 3a 73 65 6e 64 2d 64 62 6f 61 72 64 2d 6d 61 69 :send-dboard-mai
c620: 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 6c 65 n-changed). (le
c630: 74 2a 20 28 28 64 61 73 68 62 6f 61 72 64 2d 69 t* ((dashboard-i
c640: 70 73 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 ps (mddb:get-das
c650: 68 62 6f 61 72 64 73 29 29 29 0a 20 20 20 20 28 hboards))). (
c660: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
c670: 61 6d 62 64 61 20 28 69 70 61 64 72 29 0a 20 20 ambda (ipadr).
c680: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 63 (let* ((soc
c690: 20 28 63 6f 6d 6d 6f 6e 3a 6f 70 65 6e 2d 6e 6d (common:open-nm
c6a0: 2d 72 65 71 20 28 63 6f 6e 63 20 22 74 63 70 3a -req (conc "tcp:
c6b0: 2f 2f 22 20 69 70 61 64 72 29 29 29 0a 09 20 20 //" ipadr)))..
c6c0: 20 20 20 20 28 6d 73 67 20 28 63 6f 6e 63 20 22 (msg (conc "
c6d0: 6d 61 69 6e 20 22 20 2a 74 6f 70 70 61 74 68 2a main " *toppath*
c6e0: 29 29 0a 09 20 20 20 20 20 20 28 72 65 73 20 28 )).. (res (
c6f0: 63 6f 6d 6d 6f 6e 3a 6e 6d 2d 73 65 6e 64 2d 72 common:nm-send-r
c700: 65 63 65 69 76 65 2d 74 69 6d 65 6f 75 74 20 73 eceive-timeout s
c710: 6f 63 20 6d 73 67 29 29 29 0a 09 20 28 69 66 20 oc msg))).. (if
c720: 28 6e 6f 74 20 72 65 73 29 20 3b 3b 20 63 6f 75 (not res) ;; cou
c730: 6c 64 6e 27 74 20 72 65 61 63 68 20 74 68 61 74 ldn't reach that
c740: 20 64 61 73 68 62 6f 61 72 64 20 2d 20 72 65 6d dashboard - rem
c750: 6f 76 65 20 69 74 20 66 72 6f 6d 20 64 62 0a 09 ove it from db..
c760: 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 (print "ERR
c770: 4f 52 3a 20 63 6f 75 6c 64 6e 27 74 20 72 65 61 OR: couldn't rea
c780: 63 68 20 64 61 73 68 62 6f 61 72 64 20 22 20 69 ch dashboard " i
c790: 70 61 64 72 29 29 0a 09 20 72 65 73 29 29 0a 20 padr)).. res)).
c7a0: 20 20 20 20 64 61 73 68 62 6f 61 72 64 2d 69 70 dashboard-ip
c7b0: 73 29 29 29 0a 20 20 20 20 0a 20 20 20 20 0a 3b s))). . .;
c7c0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
c7d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c7f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c800: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 =======.;; D A S
c810: 20 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 44 H B O A R D D
c820: 20 42 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d B .;;==========
c830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
c870: 65 66 69 6e 65 20 28 6d 64 64 62 3a 6f 70 65 6e efine (mddb:open
c880: 2d 64 62 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 -db). (let* ((d
c890: 62 20 28 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 b (open-database
c8a0: 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 (conc (get-envi
c8b0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
c8c0: 20 22 48 4f 4d 45 22 29 20 22 2f 2e 64 61 73 68 "HOME") "/.dash
c8d0: 62 6f 61 72 64 2e 64 62 22 29 29 29 29 0a 20 20 board.db")))).
c8e0: 20 20 28 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 (set-busy-hand
c8f0: 6c 65 72 21 20 64 62 20 28 62 75 73 79 2d 74 69 ler! db (busy-ti
c900: 6d 65 6f 75 74 20 31 30 30 30 30 29 29 0a 20 20 meout 10000)).
c910: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
c920: 20 28 6c 61 6d 62 64 61 20 28 71 72 79 29 0a 20 (lambda (qry).
c930: 20 20 20 20 20 20 28 65 78 65 63 20 28 73 71 6c (exec (sql
c940: 20 64 62 20 71 72 79 29 29 29 0a 20 20 20 20 20 db qry))).
c950: 28 6c 69 73 74 20 0a 20 20 20 20 20 20 22 43 52 (list . "CR
c960: 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f EATE TABLE IF NO
c970: 54 20 45 58 49 53 54 53 20 76 61 72 73 20 20 20 T EXISTS vars
c980: 20 20 20 20 28 69 64 20 49 4e 54 45 47 45 52 20 (id INTEGER
c990: 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 PRIMARY KEY,key
c9a0: 54 45 58 54 2c 20 76 61 6c 20 54 45 58 54 2c 20 TEXT, val TEXT,
c9b0: 43 4f 4e 53 54 52 41 49 4e 54 20 76 61 72 73 63 CONSTRAINT varsc
c9c0: 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 onstraint UNIQUE
c9d0: 20 28 6b 65 79 29 29 3b 22 0a 20 20 20 20 20 20 (key));".
c9e0: 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 "CREATE TABLE IF
c9f0: 20 4e 4f 54 20 45 58 49 53 54 53 20 64 61 73 68 NOT EXISTS dash
ca00: 62 6f 61 72 64 73 20 28 0a 20 20 20 20 20 20 20 boards (.
ca10: 20 20 20 69 64 20 20 20 20 20 20 20 20 20 49 4e id IN
ca20: 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 TEGER PRIMARY KE
ca30: 59 2c 0a 20 20 20 20 20 20 20 20 20 20 70 69 64 Y,. pid
ca40: 20 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 2c INTEGER,
ca50: 0a 20 20 20 20 20 20 20 20 20 20 75 73 65 72 6e . usern
ca60: 61 6d 65 20 20 20 54 45 58 54 2c 0a 20 20 20 20 ame TEXT,.
ca70: 20 20 20 20 20 20 68 6f 73 74 6e 61 6d 65 20 20 hostname
ca80: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
ca90: 20 69 70 61 64 64 72 20 20 20 20 20 54 45 58 54 ipaddr TEXT
caa0: 2c 0a 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 ,. port
cab0: 6e 75 6d 20 20 20 20 49 4e 54 45 47 45 52 2c 0a num INTEGER,.
cac0: 20 20 20 20 20 20 20 20 20 20 73 74 61 72 74 5f start_
cad0: 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 44 time TIMESTAMP D
cae0: 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d 65 EFAULT (strftime
caf0: 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a 20 ('%s','now')),.
cb00: 20 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e 53 CONS
cb10: 54 52 41 49 4e 54 20 68 6f 73 74 70 6f 72 74 20 TRAINT hostport
cb20: 55 4e 49 51 55 45 20 28 68 6f 73 74 6e 61 6d 65 UNIQUE (hostname
cb30: 2c 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 20 ,portnum).
cb40: 20 20 29 3b 22 0a 20 20 20 20 20 20 29 29 0a 20 );". )).
cb50: 20 20 20 64 62 29 29 0a 0a 3b 3b 20 72 65 67 69 db))..;; regi
cb60: 73 74 65 72 20 61 20 64 61 73 68 62 6f 61 72 64 ster a dashboard
cb70: 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 .;;.(define (md
cb80: 64 62 3a 72 65 67 69 73 74 65 72 2d 64 61 73 68 db:register-dash
cb90: 62 6f 61 72 64 20 70 6f 72 74 29 0a 20 20 28 6c board port). (l
cba0: 65 74 2a 20 28 28 70 69 64 20 20 20 20 20 20 28 et* ((pid (
cbb0: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
cbc0: 69 64 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 id)).. (hostname
cbd0: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
cbe0: 29 0a 09 20 28 69 70 61 64 64 72 20 20 20 28 73 ).. (ipaddr (s
cbf0: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
cc00: 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 uess-address hos
cc10: 74 6e 61 6d 65 29 29 0a 09 20 28 75 73 65 72 6e tname)).. (usern
cc20: 61 6d 65 20 28 63 75 72 72 65 6e 74 2d 75 73 65 ame (current-use
cc30: 72 2d 6e 61 6d 65 29 29 20 3b 3b 20 28 63 61 72 r-name)) ;; (car
cc40: 20 75 73 65 72 69 6e 66 6f 29 29 29 0a 09 20 28 userinfo))).. (
cc50: 64 62 20 20 20 20 20 20 28 6d 64 64 62 3a 6f 70 db (mddb:op
cc60: 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 70 72 en-db))). (pr
cc70: 69 6e 74 20 22 52 65 67 69 73 74 65 72 20 6d 6f int "Register mo
cc80: 6e 69 74 6f 72 2c 20 70 69 64 3a 20 22 20 70 69 nitor, pid: " pi
cc90: 64 20 22 2c 20 68 6f 73 74 6e 61 6d 65 3a 20 22 d ", hostname: "
cca0: 20 68 6f 73 74 6e 61 6d 65 20 22 2c 20 70 6f 72 hostname ", por
ccb0: 74 3a 20 22 20 70 6f 72 74 20 22 2c 20 75 73 65 t: " port ", use
ccc0: 72 6e 61 6d 65 3a 20 22 20 75 73 65 72 6e 61 6d rname: " usernam
ccd0: 65 29 0a 20 20 20 20 28 65 78 65 63 20 28 73 71 e). (exec (sq
cce0: 6c 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 l db "INSERT OR
ccf0: 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 64 61 73 REPLACE INTO das
cd00: 68 62 6f 61 72 64 73 20 28 70 69 64 2c 75 73 65 hboards (pid,use
cd10: 72 6e 61 6d 65 2c 68 6f 73 74 6e 61 6d 65 2c 69 rname,hostname,i
cd20: 70 61 64 64 72 2c 70 6f 72 74 6e 75 6d 29 20 56 paddr,portnum) V
cd30: 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f ALUES (?,?,?,?,?
cd40: 29 3b 22 29 0a 09 20 20 20 70 69 64 20 75 73 65 );").. pid use
cd50: 72 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 20 69 rname hostname i
cd60: 70 61 64 64 72 20 70 6f 72 74 29 0a 20 20 20 20 paddr port).
cd70: 28 63 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 20 (close-database
cd80: 64 62 29 29 29 0a 0a 3b 3b 20 75 6e 72 65 67 69 db)))..;; unregi
cd90: 73 74 65 72 20 61 20 6d 6f 6e 69 74 6f 72 0a 3b ster a monitor.;
cda0: 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a ;.(define (mddb:
cdb0: 75 6e 72 65 67 69 73 74 65 72 2d 64 61 73 68 62 unregister-dashb
cdc0: 6f 61 72 64 20 68 6f 73 74 20 70 6f 72 74 29 0a oard host port).
cdd0: 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 (let* ((db
cde0: 20 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 (mddb:open-db)
cdf0: 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 )). (print "R
ce00: 65 67 69 73 74 65 72 20 75 6e 72 65 67 69 73 74 egister unregist
ce10: 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 68 6f 73 74 er monitor, host
ce20: 3a 70 6f 72 74 3d 22 20 68 6f 73 74 20 22 3a 22 :port=" host ":"
ce30: 20 70 6f 72 74 29 0a 20 20 20 20 28 65 78 65 63 port). (exec
ce40: 20 28 73 71 6c 20 64 62 20 22 44 45 4c 45 54 45 (sql db "DELETE
ce50: 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 73 FROM dashboards
ce60: 20 57 48 45 52 45 20 68 6f 73 74 6e 61 6d 65 3d WHERE hostname=
ce70: 3f 20 41 4e 44 20 70 6f 72 74 6e 75 6d 3d 3f 3b ? AND portnum=?;
ce80: 22 29 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 ") host port).
ce90: 20 20 28 63 6c 6f 73 65 2d 64 61 74 61 62 61 73 (close-databas
cea0: 65 20 64 62 29 29 29 0a 0a 3b 3b 20 67 65 74 20 e db)))..;; get
ceb0: 72 65 67 69 73 74 65 72 65 64 20 64 61 73 68 62 registered dashb
cec0: 6f 61 72 64 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 oards.;;.(define
ced0: 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 62 (mddb:get-dashb
cee0: 6f 61 72 64 73 29 0a 20 20 28 6c 65 74 20 28 28 oards). (let ((
cef0: 64 62 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 db (mddb:open-db
cf00: 29 29 29 0a 20 20 20 20 28 71 75 65 72 79 20 66 ))). (query f
cf10: 65 74 63 68 2d 63 6f 6c 75 6d 6e 0a 09 20 20 20 etch-column..
cf20: 28 73 71 6c 20 64 62 20 22 53 45 4c 45 43 54 20 (sql db "SELECT
cf30: 69 70 61 64 64 72 20 7c 7c 20 27 3a 27 20 7c 7c ipaddr || ':' ||
cf40: 20 70 6f 72 74 6e 75 6d 20 46 52 4f 4d 20 64 61 portnum FROM da
cf50: 73 68 62 6f 61 72 64 73 3b 22 29 29 29 29 0a 20 shboards;")))).
cf60: 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;==========
cf70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cf80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cf90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cfa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
cfb0: 20 54 20 45 20 53 20 54 20 20 20 4c 20 41 20 55 T E S T L A U
cfc0: 20 4e 20 43 20 48 20 49 20 4e 20 47 20 20 20 50 N C H I N G P
cfd0: 20 45 20 52 20 20 20 49 20 54 20 45 20 4d 20 20 E R I T E M
cfe0: 20 57 20 49 20 54 20 48 20 20 20 48 20 4f 20 53 W I T H H O S
cff0: 20 54 20 20 20 54 20 59 20 50 20 45 20 53 0a 3b T T Y P E S.;
d000: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
d010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d040: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 5b =======.;; .;; [
d050: 68 6f 73 74 2d 74 79 70 65 73 5d 0a 3b 3b 20 67 host-types].;; g
d060: 65 6e 65 72 61 6c 20 73 73 68 20 23 7b 67 65 74 eneral ssh #{get
d070: 62 67 65 73 74 68 6f 73 74 20 67 65 6e 65 72 61 bgesthost genera
d080: 6c 7d 0a 3b 3b 20 6e 62 67 65 6e 65 72 61 6c 20 l}.;; nbgeneral
d090: 6e 62 6a 6f 62 20 72 75 6e 20 4a 4f 42 43 4f 4d nbjob run JOBCOM
d0a0: 4d 41 4e 44 20 2d 6c 6f 67 20 24 4d 54 5f 4c 49 MAND -log $MT_LI
d0b0: 4e 4b 54 52 45 45 2f 24 4d 54 5f 54 41 52 47 45 NKTREE/$MT_TARGE
d0c0: 54 2f 24 4d 54 5f 52 55 4e 4e 41 4d 45 2e 24 4d T/$MT_RUNNAME.$M
d0d0: 54 5f 54 45 53 54 4e 41 4d 45 2d 24 4d 54 5f 49 T_TESTNAME-$MT_I
d0e0: 54 45 4d 5f 50 41 54 48 2e 6c 67 6f 0a 3b 3b 20 TEM_PATH.lgo.;;
d0f0: 0a 3b 3b 20 5b 68 6f 73 74 73 5d 0a 3b 3b 20 67 .;; [hosts].;; g
d100: 65 6e 65 72 61 6c 20 63 75 62 69 61 6e 20 78 65 eneral cubian xe
d110: 6e 61 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 6e 63 na.;; .;; [launc
d120: 68 65 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 74 75 hers].;; envsetu
d130: 70 20 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 6f 72 p general.;; xor
d140: 2f 25 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 25 20 /%/n 4C16G.;; %
d150: 6e 62 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a 3b 3b nbgeneral.;; .;;
d160: 20 5b 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b 20 6c [jobtools].;; l
d170: 61 75 6e 63 68 65 72 20 62 73 75 62 0a 3b 3b 20 auncher bsub.;;
d180: 23 20 69 66 20 64 65 66 69 6e 65 64 20 61 6e 64 # if defined and
d190: 20 6e 6f 74 20 22 6e 6f 22 20 66 6c 65 78 69 2d not "no" flexi-
d1a0: 6c 61 75 6e 63 68 65 72 20 77 69 6c 6c 20 62 79 launcher will by
d1b0: 70 61 73 73 20 6c 61 75 6e 63 68 65 72 20 75 6e pass launcher un
d1c0: 6c 65 73 73 20 74 68 65 72 65 20 69 73 20 6e 6f less there is no
d1d0: 0a 3b 3b 20 23 20 6d 61 74 63 68 2e 0a 3b 3b 20 .;; # match..;;
d1e0: 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 79 flexi-launcher y
d1f0: 65 73 20 20 0a 0a 28 64 65 66 69 6e 65 20 28 63 es ..(define (c
d200: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 75 6e 63 68 ommon:get-launch
d210: 65 72 20 63 6f 6e 66 69 67 64 61 74 20 74 65 73 er configdat tes
d220: 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a tname itempath).
d230: 20 20 28 6c 65 74 20 28 28 66 61 6c 6c 62 61 63 (let ((fallbac
d240: 6b 2d 6c 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 k-launcher (conf
d250: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
d260: 67 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 gdat "jobtools"
d270: 22 6c 61 75 6e 63 68 65 72 22 29 29 29 0a 20 20 "launcher"))).
d280: 20 20 28 69 66 20 28 61 6e 64 20 28 63 6f 6e 66 (if (and (conf
d290: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
d2a0: 67 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 gdat "jobtools"
d2b0: 22 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 "flexi-launcher"
d2c0: 29 20 3b 3b 20 6f 76 65 72 72 69 64 65 73 20 6c ) ;; overrides l
d2d0: 61 75 6e 63 68 65 72 0a 09 20 20 20 20 20 28 6e auncher.. (n
d2e0: 6f 74 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 ot (equal? (conf
d2f0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
d300: 67 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 gdat "jobtools"
d310: 22 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 "flexi-launcher"
d320: 29 20 22 6e 6f 22 29 29 29 0a 09 28 6c 65 74 2a ) "no")))..(let*
d330: 20 28 28 6c 61 75 6e 63 68 65 72 73 20 20 20 20 ((launchers
d340: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
d350: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e -ref/default con
d360: 66 69 67 64 61 74 20 22 6c 61 75 6e 63 68 65 72 figdat "launcher
d370: 73 22 20 27 28 29 29 29 29 0a 09 20 20 28 69 66 s" '()))).. (if
d380: 20 28 6e 75 6c 6c 3f 20 6c 61 75 6e 63 68 65 72 (null? launcher
d390: 73 29 0a 09 20 20 20 20 20 20 66 61 6c 6c 62 61 s).. fallba
d3a0: 63 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 20 20 20 ck-launcher..
d3b0: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
d3c0: 65 64 20 28 63 61 72 20 6c 61 75 6e 63 68 65 72 ed (car launcher
d3d0: 73 29 29 0a 09 09 09 20 28 74 61 6c 20 28 63 64 s)).... (tal (cd
d3e0: 72 20 6c 61 75 6e 63 68 65 72 73 29 29 29 0a 09 r launchers)))..
d3f0: 09 28 6c 65 74 20 28 28 70 61 74 74 20 20 20 20 .(let ((patt
d400: 20 20 28 63 61 72 20 68 65 64 29 29 0a 09 09 20 (car hed))...
d410: 20 20 20 20 20 28 68 6f 73 74 2d 74 79 70 65 20 (host-type
d420: 28 63 61 64 72 20 68 65 64 29 29 29 0a 09 09 20 (cadr hed)))...
d430: 20 28 69 66 20 28 74 65 73 74 73 3a 6d 61 74 63 (if (tests:matc
d440: 68 20 70 61 74 74 20 74 65 73 74 6e 61 6d 65 20 h patt testname
d450: 69 74 65 6d 70 61 74 68 29 0a 09 09 20 20 20 20 itempath)...
d460: 20 20 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 (begin....(deb
d470: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 ug:print-info 2
d480: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
d490: 74 2a 20 22 48 61 76 65 20 66 6c 65 78 69 2d 6c t* "Have flexi-l
d4a0: 61 75 6e 63 68 65 72 20 6d 61 74 63 68 20 66 6f auncher match fo
d4b0: 72 20 22 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 r " testname "/"
d4c0: 20 69 74 65 6d 70 61 74 68 20 22 20 3d 20 22 20 itempath " = "
d4d0: 68 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 28 6c host-type)....(l
d4e0: 65 74 20 28 28 6c 61 75 6e 63 68 65 72 20 28 63 et ((launcher (c
d4f0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
d500: 6e 66 69 67 64 61 74 20 22 68 6f 73 74 2d 74 79 nfigdat "host-ty
d510: 70 65 73 22 20 68 6f 73 74 2d 74 79 70 65 29 29 pes" host-type))
d520: 29 0a 09 09 09 20 20 28 69 66 20 6c 61 75 6e 63 ).... (if launc
d530: 68 65 72 0a 09 09 09 20 20 20 20 20 20 6c 61 75 her.... lau
d540: 6e 63 68 65 72 0a 09 09 09 20 20 20 20 20 20 28 ncher.... (
d550: 62 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 begin.....(debug
d560: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
d570: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
d580: 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 6c 61 "WARNING: no la
d590: 75 6e 63 68 65 72 20 66 6f 75 6e 64 20 66 6f 72 uncher found for
d5a0: 20 68 6f 73 74 2d 74 79 70 65 20 22 20 68 6f 73 host-type " hos
d5b0: 74 2d 74 79 70 65 29 0a 09 09 09 09 28 69 66 20 t-type).....(if
d5c0: 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 (null? tal).....
d5d0: 20 20 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 fallback-lau
d5e0: 6e 63 68 65 72 0a 09 09 09 09 20 20 20 20 28 6c ncher..... (l
d5f0: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
d600: 72 20 74 61 6c 29 29 29 29 29 29 29 0a 09 09 20 r tal)))))))...
d610: 20 20 20 20 20 3b 3b 20 6e 6f 20 6d 61 74 63 68 ;; no match
d620: 2c 20 74 72 79 20 61 67 61 69 6e 0a 09 09 20 20 , try again...
d630: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
d640: 61 6c 29 0a 09 09 09 20 20 66 61 6c 6c 62 61 63 al).... fallbac
d650: 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 k-launcher....
d660: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
d670: 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a cdr tal)))))))).
d680: 09 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 .fallback-launch
d690: 65 72 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d er))). .;;=====
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 3d ================
d6d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d6e0: 3d 0a 3b 3b 20 44 20 41 20 53 20 48 20 42 20 4f =.;; D A S H B O
d6f0: 20 41 20 52 20 44 20 20 20 55 20 53 20 45 20 52 A R D U S E R
d700: 20 20 20 56 20 49 20 45 20 57 20 53 0a 3b 3b 3d V I E W S.;;=
d710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d750: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 72 73 74 20 =====..;; first
d760: 72 65 61 64 20 7e 2f 76 69 65 77 73 2e 63 6f 6e read ~/views.con
d770: 66 69 67 20 69 66 20 69 74 20 65 78 69 73 74 73 fig if it exists
d780: 2c 20 74 68 65 6e 20 72 65 61 64 20 24 4d 54 52 , then read $MTR
d790: 41 48 2f 76 69 65 77 73 2e 63 6f 6e 66 69 67 20 AH/views.config
d7a0: 69 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 0a if it exists.;;.
d7b0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
d7c0: 6c 6f 61 64 2d 76 69 65 77 73 2d 63 6f 6e 66 69 load-views-confi
d7d0: 67 29 0a 20 20 28 6c 65 74 2a 20 28 28 76 69 65 g). (let* ((vie
d7e0: 77 2d 63 66 67 64 61 74 20 20 20 20 28 6d 61 6b w-cfgdat (mak
d7f0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 e-hash-table))..
d800: 20 28 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 20 (home-cfgfile
d810: 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 (conc (get-envi
d820: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
d830: 20 22 48 4f 4d 45 22 29 20 22 2f 2e 6d 74 76 69 "HOME") "/.mtvi
d840: 65 77 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 ews.config"))..
d850: 28 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 (mthome-cfgfile
d860: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
d870: 22 2f 2e 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 "/.mtviews.confi
d880: 67 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 g"))). (if (f
d890: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 68 6f ile-exists? mtho
d8a0: 6d 65 2d 63 66 67 66 69 6c 65 29 0a 09 28 72 65 me-cfgfile)..(re
d8b0: 61 64 2d 63 6f 6e 66 69 67 20 6d 74 68 6f 6d 65 ad-config mthome
d8c0: 2d 63 66 67 66 69 6c 65 20 76 69 65 77 2d 63 66 -cfgfile view-cf
d8d0: 67 64 61 74 20 23 74 29 29 0a 20 20 20 20 3b 3b gdat #t)). ;;
d8e0: 20 77 65 20 6c 6f 61 64 20 74 68 65 20 68 6f 6d we load the hom
d8f0: 65 20 64 69 72 20 66 69 6c 65 20 41 46 54 45 52 e dir file AFTER
d900: 20 74 68 65 20 4d 54 52 41 48 20 66 69 6c 65 20 the MTRAH file
d910: 73 6f 20 74 68 65 20 75 73 65 72 20 63 61 6e 20 so the user can
d920: 63 6c 6f 62 62 65 72 20 73 65 74 74 69 6e 67 73 clobber settings
d930: 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 74 68 when running th
d940: 65 20 64 61 73 68 62 6f 61 72 64 20 69 6e 20 72 e dashboard in r
d950: 65 61 64 2d 6f 6e 6c 79 20 61 72 65 61 73 0a 20 ead-only areas.
d960: 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 (if (file-exi
d970: 73 74 73 3f 20 68 6f 6d 65 2d 63 66 67 66 69 6c sts? home-cfgfil
d980: 65 29 0a 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 e)..(read-config
d990: 20 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 home-cfgfile vi
d9a0: 65 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 ew-cfgdat #t)).
d9b0: 20 20 20 76 69 65 77 2d 63 66 67 64 61 74 29 29 view-cfgdat))
d9c0: 0a 0a ..