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 28 69 6e 63 6c 75 64 65 20 22 74 68 75 6e 6b .(include "thunk
0340: 2d 75 74 69 6c 73 2e 73 63 6d 22 29 0a 0a 0a 3b -utils.scm")...;
0350: 3b 20 28 72 65 71 75 69 72 65 2d 6c 69 62 72 61 ; (require-libra
0360: 72 79 20 6d 61 72 67 73 29 0a 3b 3b 20 28 69 6e ry margs).;; (in
0370: 63 6c 75 64 65 20 22 6d 61 72 67 73 2e 73 63 6d clude "margs.scm
0380: 22 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 6f ")..;; (define o
0390: 6c 64 2d 65 78 69 74 20 65 78 69 74 29 0a 3b 3b ld-exit exit).;;
03a0: 20 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 65 78 .;; (define (ex
03b0: 69 74 20 2e 20 63 6f 64 65 29 0a 3b 3b 20 20 20 it . code).;;
03c0: 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6f 64 65 29 (if (null? code)
03d0: 0a 3b 3b 20 20 20 20 20 20 20 28 6f 6c 64 2d 65 .;; (old-e
03e0: 78 69 74 29 0a 3b 3b 20 20 20 20 20 20 20 28 6f xit).;; (o
03f0: 6c 64 2d 65 78 69 74 20 63 6f 64 65 29 29 29 0a ld-exit code))).
0400: 0a 28 64 65 66 69 6e 65 20 67 65 74 65 6e 76 20 .(define getenv
0410: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
0420: 76 61 72 69 61 62 6c 65 29 0a 28 64 65 66 69 6e variable).(defin
0430: 65 20 28 73 61 66 65 2d 73 65 74 65 6e 76 20 6b e (safe-setenv k
0440: 65 79 20 76 61 6c 29 0a 20 20 28 69 66 20 28 61 ey val). (if (a
0450: 6e 64 20 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 nd (string? val)
0460: 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 29 0a 20 (string? key)).
0470: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
0480: 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 65 eptions. e
0490: 78 6e 0a 20 20 20 20 20 20 20 28 64 65 62 75 67 xn. (debug
04a0: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
04b0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
04c0: 2a 20 22 62 61 64 20 76 61 6c 75 65 20 66 6f 72 * "bad value for
04d0: 20 73 65 74 65 6e 76 2c 20 6b 65 79 3d 22 20 6b setenv, key=" k
04e0: 65 79 20 22 2c 20 76 61 6c 75 65 3d 22 20 76 61 ey ", value=" va
04f0: 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 65 6e l). (seten
0500: 76 20 6b 65 79 20 76 61 6c 29 29 0a 20 20 20 20 v key val)).
0510: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
0520: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
0530: 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 76 log-port* "bad v
0540: 61 6c 75 65 20 66 6f 72 20 73 65 74 65 6e 76 2c alue for setenv,
0550: 20 6b 65 79 3d 22 20 6b 65 79 20 22 2c 20 76 61 key=" key ", va
0560: 6c 75 65 3d 22 20 76 61 6c 29 29 29 0a 0a 28 64 lue=" val)))..(d
0570: 65 66 69 6e 65 20 68 6f 6d 65 20 28 67 65 74 65 efine home (gete
0580: 6e 76 20 22 48 4f 4d 45 22 29 29 0a 28 64 65 66 nv "HOME")).(def
0590: 69 6e 65 20 75 73 65 72 20 28 67 65 74 65 6e 76 ine user (getenv
05a0: 20 22 55 53 45 52 22 29 29 0a 0a 3b 3b 20 47 4c "USER"))..;; GL
05b0: 4f 42 41 4c 20 47 4c 45 54 43 48 45 53 0a 0a 3b OBAL GLETCHES..;
05c0: 3b 20 43 4f 4e 54 45 58 54 53 0a 28 64 65 66 73 ; CONTEXTS.(defs
05d0: 74 72 75 63 74 20 63 78 74 0a 20 20 28 74 61 73 truct cxt. (tas
05e0: 6b 64 62 20 23 66 29 0a 20 20 28 63 6d 75 74 65 kdb #f). (cmute
05f0: 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 29 x (make-mutex)))
0600: 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e 74 65 78 .(define *contex
0610: 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ts* (make-hash-t
0620: 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a able)).(define *
0630: 63 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a 20 28 context-mutex* (
0640: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b make-mutex))..;;
0650: 20 73 61 66 65 20 6d 65 74 68 6f 64 20 66 6f 72 safe method for
0660: 20 61 63 63 65 73 73 69 6e 67 20 61 20 63 6f 6e accessing a con
0670: 74 65 78 74 20 67 69 76 65 6e 20 61 20 74 6f 70 text given a top
0680: 70 61 74 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 path.;;.(define
0690: 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d 63 78 74 (common:with-cxt
06a0: 20 74 6f 70 70 61 74 68 20 70 72 6f 63 29 0a 20 toppath proc).
06b0: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 63 (mutex-lock! *c
06c0: 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a 29 0a 20 ontext-mutex*).
06d0: 20 28 6c 65 74 20 28 28 63 78 74 20 28 68 61 73 (let ((cxt (has
06e0: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
06f0: 75 6c 74 20 2a 63 6f 6e 74 65 78 74 73 2a 20 74 ult *contexts* t
0700: 6f 70 70 61 74 68 20 23 66 29 29 29 0a 20 20 20 oppath #f))).
0710: 20 28 69 66 20 28 6e 6f 74 20 63 78 74 29 0a 20 (if (not cxt).
0720: 20 20 20 20 20 20 20 28 73 65 74 21 20 63 78 74 (set! cxt
0730: 20 28 6c 65 74 20 28 28 78 20 28 6d 61 6b 65 2d (let ((x (make-
0740: 63 78 74 29 29 29 28 68 61 73 68 2d 74 61 62 6c cxt)))(hash-tabl
0750: 65 2d 73 65 74 21 20 2a 63 6f 6e 74 65 78 74 73 e-set! *contexts
0760: 2a 20 74 6f 70 70 61 74 68 20 78 29 20 78 29 29 * toppath x) x))
0770: 29 0a 20 20 20 20 28 6c 65 74 20 28 28 63 78 74 ). (let ((cxt
0780: 2d 6d 75 74 65 78 20 28 63 78 74 2d 6d 75 74 65 -mutex (cxt-mute
0790: 78 20 63 78 74 29 29 29 0a 20 20 20 20 20 20 28 x cxt))). (
07a0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 63 mutex-unlock! *c
07b0: 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a 29 0a 20 ontext-mutex*).
07c0: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
07d0: 21 20 63 78 74 2d 6d 75 74 65 78 29 0a 20 20 20 ! cxt-mutex).
07e0: 20 20 20 3b 3b 20 68 65 72 65 20 77 65 20 67 75 ;; here we gu
07f0: 61 72 64 20 70 72 6f 63 20 77 69 74 68 20 65 78 ard proc with ex
0800: 63 65 70 74 69 6f 6e 20 68 61 6e 64 6c 65 72 20 ception handler
0810: 73 6f 0a 20 20 20 20 20 20 3b 3b 20 6e 6f 20 6d so. ;; no m
0820: 61 74 74 65 72 20 68 6f 77 20 70 72 6f 63 20 73 atter how proc s
0830: 75 63 63 65 65 64 73 20 6f 72 20 66 61 69 6c 73 ucceeds or fails
0840: 2c 0a 20 20 20 20 20 20 3b 3b 20 74 68 65 20 63 ,. ;; the c
0850: 78 74 2d 6d 75 74 65 78 20 77 69 6c 6c 20 62 65 xt-mutex will be
0860: 20 75 6e 6c 6f 63 6b 65 64 20 61 66 74 65 72 77 unlocked afterw
0870: 61 72 64 2e 0a 20 20 20 20 20 20 28 6c 65 74 2a ard.. (let*
0880: 20 28 28 45 58 43 45 50 54 49 4f 4e 2d 53 59 4d ((EXCEPTION-SYM
0890: 42 4f 4c 20 28 67 65 6e 73 79 6d 29 29 20 3b 3b BOL (gensym)) ;;
08a0: 20 75 73 65 20 61 20 67 65 6e 65 72 61 74 65 64 use a generated
08b0: 20 73 79 6d 62 6f 6c 0a 20 20 20 20 20 20 20 20 symbol.
08c0: 20 20 20 20 20 28 67 75 61 72 64 65 64 2d 70 72 (guarded-pr
08d0: 6f 63 20 20 20 20 20 20 20 20 20 20 20 20 20 20 oc
08e0: 20 3b 3b 20 74 6f 20 61 76 6f 69 64 20 63 6f 6c ;; to avoid col
08f0: 6c 69 73 69 6f 6e 0a 20 20 20 20 20 20 20 20 20 lision.
0900: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 61 72 67 (lambda arg
0910: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
0920: 20 20 28 6c 65 74 2a 20 28 28 72 65 73 20 28 63 (let* ((res (c
0930: 6f 6e 64 69 74 69 6f 6e 2d 63 61 73 65 0a 20 20 ondition-case.
0940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0950: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 6c (appl
0960: 79 20 70 72 6f 63 20 61 72 67 73 29 0a 20 20 20 y proc args).
0970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0980: 20 20 20 20 20 20 20 20 20 20 5b 78 20 28 29 20 [x ()
0990: 28 63 6f 6e 73 20 45 58 43 45 50 54 49 4f 4e 2d (cons EXCEPTION-
09a0: 53 59 4d 42 4f 4c 20 78 29 5d 29 29 29 0a 20 20 SYMBOL x)]))).
09b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
09c0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 63 78 mutex-unlock! cx
09d0: 74 2d 6d 75 74 65 78 29 0a 20 20 20 20 20 20 20 t-mutex).
09e0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
09f0: 6e 64 20 28 70 61 69 72 3f 20 72 65 73 29 20 28 nd (pair? res) (
0a00: 65 71 3f 20 28 63 61 72 20 72 65 73 29 20 45 58 eq? (car res) EX
0a10: 43 45 50 54 49 4f 4e 29 29 0a 20 20 20 20 20 20 CEPTION)).
0a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0a30: 61 62 6f 72 74 20 28 63 64 72 20 72 65 73 29 29 abort (cdr res))
0a40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0a50: 20 20 20 20 20 20 72 65 73 29 29 29 29 29 0a 20 res))))).
0a60: 20 20 20 20 20 20 20 28 67 75 61 72 64 65 64 2d (guarded-
0a70: 70 72 6f 63 20 63 78 74 29 29 29 29 29 0a 20 20 proc cxt))))).
0a80: 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 2a .(define *
0a90: 64 62 2d 6b 65 79 73 2a 20 23 66 29 0a 0a 28 64 db-keys* #f)..(d
0aa0: 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 69 6e 66 efine *configinf
0ab0: 6f 2a 20 20 20 23 66 29 20 20 20 3b 3b 20 72 61 o* #f) ;; ra
0ac0: 77 20 72 65 73 75 6c 74 73 20 66 72 6f 6d 20 73 w results from s
0ad0: 65 74 75 70 2c 20 69 6e 63 6c 75 64 65 73 20 74 etup, includes t
0ae0: 6f 70 70 61 74 68 20 61 6e 64 20 74 61 62 6c 65 oppath and table
0af0: 20 66 72 6f 6d 20 6d 65 67 61 74 65 73 74 2e 63 from megatest.c
0b00: 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 2a 72 onfig.(define *r
0b10: 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 23 66 29 unconfigdat* #f)
0b20: 20 20 20 3b 3b 20 72 75 6e 20 63 6f 6e 66 69 67 ;; run config
0b30: 73 20 64 61 74 61 0a 28 64 65 66 69 6e 65 20 2a s data.(define *
0b40: 63 6f 6e 66 69 67 64 61 74 2a 20 20 20 20 23 66 configdat* #f
0b50: 29 20 20 20 3b 3b 20 6d 65 67 61 74 65 73 74 2e ) ;; megatest.
0b60: 63 6f 6e 66 69 67 20 64 61 74 61 0a 28 64 65 66 config data.(def
0b70: 69 6e 65 20 2a 63 6f 6e 66 69 67 73 74 61 74 75 ine *configstatu
0b80: 73 2a 20 23 66 29 20 20 20 3b 3b 20 73 74 61 74 s* #f) ;; stat
0b90: 75 73 20 6f 66 20 64 61 74 61 3b 20 27 66 75 6c us of data; 'ful
0ba0: 6c 64 61 74 61 20 3a 20 61 6c 6c 20 70 72 6f 63 ldata : all proc
0bb0: 65 73 73 69 6e 67 20 64 6f 6e 65 2c 20 23 66 20 essing done, #f
0bc0: 3a 20 6e 6f 20 64 61 74 61 20 79 65 74 2c 20 27 : no data yet, '
0bd0: 70 61 72 74 69 61 6c 64 61 74 61 20 3a 20 70 61 partialdata : pa
0be0: 72 74 69 61 6c 20 72 65 61 64 20 64 6f 6e 65 0a rtial read done.
0bf0: 28 64 65 66 69 6e 65 20 2a 74 6f 70 70 61 74 68 (define *toppath
0c00: 2a 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 * #f).(defi
0c10: 6e 65 20 2a 61 6c 72 65 61 64 79 2d 73 65 65 6e ne *already-seen
0c20: 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a -runconfig-info*
0c30: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 2a 74 #f)..(define *t
0c40: 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 74 65 64 est-meta-updated
0c50: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
0c60: 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 67 6c le)).(define *gl
0c70: 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a 20 obalexitstatus*
0c80: 20 30 29 20 3b 3b 20 61 74 74 65 6d 70 74 20 74 0) ;; attempt t
0c90: 6f 20 77 6f 72 6b 20 61 72 6f 75 6e 64 20 70 6f o work around po
0ca0: 73 73 69 62 6c 65 20 74 68 72 65 61 64 20 69 73 ssible thread is
0cb0: 73 75 65 73 0a 28 64 65 66 69 6e 65 20 2a 70 61 sues.(define *pa
0cc0: 73 73 6e 75 6d 2a 20 20 20 20 20 20 20 20 20 20 ssnum*
0cd0: 20 30 29 20 3b 3b 20 77 68 65 6e 20 72 75 6e 6e 0) ;; when runn
0ce0: 69 6e 67 20 74 72 61 63 6b 20 63 61 6c 6c 73 20 ing track calls
0cf0: 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 6f 72 20 to run-tests or
0d00: 73 69 6d 69 6c 61 72 0a 28 64 65 66 69 6e 65 20 similar.(define
0d10: 2a 61 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a 20 23 *alt-log-file* #
0d20: 66 29 20 20 3b 3b 20 75 73 65 64 20 62 79 20 2d f) ;; used by -
0d30: 6c 6f 67 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d log.(define *com
0d40: 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 20 20 20 mon:denoise*
0d50: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
0d60: 29 29 20 3b 3b 20 66 6f 72 20 6c 6f 77 20 6e 6f )) ;; for low no
0d70: 69 73 65 20 70 72 69 6e 74 69 6e 67 0a 28 64 65 ise printing.(de
0d80: 66 69 6e 65 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fine *default-lo
0d90: 67 2d 70 6f 72 74 2a 20 20 28 63 75 72 72 65 6e g-port* (curren
0da0: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 28 t-error-port)).(
0db0: 64 65 66 69 6e 65 20 2a 74 69 6d 65 2d 7a 65 72 define *time-zer
0dc0: 6f 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f o* (current-seco
0dd0: 6e 64 73 29 29 20 3b 3b 20 66 6f 72 20 74 68 65 nds)) ;; for the
0de0: 20 77 61 74 63 68 64 6f 67 0a 0a 3b 3b 20 44 41 watchdog..;; DA
0df0: 54 41 42 41 53 45 0a 28 64 65 66 69 6e 65 20 2a TABASE.(define *
0e00: 64 62 73 74 72 75 63 74 2d 64 62 2a 20 20 20 20 dbstruct-db*
0e10: 20 20 20 20 20 23 66 29 20 3b 3b 20 75 73 65 64 #f) ;; used
0e20: 20 74 6f 20 63 61 63 68 65 20 74 68 65 20 64 62 to cache the db
0e30: 73 74 72 75 63 74 20 69 6e 20 64 62 3a 73 65 74 struct in db:set
0e40: 75 70 2e 20 47 6f 61 6c 20 69 73 20 74 6f 20 72 up. Goal is to r
0e50: 65 6d 6f 76 65 20 74 68 69 73 2e 0a 3b 3b 20 64 emove this..;; d
0e60: 62 20 73 74 61 74 73 0a 28 64 65 66 69 6e 65 20 b stats.(define
0e70: 2a 64 62 2d 73 74 61 74 73 2a 20 20 20 20 20 20 *db-stats*
0e80: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
0e90: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 61 73 68 -table)) ;; hash
0ea0: 20 6f 66 20 76 65 63 74 6f 72 73 20 3c 20 63 6f of vectors < co
0eb0: 75 6e 74 20 64 75 72 61 74 69 6f 6e 2d 74 6f 74 unt duration-tot
0ec0: 61 6c 20 3e 0a 28 64 65 66 69 6e 65 20 2a 64 62 al >.(define *db
0ed0: 2d 73 74 61 74 73 2d 6d 75 74 65 78 2a 20 20 20 -stats-mutex*
0ee0: 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 (make-mutex))
0ef0: 0a 3b 3b 20 64 62 20 61 63 63 65 73 73 0a 28 64 .;; db access.(d
0f00: 65 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 2d 61 efine *db-last-a
0f10: 63 63 65 73 73 2a 20 20 20 20 20 20 28 63 75 72 ccess* (cur
0f20: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b rent-seconds)) ;
0f30: 3b 20 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 ; last db access
0f40: 2c 20 75 73 65 64 20 69 6e 20 73 65 72 76 65 72 , used in server
0f50: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 77 72 69 .(define *db-wri
0f60: 74 65 2d 61 63 63 65 73 73 2a 20 20 20 20 20 23 te-access* #
0f70: 74 29 0a 3b 3b 20 64 62 20 73 79 6e 63 0a 28 64 t).;; db sync.(d
0f80: 65 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 2d 73 efine *db-last-s
0f90: 79 6e 63 2a 20 20 20 20 20 20 20 20 30 29 20 20 ync* 0)
0fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
0fb0: 3b 20 6c 61 73 74 20 74 69 6d 65 20 74 68 65 20 ; last time the
0fc0: 73 79 6e 63 20 74 6f 20 6d 65 67 61 74 65 73 74 sync to megatest
0fd0: 2e 64 62 20 68 61 70 70 65 6e 65 64 0a 28 64 65 .db happened.(de
0fe0: 66 69 6e 65 20 2a 64 62 2d 73 79 6e 63 2d 69 6e fine *db-sync-in
0ff0: 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 29 20 20 -progress* #f)
1000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
1010: 20 69 66 20 74 68 65 72 65 20 69 73 20 61 20 73 if there is a s
1020: 79 6e 63 20 69 6e 20 70 72 6f 67 72 65 73 73 20 ync in progress
1030: 64 6f 20 6e 6f 74 20 74 72 79 20 74 6f 20 73 74 do not try to st
1040: 61 72 74 20 61 6e 6f 74 68 65 72 0a 28 64 65 66 art another.(def
1050: 69 6e 65 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 ine *db-multi-sy
1060: 6e 63 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d nc-mutex* (make-
1070: 6d 75 74 65 78 29 29 20 20 20 20 20 20 3b 3b 20 mutex)) ;;
1080: 70 72 6f 74 65 63 74 20 61 63 63 65 73 73 20 74 protect access t
1090: 6f 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 o *db-sync-in-pr
10a0: 6f 67 72 65 73 73 2a 2c 20 2a 64 62 2d 6c 61 73 ogress*, *db-las
10b0: 74 2d 73 79 6e 63 2a 0a 3b 3b 20 74 61 73 6b 20 t-sync*.;; task
10c0: 64 62 0a 28 64 65 66 69 6e 65 20 2a 74 61 73 6b db.(define *task
10d0: 2d 64 62 2a 20 20 20 20 20 20 20 20 20 20 20 20 -db*
10e0: 20 23 66 29 20 3b 3b 20 28 76 65 63 74 6f 72 20 #f) ;; (vector
10f0: 64 62 20 70 61 74 68 2d 74 6f 2d 64 62 29 0a 28 db path-to-db).(
1100: 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 73 define *db-acces
1110: 73 2d 61 6c 6c 6f 77 65 64 2a 20 20 20 23 74 29 s-allowed* #t)
1120: 20 3b 3b 20 66 6c 61 67 20 74 6f 20 61 6c 6c 6f ;; flag to allo
1130: 77 20 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 w access.(define
1140: 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 *db-access-mute
1150: 78 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 x* (make-mut
1160: 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 ex)).(define *db
1170: 2d 63 61 63 68 65 2d 70 61 74 68 2a 20 20 20 20 -cache-path*
1180: 20 20 20 23 66 29 0a 0a 3b 3b 20 53 45 52 56 45 #f)..;; SERVE
1190: 52 0a 28 64 65 66 69 6e 65 20 2a 6d 79 2d 63 6c R.(define *my-cl
11a0: 69 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 ient-signature*
11b0: 23 66 29 0a 28 64 65 66 69 6e 65 20 2a 74 72 61 #f).(define *tra
11c0: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 20 20 23 66 nsport-type* #f
11d0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ) ;;
11e0: 20 6f 76 65 72 72 69 64 65 20 77 69 74 68 20 5b override with [
11f0: 73 65 72 76 65 72 5d 20 74 72 61 6e 73 70 6f 72 server] transpor
1200: 74 20 68 74 74 70 7c 72 70 63 7c 6e 6d 73 67 0a t http|rpc|nmsg.
1210: 0a 28 64 65 66 69 6e 65 20 2a 44 45 46 41 55 4c .(define *DEFAUL
1220: 54 2d 54 52 41 4e 53 50 4f 52 54 2a 20 22 68 74 T-TRANSPORT* "ht
1230: 74 70 22 29 0a 28 64 65 66 69 6e 65 20 28 63 6f tp").(define (co
1240: 6d 6d 6f 6e 3a 73 65 74 2d 74 72 61 6e 73 70 6f mmon:set-transpo
1250: 72 74 2d 74 79 70 65 29 0a 20 20 28 73 65 74 21 rt-type). (set!
1260: 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 *transport-type
1270: 2a 0a 20 20 20 20 20 20 20 20 28 73 74 72 69 6e *. (strin
1280: 67 2d 3e 73 79 6d 62 6f 6c 0a 20 20 20 20 20 20 g->symbol.
1290: 20 20 20 28 6f 72 0a 20 20 20 20 20 20 20 20 20 (or.
12a0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
12b0: 2d 74 72 61 6e 73 70 6f 72 74 22 29 0a 20 20 20 -transport").
12c0: 20 20 20 20 20 20 20 28 63 6f 6e 66 69 67 66 3a (configf:
12d0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
12e0: 74 2a 20 22 73 65 72 76 65 72 22 20 22 74 72 61 t* "server" "tra
12f0: 6e 73 70 6f 72 74 22 29 0a 20 20 20 20 20 20 20 nsport").
1300: 20 20 20 2a 44 45 46 41 55 4c 54 2d 54 52 41 4e *DEFAULT-TRAN
1310: 53 50 4f 52 54 2a 29 29 29 0a 20 20 2a 74 72 61 SPORT*))). *tra
1320: 6e 73 70 6f 72 74 2d 74 79 70 65 2a 29 0a 20 20 nsport-type*).
1330: 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 72 65 6d .(define *runrem
1340: 6f 74 65 2a 20 20 20 20 20 20 20 20 20 23 66 29 ote* #f)
1350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
1360: 3b 3b 20 69 66 20 73 65 74 20 75 70 20 66 6f 72 ;; if set up for
1370: 20 73 65 72 76 65 72 20 63 6f 6d 6d 75 6e 69 63 server communic
1380: 61 74 69 6f 6e 20 74 68 69 73 20 77 69 6c 6c 20 ation this will
1390: 68 6f 6c 64 20 3c 68 6f 73 74 20 70 6f 72 74 3e hold <host port>
13a0: 0a 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d 63 61 .(define *max-ca
13b0: 63 68 65 2d 73 69 7a 65 2a 20 20 20 20 30 29 0a che-size* 0).
13c0: 28 64 65 66 69 6e 65 20 2a 6c 6f 67 67 65 64 2d (define *logged-
13d0: 69 6e 2d 63 6c 69 65 6e 74 73 2a 20 28 6d 61 6b in-clients* (mak
13e0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 e-hash-table)).(
13f0: 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 define *server-i
1400: 64 2a 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 d* #f).(
1410: 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 define *server-i
1420: 6e 66 6f 2a 20 20 20 20 20 20 20 23 66 29 0a 28 nfo* #f).(
1430: 64 65 66 69 6e 65 20 2a 74 69 6d 65 2d 74 6f 2d define *time-to-
1440: 65 78 69 74 2a 20 20 20 20 20 20 23 66 29 0a 28 exit* #f).(
1450: 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 72 define *server-r
1460: 75 6e 2a 20 20 20 20 20 20 20 20 23 74 29 0a 28 un* #t).(
1470: 64 65 66 69 6e 65 20 2a 72 75 6e 2d 69 64 2a 20 define *run-id*
1480: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 #f).(
1490: 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 6b define *server-k
14a0: 69 6e 64 2d 72 75 6e 2a 20 20 20 28 6d 61 6b 65 ind-run* (make
14b0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 -hash-table)).(d
14c0: 65 66 69 6e 65 20 2a 68 6f 6d 65 2d 68 6f 73 74 efine *home-host
14d0: 2a 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 * #f).(d
14e0: 65 66 69 6e 65 20 2a 74 6f 74 61 6c 2d 6e 6f 6e efine *total-non
14f0: 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 30 29 -write-delay* 0)
1500: 0a 28 64 65 66 69 6e 65 20 2a 68 65 61 72 74 62 .(define *heartb
1510: 65 61 74 2d 6d 75 74 65 78 2a 20 20 20 28 6d 61 eat-mutex* (ma
1520: 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b 20 63 ke-mutex))..;; c
1530: 6c 69 65 6e 74 0a 28 64 65 66 69 6e 65 20 2a 72 lient.(define *r
1540: 6d 74 2d 6d 75 74 65 78 2a 20 20 20 20 20 20 20 mt-mutex*
1550: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 (make-mutex))
1560: 20 20 20 20 3b 3b 20 72 65 6d 6f 74 65 20 61 63 ;; remote ac
1570: 63 65 73 73 20 63 61 6c 6c 73 20 6d 75 74 65 78 cess calls mutex
1580: 20 0a 0a 3b 3b 20 52 50 43 20 74 72 61 6e 73 70 ..;; RPC transp
1590: 6f 72 74 0a 28 64 65 66 69 6e 65 20 2a 72 70 63 ort.(define *rpc
15a0: 3a 6c 69 73 74 65 6e 65 72 2a 20 20 20 20 20 20 :listener*
15b0: 23 66 29 0a 0a 3b 3b 20 4b 45 59 20 69 6e 66 6f #f)..;; KEY info
15c0: 0a 28 64 65 66 69 6e 65 20 2a 74 61 72 67 65 74 .(define *target
15d0: 2a 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 * (ma
15e0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
15f0: 3b 3b 20 63 61 63 68 65 20 74 68 65 20 74 61 72 ;; cache the tar
1600: 67 65 74 20 68 65 72 65 3b 20 74 61 72 67 65 74 get here; target
1610: 20 69 73 20 6b 65 79 76 61 6c 31 2f 6b 65 79 76 is keyval1/keyv
1620: 61 6c 32 2f 2e 2e 2e 2f 6b 65 79 76 61 6c 4e 0a al2/.../keyvalN.
1630: 28 64 65 66 69 6e 65 20 2a 6b 65 79 73 2a 20 20 (define *keys*
1640: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1650: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1660: 3b 20 63 61 63 68 65 20 74 68 65 20 6b 65 79 73 ; cache the keys
1670: 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 6b here.(define *k
1680: 65 79 76 61 6c 73 2a 20 20 20 20 20 20 20 20 20 eyvals*
1690: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
16a0: 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 74 6f le)).(define *to
16b0: 70 74 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 ptest-paths*
16c0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
16d0: 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 6f 70 e)) ;; cache top
16e0: 74 65 73 74 20 70 61 74 68 20 73 65 74 74 69 6e test path settin
16f0: 67 73 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 gs here.(define
1700: 2a 74 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 *test-paths*
1710: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1720: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
1730: 74 65 73 74 2d 69 64 20 74 6f 20 74 65 73 74 20 test-id to test
1740: 72 75 6e 20 70 61 74 68 73 20 68 65 72 65 0a 28 run paths here.(
1750: 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 69 64 73 define *test-ids
1760: 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 * (make
1770: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
1780: 20 63 61 63 68 65 20 72 75 6e 2d 69 64 2c 20 74 cache run-id, t
1790: 65 73 74 6e 61 6d 65 2c 20 61 6e 64 20 69 74 65 estname, and ite
17a0: 6d 2d 70 61 74 68 20 3d 3e 20 74 65 73 74 2d 69 m-path => test-i
17b0: 64 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d d.(define *test-
17c0: 69 6e 66 6f 2a 20 20 20 20 20 20 20 20 20 28 6d info* (m
17d0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
17e0: 20 3b 3b 20 63 61 63 68 65 20 74 68 65 20 74 65 ;; cache the te
17f0: 73 74 20 69 6e 66 6f 20 72 65 63 6f 72 64 73 2c st info records,
1800: 20 75 70 64 61 74 65 20 74 68 65 20 73 74 61 74 update the stat
1810: 65 2c 20 73 74 61 74 75 73 2c 20 72 75 6e 5f 64 e, status, run_d
1820: 75 72 61 74 69 6f 6e 20 65 74 63 2e 20 66 72 6f uration etc. fro
1830: 6d 20 74 65 73 74 64 61 74 2e 64 62 0a 0a 28 64 m testdat.db..(d
1840: 65 66 69 6e 65 20 2a 72 75 6e 2d 69 6e 66 6f 2d efine *run-info-
1850: 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 6b 65 cache* (make
1860: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
1870: 20 72 75 6e 20 69 6e 66 6f 20 69 73 20 73 74 61 run info is sta
1880: 62 6c 65 2c 20 6e 6f 20 6e 65 65 64 20 74 6f 20 ble, no need to
1890: 72 65 67 65 74 0a 28 64 65 66 69 6e 65 20 2a 6c reget.(define *l
18a0: 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 74 65 aunch-setup-mute
18b0: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
18c0: 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 ;; need to
18d0: 62 65 20 61 62 6c 65 20 74 6f 20 63 61 6c 6c 20 be able to call
18e0: 6c 61 75 6e 63 68 3a 73 65 74 75 70 20 6f 66 74 launch:setup oft
18f0: 65 6e 20 73 6f 20 6d 75 74 65 78 20 69 74 20 61 en so mutex it a
1900: 6e 64 20 72 65 2d 63 61 6c 6c 20 74 68 65 20 72 nd re-call the r
1910: 65 61 6c 20 64 65 61 6c 20 6f 6e 6c 79 20 69 66 eal deal only if
1920: 20 2a 74 6f 70 70 61 74 68 2a 20 6e 6f 74 20 73 *toppath* not s
1930: 65 74 0a 28 64 65 66 69 6e 65 20 2a 68 6f 6d 65 et.(define *home
1940: 68 6f 73 74 2d 6d 75 74 65 78 2a 20 20 20 20 20 host-mutex*
1950: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 28 (make-mutex))..(
1960: 64 65 66 73 74 72 75 63 74 20 72 65 6d 6f 74 65 defstruct remote
1970: 0a 20 20 28 68 68 2d 64 61 74 20 20 20 20 20 20 . (hh-dat
1980: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (common:ge
1990: 74 2d 68 6f 6d 65 68 6f 73 74 29 29 20 3b 3b 20 t-homehost)) ;;
19a0: 68 6f 6d 65 68 6f 73 74 20 72 65 63 6f 72 64 20 homehost record
19b0: 28 20 61 64 64 72 20 2e 20 68 68 66 6c 61 67 20 ( addr . hhflag
19c0: 29 0a 20 20 28 73 65 72 76 65 72 2d 75 72 6c 20 ). (server-url
19d0: 20 20 20 20 20 20 20 28 69 66 20 2a 74 6f 70 70 (if *topp
19e0: 61 74 68 2a 20 28 73 65 72 76 65 72 3a 72 65 61 ath* (server:rea
19f0: 64 2d 64 6f 74 73 65 72 76 65 72 20 2a 74 6f 70 d-dotserver *top
1a00: 70 61 74 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 path*))) ;; (ser
1a10: 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e ver:check-if-run
1a20: 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 20 ning *toppath*)
1a30: 23 66 29 29 0a 20 20 28 6c 61 73 74 2d 73 65 72 #f)). (last-ser
1a40: 76 65 72 2d 63 68 65 63 6b 20 30 29 20 20 3b 3b ver-check 0) ;;
1a50: 20 6c 61 73 74 20 74 69 6d 65 20 77 65 20 63 68 last time we ch
1a60: 65 63 6b 65 64 20 74 6f 20 73 65 65 20 69 66 20 ecked to see if
1a70: 74 68 65 20 73 65 72 76 65 72 20 77 61 73 20 61 the server was a
1a80: 6c 69 76 65 0a 20 20 28 63 6f 6e 6e 64 61 74 20 live. (conndat
1a90: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 #f).
1aa0: 28 74 72 61 6e 73 70 6f 72 74 20 20 20 20 20 20 (transport
1ab0: 20 20 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 *transport-ty
1ac0: 70 65 2a 29 0a 20 20 28 73 65 72 76 65 72 2d 74 pe*). (server-t
1ad0: 69 6d 65 6f 75 74 20 20 20 20 28 6f 72 20 28 73 imeout (or (s
1ae0: 65 72 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 erver:get-timeou
1af0: 74 29 20 31 30 30 29 29 29 20 3b 3b 20 64 65 66 t) 100))) ;; def
1b00: 61 75 6c 74 20 74 6f 20 31 30 30 20 73 65 63 6f ault to 100 seco
1b10: 6e 64 73 0a 0a 3b 3b 20 6c 61 75 6e 63 68 69 6e nds..;; launchin
1b20: 67 20 61 6e 64 20 68 6f 73 74 73 0a 28 64 65 66 g and hosts.(def
1b30: 73 74 72 75 63 74 20 68 6f 73 74 0a 20 20 28 72 struct host. (r
1b40: 65 61 63 68 61 62 6c 65 20 20 20 20 23 66 29 0a eachable #f).
1b50: 20 20 28 6c 61 73 74 2d 75 70 64 61 74 65 20 20 (last-update
1b60: 30 29 0a 20 20 28 6c 61 73 74 2d 75 73 65 64 20 0). (last-used
1b70: 20 20 20 30 29 0a 20 20 28 6c 61 73 74 2d 63 70 0). (last-cp
1b80: 75 6c 6f 61 64 20 31 29 29 0a 0a 28 64 65 66 69 uload 1))..(defi
1b90: 6e 65 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 ne *host-loads*
1ba0: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1bb0: 73 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 sh-table))..;; c
1bc0: 61 63 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 ache environment
1bd0: 20 76 61 72 73 20 66 6f 72 20 65 61 63 68 20 72 vars for each r
1be0: 75 6e 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 un here.(define
1bf0: 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e *env-vars-by-run
1c00: 2d 69 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d -id* (make-hash-
1c10: 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 54 65 73 74 table))..;; Test
1c20: 63 6f 6e 66 69 67 20 61 6e 64 20 72 75 6e 63 6f config and runco
1c30: 6e 66 69 67 20 63 61 63 68 65 73 2e 20 0a 28 64 nfig caches. .(d
1c40: 65 66 69 6e 65 20 2a 74 65 73 74 63 6f 6e 66 69 efine *testconfi
1c50: 67 73 2a 20 20 20 20 20 20 20 20 28 6d 61 6b 65 gs* (make
1c60: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
1c70: 20 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 test-name => te
1c80: 73 74 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 stconfig.(define
1c90: 20 2a 72 75 6e 63 6f 6e 66 69 67 73 2a 20 20 20 *runconfigs*
1ca0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
1cb0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 -table)) ;; targ
1cc0: 65 74 20 20 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 et => runconf
1cd0: 69 67 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 ig..;; This is a
1ce0: 20 63 61 63 68 65 20 6f 66 20 70 72 65 2d 72 65 cache of pre-re
1cf0: 71 73 20 6d 65 74 2c 20 64 6f 6e 27 74 20 72 65 qs met, don't re
1d00: 2d 63 61 6c 63 20 69 6e 20 63 61 73 65 73 20 77 -calc in cases w
1d10: 68 65 72 65 20 63 61 6c 6c 65 64 20 77 69 74 68 here called with
1d20: 20 73 61 6d 65 20 70 61 72 61 6d 73 20 6c 65 73 same params les
1d30: 73 20 74 68 61 6e 0a 3b 3b 20 66 69 76 65 20 73 s than.;; five s
1d40: 65 63 6f 6e 64 73 20 61 67 6f 0a 28 64 65 66 69 econds ago.(defi
1d50: 6e 65 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 ne *pre-reqs-met
1d60: 2d 63 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 -cache* (make-ha
1d70: 73 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 sh-table))..;; c
1d80: 61 63 68 65 20 6f 66 20 76 65 72 62 6f 73 69 74 ache of verbosit
1d90: 79 20 67 69 76 65 6e 20 73 74 72 69 6e 67 0a 3b y given string.;
1da0: 3b 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f ;.(define *verbo
1db0: 73 69 74 79 2d 63 61 63 68 65 2a 20 20 20 20 28 sity-cache* (
1dc0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
1dd0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
1de0: 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 on:clear-caches)
1df0: 0a 20 20 28 73 65 74 21 20 2a 74 61 72 67 65 74 . (set! *target
1e00: 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d * (m
1e10: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1e20: 0a 20 20 28 73 65 74 21 20 2a 6b 65 79 73 2a 20 . (set! *keys*
1e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
1e40: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1e50: 0a 20 20 28 73 65 74 21 20 2a 6b 65 79 76 61 6c . (set! *keyval
1e60: 73 2a 20 20 20 20 20 20 20 20 20 20 20 20 28 6d s* (m
1e70: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1e80: 0a 20 20 28 73 65 74 21 20 2a 74 6f 70 74 65 73 . (set! *toptes
1e90: 74 2d 70 61 74 68 73 2a 20 20 20 20 20 20 28 6d t-paths* (m
1ea0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1eb0: 0a 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 70 . (set! *test-p
1ec0: 61 74 68 73 2a 20 20 20 20 20 20 20 20 20 28 6d aths* (m
1ed0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1ee0: 0a 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 . (set! *test-i
1ef0: 64 73 2a 20 20 20 20 20 20 20 20 20 20 20 28 6d ds* (m
1f00: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1f10: 0a 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 . (set! *test-i
1f20: 6e 66 6f 2a 20 20 20 20 20 20 20 20 20 20 28 6d nfo* (m
1f30: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1f40: 0a 20 20 28 73 65 74 21 20 2a 72 75 6e 2d 69 6e . (set! *run-in
1f50: 66 6f 2d 63 61 63 68 65 2a 20 20 20 20 20 28 6d fo-cache* (m
1f60: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1f70: 0a 20 20 28 73 65 74 21 20 2a 65 6e 76 2d 76 61 . (set! *env-va
1f80: 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 28 6d rs-by-run-id* (m
1f90: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1fa0: 0a 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 . (set! *test-i
1fb0: 64 2d 63 61 63 68 65 2a 20 20 20 20 20 20 28 6d d-cache* (m
1fc0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1fd0: 29 0a 0a 3b 3b 20 47 65 6e 65 72 69 63 20 73 74 )..;; Generic st
1fe0: 72 69 6e 67 20 64 61 74 61 62 61 73 65 0a 28 64 ring database.(d
1ff0: 65 66 69 6e 65 20 73 64 62 3a 71 72 79 20 23 66 efine sdb:qry #f
2000: 29 20 3b 3b 20 28 6d 61 6b 65 2d 73 64 62 3a 71 ) ;; (make-sdb:q
2010: 72 79 29 29 20 3b 3b 20 20 27 69 6e 69 74 20 23 ry)) ;; 'init #
2020: 66 29 0a 3b 3b 20 47 65 6e 65 72 69 63 20 70 61 f).;; Generic pa
2030: 74 68 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 th database.(def
2040: 69 6e 65 20 2a 66 64 62 2a 20 23 66 29 0a 0a 28 ine *fdb* #f)..(
2050: 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6c 61 75 define *last-lau
2060: 6e 63 68 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 nch* (current-se
2070: 63 6f 6e 64 73 29 29 20 3b 3b 20 75 73 65 20 66 conds)) ;; use f
2080: 6f 72 20 74 68 72 6f 74 74 6c 69 6e 67 20 74 68 or throttling th
2090: 65 20 6c 61 75 6e 63 68 20 72 61 74 65 2e 20 57 e launch rate. W
20a0: 6f 75 6c 64 20 62 65 20 62 65 74 74 65 72 20 74 ould be better t
20b0: 6f 20 75 73 65 20 74 68 65 20 64 62 20 61 6e 64 o use the db and
20c0: 20 6c 61 73 74 20 74 69 6d 65 20 6f 66 20 61 20 last time of a
20d0: 74 65 73 74 20 69 6e 20 4c 41 55 4e 43 48 45 44 test in LAUNCHED
20e0: 20 73 74 61 74 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d state...;;=====
20f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2130: 3d 0a 3b 3b 20 56 20 45 20 52 20 53 20 49 20 4f =.;; V E R S I O
2140: 20 4e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d N.;;===========
2150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
2190: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
21a0: 2d 66 75 6c 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 -full-version).
21b0: 20 28 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d (conc megatest-
21c0: 76 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 version "-" mega
21d0: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
21e0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
21f0: 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e mon:version-sign
2200: 61 74 75 72 65 29 0a 20 20 28 63 6f 6e 63 20 6d ature). (conc m
2210: 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 egatest-version
2220: 22 2d 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d "-" (substring m
2230: 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 egatest-fossil-h
2240: 61 73 68 20 30 20 34 29 29 29 0a 0a 3b 3b 20 66 ash 0 4)))..;; f
2250: 72 6f 6d 20 6d 65 74 61 64 61 74 20 6c 6f 6f 6b rom metadat look
2260: 75 70 20 4d 45 47 41 54 45 53 54 5f 56 45 52 53 up MEGATEST_VERS
2270: 49 4f 4e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ION.;;.(define (
2280: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d common:get-last-
2290: 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 3b 3b 20 run-version) ;;
22a0: 52 41 44 54 20 3d 3e 20 48 6f 77 20 64 6f 65 73 RADT => How does
22b0: 20 74 68 69 73 20 77 6f 72 6b 20 69 6e 20 73 65 this work in se
22c0: 6e 64 2d 72 65 63 65 69 76 65 20 66 75 6e 63 74 nd-receive funct
22d0: 69 6f 6e 3f 3f 3b 20 61 73 73 75 6d 65 20 69 74 ion??; assume it
22e0: 20 69 73 20 74 68 65 20 76 61 6c 75 65 20 73 61 is the value sa
22f0: 76 65 64 20 69 6e 20 73 6f 6d 65 20 44 42 0a 20 ved in some DB.
2300: 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 22 4d (rmt:get-var "M
2310: 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 EGATEST_VERSION"
2320: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
2330: 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e mon:get-last-run
2340: 2d 76 65 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 -version-number)
2350: 0a 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 . (string->numb
2360: 65 72 20 0a 20 20 20 28 73 75 62 73 74 72 69 6e er . (substrin
2370: 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 g (common:get-la
2380: 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 st-run-version)
2390: 30 20 36 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 0 6)))..(define
23a0: 28 63 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 (common:set-last
23b0: 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 0a 20 20 -run-version).
23c0: 28 72 6d 74 3a 73 65 74 2d 76 61 72 20 22 4d 45 (rmt:set-var "ME
23d0: 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 20 GATEST_VERSION"
23e0: 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d (common:version-
23f0: 73 69 67 6e 61 74 75 72 65 29 29 29 0a 0a 28 64 signature)))..(d
2400: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 efine (common:ve
2410: 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a rsion-changed?).
2420: 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 (not (equal? (
2430: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d common:get-last-
2440: 72 75 6e 2d 76 65 72 73 69 6f 6e 29 0a 09 20 20 run-version)..
2450: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 (common:ver
2460: 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 sion-signature))
2470: 29 29 0a 0a 3b 3b 20 4d 6f 76 65 20 6d 65 20 65 ))..;; Move me e
2480: 6c 73 65 77 68 65 72 65 20 2e 2e 2e 0a 3b 3b 20 lsewhere ....;;
2490: 52 41 44 54 20 3d 3e 20 57 68 79 20 64 6f 20 77 RADT => Why do w
24a0: 65 20 6d 65 65 64 20 74 68 65 20 76 65 72 73 69 e meed the versi
24b0: 6f 6e 20 63 68 65 63 6b 20 68 65 72 65 2c 20 74 on check here, t
24c0: 68 69 73 20 69 73 20 63 61 6c 6c 65 64 20 6f 6e his is called on
24d0: 6c 79 20 69 66 20 76 65 72 73 69 6f 6e 20 6d 69 ly if version mi
24e0: 73 6d 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 sma.;;.(define (
24f0: 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 70 2d 64 common:cleanup-d
2500: 62 20 64 62 73 74 72 75 63 74 29 0a 20 20 28 64 b dbstruct). (d
2510: 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 b:multi-db-sync
2520: 0a 20 20 20 64 62 73 74 72 75 63 74 0a 20 20 20 . dbstruct.
2530: 3b 3b 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 27 ;; 'new2old. '
2540: 6b 69 6c 6c 73 65 72 76 65 72 73 0a 20 20 20 27 killservers. '
2550: 64 65 6a 75 6e 6b 0a 20 20 20 3b 3b 20 27 61 64 dejunk. ;; 'ad
2560: 6a 2d 74 65 73 74 69 64 73 0a 20 20 20 3b 3b 20 j-testids. ;;
2570: 27 6f 6c 64 32 6e 65 77 0a 20 20 20 27 6e 65 77 'old2new. 'new
2580: 32 6f 6c 64 0a 20 20 20 27 73 63 68 65 6d 61 29 2old. 'schema)
2590: 0a 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 . (if (common:v
25a0: 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 ersion-changed?)
25b0: 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 . (common:s
25c0: 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 et-last-run-vers
25d0: 69 6f 6e 29 29 29 0a 0a 3b 3b 20 52 6f 74 61 74 ion)))..;; Rotat
25e0: 65 20 6c 6f 67 73 2c 20 6c 6f 67 69 63 3a 20 0a e logs, logic: .
25f0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
2600: 20 20 20 69 66 20 3e 20 35 30 30 6b 20 61 6e 64 if > 500k and
2610: 20 6f 6c 64 65 72 20 74 68 61 6e 20 31 20 77 65 older than 1 we
2620: 65 6b 3a 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ek:.;;
2630: 20 20 20 20 20 20 20 20 20 20 20 72 65 6d 6f 76 remov
2640: 65 20 70 72 65 76 69 6f 75 73 20 63 6f 6d 70 72 e previous compr
2650: 65 73 73 65 64 20 6c 6f 67 20 61 6e 64 20 63 6f essed log and co
2660: 6d 70 72 65 73 73 20 74 68 69 73 20 6c 6f 67 0a mpress this log.
2670: 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 73 ;; WARNING: This
2680: 20 70 72 6f 63 20 6f 70 65 72 61 74 65 73 20 61 proc operates a
2690: 73 73 75 6d 69 6e 67 20 74 68 61 74 20 69 74 20 ssuming that it
26a0: 69 73 20 69 6e 20 74 68 65 20 64 69 72 65 63 74 is in the direct
26b0: 6f 72 79 20 61 62 6f 76 65 20 74 68 65 0a 3b 3b ory above the.;;
26c0: 20 20 20 20 20 20 20 20 20 20 6c 6f 67 73 20 64 logs d
26d0: 69 72 65 63 74 6f 72 79 20 79 6f 75 20 77 69 73 irectory you wis
26e0: 68 20 74 6f 20 6c 6f 67 2d 72 6f 74 61 74 65 2e h to log-rotate.
26f0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
2700: 6d 6f 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 29 mon:rotate-logs)
2710: 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 64 69 72 . (if (not (dir
2720: 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 22 ectory-exists? "
2730: 6c 6f 67 73 22 29 29 28 63 72 65 61 74 65 2d 64 logs"))(create-d
2740: 69 72 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 29 irectory "logs")
2750: 29 0a 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 ). (directory-f
2760: 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 old . (lambda
2770: 28 66 69 6c 65 20 72 65 6d 29 0a 20 20 20 20 20 (file rem).
2780: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
2790: 2d 6d 61 74 63 68 20 22 5e 2e 2a 2e 6c 6f 67 22 -match "^.*.log"
27a0: 20 66 69 6c 65 29 0a 09 20 20 20 20 20 20 28 3e file).. (>
27b0: 20 28 66 69 6c 65 2d 73 69 7a 65 20 28 63 6f 6e (file-size (con
27c0: 63 20 22 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 c "logs/" file))
27d0: 20 32 30 30 30 30 30 29 29 0a 09 20 28 6c 65 74 200000)).. (let
27e0: 20 28 28 67 7a 66 69 6c 65 20 28 63 6f 6e 63 20 ((gzfile (conc
27f0: 22 6c 6f 67 73 2f 22 20 66 69 6c 65 20 22 2e 67 "logs/" file ".g
2800: 7a 22 29 29 29 0a 09 20 20 20 28 69 66 20 28 66 z"))).. (if (f
2810: 69 6c 65 2d 65 78 69 73 74 73 3f 20 67 7a 66 69 ile-exists? gzfi
2820: 6c 65 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 le).. (beg
2830: 69 6e 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 in... (debug:pri
2840: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
2850: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
2860: 6d 6f 76 69 6e 67 20 22 20 67 7a 66 69 6c 65 29 moving " gzfile)
2870: 0a 09 09 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 ... (delete-file
2880: 20 67 7a 66 69 6c 65 29 29 29 0a 09 20 20 20 28 gzfile))).. (
2890: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
28a0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
28b0: 70 6f 72 74 2a 20 22 63 6f 6d 70 72 65 73 73 69 port* "compressi
28c0: 6e 67 20 22 20 66 69 6c 65 29 0a 09 20 20 20 28 ng " file).. (
28d0: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 67 7a system (conc "gz
28e0: 69 70 20 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 ip logs/" file))
28f0: 29 29 29 0a 20 20 20 27 28 29 0a 20 20 20 22 6c ))). '(). "l
2900: 6f 67 73 22 29 29 0a 0a 3b 3b 20 46 6f 72 63 65 ogs"))..;; Force
2910: 20 61 20 6d 65 67 61 74 65 73 74 20 63 6c 65 61 a megatest clea
2920: 6e 75 70 2d 64 62 20 69 66 20 76 65 72 73 69 6f nup-db if versio
2930: 6e 20 69 73 20 63 68 61 6e 67 65 64 20 61 6e 64 n is changed and
2940: 20 73 6b 69 70 2d 76 65 72 73 69 6f 6e 2d 63 68 skip-version-ch
2950: 65 63 6b 20 6e 6f 74 20 73 70 65 63 69 66 69 65 eck not specifie
2960: 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f d.;;.(define (co
2970: 6d 6d 6f 6e 3a 65 78 69 74 2d 6f 6e 2d 76 65 72 mmon:exit-on-ver
2980: 73 69 6f 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 sion-changed).
2990: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 (if (common:vers
29a0: 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 ion-changed?).
29b0: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
29c0: 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 on-homehost?)..
29d0: 20 28 6c 65 74 20 28 28 6d 74 63 6f 6e 66 20 28 (let ((mtconf (
29e0: 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f conc (get-enviro
29f0: 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 nment-variable "
2a00: 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 MT_RUN_AREA_HOME
2a10: 22 29 20 22 2f 6d 65 67 61 74 65 73 74 2e 63 6f ") "/megatest.co
2a20: 6e 66 69 67 22 29 29 0a 09 09 28 64 62 73 74 72 nfig"))...(dbstr
2a30: 75 63 74 20 28 64 62 3a 73 65 74 75 70 29 29 29 uct (db:setup)))
2a40: 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
2a50: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
2a60: 67 2d 70 6f 72 74 2a 0a 09 09 09 20 22 57 41 52 g-port*.... "WAR
2a70: 4e 49 4e 47 3a 20 56 65 72 73 69 6f 6e 20 6d 69 NING: Version mi
2a80: 73 6d 61 74 63 68 21 5c 6e 22 0a 09 09 09 20 22 smatch!\n".... "
2a90: 20 20 20 65 78 70 65 63 74 65 64 3a 20 22 20 28 expected: " (
2aa0: 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 common:version-s
2ab0: 69 67 6e 61 74 75 72 65 29 20 22 5c 6e 22 0a 09 ignature) "\n"..
2ac0: 09 09 20 22 20 20 20 67 6f 74 3a 20 20 20 20 20 .. " got:
2ad0: 20 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c " (common:get-l
2ae0: 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 ast-run-version)
2af0: 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 ).. (if (and
2b00: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 (file-exists? mt
2b10: 63 6f 6e 66 29 0a 09 09 20 20 20 20 20 28 65 71 conf)... (eq
2b20: 3f 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d ? (current-user-
2b30: 69 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d id)(file-owner m
2b40: 74 63 6f 6e 66 29 29 29 20 3b 3b 20 73 61 66 65 tconf))) ;; safe
2b50: 20 74 6f 20 72 75 6e 20 2d 63 6c 65 61 6e 75 70 to run -cleanup
2b60: 2d 64 62 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 -db...(begin...
2b70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2b80: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2b90: 74 2a 20 22 20 20 20 49 20 73 65 65 20 79 6f 75 t* " I see you
2ba0: 20 61 72 65 20 74 68 65 20 6f 77 6e 65 72 20 6f are the owner o
2bb0: 66 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 f megatest.confi
2bc0: 67 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f g, attempting to
2bd0: 20 63 6c 65 61 6e 75 70 20 61 6e 64 20 72 65 73 cleanup and res
2be0: 65 74 20 74 6f 20 6e 65 77 20 76 65 72 73 69 6f et to new versio
2bf0: 6e 22 29 0a 09 09 20 20 28 68 61 6e 64 6c 65 2d n")... (handle-
2c00: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 exceptions...
2c10: 65 78 6e 0a 09 09 20 20 20 28 62 65 67 69 6e 0a exn... (begin.
2c20: 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
2c30: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
2c40: 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 og-port* "Failed
2c50: 20 74 6f 20 73 77 69 74 63 68 20 76 65 72 73 69 to switch versi
2c60: 6f 6e 73 2e 22 29 0a 09 09 20 20 20 20 20 28 64 ons.")... (d
2c70: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
2c80: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
2c90: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 " message: " ((c
2ca0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
2cb0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
2cc0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
2cd0: 09 09 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 .. (print-ca
2ce0: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
2cf0: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 t-error-port))..
2d00: 09 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a . (exit 1)).
2d10: 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 .. (common:cle
2d20: 61 6e 75 70 2d 64 62 20 64 62 73 74 72 75 63 74 anup-db dbstruct
2d30: 29 29 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 )))...(begin...
2d40: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2d50: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2d60: 74 2a 20 22 20 74 6f 20 73 77 69 74 63 68 20 76 t* " to switch v
2d70: 65 72 73 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 ersions you can
2d80: 72 75 6e 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 run: \"megatest
2d90: 2d 63 6c 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a -cleanup-db\"").
2da0: 09 09 20 20 28 65 78 69 74 20 31 29 29 29 29 0a .. (exit 1)))).
2db0: 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 . (begin.. (
2dc0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2dd0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2de0: 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 "ERROR: cannot
2df0: 6d 69 67 72 61 74 65 20 76 65 72 73 69 6f 6e 20 migrate version
2e00: 75 6e 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 68 6f unless on homeho
2e10: 73 74 2e 20 45 78 69 74 69 6e 67 2e 22 29 0a 09 st. Exiting.")..
2e20: 20 20 20 20 28 65 78 69 74 20 31 29 29 29 29 29 (exit 1)))))
2e30: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
2e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 ==========.;; S
2e80: 50 20 41 20 52 20 53 20 45 20 20 20 41 20 52 20 P A R S E A R
2e90: 52 20 41 20 59 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d R A Y S.;;======
2ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ee0: 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d ..(define (make-
2ef0: 73 70 61 72 73 65 2d 61 72 72 61 79 29 0a 20 20 sparse-array).
2f00: 28 6c 65 74 20 28 28 61 20 28 6d 61 6b 65 2d 73 (let ((a (make-s
2f10: 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 29 0a parse-vector))).
2f20: 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 (sparse-vect
2f30: 6f 72 2d 73 65 74 21 20 61 20 30 20 28 6d 61 6b or-set! a 0 (mak
2f40: 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 e-sparse-vector)
2f50: 29 0a 20 20 20 20 61 29 29 0a 0a 28 64 65 66 69 ). a))..(defi
2f60: 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 ne (sparse-array
2f70: 3f 20 61 29 0a 20 20 28 61 6e 64 20 28 73 70 61 ? a). (and (spa
2f80: 72 73 65 2d 76 65 63 74 6f 72 3f 20 61 29 0a 20 rse-vector? a).
2f90: 20 20 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 (sparse-ve
2fa0: 63 74 6f 72 3f 20 28 73 70 61 72 73 65 2d 76 65 ctor? (sparse-ve
2fb0: 63 74 6f 72 2d 72 65 66 20 61 20 30 29 29 29 29 ctor-ref a 0))))
2fc0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 61 72 73 ..(define (spars
2fd0: 65 2d 61 72 72 61 79 2d 72 65 66 20 61 20 78 20 e-array-ref a x
2fe0: 79 29 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 y). (let ((row
2ff0: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 (sparse-vector-r
3000: 65 66 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 ef a x))). (i
3010: 66 20 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 f row..(sparse-v
3020: 65 63 74 6f 72 2d 72 65 66 20 72 6f 77 20 79 29 ector-ref row y)
3030: 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 ..#f)))..(define
3040: 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 2d 73 (sparse-array-s
3050: 65 74 21 20 61 20 78 20 79 20 76 61 6c 29 0a 20 et! a x y val).
3060: 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 70 61 (let ((row (spa
3070: 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 rse-vector-ref a
3080: 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 72 6f x))). (if ro
3090: 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 74 6f w..(sparse-vecto
30a0: 72 2d 73 65 74 21 20 72 6f 77 20 79 20 76 61 6c r-set! row y val
30b0: 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 2d 72 6f )..(let ((new-ro
30c0: 77 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d 76 w (make-sparse-v
30d0: 65 63 74 6f 72 29 29 29 0a 09 20 20 28 73 70 61 ector))).. (spa
30e0: 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 rse-vector-set!
30f0: 61 20 78 20 6e 65 77 2d 72 6f 77 29 0a 09 20 20 a x new-row)..
3100: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 (sparse-vector-s
3110: 65 74 21 20 6e 65 77 2d 72 6f 77 20 79 20 76 61 et! new-row y va
3120: 6c 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d l)))))..;;======
3130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3170: 0a 3b 3b 20 4c 20 4f 20 43 20 4b 20 45 20 52 20 .;; L O C K E R
3180: 53 20 20 20 41 20 4e 20 44 20 20 20 42 20 4c 20 S A N D B L
3190: 4f 20 43 20 4b 20 45 20 52 20 53 20 0a 3b 3b 3d O C K E R S .;;=
31a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31e0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 6b 20 =====..;; block
31f0: 66 75 72 74 68 65 72 20 61 63 63 65 73 73 65 73 further accesses
3200: 20 74 6f 20 64 61 74 61 62 61 73 65 73 2e 20 43 to databases. C
3210: 61 6c 6c 20 74 68 69 73 20 62 65 66 6f 72 65 20 all this before
3220: 73 68 75 74 74 69 6e 67 20 64 62 20 64 6f 77 6e shutting db down
3230: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
3240: 3a 64 62 2d 62 6c 6f 63 6b 2d 66 75 72 74 68 65 :db-block-furthe
3250: 72 2d 71 75 65 72 69 65 73 29 0a 20 20 28 6d 75 r-queries). (mu
3260: 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 tex-lock! *db-ac
3270: 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a 20 20 28 cess-mutex*). (
3280: 73 65 74 21 20 2a 64 62 2d 61 63 63 65 73 73 2d set! *db-access-
3290: 61 6c 6c 6f 77 65 64 2a 20 23 66 29 0a 20 20 28 allowed* #f). (
32a0: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 mutex-unlock! *d
32b0: 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 b-access-mutex*)
32c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
32d0: 6f 6e 3a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c on:db-access-all
32e0: 6f 77 65 64 3f 29 0a 20 20 28 6c 65 74 20 28 28 owed?). (let ((
32f0: 76 61 6c 20 28 62 65 67 69 6e 0a 09 20 20 20 20 val (begin..
3300: 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 (mutex-lock!
3310: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
3320: 2a 29 0a 09 20 20 20 20 20 20 20 2a 64 62 2d 61 *).. *db-a
3330: 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 2a 0a 09 ccess-allowed*..
3340: 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e (mutex-un
3350: 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 lock! *db-access
3360: 2d 6d 75 74 65 78 2a 29 29 29 29 0a 20 20 20 20 -mutex*)))).
3370: 76 61 6c 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d val))..;;=======
3380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
33c0: 3b 3b 20 55 20 53 20 45 20 46 20 55 20 4c 20 20 ;; U S E F U L
33d0: 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d S T U F F.;;===
33e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3420: 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 ===..;; convert
3430: 74 68 69 6e 67 73 20 74 6f 20 61 6e 20 61 6c 69 things to an ali
3440: 73 74 20 6f 72 20 61 73 73 6f 63 20 6c 69 73 74 st or assoc list
3450: 2c 20 23 66 20 67 65 74 73 20 63 6f 6e 76 65 72 , #f gets conver
3460: 74 65 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 65 ted to "".;;.(de
3470: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d fine (common:to-
3480: 61 6c 69 73 74 20 64 61 74 29 0a 20 20 28 63 6f alist dat). (co
3490: 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 64 61 nd. ((list? da
34a0: 74 29 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e t) (map common
34b0: 3a 74 6f 2d 61 6c 69 73 74 20 64 61 74 29 29 0a :to-alist dat)).
34c0: 20 20 20 28 28 76 65 63 74 6f 72 3f 20 64 61 74 ((vector? dat
34d0: 29 0a 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f ). (map commo
34e0: 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 76 65 63 74 n:to-alist (vect
34f0: 6f 72 2d 3e 6c 69 73 74 20 64 61 74 29 29 29 0a or->list dat))).
3500: 20 20 20 28 28 70 61 69 72 3f 20 64 61 74 29 0a ((pair? dat).
3510: 20 20 20 20 28 63 6f 6e 73 20 28 63 6f 6d 6d 6f (cons (commo
3520: 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 61 72 20 n:to-alist (car
3530: 64 61 74 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e dat)).. (common
3540: 3a 74 6f 2d 61 6c 69 73 74 20 28 63 64 72 20 64 :to-alist (cdr d
3550: 61 74 29 29 29 29 0a 20 20 20 28 28 68 61 73 68 at)))). ((hash
3560: 2d 74 61 62 6c 65 3f 20 64 61 74 29 0a 20 20 20 -table? dat).
3570: 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d (map common:to-
3580: 61 6c 69 73 74 20 28 68 61 73 68 2d 74 61 62 6c alist (hash-tabl
3590: 65 2d 3e 61 6c 69 73 74 20 64 61 74 29 29 29 0a e->alist dat))).
35a0: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 69 66 (else. (if
35b0: 20 64 61 74 0a 09 64 61 74 0a 09 22 22 29 29 29 dat..dat.."")))
35c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
35d0: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
35e0: 6e 74 20 77 61 69 74 76 61 6c 20 2e 20 6b 65 79 nt waitval . key
35f0: 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 s). (let* ((key
3600: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e (string-in
3610: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 tersperse (map c
3620: 6f 6e 63 20 6b 65 79 73 29 20 22 2d 22 20 29 29 onc keys) "-" ))
3630: 0a 09 20 28 6c 61 73 74 74 69 6d 65 20 28 68 61 .. (lasttime (ha
3640: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
3650: 61 75 6c 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e ault *common:den
3660: 6f 69 73 65 2a 20 6b 65 79 20 30 29 29 0a 09 20 oise* key 0))..
3670: 28 63 75 72 72 74 69 6d 65 20 28 63 75 72 72 65 (currtime (curre
3680: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 nt-seconds))).
3690: 20 20 28 69 66 20 28 3e 20 28 2d 20 63 75 72 72 (if (> (- curr
36a0: 74 69 6d 65 20 6c 61 73 74 74 69 6d 65 29 20 77 time lasttime) w
36b0: 61 69 74 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a aitval)..(begin.
36c0: 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 . (hash-table-s
36d0: 65 74 21 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f et! *common:deno
36e0: 69 73 65 2a 20 6b 65 79 20 63 75 72 72 74 69 6d ise* key currtim
36f0: 65 29 0a 09 20 20 23 74 29 0a 09 23 66 29 29 29 e).. #t)..#f)))
3700: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
3710: 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 n:get-megatest-e
3720: 78 65 29 0a 20 20 28 6f 72 20 28 67 65 74 65 6e xe). (or (geten
3730: 76 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 29 v "MT_MEGATEST")
3740: 20 22 6d 65 67 61 74 65 73 74 22 29 29 0a 0a 28 "megatest"))..(
3750: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 define (common:r
3760: 65 61 64 2d 65 6e 63 6f 64 65 64 2d 73 74 72 69 ead-encoded-stri
3770: 6e 67 20 69 6e 73 74 72 29 0a 20 20 28 68 61 6e ng instr). (han
3780: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
3790: 20 20 65 78 6e 0a 20 20 20 28 68 61 6e 64 6c 65 exn. (handle
37a0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
37b0: 65 78 6e 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 exn. (begin.
37c0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
37d0: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
37e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
37f0: 63 65 69 76 65 64 20 62 61 64 20 65 6e 63 6f 64 ceived bad encod
3800: 65 64 20 73 74 72 69 6e 67 20 5c 22 22 20 69 6e ed string \"" in
3810: 73 74 72 20 22 5c 22 2c 20 6d 65 73 73 61 67 65 str "\", message
3820: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
3830: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
3840: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
3850: 20 65 78 6e 29 29 0a 20 20 20 20 20 20 28 70 72 exn)). (pr
3860: 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 int-call-chain (
3870: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
3880: 72 74 29 29 0a 20 20 20 20 20 20 23 66 29 0a 20 rt)). #f).
3890: 20 20 20 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 (read (open-i
38a0: 6e 70 75 74 2d 73 74 72 69 6e 67 20 28 62 61 73 nput-string (bas
38b0: 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 e64:base64-decod
38c0: 65 20 69 6e 73 74 72 29 29 29 29 0a 20 20 20 28 e instr)))). (
38d0: 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 read (open-input
38e0: 2d 73 74 72 69 6e 67 20 28 7a 33 3a 64 65 63 6f -string (z3:deco
38f0: 64 65 2d 62 75 66 66 65 72 20 28 62 61 73 65 36 de-buffer (base6
3900: 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 4:base64-decode
3910: 69 6e 73 74 72 29 29 29 29 29 29 0a 0a 3b 3b 20 instr))))))..;;
3920: 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 20 dot-locking egg
3930: 73 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 seems not to wor
3940: 6b 2c 20 75 73 69 6e 67 20 74 68 69 73 20 66 6f k, using this fo
3950: 72 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b r now.;; if lock
3960: 20 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 65 is older than e
3970: 78 70 69 72 65 2d 74 69 6d 65 20 74 68 65 6e 20 xpire-time then
3980: 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 72 remove it and tr
3990: 79 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 y again.;; to ge
39a0: 74 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 t the lock.;;.(d
39b0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 efine (common:si
39c0: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 mple-file-lock f
39d0: 6e 61 6d 65 20 23 21 6b 65 79 20 28 65 78 70 69 name #!key (expi
39e0: 72 65 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 re-time 300)).
39f0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
3a00: 3f 20 66 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 ? fname). (
3a10: 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e if (> (- (curren
3a20: 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d t-seconds)(file-
3a30: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
3a40: 65 20 66 6e 61 6d 65 29 29 20 65 78 70 69 72 65 e fname)) expire
3a50: 2d 74 69 6d 65 29 0a 09 20 20 28 62 65 67 69 6e -time).. (begin
3a60: 0a 09 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 .. (delete-fi
3a70: 6c 65 2a 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 le* fname)..
3a80: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
3a90: 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 ile-lock fname e
3aa0: 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 xpire-time: expi
3ab0: 72 65 2d 74 69 6d 65 29 29 0a 09 20 20 23 66 29 re-time)).. #f)
3ac0: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 65 . (let ((ke
3ad0: 79 2d 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 y-string (conc (
3ae0: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 get-host-name) "
3af0: 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 -" (current-proc
3b00: 65 73 73 2d 69 64 29 29 29 29 0a 09 28 77 69 74 ess-id))))..(wit
3b10: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
3b20: 20 66 6e 61 6d 65 0a 09 20 20 28 6c 61 6d 62 64 fname.. (lambd
3b30: 61 20 28 29 0a 09 20 20 20 20 28 70 72 69 6e 74 a ().. (print
3b40: 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 key-string)))..
3b50: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
3b60: 2e 32 35 29 0a 09 28 69 66 20 28 66 69 6c 65 2d .25)..(if (file-
3b70: 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 exists? fname)..
3b80: 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
3b90: 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a from-file fname.
3ba0: 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
3bb0: 29 0a 09 09 28 65 71 75 61 6c 3f 20 6b 65 79 2d )...(equal? key-
3bc0: 73 74 72 69 6e 67 20 28 72 65 61 64 2d 6c 69 6e string (read-lin
3bd0: 65 29 29 29 29 0a 09 20 20 20 20 23 66 29 29 29 e)))).. #f)))
3be0: 29 0a 09 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d )...(define (com
3bf0: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
3c00: 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 release-lock fna
3c10: 6d 65 29 0a 20 20 28 64 65 6c 65 74 65 2d 66 69 me). (delete-fi
3c20: 6c 65 2a 20 66 6e 61 6d 65 29 29 0a 0a 3b 3b 3d le* fname))..;;=
3c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c70: 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 54 20 41 20 54 =====.;; S T A T
3c80: 20 45 20 53 20 20 20 41 20 4e 20 44 20 20 20 53 E S A N D S
3c90: 20 54 20 41 20 54 20 55 20 53 20 45 20 53 0a 3b T A T U S E S.;
3ca0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ce0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
3cf0: 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 *common:std-sta
3d00: 74 65 73 2a 20 20 20 0a 20 20 27 28 28 30 20 22 tes* . '((0 "
3d10: 41 52 43 48 49 56 45 44 22 29 0a 20 20 20 20 28 ARCHIVED"). (
3d20: 31 20 22 53 54 55 43 4b 22 29 0a 20 20 20 20 28 1 "STUCK"). (
3d30: 32 20 22 4b 49 4c 4c 52 45 51 22 29 0a 20 20 20 2 "KILLREQ").
3d40: 20 28 33 20 22 4b 49 4c 4c 45 44 22 29 0a 20 20 (3 "KILLED").
3d50: 20 20 28 34 20 22 4e 4f 54 5f 53 54 41 52 54 45 (4 "NOT_STARTE
3d60: 44 22 29 0a 20 20 20 20 28 35 20 22 43 4f 4d 50 D"). (5 "COMP
3d70: 4c 45 54 45 44 22 29 0a 20 20 20 20 28 36 20 22 LETED"). (6 "
3d80: 4c 41 55 4e 43 48 45 44 22 29 0a 20 20 20 20 28 LAUNCHED"). (
3d90: 37 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 7 "REMOTEHOSTSTA
3da0: 52 54 22 29 0a 20 20 20 20 28 38 20 22 52 55 4e RT"). (8 "RUN
3db0: 4e 49 4e 47 22 29 0a 20 20 20 20 29 29 0a 0a 28 NING"). ))..(
3dc0: 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 define *common:s
3dd0: 74 64 2d 73 74 61 74 75 73 65 73 2a 0a 20 20 27 td-statuses*. '
3de0: 28 3b 3b 20 28 30 20 22 44 45 4c 45 54 45 44 22 (;; (0 "DELETED"
3df0: 29 0a 20 20 20 20 28 31 20 22 6e 2f 61 22 29 0a ). (1 "n/a").
3e00: 20 20 20 20 28 32 20 22 50 41 53 53 22 29 0a 20 (2 "PASS").
3e10: 20 20 20 28 33 20 22 43 48 45 43 4b 22 29 0a 20 (3 "CHECK").
3e20: 20 20 20 28 34 20 22 53 4b 49 50 22 29 0a 20 20 (4 "SKIP").
3e30: 20 20 28 35 20 22 57 41 52 4e 22 29 0a 20 20 20 (5 "WARN").
3e40: 20 28 36 20 22 57 41 49 56 45 44 22 29 0a 20 20 (6 "WAIVED").
3e50: 20 20 28 37 20 22 53 54 55 43 4b 2f 44 45 41 44 (7 "STUCK/DEAD
3e60: 22 29 0a 20 20 20 20 28 38 20 22 46 41 49 4c 22 "). (8 "FAIL"
3e70: 29 0a 20 20 20 20 28 39 20 22 41 42 4f 52 54 22 ). (9 "ABORT"
3e80: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f )))..(define *co
3e90: 6d 6d 6f 6e 3a 65 6e 64 65 64 2d 73 74 61 74 65 mmon:ended-state
3ea0: 73 2a 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 s* ;; stat
3eb0: 65 73 20 77 68 69 63 68 20 69 6e 64 69 63 61 74 es which indicat
3ec0: 65 20 74 68 65 20 74 65 73 74 20 69 73 20 73 74 e the test is st
3ed0: 6f 70 70 65 64 20 61 6e 64 20 77 69 6c 6c 20 6e opped and will n
3ee0: 6f 74 20 70 72 6f 63 65 65 64 0a 20 20 27 28 22 ot proceed. '("
3ef0: 43 4f 4d 50 4c 45 54 45 44 22 20 22 41 52 43 48 COMPLETED" "ARCH
3f00: 49 56 45 44 22 20 22 4b 49 4c 4c 45 44 22 20 22 IVED" "KILLED" "
3f10: 4b 49 4c 4c 52 45 51 22 20 22 53 54 55 43 4b 22 KILLREQ" "STUCK"
3f20: 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 29 29 0a "INCOMPLETE")).
3f30: 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e .(define *common
3f40: 3a 62 61 64 6c 79 2d 65 6e 64 65 64 2d 73 74 61 :badly-ended-sta
3f50: 74 65 73 2a 20 3b 3b 20 74 68 65 73 65 20 72 6f tes* ;; these ro
3f60: 6c 6c 20 75 70 20 61 73 20 43 48 45 43 4b 2c 20 ll up as CHECK,
3f70: 69 2e 65 2e 20 72 65 73 75 6c 74 73 20 6e 65 65 i.e. results nee
3f80: 64 20 74 6f 20 62 65 20 63 68 65 63 6b 65 64 0a d to be checked.
3f90: 20 20 27 28 22 4b 49 4c 4c 45 44 22 20 22 4b 49 '("KILLED" "KI
3fa0: 4c 4c 52 45 51 22 20 22 53 54 55 43 4b 22 20 22 LLREQ" "STUCK" "
3fb0: 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 44 45 41 INCOMPLETE" "DEA
3fc0: 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 D"))..(define *c
3fd0: 6f 6d 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 ommon:running-st
3fe0: 61 74 65 73 2a 20 20 20 20 20 3b 3b 20 74 65 73 ates* ;; tes
3ff0: 74 20 69 73 20 65 69 74 68 65 72 20 72 75 6e 6e t is either runn
4000: 69 6e 67 20 6f 72 20 63 61 6e 20 62 65 20 72 75 ing or can be ru
4010: 6e 0a 20 20 27 28 22 52 55 4e 4e 49 4e 47 22 20 n. '("RUNNING"
4020: 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 "REMOTEHOSTSTART
4030: 22 20 22 4c 41 55 4e 43 48 45 44 22 29 29 0a 0a " "LAUNCHED"))..
4040: 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a (define *common:
4050: 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 73 2a cant-run-states*
4060: 20 20 20 20 3b 3b 20 54 68 65 73 65 20 61 72 65 ;; These are
4070: 20 73 74 6f 70 70 69 6e 67 20 63 6f 6e 64 69 74 stopping condit
4080: 69 6f 6e 73 20 74 68 61 74 20 70 72 65 76 65 6e ions that preven
4090: 74 20 61 20 74 65 73 74 20 66 72 6f 6d 20 62 65 t a test from be
40a0: 69 6e 67 20 72 75 6e 0a 20 20 27 28 22 43 4f 4d ing run. '("COM
40b0: 50 4c 45 54 45 44 22 20 22 4b 49 4c 4c 45 44 22 PLETED" "KILLED"
40c0: 20 22 55 4e 4b 4e 4f 57 4e 22 20 22 49 4e 43 4f "UNKNOWN" "INCO
40d0: 4d 50 4c 45 54 45 22 20 22 41 52 43 48 49 56 45 MPLETE" "ARCHIVE
40e0: 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 D"))..(define *c
40f0: 6f 6d 6d 6f 6e 3a 6e 6f 74 2d 73 74 61 72 74 65 ommon:not-starte
4100: 64 2d 6f 6b 2d 73 74 61 74 75 73 65 73 2a 20 3b d-ok-statuses* ;
4110: 3b 20 69 66 20 6e 6f 74 20 6f 6e 65 20 6f 66 20 ; if not one of
4120: 74 68 65 73 65 20 73 74 61 74 75 73 65 73 20 77 these statuses w
4130: 68 65 6e 20 69 6e 20 6e 6f 74 5f 73 74 61 72 74 hen in not_start
4140: 65 64 20 73 74 61 74 65 20 74 72 65 61 74 20 61 ed state treat a
4150: 73 20 64 65 61 64 0a 20 20 27 28 22 6e 2f 61 22 s dead. '("n/a"
4160: 20 22 6e 61 22 20 22 50 41 53 53 22 20 22 46 41 "na" "PASS" "FA
4170: 49 4c 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 IL" "WARN" "CHEC
4180: 4b 22 20 22 57 41 49 56 45 44 22 20 22 44 45 41 K" "WAIVED" "DEA
4190: 44 22 20 22 53 4b 49 50 22 29 29 0a 0a 28 64 65 D" "SKIP"))..(de
41a0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 70 65 fine (common:spe
41b0: 63 69 61 6c 2d 73 6f 72 74 20 69 74 65 6d 73 20 cial-sort items
41c0: 6f 72 64 65 72 20 63 6f 6d 70 29 0a 20 20 28 6c order comp). (l
41d0: 65 74 20 28 28 69 74 65 6d 73 2d 6f 72 64 65 72 et ((items-order
41e0: 20 28 6d 61 70 20 72 65 76 65 72 73 65 20 6f 72 (map reverse or
41f0: 64 65 72 29 29 0a 20 20 20 20 20 20 20 20 28 61 der)). (a
4200: 63 6f 6d 70 20 20 20 20 20 20 20 28 6f 72 20 63 comp (or c
4210: 6f 6d 70 20 3e 29 29 29 0a 20 20 20 20 28 73 6f omp >))). (so
4220: 72 74 20 69 74 65 6d 73 0a 20 20 20 20 20 20 20 rt items.
4230: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 (lambda (a b).
4240: 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 (let ((
4250: 61 2d 6e 75 6d 20 28 63 61 64 72 20 28 6f 72 20 a-num (cadr (or
4260: 28 61 73 73 6f 63 20 61 20 69 74 65 6d 73 2d 6f (assoc a items-o
4270: 72 64 65 72 29 20 27 28 30 20 30 29 29 29 29 0a rder) '(0 0)))).
4280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4290: 28 62 2d 6e 75 6d 20 28 63 61 64 72 20 28 6f 72 (b-num (cadr (or
42a0: 20 28 61 73 73 6f 63 20 62 20 69 74 65 6d 73 2d (assoc b items-
42b0: 6f 72 64 65 72 29 20 27 28 30 20 30 29 29 29 29 order) '(0 0))))
42c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 61 ). (a
42d0: 63 6f 6d 70 20 61 2d 6e 75 6d 20 62 2d 6e 75 6d comp a-num b-num
42e0: 29 29 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 67 69 ))))))..;; ;; gi
42f0: 76 65 6e 20 61 20 74 6f 70 6c 65 76 65 6c 20 77 ven a toplevel w
4300: 69 74 68 20 63 75 72 72 73 74 61 74 65 2c 20 63 ith currstate, c
4310: 75 72 72 73 74 61 74 75 73 20 61 70 70 6c 79 20 urrstatus apply
4320: 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 state and status
4330: 0a 3b 3b 20 3b 3b 20 20 3d 3e 20 28 6e 65 77 73 .;; ;; => (news
4340: 74 61 74 65 20 2e 20 6e 65 77 73 74 61 74 75 73 tate . newstatus
4350: 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6f ).;; (define (co
4360: 6d 6d 6f 6e 3a 61 70 70 6c 79 2d 73 74 61 74 65 mmon:apply-state
4370: 2d 73 74 61 74 75 73 20 63 75 72 72 73 74 61 74 -status currstat
4380: 65 20 63 75 72 72 73 74 61 74 75 73 20 73 74 61 e currstatus sta
4390: 74 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 te status).;;
43a0: 28 6c 65 74 2a 20 28 28 63 73 74 61 74 65 20 20 (let* ((cstate
43b0: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
43c0: 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 (string-downcase
43d0: 20 63 75 72 72 73 74 61 74 65 29 29 29 0a 3b 3b currstate))).;;
43e0: 20 20 20 20 20 20 20 20 20 20 28 63 73 74 61 74 (cstat
43f0: 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 us (string->symb
4400: 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 ol (string-downc
4410: 61 73 65 20 63 75 72 72 73 74 61 74 75 73 29 29 ase currstatus))
4420: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 73 ).;; (s
4430: 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d 3e state (string->
4440: 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 symbol (string-d
4450: 6f 77 6e 63 61 73 65 20 73 74 61 74 65 29 29 29 owncase state)))
4460: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 73 73 .;; (ss
4470: 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 tatus (string->s
4480: 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f ymbol (string-do
4490: 77 6e 63 61 73 65 20 73 74 61 74 75 73 29 29 29 wncase status)))
44a0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6e 73 .;; (ns
44b0: 74 61 74 65 20 20 23 66 29 0a 3b 3b 20 20 20 20 tate #f).;;
44c0: 20 20 20 20 20 20 28 6e 73 74 61 74 75 73 20 23 (nstatus #
44d0: 66 29 29 0a 3b 3b 20 20 20 20 20 28 73 65 74 21 f)).;; (set!
44e0: 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 nstate.;;
44f0: 20 20 20 20 20 28 63 61 73 65 20 63 73 74 61 74 (case cstat
4500: 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 e.;;
4510: 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6e 6f 74 ((completed not
4520: 5f 73 74 61 72 74 65 64 20 6b 69 6c 6c 65 64 20 _started killed
4530: 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 72 killreq stuck ar
4540: 63 68 69 76 65 64 29 20 0a 3b 3b 20 20 20 20 20 chived) .;;
4550: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 73 (case s
4560: 73 74 61 74 65 20 3b 3b 20 63 6f 6d 70 6c 65 74 state ;; complet
4570: 65 64 20 2d 3e 20 73 73 74 61 74 65 0a 3b 3b 20 ed -> sstate.;;
4580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4590: 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 6c 6c 65 (completed kille
45a0: 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 d killreq stuck
45b0: 61 72 63 68 69 76 65 64 29 20 63 6f 6d 70 6c 65 archived) comple
45c0: 74 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ted).;;
45d0: 20 20 20 20 20 20 20 28 28 72 75 6e 6e 69 6e 67 ((running
45e0: 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 remotehoststart
45f0: 20 6c 61 75 6e 63 68 65 64 29 20 20 20 20 20 20 launched)
4600: 20 20 72 75 6e 6e 69 6e 67 29 0a 3b 3b 20 20 20 running).;;
4610: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
4620: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
4630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4640: 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d unknown-
4650: 65 72 72 6f 72 2d 31 29 29 29 0a 3b 3b 20 20 20 error-1))).;;
4660: 20 20 20 20 20 20 20 20 20 20 28 28 72 75 6e 6e ((runn
4670: 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 ing remotehostst
4680: 61 72 74 20 6c 61 75 6e 63 68 65 64 29 0a 3b 3b art launched).;;
4690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
46a0: 61 73 65 20 73 73 74 61 74 65 0a 3b 3b 20 20 20 ase sstate.;;
46b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 ((c
46c0: 6f 6d 70 6c 65 74 65 64 20 6b 69 6c 6c 65 64 20 ompleted killed
46d0: 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 72 killreq stuck ar
46e0: 63 68 69 76 65 64 29 20 23 66 29 20 3b 3b 20 6e chived) #f) ;; n
46f0: 65 65 64 20 74 6f 20 6c 6f 6f 6b 20 61 74 20 61 eed to look at a
4700: 6c 6c 20 69 74 65 6d 73 0a 3b 3b 20 20 20 20 20 ll items.;;
4710: 20 20 20 20 20 20 20 20 20 20 20 28 28 72 75 6e ((run
4720: 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 ning remotehosts
4730: 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 20 20 tart launched)
4740: 20 20 20 20 20 20 72 75 6e 6e 69 6e 67 29 0a 3b running).;
4750: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4760: 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 (else
4770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4780: 20 20 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e unkn
4790: 6f 77 6e 2d 65 72 72 6f 72 2d 32 29 29 29 0a 3b own-error-2))).;
47a0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 ; (e
47b0: 6c 73 65 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f lse unknown-erro
47c0: 72 2d 33 29 29 29 0a 3b 3b 20 20 20 20 20 28 73 r-3))).;; (s
47d0: 65 74 21 20 6e 73 74 61 74 75 73 0a 3b 3b 20 20 et! nstatus.;;
47e0: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 73 (case s
47f0: 73 74 61 74 75 73 0a 3b 3b 20 20 20 20 20 20 20 status.;;
4800: 20 20 20 20 20 20 28 28 70 61 73 73 29 0a 3b 3b ((pass).;;
4810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
4820: 61 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 ase nstate.;;
4830: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 ((p
4840: 61 73 73 20 6e 2f 61 20 64 65 6c 65 74 65 64 29 ass n/a deleted)
4850: 20 20 20 20 20 70 61 73 73 29 0a 3b 3b 20 20 20 pass).;;
4860: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 77 ((w
4870: 61 72 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 arn)
4880: 20 20 20 20 20 77 61 72 6e 29 0a 3b 3b 20 20 20 warn).;;
4890: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 66 ((f
48a0: 61 69 6c 29 20 20 20 20 20 20 20 20 20 20 20 20 ail)
48b0: 20 20 20 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 fail).;;
48c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 ((c
48d0: 68 65 63 6b 29 20 20 20 20 20 20 20 20 20 20 20 heck)
48e0: 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b 20 20 20 check).;;
48f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 77 ((w
4900: 61 69 76 65 64 29 20 20 20 20 20 20 20 20 20 20 aived)
4910: 20 20 20 77 61 69 76 65 64 29 0a 3b 3b 20 20 20 waived).;;
4920: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 ((s
4930: 6b 69 70 29 20 20 20 20 20 20 20 20 20 20 20 20 kip)
4940: 20 20 20 20 20 73 6b 69 70 29 0a 3b 3b 20 20 20 skip).;;
4950: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 ((s
4960: 74 75 63 6b 2f 64 65 61 64 29 20 20 20 20 20 20 tuck/dead)
4970: 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b 20 20 20 stuck).;;
4980: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 ((a
4990: 62 6f 72 74 29 20 20 20 20 20 20 20 20 20 20 20 bort)
49a0: 20 20 20 20 61 62 6f 72 74 29 0a 3b 3b 20 20 20 abort).;;
49b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
49c0: 73 65 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 se unknow
49d0: 6e 2d 65 72 72 6f 72 2d 34 29 29 29 0a 3b 3b 20 n-error-4))).;;
49e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 77 61 ((wa
49f0: 72 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 rn).;;
4a00: 20 20 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 (case nstate
4a10: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4a20: 20 20 20 28 28 70 61 73 73 20 77 61 72 6e 20 6e ((pass warn n
4a30: 2f 61 20 73 6b 69 70 20 64 65 6c 65 74 65 64 29 /a skip deleted)
4a40: 20 20 20 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 warn).;;
4a50: 20 20 20 20 20 20 20 20 20 20 20 28 28 66 61 69 ((fai
4a60: 6c 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 l)
4a70: 20 20 20 20 20 20 20 20 20 20 20 66 61 69 6c 29 fail)
4a80: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4a90: 20 20 20 28 28 63 68 65 63 6b 29 20 20 20 20 20 ((check)
4aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ab0: 20 20 63 68 65 63 6b 29 0a 3b 3b 20 20 20 20 20 check).;;
4ac0: 20 20 20 20 20 20 20 20 20 20 20 28 28 77 61 69 ((wai
4ad0: 76 65 64 29 20 20 20 20 20 20 20 20 20 20 20 20 ved)
4ae0: 20 20 20 20 20 20 20 20 20 77 61 69 76 65 64 29 waived)
4af0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4b00: 20 20 20 28 28 73 74 75 63 6b 2f 64 65 61 64 29 ((stuck/dead)
4b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b20: 20 20 73 74 75 63 6b 29 0a 3b 3b 20 20 20 20 20 stuck).;;
4b30: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
4b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b50: 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 35 29 unknown-error-5)
4b60: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 )).;;
4b70: 20 20 28 28 66 61 69 6c 29 0a 3b 3b 20 20 20 20 ((fail).;;
4b80: 20 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 (case
4b90: 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 nstate.;;
4ba0: 20 20 20 20 20 20 20 20 20 28 28 70 61 73 73 20 ((pass
4bb0: 77 61 72 6e 20 66 61 69 6c 20 63 68 65 63 6b 20 warn fail check
4bc0: 6e 2f 61 20 77 61 69 76 65 64 20 73 6b 69 70 20 n/a waived skip
4bd0: 64 65 6c 65 74 65 64 20 73 74 75 63 6b 2f 64 65 deleted stuck/de
4be0: 61 64 20 73 74 75 63 6b 29 20 20 66 61 69 6c 29 ad stuck) fail)
4bf0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4c00: 20 20 20 28 28 61 62 6f 72 74 29 20 20 20 20 20 ((abort)
4c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c40: 20 20 20 20 61 62 6f 72 74 29 0a 3b 3b 20 20 20 abort).;;
4c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
4c60: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
4c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c90: 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f unknown-erro
4ca0: 72 2d 36 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 r-6))).;;
4cb0: 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 75 (else u
4cc0: 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 37 29 29 nknown-error-7))
4cd0: 29 0a 3b 3b 20 20 20 20 20 28 63 6f 6e 73 20 0a ).;; (cons .
4ce0: 3b 3b 20 20 20 20 20 20 28 69 66 20 6e 73 74 61 ;; (if nsta
4cf0: 74 65 20 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 te (symbol->str
4d00: 69 6e 67 20 6e 73 74 61 74 65 29 20 20 6e 73 74 ing nstate) nst
4d10: 61 74 65 29 0a 3b 3b 20 20 20 20 20 20 28 69 66 ate).;; (if
4d20: 20 6e 73 74 61 74 75 73 20 28 73 79 6d 62 6f 6c nstatus (symbol
4d30: 2d 3e 73 74 72 69 6e 67 20 6e 73 74 61 74 75 73 ->string nstatus
4d40: 29 20 6e 73 74 61 74 75 73 29 29 29 29 0a 20 20 ) nstatus)))).
4d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 3b 3b .;;
4d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4da0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 45 20 42 20 ======.;; D E B
4db0: 55 20 47 20 47 20 49 20 4e 20 47 20 20 20 53 20 U G G I N G S
4dc0: 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d 3d 3d T U F F .;;=====
4dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e10: 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 =..(define *verb
4e20: 6f 73 69 74 79 2a 20 20 20 20 20 20 20 20 20 31 osity* 1
4e30: 29 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 67 67 69 ).(define *loggi
4e40: 6e 67 2a 20 20 20 20 20 20 20 20 20 20 20 23 66 ng* #f
4e50: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get-
4e60: 77 69 74 68 2d 64 65 66 61 75 6c 74 20 76 61 6c with-default val
4e70: 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 default). (let
4e80: 20 28 28 76 61 6c 20 28 61 72 67 73 3a 67 65 74 ((val (args:get
4e90: 2d 61 72 67 20 76 61 6c 29 29 29 0a 20 20 20 20 -arg val))).
4ea0: 28 69 66 20 76 61 6c 20 76 61 6c 20 64 65 66 61 (if val val defa
4eb0: 75 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ult)))..(define
4ec0: 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 6b (assoc/default k
4ed0: 65 79 20 6c 73 74 20 2e 20 64 65 66 61 75 6c 74 ey lst . default
4ee0: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 ). (let ((res (
4ef0: 61 73 73 6f 63 20 6b 65 79 20 6c 73 74 29 29 29 assoc key lst)))
4f00: 0a 20 20 20 20 28 69 66 20 72 65 73 20 28 63 61 . (if res (ca
4f10: 64 72 20 72 65 73 29 28 69 66 20 28 6e 75 6c 6c dr res)(if (null
4f20: 3f 20 64 65 66 61 75 6c 74 29 20 23 66 20 28 63 ? default) #f (c
4f30: 61 72 20 64 65 66 61 75 6c 74 29 29 29 29 29 0a ar default))))).
4f40: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
4f50: 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e :get-testsuite-n
4f60: 61 6d 65 29 0a 20 20 28 6f 72 20 28 63 6f 6e 66 ame). (or (conf
4f70: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
4f80: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
4f90: 74 65 73 74 73 75 69 74 65 22 20 29 0a 20 20 20 testsuite" ).
4fa0: 20 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a (if *toppath*
4fb0: 20 0a 20 20 20 20 20 20 20 20 20 20 28 70 61 74 . (pat
4fc0: 68 6e 61 6d 65 2d 66 69 6c 65 20 2a 74 6f 70 70 hname-file *topp
4fd0: 61 74 68 2a 29 0a 20 20 20 20 20 20 20 20 20 20 ath*).
4fe0: 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 (pathname-file (
4ff0: 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 current-director
5000: 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 y)))))..(define
5010: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 (common:get-db-t
5020: 6d 70 2d 61 72 65 61 29 0a 20 20 28 69 66 20 2a mp-area). (if *
5030: 64 62 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 db-cache-path*.
5040: 20 20 20 20 20 2a 64 62 2d 63 61 63 68 65 2d 70 *db-cache-p
5050: 61 74 68 2a 0a 20 20 20 20 20 20 28 6c 65 74 20 ath*. (let
5060: 28 28 64 62 70 61 74 68 20 28 63 72 65 61 74 65 ((dbpath (create
5070: 2d 64 69 72 65 63 74 6f 72 79 20 28 63 6f 6e 63 -directory (conc
5080: 20 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 65 6e "/tmp/" (curren
5090: 74 2d 75 73 65 72 2d 6e 61 6d 65 29 0a 09 09 09 t-user-name)....
50a0: 09 09 20 20 20 20 22 2f 6d 65 67 61 74 65 73 74 .. "/megatest
50b0: 5f 6c 6f 63 61 6c 64 62 2f 22 0a 09 09 09 09 09 _localdb/"......
50c0: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
50d0: 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 20 testsuite-name)
50e0: 22 2f 22 0a 09 09 09 09 09 20 20 20 20 28 73 74 "/"...... (st
50f0: 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 2a ring-translate *
5100: 74 6f 70 70 61 74 68 2a 20 22 2f 22 20 22 2e 22 toppath* "/" "."
5110: 29 29 20 23 74 29 29 29 0a 09 28 73 65 74 21 20 )) #t)))..(set!
5120: 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 68 2a 20 *db-cache-path*
5130: 64 62 70 61 74 68 29 0a 09 64 62 70 61 74 68 29 dbpath)..dbpath)
5140: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
5150: 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 70 61 74 mon:get-area-pat
5160: 68 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 h-signature). (
5170: 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 message-digest-s
5180: 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 tring (md5-primi
5190: 74 69 76 65 29 20 2a 74 6f 70 70 61 74 68 2a 29 tive) *toppath*)
51a0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
51b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
51c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
51d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
51e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 ===========.;; E
51f0: 20 58 20 49 20 54 20 20 20 48 20 41 20 4e 20 44 X I T H A N D
5200: 20 4c 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d L I N G.;;=====
5210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5250: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d =..(define (comm
5260: 6f 6e 3a 72 75 6e 2d 73 79 6e 63 3f 29 0a 20 20 on:run-sync?).
5270: 20 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 6f (and (common:o
5280: 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 28 n-homehost?).. (
5290: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 args:get-arg "-s
52a0: 65 72 76 65 72 22 29 29 29 0a 0a 3b 3b 20 20 20 erver")))..;;
52b0: 28 6c 65 74 20 28 28 6f 68 68 20 28 63 6f 6d 6d (let ((ohh (comm
52c0: 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 on:on-homehost?)
52d0: 29 0a 3b 3b 20 09 28 73 72 76 20 28 61 72 67 73 ).;; .(srv (args
52e0: 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 :get-arg "-serve
52f0: 72 22 29 29 29 0a 3b 3b 20 20 20 20 20 28 61 6e r"))).;; (an
5300: 64 20 6f 68 68 20 73 72 76 29 29 29 0a 20 20 20 d ohh srv))).
5310: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
5320: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
5330: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d 6d -log-port* "comm
5340: 6f 6e 3a 72 75 6e 2d 73 79 6e 63 3f 20 6f 68 68 on:run-sync? ohh
5350: 3d 22 20 6f 68 68 20 22 2c 20 73 72 76 3d 22 20 =" ohh ", srv="
5360: 73 72 76 29 0a 0a 3b 3b 3b 3b 20 72 75 6e 2d 69 srv)..;;;; run-i
5370: 64 73 0a 3b 3b 20 20 20 20 69 66 20 23 66 20 75 ds.;; if #f u
5380: 73 65 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 79 6e se *db-local-syn
5390: 63 2a 20 3a 20 6f 72 20 27 6c 6f 63 61 6c 2d 73 c* : or 'local-s
53a0: 79 6e 63 2d 66 6c 61 67 73 0a 3b 3b 20 20 20 20 ync-flags.;;
53b0: 69 66 20 23 74 20 75 73 65 20 74 69 6d 65 73 74 if #t use timest
53c0: 61 6d 70 73 20 20 20 20 20 20 3a 20 6f 72 20 27 amps : or '
53d0: 74 69 6d 65 73 74 61 6d 70 73 0a 28 64 65 66 69 timestamps.(defi
53e0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d ne (common:sync-
53f0: 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 62 20 64 to-megatest.db d
5400: 62 73 74 72 75 63 74 29 20 0a 20 20 28 6c 65 74 bstruct) . (let
5410: 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 20 20 ((start-time
5420: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 (current-s
5430: 65 63 6f 6e 64 73 29 29 0a 09 28 72 65 73 20 20 econds))..(res
5440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
5450: 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 b:multi-db-sync
5460: 64 62 73 74 72 75 63 74 20 27 6e 65 77 32 6f 6c dbstruct 'new2ol
5470: 64 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 d))). (let ((
5480: 73 79 6e 63 2d 74 69 6d 65 20 28 2d 20 28 63 75 sync-time (- (cu
5490: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 rrent-seconds) s
54a0: 74 61 72 74 2d 74 69 6d 65 29 29 29 0a 20 20 20 tart-time))).
54b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
54c0: 69 6e 66 6f 20 33 20 2a 64 65 66 61 75 6c 74 2d info 3 *default-
54d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 79 6e 63 20 log-port* "Sync
54e0: 6f 66 20 6e 65 77 64 62 20 74 6f 20 6f 6c 64 64 of newdb to oldd
54f0: 62 20 63 6f 6d 70 6c 65 74 65 64 20 69 6e 20 22 b completed in "
5500: 20 73 79 6e 63 2d 74 69 6d 65 20 22 20 73 65 63 sync-time " sec
5510: 6f 6e 64 73 20 70 69 64 3d 22 28 63 75 72 72 65 onds pid="(curre
5520: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a nt-process-id)).
5530: 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f (if (commo
5540: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
5550: 74 20 33 30 20 22 73 79 6e 63 20 6e 65 77 20 74 t 30 "sync new t
5560: 6f 20 6f 6c 64 22 29 0a 09 20 20 28 64 65 62 75 o old").. (debu
5570: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
5580: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5590: 2a 20 22 53 79 6e 63 20 6f 66 20 6e 65 77 64 62 * "Sync of newdb
55a0: 20 74 6f 20 6f 6c 64 64 62 20 63 6f 6d 70 6c 65 to olddb comple
55b0: 74 65 64 20 69 6e 20 22 20 73 79 6e 63 2d 74 69 ted in " sync-ti
55c0: 6d 65 20 22 20 73 65 63 6f 6e 64 73 20 70 69 64 me " seconds pid
55d0: 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 ="(current-proce
55e0: 73 73 2d 69 64 29 29 29 29 0a 20 20 20 20 72 65 ss-id)))). re
55f0: 73 29 29 0a 0a 3b 3b 20 63 75 72 72 65 6e 74 6c s))..;; currentl
5600: 79 20 74 68 65 20 70 72 69 6d 61 72 79 20 6a 6f y the primary jo
5610: 62 20 6f 66 20 74 68 65 20 77 61 74 63 68 64 6f b of the watchdo
5620: 67 20 69 73 20 74 6f 20 72 75 6e 20 74 68 65 20 g is to run the
5630: 73 79 6e 63 20 62 61 63 6b 20 74 6f 20 6d 65 67 sync back to meg
5640: 61 74 65 73 74 2e 64 62 20 66 72 6f 6d 20 74 68 atest.db from th
5650: 65 20 64 62 20 69 6e 20 2f 74 6d 70 0a 3b 3b 20 e db in /tmp.;;
5660: 69 66 20 77 65 20 61 72 65 20 6f 6e 20 74 68 65 if we are on the
5670: 20 68 6f 6d 65 68 6f 73 74 20 61 6e 64 20 77 65 homehost and we
5680: 20 61 72 65 20 61 20 73 65 72 76 65 72 20 28 62 are a server (b
5690: 79 20 64 65 66 69 6e 69 74 69 6f 6e 20 77 65 20 y definition we
56a0: 61 72 65 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 are on the homeh
56b0: 6f 73 74 20 69 66 20 77 65 20 61 72 65 20 61 20 ost if we are a
56c0: 73 65 72 76 65 72 29 0a 3b 3b 0a 28 64 65 66 69 server).;;.(defi
56d0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 74 63 68 ne (common:watch
56e0: 64 6f 67 29 0a 20 20 28 74 68 72 65 61 64 2d 73 dog). (thread-s
56f0: 6c 65 65 70 21 20 30 2e 30 35 29 20 3b 3b 20 64 leep! 0.05) ;; d
5700: 65 6c 61 79 20 66 6f 72 20 73 74 61 72 74 75 70 elay for startup
5710: 0a 20 20 28 6c 65 74 20 28 28 6c 65 67 61 63 79 . (let ((legacy
5720: 2d 73 79 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 72 75 -sync (common:ru
5730: 6e 2d 73 79 6e 63 3f 29 29 0a 09 28 64 65 62 75 n-sync?))..(debu
5740: 67 2d 6d 6f 64 65 20 20 28 64 65 62 75 67 3a 64 g-mode (debug:d
5750: 65 62 75 67 2d 6d 6f 64 65 20 31 29 29 0a 09 28 ebug-mode 1))..(
5760: 6c 61 73 74 2d 74 69 6d 65 20 20 20 28 63 75 72 last-time (cur
5770: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
5780: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
5790: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
57a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 74 63 -log-port* "watc
57b0: 68 64 6f 67 20 73 74 61 72 74 69 6e 67 2e 20 6c hdog starting. l
57c0: 65 67 61 63 79 2d 73 79 6e 63 20 69 73 20 22 20 egacy-sync is "
57d0: 6c 65 67 61 63 79 2d 73 79 6e 63 22 20 70 69 64 legacy-sync" pid
57e0: 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 ="(current-proce
57f0: 73 73 2d 69 64 29 29 0a 20 20 20 20 28 69 66 20 ss-id)). (if
5800: 6c 65 67 61 63 79 2d 73 79 6e 63 0a 09 28 6c 65 legacy-sync..(le
5810: 74 20 28 28 64 62 73 74 72 75 63 74 20 28 64 62 t ((dbstruct (db
5820: 3a 73 65 74 75 70 29 29 29 0a 09 20 20 28 64 65 :setup))).. (de
5830: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
5840: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5850: 72 74 2a 20 22 53 65 72 76 65 72 20 72 75 6e 6e rt* "Server runn
5860: 69 6e 67 2c 20 70 65 72 69 6f 64 69 63 20 73 79 ing, periodic sy
5870: 6e 63 20 73 74 61 72 74 65 64 2e 22 29 0a 09 20 nc started.")..
5880: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a 20 20 (let loop ().
5890: 20 20 20 20 20 20 20 20 20 20 3b 3b 28 42 42 3e ;;(BB>
58a0: 20 22 77 61 74 63 68 64 6f 67 20 6c 6f 6f 70 2e "watchdog loop.
58b0: 20 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 2d pid="(current-
58c0: 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 09 20 20 process-id))..
58d0: 20 20 3b 3b 20 73 79 6e 63 20 66 6f 72 20 66 69 ;; sync for fi
58e0: 6c 65 73 79 73 74 65 6d 20 6c 6f 63 61 6c 20 64 lesystem local d
58f0: 62 20 77 72 69 74 65 73 0a 09 20 20 20 20 3b 3b b writes.. ;;
5900: 0a 09 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 .. (mutex-loc
5910: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
5920: 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 28 c-mutex*).. (
5930: 6c 65 74 2a 20 28 28 6e 65 65 64 2d 73 79 6e 63 let* ((need-sync
5940: 20 20 20 20 20 20 20 20 28 3e 3d 20 2a 64 62 2d (>= *db-
5950: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 2a 64 62 last-access* *db
5960: 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 29 20 3b 3b -last-sync*)) ;;
5970: 20 6e 6f 20 73 79 6e 63 20 73 69 6e 63 65 20 6c no sync since l
5980: 61 73 74 20 77 72 69 74 65 0a 09 09 20 20 20 28 ast write... (
5990: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
59a0: 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f *db-sync-in-pro
59b0: 67 72 65 73 73 2a 29 0a 09 09 20 20 20 28 73 68 gress*)... (sh
59c0: 6f 75 6c 64 2d 73 79 6e 63 20 20 20 20 20 20 28 ould-sync (
59d0: 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 > (- (current-se
59e0: 63 6f 6e 64 73 29 20 2a 64 62 2d 6c 61 73 74 2d conds) *db-last-
59f0: 73 79 6e 63 2a 29 20 35 29 29 20 3b 3b 20 73 79 sync*) 5)) ;; sy
5a00: 6e 63 20 65 76 65 72 79 20 66 69 76 65 20 73 65 nc every five se
5a10: 63 6f 6e 64 73 20 6d 69 6e 69 6d 75 6d 0a 09 09 conds minimum...
5a20: 20 20 20 28 77 69 6c 6c 2d 73 79 6e 63 20 20 20 (will-sync
5a30: 20 20 20 20 20 28 61 6e 64 20 28 6f 72 20 6e 65 (and (or ne
5a40: 65 64 2d 73 79 6e 63 20 73 68 6f 75 6c 64 2d 73 ed-sync should-s
5a50: 79 6e 63 29 0a 09 09 09 09 09 20 20 28 6e 6f 74 ync)...... (not
5a60: 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 sync-in-progres
5a70: 73 29 29 29 0a 09 09 20 20 20 28 73 74 61 72 74 s)))... (start
5a80: 2d 74 69 6d 65 20 20 20 20 20 20 20 28 63 75 72 -time (cur
5a90: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
5aa0: 09 20 20 20 20 20 20 3b 3b 20 28 64 65 62 75 67 . ;; (debug
5ab0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
5ac0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5ad0: 20 22 6e 65 65 64 2d 73 79 6e 63 3a 20 22 20 6e "need-sync: " n
5ae0: 65 65 64 2d 73 79 6e 63 20 22 20 73 79 6e 63 2d eed-sync " sync-
5af0: 69 6e 2d 70 72 6f 67 72 65 73 73 3a 20 22 20 73 in-progress: " s
5b00: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 20 ync-in-progress
5b10: 22 20 73 68 6f 75 6c 64 2d 73 79 6e 63 3a 20 22 " should-sync: "
5b20: 20 73 68 6f 75 6c 64 2d 73 79 6e 63 20 22 20 77 should-sync " w
5b30: 69 6c 6c 2d 73 79 6e 63 3a 20 22 20 77 69 6c 6c ill-sync: " will
5b40: 2d 73 79 6e 63 29 0a 09 20 20 20 20 20 20 28 69 -sync).. (i
5b50: 66 20 77 69 6c 6c 2d 73 79 6e 63 20 28 73 65 74 f will-sync (set
5b60: 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 ! *db-sync-in-pr
5b70: 6f 67 72 65 73 73 2a 20 23 74 29 29 0a 09 20 20 ogress* #t))..
5b80: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
5b90: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
5ba0: 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 20 c-mutex*)..
5bb0: 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 0a 09 (if will-sync..
5bc0: 09 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 63 . (let ((res (c
5bd0: 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d 74 6f 2d 6d 65 ommon:sync-to-me
5be0: 67 61 74 65 73 74 2e 64 62 20 64 62 73 74 72 75 gatest.db dbstru
5bf0: 63 74 29 29 29 20 3b 3b 20 64 69 64 20 77 65 20 ct))) ;; did we
5c00: 73 79 6e 63 20 61 6e 79 20 64 61 74 61 3f 20 49 sync any data? I
5c10: 66 20 73 6f 20 6e 65 65 64 20 74 6f 20 73 65 74 f so need to set
5c20: 20 74 68 65 20 64 62 20 74 6f 75 63 68 65 64 20 the db touched
5c30: 66 6c 61 67 20 74 6f 20 6b 65 65 70 20 74 68 65 flag to keep the
5c40: 20 73 65 72 76 65 72 20 61 6c 69 76 65 0a 09 09 server alive...
5c50: 20 20 20 20 28 69 66 20 28 3e 20 72 65 73 20 30 (if (> res 0
5c60: 29 20 3b 3b 20 73 6f 6d 65 20 72 65 63 6f 72 64 ) ;; some record
5c70: 73 20 77 65 72 65 20 74 72 61 6e 73 66 65 72 72 s were transferr
5c80: 65 64 2c 20 6b 65 65 70 20 74 68 65 20 64 62 20 ed, keep the db
5c90: 61 6c 69 76 65 0a 09 09 09 28 62 65 67 69 6e 0a alive....(begin.
5ca0: 09 09 09 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b ... (mutex-lock
5cb0: 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 ! *heartbeat-mut
5cc0: 65 78 2a 29 0a 09 09 09 20 20 28 73 65 74 21 20 ex*).... (set!
5cd0: 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a *db-last-access*
5ce0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
5cf0: 73 29 29 0a 09 09 09 20 20 28 6d 75 74 65 78 2d s)).... (mutex-
5d00: 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 unlock! *heartbe
5d10: 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 at-mutex*)....
5d20: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5d30: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
5d40: 2d 70 6f 72 74 2a 20 22 73 79 6e 63 20 63 61 6c -port* "sync cal
5d50: 6c 65 64 2c 20 22 20 72 65 73 20 22 20 72 65 63 led, " res " rec
5d60: 6f 72 64 73 20 74 72 61 6e 73 66 65 72 72 65 64 ords transferred
5d70: 2e 22 29 29 0a 09 09 09 28 64 65 62 75 67 3a 70 ."))....(debug:p
5d80: 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 rint-info 2 *def
5d90: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5da0: 73 79 6e 63 20 63 61 6c 6c 65 64 20 62 75 74 20 sync called but
5db0: 7a 65 72 6f 20 72 65 63 6f 72 64 73 20 74 72 61 zero records tra
5dc0: 6e 73 66 65 72 72 65 64 22 29 29 29 29 0a 09 20 nsferred"))))..
5dd0: 20 20 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 79 (if will-sy
5de0: 6e 63 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 nc... (begin...
5df0: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
5e00: 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d *db-multi-sync-
5e10: 6d 75 74 65 78 2a 29 0a 09 09 20 20 20 20 28 73 mutex*)... (s
5e20: 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d et! *db-sync-in-
5e30: 70 72 6f 67 72 65 73 73 2a 20 23 66 29 0a 09 09 progress* #f)...
5e40: 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 (set! *db-la
5e50: 73 74 2d 73 79 6e 63 2a 20 73 74 61 72 74 2d 74 st-sync* start-t
5e60: 69 6d 65 29 0a 09 09 20 20 20 20 28 6d 75 74 65 ime)... (mute
5e70: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 x-unlock! *db-mu
5e80: 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 lti-sync-mutex*)
5e90: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 61 )).. (if (a
5ea0: 6e 64 20 64 65 62 75 67 2d 6d 6f 64 65 0a 09 09 nd debug-mode...
5eb0: 20 20 20 20 20 20 20 28 3e 20 28 2d 20 73 74 61 (> (- sta
5ec0: 72 74 2d 74 69 6d 65 20 6c 61 73 74 2d 74 69 6d rt-time last-tim
5ed0: 65 29 20 36 30 29 29 0a 09 09 20 20 28 62 65 67 e) 60))... (beg
5ee0: 69 6e 0a 09 09 20 20 20 20 28 73 65 74 21 20 6c in... (set! l
5ef0: 61 73 74 2d 74 69 6d 65 20 73 74 61 72 74 2d 74 ast-time start-t
5f00: 69 6d 65 29 0a 09 09 20 20 20 20 28 64 65 62 75 ime)... (debu
5f10: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
5f20: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
5f30: 2a 20 22 74 69 6d 65 73 74 61 6d 70 20 2d 3e 20 * "timestamp ->
5f40: 22 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 " (seconds->time
5f50: 2d 73 74 72 69 6e 67 20 28 63 75 72 72 65 6e 74 -string (current
5f60: 2d 73 65 63 6f 6e 64 73 29 29 20 22 2c 20 74 69 -seconds)) ", ti
5f70: 6d 65 20 73 69 6e 63 65 20 73 74 61 72 74 20 2d me since start -
5f80: 3e 20 22 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 > " (seconds->hr
5f90: 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 28 63 75 72 -min-sec (- (cur
5fa0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a 74 rent-seconds) *t
5fb0: 69 6d 65 2d 7a 65 72 6f 2a 29 29 29 29 29 29 0a ime-zero*)))))).
5fc0: 09 20 20 20 20 0a 09 20 20 20 20 3b 3b 20 6b 65 . .. ;; ke
5fd0: 65 70 20 67 6f 69 6e 67 20 75 6e 6c 65 73 73 20 ep going unless
5fe0: 74 69 6d 65 20 74 6f 20 65 78 69 74 0a 09 20 20 time to exit..
5ff0: 20 20 3b 3b 0a 09 20 20 20 20 28 69 66 20 28 6e ;;.. (if (n
6000: 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 ot *time-to-exit
6010: 2a 29 0a 09 09 28 6c 65 74 20 64 65 6c 61 79 2d *)...(let delay-
6020: 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 29 29 loop ((count 0))
6030: 0a 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e ... (if (and (n
6040: 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 ot *time-to-exit
6050: 2a 29 0a 09 09 09 20 20 20 28 3c 20 63 6f 75 6e *).... (< coun
6060: 74 20 34 29 29 20 3b 3b 20 77 61 73 20 31 31 2c t 4)) ;; was 11,
6070: 20 63 68 61 6e 67 69 6e 67 20 74 6f 20 34 2e 20 changing to 4.
6080: 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
6090: 09 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 ...(thread-sleep
60a0: 21 20 31 29 0a 09 09 09 28 64 65 6c 61 79 2d 6c ! 1)....(delay-l
60b0: 6f 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 oop (+ count 1))
60c0: 29 29 0a 09 09 20 20 28 6c 6f 6f 70 29 29 29 0a ))... (loop))).
60d0: 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
60e0: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
60f0: 20 33 30 29 0a 09 09 28 64 65 62 75 67 3a 70 72 30)...(debug:pr
6100: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
6110: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
6120: 78 69 74 69 6e 67 20 77 61 74 63 68 64 6f 67 20 xiting watchdog
6130: 74 69 6d 65 72 2c 20 2a 74 69 6d 65 2d 74 6f 2d timer, *time-to-
6140: 65 78 69 74 2a 20 3d 20 22 20 2a 74 69 6d 65 2d exit* = " *time-
6150: 74 6f 2d 65 78 69 74 2a 22 20 70 69 64 3d 22 28 to-exit*" pid="(
6160: 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d current-process-
6170: 69 64 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 id))))))))..(def
6180: 69 6e 65 20 28 73 74 64 2d 65 78 69 74 2d 70 72 ine (std-exit-pr
6190: 6f 63 65 64 75 72 65 29 0a 20 20 28 6f 6e 2d 65 ocedure). (on-e
61a0: 78 69 74 20 28 6c 61 6d 62 64 61 20 28 29 20 30 xit (lambda () 0
61b0: 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 6f 2d 68 )). (let ((no-h
61c0: 75 72 72 79 20 20 28 69 66 20 2a 74 69 6d 65 2d urry (if *time-
61d0: 74 6f 2d 65 78 69 74 2a 20 3b 3b 20 68 75 72 72 to-exit* ;; hurr
61e0: 79 20 75 70 0a 09 09 20 20 20 20 20 20 20 23 66 y up... #f
61f0: 0a 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ... (begin
6200: 0a 09 09 09 20 28 73 65 74 21 20 2a 74 69 6d 65 .... (set! *time
6210: 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 09 -to-exit* #t)...
6220: 09 20 23 74 29 29 29 29 0a 20 20 20 20 28 64 65 . #t)))). (de
6230: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
6240: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6250: 72 74 2a 20 22 73 74 61 72 74 69 6e 67 20 65 78 rt* "starting ex
6260: 69 74 20 70 72 6f 63 65 73 73 2c 20 66 69 6e 61 it process, fina
6270: 6c 69 7a 69 6e 67 20 64 61 74 61 62 61 73 65 73 lizing databases
6280: 2e 22 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ."). (if (and
6290: 20 6e 6f 2d 68 75 72 72 79 20 28 64 65 62 75 67 no-hurry (debug
62a0: 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 38 29 29 :debug-mode 18))
62b0: 0a 09 28 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d ..(rmt:print-db-
62c0: 73 74 61 74 73 29 29 0a 20 20 20 20 28 6c 65 74 stats)). (let
62d0: 20 28 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 ((th1 (make-thr
62e0: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 20 3b ead (lambda () ;
62f0: 3b 20 74 68 72 65 61 64 20 66 6f 72 20 63 6c 65 ; thread for cle
6300: 61 6e 69 6e 67 20 75 70 2c 20 67 69 76 65 20 69 aning up, give i
6310: 74 20 66 69 76 65 20 73 65 63 6f 6e 64 73 0a 20 t five seconds.
6320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6330: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
6340: 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 28 *dbstruct-db* (
6350: 64 62 3a 63 6c 6f 73 65 2d 61 6c 6c 20 2a 64 62 db:close-all *db
6360: 73 74 72 75 63 74 2d 64 62 2a 29 29 20 3b 3b 20 struct-db*)) ;;
6370: 6f 6e 65 20 73 65 63 6f 6e 64 20 61 6c 6c 6f 63 one second alloc
6380: 61 74 65 64 0a 09 09 09 20 20 20 20 20 20 28 69 ated.... (i
6390: 66 20 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 0a f *task-db* .
63a0: 09 09 09 09 20 20 28 6c 65 74 20 28 28 64 62 20 .... (let ((db
63b0: 28 63 64 72 20 2a 74 61 73 6b 2d 64 62 2a 29 29 (cdr *task-db*))
63c0: 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 73 )..... (if (s
63d0: 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f qlite3:database?
63e0: 20 64 62 29 0a 09 09 09 09 09 28 62 65 67 69 6e db)......(begin
63f0: 0a 09 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 ...... (sqlite3
6400: 3a 69 6e 74 65 72 72 75 70 74 21 20 64 62 29 0a :interrupt! db).
6410: 09 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a ..... (sqlite3:
6420: 66 69 6e 61 6c 69 7a 65 21 20 64 62 20 23 74 29 finalize! db #t)
6430: 0a 09 09 09 09 09 20 20 3b 3b 20 28 76 65 63 74 ...... ;; (vect
6440: 6f 72 2d 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 or-set! *task-db
6450: 2a 20 30 20 23 66 29 0a 09 09 09 09 09 20 20 28 * 0 #f)...... (
6460: 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 23 set! *task-db* #
6470: 66 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 f))))).
6480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6490: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 2a 72 (if (and *r
64a0: 75 6e 72 65 6d 6f 74 65 2a 0a 20 20 20 20 20 20 unremote*.
64b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
64c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
64d0: 20 28 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 (remote-conndat
64e0: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 29 0a 20 *runremote*)).
64f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6510: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
6520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6530: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 74 74 (htt
6540: 70 2d 63 6c 69 65 6e 74 23 63 6c 6f 73 65 2d 61 p-client#close-a
6550: 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 ll-connections!)
6560: 29 29 20 3b 3b 20 66 6f 72 20 68 74 74 70 2d 63 )) ;; for http-c
6570: 6c 69 65 6e 74 0a 20 20 20 20 20 20 20 20 20 20 lient.
6580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6590: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
65a0: 3f 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 ? *default-log-p
65b0: 6f 72 74 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 ort* (current-er
65c0: 72 6f 72 2d 70 6f 72 74 29 29 29 0a 20 20 20 20 ror-port))).
65d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
65f0: 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 lose-output-port
6600: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6610: 72 74 2a 29 29 0a 09 09 09 20 20 20 20 20 20 28 rt*)).... (
6620: 73 65 74 21 20 2a 64 65 66 61 75 6c 74 2d 6c 6f set! *default-lo
6630: 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 65 6e 74 g-port* (current
6640: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 20 22 -error-port))) "
6650: 43 6c 65 61 6e 75 70 20 64 62 20 65 78 69 74 20 Cleanup db exit
6660: 74 68 72 65 61 64 22 29 29 0a 09 20 20 28 74 68 thread")).. (th
6670: 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 2 (make-thread (
6680: 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 lambda ()....
6690: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
66a0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
66b0: 6f 72 74 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 ort* "Attempting
66c0: 20 63 6c 65 61 6e 20 65 78 69 74 2e 20 50 6c 65 clean exit. Ple
66d0: 61 73 65 20 62 65 20 70 61 74 69 65 6e 74 20 61 ase be patient a
66e0: 6e 64 20 77 61 69 74 20 61 20 66 65 77 20 73 65 nd wait a few se
66f0: 63 6f 6e 64 73 2e 2e 2e 22 29 0a 09 09 09 20 20 conds...")....
6700: 20 20 20 20 28 69 66 20 6e 6f 2d 68 75 72 72 79 (if no-hurry
6710: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6730: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
6740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 74 (t
6760: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 29 29 hread-sleep! 5))
6770: 20 3b 3b 20 67 69 76 65 20 74 68 65 20 63 6c 65 ;; give the cle
6780: 61 6e 20 75 70 20 66 65 77 20 73 65 63 6f 6e 64 an up few second
6790: 73 20 74 6f 20 64 6f 20 69 74 27 73 20 73 74 75 s to do it's stu
67a0: 66 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ff.
67b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67c0: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
67d0: 20 20 09 09 09 09 20 20 28 74 68 72 65 61 64 2d .... (thread-
67e0: 73 6c 65 65 70 21 20 32 29 29 29 0a 20 20 20 20 sleep! 2))).
67f0: 20 20 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ... (debu
6800: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
6810: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2e lt-log-port* " .
6820: 2e 2e 20 64 6f 6e 65 22 29 0a 20 20 20 20 20 20 .. done").
6830: 09 09 09 20 20 20 20 20 20 29 0a 09 09 09 20 20 ... )....
6840: 20 20 22 63 6c 65 61 6e 20 65 78 69 74 22 29 29 "clean exit"))
6850: 29 0a 0a 20 20 20 20 20 20 3b 3b 20 6c 65 74 27 ).. ;; let'
6860: 73 20 74 72 79 20 74 6f 20 63 6c 65 61 6e 20 75 s try to clean u
6870: 70 20 6f 70 65 6e 20 73 6f 63 6b 65 74 73 0a 20 p open sockets.
6880: 20 20 20 20 20 28 69 66 20 2a 72 75 6e 72 65 6d (if *runrem
6890: 6f 74 65 2a 0a 20 20 20 20 20 20 20 20 20 20 28 ote*. (
68a0: 63 61 73 65 20 28 72 65 6d 6f 74 65 2d 74 72 61 case (remote-tra
68b0: 6e 73 70 6f 72 74 20 2a 72 75 6e 72 65 6d 6f 74 nsport *runremot
68c0: 65 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e*).
68d0: 28 28 68 74 74 70 29 20 23 74 29 0a 20 20 20 20 ((http) #t).
68e0: 20 20 20 20 20 20 20 20 28 28 72 70 63 29 20 20 ((rpc)
68f0: 28 72 70 63 3a 63 6c 6f 73 65 2d 61 6c 6c 2d 63 (rpc:close-all-c
6900: 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 0a 20 20 onnections!)).
6910: 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a (else.
6920: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
6930: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
6940: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6950: 72 74 2a 20 22 54 72 61 6e 73 70 6f 72 74 20 22 rt* "Transport "
6960: 28 72 65 6d 6f 74 65 2d 74 72 61 6e 73 70 6f 72 (remote-transpor
6970: 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 22 20 t *runremote*)"
6980: 6e 6f 74 20 73 75 70 70 6f 72 74 65 64 22 29 29 not supported"))
6990: 29 29 0a 0a 20 20 20 20 20 20 28 74 68 72 65 61 )).. (threa
69a0: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 d-start! th1).
69b0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
69c0: 74 21 20 74 68 32 29 0a 20 20 20 20 20 20 28 74 t! th2). (t
69d0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 hread-join! th1)
69e0: 0a 20 20 20 20 20 20 29 0a 20 20 20 20 29 0a 0a . ). )..
69f0: 20 20 30 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 0)..(define (s
6a00: 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 td-signal-handle
6a10: 72 20 73 69 67 6e 75 6d 29 0a 20 20 3b 3b 20 28 r signum). ;; (
6a20: 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 67 signal-mask! sig
6a30: 6e 75 6d 29 0a 20 20 28 73 65 74 21 20 2a 74 69 num). (set! *ti
6a40: 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a me-to-exit* #t).
6a50: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
6a60: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
6a70: 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 log-port* "Recei
6a80: 76 65 64 20 73 69 67 6e 61 6c 20 22 20 73 69 67 ved signal " sig
6a90: 6e 75 6d 20 22 20 65 78 69 74 69 6e 67 20 70 72 num " exiting pr
6aa0: 6f 6d 70 74 6c 79 22 29 0a 20 20 3b 3b 20 28 73 omptly"). ;; (s
6ab0: 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 72 td-exit-procedur
6ac0: 65 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 20 e) ;; shouldn't
6ad0: 6e 65 65 64 20 74 68 69 73 20 73 69 6e 63 65 20 need this since
6ae0: 77 65 20 61 72 65 20 65 78 69 74 69 6e 67 20 61 we are exiting a
6af0: 6e 64 20 69 74 20 77 69 6c 6c 20 62 65 20 63 61 nd it will be ca
6b00: 6c 6c 65 64 20 61 6e 79 77 61 79 0a 20 20 28 65 lled anyway. (e
6b10: 78 69 74 29 29 0a 0a 28 73 65 74 2d 73 69 67 6e xit))..(set-sign
6b20: 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e al-handler! sign
6b30: 61 6c 2f 69 6e 74 20 20 73 74 64 2d 73 69 67 6e al/int std-sign
6b40: 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b 20 al-handler) ;;
6b50: 5e 43 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 ^C.(set-signal-h
6b60: 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 74 andler! signal/t
6b70: 65 72 6d 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 erm std-signal-h
6b80: 61 6e 64 6c 65 72 29 0a 3b 3b 20 28 73 65 74 2d andler).;; (set-
6b90: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 signal-handler!
6ba0: 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 74 64 2d signal/stop std-
6bb0: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 signal-handler)
6bc0: 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 6f 20 4e 4f ;; ^Z NO, do NO
6bd0: 54 20 68 61 6e 64 6c 65 20 5e 5a 21 0a 0a 3b 3b T handle ^Z!..;;
6be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c20: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 ======.;; M I S
6c30: 43 20 20 20 55 20 54 20 49 20 4c 20 53 0a 3b 3b C U T I L S.;;
6c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6c80: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6f 6e 65 2d 6f ======..;; one-o
6c90: 66 20 61 72 67 73 20 64 65 66 69 6e 65 64 0a 28 f args defined.(
6ca0: 64 65 66 69 6e 65 20 28 61 72 67 73 2d 64 65 66 define (args-def
6cb0: 69 6e 65 64 3f 20 2e 20 70 61 72 61 6d 29 0a 20 ined? . param).
6cc0: 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 (let ((res #f))
6cd0: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a . (for-each .
6ce0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 72 (lambda (ar
6cf0: 67 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 61 g). (if (a
6d00: 72 67 73 3a 67 65 74 2d 61 72 67 20 61 72 67 29 rgs:get-arg arg)
6d10: 28 73 65 74 21 20 72 65 73 20 23 74 29 29 29 0a (set! res #t))).
6d20: 20 20 20 20 20 70 61 72 61 6d 29 0a 20 20 20 20 param).
6d30: 72 65 73 29 29 0a 0a 3b 3b 20 63 6f 6e 76 65 72 res))..;; conver
6d40: 74 20 73 74 75 66 66 20 74 6f 20 61 20 6e 75 6d t stuff to a num
6d50: 62 65 72 20 69 66 20 70 6f 73 73 69 62 6c 65 0a ber if possible.
6d60: 28 64 65 66 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 (define (any->nu
6d70: 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e mber val). (con
6d80: 64 20 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 d . ((number?
6d90: 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 73 val) val). ((s
6da0: 74 72 69 6e 67 3f 20 76 61 6c 29 20 28 73 74 72 tring? val) (str
6db0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 ing->number val)
6dc0: 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 ). ((symbol? v
6dd0: 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 al) (any->number
6de0: 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 (symbol->string
6df0: 20 76 61 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 val))). (else
6e00: 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f)))..(define
6e10: 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d (any->number-if-
6e20: 70 6f 73 73 69 62 6c 65 20 76 61 6c 29 0a 20 20 possible val).
6e30: 28 6c 65 74 20 28 28 6e 75 6d 20 28 61 6e 79 2d (let ((num (any-
6e40: 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 29 0a 20 >number val))).
6e50: 20 20 20 28 69 66 20 6e 75 6d 20 6e 75 6d 20 76 (if num num v
6e60: 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 al)))..(define (
6e70: 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 patt-list-match
6e80: 69 74 65 6d 20 70 61 74 74 73 29 0a 20 20 28 64 item patts). (d
6e90: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
6ea0: 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 8 *default-log-p
6eb0: 6f 72 74 2a 20 22 70 61 74 74 2d 6c 69 73 74 2d ort* "patt-list-
6ec0: 6d 61 74 63 68 20 69 74 65 6d 3d 22 20 69 74 65 match item=" ite
6ed0: 6d 20 22 20 70 61 74 74 73 3d 22 20 70 61 74 74 m " patts=" patt
6ee0: 73 29 0a 20 20 28 69 66 20 28 61 6e 64 20 69 74 s). (if (and it
6ef0: 65 6d 20 70 61 74 74 73 29 20 20 3b 3b 20 68 65 em patts) ;; he
6f00: 72 65 20 77 65 20 61 72 65 20 66 69 6c 74 65 72 re we are filter
6f10: 69 6e 67 20 66 6f 72 20 6d 61 74 63 68 65 73 20 ing for matches
6f20: 77 69 74 68 20 69 74 65 6d 20 70 61 74 74 65 72 with item patter
6f30: 6e 73 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 ns. (let ((
6f40: 72 65 73 20 23 66 29 29 20 20 20 3b 3b 20 6c 6f res #f)) ;; lo
6f50: 6f 6b 20 74 68 72 6f 75 67 68 20 61 6c 6c 20 74 ok through all t
6f60: 68 65 20 69 74 65 6d 2d 70 61 74 74 73 20 69 66 he item-patts if
6f70: 20 64 65 66 69 6e 65 64 2c 20 66 6f 72 6d 61 74 defined, format
6f80: 20 69 73 20 70 61 74 74 31 2c 70 61 74 74 32 2c is patt1,patt2,
6f90: 70 61 74 74 33 20 2e 2e 2e 20 77 69 6c 64 63 61 patt3 ... wildca
6fa0: 72 64 20 69 73 20 25 0a 09 28 66 6f 72 2d 65 61 rd is %..(for-ea
6fb0: 63 68 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 70 ch .. (lambda (p
6fc0: 61 74 74 29 0a 09 20 20 20 28 6c 65 74 20 28 28 att).. (let ((
6fd0: 6d 6f 64 70 61 74 74 20 28 73 74 72 69 6e 67 2d modpatt (string-
6fe0: 73 75 62 73 74 69 74 75 74 65 20 22 25 22 20 22 substitute "%" "
6ff0: 2e 2a 22 20 70 61 74 74 20 23 74 29 29 29 0a 09 .*" patt #t)))..
7000: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
7010: 74 2d 69 6e 66 6f 20 31 30 20 2a 64 65 66 61 75 t-info 10 *defau
7020: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 61 lt-log-port* "pa
7030: 74 74 20 22 20 70 61 74 74 20 22 20 6d 6f 64 70 tt " patt " modp
7040: 61 74 74 20 22 20 6d 6f 64 70 61 74 74 29 0a 09 att " modpatt)..
7050: 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 (if (string
7060: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 6d -match (regexp m
7070: 6f 64 70 61 74 74 29 20 69 74 65 6d 29 0a 09 09 odpatt) item)...
7080: 20 28 73 65 74 21 20 72 65 73 20 23 74 29 29 29 (set! res #t)))
7090: 29 0a 09 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 ).. (string-spli
70a0: 74 20 70 61 74 74 73 20 22 2c 22 29 29 0a 09 72 t patts ","))..r
70b0: 65 73 29 0a 20 20 20 20 20 20 23 74 29 29 0a 0a es). #t))..
70c0: 3b 3b 20 28 6d 61 70 20 70 72 69 6e 74 20 28 6d ;; (map print (m
70d0: 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 ap car (hash-tab
70e0: 6c 65 2d 3e 61 6c 69 73 74 20 28 72 65 61 64 2d le->alist (read-
70f0: 63 6f 6e 66 69 67 20 22 72 75 6e 63 6f 6e 66 69 config "runconfi
7100: 67 73 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 74 gs.config" #f #t
7110: 29 29 29 29 0a 28 64 65 66 69 6e 65 20 28 63 6f )))).(define (co
7120: 6d 6d 6f 6e 3a 67 65 74 2d 72 75 6e 63 6f 6e 66 mmon:get-runconf
7130: 69 67 2d 74 61 72 67 65 74 73 20 23 21 6b 65 79 ig-targets #!key
7140: 20 28 63 6f 6e 66 69 67 66 20 23 66 29 29 0a 20 (configf #f)).
7150: 20 28 6c 65 74 20 28 28 74 61 72 67 73 20 20 20 (let ((targs
7160: 20 20 20 20 28 73 6f 72 74 20 28 6d 61 70 20 63 (sort (map c
7170: 61 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e ar (hash-table->
7180: 61 6c 69 73 74 0a 09 09 09 09 20 20 20 20 20 28 alist..... (
7190: 6f 72 20 63 6f 6e 66 69 67 66 0a 09 09 09 09 09 or configf......
71a0: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 (read-config (c
71b0: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
71c0: 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 runconfigs.confi
71d0: 67 22 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 g").......
71e0: 23 66 20 23 74 29 0a 09 09 09 09 09 20 28 6d 61 #f #t)...... (ma
71f0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
7200: 29 0a 09 09 09 20 20 20 73 74 72 69 6e 67 3c 3f ).... string<?
7210: 29 29 0a 09 28 74 61 72 67 65 74 2d 70 61 74 74 ))..(target-patt
7220: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7230: 2d 74 61 72 67 65 74 22 29 29 29 0a 20 20 20 20 -target"))).
7240: 28 69 66 20 74 61 72 67 65 74 2d 70 61 74 74 0a (if target-patt.
7250: 09 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 .(filter (lambda
7260: 20 28 78 29 0a 09 09 20 20 28 70 61 74 74 2d 6c (x)... (patt-l
7270: 69 73 74 2d 6d 61 74 63 68 20 78 20 74 61 72 67 ist-match x targ
7280: 65 74 2d 70 61 74 74 29 29 0a 09 09 74 61 72 67 et-patt))...targ
7290: 73 29 0a 09 74 61 72 67 73 29 29 29 0a 0a 3b 3b s)..targs)))..;;
72a0: 20 27 28 70 72 69 6e 74 20 28 73 74 72 69 6e 67 '(print (string
72b0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 -intersperse (ma
72c0: 70 20 63 61 64 72 20 28 68 61 73 68 2d 74 61 62 p cadr (hash-tab
72d0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 le-ref/default (
72e0: 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 read-config "meg
72f0: 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 5c 23 atest.config" \#
7300: 66 20 5c 23 74 29 20 22 64 69 73 6b 73 22 20 27 f \#t) "disks" '
7310: 22 27 22 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 "'"'("none" ""))
7320: 29 20 22 5c 6e 22 29 29 27 0a 28 64 65 66 69 6e ) "\n"))'.(defin
7330: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 e (common:get-di
7340: 73 6b 73 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 sks #!key (confi
7350: 67 66 20 23 66 29 29 0a 20 20 28 68 61 73 68 2d gf #f)). (hash-
7360: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
7370: 74 20 0a 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 t . (or config
7380: 66 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 f (read-config "
7390: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 megatest.config"
73a0: 20 23 66 20 23 74 29 29 0a 20 20 20 22 64 69 73 #f #t)). "dis
73b0: 6b 73 22 20 27 28 22 6e 6f 6e 65 22 20 22 22 29 ks" '("none" "")
73c0: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 ))..;; return fi
73d0: 72 73 74 20 63 6f 6d 6d 61 6e 64 20 74 68 61 74 rst command that
73e0: 20 65 78 69 73 74 73 2c 20 65 6c 73 65 20 23 66 exists, else #f
73f0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
7400: 6d 6f 6e 3a 77 68 69 63 68 20 63 6d 64 73 29 0a mon:which cmds).
7410: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 (if (null? cmd
7420: 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 s). #f.
7430: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
7440: 64 20 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 d (car cmds))...
7450: 20 28 74 61 6c 20 28 63 64 72 20 63 6d 64 73 29 (tal (cdr cmds)
7460: 29 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 ))..(let ((res (
7470: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
7480: 70 69 70 65 20 28 63 6f 6e 63 20 22 77 68 69 63 pipe (conc "whic
7490: 68 20 22 20 68 65 64 29 20 72 65 61 64 2d 6c 69 h " hed) read-li
74a0: 6e 65 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e ne))).. (if (an
74b0: 64 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a d (string? res).
74c0: 09 09 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 .. (file-exist
74d0: 73 3f 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 s? res))..
74e0: 72 65 73 0a 09 20 20 20 20 20 20 28 69 66 20 28 res.. (if (
74f0: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 null? tal)... #
7500: 66 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 f... (loop (car
7510: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 tal)(cdr tal)))
7520: 29 29 29 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 ))))). .(define
7530: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 (common:get-ins
7540: 74 61 6c 6c 2d 61 72 65 61 29 0a 20 20 28 6c 65 tall-area). (le
7550: 74 20 28 28 65 78 65 2d 70 61 74 68 20 28 63 61 t ((exe-path (ca
7560: 72 20 28 61 72 67 76 29 29 29 29 0a 20 20 20 20 r (argv)))).
7570: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
7580: 3f 20 65 78 65 2d 70 61 74 68 29 0a 09 28 68 61 ? exe-path)..(ha
7590: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
75a0: 09 20 65 78 6e 0a 09 20 23 66 0a 09 20 28 70 61 . exn.. #f.. (pa
75b0: 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 thname-directory
75c0: 0a 09 20 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 .. (pathname-di
75d0: 72 65 63 74 6f 72 79 20 0a 09 20 20 20 28 70 61 rectory .. (pa
75e0: 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 thname-directory
75f0: 20 65 78 65 2d 70 61 74 68 29 29 29 29 0a 09 23 exe-path))))..#
7600: 66 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 f)))..;; return
7610: 66 69 72 73 74 20 70 61 74 68 20 74 68 61 74 20 first path that
7620: 63 61 6e 20 62 65 20 63 72 65 61 74 65 64 20 6f can be created o
7630: 72 20 61 6c 72 65 61 64 79 20 65 78 69 73 74 73 r already exists
7640: 20 61 6e 64 20 69 73 20 77 72 69 74 61 62 6c 65 and is writable
7650: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
7660: 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 74 65 2d 77 mon:get-create-w
7670: 72 69 74 65 61 62 6c 65 2d 64 69 72 20 64 69 72 riteable-dir dir
7680: 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 s). (if (null?
7690: 64 69 72 73 29 0a 20 20 20 20 20 20 23 66 0a 20 dirs). #f.
76a0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
76b0: 28 68 65 64 20 28 63 61 72 20 64 69 72 73 29 29 (hed (car dirs))
76c0: 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 64 69 ... (tal (cdr di
76d0: 72 73 29 29 29 0a 09 28 6c 65 74 20 28 28 72 65 rs)))..(let ((re
76e0: 73 20 28 6f 72 20 28 61 6e 64 20 28 64 69 72 65 s (or (and (dire
76f0: 63 74 6f 72 79 3f 20 68 65 64 29 0a 09 09 09 20 ctory? hed)....
7700: 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 (file-write-a
7710: 63 63 65 73 73 3f 20 68 65 64 29 0a 09 09 09 20 ccess? hed)....
7720: 20 20 20 68 65 64 29 0a 09 09 20 20 20 20 20 20 hed)...
7730: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
7740: 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 09 09 23 66 ons....exn....#f
7750: 0a 09 09 09 28 63 72 65 61 74 65 2d 64 69 72 65 ....(create-dire
7760: 63 74 6f 72 79 20 68 65 64 20 23 74 29 29 29 29 ctory hed #t))))
7770: 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 73 ).. (if (and (s
7780: 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 tring? res)...
7790: 20 28 64 69 72 65 63 74 6f 72 79 3f 20 72 65 73 (directory? res
77a0: 29 29 0a 09 20 20 20 20 20 20 72 65 73 0a 09 20 )).. res..
77b0: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
77c0: 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 20 tal)... #f...
77d0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
77e0: 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a cdr tal)))))))).
77f0: 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;===========
7800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 ===========.;; T
7840: 20 41 20 52 20 47 20 45 20 54 20 53 20 20 2c 20 A R G E T S ,
7850: 20 20 53 20 54 20 41 20 54 20 45 20 2c 20 20 20 S T A T E ,
7860: 53 20 54 20 41 20 54 20 55 20 53 20 2c 20 20 20 S T A T U S ,
7870: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
7880: 20 20 20 20 20 20 20 52 20 55 20 4e 20 4e 20 41 R U N N A
7890: 20 4d 20 45 20 20 20 20 41 20 4e 20 44 20 20 20 M E A N D
78a0: 54 20 45 20 53 20 54 20 50 20 41 20 54 20 54 0a T E S T P A T T.
78b0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
78c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
78f0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4c 6f 6f ========..;; Loo
7900: 6b 75 70 20 61 20 76 61 6c 75 65 20 69 6e 20 72 kup a value in r
7910: 75 6e 63 6f 6e 66 69 67 73 20 62 61 73 65 64 20 unconfigs based
7920: 6f 6e 20 2d 72 65 71 74 61 72 67 20 6f 72 20 2d on -reqtarg or -
7930: 74 61 72 67 65 74 0a 28 64 65 66 69 6e 65 20 28 target.(define (
7940: 72 75 6e 63 6f 6e 66 69 67 73 2d 67 65 74 20 63 runconfigs-get c
7950: 6f 6e 66 69 67 20 76 61 72 29 0a 20 20 28 6c 65 onfig var). (le
7960: 74 20 28 28 74 61 72 67 20 28 63 6f 6d 6d 6f 6e t ((targ (common
7970: 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 :args-get-target
7980: 29 29 29 20 3b 3b 20 28 6f 72 20 28 61 72 67 73 ))) ;; (or (args
7990: 3a 67 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 :get-arg "-reqta
79a0: 72 67 22 29 28 61 72 67 73 3a 67 65 74 2d 61 72 rg")(args:get-ar
79b0: 67 20 22 2d 74 61 72 67 65 74 22 29 28 67 65 74 g "-target")(get
79c0: 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 env "MT_TARGET")
79d0: 29 29 29 0a 20 20 20 20 28 69 66 20 74 61 72 67 ))). (if targ
79e0: 0a 09 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c ..(or (configf:l
79f0: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 74 61 72 ookup config tar
7a00: 67 20 76 61 72 29 0a 09 20 20 20 20 28 63 6f 6e g var).. (con
7a10: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 figf:lookup conf
7a20: 69 67 20 22 64 65 66 61 75 6c 74 22 20 76 61 72 ig "default" var
7a30: 29 29 0a 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f ))..(configf:loo
7a40: 6b 75 70 20 63 6f 6e 66 69 67 20 22 64 65 66 61 kup config "defa
7a50: 75 6c 74 22 20 76 61 72 29 29 29 29 0a 0a 28 64 ult" var))))..(d
7a60: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 efine (common:ar
7a70: 67 73 2d 67 65 74 2d 73 74 61 74 65 29 0a 20 20 gs-get-state).
7a80: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
7a90: 67 20 22 2d 73 74 61 74 65 22 29 28 61 72 67 73 g "-state")(args
7aa0: 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 65 :get-arg ":state
7ab0: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ")))..(define (c
7ac0: 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 73 ommon:args-get-s
7ad0: 74 61 74 75 73 29 0a 20 20 28 6f 72 20 28 61 72 tatus). (or (ar
7ae0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 61 gs:get-arg "-sta
7af0: 74 75 73 22 29 28 61 72 67 73 3a 67 65 74 2d 61 tus")(args:get-a
7b00: 72 67 20 22 3a 73 74 61 74 75 73 22 29 29 29 0a rg ":status"))).
7b10: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
7b20: 3a 61 72 67 73 2d 67 65 74 2d 74 65 73 74 70 61 :args-get-testpa
7b30: 74 74 20 72 63 6f 6e 66 29 0a 20 20 28 6c 65 74 tt rconf). (let
7b40: 2a 20 28 28 74 61 67 65 78 70 72 20 28 61 72 67 * ((tagexpr (arg
7b50: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 67 65 s:get-arg "-tage
7b60: 78 70 72 22 29 29 0a 20 20 20 20 20 20 20 20 20 xpr")).
7b70: 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 20 28 (tags-testpatt (
7b80: 69 66 20 74 61 67 65 78 70 72 20 28 73 74 72 69 if tagexpr (stri
7b90: 6e 67 2d 6a 6f 69 6e 20 28 72 75 6e 73 3a 67 65 ng-join (runs:ge
7ba0: 74 2d 74 65 73 74 73 2d 6d 61 74 63 68 69 6e 67 t-tests-matching
7bb0: 2d 74 61 67 73 20 74 61 67 65 78 70 72 29 20 22 -tags tagexpr) "
7bc0: 2c 22 29 20 23 66 29 29 0a 20 20 20 20 20 20 20 ,") #f)).
7bd0: 20 20 28 74 65 73 74 70 61 74 74 2d 6b 65 79 20 (testpatt-key
7be0: 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 (if (args:get-a
7bf0: 72 67 20 22 2d 6d 6f 64 65 22 29 20 28 61 72 67 rg "-mode") (arg
7c00: 73 3a 67 65 74 2d 61 72 67 20 22 2d 6d 6f 64 65 s:get-arg "-mode
7c10: 22 29 20 22 54 45 53 54 50 41 54 54 22 29 29 0a ") "TESTPATT")).
7c20: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 2d 74 (args-t
7c30: 65 73 74 70 61 74 74 20 28 6f 72 20 28 61 72 67 estpatt (or (arg
7c40: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 s:get-arg "-test
7c50: 70 61 74 74 22 29 20 28 61 72 67 73 3a 67 65 74 patt") (args:get
7c60: 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 -arg "-runtests"
7c70: 29 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 ) "%")).
7c80: 20 28 72 74 65 73 74 70 61 74 74 20 20 20 20 20 (rtestpatt
7c90: 28 69 66 20 72 63 6f 6e 66 20 28 72 75 6e 63 6f (if rconf (runco
7ca0: 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 20 nfigs-get rconf
7cb0: 74 65 73 74 70 61 74 74 2d 6b 65 79 29 20 23 66 testpatt-key) #f
7cc0: 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 ))). (cond.
7cd0: 20 20 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 (tags-testpat
7ce0: 74 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 t. (debug:p
7cf0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
7d00: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7d10: 2d 74 61 67 65 78 70 72 20 22 74 61 67 65 78 70 -tagexpr "tagexp
7d20: 72 22 20 73 65 6c 65 63 74 73 20 74 65 73 74 70 r" selects testp
7d30: 61 74 74 20 22 74 61 67 73 2d 74 65 73 74 70 61 att "tags-testpa
7d40: 74 74 29 0a 20 20 20 20 20 20 74 61 67 73 2d 74 tt). tags-t
7d50: 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 28 28 estpatt). ((
7d60: 61 6e 64 20 28 65 71 75 61 6c 3f 20 61 72 67 73 and (equal? args
7d70: 2d 74 65 73 74 70 61 74 74 20 22 25 22 29 20 72 -testpatt "%") r
7d80: 74 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 20 testpatt).
7d90: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7da0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
7db0: 2d 70 6f 72 74 2a 20 22 74 65 73 74 70 61 74 74 -port* "testpatt
7dc0: 20 64 65 66 69 6e 65 64 20 69 6e 20 22 74 65 73 defined in "tes
7dd0: 74 70 61 74 74 2d 6b 65 79 22 20 66 72 6f 6d 20 tpatt-key" from
7de0: 72 75 6e 63 6f 6e 66 69 67 73 3a 20 22 20 72 74 runconfigs: " rt
7df0: 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 20 72 estpatt). r
7e00: 74 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 28 testpatt). (
7e10: 65 6c 73 65 20 61 72 67 73 2d 74 65 73 74 70 61 else args-testpa
7e20: 74 74 29 29 29 29 0a 20 20 20 20 20 0a 28 64 65 tt)))). .(de
7e30: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
7e40: 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 20 28 6f 72 -linktree). (or
7e50: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e (getenv "MT_LIN
7e60: 4b 54 52 45 45 22 29 0a 20 20 20 20 20 20 28 69 KTREE"). (i
7e70: 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 20 f *configdat*..
7e80: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
7e90: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
7ea0: 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 tup" "linktree")
7eb0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
7ec0: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 72 75 mmon:args-get-ru
7ed0: 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 nname). (let ((
7ee0: 72 65 73 20 28 6f 72 20 28 61 72 67 73 3a 67 65 res (or (args:ge
7ef0: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
7f00: 29 0a 09 09 20 28 61 72 67 73 3a 67 65 74 2d 61 )... (args:get-a
7f10: 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 0a 09 rg ":runname")..
7f20: 09 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 . (getenv "MT_RU
7f30: 4e 4e 41 4d 45 22 29 29 29 29 0a 20 20 20 20 3b NNAME")))). ;
7f40: 3b 20 28 69 66 20 72 65 73 20 28 73 65 74 2d 65 ; (if res (set-e
7f50: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
7f60: 62 6c 65 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 ble "MT_RUNNAME"
7f70: 20 72 65 73 29 29 20 3b 3b 20 6e 6f 74 20 73 75 res)) ;; not su
7f80: 72 65 20 69 66 20 74 68 69 73 20 69 73 20 61 20 re if this is a
7f90: 67 6f 6f 64 20 69 64 65 61 2e 20 73 69 64 65 20 good idea. side
7fa0: 65 66 66 65 63 74 20 61 6e 64 20 61 6c 6c 20 2e effect and all .
7fb0: 2e 2e 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 ... res))..(d
7fc0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 efine (common:ar
7fd0: 67 73 2d 67 65 74 2d 74 61 72 67 65 74 20 23 21 gs-get-target #!
7fe0: 6b 65 79 20 28 73 70 6c 69 74 20 23 66 29 29 0a key (split #f)).
7ff0: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 (let* ((keys
8000: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
8010: 65 3f 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 20 e? *configdat*)
8020: 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 (keys:config-get
8030: 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 -fields *configd
8040: 61 74 2a 29 20 27 28 29 29 29 0a 09 20 28 6e 75 at*) '())).. (nu
8050: 6d 6b 65 79 73 20 28 6c 65 6e 67 74 68 20 6b 65 mkeys (length ke
8060: 79 73 29 29 0a 09 20 28 74 61 72 67 65 74 20 20 ys)).. (target
8070: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
8080: 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 g "-reqtarg")...
8090: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
80a0: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 arg "-target")..
80b0: 09 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 . (getenv "
80c0: 4d 54 5f 54 41 52 47 45 54 22 29 29 29 0a 09 20 MT_TARGET")))..
80d0: 28 74 6c 69 73 74 20 20 20 28 69 66 20 74 61 72 (tlist (if tar
80e0: 67 65 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 get (string-spli
80f0: 74 20 74 61 72 67 65 74 20 22 2f 22 20 23 74 29 t target "/" #t)
8100: 20 27 28 29 29 29 0a 09 20 28 76 61 6c 69 64 20 '())).. (valid
8110: 20 20 28 69 66 20 74 61 72 67 65 74 0a 09 09 20 (if target...
8120: 20 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 (or (null?
8130: 6b 65 79 73 29 20 3b 3b 20 70 72 6f 62 61 62 6c keys) ;; probabl
8140: 79 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 6f 75 72 y don't know our
8150: 20 6b 65 79 73 20 79 65 74 0a 09 09 09 20 20 28 keys yet.... (
8160: 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 and (not (null?
8170: 74 6c 69 73 74 29 29 0a 09 09 09 20 20 20 20 20 tlist))....
8180: 20 20 28 65 71 3f 20 6e 75 6d 6b 65 79 73 20 28 (eq? numkeys (
8190: 6c 65 6e 67 74 68 20 74 6c 69 73 74 29 29 0a 09 length tlist))..
81a0: 09 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 .. (null?
81b0: 28 66 69 6c 74 65 72 20 73 74 72 69 6e 67 2d 6e (filter string-n
81c0: 75 6c 6c 3f 20 74 6c 69 73 74 29 29 29 29 0a 09 ull? tlist))))..
81d0: 09 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 . #f))).
81e0: 20 28 69 66 20 76 61 6c 69 64 0a 09 28 69 66 20 (if valid..(if
81f0: 73 70 6c 69 74 0a 09 20 20 20 20 74 6c 69 73 74 split.. tlist
8200: 0a 09 20 20 20 20 74 61 72 67 65 74 29 0a 09 28 .. target)..(
8210: 69 66 20 74 61 72 67 65 74 0a 09 20 20 20 20 28 if target.. (
8220: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
8230: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
8240: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
8250: 6f 72 74 2a 20 22 49 6e 76 61 6c 69 64 20 74 61 ort* "Invalid ta
8260: 72 67 65 74 2c 20 73 70 61 63 65 73 20 6f 72 20 rget, spaces or
8270: 62 6c 61 6e 6b 73 20 6e 6f 74 20 61 6c 6c 6f 77 blanks not allow
8280: 65 64 20 5c 22 22 20 74 61 72 67 65 74 20 22 5c ed \"" target "\
8290: 22 2c 20 74 61 72 67 65 74 20 73 68 6f 75 6c 64 ", target should
82a0: 20 62 65 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 be: " (string-i
82b0: 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 73 20 ntersperse keys
82c0: 22 2f 22 29 20 22 2c 20 68 61 76 65 20 22 20 74 "/") ", have " t
82d0: 6c 69 73 74 20 22 20 66 6f 72 20 65 6c 65 6d 65 list " for eleme
82e0: 6e 74 73 22 29 0a 09 20 20 20 20 20 20 23 66 29 nts").. #f)
82f0: 0a 09 20 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b .. #f))))..;;
8300: 20 6c 6f 67 69 63 20 66 6f 72 20 67 65 74 74 69 logic for getti
8310: 6e 67 20 68 6f 6d 65 68 6f 73 74 2e 20 52 65 74 ng homehost. Ret
8320: 75 72 6e 73 20 28 68 6f 73 74 20 2e 20 61 74 2d urns (host . at-
8330: 68 6f 6d 65 29 0a 3b 3b 20 49 46 20 2a 74 6f 70 home).;; IF *top
8340: 70 61 74 68 2a 20 69 73 20 6e 6f 74 20 73 65 74 path* is not set
8350: 2c 20 77 61 69 74 20 75 70 20 74 6f 20 66 69 76 , wait up to fiv
8360: 65 20 73 65 63 6f 6e 64 73 20 74 72 79 69 6e 67 e seconds trying
8370: 20 65 76 65 72 79 20 74 77 6f 20 73 65 63 6f 6e every two secon
8380: 64 73 0a 3b 3b 20 28 74 68 69 73 20 69 73 20 74 ds.;; (this is t
8390: 6f 20 61 63 63 6f 6d 6f 64 61 74 65 20 74 68 65 o accomodate the
83a0: 20 77 61 74 63 68 64 6f 67 29 0a 3b 3b 0a 28 64 watchdog).;;.(d
83b0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
83c0: 74 2d 68 6f 6d 65 68 6f 73 74 20 23 21 6b 65 79 t-homehost #!key
83d0: 20 28 74 72 79 6e 75 6d 20 35 29 29 0a 20 20 3b (trynum 5)). ;
83e0: 3b 20 63 61 6c 6c 65 64 20 6f 66 74 65 6e 20 65 ; called often e
83f0: 73 70 65 63 69 61 6c 6c 79 20 61 74 20 73 74 61 specially at sta
8400: 72 74 20 75 70 2e 20 75 73 65 20 6d 75 74 65 78 rt up. use mutex
8410: 20 74 6f 20 65 6c 69 6d 69 6e 61 74 65 20 63 6f to eliminate co
8420: 6c 6c 69 73 69 6f 6e 73 0a 20 20 28 6d 75 74 65 llisions. (mute
8430: 78 2d 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 x-lock! *homehos
8440: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 63 6f 6e t-mutex*). (con
8450: 64 0a 20 20 20 28 2a 68 6f 6d 65 2d 68 6f 73 74 d. (*home-host
8460: 2a 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c *. (mutex-unl
8470: 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d ock! *homehost-m
8480: 75 74 65 78 2a 29 0a 20 20 20 20 2a 68 6f 6d 65 utex*). *home
8490: 2d 68 6f 73 74 2a 29 0a 20 20 20 28 28 6e 6f 74 -host*). ((not
84a0: 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 *toppath*).
84b0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
84c0: 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 homehost-mutex*)
84d0: 0a 20 20 20 20 28 6c 61 75 6e 63 68 3a 73 65 74 . (launch:set
84e0: 75 70 29 20 3b 3b 20 73 61 66 65 6c 79 20 6d 75 up) ;; safely mu
84f0: 74 65 78 65 64 20 6e 6f 77 0a 20 20 20 20 28 69 texed now. (i
8500: 66 20 28 3e 20 74 72 79 6e 75 6d 20 30 29 0a 09 f (> trynum 0)..
8510: 28 62 65 67 69 6e 0a 09 20 20 28 74 68 72 65 61 (begin.. (threa
8520: 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 20 20 28 d-sleep! 2).. (
8530: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 common:get-homeh
8540: 6f 73 74 20 74 72 79 6e 75 6d 3a 20 28 2d 20 74 ost trynum: (- t
8550: 72 79 6e 75 6d 20 31 29 29 29 0a 09 23 66 29 29 rynum 1)))..#f))
8560: 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 6c . (else. (l
8570: 65 74 2a 20 28 28 63 75 72 72 68 6f 73 74 20 28 et* ((currhost (
8580: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a get-host-name)).
8590: 09 20 20 20 28 62 65 73 74 61 64 72 73 20 28 73 . (bestadrs (s
85a0: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
85b0: 75 65 73 73 2d 61 64 64 72 65 73 73 20 63 75 72 uess-address cur
85c0: 72 68 6f 73 74 29 29 0a 09 20 20 20 3b 3b 20 66 rhost)).. ;; f
85d0: 69 72 73 74 20 6c 6f 6f 6b 20 69 6e 20 63 6f 6e irst look in con
85e0: 66 69 67 2c 20 74 68 65 6e 20 6c 6f 6f 6b 20 69 fig, then look i
85f0: 6e 20 66 69 6c 65 20 2e 68 6f 6d 65 68 6f 73 74 n file .homehost
8600: 2c 20 63 72 65 61 74 65 20 69 74 20 69 66 20 6e , create it if n
8610: 6f 74 20 66 6f 75 6e 64 0a 09 20 20 20 28 68 6f ot found.. (ho
8620: 6d 65 68 6f 73 74 20 28 6f 72 20 28 63 6f 6e 66 mehost (or (conf
8630: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
8640: 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 igdat* "server"
8650: 22 68 6f 6d 65 68 6f 73 74 22 20 29 0a 09 09 09 "homehost" )....
8660: 20 28 6c 65 74 20 28 28 68 68 66 20 28 63 6f 6e (let ((hhf (con
8670: 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e 68 c *toppath* "/.h
8680: 6f 6d 65 68 6f 73 74 22 29 29 29 0a 09 09 09 20 omehost")))....
8690: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
86a0: 74 73 3f 20 68 68 66 29 0a 09 09 09 20 20 20 20 ts? hhf)....
86b0: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
86c0: 72 6f 6d 2d 66 69 6c 65 20 68 68 66 20 72 65 61 rom-file hhf rea
86d0: 64 2d 6c 69 6e 65 29 0a 09 09 09 20 20 20 20 20 d-line)....
86e0: 20 20 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 (if (file-writ
86f0: 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 70 61 e-access? *toppa
8700: 74 68 2a 29 0a 09 09 09 09 20 20 20 28 62 65 67 th*)..... (beg
8710: 69 6e 0a 09 09 09 09 20 20 20 20 20 28 77 69 74 in..... (wit
8720: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
8730: 20 68 68 66 0a 09 09 09 09 20 20 20 20 20 20 20 hhf.....
8740: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 (lambda ()......
8750: 20 28 70 72 69 6e 74 20 62 65 73 74 61 64 72 73 (print bestadrs
8760: 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 62 65 )))..... (be
8770: 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 gin..... (
8780: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
8790: 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a omehost-mutex*).
87a0: 09 09 09 09 20 20 20 20 20 20 20 28 63 61 72 20 .... (car
87b0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 (common:get-home
87c0: 68 6f 73 74 29 29 29 29 0a 09 09 09 09 20 20 20 host)))).....
87d0: 23 66 29 29 29 29 29 0a 09 20 20 20 28 61 74 2d #f))))).. (at-
87e0: 68 6f 6d 65 20 20 28 6f 72 20 28 65 71 75 61 6c home (or (equal
87f0: 3f 20 68 6f 6d 65 68 6f 73 74 20 63 75 72 72 68 ? homehost currh
8800: 6f 73 74 29 0a 09 09 09 20 28 65 71 75 61 6c 3f ost).... (equal?
8810: 20 68 6f 6d 65 68 6f 73 74 20 62 65 73 74 61 64 homehost bestad
8820: 72 73 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 rs)))). (se
8830: 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 28 t! *home-host* (
8840: 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 74 20 61 74 cons homehost at
8850: 2d 68 6f 6d 65 29 29 0a 20 20 20 20 20 20 28 6d -home)). (m
8860: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f utex-unlock! *ho
8870: 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 mehost-mutex*).
8880: 20 20 20 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a *home-host*
8890: 29 29 29 29 0a 0a 3b 3b 20 61 6d 20 49 20 6f 6e ))))..;; am I on
88a0: 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 3f 0a 3b the homehost?.;
88b0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
88c0: 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a n:on-homehost?).
88d0: 20 20 28 6c 65 74 20 28 28 68 68 20 28 63 6f 6d (let ((hh (com
88e0: 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mon:get-homehost
88f0: 29 29 29 0a 20 20 20 20 28 69 66 20 68 68 0a 09 ))). (if hh..
8900: 28 63 64 72 20 68 68 29 0a 09 23 66 29 29 29 0a (cdr hh)..#f))).
8910: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
8920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 =========.;; M I
8960: 20 53 20 43 20 20 20 4c 20 49 20 53 20 54 20 53 S C L I S T S
8970: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
8980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
89b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 74 =========..;; it
89c0: 65 6d 73 20 69 6e 20 6c 69 73 74 61 20 61 72 65 ems in lista are
89d0: 20 6d 61 74 63 68 65 64 20 76 61 6c 75 65 20 61 matched value a
89e0: 6e 64 20 70 6f 73 69 74 69 6f 6e 20 69 6e 20 6c nd position in l
89f0: 69 73 74 62 0a 3b 3b 20 72 65 74 75 72 6e 20 74 istb.;; return t
8a00: 68 65 20 72 65 6d 61 69 6e 69 6e 67 20 69 74 65 he remaining ite
8a10: 6d 73 20 69 6e 20 6c 69 73 74 62 20 6f 72 20 23 ms in listb or #
8a20: 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f f.;;.(define (co
8a30: 6d 6d 6f 6e 3a 6c 69 73 74 2d 69 73 2d 73 75 62 mmon:list-is-sub
8a40: 6c 69 73 74 20 6c 69 73 74 61 20 6c 69 73 74 62 list lista listb
8a50: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c ). (if (null? l
8a60: 69 73 74 61 29 0a 20 20 20 20 20 20 6c 69 73 74 ista). list
8a70: 62 20 3b 3b 20 61 6c 6c 20 69 74 65 6d 73 20 69 b ;; all items i
8a80: 6e 20 6c 69 73 74 62 20 61 72 65 20 22 72 65 6d n listb are "rem
8a90: 61 69 6e 69 6e 67 22 0a 20 20 20 20 20 20 28 69 aining". (i
8aa0: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 6c 69 73 f (> (length lis
8ab0: 74 61 29 28 6c 65 6e 67 74 68 20 6c 69 73 74 62 ta)(length listb
8ac0: 29 29 20 0a 09 20 20 23 66 0a 09 20 20 28 6c 65 )) .. #f.. (le
8ad0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 61 20 28 63 t loop ((heda (c
8ae0: 61 72 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 ar lista))...
8af0: 20 20 28 74 61 6c 61 20 28 63 64 72 20 6c 69 73 (tala (cdr lis
8b00: 74 61 29 29 0a 09 09 20 20 20 20 20 28 68 65 64 ta))... (hed
8b10: 62 20 28 63 61 72 20 6c 69 73 74 62 29 29 0a 09 b (car listb))..
8b20: 09 20 20 20 20 20 28 74 61 6c 62 20 28 63 64 72 . (talb (cdr
8b30: 20 6c 69 73 74 62 29 29 29 0a 09 20 20 20 20 28 listb))).. (
8b40: 69 66 20 28 65 71 75 61 6c 3f 20 68 65 64 61 20 if (equal? heda
8b50: 68 65 64 62 29 0a 09 09 28 69 66 20 28 6e 75 6c hedb)...(if (nul
8b60: 6c 3f 20 74 61 6c 61 29 20 3b 3b 20 77 65 20 61 l? tala) ;; we a
8b70: 72 65 20 64 6f 6e 65 0a 09 09 20 20 20 20 74 61 re done... ta
8b80: 6c 62 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 lb... (loop (
8b90: 63 61 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 car tala).... (
8ba0: 63 64 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 cdr tala).... (
8bb0: 63 61 72 20 74 61 6c 62 29 0a 09 09 09 20 20 0a car talb).... .
8bc0: 09 09 09 20 20 28 63 64 72 20 74 61 6c 62 29 29 ... (cdr talb))
8bd0: 29 0a 09 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 )...#f)))))..;;
8be0: 4e 65 65 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 Needed for long
8bf0: 6c 69 73 74 73 20 74 6f 20 62 65 20 73 6f 72 74 lists to be sort
8c00: 65 64 20 77 68 65 72 65 20 28 61 70 70 6c 79 20 ed where (apply
8c10: 6d 61 78 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b max ... ) dies.;
8c20: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
8c30: 6e 3a 6d 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 n:max inlst). (
8c40: 6c 65 74 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 let loop ((max-v
8c50: 61 6c 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a al (car inlst)).
8c60: 09 20 20 20 20 20 28 68 65 64 20 20 20 20 20 28 . (hed (
8c70: 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 car inlst))..
8c80: 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 (tal (cdr
8c90: 69 6e 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 inlst))). (if
8ca0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
8cb0: 29 29 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 ))..(loop (max h
8cc0: 65 64 20 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 ed max-val)..
8cd0: 20 20 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 (car tal)..
8ce0: 20 20 20 20 28 63 64 72 20 74 61 6c 29 29 0a 09 (cdr tal))..
8cf0: 28 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c (max hed max-val
8d00: 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e ))))..;; get min
8d10: 20 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 or max, use > f
8d20: 6f 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 or max and < for
8d30: 20 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 min, this works
8d40: 20 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 around the limi
8d50: 74 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 ts on apply.;;.(
8d60: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d define (common:m
8d70: 69 6e 2d 6d 61 78 20 63 6f 6d 70 20 6c 73 74 29 in-max comp lst)
8d80: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 . (if (null? ls
8d90: 74 29 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 62 t). #f ;; b
8da0: 65 74 74 65 72 20 74 68 61 6e 20 61 6e 20 65 78 etter than an ex
8db0: 63 65 70 74 69 6f 6e 20 66 6f 72 20 6d 79 20 6e ception for my n
8dc0: 65 65 64 73 0a 20 20 20 20 20 20 28 66 6f 6c 64 eeds. (fold
8dd0: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 (lambda (a b)..
8de0: 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 70 20 (if (comp
8df0: 61 20 62 29 20 61 20 62 29 29 0a 09 20 20 20 20 a b) a b))..
8e00: 28 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 6c (car lst).. l
8e10: 73 74 29 29 29 0a 0a 3b 3b 20 70 61 74 68 20 6c st)))..;; path l
8e20: 69 73 74 20 74 6f 20 68 61 73 68 2d 74 61 62 6c ist to hash-tabl
8e30: 65 20 74 72 65 65 0a 3b 3b 20 20 20 28 28 61 20 e tree.;; ((a
8e40: 62 20 63 29 28 61 20 62 20 64 29 28 65 20 62 20 b c)(a b d)(e b
8e50: 63 29 29 20 3d 3e 20 28 28 61 20 28 62 20 28 64 c)) => ((a (b (d
8e60: 29 20 28 63 29 29 29 20 28 65 20 28 62 20 28 63 ) (c))) (e (b (c
8e70: 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 )))).;;.(define
8e80: 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 (common:list->ht
8e90: 72 65 65 20 6c 73 74 29 0a 20 20 28 6c 65 74 20 ree lst). (let
8ea0: 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 ((resh (make-has
8eb0: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 h-table))). (
8ec0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
8ed0: 61 6d 62 64 61 20 28 69 6e 6c 73 74 29 0a 20 20 ambda (inlst).
8ee0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
8ef0: 28 68 74 20 20 72 65 73 68 29 0a 09 09 20 20 28 (ht resh)... (
8f00: 68 65 64 20 28 63 61 72 20 69 6e 6c 73 74 29 29 hed (car inlst))
8f10: 0a 09 09 20 20 28 74 61 6c 20 28 63 64 72 20 69 ... (tal (cdr i
8f20: 6e 6c 73 74 29 29 29 0a 09 20 28 69 66 20 28 68 nlst))).. (if (h
8f30: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
8f40: 66 61 75 6c 74 20 68 74 20 68 65 64 20 23 66 29 fault ht hed #f)
8f50: 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 .. (if (not
8f60: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 (null? tal))...
8f70: 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 6c (loop (hash-tabl
8f80: 65 2d 72 65 66 20 68 74 20 68 65 64 29 0a 09 09 e-ref ht hed)...
8f90: 20 20 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 (car tal)
8fa0: 0a 09 09 20 20 20 20 20 20 20 28 63 64 72 20 74 ... (cdr t
8fb0: 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 al))).. (beg
8fc0: 69 6e 0a 09 20 20 20 20 20 20 20 28 68 61 73 68 in.. (hash
8fd0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 68 -table-set! ht h
8fe0: 65 64 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 ed (make-hash-ta
8ff0: 62 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c ble)).. (l
9000: 6f 6f 70 20 68 74 20 68 65 64 20 74 61 6c 29 29 oop ht hed tal))
9010: 29 29 29 0a 20 20 20 20 20 6c 73 74 29 0a 20 20 ))). lst).
9020: 20 20 72 65 73 68 29 29 0a 0a 3b 3b 20 68 61 73 resh))..;; has
9030: 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 h-table tree to
9040: 68 74 6d 6c 20 6c 69 73 74 20 74 72 65 65 0a 3b html list tree.;
9050: 3b 0a 3b 3b 20 20 20 74 69 70 66 75 6e 63 20 74 ;.;; tipfunc t
9060: 61 6b 65 73 20 74 77 6f 20 70 61 72 61 6d 65 74 akes two paramet
9070: 65 72 73 3a 20 79 20 74 68 65 20 74 69 70 20 76 ers: y the tip v
9080: 61 6c 75 65 20 61 6e 64 20 70 61 74 68 20 74 68 alue and path th
9090: 65 20 70 61 74 68 20 74 6f 20 74 68 61 74 20 70 e path to that p
90a0: 6f 69 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 oint.;;.(define
90b0: 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 (common:htree->h
90c0: 74 6d 6c 20 68 74 20 70 61 74 68 20 74 69 70 66 tml ht path tipf
90d0: 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 64 61 unc). (let ((da
90e0: 74 6c 69 73 74 20 09 28 73 6f 72 74 20 28 68 61 tlist .(sort (ha
90f0: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
9100: 68 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ht).
9110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9120: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a (lambda (a b).
9130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9150: 28 73 74 72 69 6e 67 3c 20 28 63 61 72 20 61 29 (string< (car a)
9160: 28 63 61 72 20 62 29 29 29 29 29 29 0a 20 20 20 (car b)))))).
9170: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 6c (if (null? datl
9180: 69 73 74 29 0a 20 20 20 20 09 28 74 69 70 66 75 ist). .(tipfu
9190: 6e 63 20 23 66 20 70 61 74 68 29 20 3b 3b 20 72 nc #f path) ;; r
91a0: 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 eally shouldn't
91b0: 67 65 74 20 68 65 72 65 0a 09 28 73 3a 75 6c 0a get here..(s:ul.
91c0: 09 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 . (map (lambda (
91d0: 78 29 0a 09 09 28 6c 65 74 2a 20 28 28 6c 65 76 x)...(let* ((lev
91e0: 65 6c 6e 61 6d 65 20 28 63 61 72 20 78 29 29 0a elname (car x)).
91f0: 09 09 20 20 20 20 20 20 20 28 79 20 20 20 20 20 .. (y
9200: 20 20 20 20 28 63 64 72 20 78 29 29 0a 09 09 20 (cdr x))...
9210: 20 20 20 20 20 20 28 6e 65 77 70 61 74 68 20 20 (newpath
9220: 20 28 61 70 70 65 6e 64 20 70 61 74 68 20 28 6c (append path (l
9230: 69 73 74 20 6c 65 76 65 6c 6e 61 6d 65 29 29 29 ist levelname)))
9240: 0a 09 09 20 20 20 20 20 20 20 28 6c 65 61 66 20 ... (leaf
9250: 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 68 (or (not (h
9260: 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 29 0a 09 ash-table? y))..
9270: 09 09 09 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 ... (null?
9280: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
9290: 20 79 29 29 29 29 29 0a 09 09 20 20 28 69 66 20 y)))))... (if
92a0: 6c 65 61 66 0a 09 09 20 20 20 20 20 20 28 73 3a leaf... (s:
92b0: 6c 69 20 28 74 69 70 66 75 6e 63 20 79 20 6e 65 li (tipfunc y ne
92c0: 77 70 61 74 68 29 29 0a 09 09 20 20 20 20 20 20 wpath))...
92d0: 28 73 3a 6c 69 0a 09 09 20 20 20 20 20 20 20 28 (s:li... (
92e0: 6c 69 73 74 20 0a 09 09 09 6c 65 76 65 6c 6e 61 list ....levelna
92f0: 6d 65 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a 68 74 me....(common:ht
9300: 72 65 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 77 70 ree->html y newp
9310: 61 74 68 20 74 69 70 66 75 6e 63 29 29 29 29 29 ath tipfunc)))))
9320: 29 0a 09 20 20 20 20 20 20 64 61 74 6c 69 73 74 ).. datlist
9330: 29 29 29 29 29 0a 0a 3b 3b 20 68 61 73 68 2d 74 )))))..;; hash-t
9340: 61 62 6c 65 20 74 72 65 65 20 74 6f 20 61 6c 69 able tree to ali
9350: 73 74 20 74 72 65 65 0a 3b 3b 0a 28 64 65 66 69 st tree.;;.(defi
9360: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 ne (common:htree
9370: 2d 3e 61 74 72 65 65 20 68 74 29 0a 20 20 28 6d ->atree ht). (m
9380: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 ap (lambda (x)..
9390: 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 0a 09 (cons (car x)..
93a0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 79 20 (let ((y
93b0: 28 63 64 72 20 78 29 29 29 0a 09 09 20 28 69 66 (cdr x)))... (if
93c0: 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 (hash-table? y)
93d0: 0a 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ... (common:
93e0: 68 74 72 65 65 2d 3e 61 74 72 65 65 20 79 29 0a htree->atree y).
93f0: 09 09 20 20 20 20 20 79 29 29 29 29 0a 20 20 20 .. y)))).
9400: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
9410: 3e 61 6c 69 73 74 20 68 74 29 29 29 0a 0a 3b 3b >alist ht)))..;;
9420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9460: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4e 20 ======.;; M U N
9470: 47 20 45 20 20 20 44 20 41 20 54 20 41 20 20 20 G E D A T A
9480: 49 20 4e 20 54 20 4f 20 20 20 4e 20 49 20 43 20 I N T O N I C
9490: 45 20 20 20 46 20 4f 20 52 20 4d 20 53 0a 3b 3b E F O R M S.;;
94a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94e0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 72 ======..;; Gener
94f0: 61 74 65 20 61 6e 20 69 6e 64 65 78 20 66 6f 72 ate an index for
9500: 20 61 20 73 70 61 72 73 65 20 6c 69 73 74 20 6f a sparse list o
9510: 66 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b 3b 20 f key values.;;
9520: 20 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 63 6f ( (rowname1 co
9530: 6c 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 6f 77 lname1 val1)(row
9540: 6e 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 20 76 name2 colname2 v
9550: 61 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e 20 al2) ).;;.;; =>
9560: 0a 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e .;;.;; ( (rown
9570: 61 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d 65 32 ame1 0)(rowname2
9580: 20 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 6e 61 1)) ;; rowna
9590: 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 20 mes -> num.;;
95a0: 20 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 28 63 (colname1 0)(c
95b0: 6f 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 20 3b olname2 1)) ) ;
95c0: 3b 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e 75 ; colnames -> nu
95d0: 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e 61 m.;; .;; optiona
95e0: 6c 20 61 70 70 6c 79 20 70 72 6f 63 20 74 6f 20 l apply proc to
95f0: 72 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 61 rownum colnum va
9600: 6c 75 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d lue.(define (com
9610: 6d 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 74 2d mon:sparse-list-
9620: 67 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 20 64 generate-index d
9630: 61 74 61 20 23 21 6b 65 79 20 28 70 72 6f 63 20 ata #!key (proc
9640: 23 66 29 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c #f)). (if (null
9650: 3f 20 64 61 74 61 29 0a 20 20 20 20 20 20 28 6c ? data). (l
9660: 69 73 74 20 27 28 29 20 27 28 29 29 0a 20 20 20 ist '() '()).
9670: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
9680: 65 64 20 28 63 61 72 20 64 61 74 61 29 29 0a 09 ed (car data))..
9690: 09 20 28 74 61 6c 20 28 63 64 72 20 64 61 74 61 . (tal (cdr data
96a0: 29 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 73 20 ))... (rownames
96b0: 27 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 6d 65 '())... (colname
96c0: 73 20 27 28 29 29 0a 09 09 20 28 72 6f 77 6e 75 s '())... (rownu
96d0: 6d 20 20 20 30 29 0a 09 09 20 28 63 6f 6c 6e 75 m 0)... (colnu
96e0: 6d 20 20 20 30 29 29 0a 09 28 6c 65 74 2a 20 28 m 0))..(let* (
96f0: 28 72 6f 77 6b 65 79 20 20 20 20 20 20 20 20 20 (rowkey
9700: 20 28 63 61 72 20 20 20 68 65 64 29 29 0a 09 20 (car hed))..
9710: 20 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 20 20 (colkey
9720: 20 20 20 20 20 20 20 28 63 61 64 72 20 20 68 65 (cadr he
9730: 64 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 6c d)).. (val
9740: 75 65 20 20 20 20 20 20 20 20 20 20 20 28 63 61 ue (ca
9750: 64 64 72 20 68 65 64 29 29 0a 09 20 20 20 20 20 ddr hed))..
9760: 20 20 28 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 (existing-rowd
9770: 61 74 20 28 61 73 73 6f 63 20 72 6f 77 6b 65 79 at (assoc rowkey
9780: 20 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 20 20 rownames))..
9790: 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d 63 6f (existing-co
97a0: 6c 64 61 74 20 28 61 73 73 6f 63 20 63 6f 6c 6b ldat (assoc colk
97b0: 65 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 20 ey colnames))..
97c0: 20 20 20 20 20 20 28 63 75 72 72 2d 72 6f 77 6e (curr-rown
97d0: 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 74 um (if exist
97e0: 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e 75 ing-rowdat rownu
97f0: 6d 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 29 29 m (+ rownum 1)))
9800: 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 63 .. (curr-c
9810: 6f 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 olnum (if ex
9820: 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 63 6f isting-coldat co
9830: 6c 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 31 lnum (+ colnum 1
9840: 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 77 ))).. (new
9850: 2d 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 69 66 -rownames (if
9860: 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 existing-rowdat
9870: 20 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e 73 20 rownames (cons
9880: 28 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 75 72 (list rowkey cur
9890: 72 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 6d r-rownum) rownam
98a0: 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e es))).. (n
98b0: 65 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 20 28 ew-colnames (
98c0: 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 if existing-cold
98d0: 61 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 6f 6e at colnames (con
98e0: 73 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 20 63 s (list colkey c
98f0: 75 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c 6e urr-colnum) coln
9900: 61 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b 20 28 ames)))).. ;; (
9910: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
9920: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
9930: 70 6f 72 74 2a 20 22 50 72 6f 63 65 73 73 69 6e port* "Processin
9940: 67 20 72 65 63 6f 72 64 3a 20 22 20 68 65 64 20 g record: " hed
9950: 29 0a 09 20 20 28 69 66 20 70 72 6f 63 20 28 70 ).. (if proc (p
9960: 72 6f 63 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 roc curr-rownum
9970: 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 6b curr-colnum rowk
9980: 65 79 20 63 6f 6c 6b 65 79 20 76 61 6c 75 65 29 ey colkey value)
9990: 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ).. (if (null?
99a0: 74 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 69 73 tal).. (lis
99b0: 74 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 6e t new-rownames n
99c0: 65 77 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 20 ew-colnames)..
99d0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
99e0: 61 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 al)... (cdr t
99f0: 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 2d 72 6f al)... new-ro
9a00: 77 6e 61 6d 65 73 0a 09 09 20 20 20 20 6e 65 77 wnames... new
9a10: 2d 63 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 20 20 -colnames...
9a20: 28 69 66 20 28 3e 20 63 75 72 72 2d 72 6f 77 6e (if (> curr-rown
9a30: 75 6d 20 72 6f 77 6e 75 6d 29 20 63 75 72 72 2d um rownum) curr-
9a40: 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a 09 rownum rownum)..
9a50: 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 72 . (if (> curr
9a60: 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 20 -colnum colnum)
9a70: 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e curr-colnum coln
9a80: 75 6d 29 0a 09 09 20 20 20 20 29 29 29 29 29 29 um)... ))))))
9a90: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
9aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 ==========.;; S
9ae0: 59 20 53 20 54 20 45 20 4d 20 20 20 53 20 54 20 Y S T E M S T
9af0: 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d U F F.;;========
9b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
9b40: 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 74 ;; lazy-safe get
9b50: 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e 20 file mod time.
9b60: 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 66 69 on any error (fi
9b70: 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 20 le not existing
9b80: 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 0a 3b etc.) return 0.;
9b90: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
9ba0: 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 n:lazy-modificat
9bb0: 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a ion-time fpath).
9bc0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
9bd0: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 30 ions. exn. 0
9be0: 0a 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 . (file-modifi
9bf0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 cation-time fpat
9c00: 68 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 h)))..;; return
9c10: 61 20 6e 69 63 65 20 63 6c 65 61 6e 20 70 61 74 a nice clean pat
9c20: 68 6e 61 6d 65 20 6d 61 64 65 20 61 62 73 6f 6c hname made absol
9c30: 75 74 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ute.(define (com
9c40: 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 64 69 mon:nice-path di
9c50: 72 29 0a 20 20 28 6c 65 74 20 28 28 6d 61 74 63 r). (let ((matc
9c60: 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 h (string-match
9c70: 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f "^(~[^\\/]*)(\\/
9c80: 2e 2a 7c 29 24 22 20 64 69 72 29 29 29 0a 20 20 .*|)$" dir))).
9c90: 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 75 (if match ;; u
9ca0: 73 69 6e 67 20 7e 20 66 6f 72 20 68 6f 6d 65 3f sing ~ for home?
9cb0: 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 ..(common:nice-p
9cc0: 61 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f ath (conc (commo
9cd0: 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 28 63 n:read-link-f (c
9ce0: 61 64 72 20 6d 61 74 63 68 29 29 20 22 2f 22 20 adr match)) "/"
9cf0: 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 0a (caddr match))).
9d00: 09 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 68 .(normalize-path
9d10: 6e 61 6d 65 20 28 69 66 20 28 61 62 73 6f 6c 75 name (if (absolu
9d20: 74 65 2d 70 61 74 68 6e 61 6d 65 3f 20 64 69 72 te-pathname? dir
9d30: 29 0a 09 09 09 09 64 69 72 0a 09 09 09 09 28 63 ).....dir.....(c
9d40: 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 64 69 72 onc (current-dir
9d50: 65 63 74 6f 72 79 29 20 22 2f 22 20 64 69 72 29 ectory) "/" dir)
9d60: 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 22 )))))..;; make "
9d70: 6e 69 63 65 2d 70 61 74 68 22 20 61 76 61 69 6c nice-path" avail
9d80: 61 62 6c 65 20 69 6e 20 63 6f 6e 66 69 67 20 66 able in config f
9d90: 69 6c 65 73 20 61 6e 64 20 74 68 65 20 72 65 70 iles and the rep
9da0: 6c 0a 28 64 65 66 69 6e 65 20 6e 69 63 65 2d 70 l.(define nice-p
9db0: 61 74 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d ath common:nice-
9dc0: 70 61 74 68 29 0a 0a 28 64 65 66 69 6e 65 20 28 path)..(define (
9dd0: 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b common:read-link
9de0: 2d 66 20 70 61 74 68 29 0a 20 20 28 68 61 6e 64 -f path). (hand
9df0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
9e00: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 28 62 exn. (b
9e10: 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 egin..(debug:pri
9e20: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
9e30: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 ult-log-port* "c
9e40: 6f 6d 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f 72 65 ommand \"/bin/re
9e50: 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 adlink -f " path
9e60: 20 22 5c 22 20 66 61 69 6c 65 64 2e 22 29 0a 09 "\" failed.")..
9e70: 70 61 74 68 29 20 3b 3b 20 6a 75 73 74 20 67 69 path) ;; just gi
9e80: 76 65 20 75 70 0a 20 20 20 20 28 77 69 74 68 2d ve up. (with-
9e90: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a input-from-pipe.
9ea0: 09 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 65 61 .(conc "/bin/rea
9eb0: 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 29 dlink -f " path)
9ec0: 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
9ed0: 29 0a 09 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 )..(read-line)))
9ee0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 ))..(define (get
9ef0: 2d 63 70 75 2d 6c 6f 61 64 20 23 21 6b 65 79 20 -cpu-load #!key
9f00: 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 (remote-host #f)
9f10: 29 0a 20 20 28 63 61 72 20 28 63 6f 6d 6d 6f 6e ). (car (common
9f20: 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 :get-cpu-load re
9f30: 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 3b 3b 20 mote-host))).;;
9f40: 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d 72 (let* ((load-r
9f50: 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d es (process:cmd-
9f60: 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 69 6d run->list "uptim
9f70: 65 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 2d e")).;; . (load-
9f80: 72 78 20 20 28 72 65 67 65 78 70 20 22 6c 6f 61 rx (regexp "loa
9f90: 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 5c d average:\\s+(\
9fa0: 5c 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 63 70 \d+)")).;; . (cp
9fb0: 75 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b 20 20 u-load #f)).;;
9fc0: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
9fd0: 6d 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 28 6c mbda (l).;; ..(l
9fe0: 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 et ((match (stri
9ff0: 6e 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 2d 72 ng-search load-r
a000: 78 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 28 69 x l))).;; .. (i
a010: 66 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 20 20 f match.;; ..
a020: 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 61 6c (let ((newval
a030: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
a040: 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 29 (cadr match))))
a050: 0a 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 6d 62 .;; ...(if (numb
a060: 65 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 09 er? newval).;; .
a070: 09 09 20 20 20 20 28 73 65 74 21 20 63 70 75 2d .. (set! cpu-
a080: 6c 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 29 29 load newval)))))
a090: 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 61 72 ).;; . (car
a0a0: 20 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b 20 20 load-res)).;;
a0b0: 20 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a 0a 3b cpu-load))..;
a0c0: 3b 20 67 65 74 20 63 70 75 20 6c 6f 61 64 20 62 ; get cpu load b
a0d0: 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 2f y reading from /
a0e0: 70 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 72 65 proc/loadavg, re
a0f0: 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 turn all three v
a100: 61 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 alues.;;.(define
a110: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 (common:get-cpu
a120: 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 -load remote-hos
a130: 74 29 0a 20 20 28 69 66 20 72 65 6d 6f 74 65 2d t). (if remote-
a140: 68 6f 73 74 0a 20 20 20 20 20 20 28 6d 61 70 20 host. (map
a150: 28 6c 61 6d 62 64 61 20 28 72 65 73 29 0a 09 20 (lambda (res)..
a160: 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a (if (eof-obj
a170: 65 63 74 3f 20 72 65 73 29 20 39 65 39 39 20 72 ect? res) 9e99 r
a180: 65 73 29 29 0a 09 20 20 20 28 77 69 74 68 2d 69 es)).. (with-i
a190: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a nput-from-pipe .
a1a0: 09 20 20 20 20 28 63 6f 6e 63 20 22 73 73 68 20 . (conc "ssh
a1b0: 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 " remote-host "
a1c0: 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 cat /proc/loadav
a1d0: 67 22 29 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 g").. (lambda
a1e0: 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 29 28 ()(list (read)(
a1f0: 72 65 61 64 29 28 72 65 61 64 29 29 29 29 29 0a read)(read))))).
a200: 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 (with-inpu
a210: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 t-from-file "/pr
a220: 6f 63 2f 6c 6f 61 64 61 76 67 22 20 0a 09 28 6c oc/loadavg" ..(l
a230: 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 28 72 ambda ()(list (r
a240: 65 61 64 29 28 72 65 61 64 29 28 72 65 61 64 29 ead)(read)(read)
a250: 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6e 6f )))))..;; get no
a260: 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f 61 rmalized cpu loa
a270: 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f d by reading fro
a280: 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 20 m /proc/loadavg
a290: 61 6e 64 20 2f 70 72 6f 63 2f 63 70 75 69 6e 66 and /proc/cpuinf
a2a0: 6f 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 o return all thr
a2b0: 65 65 20 76 61 6c 75 65 73 20 61 6e 64 20 74 68 ee values and th
a2c0: 65 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 61 6c e number of real
a2d0: 20 63 70 75 73 20 61 6e 64 20 74 68 65 20 6e 75 cpus and the nu
a2e0: 6d 62 65 72 20 6f 66 20 74 68 72 65 61 64 73 0a mber of threads.
a2f0: 3b 3b 20 72 65 74 75 72 6e 73 20 61 6c 69 73 74 ;; returns alist
a300: 20 27 28 28 61 64 6a 2d 63 70 75 2d 6c 6f 61 64 '((adj-cpu-load
a310: 20 2e 20 6e 6f 72 6d 61 6c 69 7a 65 64 2d 70 72 . normalized-pr
a320: 6f 63 2d 6c 6f 61 64 29 20 2e 2e 2e 20 65 74 63 oc-load) ... etc
a330: 2e 0a 3b 3b 20 20 6b 65 79 73 3a 20 61 64 6a 2d ..;; keys: adj-
a340: 70 72 6f 63 2d 6c 6f 61 64 2c 20 61 64 6a 2d 63 proc-load, adj-c
a350: 6f 72 65 2d 6c 6f 61 64 2c 20 31 6d 2d 6c 6f 61 ore-load, 1m-loa
a360: 64 2c 20 35 6d 2d 6c 6f 61 64 2c 20 31 35 6d 2d d, 5m-load, 15m-
a370: 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 load.;;.(define
a380: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d (common:get-norm
a390: 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 alized-cpu-load
a3a0: 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 20 28 remote-host). (
a3b0: 6c 65 74 20 28 28 64 61 74 61 20 28 69 66 20 72 let ((data (if r
a3c0: 65 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 20 20 emote-host.
a3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 69 (wi
a3e0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
a3f0: 70 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 pe .
a400: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 73 73 (conc "ss
a410: 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 h " remote-host
a420: 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 " cat /proc/load
a430: 61 76 67 3b 63 61 74 20 2f 70 72 6f 63 2f 63 70 avg;cat /proc/cp
a440: 75 69 6e 66 6f 3b 65 63 68 6f 20 65 6e 64 22 29 uinfo;echo end")
a450: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a460: 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a read-lines).
a470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a480: 20 20 28 61 70 70 65 6e 64 20 0a 20 20 20 20 20 (append .
a490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
a4a0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
a4b0: 69 6c 65 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 ile "/proc/loada
a4c0: 76 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 vg" .
a4d0: 20 20 20 20 20 20 20 20 20 20 72 65 61 64 2d 6c read-l
a4e0: 69 6e 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 ines).
a4f0: 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d 69 (with-i
a500: 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 nput-from-file "
a510: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 0a 20 /proc/cpuinfo".
a520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a530: 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a read-lines).
a540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a550: 20 20 20 28 6c 69 73 74 20 22 65 6e 64 22 29 29 (list "end"))
a560: 29 29 0a 20 20 20 20 20 20 20 20 28 6c 6f 61 64 )). (load
a570: 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 28 -rx (regexp "^(
a580: 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b [\\d\\.]+)\\s+([
a590: 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b 5c \\d\\.]+)\\s+([\
a5a0: 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e 2a 24 22 \d\\.]+)\\s+.*$"
a5b0: 29 29 0a 20 20 20 20 20 20 20 20 28 70 72 6f 63 )). (proc
a5c0: 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 70 -rx (regexp "^p
a5d0: 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 rocessor\\s+:\\s
a5e0: 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a +(\\d+)\\s*$")).
a5f0: 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d 72 78 (core-rx
a600: 20 20 28 72 65 67 65 78 70 20 22 5e 63 6f 72 65 (regexp "^core
a610: 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 id\\s+:\\s+(\\d
a620: 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 +)\\s*$")).
a630: 20 20 20 28 70 68 79 73 2d 72 78 20 20 28 72 65 (phys-rx (re
a640: 67 65 78 70 20 22 5e 70 68 79 73 69 63 61 6c 20 gexp "^physical
a650: 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b id\\s+:\\s+(\\d+
a660: 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 20 )\\s*$")).
a670: 20 20 28 6d 61 78 2d 6e 75 6d 20 20 28 6c 61 6d (max-num (lam
a680: 62 64 61 20 28 70 20 6e 29 28 6d 61 78 20 28 73 bda (p n)(max (s
a690: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 29 tring->number p)
a6a0: 20 6e 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 70 n)))). ;; (p
a6b0: 72 69 6e 74 20 22 64 61 74 61 3d 22 20 64 61 74 rint "data=" dat
a6c0: 61 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c a). (if (null
a6d0: 3f 20 64 61 74 61 29 20 3b 3b 20 73 6f 6d 65 74 ? data) ;; somet
a6e0: 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 0a hing went wrong.
a6f0: 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 #f.
a700: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
a710: 65 64 20 20 20 20 20 20 28 63 61 72 20 64 61 74 ed (car dat
a720: 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 a)).
a730: 20 20 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 (tal
a740: 20 28 63 64 72 20 64 61 74 61 29 29 0a 20 20 20 (cdr data)).
a750: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a760: 28 6c 6f 61 64 73 20 20 20 20 23 66 29 0a 20 20 (loads #f).
a770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a780: 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 20 20 3b (proc-num 0) ;
a790: 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 6e 63 6c ; processor incl
a7a0: 75 64 65 73 20 74 68 72 65 61 64 73 0a 20 20 20 udes threads.
a7b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7c0: 28 70 68 79 73 2d 6e 75 6d 20 30 29 20 20 3b 3b (phys-num 0) ;;
a7d0: 20 70 68 79 73 69 63 61 6c 20 63 68 69 70 20 6f physical chip o
a7e0: 6e 20 6d 6f 74 68 65 72 62 6f 61 72 64 0a 20 20 n motherboard.
a7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a800: 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 29 20 3b (core-num 0)) ;
a810: 3b 20 63 6f 72 65 0a 20 20 20 20 20 20 20 20 20 ; core.
a820: 20 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 20 22 ;; (print hed "
a830: 2c 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 20 70 , " loads ", " p
a840: 72 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 68 79 roc-num ", " phy
a850: 73 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 65 2d s-num ", " core-
a860: 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 20 20 28 num). (
a870: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b if (null? tal) ;
a880: 3b 20 68 61 76 65 20 61 6c 6c 20 6f 75 72 20 64 ; have all our d
a890: 61 74 61 2c 20 63 61 6c 63 75 6c 61 74 65 20 6e ata, calculate n
a8a0: 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 61 ormalized load a
a8b0: 6e 64 20 72 65 74 75 72 6e 20 72 65 73 75 6c 74 nd return result
a8c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
a8d0: 6c 65 74 2a 20 28 28 61 63 74 2d 70 72 6f 63 20 let* ((act-proc
a8e0: 28 2b 20 70 72 6f 63 2d 6e 75 6d 20 31 29 29 0a (+ proc-num 1)).
a8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a900: 20 20 20 20 20 28 61 63 74 2d 70 68 79 73 20 28 (act-phys (
a910: 2b 20 70 68 79 73 2d 6e 75 6d 20 31 29 29 0a 20 + phys-num 1)).
a920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a930: 20 20 20 20 28 61 63 74 2d 63 6f 72 65 20 28 2b (act-core (+
a940: 20 63 6f 72 65 2d 6e 75 6d 20 31 29 29 0a 20 20 core-num 1)).
a950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a960: 20 20 20 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 (adj-proc-loa
a970: 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 d (/ (car loads)
a980: 20 61 63 74 2d 70 72 6f 63 29 29 0a 20 20 20 20 act-proc)).
a990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a9a0: 20 28 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 (adj-core-load
a9b0: 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 20 61 (/ (car loads) a
a9c0: 63 74 2d 63 6f 72 65 29 29 29 0a 20 20 20 20 20 ct-core))).
a9d0: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 65 (appe
a9e0: 6e 64 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 nd (list (cons '
a9f0: 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 61 64 adj-proc-load ad
aa00: 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a 20 20 20 j-proc-load).
aa10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa20: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
aa30: 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 'adj-core-load
aa40: 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 29 29 0a adj-core-load)).
aa50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa60: 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 (list (c
aa70: 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 28 63 61 ons '1m-load (ca
aa80: 72 20 6c 6f 61 64 73 29 29 0a 20 20 20 20 20 20 r loads)).
aa90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aaa0: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 35 (cons '5
aab0: 6d 2d 6c 6f 61 64 20 28 63 61 64 72 20 6c 6f 61 m-load (cadr loa
aac0: 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ds)).
aad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aae0: 20 20 20 28 63 6f 6e 73 20 27 31 35 6d 2d 6c 6f (cons '15m-lo
aaf0: 61 64 20 28 63 61 64 64 72 20 6c 6f 61 64 73 29 ad (caddr loads)
ab00: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ab10: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
ab20: 20 28 63 6f 6e 73 20 27 70 72 6f 63 20 61 63 74 (cons 'proc act
ab30: 2d 70 72 6f 63 29 0a 20 20 20 20 20 20 20 20 20 -proc).
ab40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ab50: 20 20 20 20 20 28 63 6f 6e 73 20 27 63 6f 72 65 (cons 'core
ab60: 20 61 63 74 2d 63 6f 72 65 29 0a 20 20 20 20 20 act-core).
ab70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ab80: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 (cons '
ab90: 70 68 79 73 20 61 63 74 2d 70 68 79 73 29 29 29 phys act-phys)))
aba0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
abb0: 28 72 65 67 65 78 2d 63 61 73 65 0a 20 20 20 20 (regex-case.
abc0: 20 20 20 20 20 20 20 20 20 20 20 68 65 64 0a 20 hed.
abd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
abe0: 6f 61 64 2d 72 78 20 20 28 20 78 20 6c 31 20 6c oad-rx ( x l1 l
abf0: 35 20 6c 31 35 20 29 20 28 6c 6f 6f 70 20 28 63 5 l15 ) (loop (c
ac00: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
ac10: 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d (map string->num
ac20: 62 65 72 20 28 6c 69 73 74 20 6c 31 20 6c 35 20 ber (list l1 l5
ac30: 6c 31 35 29 29 20 70 72 6f 63 2d 6e 75 6d 20 70 l15)) proc-num p
ac40: 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d hys-num core-num
ac50: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ac60: 20 20 28 70 72 6f 63 2d 72 78 20 20 28 20 78 20 (proc-rx ( x
ac70: 70 20 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f p ) (loo
ac80: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
ac90: 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 tal) loads
aca0: 20 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 70 20 (max-num p
acb0: 70 72 6f 63 2d 6e 75 6d 29 20 70 68 79 73 2d 6e proc-num) phys-n
acc0: 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 um core-num)).
acd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 68 (ph
ace0: 79 73 2d 72 78 20 20 28 20 78 20 70 20 20 20 20 ys-rx ( x p
acf0: 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 ) (loop (ca
ad00: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
ad10: 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 20 20 loads
ad20: 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 proc-num (max-nu
ad30: 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 20 63 6f m p phys-num) co
ad40: 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 20 20 re-num)).
ad50: 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d 72 78 (core-rx
ad60: 20 20 28 20 78 20 63 20 20 20 20 20 20 20 20 20 ( x c
ad70: 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c ) (loop (car tal
ad80: 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 )(cdr tal) loads
ad90: 20 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 2d proc-
ada0: 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 28 6d 61 num phys-num (ma
adb0: 78 2d 6e 75 6d 20 63 20 63 6f 72 65 2d 6e 75 6d x-num c core-num
adc0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
add0: 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 20 20 (else .
ade0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
adf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ae00: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4e 4f ;; (print "NO
ae10: 20 4d 41 54 43 48 3a 20 22 20 68 65 64 29 0a 20 MATCH: " hed).
ae20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae30: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
ae40: 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 (cdr tal) loads
ae50: 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 proc-num phys-nu
ae60: 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 29 29 29 29 m core-num))))))
ae70: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
ae80: 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 20 68 mmon:unix-ping h
ae90: 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 ostname). (let
aea0: 28 28 72 65 73 20 28 73 79 73 74 65 6d 20 28 63 ((res (system (c
aeb0: 6f 6e 63 20 22 70 69 6e 67 20 2d 63 20 31 20 22 onc "ping -c 1 "
aec0: 20 68 6f 73 74 6e 61 6d 65 20 22 20 3e 20 2f 64 hostname " > /d
aed0: 65 76 2f 6e 75 6c 6c 22 29 29 29 29 0a 20 20 20 ev/null")))).
aee0: 20 28 65 71 3f 20 72 65 73 20 30 29 29 29 0a 0a (eq? res 0)))..
aef0: 3b 3b 20 69 64 65 61 6c 6c 79 20 70 75 74 20 61 ;; ideally put a
af00: 6c 6c 20 74 68 69 73 20 69 6e 66 6f 20 69 6e 74 ll this info int
af10: 6f 20 74 68 65 20 64 62 2c 20 6e 6f 20 6e 65 65 o the db, no nee
af20: 64 20 74 6f 20 70 72 65 73 65 72 76 65 20 69 74 d to preserve it
af30: 20 61 63 72 6f 73 73 20 6d 6f 76 69 6e 67 20 68 across moving h
af40: 6f 6d 65 68 6f 73 74 0a 3b 3b 0a 3b 3b 20 72 65 omehost.;;.;; re
af50: 74 75 72 6e 20 6c 69 73 74 20 6f 66 0a 3b 3b 20 turn list of.;;
af60: 20 28 20 72 65 61 63 68 61 62 6c 65 3f 20 63 70 ( reachable? cp
af70: 75 6c 6f 61 64 20 75 70 64 61 74 65 2d 74 69 6d uload update-tim
af80: 65 20 29 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d e ).(define (com
af90: 6d 6f 6e 3a 67 65 74 2d 68 6f 73 74 2d 69 6e 66 mon:get-host-inf
afa0: 6f 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c o hostname). (l
afb0: 65 74 2a 20 28 28 6c 6f 61 64 69 6e 66 6f 20 28 et* ((loadinfo (
afc0: 72 6d 74 3a 67 65 74 2d 6c 61 74 65 73 74 2d 68 rmt:get-latest-h
afd0: 6f 73 74 2d 6c 6f 61 64 20 68 6f 73 74 6e 61 6d ost-load hostnam
afe0: 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f e)). (lo
aff0: 61 64 20 28 63 61 72 20 6c 6f 61 64 69 6e 66 6f ad (car loadinfo
b000: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 )). (loa
b010: 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 20 28 63 d-sample-time (c
b020: 64 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a 20 20 dr loadinfo)).
b030: 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 61 6d (load-sam
b040: 70 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 72 72 ple-age (- (curr
b050: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 6f 61 ent-seconds) loa
b060: 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 29 29 0a d-sample-time)).
b070: 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 69 6e (loadin
b080: 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e fo-timeout-secon
b090: 64 73 20 32 30 29 0a 20 20 20 20 20 20 20 20 20 ds 20).
b0a0: 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 (host-last-updat
b0b0: 65 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 e-timeout-second
b0c0: 73 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 28 s 10). (
b0d0: 68 6f 73 74 2d 72 65 63 20 28 68 61 73 68 2d 74 host-rec (hash-t
b0e0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
b0f0: 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f *host-loads* ho
b100: 73 74 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 20 stname #f)).
b110: 20 20 20 20 20 29 0a 20 20 20 20 28 63 6f 6e 64 ). (cond
b120: 0a 20 20 20 20 20 28 28 3c 20 6c 6f 61 64 2d 73 . ((< load-s
b130: 61 6d 70 6c 65 2d 61 67 65 20 6c 6f 61 64 69 6e ample-age loadin
b140: 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e fo-timeout-secon
b150: 64 73 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 ds). (list
b160: 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 6c #t. l
b170: 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 0a oad-sample-time.
b180: 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f 61 64 load
b190: 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 68 6f )). ((and ho
b1a0: 73 74 2d 72 65 63 0a 20 20 20 20 20 20 20 20 20 st-rec.
b1b0: 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 65 (< (current-se
b1c0: 63 6f 6e 64 73 29 20 28 2b 20 28 68 6f 73 74 2d conds) (+ (host-
b1d0: 6c 61 73 74 2d 75 70 64 61 74 65 20 68 6f 73 74 last-update host
b1e0: 2d 72 65 63 29 20 68 6f 73 74 2d 6c 61 73 74 2d -rec) host-last-
b1f0: 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 2d 73 update-timeout-s
b200: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 econds))).
b210: 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 20 20 (list #t.
b220: 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d (host-last-
b230: 75 70 64 61 74 65 20 68 6f 73 74 2d 72 65 63 29 update host-rec)
b240: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 6f . (ho
b250: 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 64 20 st-last-cpuload
b260: 68 6f 73 74 2d 72 65 63 20 29 29 29 0a 20 20 20 host-rec ))).
b270: 20 20 28 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d ((common:unix-
b280: 70 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 0a 20 ping hostname).
b290: 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a 20 20 (list #t.
b2a0: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
b2b0: 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 20 nt-seconds).
b2c0: 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 (alist-r
b2d0: 65 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 ef 'adj-core-loa
b2e0: 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f d (common:get-no
b2f0: 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 rmalized-cpu-loa
b300: 64 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 d hostname)))).
b310: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
b320: 28 6c 69 73 74 20 23 66 20 30 20 2d 31 29 29 29 (list #f 0 -1)))
b330: 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 )). .(define
b340: 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 (common:update-h
b350: 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 20 ost-loads-table
b360: 68 6f 73 74 73 2d 72 61 77 29 0a 20 20 28 6c 65 hosts-raw). (le
b370: 74 2a 20 28 28 68 6f 73 74 73 20 28 66 69 6c 74 t* ((hosts (filt
b380: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 er (lambda (x).
b390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3a0: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
b3b0: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
b3c0: 5e 5c 5c 53 2b 24 22 29 20 78 29 29 0a 20 20 20 ^\\S+$") x)).
b3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3e0: 20 20 20 20 20 68 6f 73 74 73 2d 72 61 77 29 29 hosts-raw))
b3f0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
b400: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 6f (lambda (ho
b410: 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 stname). (
b420: 6c 65 74 2a 20 28 28 72 65 63 20 20 20 20 20 20 let* ((rec
b430: 20 28 6c 65 74 20 28 28 68 20 28 68 61 73 68 2d (let ((h (hash-
b440: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
b450: 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 t *host-loads* h
b460: 6f 73 74 6e 61 6d 65 20 23 66 29 29 29 0a 20 20 ostname #f))).
b470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b480: 20 20 20 20 20 20 20 20 28 69 66 20 68 0a 20 20 (if h.
b490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b4a0: 20 20 20 20 20 20 20 20 20 20 20 20 68 0a 20 20 h.
b4b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b4c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
b4d0: 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 29 ((h (make-host)
b4e0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b4f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b500: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
b510: 65 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a et! *host-loads*
b520: 20 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 20 20 hostname h).
b530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b540: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 29 29 h))
b550: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b560: 20 28 68 6f 73 74 2d 69 6e 66 6f 20 20 20 20 20 (host-info
b570: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
b580: 68 6f 73 74 2d 69 6e 66 6f 20 68 6f 73 74 6e 61 host-info hostna
b590: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 me)).
b5a0: 20 20 20 28 69 73 2d 72 65 61 63 68 61 62 6c 65 (is-reachable
b5b0: 20 20 20 20 20 20 28 63 61 72 20 68 6f 73 74 2d (car host-
b5c0: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
b5d0: 20 20 20 20 20 28 6c 61 73 74 2d 72 65 61 63 68 (last-reach
b5e0: 65 64 2d 74 69 6d 65 20 28 63 61 64 72 20 68 6f ed-time (cadr ho
b5f0: 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 st-info)).
b600: 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 20 20 (load
b610: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 64 64 (cadd
b620: 72 20 68 6f 73 74 2d 69 6e 66 6f 29 29 29 0a 20 r host-info))).
b630: 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d 72 65 (host-re
b640: 61 63 68 61 62 6c 65 2d 73 65 74 21 20 20 20 20 achable-set!
b650: 72 65 63 20 69 73 2d 72 65 61 63 68 61 62 6c 65 rec is-reachable
b660: 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 ). (host
b670: 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 65 74 -last-update-set
b680: 21 20 20 72 65 63 20 6c 61 73 74 2d 72 65 61 63 ! rec last-reac
b690: 68 65 64 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 hed-time).
b6a0: 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 63 70 (host-last-cp
b6b0: 75 6c 6f 61 64 2d 73 65 74 21 20 72 65 63 20 6c uload-set! rec l
b6c0: 6f 61 64 29 29 29 0a 20 20 20 20 20 68 6f 73 74 oad))). host
b6d0: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 s)))..(define (c
b6e0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 74 2d ommon:get-least-
b6f0: 6c 6f 61 64 65 64 2d 68 6f 73 74 20 68 6f 73 74 loaded-host host
b700: 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a 20 28 s-raw). (let* (
b710: 28 68 6f 73 74 73 20 28 66 69 6c 74 65 72 20 28 (hosts (filter (
b720: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x).
b730: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b740: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 (string-mat
b750: 63 68 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 53 ch (regexp "^\\S
b760: 2b 24 22 29 20 78 29 29 0a 20 20 20 20 20 20 20 +$") x)).
b770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b780: 20 68 6f 73 74 73 2d 72 61 77 29 29 0a 20 20 20 hosts-raw)).
b790: 20 20 20 20 20 20 28 62 65 73 74 2d 68 6f 73 74 (best-host
b7a0: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 28 62 #f). (b
b7b0: 65 73 74 2d 6c 6f 61 64 20 39 39 39 39 39 29 0a est-load 99999).
b7c0: 20 20 20 20 20 20 20 20 20 28 63 75 72 72 2d 74 (curr-t
b7d0: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
b7e0: 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 63 6f 6d onds))). (com
b7f0: 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 74 2d mon:update-host-
b800: 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f 73 74 loads-table host
b810: 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s). (for-each
b820: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 . (lambda (h
b830: 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 ostname).
b840: 28 6c 65 74 2a 20 28 28 72 65 63 0a 20 20 20 20 (let* ((rec.
b850: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
b860: 28 28 68 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ((h (hash-table-
b870: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 6f 73 ref/default *hos
b880: 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d t-loads* hostnam
b890: 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 e #f))).
b8a0: 20 20 20 20 20 20 20 20 20 28 69 66 20 68 0a 20 (if h.
b8b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b8c0: 20 20 20 20 68 0a 20 20 20 20 20 20 20 20 20 20 h.
b8d0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
b8e0: 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 29 29 ((h (make-host))
b8f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b900: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
b910: 61 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 74 2d able-set! *host-
b920: 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 loads* hostname
b930: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
b940: 20 20 20 20 20 20 20 20 20 20 68 29 29 29 29 0a h)))).
b950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
b960: 65 61 63 68 61 62 6c 65 20 28 68 6f 73 74 2d 72 eachable (host-r
b970: 65 61 63 68 61 62 6c 65 20 72 65 63 29 29 0a 20 eachable rec)).
b980: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f (lo
b990: 61 64 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 ad (host-la
b9a0: 73 74 2d 63 70 75 6c 6f 61 64 20 20 20 72 65 63 st-cpuload rec
b9b0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 6f ))). (co
b9c0: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 28 28 6e nd. ((n
b9d0: 6f 74 20 72 65 61 63 68 61 62 6c 65 29 20 23 66 ot reachable) #f
b9e0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 3c 20 ). ((<
b9f0: 28 2b 20 6c 6f 61 64 20 28 2f 20 28 72 61 6e 64 (+ load (/ (rand
ba00: 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 20 om 250) 1000))
ba10: 20 20 20 20 20 20 20 3b 3b 20 61 64 64 20 61 20 ;; add a
ba20: 72 61 6e 64 6f 6d 20 66 61 63 74 6f 72 20 74 6f random factor to
ba30: 20 6b 65 65 70 20 66 72 6f 6d 20 67 65 74 74 69 keep from getti
ba40: 6e 67 20 69 6e 20 61 20 72 75 74 0a 20 20 20 20 ng in a rut.
ba50: 20 20 20 20 20 20 20 20 20 20 28 2b 20 62 65 73 (+ bes
ba60: 74 2d 6c 6f 61 64 20 28 2f 20 28 72 61 6e 64 6f t-load (/ (rando
ba70: 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 20 29 m 250) 1000)) )
ba80: 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 . (set
ba90: 21 20 62 65 73 74 2d 6c 6f 61 64 20 6c 6f 61 64 ! best-load load
baa0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 ). (se
bab0: 74 21 20 62 65 73 74 2d 68 6f 73 74 20 68 6f 73 t! best-host hos
bac0: 74 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 20 tname))))).
bad0: 68 6f 73 74 73 29 0a 20 20 20 20 62 65 73 74 2d hosts). best-
bae0: 68 6f 73 74 29 29 0a 0a 0a 0a 0a 28 64 65 66 69 host)).....(defi
baf0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d ne (common:wait-
bb00: 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c for-cpuload maxl
bb10: 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 oad numcpus wait
bb20: 64 65 6c 61 79 20 23 21 6b 65 79 20 28 63 6f 75 delay #!key (cou
bb30: 6e 74 20 31 30 30 30 29 20 28 6d 73 67 20 23 66 nt 1000) (msg #f
bb40: 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 )(remote-host #f
bb50: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 )). (let* ((loa
bb60: 64 61 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 davg (common:get
bb70: 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 -cpu-load remote
bb80: 2d 68 6f 73 74 29 29 0a 09 20 28 66 69 72 73 74 -host)).. (first
bb90: 20 20 20 28 63 61 72 20 6c 6f 61 64 61 76 67 29 (car loadavg)
bba0: 29 0a 09 20 28 6e 65 78 74 20 20 20 20 28 63 61 ).. (next (ca
bbb0: 64 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 dr loadavg)).. (
bbc0: 61 64 6a 6c 6f 61 64 20 28 2a 20 6d 61 78 6c 6f adjload (* maxlo
bbd0: 61 64 20 6e 75 6d 63 70 75 73 29 29 0a 09 20 28 ad numcpus)).. (
bbe0: 6c 6f 61 64 6a 6d 70 20 28 2d 20 66 69 72 73 74 loadjmp (- first
bbf0: 20 6e 65 78 74 29 29 29 0a 20 20 20 20 28 63 6f next))). (co
bc00: 6e 64 0a 20 20 20 20 20 28 28 61 6e 64 20 28 3e nd. ((and (>
bc10: 20 66 69 72 73 74 20 61 64 6a 6c 6f 61 64 29 0a first adjload).
bc20: 09 20 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 . (> count 0))
bc30: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
bc40: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
bc50: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
bc60: 61 69 74 69 6e 67 20 22 20 77 61 69 74 64 65 6c aiting " waitdel
bc70: 61 79 20 22 20 73 65 63 6f 6e 64 73 20 64 75 65 ay " seconds due
bc80: 20 74 6f 20 6c 6f 61 64 20 22 20 66 69 72 73 74 to load " first
bc90: 20 22 20 65 78 63 65 65 64 69 6e 67 20 6d 61 78 " exceeding max
bca0: 20 6f 66 20 22 20 61 64 6a 6c 6f 61 64 20 28 69 of " adjload (i
bcb0: 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 0a 20 f msg msg "")).
bcc0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
bcd0: 65 70 21 20 77 61 69 74 64 65 6c 61 79 29 0a 20 ep! waitdelay).
bce0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 (common:wai
bcf0: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
bd00: 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 xload numcpus wa
bd10: 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 itdelay count: (
bd20: 2d 20 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 - count 1))).
bd30: 20 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 64 6a ((and (> loadj
bd40: 6d 70 20 6e 75 6d 63 70 75 73 29 0a 09 20 20 20 mp numcpus)..
bd50: 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 (> count 0)).
bd60: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
bd70: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
bd80: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 log-port* "waiti
bd90: 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 20 22 ng " waitdelay "
bda0: 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 seconds due to
bdb0: 6c 6f 61 64 20 6a 75 6d 70 20 22 20 6c 6f 61 64 load jump " load
bdc0: 6a 6d 70 20 22 20 3e 20 6e 75 6d 63 70 75 73 20 jmp " > numcpus
bdd0: 22 20 6e 75 6d 63 70 75 73 20 28 69 66 20 6d 73 " numcpus (if ms
bde0: 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 20 20 g msg "")).
bdf0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
be00: 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 20 20 waitdelay).
be10: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
be20: 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 r-cpuload maxloa
be30: 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 d numcpus waitde
be40: 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f lay count: (- co
be50: 75 6e 74 20 31 29 29 29 29 29 29 0a 0a 28 64 65 unt 1))))))..(de
be60: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
be70: 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 -num-cpus remote
be80: 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 20 28 28 -host). (let ((
be90: 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 29 0a proc (lambda ().
bea0: 09 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 ..(let loop ((nu
beb0: 6d 63 70 75 20 30 29 0a 09 09 09 20 20 20 28 69 mcpu 0).... (i
bec0: 6e 6c 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 nl (read-line
bed0: 29 29 29 0a 09 09 20 20 28 69 66 20 28 65 6f 66 )))... (if (eof
bee0: 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 09 -object? inl)...
bef0: 20 20 20 20 20 20 6e 75 6d 63 70 75 0a 09 09 20 numcpu...
bf00: 20 20 20 20 20 28 6c 6f 6f 70 20 28 69 66 20 28 (loop (if (
bf10: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 70 string-match "^p
bf20: 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 rocessor\\s+:\\s
bf30: 2b 5c 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 09 09 +\\d+$" inl)....
bf40: 09 28 2b 20 6e 75 6d 63 70 75 20 31 29 0a 09 09 .(+ numcpu 1)...
bf50: 09 09 6e 75 6d 63 70 75 29 0a 09 09 09 20 20 20 ..numcpu)....
bf60: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 (read-line)))))
bf70: 29 29 0a 20 20 20 20 28 69 66 20 72 65 6d 6f 74 )). (if remot
bf80: 65 2d 68 6f 73 74 0a 09 28 77 69 74 68 2d 69 6e e-host..(with-in
bf90: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 put-from-pipe ..
bfa0: 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 72 65 (conc "ssh " re
bfb0: 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 74 20 mote-host " cat
bfc0: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 29 0a /proc/cpuinfo").
bfd0: 09 20 70 72 6f 63 29 0a 09 28 77 69 74 68 2d 69 . proc)..(with-i
bfe0: 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 nput-from-file "
bff0: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 20 70 /proc/cpuinfo" p
c000: 72 6f 63 29 29 29 29 0a 0a 3b 3b 20 77 61 69 74 roc))))..;; wait
c010: 20 66 6f 72 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 for normalized
c020: 63 70 75 20 6c 6f 61 64 20 74 6f 20 64 72 6f 70 cpu load to drop
c030: 20 62 65 6c 6f 77 20 6d 61 78 6c 6f 61 64 0a 3b below maxload.;
c040: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
c050: 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 n:wait-for-norma
c060: 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 6c 6f lized-load maxlo
c070: 61 64 20 23 21 6b 65 79 20 28 6d 73 67 20 23 66 ad #!key (msg #f
c080: 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 )(remote-host #f
c090: 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d )). (let ((num-
c0a0: 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 cpus (common:get
c0b0: 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 -num-cpus remote
c0c0: 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 28 63 6f -host))). (co
c0d0: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 mmon:wait-for-cp
c0e0: 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 uload maxload nu
c0f0: 6d 2d 63 70 75 73 20 31 35 20 6d 73 67 3a 20 6d m-cpus 15 msg: m
c100: 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 sg)))..(define (
c110: 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 61 72 61 get-uname . para
c120: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 6e ms). (let* ((un
c130: 61 6d 65 2d 72 65 73 20 28 70 72 6f 63 65 73 73 ame-res (process
c140: 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 :cmd-run->list (
c150: 63 6f 6e 63 20 22 75 6e 61 6d 65 20 22 20 28 69 conc "uname " (i
c160: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
c170: 20 22 2d 61 22 20 28 63 61 72 20 70 61 72 61 6d "-a" (car param
c180: 73 29 29 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 s))))).. (uname
c190: 23 66 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 #f)). (if (nu
c1a0: 6c 6c 3f 20 28 63 61 72 20 75 6e 61 6d 65 2d 72 ll? (car uname-r
c1b0: 65 73 29 29 0a 09 22 75 6e 6b 6e 6f 77 6e 22 0a es)).."unknown".
c1c0: 09 28 63 61 61 72 20 75 6e 61 6d 65 2d 72 65 73 .(caar uname-res
c1d0: 29 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 72 65 61 ))))..;; for rea
c1e0: 73 6f 6e 73 20 49 20 64 6f 6e 27 74 20 75 6e 64 sons I don't und
c1f0: 65 72 73 74 61 6e 64 20 6d 75 6c 74 69 70 6c 65 erstand multiple
c200: 20 63 61 6c 6c 73 20 74 6f 20 72 65 61 6c 2d 70 calls to real-p
c210: 61 74 68 20 69 6e 20 70 61 72 61 6c 6c 65 6c 20 ath in parallel
c220: 74 68 72 65 61 64 73 0a 3b 3b 20 6d 75 73 74 20 threads.;; must
c230: 62 65 20 70 72 6f 74 65 63 74 65 64 20 62 79 20 be protected by
c240: 6d 75 74 65 78 65 73 0a 3b 3b 0a 28 64 65 66 69 mutexes.;;.(defi
c250: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d ne (common:real-
c260: 70 61 74 68 20 69 6e 70 61 74 68 29 0a 20 20 3b path inpath). ;
c270: 3b 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 ; (process:cmd-r
c280: 75 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 2d 3e un-with-stderr->
c290: 6c 69 73 74 20 22 72 65 61 64 6c 69 6e 6b 22 20 list "readlink"
c2a0: 22 2d 66 22 20 69 6e 70 61 74 68 29 29 20 3b 3b "-f" inpath)) ;;
c2b0: 20 63 6d 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 cmd . params).
c2c0: 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 ;; (let-values
c2d0: 0a 20 20 3b 3b 20 20 28 28 28 69 6e 70 20 6f 75 . ;; (((inp ou
c2e0: 70 20 70 69 64 29 20 28 70 72 6f 63 65 73 73 20 p pid) (process
c2f0: 22 72 65 61 64 6c 69 6e 6b 22 20 28 6c 69 73 74 "readlink" (list
c300: 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 29 29 "-f" inpath))))
c310: 0a 20 20 3b 3b 20 20 28 77 69 74 68 2d 69 6e 70 . ;; (with-inp
c320: 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 ut-from-port inp
c330: 0a 20 20 3b 3b 20 20 20 20 28 6c 65 74 20 6c 6f . ;; (let lo
c340: 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c op ((inl (read-l
c350: 69 6e 65 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 ine)). ;;
c360: 20 09 28 72 65 73 20 23 66 29 29 0a 20 20 3b 3b .(res #f)). ;;
c370: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 69 6e (print "in
c380: 6c 3d 22 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 l=" inl). ;;
c390: 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje
c3a0: 63 74 3f 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 ct? inl). ;;
c3b0: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
c3c0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 63 ;; (c
c3d0: 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 lose-input-port
c3e0: 69 6e 70 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 inp). ;;
c3f0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 (close-outp
c400: 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 20 3b ut-port oup). ;
c410: 3b 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ; ;;
c420: 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 69 (process-wait pi
c430: 64 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 d). ;;
c440: 20 20 20 72 65 73 29 0a 20 20 3b 3b 20 20 20 20 res). ;;
c450: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 (loop (rea
c460: 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 d-line) inl)))))
c470: 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ). (with-input-
c480: 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 from-pipe (conc
c490: 22 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 69 "readlink -f " i
c4a0: 6e 70 61 74 68 29 20 72 65 61 64 2d 6c 69 6e 65 npath) read-line
c4b0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
c4c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
c500: 44 20 49 20 53 20 4b 20 20 20 53 20 50 20 41 20 D I S K S P A
c510: 43 20 45 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d C E .;;=========
c520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
c560: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
c570: 65 74 2d 64 69 73 6b 2d 73 70 61 63 65 2d 75 73 et-disk-space-us
c580: 65 64 20 66 70 61 74 68 29 0a 20 20 28 77 69 74 ed fpath). (wit
c590: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
c5a0: 65 20 28 63 6f 6e 63 20 22 2f 75 73 72 2f 62 69 e (conc "/usr/bi
c5b0: 6e 2f 64 75 20 2d 73 20 22 20 66 70 61 74 68 29 n/du -s " fpath)
c5c0: 20 72 65 61 64 29 29 0a 0a 3b 3b 20 67 69 76 65 read))..;; give
c5d0: 6e 20 70 61 74 68 20 67 65 74 20 66 72 65 65 20 n path get free
c5e0: 73 70 61 63 65 2c 20 61 6c 6c 6f 77 73 20 6f 76 space, allows ov
c5f0: 65 72 72 69 64 65 20 69 6e 20 5b 73 65 74 75 70 erride in [setup
c600: 5d 0a 3b 3b 20 77 69 74 68 20 66 72 65 65 2d 73 ].;; with free-s
c610: 70 61 63 65 2d 73 63 72 69 70 74 20 2f 70 61 74 pace-script /pat
c620: 68 2f 74 6f 2f 73 6f 6d 65 2f 73 63 72 69 70 74 h/to/some/script
c630: 2e 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 .sh.;;.(define (
c640: 67 65 74 2d 64 66 20 70 61 74 68 29 0a 20 20 28 get-df path). (
c650: 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b if (configf:look
c660: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
c670: 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 70 61 setup" "free-spa
c680: 63 65 2d 73 63 72 69 70 74 22 29 0a 20 20 20 20 ce-script").
c690: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
c6a0: 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 20 20 20 om-pipe .
c6b0: 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 66 3a 6c (conc (configf:l
c6c0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
c6d0: 2a 20 22 73 65 74 75 70 22 20 22 66 72 65 65 2d * "setup" "free-
c6e0: 73 70 61 63 65 2d 73 63 72 69 70 74 22 29 20 22 space-script") "
c6f0: 20 22 20 70 61 74 68 29 0a 20 20 20 20 20 20 20 " path).
c700: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 (lambda ().. (le
c710: 74 20 28 28 72 65 73 20 28 72 65 61 64 2d 6c 69 t ((res (read-li
c720: 6e 65 29 29 29 0a 09 20 20 20 28 69 66 20 28 73 ne))).. (if (s
c730: 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 20 20 20 tring? res)..
c740: 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d (string->num
c750: 62 65 72 20 72 65 73 29 29 29 29 29 0a 20 20 20 ber res))))).
c760: 20 20 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 (get-unix-df
c770: 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 path)))..(define
c780: 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 (get-unix-df pa
c790: 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 66 th). (let* ((df
c7a0: 2d 72 65 73 75 6c 74 73 20 28 70 72 6f 63 65 73 -results (proces
c7b0: 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 s:cmd-run->list
c7c0: 28 63 6f 6e 63 20 22 64 66 20 22 20 70 61 74 68 (conc "df " path
c7d0: 29 29 29 0a 09 20 28 73 70 61 63 65 2d 72 78 20 ))).. (space-rx
c7e0: 20 20 28 72 65 67 65 78 70 20 22 28 5b 30 2d 39 (regexp "([0-9
c7f0: 5d 2b 29 5c 5c 73 2b 28 5b 30 2d 39 5d 2b 29 25 ]+)\\s+([0-9]+)%
c800: 22 29 29 0a 09 20 28 66 72 65 65 73 70 63 20 20 ")).. (freespc
c810: 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 28 77 #f)). ;; (w
c820: 72 69 74 65 20 64 66 2d 72 65 73 75 6c 74 73 29 rite df-results)
c830: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
c840: 6c 61 6d 62 64 61 20 28 6c 29 0a 09 09 28 6c 65 lambda (l)...(le
c850: 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
c860: 67 2d 73 65 61 72 63 68 20 73 70 61 63 65 2d 72 g-search space-r
c870: 78 20 6c 29 29 29 0a 09 09 20 20 28 69 66 20 6d x l)))... (if m
c880: 61 74 63 68 20 0a 09 09 20 20 20 20 20 20 28 6c atch ... (l
c890: 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 74 72 et ((newval (str
c8a0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 ing->number (cad
c8b0: 72 20 6d 61 74 63 68 29 29 29 29 0a 09 09 09 28 r match))))....(
c8c0: 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 if (number? newv
c8d0: 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 74 21 al).... (set!
c8e0: 20 66 72 65 65 73 70 63 20 6e 65 77 76 61 6c 29 freespc newval)
c8f0: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 63 61 ))))).. (ca
c900: 72 20 64 66 2d 72 65 73 75 6c 74 73 29 29 0a 20 r df-results)).
c910: 20 20 20 66 72 65 65 73 70 63 29 29 0a 0a 28 64 freespc))..(d
c920: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 efine (common:ch
c930: 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 72 eck-space-in-dir
c940: 20 64 69 72 70 61 74 68 20 72 65 71 75 69 72 65 dirpath require
c950: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 73 d). (let* ((dbs
c960: 70 61 63 65 20 20 28 69 66 20 28 64 69 72 65 63 pace (if (direc
c970: 74 6f 72 79 3f 20 64 69 72 70 61 74 68 29 0a 09 tory? dirpath)..
c980: 09 20 20 20 20 20 20 20 28 67 65 74 2d 64 66 20 . (get-df
c990: 64 69 72 70 61 74 68 29 0a 09 09 20 20 20 20 20 dirpath)...
c9a0: 20 20 30 29 29 29 0a 20 20 20 20 28 6c 69 73 74 0))). (list
c9b0: 20 28 3e 20 64 62 73 70 61 63 65 20 72 65 71 75 (> dbspace requ
c9c0: 69 72 65 64 29 0a 09 20 20 64 62 73 70 61 63 65 ired).. dbspace
c9d0: 0a 09 20 20 72 65 71 75 69 72 65 64 0a 09 20 20 .. required..
c9e0: 64 69 72 70 61 74 68 29 29 29 0a 0a 3b 3b 20 63 dirpath)))..;; c
c9f0: 68 65 63 6b 20 73 70 61 63 65 20 69 6e 20 64 62 heck space in db
ca00: 64 69 72 20 61 6e 64 20 69 6e 20 6d 65 67 61 74 dir and in megat
ca10: 65 73 74 20 64 69 72 0a 3b 3b 20 72 65 74 75 72 est dir.;; retur
ca20: 6e 73 3a 20 6f 6b 2f 6e 6f 74 20 64 62 73 70 61 ns: ok/not dbspa
ca30: 63 65 20 72 65 71 75 69 72 65 64 2d 73 70 61 63 ce required-spac
ca40: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f e.;;.(define (co
ca50: 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 mmon:check-db-di
ca60: 72 2d 73 70 61 63 65 29 0a 20 20 28 6c 65 74 2a r-space). (let*
ca70: 20 28 28 72 65 71 75 69 72 65 64 20 28 73 74 72 ((required (str
ca80: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 09 09 20 ing->number ...
ca90: 20 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a (or (configf:
caa0: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
cab0: 74 2a 20 22 73 65 74 75 70 22 20 22 64 62 64 69 t* "setup" "dbdi
cac0: 72 2d 73 70 61 63 65 2d 72 65 71 75 69 72 65 64 r-space-required
cad0: 22 29 0a 09 09 09 22 31 30 30 30 30 30 22 29 29 ")...."100000"))
cae0: 29 0a 09 20 28 64 62 64 69 72 20 20 20 20 28 63 ).. (dbdir (c
caf0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 ommon:get-db-tmp
cb00: 2d 61 72 65 61 29 29 20 3b 3b 20 28 64 62 3a 67 -area)) ;; (db:g
cb10: 65 74 2d 64 62 64 69 72 29 29 0a 09 20 28 74 64 et-dbdir)).. (td
cb20: 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a 63 bspace (common:c
cb30: 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 heck-space-in-di
cb40: 72 20 64 62 64 69 72 20 72 65 71 75 69 72 65 64 r dbdir required
cb50: 29 29 0a 09 20 28 6d 64 62 73 70 61 63 65 20 28 )).. (mdbspace (
cb60: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 common:check-spa
cb70: 63 65 2d 69 6e 2d 64 69 72 20 2a 74 6f 70 70 61 ce-in-dir *toppa
cb80: 74 68 2a 20 72 65 71 75 69 72 65 64 29 29 29 0a th* required))).
cb90: 20 20 20 20 28 73 6f 72 74 20 28 6c 69 73 74 20 (sort (list
cba0: 74 64 62 73 70 61 63 65 20 6d 64 62 73 70 61 63 tdbspace mdbspac
cbb0: 65 29 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 e) (lambda (a b)
cbc0: 0a 09 09 09 09 20 20 20 20 20 28 3c 20 28 63 61 ..... (< (ca
cbd0: 64 72 20 61 29 28 63 61 64 72 20 62 29 29 29 29 dr a)(cadr b))))
cbe0: 29 29 0a 20 20 20 20 0a 3b 3b 20 63 68 65 63 6b )). .;; check
cbf0: 20 61 76 61 69 6c 61 62 6c 65 20 73 70 61 63 65 available space
cc00: 20 69 6e 20 64 62 64 69 72 2c 20 65 78 69 74 20 in dbdir, exit
cc10: 69 66 20 69 6e 73 75 66 66 69 63 69 65 6e 74 0a if insufficient.
cc20: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
cc30: 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d on:check-db-dir-
cc40: 61 6e 64 2d 65 78 69 74 2d 69 66 2d 69 6e 73 75 and-exit-if-insu
cc50: 66 66 69 63 69 65 6e 74 29 0a 20 20 28 6c 65 74 fficient). (let
cc60: 2a 20 28 28 73 70 61 63 65 64 61 74 20 28 63 61 * ((spacedat (ca
cc70: 72 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d r (common:check-
cc80: 64 62 2d 64 69 72 2d 73 70 61 63 65 29 29 29 20 db-dir-space)))
cc90: 3b 3b 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 ;; look only at
cca0: 77 6f 72 73 74 20 66 6f 72 20 6e 6f 77 0a 09 20 worst for now..
ccb0: 28 69 73 2d 6f 6b 20 20 20 20 28 63 61 72 20 73 (is-ok (car s
ccc0: 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 62 73 pacedat)).. (dbs
ccd0: 70 61 63 65 20 20 28 63 61 64 72 20 73 70 61 63 pace (cadr spac
cce0: 65 64 61 74 29 29 0a 09 20 28 72 65 71 75 69 72 edat)).. (requir
ccf0: 65 64 20 28 63 61 64 64 72 20 73 70 61 63 65 64 ed (caddr spaced
cd00: 61 74 29 29 0a 09 20 28 64 62 64 69 72 20 20 20 at)).. (dbdir
cd10: 20 28 63 61 64 64 64 72 20 73 70 61 63 65 64 61 (cadddr spaceda
cd20: 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f t))). (if (no
cd30: 74 20 69 73 2d 6f 6b 29 0a 09 28 62 65 67 69 6e t is-ok)..(begin
cd40: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
cd50: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
cd60: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 73 t-log-port* "Ins
cd70: 75 66 66 69 63 69 65 6e 74 20 73 70 61 63 65 20 ufficient space
cd80: 69 6e 20 22 20 64 62 64 69 72 20 22 2c 20 72 65 in " dbdir ", re
cd90: 71 75 69 72 65 20 22 20 72 65 71 75 69 72 65 64 quire " required
cda0: 20 22 2c 20 68 61 76 65 20 22 20 64 62 73 70 61 ", have " dbspa
cdb0: 63 65 20 20 22 2c 20 65 78 69 74 69 6e 67 20 6e ce ", exiting n
cdc0: 6f 77 2e 22 29 0a 09 20 20 28 65 78 69 74 20 31 ow.").. (exit 1
cdd0: 29 29 29 29 29 0a 20 20 0a 3b 3b 20 70 61 74 68 ))))). .;; path
cde0: 73 20 69 73 20 6c 69 73 74 20 6f 66 20 6c 69 73 s is list of lis
cdf0: 74 73 20 28 28 6e 61 6d 65 20 70 61 74 68 29 20 ts ((name path)
ce00: 2e 2e 2e 20 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 ... ).;;.(define
ce10: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 (common:get-dis
ce20: 6b 2d 77 69 74 68 2d 6d 6f 73 74 2d 66 72 65 65 k-with-most-free
ce30: 2d 73 70 61 63 65 20 64 69 73 6b 73 20 6d 69 6e -space disks min
ce40: 73 69 7a 65 29 0a 20 20 28 6c 65 74 20 28 28 62 size). (let ((b
ce50: 65 73 74 20 20 20 20 20 23 66 29 0a 09 28 62 65 est #f)..(be
ce60: 73 74 73 69 7a 65 20 30 29 29 0a 20 20 20 20 28 stsize 0)). (
ce70: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
ce80: 6c 61 6d 62 64 61 20 28 64 69 73 6b 2d 6e 75 6d lambda (disk-num
ce90: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
cea0: 28 64 69 72 70 61 74 68 20 20 20 20 28 63 61 64 (dirpath (cad
ceb0: 72 20 28 61 73 73 6f 63 20 64 69 73 6b 2d 6e 75 r (assoc disk-nu
cec0: 6d 20 64 69 73 6b 73 29 29 29 0a 09 20 20 20 20 m disks)))..
ced0: 20 20 28 66 72 65 65 73 70 63 20 20 20 20 28 63 (freespc (c
cee0: 6f 6e 64 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 ond.... ((not
cef0: 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 72 70 (directory? dirp
cf00: 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 66 ath)).... (if
cf10: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
cf20: 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 se-print 300 "di
cf30: 73 6b 73 20 6e 6f 74 20 61 20 64 69 72 20 22 20 sks not a dir "
cf40: 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 disk-num).....(d
cf50: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
cf60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
cf70: 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 "WARNING: disk "
cf80: 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 disk-num " at p
cf90: 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 ath \"" dirpath
cfa0: 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 64 69 72 "\" is not a dir
cfb0: 65 63 74 6f 72 79 20 2d 20 69 67 6e 6f 72 69 6e ectory - ignorin
cfc0: 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 20 g it."))....
cfd0: 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 -1).... ((not
cfe0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
cff0: 73 73 3f 20 64 69 72 70 61 74 68 29 29 0a 09 09 ss? dirpath))...
d000: 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
d010: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
d020: 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 300 "disks not
d030: 77 72 69 74 65 61 62 6c 65 20 22 20 64 69 73 6b writeable " disk
d040: 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 75 67 -num).....(debug
d050: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
d060: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
d070: 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 73 NING: disk " dis
d080: 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 68 20 k-num " at path
d090: 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c 22 20 \"" dirpath "\"
d0a0: 69 73 20 6e 6f 74 20 77 72 69 74 65 61 62 6c 65 is not writeable
d0b0: 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 - ignoring it."
d0c0: 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 )).... -1)...
d0d0: 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 28 . ((not (eq? (
d0e0: 73 74 72 69 6e 67 2d 72 65 66 20 64 69 72 70 61 string-ref dirpa
d0f0: 74 68 20 30 29 20 23 5c 2f 29 29 0a 09 09 09 20 th 0) #\/))....
d100: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c (if (common:l
d110: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 ow-noise-print 3
d120: 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 61 20 00 "disks not a
d130: 70 72 6f 70 65 72 20 70 61 74 68 20 22 20 64 69 proper path " di
d140: 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 sk-num).....(deb
d150: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
d160: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
d170: 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 ARNING: disk " d
d180: 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 isk-num " at pat
d190: 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c h \"" dirpath "\
d1a0: 22 20 69 73 20 6e 6f 74 20 61 20 66 75 6c 6c 79 " is not a fully
d1b0: 20 71 75 61 6c 69 66 69 65 64 20 70 61 74 68 20 qualified path
d1c0: 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 - ignoring it.")
d1d0: 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 ).... -1)....
d1e0: 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 20 (else....
d1f0: 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 29 (get-df dirpath)
d200: 29 29 29 29 0a 09 20 28 69 66 20 28 3e 20 66 72 )))).. (if (> fr
d210: 65 65 73 70 63 20 62 65 73 74 73 69 7a 65 29 0a eespc bestsize).
d220: 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 . (begin..
d230: 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 20 (set! best
d240: 20 20 20 20 28 63 6f 6e 73 20 64 69 73 6b 2d 6e (cons disk-n
d250: 75 6d 20 64 69 72 70 61 74 68 29 29 0a 09 20 20 um dirpath))..
d260: 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 73 (set! bests
d270: 69 7a 65 20 66 72 65 65 73 70 63 29 29 29 29 29 ize freespc)))))
d280: 0a 20 20 20 20 20 28 6d 61 70 20 63 61 72 20 64 . (map car d
d290: 69 73 6b 73 29 29 0a 20 20 20 20 28 69 66 20 28 isks)). (if (
d2a0: 61 6e 64 20 62 65 73 74 20 28 3e 20 62 65 73 74 and best (> best
d2b0: 73 69 7a 65 20 6d 69 6e 73 69 7a 65 29 29 0a 09 size minsize))..
d2c0: 62 65 73 74 0a 09 23 66 29 29 29 20 3b 3b 20 23 best..#f))) ;; #
d2d0: 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 73 6b 20 f means no disk
d2e0: 63 61 6e 64 69 64 61 74 65 20 66 6f 75 6e 64 0a candidate found.
d2f0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
d300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 4e =========.;; E N
d340: 20 56 20 49 20 52 20 4f 20 4e 20 4d 20 45 20 4e V I R O N M E N
d350: 20 54 20 20 20 56 20 41 20 52 20 53 0a 3b 3b 3d T V A R S.;;=
d360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d3a0: 3d 3d 3d 3d 3d 0a 09 20 20 20 20 20 20 0a 28 64 =====.. .(d
d3b0: 65 66 69 6e 65 20 28 73 61 76 65 2d 65 6e 76 69 efine (save-envi
d3c0: 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 73 ronment-as-files
d3d0: 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 69 67 fname #!key (ig
d3e0: 6e 6f 72 65 76 61 72 73 20 28 6c 69 73 74 20 22 norevars (list "
d3f0: 55 53 45 52 22 20 22 48 4f 4d 45 22 20 22 44 49 USER" "HOME" "DI
d400: 53 50 4c 41 59 22 20 22 4c 53 5f 43 4f 4c 4f 52 SPLAY" "LS_COLOR
d410: 53 22 20 22 58 4b 45 59 53 59 4d 44 42 22 20 22 S" "XKEYSYMDB" "
d420: 45 44 49 54 4f 52 22 20 22 4d 41 4b 45 46 4c 41 EDITOR" "MAKEFLA
d430: 47 53 22 20 22 4d 41 4b 45 46 22 20 22 4d 41 4b GS" "MAKEF" "MAK
d440: 45 4f 56 45 52 52 49 44 45 53 22 29 29 29 0a 20 EOVERRIDES"))).
d450: 20 28 6c 65 74 20 28 28 65 6e 76 76 61 72 73 20 (let ((envvars
d460: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
d470: 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 20 -variables)).
d480: 20 20 20 20 20 28 77 68 69 74 65 73 70 20 28 72 (whitesp (r
d490: 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 egexp "[^a-zA-Z0
d4a0: 2d 39 5f 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 24 5d 22 -9_\\-:,.\\/%$]"
d4b0: 29 29 0a 09 28 6d 75 6e 67 65 76 61 6c 20 28 6c ))..(mungeval (l
d4c0: 61 6d 62 64 61 20 28 76 61 6c 29 0a 09 09 20 20 ambda (val)...
d4d0: 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 28 (cond... (
d4e0: 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 22 29 (eq? val #t) "")
d4f0: 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 74 20 74 ;; convert #t t
d500: 6f 20 65 6d 70 74 79 20 73 74 72 69 6e 67 0a 09 o empty string..
d510: 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 6c 20 . ((eq? val
d520: 23 66 29 20 23 66 29 20 3b 3b 20 63 6f 6e 76 65 #f) #f) ;; conve
d530: 72 74 20 23 66 20 74 6f 20 69 74 73 65 6c 66 20 rt #f to itself
d540: 28 73 74 69 6c 6c 20 74 68 69 6e 6b 69 6e 67 20 (still thinking
d550: 61 62 6f 75 74 20 74 68 69 73 20 6f 6e 65 0a 09 about this one..
d560: 09 20 20 20 20 20 28 65 6c 73 65 20 76 61 6c 29 . (else val)
d570: 29 29 29 29 0a 20 20 20 20 20 28 77 69 74 68 2d )))). (with-
d580: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 output-to-file (
d590: 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 73 68 conc fname ".csh
d5a0: 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 "). (lambd
d5b0: 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 28 a (). (
d5c0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
d5d0: 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 20 20 (keyval)...
d5e0: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 (let* ((key
d5f0: 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 (car keyval))...
d600: 09 20 20 20 20 20 28 76 61 6c 20 20 20 28 63 64 . (val (cd
d610: 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 r keyval))....
d620: 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 28 73 (delim (if (s
d630: 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 tring-search whi
d640: 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 09 09 tesp val) ......
d650: 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 29 0a "\""......""))).
d660: 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 28 6d ...(print (if (m
d670: 65 6d 62 65 72 20 6b 65 79 20 69 67 6e 6f 72 65 ember key ignore
d680: 76 61 72 73 29 0a 09 09 09 09 20 20 20 22 23 20 vars)..... "#
d690: 73 65 74 65 6e 76 20 22 0a 09 09 09 09 20 20 20 setenv ".....
d6a0: 22 73 65 74 65 6e 76 20 22 29 0a 09 09 09 20 20 "setenv ")....
d6b0: 20 20 20 20 20 6b 65 79 20 22 20 22 20 64 65 6c key " " del
d6c0: 69 6d 20 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c im (mungeval val
d6d0: 29 20 64 65 6c 69 6d 29 29 29 0a 09 09 20 20 20 ) delim)))...
d6e0: 20 65 6e 76 76 61 72 73 29 29 29 0a 20 20 20 20 envvars))).
d6f0: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
d700: 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e 61 6d -file (conc fnam
d710: 65 20 22 2e 73 68 22 29 0a 20 20 20 20 20 20 20 e ".sh").
d720: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
d730: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
d740: 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 0a lambda (keyval).
d750: 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
d760: 6b 65 79 20 28 63 61 72 20 6b 65 79 76 61 6c 29 key (car keyval)
d770: 29 0a 09 09 09 20 20 20 20 20 28 76 61 6c 20 28 ).... (val (
d780: 63 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 cdr keyval))....
d790: 20 20 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 (delim (if
d7a0: 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 (string-search w
d7b0: 68 69 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 hitesp val) ....
d7c0: 09 09 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 .."\""......""))
d7d0: 29 0a 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 )....(print (if
d7e0: 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 6e 6f (member key igno
d7f0: 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 20 22 revars)..... "
d800: 23 20 65 78 70 6f 72 74 20 22 0a 09 09 09 09 20 # export ".....
d810: 20 20 22 65 78 70 6f 72 74 20 22 29 0a 09 09 09 "export ")....
d820: 20 20 20 20 20 20 20 6b 65 79 20 22 3d 22 20 64 key "=" d
d830: 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c 20 76 elim (mungeval v
d840: 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a 20 20 20 al) delim))).
d850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d860: 20 65 6e 76 76 61 72 73 29 29 29 29 29 0a 0a 3b envvars)))))..;
d870: 3b 20 73 65 74 20 73 6f 6d 65 20 65 6e 76 20 76 ; set some env v
d880: 61 72 73 20 66 72 6f 6d 20 61 6e 20 61 6c 69 73 ars from an alis
d890: 74 2c 20 72 65 74 75 72 6e 20 61 6e 20 61 6c 69 t, return an ali
d8a0: 73 74 20 77 69 74 68 20 6f 72 69 67 69 6e 61 6c st with original
d8b0: 20 76 61 6c 75 65 73 0a 3b 3b 20 28 28 22 56 41 values.;; (("VA
d8c0: 52 22 20 22 76 61 6c 75 65 22 29 20 2e 2e 2e 29 R" "value") ...)
d8d0: 0a 28 64 65 66 69 6e 65 20 28 61 6c 69 73 74 2d .(define (alist-
d8e0: 3e 65 6e 76 2d 76 61 72 73 20 6c 73 74 29 0a 20 >env-vars lst).
d8f0: 20 28 69 66 20 28 6c 69 73 74 3f 20 6c 73 74 29 (if (list? lst)
d900: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
d910: 73 20 27 28 29 29 29 0a 09 28 66 6f 72 2d 65 61 s '()))..(for-ea
d920: 63 68 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 ch (lambda (p)..
d930: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 76 61 72 . (let* ((var
d940: 20 28 63 61 72 20 20 70 29 29 0a 09 09 09 20 20 (car p))....
d950: 20 28 76 61 6c 20 28 63 61 64 72 20 70 29 29 0a (val (cadr p)).
d960: 09 09 09 20 20 20 28 70 72 76 20 28 67 65 74 2d ... (prv (get-
d970: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
d980: 61 62 6c 65 20 76 61 72 29 29 29 0a 09 09 20 20 able var)))...
d990: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 63 (set! res (c
d9a0: 6f 6e 73 20 28 6c 69 73 74 20 76 61 72 20 70 72 ons (list var pr
d9b0: 76 29 20 72 65 73 29 29 0a 09 09 20 20 20 20 20 v) res))...
d9c0: 20 28 69 66 20 76 61 6c 20 0a 09 09 09 20 20 28 (if val .... (
d9d0: 73 65 74 65 6e 76 20 76 61 72 20 28 2d 3e 73 74 setenv var (->st
d9e0: 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 ring val))....
d9f0: 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 29 (unsetenv var)))
da00: 29 0a 09 09 20 20 6c 73 74 29 0a 09 72 65 73 29 )... lst)..res)
da10: 0a 20 20 20 20 20 20 27 28 29 29 29 0a 0a 3b 3b . '()))..;;
da20: 20 63 6c 65 61 72 20 76 61 72 73 20 6d 61 74 63 clear vars matc
da30: 68 69 6e 67 20 70 61 74 74 65 72 6e 2c 20 72 75 hing pattern, ru
da40: 6e 20 70 72 6f 63 2c 20 73 65 74 20 76 61 72 73 n proc, set vars
da50: 20 62 61 63 6b 0a 3b 3b 20 69 66 20 70 72 6f 63 back.;; if proc
da60: 20 69 73 20 61 20 73 74 72 69 6e 67 20 72 75 6e is a string run
da70: 20 74 68 61 74 20 73 74 72 69 6e 67 20 61 73 20 that string as
da80: 61 20 63 6f 6d 6d 61 6e 64 20 77 69 74 68 0a 3b a command with.;
da90: 3b 20 73 79 73 74 65 6d 2e 0a 3b 3b 0a 28 64 65 ; system..;;.(de
daa0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 fine (common:wit
dab0: 68 6f 75 74 2d 76 61 72 73 20 70 72 6f 63 20 2e hout-vars proc .
dac0: 20 76 61 72 2d 70 61 74 74 73 29 0a 20 20 28 6c var-patts). (l
dad0: 65 74 20 28 28 76 61 72 73 20 28 6d 61 6b 65 2d et ((vars (make-
dae0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
daf0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
db00: 20 28 6c 61 6d 62 64 61 20 28 76 61 72 64 61 74 (lambda (vardat
db10: 29 20 3b 3b 20 65 61 63 68 20 65 6e 76 20 76 61 ) ;; each env va
db20: 72 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 r. (for-ea
db30: 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 76 61 72 ch..(lambda (var
db40: 2d 70 61 74 74 29 0a 09 20 20 28 69 66 20 28 73 -patt).. (if (s
db50: 74 72 69 6e 67 2d 6d 61 74 63 68 20 76 61 72 2d tring-match var-
db60: 70 61 74 74 20 28 63 61 72 20 76 61 72 64 61 74 patt (car vardat
db70: 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 )).. (let (
db80: 28 76 61 72 20 28 63 61 72 20 76 61 72 64 61 74 (var (car vardat
db90: 29 29 0a 09 09 20 20 20 20 28 76 61 6c 20 28 63 ))... (val (c
dba0: 64 72 20 76 61 72 64 61 74 29 29 29 0a 09 09 28 dr vardat)))...(
dbb0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
dbc0: 76 61 72 73 20 76 61 72 20 76 61 6c 29 0a 09 09 vars var val)...
dbd0: 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 29 (unsetenv var)))
dbe0: 29 0a 09 76 61 72 2d 70 61 74 74 73 29 29 0a 20 )..var-patts)).
dbf0: 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (get-environ
dc00: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 ment-variables))
dc10: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
dc20: 28 28 73 74 72 69 6e 67 3f 20 70 72 6f 63 29 28 ((string? proc)(
dc30: 73 79 73 74 65 6d 20 70 72 6f 63 29 29 0a 20 20 system proc)).
dc40: 20 20 20 28 70 72 6f 63 20 20 20 20 20 20 20 20 (proc
dc50: 20 20 28 70 72 6f 63 29 29 29 0a 20 20 20 20 28 (proc))). (
dc60: 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 hash-table-for-e
dc70: 61 63 68 0a 20 20 20 20 20 76 61 72 73 0a 20 20 ach. vars.
dc80: 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 20 (lambda (var
dc90: 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 val). (set
dca0: 65 6e 76 20 76 61 72 20 76 61 6c 29 29 29 0a 20 env var val))).
dcb0: 20 20 20 76 61 72 73 29 29 0a 0a 28 64 65 66 69 vars))..(defi
dcc0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 61 ne (common:run-a
dcd0: 2d 63 6f 6d 6d 61 6e 64 20 63 6d 64 20 23 21 6b -command cmd #!k
dce0: 65 79 20 28 77 69 74 68 2d 76 61 72 73 20 23 66 ey (with-vars #f
dcf0: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 72 65 )). (let* ((pre
dd00: 2d 63 6d 64 20 20 28 64 74 65 73 74 73 3a 67 65 -cmd (dtests:ge
dd10: 74 2d 70 72 65 2d 63 6f 6d 6d 61 6e 64 29 29 0a t-pre-command)).
dd20: 20 20 20 20 20 20 20 20 20 28 70 6f 73 74 2d 63 (post-c
dd30: 6d 64 20 28 64 74 65 73 74 73 3a 67 65 74 2d 70 md (dtests:get-p
dd40: 6f 73 74 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 ost-command)).
dd50: 20 20 20 20 20 20 20 28 66 75 6c 6c 63 6d 64 20 (fullcmd
dd60: 20 28 69 66 20 28 6f 72 20 70 72 65 2d 63 6d 64 (if (or pre-cmd
dd70: 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 20 20 post-cmd).
dd80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd90: 20 20 28 63 6f 6e 63 20 70 72 65 2d 63 6d 64 20 (conc pre-cmd
dda0: 63 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 cmd post-cmd).
ddb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ddc0: 20 20 20 20 20 28 63 6f 6e 63 20 22 76 69 65 77 (conc "view
ddd0: 73 63 72 65 65 6e 20 22 20 63 6d 64 29 29 29 29 screen " cmd))))
dde0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
ddf0: 74 2d 69 6e 66 6f 20 30 32 20 2a 64 65 66 61 75 t-info 02 *defau
de00: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 75 lt-log-port* "Ru
de10: 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 3a 20 22 nning command: "
de20: 20 66 75 6c 6c 63 6d 64 29 0a 20 20 20 20 28 69 fullcmd). (i
de30: 66 20 77 69 74 68 2d 76 61 72 73 0a 20 20 20 20 f with-vars.
de40: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 (common:with
de50: 6f 75 74 2d 76 61 72 73 20 63 6d 64 29 0a 20 20 out-vars cmd).
de60: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 (common:wi
de70: 74 68 6f 75 74 2d 76 61 72 73 20 66 75 6c 6c 63 thout-vars fullc
de80: 6d 64 20 22 4d 54 5f 2e 2a 22 29 29 29 29 0a 09 md "MT_.*"))))..
de90: 09 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d . .;;==========
dea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
deb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ded0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
dee0: 54 20 49 20 4d 20 45 20 20 20 41 20 4e 20 44 20 T I M E A N D
def0: 20 20 44 20 41 20 54 20 45 0a 3b 3b 3d 3d 3d 3d D A T E.;;====
df00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
df10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
df20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
df30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
df40: 3d 3d 0a 0a 3b 3b 20 43 6f 6e 76 65 72 74 20 73 ==..;; Convert s
df50: 74 72 69 6e 67 73 20 6c 69 6b 65 20 22 35 73 20 trings like "5s
df60: 32 68 20 33 6d 22 20 3d 3e 20 36 30 78 36 30 78 2h 3m" => 60x60x
df70: 32 20 2b 20 33 78 36 30 20 2b 20 35 0a 28 64 65 2 + 3x60 + 5.(de
df80: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 fine (common:hms
df90: 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 -string->seconds
dfa0: 20 74 73 74 72 29 0a 20 20 28 6c 65 74 20 28 28 tstr). (let ((
dfb0: 70 61 72 74 73 20 20 20 20 20 28 73 74 72 69 6e parts (strin
dfc0: 67 2d 73 70 6c 69 74 20 74 73 74 72 29 29 0a 09 g-split tstr))..
dfd0: 28 74 69 6d 65 2d 73 65 63 73 20 30 29 0a 09 3b (time-secs 0)..;
dfe0: 3b 20 73 3d 73 65 63 6f 6e 64 73 2c 20 6d 3d 6d ; s=seconds, m=m
dff0: 69 6e 75 74 65 73 2c 20 68 3d 68 6f 75 72 73 2c inutes, h=hours,
e000: 20 64 3d 64 61 79 73 0a 09 28 74 72 78 20 20 20 d=days..(trx
e010: 20 20 20 20 28 72 65 67 65 78 70 20 22 28 5c 5c (regexp "(\\
e020: 64 2b 29 28 5b 73 6d 68 64 5d 29 22 29 29 29 0a d+)([smhd])"))).
e030: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
e040: 61 6d 62 64 61 20 28 70 61 72 74 29 0a 09 09 28 ambda (part)...(
e050: 6c 65 74 20 28 28 6d 61 74 63 68 20 20 28 73 74 let ((match (st
e060: 72 69 6e 67 2d 6d 61 74 63 68 20 74 72 78 20 70 ring-match trx p
e070: 61 72 74 29 29 29 0a 09 09 20 20 28 69 66 20 6d art)))... (if m
e080: 61 74 63 68 0a 09 09 20 20 20 20 20 20 28 6c 65 atch... (le
e090: 74 20 28 28 76 61 6c 20 28 73 74 72 69 6e 67 2d t ((val (string-
e0a0: 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d 61 >number (cadr ma
e0b0: 74 63 68 29 29 29 0a 09 09 09 20 20 20 20 28 75 tch))).... (u
e0c0: 6e 74 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 nt (caddr match)
e0d0: 29 29 0a 09 09 09 28 69 66 20 76 61 6c 20 0a 09 ))....(if val ..
e0e0: 09 09 20 20 20 20 28 73 65 74 21 20 74 69 6d 65 .. (set! time
e0f0: 2d 73 65 63 73 20 28 2b 20 74 69 6d 65 2d 73 65 -secs (+ time-se
e100: 63 73 20 28 2a 20 76 61 6c 0a 09 09 09 09 09 09 cs (* val.......
e110: 09 20 20 20 20 28 63 61 73 65 20 28 73 74 72 69 . (case (stri
e120: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 75 6e 74 29 0a ng->symbol unt).
e130: 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 73 ....... ((s
e140: 29 20 31 29 0a 09 09 09 09 09 09 09 20 20 20 20 ) 1)........
e150: 20 20 28 28 6d 29 20 36 30 29 0a 09 09 09 09 09 ((m) 60)......
e160: 09 09 20 20 20 20 20 20 28 28 68 29 20 28 2a 20 .. ((h) (*
e170: 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 20 60 60))........
e180: 20 20 20 20 20 28 28 64 29 20 28 2a 20 32 34 20 ((d) (* 24
e190: 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 20 60 60))........
e1a0: 20 20 20 20 20 28 65 6c 73 65 20 30 29 29 29 29 (else 0))))
e1b0: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 70 61 )))))).. pa
e1c0: 72 74 73 29 0a 20 20 20 20 74 69 6d 65 2d 73 65 rts). time-se
e1d0: 63 73 29 29 0a 09 09 20 20 20 20 20 20 20 0a 28 cs))... .(
e1e0: 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d define (seconds-
e1f0: 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 63 73 >hr-min-sec secs
e200: 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 73 20 ). (let* ((hrs
e210: 28 71 75 6f 74 69 65 6e 74 20 73 65 63 73 20 33 (quotient secs 3
e220: 36 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 71 75 600)).. (min (qu
e230: 6f 74 69 65 6e 74 20 28 2d 20 73 65 63 73 20 28 otient (- secs (
e240: 2a 20 68 72 73 20 33 36 30 30 29 29 20 36 30 29 * hrs 3600)) 60)
e250: 29 0a 09 20 28 73 65 63 20 28 2d 20 73 65 63 73 ).. (sec (- secs
e260: 20 28 2a 20 68 72 73 20 33 36 30 30 29 28 2a 20 (* hrs 3600)(*
e270: 6d 69 6e 20 36 30 29 29 29 29 0a 20 20 20 20 28 min 60)))). (
e280: 63 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 73 20 conc (if (> hrs
e290: 30 29 28 63 6f 6e 63 20 68 72 73 20 22 68 72 20 0)(conc hrs "hr
e2a0: 22 29 20 22 22 29 0a 09 20 20 28 69 66 20 28 3e ") "").. (if (>
e2b0: 20 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d 69 6e min 0)(conc min
e2c0: 20 22 6d 20 22 29 20 20 22 22 29 0a 09 20 20 73 "m ") "").. s
e2d0: 65 63 20 22 73 22 29 29 29 0a 0a 28 64 65 66 69 ec "s")))..(defi
e2e0: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d ne (seconds->tim
e2f0: 65 2d 73 74 72 69 6e 67 20 73 65 63 29 0a 20 20 e-string sec).
e300: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 20 (time->string .
e310: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
e320: 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 48 3a l-time sec) "%H:
e330: 25 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 69 6e %M:%S"))..(defin
e340: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b e (seconds->work
e350: 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 -week/day-time s
e360: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
e370: 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ing. (seconds-
e380: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
e390: 20 22 77 77 25 56 2e 25 75 20 25 48 3a 25 4d 22 "ww%V.%u %H:%M"
e3a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ))..(define (sec
e3b0: 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f onds->work-week/
e3c0: 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d 65 day sec). (time
e3d0: 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 ->string. (sec
e3e0: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
e3f0: 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 22 29 sec) "ww%V.%u")
e400: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
e410: 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 nds->year-work-w
e420: 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 28 eek/day sec). (
e430: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 time->string.
e440: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
e450: 74 69 6d 65 20 73 65 63 29 20 22 25 79 77 77 25 time sec) "%yww%
e460: 56 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 6e 65 V.%w"))..(define
e470: 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d (seconds->year-
e480: 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 work-week/day-ti
e490: 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d me sec). (time-
e4a0: 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f >string. (seco
e4b0: 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 nds->local-time
e4c0: 73 65 63 29 20 22 25 59 77 77 25 56 2e 25 77 20 sec) "%Yww%V.%w
e4d0: 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 69 6e %H:%M"))..(defin
e4e0: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 e (seconds->year
e4f0: 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 -week/day-time s
e500: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
e510: 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ing. (seconds-
e520: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
e530: 20 22 25 59 77 25 56 2e 25 77 20 25 48 3a 25 4d "%Yw%V.%w %H:%M
e540: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
e550: 63 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 20 73 conds->quarter s
e560: 65 63 29 0a 20 20 28 63 61 73 65 20 28 73 74 72 ec). (case (str
e570: 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 28 74 ing->number.. (t
e580: 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 09 20 20 ime->string ..
e590: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
e5a0: 74 69 6d 65 20 73 65 63 29 0a 09 20 20 22 25 6d time sec).. "%m
e5b0: 22 29 29 0a 20 20 20 20 28 28 31 20 32 20 33 29 ")). ((1 2 3)
e5c0: 20 31 29 0a 20 20 20 20 28 28 34 20 35 20 36 29 1). ((4 5 6)
e5d0: 20 32 29 0a 20 20 20 20 28 28 37 20 38 20 39 29 2). ((7 8 9)
e5e0: 20 33 29 0a 20 20 20 20 28 28 31 30 20 31 31 20 3). ((10 11
e5f0: 31 32 29 20 34 29 0a 20 20 20 20 28 65 6c 73 65 12) 4). (else
e600: 20 23 66 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e #f)))..;; given
e610: 20 73 70 61 6e 20 6f 66 20 73 65 63 6f 6e 64 73 span of seconds
e620: 20 74 73 74 61 72 74 20 74 6f 20 74 65 6e 64 0a tstart to tend.
e630: 3b 3b 20 66 69 6e 64 20 73 74 61 72 74 20 74 69 ;; find start ti
e640: 6d 65 20 74 6f 20 6d 61 72 6b 20 61 6e 64 20 6d me to mark and m
e650: 61 72 6b 20 64 65 6c 74 61 0a 3b 3b 0a 28 64 65 ark delta.;;.(de
e660: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6e fine (common:fin
e670: 64 2d 73 74 61 72 74 2d 6d 61 72 6b 2d 61 6e 64 d-start-mark-and
e680: 2d 6d 61 72 6b 2d 64 65 6c 74 61 20 74 73 74 61 -mark-delta tsta
e690: 72 74 20 74 65 6e 64 29 0a 20 20 28 6c 65 74 2a rt tend). (let*
e6a0: 20 28 28 64 65 6c 74 61 74 20 20 20 28 2d 20 28 ((deltat (- (
e6b0: 6d 61 78 20 74 65 6e 64 20 28 2b 20 74 65 6e 64 max tend (+ tend
e6c0: 20 31 30 29 29 20 74 73 74 61 72 74 29 29 20 3b 10)) tstart)) ;
e6d0: 3b 20 63 61 6e 27 74 20 68 61 6e 64 6c 65 20 72 ; can't handle r
e6e0: 75 6e 73 20 6f 66 20 6c 65 73 73 20 74 68 61 6e uns of less than
e6f0: 20 34 20 73 65 63 6f 6e 64 73 2e 20 50 61 64 20 4 seconds. Pad
e700: 69 74 20 74 6f 20 31 30 20 73 65 63 6f 6e 64 73 it to 10 seconds
e710: 20 2e 2e 2e 0a 09 20 28 72 65 73 75 6c 74 20 20 ..... (result
e720: 20 23 66 29 0a 09 20 28 6d 69 6e 20 20 20 20 20 #f).. (min
e730: 20 36 30 29 0a 09 20 28 68 72 20 20 20 20 20 20 60).. (hr
e740: 20 28 2a 20 36 30 20 36 30 29 29 0a 09 20 28 64 (* 60 60)).. (d
e750: 61 79 20 20 20 20 20 20 28 2a 20 32 34 20 68 72 ay (* 24 hr
e760: 29 29 0a 09 20 28 79 72 20 20 20 20 20 20 20 28 )).. (yr (
e770: 2a 20 33 36 35 20 64 61 79 29 29 20 3b 3b 20 79 * 365 day)) ;; y
e780: 65 61 72 0a 09 20 28 6d 6f 20 20 20 20 20 20 20 ear.. (mo
e790: 28 2f 20 79 72 20 31 32 29 29 0a 09 20 28 77 6b (/ yr 12)).. (wk
e7a0: 20 20 20 20 20 20 20 28 2a 20 64 61 79 20 37 29 (* day 7)
e7b0: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
e7c0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6d . (lambda (m
e7d0: 61 78 2d 62 6c 6b 73 29 0a 20 20 20 20 20 20 20 ax-blks).
e7e0: 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 6d 62 (for-each..(lamb
e7f0: 64 61 20 28 73 70 61 6e 29 20 3b 3b 20 35 20 32 da (span) ;; 5 2
e800: 20 31 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 72 1.. (if (not r
e810: 65 73 75 6c 74 29 0a 09 20 20 20 20 20 20 28 66 esult).. (f
e820: 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 20 or-each ..
e830: 20 28 6c 61 6d 62 64 61 20 28 74 69 6d 65 75 6e (lambda (timeun
e840: 69 74 20 74 69 6d 65 73 79 6d 29 20 3b 3b 20 79 it timesym) ;; y
e850: 65 61 72 20 6d 6f 6e 74 68 20 64 61 79 20 68 72 ear month day hr
e860: 20 6d 69 6e 20 73 65 63 0a 09 09 20 28 69 66 20 min sec... (if
e870: 28 6e 6f 74 20 72 65 73 75 6c 74 29 0a 09 09 20 (not result)...
e880: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 69 6d 65 (let* ((time
e890: 2d 62 6c 6b 20 28 2a 20 73 70 61 6e 20 74 69 6d -blk (* span tim
e8a0: 65 75 6e 69 74 29 29 0a 09 09 09 20 20 20 20 28 eunit)).... (
e8b0: 6e 75 6d 2d 62 6c 6b 73 20 28 71 75 6f 74 69 65 num-blks (quotie
e8c0: 6e 74 20 64 65 6c 74 61 74 20 74 69 6d 65 2d 62 nt deltat time-b
e8d0: 6c 6b 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 lk)))... (
e8e0: 69 66 20 28 61 6e 64 20 28 3e 20 6e 75 6d 2d 62 if (and (> num-b
e8f0: 6c 6b 73 20 34 29 28 3c 20 6e 75 6d 2d 62 6c 6b lks 4)(< num-blk
e900: 73 20 6d 61 78 2d 62 6c 6b 73 29 29 0a 09 09 09 s max-blks))....
e910: 20 20 20 28 6c 65 74 20 28 28 66 69 72 73 74 20 (let ((first
e920: 28 2a 20 28 71 75 6f 74 69 65 6e 74 20 74 73 74 (* (quotient tst
e930: 61 72 74 20 74 69 6d 65 2d 62 6c 6b 29 20 74 69 art time-blk) ti
e940: 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 09 20 20 20 me-blk)))....
e950: 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 (set! result (
e960: 6c 69 73 74 20 73 70 61 6e 20 74 69 6d 65 75 6e list span timeun
e970: 69 74 20 74 69 6d 65 2d 62 6c 6b 20 66 69 72 73 it time-blk firs
e980: 74 20 74 69 6d 65 73 79 6d 29 29 0a 09 09 09 20 t timesym))....
e990: 20 20 20 20 29 29 29 29 29 0a 09 20 20 20 20 20 )))))..
e9a0: 20 20 28 6c 69 73 74 20 79 72 20 6d 6f 20 77 6b (list yr mo wk
e9b0: 20 64 61 79 20 68 72 20 6d 69 6e 20 31 29 0a 09 day hr min 1)..
e9c0: 20 20 20 20 20 20 20 27 28 20 20 20 20 20 79 20 '( y
e9d0: 20 6d 6f 20 77 20 20 64 20 20 20 68 20 20 6d 20 mo w d h m
e9e0: 20 20 73 29 29 29 29 0a 09 28 6c 69 73 74 20 38 s))))..(list 8
e9f0: 20 36 20 35 20 32 20 31 29 29 29 0a 20 20 20 20 6 5 2 1))).
ea00: 20 27 28 35 20 31 30 20 31 35 20 32 30 20 33 30 '(5 10 15 20 30
ea10: 20 34 30 20 35 30 20 35 30 30 29 29 0a 20 20 20 40 50 500)).
ea20: 20 28 69 66 20 76 61 6c 75 65 73 0a 09 28 61 70 (if values..(ap
ea30: 70 6c 79 20 76 61 6c 75 65 73 20 72 65 73 75 6c ply values resul
ea40: 74 29 0a 09 28 76 61 6c 75 65 73 20 30 20 64 61 t)..(values 0 da
ea50: 79 20 31 20 30 20 27 64 29 29 29 29 0a 09 20 20 y 1 0 'd))))..
ea60: 20 20 0a 09 20 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d .. ..;;======
ea70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ea80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ea90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eaa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eab0: 0a 3b 3b 20 43 20 4f 20 4c 20 4f 20 52 20 53 0a .;; C O L O R S.
eac0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
ead0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eaf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb00: 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 20 0a ========. .
eb10: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
eb20: 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f 72 20 name->iup-color
eb30: 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 28 73 name). (case (s
eb40: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 tring->symbol (s
eb50: 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 6e tring-downcase n
eb60: 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 64 29 ame)). ((red)
eb70: 20 20 20 20 22 32 32 33 20 33 33 20 34 39 22 29 "223 33 49")
eb80: 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 20 22 . ((grey) "
eb90: 31 39 32 20 31 39 32 20 31 39 32 22 29 0a 20 20 192 192 192").
eba0: 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 35 35 ((orange) "255
ebb0: 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 28 28 172 13"). ((
ebc0: 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 69 73 purple) "This is
ebd0: 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e 2e 22 unfinished ..."
ebe0: 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 )))..;; (define
ebf0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
ec00: 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 61 74 r-for-state-stat
ec10: 75 73 20 73 74 61 74 65 20 73 74 61 74 75 73 29 us state status)
ec20: 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 73 74 72 .;; (case (str
ec30: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 74 ing->symbol stat
ec40: 65 29 0a 3b 3b 20 20 20 20 20 28 28 43 4f 4d 50 e).;; ((COMP
ec50: 4c 45 54 45 44 29 0a 3b 3b 20 20 20 20 20 20 28 LETED).;; (
ec60: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
ec70: 6d 62 6f 6c 20 73 74 61 74 75 73 29 0a 3b 3b 20 mbol status).;;
ec80: 20 20 20 20 20 20 20 28 28 50 41 53 53 29 20 20 ((PASS)
ec90: 20 20 20 20 20 20 22 37 30 20 20 32 34 39 20 37 "70 249 7
eca0: 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 3").;; ((
ecb0: 57 41 52 4e 20 57 41 49 56 45 44 29 20 22 32 35 WARN WAIVED) "25
ecc0: 35 20 31 37 32 20 31 33 22 29 0a 3b 3b 20 20 20 5 172 13").;;
ecd0: 20 20 20 20 20 28 28 53 4b 49 50 29 20 20 20 20 ((SKIP)
ece0: 20 20 20 20 22 32 33 30 20 32 33 30 20 30 22 29 "230 230 0")
ecf0: 0a 3b 3b 20 20 20 20 20 20 20 20 28 65 6c 73 65 .;; (else
ed00: 20 22 32 32 33 20 33 33 20 34 39 22 29 29 29 0a "223 33 49"))).
ed10: 3b 3b 20 20 20 20 20 28 28 4c 41 55 4e 43 48 45 ;; ((LAUNCHE
ed20: 44 29 20 20 20 20 20 20 20 20 20 22 31 30 31 20 D) "101
ed30: 31 32 33 20 31 34 32 22 29 0a 3b 3b 20 20 20 20 123 142").;;
ed40: 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 20 20 ((CHECK)
ed50: 20 20 20 20 20 22 32 35 35 20 31 30 30 20 35 30 "255 100 50
ed60: 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 45 4d 4f ").;; ((REMO
ed70: 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 22 35 TEHOSTSTART) "5
ed80: 30 20 20 31 33 30 20 31 39 35 22 29 0a 3b 3b 20 0 130 195").;;
ed90: 20 20 20 20 28 28 52 55 4e 4e 49 4e 47 29 20 20 ((RUNNING)
eda0: 20 20 20 20 20 20 20 20 22 39 20 20 20 31 33 31 "9 131
edb0: 20 32 33 32 22 29 0a 3b 3b 20 20 20 20 20 28 28 232").;; ((
edc0: 4b 49 4c 4c 52 45 51 29 20 20 20 20 20 20 20 20 KILLREQ)
edd0: 20 20 22 33 39 20 20 38 32 20 20 32 30 36 22 29 "39 82 206")
ede0: 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c 45 44 .;; ((KILLED
edf0: 29 20 20 20 20 20 20 20 20 20 20 20 22 32 33 34 ) "234
ee00: 20 31 30 31 20 31 37 22 29 0a 3b 3b 20 20 20 20 101 17").;;
ee10: 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 29 20 ((NOT_STARTED)
ee20: 20 20 20 20 20 22 32 34 30 20 32 34 30 20 32 34 "240 240 24
ee30: 30 22 29 0a 3b 3b 20 20 20 20 20 28 65 6c 73 65 0").;; (else
ee40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
ee50: 31 39 32 20 31 39 32 20 31 39 32 22 29 29 29 0a 192 192 192"))).
ee60: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
ee70: 3a 69 75 70 2d 63 6f 6c 6f 72 2d 3e 72 67 62 2d :iup-color->rgb-
ee80: 68 65 78 20 69 6e 73 74 72 29 0a 20 20 28 73 74 hex instr). (st
ee90: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
eea0: 20 0a 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 . (map (lambd
eeb0: 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 20 a (x).
eec0: 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 (number->string
eed0: 78 20 31 36 29 29 0a 20 20 20 20 20 20 20 20 28 x 16)). (
eee0: 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 map string->numb
eef0: 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 er.
ef00: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 6e (string-split in
ef10: 73 74 72 29 29 29 0a 20 20 20 22 2f 22 29 29 0a str))). "/")).
ef20: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
ef30: 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d :get-color-from-
ef40: 73 74 61 74 75 73 20 73 74 61 74 75 73 29 0a 20 status status).
ef50: 20 28 63 6f 6e 64 0a 20 20 20 28 28 65 71 75 61 (cond. ((equa
ef60: 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 53 22 l? status "PASS"
ef70: 29 20 20 20 20 22 67 72 65 65 6e 22 29 0a 20 20 ) "green").
ef80: 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 ((equal? status
ef90: 20 22 46 41 49 4c 22 29 20 20 20 20 22 72 65 64 "FAIL") "red
efa0: 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 "). ((equal? s
efb0: 74 61 74 75 73 20 22 57 41 52 4e 22 29 20 20 20 tatus "WARN")
efc0: 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 28 "orange"). ((
efd0: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 4b equal? status "K
efe0: 49 4c 4c 45 44 22 29 20 20 22 6f 72 61 6e 67 65 ILLED") "orange
eff0: 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 "). ((equal? s
f000: 74 61 74 75 73 20 22 4b 49 4c 4c 52 45 51 22 29 tatus "KILLREQ")
f010: 20 22 70 75 72 70 6c 65 22 29 0a 20 20 20 28 28 "purple"). ((
f020: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 52 equal? status "R
f030: 55 4e 4e 49 4e 47 22 29 20 22 62 6c 75 65 22 29 UNNING") "blue")
f040: 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
f050: 74 75 73 20 22 41 42 4f 52 54 22 29 20 20 20 22 tus "ABORT") "
f060: 62 72 6f 77 6e 22 29 0a 20 20 20 28 65 6c 73 65 brown"). (else
f070: 20 22 62 6c 61 63 6b 22 29 29 29 0a 0a 3b 3b 3d "black")))..;;=
f080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0c0: 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 20 41 20 4e 20 4f =====.;; N A N O
f0d0: 20 4d 20 53 20 47 20 20 20 43 20 4c 20 49 20 45 M S G C L I E
f0e0: 20 4e 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d N T.;;=========
f0f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
f130: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 define (server:g
f140: 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
f150: 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a dress hostname).
f160: 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 (let ((res #f)
f170: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
f180: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 . (lambda (a
f190: 64 72 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 dr). (if (
f1a0: 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 74 not (eq? (u8vect
f1b0: 6f 72 2d 72 65 66 20 61 64 72 20 30 29 20 31 32 or-ref adr 0) 12
f1c0: 37 29 29 0a 09 20 20 20 28 73 65 74 21 20 72 65 7)).. (set! re
f1d0: 73 20 61 64 72 29 29 29 0a 20 20 20 20 20 3b 3b s adr))). ;;
f1e0: 20 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 6e 20 NOTE: This can
f1f0: 66 61 69 6c 20 77 68 65 6e 20 74 68 65 72 65 20 fail when there
f200: 69 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f 66 is no mention of
f210: 20 74 68 65 20 68 6f 73 74 20 69 6e 20 2f 65 74 the host in /et
f220: 63 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 0a 20 c/hosts. FIXME.
f230: 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 (vector->lis
f240: 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 t (hostinfo-addr
f250: 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d esses (hostname-
f260: 3e 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 6e 61 >hostinfo hostna
f270: 6d 65 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 me)))). (stri
f280: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
f290: 20 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 65 72 (map number
f2a0: 2d 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 38 76 ->string.. (u8v
f2b0: 65 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 20 ector->list..
f2c0: 28 69 66 20 72 65 73 20 72 65 73 20 28 68 6f 73 (if res res (hos
f2d0: 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 tname->ip hostna
f2e0: 6d 65 29 29 29 29 20 22 2e 22 29 29 29 0a 0a 0a me)))) ".")))...
f2f0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
f300: 73 65 6e 64 2d 64 62 6f 61 72 64 2d 6d 61 69 6e send-dboard-main
f310: 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 6c 65 74 -changed). (let
f320: 2a 20 28 28 64 61 73 68 62 6f 61 72 64 2d 69 70 * ((dashboard-ip
f330: 73 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 s (mddb:get-dash
f340: 62 6f 61 72 64 73 29 29 29 0a 20 20 20 20 28 66 boards))). (f
f350: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
f360: 6d 62 64 61 20 28 69 70 61 64 72 29 0a 20 20 20 mbda (ipadr).
f370: 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 63 20 (let* ((soc
f380: 28 63 6f 6d 6d 6f 6e 3a 6f 70 65 6e 2d 6e 6d 2d (common:open-nm-
f390: 72 65 71 20 28 63 6f 6e 63 20 22 74 63 70 3a 2f req (conc "tcp:/
f3a0: 2f 22 20 69 70 61 64 72 29 29 29 0a 09 20 20 20 /" ipadr)))..
f3b0: 20 20 20 28 6d 73 67 20 28 63 6f 6e 63 20 22 6d (msg (conc "m
f3c0: 61 69 6e 20 22 20 2a 74 6f 70 70 61 74 68 2a 29 ain " *toppath*)
f3d0: 29 0a 09 20 20 20 20 20 20 28 72 65 73 20 28 63 ).. (res (c
f3e0: 6f 6d 6d 6f 6e 3a 6e 6d 2d 73 65 6e 64 2d 72 65 ommon:nm-send-re
f3f0: 63 65 69 76 65 2d 74 69 6d 65 6f 75 74 20 73 6f ceive-timeout so
f400: 63 20 6d 73 67 29 29 29 0a 09 20 28 69 66 20 28 c msg))).. (if (
f410: 6e 6f 74 20 72 65 73 29 20 3b 3b 20 63 6f 75 6c not res) ;; coul
f420: 64 6e 27 74 20 72 65 61 63 68 20 74 68 61 74 20 dn't reach that
f430: 64 61 73 68 62 6f 61 72 64 20 2d 20 72 65 6d 6f dashboard - remo
f440: 76 65 20 69 74 20 66 72 6f 6d 20 64 62 0a 09 20 ve it from db..
f450: 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f (print "ERRO
f460: 52 3a 20 63 6f 75 6c 64 6e 27 74 20 72 65 61 63 R: couldn't reac
f470: 68 20 64 61 73 68 62 6f 61 72 64 20 22 20 69 70 h dashboard " ip
f480: 61 64 72 29 29 0a 09 20 72 65 73 29 29 0a 20 20 adr)).. res)).
f490: 20 20 20 64 61 73 68 62 6f 61 72 64 2d 69 70 73 dashboard-ips
f4a0: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 0a 3b 3b ))). . .;;
f4b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f4c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f4f0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 ======.;; D A S
f500: 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 44 20 H B O A R D D
f510: 42 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d B .;;===========
f520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
f560: 66 69 6e 65 20 28 6d 64 64 62 3a 6f 70 65 6e 2d fine (mddb:open-
f570: 64 62 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 db). (let* ((db
f580: 20 28 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 (open-database
f590: 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 (conc (get-envir
f5a0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
f5b0: 22 48 4f 4d 45 22 29 20 22 2f 2e 64 61 73 68 62 "HOME") "/.dashb
f5c0: 6f 61 72 64 2e 64 62 22 29 29 29 29 0a 20 20 20 oard.db")))).
f5d0: 20 28 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c (set-busy-handl
f5e0: 65 72 21 20 64 62 20 28 62 75 73 79 2d 74 69 6d er! db (busy-tim
f5f0: 65 6f 75 74 20 31 30 30 30 30 29 29 0a 20 20 20 eout 10000)).
f600: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
f610: 28 6c 61 6d 62 64 61 20 28 71 72 79 29 0a 20 20 (lambda (qry).
f620: 20 20 20 20 20 28 65 78 65 63 20 28 73 71 6c 20 (exec (sql
f630: 64 62 20 71 72 79 29 29 29 0a 20 20 20 20 20 28 db qry))). (
f640: 6c 69 73 74 20 0a 20 20 20 20 20 20 22 43 52 45 list . "CRE
f650: 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 ATE TABLE IF NOT
f660: 20 45 58 49 53 54 53 20 76 61 72 73 20 20 20 20 EXISTS vars
f670: 20 20 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 (id INTEGER P
f680: 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 54 RIMARY KEY,key T
f690: 45 58 54 2c 20 76 61 6c 20 54 45 58 54 2c 20 43 EXT, val TEXT, C
f6a0: 4f 4e 53 54 52 41 49 4e 54 20 76 61 72 73 63 6f ONSTRAINT varsco
f6b0: 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 nstraint UNIQUE
f6c0: 28 6b 65 79 29 29 3b 22 0a 20 20 20 20 20 20 22 (key));". "
f6d0: 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 CREATE TABLE IF
f6e0: 4e 4f 54 20 45 58 49 53 54 53 20 64 61 73 68 62 NOT EXISTS dashb
f6f0: 6f 61 72 64 73 20 28 0a 20 20 20 20 20 20 20 20 oards (.
f700: 20 20 69 64 20 20 20 20 20 20 20 20 20 49 4e 54 id INT
f710: 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 EGER PRIMARY KEY
f720: 2c 0a 20 20 20 20 20 20 20 20 20 20 70 69 64 20 ,. pid
f730: 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 2c 0a INTEGER,.
f740: 20 20 20 20 20 20 20 20 20 20 75 73 65 72 6e 61 userna
f750: 6d 65 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 me TEXT,.
f760: 20 20 20 20 20 68 6f 73 74 6e 61 6d 65 20 20 20 hostname
f770: 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 TEXT,.
f780: 69 70 61 64 64 72 20 20 20 20 20 54 45 58 54 2c ipaddr TEXT,
f790: 0a 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 6e . portn
f7a0: 75 6d 20 20 20 20 49 4e 54 45 47 45 52 2c 0a 20 um INTEGER,.
f7b0: 20 20 20 20 20 20 20 20 20 73 74 61 72 74 5f 74 start_t
f7c0: 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 44 45 ime TIMESTAMP DE
f7d0: 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 FAULT (strftime(
f7e0: 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a 20 20 '%s','now')),.
f7f0: 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 CONST
f800: 52 41 49 4e 54 20 68 6f 73 74 70 6f 72 74 20 55 RAINT hostport U
f810: 4e 49 51 55 45 20 28 68 6f 73 74 6e 61 6d 65 2c NIQUE (hostname,
f820: 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 20 20 portnum).
f830: 20 29 3b 22 0a 20 20 20 20 20 20 29 29 0a 20 20 );". )).
f840: 20 20 64 62 29 29 0a 0a 3b 3b 20 72 65 67 69 73 db))..;; regis
f850: 74 65 72 20 61 20 64 61 73 68 62 6f 61 72 64 20 ter a dashboard
f860: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 .;;.(define (mdd
f870: 62 3a 72 65 67 69 73 74 65 72 2d 64 61 73 68 62 b:register-dashb
f880: 6f 61 72 64 20 70 6f 72 74 29 0a 20 20 28 6c 65 oard port). (le
f890: 74 2a 20 28 28 70 69 64 20 20 20 20 20 20 28 63 t* ((pid (c
f8a0: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
f8b0: 64 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 d)).. (hostname
f8c0: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
f8d0: 0a 09 20 28 69 70 61 64 64 72 20 20 20 28 73 65 .. (ipaddr (se
f8e0: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 rver:get-best-gu
f8f0: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
f900: 6e 61 6d 65 29 29 0a 09 20 28 75 73 65 72 6e 61 name)).. (userna
f910: 6d 65 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 me (current-user
f920: 2d 6e 61 6d 65 29 29 20 3b 3b 20 28 63 61 72 20 -name)) ;; (car
f930: 75 73 65 72 69 6e 66 6f 29 29 29 0a 09 20 28 64 userinfo))).. (d
f940: 62 20 20 20 20 20 20 28 6d 64 64 62 3a 6f 70 65 b (mddb:ope
f950: 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 70 72 69 n-db))). (pri
f960: 6e 74 20 22 52 65 67 69 73 74 65 72 20 6d 6f 6e nt "Register mon
f970: 69 74 6f 72 2c 20 70 69 64 3a 20 22 20 70 69 64 itor, pid: " pid
f980: 20 22 2c 20 68 6f 73 74 6e 61 6d 65 3a 20 22 20 ", hostname: "
f990: 68 6f 73 74 6e 61 6d 65 20 22 2c 20 70 6f 72 74 hostname ", port
f9a0: 3a 20 22 20 70 6f 72 74 20 22 2c 20 75 73 65 72 : " port ", user
f9b0: 6e 61 6d 65 3a 20 22 20 75 73 65 72 6e 61 6d 65 name: " username
f9c0: 29 0a 20 20 20 20 28 65 78 65 63 20 28 73 71 6c ). (exec (sql
f9d0: 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 db "INSERT OR R
f9e0: 45 50 4c 41 43 45 20 49 4e 54 4f 20 64 61 73 68 EPLACE INTO dash
f9f0: 62 6f 61 72 64 73 20 28 70 69 64 2c 75 73 65 72 boards (pid,user
fa00: 6e 61 6d 65 2c 68 6f 73 74 6e 61 6d 65 2c 69 70 name,hostname,ip
fa10: 61 64 64 72 2c 70 6f 72 74 6e 75 6d 29 20 56 41 addr,portnum) VA
fa20: 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 LUES (?,?,?,?,?)
fa30: 3b 22 29 0a 09 20 20 20 70 69 64 20 75 73 65 72 ;").. pid user
fa40: 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 20 69 70 name hostname ip
fa50: 61 64 64 72 20 70 6f 72 74 29 0a 20 20 20 20 28 addr port). (
fa60: 63 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 20 64 close-database d
fa70: 62 29 29 29 0a 0a 3b 3b 20 75 6e 72 65 67 69 73 b)))..;; unregis
fa80: 74 65 72 20 61 20 6d 6f 6e 69 74 6f 72 0a 3b 3b ter a monitor.;;
fa90: 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 75 .(define (mddb:u
faa0: 6e 72 65 67 69 73 74 65 72 2d 64 61 73 68 62 6f nregister-dashbo
fab0: 61 72 64 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 ard host port).
fac0: 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 (let* ((db
fad0: 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 (mddb:open-db))
fae0: 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 ). (print "Re
faf0: 67 69 73 74 65 72 20 75 6e 72 65 67 69 73 74 65 gister unregiste
fb00: 72 20 6d 6f 6e 69 74 6f 72 2c 20 68 6f 73 74 3a r monitor, host:
fb10: 70 6f 72 74 3d 22 20 68 6f 73 74 20 22 3a 22 20 port=" host ":"
fb20: 70 6f 72 74 29 0a 20 20 20 20 28 65 78 65 63 20 port). (exec
fb30: 28 73 71 6c 20 64 62 20 22 44 45 4c 45 54 45 20 (sql db "DELETE
fb40: 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 73 20 FROM dashboards
fb50: 57 48 45 52 45 20 68 6f 73 74 6e 61 6d 65 3d 3f WHERE hostname=?
fb60: 20 41 4e 44 20 70 6f 72 74 6e 75 6d 3d 3f 3b 22 AND portnum=?;"
fb70: 29 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 20 ) host port).
fb80: 20 28 63 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 (close-database
fb90: 20 64 62 29 29 29 0a 0a 3b 3b 20 67 65 74 20 72 db)))..;; get r
fba0: 65 67 69 73 74 65 72 65 64 20 64 61 73 68 62 6f egistered dashbo
fbb0: 61 72 64 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ards.;;.(define
fbc0: 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 62 6f (mddb:get-dashbo
fbd0: 61 72 64 73 29 0a 20 20 28 6c 65 74 20 28 28 64 ards). (let ((d
fbe0: 62 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 b (mddb:open-db)
fbf0: 29 29 0a 20 20 20 20 28 71 75 65 72 79 20 66 65 )). (query fe
fc00: 74 63 68 2d 63 6f 6c 75 6d 6e 0a 09 20 20 20 28 tch-column.. (
fc10: 73 71 6c 20 64 62 20 22 53 45 4c 45 43 54 20 69 sql db "SELECT i
fc20: 70 61 64 64 72 20 7c 7c 20 27 3a 27 20 7c 7c 20 paddr || ':' ||
fc30: 70 6f 72 74 6e 75 6d 20 46 52 4f 4d 20 64 61 73 portnum FROM das
fc40: 68 62 6f 61 72 64 73 3b 22 29 29 29 29 0a 20 20 hboards;")))).
fc50: 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;===========
fc60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fc70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fc80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fc90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
fca0: 54 20 45 20 53 20 54 20 20 20 4c 20 41 20 55 20 T E S T L A U
fcb0: 4e 20 43 20 48 20 49 20 4e 20 47 20 20 20 50 20 N C H I N G P
fcc0: 45 20 52 20 20 20 49 20 54 20 45 20 4d 20 20 20 E R I T E M
fcd0: 57 20 49 20 54 20 48 20 20 20 48 20 4f 20 53 20 W I T H H O S
fce0: 54 20 20 20 54 20 59 20 50 20 45 20 53 0a 3b 3b T T Y P E S.;;
fcf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd30: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 5b 68 ======.;; .;; [h
fd40: 6f 73 74 73 5d 0a 3b 3b 20 61 72 6d 20 63 75 62 osts].;; arm cub
fd50: 69 65 30 31 20 63 75 62 69 65 30 32 0a 3b 3b 20 ie01 cubie02.;;
fd60: 78 38 36 5f 36 34 20 7a 65 75 73 20 78 65 6e 61 x86_64 zeus xena
fd70: 20 6d 79 74 68 30 31 0a 3b 3b 20 61 6c 6c 68 6f myth01.;; allho
fd80: 73 74 73 20 23 7b 67 20 68 6f 73 74 73 20 61 72 sts #{g hosts ar
fd90: 6d 7d 20 23 7b 67 20 68 6f 73 74 73 20 78 38 36 m} #{g hosts x86
fda0: 5f 36 34 7d 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 _64}.;; .;; [hos
fdb0: 74 2d 74 79 70 65 73 5d 0a 3b 3b 20 67 65 6e 65 t-types].;; gene
fdc0: 72 61 6c 20 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 ral #MTLOWESTLOA
fdd0: 44 20 23 7b 67 20 68 6f 73 74 73 20 61 6c 6c 68 D #{g hosts allh
fde0: 6f 73 74 73 7d 0a 3b 3b 20 61 72 6d 20 20 20 20 osts}.;; arm
fdf0: 20 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 20 23 #MTLOWESTLOAD #
fe00: 7b 67 20 68 6f 73 74 73 20 61 72 6d 7d 0a 3b 3b {g hosts arm}.;;
fe10: 20 6e 62 67 65 6e 65 72 61 6c 20 6e 62 6a 6f 62 nbgeneral nbjob
fe20: 20 72 75 6e 20 4a 4f 42 43 4f 4d 4d 41 4e 44 20 run JOBCOMMAND
fe30: 2d 6c 6f 67 20 24 4d 54 5f 4c 49 4e 4b 54 52 45 -log $MT_LINKTRE
fe40: 45 2f 24 4d 54 5f 54 41 52 47 45 54 2f 24 4d 54 E/$MT_TARGET/$MT
fe50: 5f 52 55 4e 4e 41 4d 45 2e 24 4d 54 5f 54 45 53 _RUNNAME.$MT_TES
fe60: 54 4e 41 4d 45 2d 24 4d 54 5f 49 54 45 4d 5f 50 TNAME-$MT_ITEM_P
fe70: 41 54 48 2e 6c 67 6f 0a 3b 3b 20 0a 3b 3b 20 5b ATH.lgo.;; .;; [
fe80: 6c 61 75 6e 63 68 65 72 73 5d 0a 3b 3b 20 65 6e launchers].;; en
fe90: 76 73 65 74 75 70 20 67 65 6e 65 72 61 6c 0a 3b vsetup general.;
fea0: 3b 20 78 6f 72 2f 25 2f 6e 20 34 43 31 36 47 0a ; xor/%/n 4C16G.
feb0: 3b 3b 20 25 20 6e 62 67 65 6e 65 72 61 6c 0a 3b ;; % nbgeneral.;
fec0: 3b 20 0a 3b 3b 20 5b 6a 6f 62 74 6f 6f 6c 73 5d ; .;; [jobtools]
fed0: 0a 3b 3b 20 23 20 69 66 20 64 65 66 69 6e 65 64 .;; # if defined
fee0: 20 61 6e 64 20 6e 6f 74 20 22 6e 6f 22 20 66 6c and not "no" fl
fef0: 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 77 69 6c exi-launcher wil
ff00: 6c 20 62 79 70 61 73 73 20 22 6c 61 75 6e 63 68 l bypass "launch
ff10: 65 72 22 20 75 6e 6c 65 73 73 20 6e 6f 20 6d 61 er" unless no ma
ff20: 74 63 68 2e 0a 3b 3b 20 66 6c 65 78 69 2d 6c 61 tch..;; flexi-la
ff30: 75 6e 63 68 65 72 20 79 65 73 20 20 0a 3b 3b 20 uncher yes .;;
ff40: 6c 61 75 6e 63 68 65 72 20 6e 62 66 61 6b 65 0a launcher nbfake.
ff50: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
ff60: 6f 6e 3a 67 65 74 2d 6c 61 75 6e 63 68 65 72 20 on:get-launcher
ff70: 63 6f 6e 66 69 67 64 61 74 20 74 65 73 74 6e 61 configdat testna
ff80: 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 20 28 me itempath). (
ff90: 6c 65 74 20 28 28 66 61 6c 6c 62 61 63 6b 2d 6c let ((fallback-l
ffa0: 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 66 auncher (configf
ffb0: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
ffc0: 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6c 61 t "jobtools" "la
ffd0: 75 6e 63 68 65 72 22 29 29 29 0a 20 20 20 20 28 uncher"))). (
ffe0: 69 66 20 28 61 6e 64 20 28 63 6f 6e 66 69 67 66 if (and (configf
fff0: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
10000 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 6c t "jobtools" "fl
10010 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 20 3b exi-launcher") ;
10020 3b 20 6f 76 65 72 72 69 64 65 73 20 6c 61 75 6e ; overrides laun
10030 63 68 65 72 0a 09 20 20 20 20 20 28 6e 6f 74 20 cher.. (not
10040 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 (equal? (configf
10050 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
10060 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 6c t "jobtools" "fl
10070 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 20 22 exi-launcher") "
10080 6e 6f 22 29 29 29 0a 09 28 6c 65 74 2a 20 28 28 no")))..(let* ((
10090 6c 61 75 6e 63 68 65 72 73 20 20 20 20 20 20 20 launchers
100a0 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
100b0 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
100c0 64 61 74 20 22 6c 61 75 6e 63 68 65 72 73 22 20 dat "launchers"
100d0 27 28 29 29 29 29 0a 09 20 20 28 69 66 20 28 6e '()))).. (if (n
100e0 75 6c 6c 3f 20 6c 61 75 6e 63 68 65 72 73 29 0a ull? launchers).
100f0 09 20 20 20 20 20 20 66 61 6c 6c 62 61 63 6b 2d . fallback-
10100 6c 61 75 6e 63 68 65 72 0a 09 20 20 20 20 20 20 launcher..
10110 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
10120 28 63 61 72 20 6c 61 75 6e 63 68 65 72 73 29 29 (car launchers))
10130 0a 09 09 09 20 28 74 61 6c 20 28 63 64 72 20 6c .... (tal (cdr l
10140 61 75 6e 63 68 65 72 73 29 29 29 0a 09 09 28 6c aunchers)))...(l
10150 65 74 20 28 28 70 61 74 74 20 20 20 20 20 20 28 et ((patt (
10160 63 61 72 20 68 65 64 29 29 0a 09 09 20 20 20 20 car hed))...
10170 20 20 28 68 6f 73 74 2d 74 79 70 65 20 28 63 61 (host-type (ca
10180 64 72 20 68 65 64 29 29 29 0a 09 09 20 20 28 69 dr hed)))... (i
10190 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 70 f (tests:match p
101a0 61 74 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 att testname ite
101b0 6d 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 28 mpath)... (
101c0 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 67 3a begin....(debug:
101d0 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 print-info 2 *de
101e0 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
101f0 22 48 61 76 65 20 66 6c 65 78 69 2d 6c 61 75 6e "Have flexi-laun
10200 63 68 65 72 20 6d 61 74 63 68 20 66 6f 72 20 22 cher match for "
10210 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
10220 65 6d 70 61 74 68 20 22 20 3d 20 22 20 68 6f 73 empath " = " hos
10230 74 2d 74 79 70 65 29 0a 09 09 09 28 6c 65 74 20 t-type)....(let
10240 28 28 6c 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 ((launcher (conf
10250 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
10260 67 64 61 74 20 22 68 6f 73 74 2d 74 79 70 65 73 gdat "host-types
10270 22 20 68 6f 73 74 2d 74 79 70 65 29 29 29 0a 09 " host-type)))..
10280 09 09 20 20 28 69 66 20 6c 61 75 6e 63 68 65 72 .. (if launcher
10290 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 .... (let*
102a0 28 28 6c 61 75 6e 63 68 65 72 2d 70 61 72 74 73 ((launcher-parts
102b0 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c (string-split l
102c0 61 75 6e 63 68 65 72 29 29 0a 09 09 09 09 20 20 auncher)).....
102d0 20 20 20 28 6c 61 75 6e 63 68 65 72 2d 65 78 65 (launcher-exe
102e0 20 20 20 28 63 61 72 20 6c 61 75 6e 63 68 65 72 (car launcher
102f0 2d 70 61 72 74 73 29 29 29 0a 09 09 09 09 28 69 -parts))).....(i
10300 66 20 28 65 71 75 61 6c 3f 20 6c 61 75 6e 63 68 f (equal? launch
10310 65 72 2d 65 78 65 20 22 23 4d 54 4c 4f 57 45 53 er-exe "#MTLOWES
10320 54 4c 4f 41 44 22 29 20 3b 3b 20 74 68 69 73 20 TLOAD") ;; this
10330 69 73 20 6f 75 72 20 73 70 65 63 69 61 6c 20 63 is our special c
10340 61 73 65 2c 20 77 65 20 77 69 6c 6c 20 66 69 6e ase, we will fin
10350 64 20 74 68 65 20 6c 6f 77 65 73 74 20 6c 6f 61 d the lowest loa
10360 64 20 61 6e 64 20 63 72 61 66 74 20 61 20 6e 62 d and craft a nb
10370 66 61 6b 65 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 fake commandline
10380 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 28 ..... (let ((
10390 74 61 72 67 2d 68 6f 73 74 20 28 63 6f 6d 6d 6f targ-host (commo
103a0 6e 3a 67 65 74 2d 6c 65 61 73 74 2d 6c 6f 61 64 n:get-least-load
103b0 65 64 2d 68 6f 73 74 20 28 63 64 72 20 6c 61 75 ed-host (cdr lau
103c0 6e 63 68 65 72 2d 70 61 72 74 73 29 29 29 29 0a ncher-parts)))).
103d0 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e 63 20 .... (conc
103e0 22 72 65 6d 72 75 6e 20 22 20 74 61 72 67 2d 68 "remrun " targ-h
103f0 6f 73 74 29 29 0a 09 09 09 09 20 20 20 20 6c 61 ost))..... la
10400 75 6e 63 68 65 72 29 29 0a 09 09 09 20 20 20 20 uncher))....
10410 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 (begin.....(de
10420 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
10430 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
10440 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f rt* "WARNING: no
10450 20 6c 61 75 6e 63 68 65 72 20 66 6f 75 6e 64 20 launcher found
10460 66 6f 72 20 68 6f 73 74 2d 74 79 70 65 20 22 20 for host-type "
10470 68 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 09 28 host-type).....(
10480 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
10490 09 09 09 20 20 20 20 66 61 6c 6c 62 61 63 6b 2d ... fallback-
104a0 6c 61 75 6e 63 68 65 72 0a 09 09 09 09 20 20 20 launcher.....
104b0 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
104c0 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 0a (cdr tal))))))).
104d0 09 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 6d 61 .. ;; no ma
104e0 74 63 68 2c 20 74 72 79 20 61 67 61 69 6e 0a 09 tch, try again..
104f0 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
10500 3f 20 74 61 6c 29 0a 09 09 09 20 20 66 61 6c 6c ? tal).... fall
10510 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 09 back-launcher...
10520 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
10530 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
10540 29 29 0a 09 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 ))..fallback-lau
10550 6e 63 68 65 72 29 29 29 0a 20 20 0a 3b 3b 3d 3d ncher))). .;;==
10560 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10570 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10580 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10590 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105a0 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 48 20 ====.;; D A S H
105b0 42 20 4f 20 41 20 52 20 44 20 20 20 55 20 53 20 B O A R D U S
105c0 45 20 52 20 20 20 56 20 49 20 45 20 57 20 53 0a E R V I E W S.
105d0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
105e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
105f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10600 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10610 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 72 ========..;; fir
10620 73 74 20 72 65 61 64 20 7e 2f 76 69 65 77 73 2e st read ~/views.
10630 63 6f 6e 66 69 67 20 69 66 20 69 74 20 65 78 69 config if it exi
10640 73 74 73 2c 20 74 68 65 6e 20 72 65 61 64 20 24 sts, then read $
10650 4d 54 52 41 48 2f 76 69 65 77 73 2e 63 6f 6e 66 MTRAH/views.conf
10660 69 67 20 69 66 20 69 74 20 65 78 69 73 74 73 0a ig if it exists.
10670 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
10680 6f 6e 3a 6c 6f 61 64 2d 76 69 65 77 73 2d 63 6f on:load-views-co
10690 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 28 28 nfig). (let* ((
106a0 76 69 65 77 2d 63 66 67 64 61 74 20 20 20 20 28 view-cfgdat (
106b0 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
106c0 29 0a 09 20 28 68 6f 6d 65 2d 63 66 67 66 69 6c ).. (home-cfgfil
106d0 65 20 20 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 e (conc (get-e
106e0 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
106f0 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f 2e 6d ble "HOME") "/.m
10700 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 29 29 tviews.config"))
10710 0a 09 20 28 6d 74 68 6f 6d 65 2d 63 66 67 66 69 .. (mthome-cfgfi
10720 6c 65 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 le (conc *toppat
10730 68 2a 20 22 2f 2e 6d 74 76 69 65 77 73 2e 63 6f h* "/.mtviews.co
10740 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 69 66 nfig"))). (if
10750 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d (file-exists? m
10760 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a 09 thome-cfgfile)..
10770 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 6d 74 68 (read-config mth
10780 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 65 77 ome-cfgfile view
10790 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 20 20 -cfgdat #t)).
107a0 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 68 65 20 ;; we load the
107b0 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 20 41 46 home dir file AF
107c0 54 45 52 20 74 68 65 20 4d 54 52 41 48 20 66 69 TER the MTRAH fi
107d0 6c 65 20 73 6f 20 74 68 65 20 75 73 65 72 20 63 le so the user c
107e0 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 74 74 69 an clobber setti
107f0 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 ngs when running
10800 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 20 69 the dashboard i
10810 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 72 65 61 n read-only area
10820 73 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d s. (if (file-
10830 65 78 69 73 74 73 3f 20 68 6f 6d 65 2d 63 66 67 exists? home-cfg
10840 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 6f 6e file)..(read-con
10850 66 69 67 20 68 6f 6d 65 2d 63 66 67 66 69 6c 65 fig home-cfgfile
10860 20 76 69 65 77 2d 63 66 67 64 61 74 20 23 74 29 view-cfgdat #t)
10870 29 0a 20 20 20 20 76 69 65 77 2d 63 66 67 64 61 ). view-cfgda
10880 74 29 29 0a 0a t))..