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 77 efine *db-last-w
0f90: 72 69 74 65 2a 20 20 20 20 20 20 20 30 29 20 20 rite* 0)
0fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
0fb0: 3b 20 75 73 65 64 20 74 6f 20 72 65 63 6f 72 64 ; used to record
0fc0: 20 6c 61 73 74 20 74 6f 75 63 68 20 6f 66 20 64 last touch of d
0fd0: 62 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6c 61 b.(define *db-la
0fe0: 73 74 2d 73 79 6e 63 2a 20 20 20 20 20 20 20 20 st-sync*
0ff0: 30 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0)
1000: 20 20 20 3b 3b 20 6c 61 73 74 20 74 69 6d 65 20 ;; last time
1010: 74 68 65 20 73 79 6e 63 20 74 6f 20 6d 65 67 61 the sync to mega
1020: 74 65 73 74 2e 64 62 20 68 61 70 70 65 6e 65 64 test.db happened
1030: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 79 6e .(define *db-syn
1040: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 c-in-progress* #
1050: 66 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 f)
1060: 20 20 3b 3b 20 69 66 20 74 68 65 72 65 20 69 73 ;; if there is
1070: 20 61 20 73 79 6e 63 20 69 6e 20 70 72 6f 67 72 a sync in progr
1080: 65 73 73 20 64 6f 20 6e 6f 74 20 74 72 79 20 74 ess do not try t
1090: 6f 20 73 74 61 72 74 20 61 6e 6f 74 68 65 72 0a o start another.
10a0: 28 64 65 66 69 6e 65 20 2a 64 62 2d 6d 75 6c 74 (define *db-mult
10b0: 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 20 28 6d i-sync-mutex* (m
10c0: 61 6b 65 2d 6d 75 74 65 78 29 29 20 20 20 20 20 ake-mutex))
10d0: 20 3b 3b 20 70 72 6f 74 65 63 74 20 61 63 63 65 ;; protect acce
10e0: 73 73 20 74 6f 20 2a 64 62 2d 73 79 6e 63 2d 69 ss to *db-sync-i
10f0: 6e 2d 70 72 6f 67 72 65 73 73 2a 2c 20 2a 64 62 n-progress*, *db
1100: 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 61 6e 64 20 -last-sync* and
1110: 2a 64 62 2d 6c 61 73 74 2d 77 72 69 74 65 2a 0a *db-last-write*.
1120: 3b 3b 20 74 61 73 6b 20 64 62 0a 28 64 65 66 69 ;; task db.(defi
1130: 6e 65 20 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 ne *task-db*
1140: 20 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 #f) ;;
1150: 28 76 65 63 74 6f 72 20 64 62 20 70 61 74 68 2d (vector db path-
1160: 74 6f 2d 64 62 29 0a 28 64 65 66 69 6e 65 20 2a to-db).(define *
1170: 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 db-access-allowe
1180: 64 2a 20 20 20 23 74 29 20 3b 3b 20 66 6c 61 67 d* #t) ;; flag
1190: 20 74 6f 20 61 6c 6c 6f 77 20 61 63 63 65 73 73 to allow access
11a0: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 .(define *db-acc
11b0: 65 73 73 2d 6d 75 74 65 78 2a 20 20 20 20 20 28 ess-mutex* (
11c0: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 make-mutex)).(de
11d0: 66 69 6e 65 20 2a 64 62 2d 63 61 63 68 65 2d 70 fine *db-cache-p
11e0: 61 74 68 2a 20 20 20 20 20 20 20 23 66 29 0a 0a ath* #f)..
11f0: 3b 3b 20 53 45 52 56 45 52 0a 28 64 65 66 69 6e ;; SERVER.(defin
1200: 65 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 e *my-client-sig
1210: 6e 61 74 75 72 65 2a 20 23 66 29 0a 28 64 65 66 nature* #f).(def
1220: 69 6e 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 ine *transport-t
1230: 79 70 65 2a 20 20 23 66 29 20 20 20 20 20 20 20 ype* #f)
1240: 20 20 20 20 20 20 3b 3b 20 6f 76 65 72 72 69 64 ;; overrid
1250: 65 20 77 69 74 68 20 5b 73 65 72 76 65 72 5d 20 e with [server]
1260: 74 72 61 6e 73 70 6f 72 74 20 68 74 74 70 7c 72 transport http|r
1270: 70 63 7c 6e 6d 73 67 0a 0a 28 64 65 66 69 6e 65 pc|nmsg..(define
1280: 20 2a 44 45 46 41 55 4c 54 2d 54 52 41 4e 53 50 *DEFAULT-TRANSP
1290: 4f 52 54 2a 20 22 68 74 74 70 22 29 0a 28 64 65 ORT* "http").(de
12a0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 fine (common:set
12b0: 2d 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 29 -transport-type)
12c0: 0a 20 20 28 73 65 74 21 20 2a 74 72 61 6e 73 70 . (set! *transp
12d0: 6f 72 74 2d 74 79 70 65 2a 0a 20 20 20 20 20 20 ort-type*.
12e0: 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f (string->symbo
12f0: 6c 0a 20 20 20 20 20 20 20 20 20 28 6f 72 0a 20 l. (or.
1300: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 3a 67 (args:g
1310: 65 74 2d 61 72 67 20 22 2d 74 72 61 6e 73 70 6f et-arg "-transpo
1320: 72 74 22 29 0a 20 20 20 20 20 20 20 20 20 20 28 rt"). (
1330: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
1340: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 configdat* "serv
1350: 65 72 22 20 22 74 72 61 6e 73 70 6f 72 74 22 29 er" "transport")
1360: 0a 20 20 20 20 20 20 20 20 20 20 2a 44 45 46 41 . *DEFA
1370: 55 4c 54 2d 54 52 41 4e 53 50 4f 52 54 2a 29 29 ULT-TRANSPORT*))
1380: 29 0a 20 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 ). *transport-t
1390: 79 70 65 2a 29 0a 20 20 0a 28 64 65 66 69 6e 65 ype*). .(define
13a0: 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 20 20 20 *runremote*
13b0: 20 20 20 20 20 23 66 29 20 20 20 20 20 20 20 20 #f)
13c0: 20 20 20 20 20 20 20 20 3b 3b 20 69 66 20 73 65 ;; if se
13d0: 74 20 75 70 20 66 6f 72 20 73 65 72 76 65 72 20 t up for server
13e0: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 74 68 communication th
13f0: 69 73 20 77 69 6c 6c 20 68 6f 6c 64 20 3c 68 6f is will hold <ho
1400: 73 74 20 70 6f 72 74 3e 0a 28 64 65 66 69 6e 65 st port>.(define
1410: 20 2a 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 *max-cache-size
1420: 2a 20 20 20 20 30 29 0a 28 64 65 66 69 6e 65 20 * 0).(define
1430: 2a 6c 6f 67 67 65 64 2d 69 6e 2d 63 6c 69 65 6e *logged-in-clien
1440: 74 73 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 ts* (make-hash-t
1450: 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a able)).(define *
1460: 73 65 72 76 65 72 2d 69 64 2a 20 20 20 20 20 20 server-id*
1470: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
1480: 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 20 20 20 server-info*
1490: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
14a0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 20 20 time-to-exit*
14b0: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
14c0: 73 65 72 76 65 72 2d 72 75 6e 2a 20 20 20 20 20 server-run*
14d0: 20 20 20 23 74 29 0a 28 64 65 66 69 6e 65 20 2a #t).(define *
14e0: 72 75 6e 2d 69 64 2a 20 20 20 20 20 20 20 20 20 run-id*
14f0: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
1500: 73 65 72 76 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a server-kind-run*
1510: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1520: 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 68 ble)).(define *h
1530: 6f 6d 65 2d 68 6f 73 74 2a 20 20 20 20 20 20 20 ome-host*
1540: 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a 74 #f).(define *t
1550: 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 otal-non-write-d
1560: 65 6c 61 79 2a 20 30 29 0a 28 64 65 66 69 6e 65 elay* 0).(define
1570: 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 *heartbeat-mute
1580: 78 2a 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 x* (make-mutex
1590: 29 29 0a 0a 3b 3b 20 63 6c 69 65 6e 74 0a 28 64 ))..;; client.(d
15a0: 65 66 69 6e 65 20 2a 72 6d 74 2d 6d 75 74 65 78 efine *rmt-mutex
15b0: 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d * (make-
15c0: 6d 75 74 65 78 29 29 20 20 20 20 20 3b 3b 20 72 mutex)) ;; r
15d0: 65 6d 6f 74 65 20 61 63 63 65 73 73 20 63 61 6c emote access cal
15e0: 6c 73 20 6d 75 74 65 78 20 0a 0a 3b 3b 20 52 50 ls mutex ..;; RP
15f0: 43 20 74 72 61 6e 73 70 6f 72 74 0a 28 64 65 66 C transport.(def
1600: 69 6e 65 20 2a 72 70 63 3a 6c 69 73 74 65 6e 65 ine *rpc:listene
1610: 72 2a 20 20 20 20 20 20 23 66 29 0a 0a 3b 3b 20 r* #f)..;;
1620: 4b 45 59 20 69 6e 66 6f 0a 28 64 65 66 69 6e 65 KEY info.(define
1630: 20 2a 74 61 72 67 65 74 2a 20 20 20 20 20 20 20 *target*
1640: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1650: 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 table)) ;; cache
1660: 20 74 68 65 20 74 61 72 67 65 74 20 68 65 72 65 the target here
1670: 3b 20 74 61 72 67 65 74 20 69 73 20 6b 65 79 76 ; target is keyv
1680: 61 6c 31 2f 6b 65 79 76 61 6c 32 2f 2e 2e 2e 2f al1/keyval2/.../
1690: 6b 65 79 76 61 6c 4e 0a 28 64 65 66 69 6e 65 20 keyvalN.(define
16a0: 2a 6b 65 79 73 2a 20 20 20 20 20 20 20 20 20 20 *keys*
16b0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
16c0: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
16d0: 74 68 65 20 6b 65 79 73 20 68 65 72 65 0a 28 64 the keys here.(d
16e0: 65 66 69 6e 65 20 2a 6b 65 79 76 61 6c 73 2a 20 efine *keyvals*
16f0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
1700: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 hash-table)).(de
1710: 66 69 6e 65 20 2a 74 6f 70 74 65 73 74 2d 70 61 fine *toptest-pa
1720: 74 68 73 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 ths* (make-h
1730: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 ash-table)) ;; c
1740: 61 63 68 65 20 74 6f 70 74 65 73 74 20 70 61 74 ache toptest pat
1750: 68 20 73 65 74 74 69 6e 67 73 20 68 65 72 65 0a h settings here.
1760: 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 70 61 (define *test-pa
1770: 74 68 73 2a 20 20 20 20 20 20 20 20 28 6d 61 6b ths* (mak
1780: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1790: 3b 20 63 61 63 68 65 20 74 65 73 74 2d 69 64 20 ; cache test-id
17a0: 74 6f 20 74 65 73 74 20 72 75 6e 20 70 61 74 68 to test run path
17b0: 73 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a s here.(define *
17c0: 74 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 20 test-ids*
17d0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
17e0: 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 72 ble)) ;; cache r
17f0: 75 6e 2d 69 64 2c 20 74 65 73 74 6e 61 6d 65 2c un-id, testname,
1800: 20 61 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 3d and item-path =
1810: 3e 20 74 65 73 74 2d 69 64 0a 28 64 65 66 69 6e > test-id.(defin
1820: 65 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 20 e *test-info*
1830: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
1840: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 -table)) ;; cach
1850: 65 20 74 68 65 20 74 65 73 74 20 69 6e 66 6f 20 e the test info
1860: 72 65 63 6f 72 64 73 2c 20 75 70 64 61 74 65 20 records, update
1870: 74 68 65 20 73 74 61 74 65 2c 20 73 74 61 74 75 the state, statu
1880: 73 2c 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e 20 s, run_duration
1890: 65 74 63 2e 20 66 72 6f 6d 20 74 65 73 74 64 61 etc. from testda
18a0: 74 2e 64 62 0a 0a 28 64 65 66 69 6e 65 20 2a 72 t.db..(define *r
18b0: 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 20 un-info-cache*
18c0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
18d0: 62 6c 65 29 29 20 3b 3b 20 72 75 6e 20 69 6e 66 ble)) ;; run inf
18e0: 6f 20 69 73 20 73 74 61 62 6c 65 2c 20 6e 6f 20 o is stable, no
18f0: 6e 65 65 64 20 74 6f 20 72 65 67 65 74 0a 28 64 need to reget.(d
1900: 65 66 69 6e 65 20 2a 6c 61 75 6e 63 68 2d 73 65 efine *launch-se
1910: 74 75 70 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 tup-mutex* (make
1920: 2d 6d 75 74 65 78 29 29 20 20 20 20 20 3b 3b 20 -mutex)) ;;
1930: 6e 65 65 64 20 74 6f 20 62 65 20 61 62 6c 65 20 need to be able
1940: 74 6f 20 63 61 6c 6c 20 6c 61 75 6e 63 68 3a 73 to call launch:s
1950: 65 74 75 70 20 6f 66 74 65 6e 20 73 6f 20 6d 75 etup often so mu
1960: 74 65 78 20 69 74 20 61 6e 64 20 72 65 2d 63 61 tex it and re-ca
1970: 6c 6c 20 74 68 65 20 72 65 61 6c 20 64 65 61 6c ll the real deal
1980: 20 6f 6e 6c 79 20 69 66 20 2a 74 6f 70 70 61 74 only if *toppat
1990: 68 2a 20 6e 6f 74 20 73 65 74 0a 28 64 65 66 69 h* not set.(defi
19a0: 6e 65 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 ne *homehost-mut
19b0: 65 78 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 ex* (make-mu
19c0: 74 65 78 29 29 0a 0a 3b 3b 20 6c 61 75 6e 63 68 tex))..;; launch
19d0: 69 6e 67 20 61 6e 64 20 68 6f 73 74 73 0a 28 64 ing and hosts.(d
19e0: 65 66 73 74 72 75 63 74 20 68 6f 73 74 0a 20 20 efstruct host.
19f0: 28 72 65 61 63 68 61 62 6c 65 20 20 20 20 23 66 (reachable #f
1a00: 29 0a 20 20 28 6c 61 73 74 2d 75 70 64 61 74 65 ). (last-update
1a10: 20 20 30 29 0a 20 20 28 6c 61 73 74 2d 75 73 65 0). (last-use
1a20: 64 20 20 20 20 30 29 0a 20 20 28 6c 61 73 74 2d d 0). (last-
1a30: 63 70 75 6c 6f 61 64 20 31 29 29 0a 0a 28 64 65 cpuload 1))..(de
1a40: 66 69 6e 65 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 fine *host-loads
1a50: 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d * (make-
1a60: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b hash-table))..;;
1a70: 20 63 61 63 68 65 20 65 6e 76 69 72 6f 6e 6d 65 cache environme
1a80: 6e 74 20 76 61 72 73 20 66 6f 72 20 65 61 63 68 nt vars for each
1a90: 20 72 75 6e 20 68 65 72 65 0a 28 64 65 66 69 6e run here.(defin
1aa0: 65 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 e *env-vars-by-r
1ab0: 75 6e 2d 69 64 2a 20 28 6d 61 6b 65 2d 68 61 73 un-id* (make-has
1ac0: 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 54 65 h-table))..;; Te
1ad0: 73 74 63 6f 6e 66 69 67 20 61 6e 64 20 72 75 6e stconfig and run
1ae0: 63 6f 6e 66 69 67 20 63 61 63 68 65 73 2e 20 0a config caches. .
1af0: 28 64 65 66 69 6e 65 20 2a 74 65 73 74 63 6f 6e (define *testcon
1b00: 66 69 67 73 2a 20 20 20 20 20 20 20 20 28 6d 61 figs* (ma
1b10: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1b20: 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 ;; test-name =>
1b30: 74 65 73 74 63 6f 6e 66 69 67 0a 28 64 65 66 69 testconfig.(defi
1b40: 6e 65 20 2a 72 75 6e 63 6f 6e 66 69 67 73 2a 20 ne *runconfigs*
1b50: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1b60: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 61 sh-table)) ;; ta
1b70: 72 67 65 74 20 20 20 20 3d 3e 20 72 75 6e 63 6f rget => runco
1b80: 6e 66 69 67 0a 0a 3b 3b 20 54 68 69 73 20 69 73 nfig..;; This is
1b90: 20 61 20 63 61 63 68 65 20 6f 66 20 70 72 65 2d a cache of pre-
1ba0: 72 65 71 73 20 6d 65 74 2c 20 64 6f 6e 27 74 20 reqs met, don't
1bb0: 72 65 2d 63 61 6c 63 20 69 6e 20 63 61 73 65 73 re-calc in cases
1bc0: 20 77 68 65 72 65 20 63 61 6c 6c 65 64 20 77 69 where called wi
1bd0: 74 68 20 73 61 6d 65 20 70 61 72 61 6d 73 20 6c th same params l
1be0: 65 73 73 20 74 68 61 6e 0a 3b 3b 20 66 69 76 65 ess than.;; five
1bf0: 20 73 65 63 6f 6e 64 73 20 61 67 6f 0a 28 64 65 seconds ago.(de
1c00: 66 69 6e 65 20 2a 70 72 65 2d 72 65 71 73 2d 6d fine *pre-reqs-m
1c10: 65 74 2d 63 61 63 68 65 2a 20 28 6d 61 6b 65 2d et-cache* (make-
1c20: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b hash-table))..;;
1c30: 20 63 61 63 68 65 20 6f 66 20 76 65 72 62 6f 73 cache of verbos
1c40: 69 74 79 20 67 69 76 65 6e 20 73 74 72 69 6e 67 ity given string
1c50: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 .;;.(define *ver
1c60: 62 6f 73 69 74 79 2d 63 61 63 68 65 2a 20 20 20 bosity-cache*
1c70: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1c80: 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f e))..(define (co
1c90: 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 mmon:clear-cache
1ca0: 73 29 0a 20 20 28 73 65 74 21 20 2a 74 61 72 67 s). (set! *targ
1cb0: 65 74 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 et*
1cc0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1cd0: 29 29 0a 20 20 28 73 65 74 21 20 2a 6b 65 79 73 )). (set! *keys
1ce0: 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 *
1cf0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1d00: 29 29 0a 20 20 28 73 65 74 21 20 2a 6b 65 79 76 )). (set! *keyv
1d10: 61 6c 73 2a 20 20 20 20 20 20 20 20 20 20 20 20 als*
1d20: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1d30: 29 29 0a 20 20 28 73 65 74 21 20 2a 74 6f 70 74 )). (set! *topt
1d40: 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 20 20 est-paths*
1d50: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1d60: 29 29 0a 20 20 28 73 65 74 21 20 2a 74 65 73 74 )). (set! *test
1d70: 2d 70 61 74 68 73 2a 20 20 20 20 20 20 20 20 20 -paths*
1d80: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1d90: 29 29 0a 20 20 28 73 65 74 21 20 2a 74 65 73 74 )). (set! *test
1da0: 2d 69 64 73 2a 20 20 20 20 20 20 20 20 20 20 20 -ids*
1db0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1dc0: 29 29 0a 20 20 28 73 65 74 21 20 2a 74 65 73 74 )). (set! *test
1dd0: 2d 69 6e 66 6f 2a 20 20 20 20 20 20 20 20 20 20 -info*
1de0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1df0: 29 29 0a 20 20 28 73 65 74 21 20 2a 72 75 6e 2d )). (set! *run-
1e00: 69 6e 66 6f 2d 63 61 63 68 65 2a 20 20 20 20 20 info-cache*
1e10: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1e20: 29 29 0a 20 20 28 73 65 74 21 20 2a 65 6e 76 2d )). (set! *env-
1e30: 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 vars-by-run-id*
1e40: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1e50: 29 29 0a 20 20 28 73 65 74 21 20 2a 74 65 73 74 )). (set! *test
1e60: 2d 69 64 2d 63 61 63 68 65 2a 20 20 20 20 20 20 -id-cache*
1e70: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1e80: 29 29 29 0a 0a 3b 3b 20 47 65 6e 65 72 69 63 20 )))..;; Generic
1e90: 73 74 72 69 6e 67 20 64 61 74 61 62 61 73 65 0a string database.
1ea0: 28 64 65 66 69 6e 65 20 73 64 62 3a 71 72 79 20 (define sdb:qry
1eb0: 23 66 29 20 3b 3b 20 28 6d 61 6b 65 2d 73 64 62 #f) ;; (make-sdb
1ec0: 3a 71 72 79 29 29 20 3b 3b 20 20 27 69 6e 69 74 :qry)) ;; 'init
1ed0: 20 23 66 29 0a 3b 3b 20 47 65 6e 65 72 69 63 20 #f).;; Generic
1ee0: 70 61 74 68 20 64 61 74 61 62 61 73 65 0a 28 64 path database.(d
1ef0: 65 66 69 6e 65 20 2a 66 64 62 2a 20 23 66 29 0a efine *fdb* #f).
1f00: 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6c .(define *last-l
1f10: 61 75 6e 63 68 2a 20 28 63 75 72 72 65 6e 74 2d aunch* (current-
1f20: 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 75 73 65 seconds)) ;; use
1f30: 20 66 6f 72 20 74 68 72 6f 74 74 6c 69 6e 67 20 for throttling
1f40: 74 68 65 20 6c 61 75 6e 63 68 20 72 61 74 65 2e the launch rate.
1f50: 20 57 6f 75 6c 64 20 62 65 20 62 65 74 74 65 72 Would be better
1f60: 20 74 6f 20 75 73 65 20 74 68 65 20 64 62 20 61 to use the db a
1f70: 6e 64 20 6c 61 73 74 20 74 69 6d 65 20 6f 66 20 nd last time of
1f80: 61 20 74 65 73 74 20 69 6e 20 4c 41 55 4e 43 48 a test in LAUNCH
1f90: 45 44 20 73 74 61 74 65 2e 0a 0a 3b 3b 3d 3d 3d ED state...;;===
1fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fe0: 3d 3d 3d 0a 3b 3b 20 56 20 45 20 52 20 53 20 49 ===.;; V E R S I
1ff0: 20 4f 20 4e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d O N.;;=========
2000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
2040: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
2050: 65 74 2d 66 75 6c 6c 2d 76 65 72 73 69 6f 6e 29 et-full-version)
2060: 0a 20 20 28 63 6f 6e 63 20 6d 65 67 61 74 65 73 . (conc megates
2070: 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 t-version "-" me
2080: 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 gatest-fossil-ha
2090: 73 68 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 sh))..(define (c
20a0: 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 ommon:version-si
20b0: 67 6e 61 74 75 72 65 29 0a 20 20 28 63 6f 6e 63 gnature). (conc
20c0: 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f megatest-versio
20d0: 6e 20 22 2d 22 20 28 73 75 62 73 74 72 69 6e 67 n "-" (substring
20e0: 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c megatest-fossil
20f0: 2d 68 61 73 68 20 30 20 34 29 29 29 0a 0a 3b 3b -hash 0 4)))..;;
2100: 20 66 72 6f 6d 20 6d 65 74 61 64 61 74 20 6c 6f from metadat lo
2110: 6f 6b 75 70 20 4d 45 47 41 54 45 53 54 5f 56 45 okup MEGATEST_VE
2120: 52 53 49 4f 4e 0a 3b 3b 0a 28 64 65 66 69 6e 65 RSION.;;.(define
2130: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
2140: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 3b t-run-version) ;
2150: 3b 20 52 41 44 54 20 3d 3e 20 48 6f 77 20 64 6f ; RADT => How do
2160: 65 73 20 74 68 69 73 20 77 6f 72 6b 20 69 6e 20 es this work in
2170: 73 65 6e 64 2d 72 65 63 65 69 76 65 20 66 75 6e send-receive fun
2180: 63 74 69 6f 6e 3f 3f 3b 20 61 73 73 75 6d 65 20 ction??; assume
2190: 69 74 20 69 73 20 74 68 65 20 76 61 6c 75 65 20 it is the value
21a0: 73 61 76 65 64 20 69 6e 20 73 6f 6d 65 20 44 42 saved in some DB
21b0: 0a 20 20 28 72 6d 74 3a 67 65 74 2d 76 61 72 20 . (rmt:get-var
21c0: 22 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f "MEGATEST_VERSIO
21d0: 4e 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 N"))..(define (c
21e0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 ommon:get-last-r
21f0: 75 6e 2d 76 65 72 73 69 6f 6e 2d 6e 75 6d 62 65 un-version-numbe
2200: 72 29 0a 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 r). (string->nu
2210: 6d 62 65 72 20 0a 20 20 20 28 73 75 62 73 74 72 mber . (substr
2220: 69 6e 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ing (common:get-
2230: 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e last-run-version
2240: 29 20 30 20 36 29 29 29 0a 0a 28 64 65 66 69 6e ) 0 6)))..(defin
2250: 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 e (common:set-la
2260: 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 0a st-run-version).
2270: 20 20 28 72 6d 74 3a 73 65 74 2d 76 61 72 20 22 (rmt:set-var "
2280: 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e MEGATEST_VERSION
2290: 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f " (common:versio
22a0: 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 29 0a 0a n-signature)))..
22b0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
22c0: 76 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f version-changed?
22d0: 29 0a 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f ). (not (equal?
22e0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
22f0: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 0a 09 t-run-version)..
2300: 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 (common:v
2310: 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 ersion-signature
2320: 29 29 29 29 0a 0a 3b 3b 20 4d 6f 76 65 20 6d 65 ))))..;; Move me
2330: 20 65 6c 73 65 77 68 65 72 65 20 2e 2e 2e 0a 3b elsewhere ....;
2340: 3b 20 52 41 44 54 20 3d 3e 20 57 68 79 20 64 6f ; RADT => Why do
2350: 20 77 65 20 6d 65 65 64 20 74 68 65 20 76 65 72 we meed the ver
2360: 73 69 6f 6e 20 63 68 65 63 6b 20 68 65 72 65 2c sion check here,
2370: 20 74 68 69 73 20 69 73 20 63 61 6c 6c 65 64 20 this is called
2380: 6f 6e 6c 79 20 69 66 20 76 65 72 73 69 6f 6e 20 only if version
2390: 6d 69 73 6d 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 misma.;;.(define
23a0: 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 70 (common:cleanup
23b0: 2d 64 62 20 64 62 73 74 72 75 63 74 29 0a 20 20 -db dbstruct).
23c0: 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e (db:multi-db-syn
23d0: 63 20 0a 20 20 20 64 62 73 74 72 75 63 74 0a 20 c . dbstruct.
23e0: 20 20 3b 3b 20 27 6e 65 77 32 6f 6c 64 0a 20 20 ;; 'new2old.
23f0: 20 27 6b 69 6c 6c 73 65 72 76 65 72 73 0a 20 20 'killservers.
2400: 20 27 64 65 6a 75 6e 6b 0a 20 20 20 3b 3b 20 27 'dejunk. ;; '
2410: 61 64 6a 2d 74 65 73 74 69 64 73 0a 20 20 20 3b adj-testids. ;
2420: 3b 20 27 6f 6c 64 32 6e 65 77 0a 20 20 20 27 6e ; 'old2new. 'n
2430: 65 77 32 6f 6c 64 0a 20 20 20 27 73 63 68 65 6d ew2old. 'schem
2440: 61 29 0a 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e a). (if (common
2450: 3a 76 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 :version-changed
2460: 3f 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e ?). (common
2470: 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :set-last-run-ve
2480: 72 73 69 6f 6e 29 29 29 0a 0a 3b 3b 20 52 6f 74 rsion)))..;; Rot
2490: 61 74 65 20 6c 6f 67 73 2c 20 6c 6f 67 69 63 3a ate logs, logic:
24a0: 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 .;;
24b0: 20 20 20 20 20 69 66 20 3e 20 35 30 30 6b 20 61 if > 500k a
24c0: 6e 64 20 6f 6c 64 65 72 20 74 68 61 6e 20 31 20 nd older than 1
24d0: 77 65 65 6b 3a 0a 3b 3b 20 20 20 20 20 20 20 20 week:.;;
24e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 6d rem
24f0: 6f 76 65 20 70 72 65 76 69 6f 75 73 20 63 6f 6d ove previous com
2500: 70 72 65 73 73 65 64 20 6c 6f 67 20 61 6e 64 20 pressed log and
2510: 63 6f 6d 70 72 65 73 73 20 74 68 69 73 20 6c 6f compress this lo
2520: 67 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 54 68 g.;; WARNING: Th
2530: 69 73 20 70 72 6f 63 20 6f 70 65 72 61 74 65 73 is proc operates
2540: 20 61 73 73 75 6d 69 6e 67 20 74 68 61 74 20 69 assuming that i
2550: 74 20 69 73 20 69 6e 20 74 68 65 20 64 69 72 65 t is in the dire
2560: 63 74 6f 72 79 20 61 62 6f 76 65 20 74 68 65 0a ctory above the.
2570: 3b 3b 20 20 20 20 20 20 20 20 20 20 6c 6f 67 73 ;; logs
2580: 20 64 69 72 65 63 74 6f 72 79 20 79 6f 75 20 77 directory you w
2590: 69 73 68 20 74 6f 20 6c 6f 67 2d 72 6f 74 61 74 ish to log-rotat
25a0: 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 e..;;.(define (c
25b0: 6f 6d 6d 6f 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 ommon:rotate-log
25c0: 73 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 64 s). (if (not (d
25d0: 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f irectory-exists?
25e0: 20 22 6c 6f 67 73 22 29 29 28 63 72 65 61 74 65 "logs"))(create
25f0: 2d 64 69 72 65 63 74 6f 72 79 20 22 6c 6f 67 73 -directory "logs
2600: 22 29 29 0a 20 20 28 64 69 72 65 63 74 6f 72 79 ")). (directory
2610: 2d 66 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 64 -fold . (lambd
2620: 61 20 28 66 69 6c 65 20 72 65 6d 29 0a 20 20 20 a (file rem).
2630: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
2640: 6e 67 2d 6d 61 74 63 68 20 22 5e 2e 2a 2e 6c 6f ng-match "^.*.lo
2650: 67 22 20 66 69 6c 65 29 0a 09 20 20 20 20 20 20 g" file)..
2660: 28 3e 20 28 66 69 6c 65 2d 73 69 7a 65 20 28 63 (> (file-size (c
2670: 6f 6e 63 20 22 6c 6f 67 73 2f 22 20 66 69 6c 65 onc "logs/" file
2680: 29 29 20 32 30 30 30 30 30 29 29 0a 09 20 28 6c )) 200000)).. (l
2690: 65 74 20 28 28 67 7a 66 69 6c 65 20 28 63 6f 6e et ((gzfile (con
26a0: 63 20 22 6c 6f 67 73 2f 22 20 66 69 6c 65 20 22 c "logs/" file "
26b0: 2e 67 7a 22 29 29 29 0a 09 20 20 20 28 69 66 20 .gz"))).. (if
26c0: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 67 7a (file-exists? gz
26d0: 66 69 6c 65 29 0a 09 20 20 20 20 20 20 20 28 62 file).. (b
26e0: 65 67 69 6e 0a 09 09 20 28 64 65 62 75 67 3a 70 egin... (debug:p
26f0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
2700: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2710: 72 65 6d 6f 76 69 6e 67 20 22 20 67 7a 66 69 6c removing " gzfil
2720: 65 29 0a 09 09 20 28 64 65 6c 65 74 65 2d 66 69 e)... (delete-fi
2730: 6c 65 20 67 7a 66 69 6c 65 29 29 29 0a 09 20 20 le gzfile)))..
2740: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2750: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
2760: 67 2d 70 6f 72 74 2a 20 22 63 6f 6d 70 72 65 73 g-port* "compres
2770: 73 69 6e 67 20 22 20 66 69 6c 65 29 0a 09 20 20 sing " file)..
2780: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
2790: 67 7a 69 70 20 6c 6f 67 73 2f 22 20 66 69 6c 65 gzip logs/" file
27a0: 29 29 29 29 29 0a 20 20 20 27 28 29 0a 20 20 20 ))))). '().
27b0: 22 6c 6f 67 73 22 29 29 0a 0a 3b 3b 20 46 6f 72 "logs"))..;; For
27c0: 63 65 20 61 20 6d 65 67 61 74 65 73 74 20 63 6c ce a megatest cl
27d0: 65 61 6e 75 70 2d 64 62 20 69 66 20 76 65 72 73 eanup-db if vers
27e0: 69 6f 6e 20 69 73 20 63 68 61 6e 67 65 64 20 61 ion is changed a
27f0: 6e 64 20 73 6b 69 70 2d 76 65 72 73 69 6f 6e 2d nd skip-version-
2800: 63 68 65 63 6b 20 6e 6f 74 20 73 70 65 63 69 66 check not specif
2810: 69 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ied.;;.(define (
2820: 63 6f 6d 6d 6f 6e 3a 65 78 69 74 2d 6f 6e 2d 76 common:exit-on-v
2830: 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 29 0a ersion-changed).
2840: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 (if (common:ve
2850: 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a rsion-changed?).
2860: 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f (if (commo
2870: 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a n:on-homehost?).
2880: 09 20 20 28 6c 65 74 20 28 28 6d 74 63 6f 6e 66 . (let ((mtconf
2890: 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 (conc (get-envi
28a0: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
28b0: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
28c0: 4d 45 22 29 20 22 2f 6d 65 67 61 74 65 73 74 2e ME") "/megatest.
28d0: 63 6f 6e 66 69 67 22 29 29 0a 09 09 28 64 62 73 config"))...(dbs
28e0: 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 29 truct (db:setup)
28f0: 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
2900: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2910: 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 20 22 57 log-port*.... "W
2920: 41 52 4e 49 4e 47 3a 20 56 65 72 73 69 6f 6e 20 ARNING: Version
2930: 6d 69 73 6d 61 74 63 68 21 5c 6e 22 0a 09 09 09 mismatch!\n"....
2940: 20 22 20 20 20 65 78 70 65 63 74 65 64 3a 20 22 " expected: "
2950: 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e (common:version
2960: 2d 73 69 67 6e 61 74 75 72 65 29 20 22 5c 6e 22 -signature) "\n"
2970: 0a 09 09 09 20 22 20 20 20 67 6f 74 3a 20 20 20 .... " got:
2980: 20 20 20 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 " (common:get
2990: 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f -last-run-versio
29a0: 6e 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e n)).. (if (an
29b0: 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 d (file-exists?
29c0: 6d 74 63 6f 6e 66 29 0a 09 09 20 20 20 20 20 28 mtconf)... (
29d0: 65 71 3f 20 28 63 75 72 72 65 6e 74 2d 75 73 65 eq? (current-use
29e0: 72 2d 69 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 r-id)(file-owner
29f0: 20 6d 74 63 6f 6e 66 29 29 29 20 3b 3b 20 73 61 mtconf))) ;; sa
2a00: 66 65 20 74 6f 20 72 75 6e 20 2d 63 6c 65 61 6e fe to run -clean
2a10: 75 70 2d 64 62 0a 09 09 28 62 65 67 69 6e 0a 09 up-db...(begin..
2a20: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
2a30: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2a40: 6f 72 74 2a 20 22 20 20 20 49 20 73 65 65 20 79 ort* " I see y
2a50: 6f 75 20 61 72 65 20 74 68 65 20 6f 77 6e 65 72 ou are the owner
2a60: 20 6f 66 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e of megatest.con
2a70: 66 69 67 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 fig, attempting
2a80: 74 6f 20 63 6c 65 61 6e 75 70 20 61 6e 64 20 72 to cleanup and r
2a90: 65 73 65 74 20 74 6f 20 6e 65 77 20 76 65 72 73 eset to new vers
2aa0: 69 6f 6e 22 29 0a 09 09 20 20 28 68 61 6e 64 6c ion")... (handl
2ab0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 e-exceptions...
2ac0: 20 20 65 78 6e 0a 09 09 20 20 20 28 62 65 67 69 exn... (begi
2ad0: 6e 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 3a n... (debug:
2ae0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
2af0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c -log-port* "Fail
2b00: 65 64 20 74 6f 20 73 77 69 74 63 68 20 76 65 72 ed to switch ver
2b10: 73 69 6f 6e 73 2e 22 29 0a 09 09 20 20 20 20 20 sions.")...
2b20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
2b30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2b40: 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 * " message: " (
2b50: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
2b60: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
2b70: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
2b80: 29 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 2d )... (print-
2b90: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
2ba0: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
2bb0: 0a 09 09 20 20 20 20 20 28 65 78 69 74 20 31 29 ... (exit 1)
2bc0: 29 0a 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 )... (common:c
2bd0: 6c 65 61 6e 75 70 2d 64 62 20 64 62 73 74 72 75 leanup-db dbstru
2be0: 63 74 29 29 29 0a 09 09 28 62 65 67 69 6e 0a 09 ct)))...(begin..
2bf0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
2c00: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2c10: 6f 72 74 2a 20 22 20 74 6f 20 73 77 69 74 63 68 ort* " to switch
2c20: 20 76 65 72 73 69 6f 6e 73 20 79 6f 75 20 63 61 versions you ca
2c30: 6e 20 72 75 6e 3a 20 5c 22 6d 65 67 61 74 65 73 n run: \"megates
2c40: 74 20 2d 63 6c 65 61 6e 75 70 2d 64 62 5c 22 22 t -cleanup-db\""
2c50: 29 0a 09 09 20 20 28 65 78 69 74 20 31 29 29 29 )... (exit 1)))
2c60: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
2c70: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2c80: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2c90: 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f t* "ERROR: canno
2ca0: 74 20 6d 69 67 72 61 74 65 20 76 65 72 73 69 6f t migrate versio
2cb0: 6e 20 75 6e 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 n unless on home
2cc0: 68 6f 73 74 2e 20 45 78 69 74 69 6e 67 2e 22 29 host. Exiting.")
2cd0: 0a 09 20 20 20 20 28 65 78 69 74 20 31 29 29 29 .. (exit 1)))
2ce0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
2cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
2d30: 53 20 50 20 41 20 52 20 53 20 45 20 20 20 41 20 S P A R S E A
2d40: 52 20 52 20 41 20 59 20 53 0a 3b 3b 3d 3d 3d 3d R R A Y S.;;====
2d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2d90: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ==..(define (mak
2da0: 65 2d 73 70 61 72 73 65 2d 61 72 72 61 79 29 0a e-sparse-array).
2db0: 20 20 28 6c 65 74 20 28 28 61 20 28 6d 61 6b 65 (let ((a (make
2dc0: 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 -sparse-vector))
2dd0: 29 0a 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 ). (sparse-ve
2de0: 63 74 6f 72 2d 73 65 74 21 20 61 20 30 20 28 6d ctor-set! a 0 (m
2df0: 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f ake-sparse-vecto
2e00: 72 29 29 0a 20 20 20 20 61 29 29 0a 0a 28 64 65 r)). a))..(de
2e10: 66 69 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 fine (sparse-arr
2e20: 61 79 3f 20 61 29 0a 20 20 28 61 6e 64 20 28 73 ay? a). (and (s
2e30: 70 61 72 73 65 2d 76 65 63 74 6f 72 3f 20 61 29 parse-vector? a)
2e40: 0a 20 20 20 20 20 20 20 28 73 70 61 72 73 65 2d . (sparse-
2e50: 76 65 63 74 6f 72 3f 20 28 73 70 61 72 73 65 2d vector? (sparse-
2e60: 76 65 63 74 6f 72 2d 72 65 66 20 61 20 30 29 29 vector-ref a 0))
2e70: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 61 ))..(define (spa
2e80: 72 73 65 2d 61 72 72 61 79 2d 72 65 66 20 61 20 rse-array-ref a
2e90: 78 20 79 29 0a 20 20 28 6c 65 74 20 28 28 72 6f x y). (let ((ro
2ea0: 77 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 w (sparse-vector
2eb0: 2d 72 65 66 20 61 20 78 29 29 29 0a 20 20 20 20 -ref a x))).
2ec0: 28 69 66 20 72 6f 77 0a 09 28 73 70 61 72 73 65 (if row..(sparse
2ed0: 2d 76 65 63 74 6f 72 2d 72 65 66 20 72 6f 77 20 -vector-ref row
2ee0: 79 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 y)..#f)))..(defi
2ef0: 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 ne (sparse-array
2f00: 2d 73 65 74 21 20 61 20 78 20 79 20 76 61 6c 29 -set! a x y val)
2f10: 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 . (let ((row (s
2f20: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 parse-vector-ref
2f30: 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 a x))). (if
2f40: 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 row..(sparse-vec
2f50: 74 6f 72 2d 73 65 74 21 20 72 6f 77 20 79 20 76 tor-set! row y v
2f60: 61 6c 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 2d al)..(let ((new-
2f70: 72 6f 77 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 row (make-sparse
2f80: 2d 76 65 63 74 6f 72 29 29 29 0a 09 20 20 28 73 -vector))).. (s
2f90: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 parse-vector-set
2fa0: 21 20 61 20 78 20 6e 65 77 2d 72 6f 77 29 0a 09 ! a x new-row)..
2fb0: 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 (sparse-vector
2fc0: 2d 73 65 74 21 20 6e 65 77 2d 72 6f 77 20 79 20 -set! new-row y
2fd0: 76 61 6c 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d val)))))..;;====
2fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3020: 3d 3d 0a 3b 3b 20 4c 20 4f 20 43 20 4b 20 45 20 ==.;; L O C K E
3030: 52 20 53 20 20 20 41 20 4e 20 44 20 20 20 42 20 R S A N D B
3040: 4c 20 4f 20 43 20 4b 20 45 20 52 20 53 20 0a 3b L O C K E R S .;
3050: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3090: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 =======..;; bloc
30a0: 6b 20 66 75 72 74 68 65 72 20 61 63 63 65 73 73 k further access
30b0: 65 73 20 74 6f 20 64 61 74 61 62 61 73 65 73 2e es to databases.
30c0: 20 43 61 6c 6c 20 74 68 69 73 20 62 65 66 6f 72 Call this befor
30d0: 65 20 73 68 75 74 74 69 6e 67 20 64 62 20 64 6f e shutting db do
30e0: 77 6e 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d wn.(define (comm
30f0: 6f 6e 3a 64 62 2d 62 6c 6f 63 6b 2d 66 75 72 74 on:db-block-furt
3100: 68 65 72 2d 71 75 65 72 69 65 73 29 0a 20 20 28 her-queries). (
3110: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
3120: 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a 20 access-mutex*).
3130: 20 28 73 65 74 21 20 2a 64 62 2d 61 63 63 65 73 (set! *db-acces
3140: 73 2d 61 6c 6c 6f 77 65 64 2a 20 23 66 29 0a 20 s-allowed* #f).
3150: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
3160: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
3170: 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f *))..(define (co
3180: 6d 6d 6f 6e 3a 64 62 2d 61 63 63 65 73 73 2d 61 mmon:db-access-a
3190: 6c 6c 6f 77 65 64 3f 29 0a 20 20 28 6c 65 74 20 llowed?). (let
31a0: 28 28 76 61 6c 20 28 62 65 67 69 6e 0a 09 20 20 ((val (begin..
31b0: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
31c0: 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 ! *db-access-mut
31d0: 65 78 2a 29 0a 09 20 20 20 20 20 20 20 2a 64 62 ex*).. *db
31e0: 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 2a -access-allowed*
31f0: 0a 09 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d .. (mutex-
3200: 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 unlock! *db-acce
3210: 73 73 2d 6d 75 74 65 78 2a 29 29 29 29 0a 20 20 ss-mutex*)))).
3220: 20 20 76 61 6c 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d val))..;;=====
3230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3270: 3d 0a 3b 3b 20 55 20 53 20 45 20 46 20 55 20 4c =.;; U S E F U L
3280: 20 20 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d S T U F F.;;=
3290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
32d0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 =====..;; conver
32e0: 74 20 74 68 69 6e 67 73 20 74 6f 20 61 6e 20 61 t things to an a
32f0: 6c 69 73 74 20 6f 72 20 61 73 73 6f 63 20 6c 69 list or assoc li
3300: 73 74 2c 20 23 66 20 67 65 74 73 20 63 6f 6e 76 st, #f gets conv
3310: 65 72 74 65 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 erted to "".;;.(
3320: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 define (common:t
3330: 6f 2d 61 6c 69 73 74 20 64 61 74 29 0a 20 20 28 o-alist dat). (
3340: 63 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 cond. ((list?
3350: 64 61 74 29 20 20 20 28 6d 61 70 20 63 6f 6d 6d dat) (map comm
3360: 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 64 61 74 29 on:to-alist dat)
3370: 29 0a 20 20 20 28 28 76 65 63 74 6f 72 3f 20 64 ). ((vector? d
3380: 61 74 29 0a 20 20 20 20 28 6d 61 70 20 63 6f 6d at). (map com
3390: 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 76 65 mon:to-alist (ve
33a0: 63 74 6f 72 2d 3e 6c 69 73 74 20 64 61 74 29 29 ctor->list dat))
33b0: 29 0a 20 20 20 28 28 70 61 69 72 3f 20 64 61 74 ). ((pair? dat
33c0: 29 0a 20 20 20 20 28 63 6f 6e 73 20 28 63 6f 6d ). (cons (com
33d0: 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 61 mon:to-alist (ca
33e0: 72 20 64 61 74 29 29 0a 09 20 20 28 63 6f 6d 6d r dat)).. (comm
33f0: 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 64 72 on:to-alist (cdr
3400: 20 64 61 74 29 29 29 29 0a 20 20 20 28 28 68 61 dat)))). ((ha
3410: 73 68 2d 74 61 62 6c 65 3f 20 64 61 74 29 0a 20 sh-table? dat).
3420: 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 (map common:t
3430: 6f 2d 61 6c 69 73 74 20 28 68 61 73 68 2d 74 61 o-alist (hash-ta
3440: 62 6c 65 2d 3e 61 6c 69 73 74 20 64 61 74 29 29 ble->alist dat))
3450: 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 ). (else. (
3460: 69 66 20 64 61 74 0a 09 64 61 74 0a 09 22 22 29 if dat..dat.."")
3470: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
3480: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
3490: 72 69 6e 74 20 77 61 69 74 76 61 6c 20 2e 20 6b rint waitval . k
34a0: 65 79 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b eys). (let* ((k
34b0: 65 79 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d ey (string-
34c0: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
34d0: 20 63 6f 6e 63 20 6b 65 79 73 29 20 22 2d 22 20 conc keys) "-"
34e0: 29 29 0a 09 20 28 6c 61 73 74 74 69 6d 65 20 28 )).. (lasttime (
34f0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
3500: 65 66 61 75 6c 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 efault *common:d
3510: 65 6e 6f 69 73 65 2a 20 6b 65 79 20 30 29 29 0a enoise* key 0)).
3520: 09 20 28 63 75 72 72 74 69 6d 65 20 28 63 75 72 . (currtime (cur
3530: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
3540: 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 63 75 (if (> (- cu
3550: 72 72 74 69 6d 65 20 6c 61 73 74 74 69 6d 65 29 rrtime lasttime)
3560: 20 77 61 69 74 76 61 6c 29 0a 09 28 62 65 67 69 waitval)..(begi
3570: 6e 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 n.. (hash-table
3580: 2d 73 65 74 21 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 -set! *common:de
3590: 6e 6f 69 73 65 2a 20 6b 65 79 20 63 75 72 72 74 noise* key currt
35a0: 69 6d 65 29 0a 09 20 20 23 74 29 0a 09 23 66 29 ime).. #t)..#f)
35b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
35c0: 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 mon:get-megatest
35d0: 2d 65 78 65 29 0a 20 20 28 6f 72 20 28 67 65 74 -exe). (or (get
35e0: 65 6e 76 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 env "MT_MEGATEST
35f0: 22 29 20 22 6d 65 67 61 74 65 73 74 22 29 29 0a ") "megatest")).
3600: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
3610: 3a 72 65 61 64 2d 65 6e 63 6f 64 65 64 2d 73 74 :read-encoded-st
3620: 72 69 6e 67 20 69 6e 73 74 72 29 0a 20 20 28 68 ring instr). (h
3630: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
3640: 0a 20 20 20 65 78 6e 0a 20 20 20 28 68 61 6e 64 . exn. (hand
3650: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
3660: 20 20 65 78 6e 0a 20 20 20 20 28 62 65 67 69 6e exn. (begin
3670: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
3680: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
3690: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
36a0: 72 65 63 65 69 76 65 64 20 62 61 64 20 65 6e 63 received bad enc
36b0: 6f 64 65 64 20 73 74 72 69 6e 67 20 5c 22 22 20 oded string \""
36c0: 69 6e 73 74 72 20 22 5c 22 2c 20 6d 65 73 73 61 instr "\", messa
36d0: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
36e0: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
36f0: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
3700: 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 20 28 e) exn)). (
3710: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
3720: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
3730: 70 6f 72 74 29 29 0a 20 20 20 20 20 20 23 66 29 port)). #f)
3740: 0a 20 20 20 20 28 72 65 61 64 20 28 6f 70 65 6e . (read (open
3750: 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 28 62 -input-string (b
3760: 61 73 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 ase64:base64-dec
3770: 6f 64 65 20 69 6e 73 74 72 29 29 29 29 0a 20 20 ode instr)))).
3780: 20 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 (read (open-inp
3790: 75 74 2d 73 74 72 69 6e 67 20 28 7a 33 3a 64 65 ut-string (z3:de
37a0: 63 6f 64 65 2d 62 75 66 66 65 72 20 28 62 61 73 code-buffer (bas
37b0: 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 e64:base64-decod
37c0: 65 20 69 6e 73 74 72 29 29 29 29 29 29 0a 0a 3b e instr))))))..;
37d0: 3b 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 ; dot-locking eg
37e0: 67 20 73 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 g seems not to w
37f0: 6f 72 6b 2c 20 75 73 69 6e 67 20 74 68 69 73 20 ork, using this
3800: 66 6f 72 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f for now.;; if lo
3810: 63 6b 20 69 73 20 6f 6c 64 65 72 20 74 68 61 6e ck is older than
3820: 20 65 78 70 69 72 65 2d 74 69 6d 65 20 74 68 65 expire-time the
3830: 6e 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 n remove it and
3840: 74 72 79 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 try again.;; to
3850: 67 65 74 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a get the lock.;;.
3860: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
3870: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
3880: 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 65 78 fname #!key (ex
3890: 70 69 72 65 2d 74 69 6d 65 20 33 30 30 29 29 0a pire-time 300)).
38a0: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
38b0: 74 73 3f 20 66 6e 61 6d 65 29 0a 20 20 20 20 20 ts? fname).
38c0: 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 (if (> (- (curr
38d0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c ent-seconds)(fil
38e0: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
38f0: 69 6d 65 20 66 6e 61 6d 65 29 29 20 65 78 70 69 ime fname)) expi
3900: 72 65 2d 74 69 6d 65 29 0a 09 20 20 28 62 65 67 re-time).. (beg
3910: 69 6e 0a 09 20 20 20 20 28 64 65 6c 65 74 65 2d in.. (delete-
3920: 66 69 6c 65 2a 20 66 6e 61 6d 65 29 0a 09 20 20 file* fname)..
3930: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 (common:simple
3940: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 -file-lock fname
3950: 20 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 expire-time: ex
3960: 70 69 72 65 2d 74 69 6d 65 29 29 0a 09 20 20 23 pire-time)).. #
3970: 66 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 f). (let ((
3980: 6b 65 79 2d 73 74 72 69 6e 67 20 28 63 6f 6e 63 key-string (conc
3990: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
39a0: 20 22 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 "-" (current-pr
39b0: 6f 63 65 73 73 2d 69 64 29 29 29 29 0a 09 28 77 ocess-id))))..(w
39c0: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 ith-output-to-fi
39d0: 6c 65 20 66 6e 61 6d 65 0a 09 20 20 28 6c 61 6d le fname.. (lam
39e0: 62 64 61 20 28 29 0a 09 20 20 20 20 28 70 72 69 bda ().. (pri
39f0: 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 nt key-string)))
3a00: 0a 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
3a10: 20 30 2e 32 35 29 0a 09 28 69 66 20 28 66 69 6c 0.25)..(if (fil
3a20: 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 e-exists? fname)
3a30: 0a 09 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 .. (with-inpu
3a40: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d t-from-file fnam
3a50: 65 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 e.. (lambda
3a60: 20 28 29 0a 09 09 28 65 71 75 61 6c 3f 20 6b 65 ()...(equal? ke
3a70: 79 2d 73 74 72 69 6e 67 20 28 72 65 61 64 2d 6c y-string (read-l
3a80: 69 6e 65 29 29 29 29 0a 09 20 20 20 20 23 66 29 ine)))).. #f)
3a90: 29 29 29 0a 09 0a 28 64 65 66 69 6e 65 20 28 63 )))...(define (c
3aa0: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
3ab0: 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 e-release-lock f
3ac0: 6e 61 6d 65 29 0a 20 20 28 64 65 6c 65 74 65 2d name). (delete-
3ad0: 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 0a 0a 3b file* fname))..;
3ae0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b20: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 54 20 41 =======.;; S T A
3b30: 20 54 20 45 20 53 20 20 20 41 20 4e 20 44 20 20 T E S A N D
3b40: 20 53 20 54 20 41 20 54 20 55 20 53 20 45 20 53 S T A T U S E S
3b50: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
3ba0: 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 ne *common:std-s
3bb0: 74 61 74 65 73 2a 20 20 20 0a 20 20 27 28 28 30 tates* . '((0
3bc0: 20 22 41 52 43 48 49 56 45 44 22 29 0a 20 20 20 "ARCHIVED").
3bd0: 20 28 31 20 22 53 54 55 43 4b 22 29 0a 20 20 20 (1 "STUCK").
3be0: 20 28 32 20 22 4b 49 4c 4c 52 45 51 22 29 0a 20 (2 "KILLREQ").
3bf0: 20 20 20 28 33 20 22 4b 49 4c 4c 45 44 22 29 0a (3 "KILLED").
3c00: 20 20 20 20 28 34 20 22 4e 4f 54 5f 53 54 41 52 (4 "NOT_STAR
3c10: 54 45 44 22 29 0a 20 20 20 20 28 35 20 22 43 4f TED"). (5 "CO
3c20: 4d 50 4c 45 54 45 44 22 29 0a 20 20 20 20 28 36 MPLETED"). (6
3c30: 20 22 4c 41 55 4e 43 48 45 44 22 29 0a 20 20 20 "LAUNCHED").
3c40: 20 28 37 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 (7 "REMOTEHOSTS
3c50: 54 41 52 54 22 29 0a 20 20 20 20 28 38 20 22 52 TART"). (8 "R
3c60: 55 4e 4e 49 4e 47 22 29 0a 20 20 20 20 29 29 0a UNNING"). )).
3c70: 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e .(define *common
3c80: 3a 73 74 64 2d 73 74 61 74 75 73 65 73 2a 0a 20 :std-statuses*.
3c90: 20 27 28 3b 3b 20 28 30 20 22 44 45 4c 45 54 45 '(;; (0 "DELETE
3ca0: 44 22 29 0a 20 20 20 20 28 31 20 22 6e 2f 61 22 D"). (1 "n/a"
3cb0: 29 0a 20 20 20 20 28 32 20 22 50 41 53 53 22 29 ). (2 "PASS")
3cc0: 0a 20 20 20 20 28 33 20 22 43 48 45 43 4b 22 29 . (3 "CHECK")
3cd0: 0a 20 20 20 20 28 34 20 22 53 4b 49 50 22 29 0a . (4 "SKIP").
3ce0: 20 20 20 20 28 35 20 22 57 41 52 4e 22 29 0a 20 (5 "WARN").
3cf0: 20 20 20 28 36 20 22 57 41 49 56 45 44 22 29 0a (6 "WAIVED").
3d00: 20 20 20 20 28 37 20 22 53 54 55 43 4b 2f 44 45 (7 "STUCK/DE
3d10: 41 44 22 29 0a 20 20 20 20 28 38 20 22 46 41 49 AD"). (8 "FAI
3d20: 4c 22 29 0a 20 20 20 20 28 39 20 22 41 42 4f 52 L"). (9 "ABOR
3d30: 54 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a T")))..(define *
3d40: 63 6f 6d 6d 6f 6e 3a 65 6e 64 65 64 2d 73 74 61 common:ended-sta
3d50: 74 65 73 2a 20 20 20 20 20 20 20 3b 3b 20 73 74 tes* ;; st
3d60: 61 74 65 73 20 77 68 69 63 68 20 69 6e 64 69 63 ates which indic
3d70: 61 74 65 20 74 68 65 20 74 65 73 74 20 69 73 20 ate the test is
3d80: 73 74 6f 70 70 65 64 20 61 6e 64 20 77 69 6c 6c stopped and will
3d90: 20 6e 6f 74 20 70 72 6f 63 65 65 64 0a 20 20 27 not proceed. '
3da0: 28 22 43 4f 4d 50 4c 45 54 45 44 22 20 22 41 52 ("COMPLETED" "AR
3db0: 43 48 49 56 45 44 22 20 22 4b 49 4c 4c 45 44 22 CHIVED" "KILLED"
3dc0: 20 22 4b 49 4c 4c 52 45 51 22 20 22 53 54 55 43 "KILLREQ" "STUC
3dd0: 4b 22 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 29 K" "INCOMPLETE")
3de0: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d )..(define *comm
3df0: 6f 6e 3a 62 61 64 6c 79 2d 65 6e 64 65 64 2d 73 on:badly-ended-s
3e00: 74 61 74 65 73 2a 20 3b 3b 20 74 68 65 73 65 20 tates* ;; these
3e10: 72 6f 6c 6c 20 75 70 20 61 73 20 43 48 45 43 4b roll up as CHECK
3e20: 2c 20 69 2e 65 2e 20 72 65 73 75 6c 74 73 20 6e , i.e. results n
3e30: 65 65 64 20 74 6f 20 62 65 20 63 68 65 63 6b 65 eed to be checke
3e40: 64 0a 20 20 27 28 22 4b 49 4c 4c 45 44 22 20 22 d. '("KILLED" "
3e50: 4b 49 4c 4c 52 45 51 22 20 22 53 54 55 43 4b 22 KILLREQ" "STUCK"
3e60: 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 44 "INCOMPLETE" "D
3e70: 45 41 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 EAD"))..(define
3e80: 2a 63 6f 6d 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d *common:running-
3e90: 73 74 61 74 65 73 2a 20 20 20 20 20 3b 3b 20 74 states* ;; t
3ea0: 65 73 74 20 69 73 20 65 69 74 68 65 72 20 72 75 est is either ru
3eb0: 6e 6e 69 6e 67 20 6f 72 20 63 61 6e 20 62 65 20 nning or can be
3ec0: 72 75 6e 0a 20 20 27 28 22 52 55 4e 4e 49 4e 47 run. '("RUNNING
3ed0: 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 " "REMOTEHOSTSTA
3ee0: 52 54 22 20 22 4c 41 55 4e 43 48 45 44 22 29 29 RT" "LAUNCHED"))
3ef0: 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f ..(define *commo
3f00: 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 n:cant-run-state
3f10: 73 2a 20 20 20 20 3b 3b 20 54 68 65 73 65 20 61 s* ;; These a
3f20: 72 65 20 73 74 6f 70 70 69 6e 67 20 63 6f 6e 64 re stopping cond
3f30: 69 74 69 6f 6e 73 20 74 68 61 74 20 70 72 65 76 itions that prev
3f40: 65 6e 74 20 61 20 74 65 73 74 20 66 72 6f 6d 20 ent a test from
3f50: 62 65 69 6e 67 20 72 75 6e 0a 20 20 27 28 22 43 being run. '("C
3f60: 4f 4d 50 4c 45 54 45 44 22 20 22 4b 49 4c 4c 45 OMPLETED" "KILLE
3f70: 44 22 20 22 55 4e 4b 4e 4f 57 4e 22 20 22 49 4e D" "UNKNOWN" "IN
3f80: 43 4f 4d 50 4c 45 54 45 22 20 22 41 52 43 48 49 COMPLETE" "ARCHI
3f90: 56 45 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 VED"))..(define
3fa0: 2a 63 6f 6d 6d 6f 6e 3a 6e 6f 74 2d 73 74 61 72 *common:not-star
3fb0: 74 65 64 2d 6f 6b 2d 73 74 61 74 75 73 65 73 2a ted-ok-statuses*
3fc0: 20 3b 3b 20 69 66 20 6e 6f 74 20 6f 6e 65 20 6f ;; if not one o
3fd0: 66 20 74 68 65 73 65 20 73 74 61 74 75 73 65 73 f these statuses
3fe0: 20 77 68 65 6e 20 69 6e 20 6e 6f 74 5f 73 74 61 when in not_sta
3ff0: 72 74 65 64 20 73 74 61 74 65 20 74 72 65 61 74 rted state treat
4000: 20 61 73 20 64 65 61 64 0a 20 20 27 28 22 6e 2f as dead. '("n/
4010: 61 22 20 22 6e 61 22 20 22 50 41 53 53 22 20 22 a" "na" "PASS" "
4020: 46 41 49 4c 22 20 22 57 41 52 4e 22 20 22 43 48 FAIL" "WARN" "CH
4030: 45 43 4b 22 20 22 57 41 49 56 45 44 22 20 22 44 ECK" "WAIVED" "D
4040: 45 41 44 22 20 22 53 4b 49 50 22 29 29 0a 0a 28 EAD" "SKIP"))..(
4050: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
4060: 70 65 63 69 61 6c 2d 73 6f 72 74 20 69 74 65 6d pecial-sort item
4070: 73 20 6f 72 64 65 72 20 63 6f 6d 70 29 0a 20 20 s order comp).
4080: 28 6c 65 74 20 28 28 69 74 65 6d 73 2d 6f 72 64 (let ((items-ord
4090: 65 72 20 28 6d 61 70 20 72 65 76 65 72 73 65 20 er (map reverse
40a0: 6f 72 64 65 72 29 29 0a 20 20 20 20 20 20 20 20 order)).
40b0: 28 61 63 6f 6d 70 20 20 20 20 20 20 20 28 6f 72 (acomp (or
40c0: 20 63 6f 6d 70 20 3e 29 29 29 0a 20 20 20 20 28 comp >))). (
40d0: 73 6f 72 74 20 69 74 65 6d 73 0a 20 20 20 20 20 sort items.
40e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 (lambda (a b)
40f0: 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 . (let
4100: 28 28 61 2d 6e 75 6d 20 28 63 61 64 72 20 28 6f ((a-num (cadr (o
4110: 72 20 28 61 73 73 6f 63 20 61 20 69 74 65 6d 73 r (assoc a items
4120: 2d 6f 72 64 65 72 29 20 27 28 30 20 30 29 29 29 -order) '(0 0)))
4130: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
4140: 20 20 28 62 2d 6e 75 6d 20 28 63 61 64 72 20 28 (b-num (cadr (
4150: 6f 72 20 28 61 73 73 6f 63 20 62 20 69 74 65 6d or (assoc b item
4160: 73 2d 6f 72 64 65 72 29 20 27 28 30 20 30 29 29 s-order) '(0 0))
4170: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
4180: 28 61 63 6f 6d 70 20 61 2d 6e 75 6d 20 62 2d 6e (acomp a-num b-n
4190: 75 6d 29 29 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 um))))))..;; ;;
41a0: 67 69 76 65 6e 20 61 20 74 6f 70 6c 65 76 65 6c given a toplevel
41b0: 20 77 69 74 68 20 63 75 72 72 73 74 61 74 65 2c with currstate,
41c0: 20 63 75 72 72 73 74 61 74 75 73 20 61 70 70 6c currstatus appl
41d0: 79 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 y state and stat
41e0: 75 73 0a 3b 3b 20 3b 3b 20 20 3d 3e 20 28 6e 65 us.;; ;; => (ne
41f0: 77 73 74 61 74 65 20 2e 20 6e 65 77 73 74 61 74 wstate . newstat
4200: 75 73 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 us).;; (define (
4210: 63 6f 6d 6d 6f 6e 3a 61 70 70 6c 79 2d 73 74 61 common:apply-sta
4220: 74 65 2d 73 74 61 74 75 73 20 63 75 72 72 73 74 te-status currst
4230: 61 74 65 20 63 75 72 72 73 74 61 74 75 73 20 73 ate currstatus s
4240: 74 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 tate status).;;
4250: 20 20 28 6c 65 74 2a 20 28 28 63 73 74 61 74 65 (let* ((cstate
4260: 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f (string->symbo
4270: 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 l (string-downca
4280: 73 65 20 63 75 72 72 73 74 61 74 65 29 29 29 0a se currstate))).
4290: 3b 3b 20 20 20 20 20 20 20 20 20 20 28 63 73 74 ;; (cst
42a0: 61 74 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 79 atus (string->sy
42b0: 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 mbol (string-dow
42c0: 6e 63 61 73 65 20 63 75 72 72 73 74 61 74 75 73 ncase currstatus
42d0: 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ))).;;
42e0: 28 73 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 (sstate (string
42f0: 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 ->symbol (string
4300: 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 65 29 -downcase state)
4310: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 )).;; (
4320: 73 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d sstatus (string-
4330: 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d >symbol (string-
4340: 64 6f 77 6e 63 61 73 65 20 73 74 61 74 75 73 29 downcase status)
4350: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 )).;; (
4360: 6e 73 74 61 74 65 20 20 23 66 29 0a 3b 3b 20 20 nstate #f).;;
4370: 20 20 20 20 20 20 20 20 28 6e 73 74 61 74 75 73 (nstatus
4380: 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 28 73 65 #f)).;; (se
4390: 74 21 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 t! nstate.;;
43a0: 20 20 20 20 20 20 20 28 63 61 73 65 20 63 73 74 (case cst
43b0: 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ate.;;
43c0: 20 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6e ((completed n
43d0: 6f 74 5f 73 74 61 72 74 65 64 20 6b 69 6c 6c 65 ot_started kille
43e0: 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 d killreq stuck
43f0: 61 72 63 68 69 76 65 64 29 20 0a 3b 3b 20 20 20 archived) .;;
4400: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 65 (case
4410: 20 73 73 74 61 74 65 20 3b 3b 20 63 6f 6d 70 6c sstate ;; compl
4420: 65 74 65 64 20 2d 3e 20 73 73 74 61 74 65 0a 3b eted -> sstate.;
4430: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4440: 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 6c ((completed kil
4450: 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 led killreq stuc
4460: 6b 20 61 72 63 68 69 76 65 64 29 20 63 6f 6d 70 k archived) comp
4470: 6c 65 74 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 leted).;;
4480: 20 20 20 20 20 20 20 20 20 28 28 72 75 6e 6e 69 ((runni
4490: 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 ng remotehoststa
44a0: 72 74 20 6c 61 75 6e 63 68 65 64 29 20 20 20 20 rt launched)
44b0: 20 20 20 20 72 75 6e 6e 69 6e 67 29 0a 3b 3b 20 running).;;
44c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
44d0: 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 else
44e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
44f0: 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 unknow
4500: 6e 2d 65 72 72 6f 72 2d 31 29 29 29 0a 3b 3b 20 n-error-1))).;;
4510: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 72 75 ((ru
4520: 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 nning remotehost
4530: 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 0a start launched).
4540: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
4550: 28 63 61 73 65 20 73 73 74 61 74 65 0a 3b 3b 20 (case sstate.;;
4560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4570: 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 6c 6c 65 (completed kille
4580: 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 d killreq stuck
4590: 61 72 63 68 69 76 65 64 29 20 23 66 29 20 3b 3b archived) #f) ;;
45a0: 20 6e 65 65 64 20 74 6f 20 6c 6f 6f 6b 20 61 74 need to look at
45b0: 20 61 6c 6c 20 69 74 65 6d 73 0a 3b 3b 20 20 20 all items.;;
45c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 72 ((r
45d0: 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 unning remotehos
45e0: 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 tstart launched)
45f0: 20 20 20 20 20 20 20 20 72 75 6e 6e 69 6e 67 29 running)
4600: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4610: 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 (else
4620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 75 6e un
4640: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 32 29 29 29 known-error-2)))
4650: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4660: 28 65 6c 73 65 20 75 6e 6b 6e 6f 77 6e 2d 65 72 (else unknown-er
4670: 72 6f 72 2d 33 29 29 29 0a 3b 3b 20 20 20 20 20 ror-3))).;;
4680: 28 73 65 74 21 20 6e 73 74 61 74 75 73 0a 3b 3b (set! nstatus.;;
4690: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 65 (case
46a0: 20 73 73 74 61 74 75 73 0a 3b 3b 20 20 20 20 20 sstatus.;;
46b0: 20 20 20 20 20 20 20 20 28 28 70 61 73 73 29 0a ((pass).
46c0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
46d0: 28 63 61 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 (case nstate.;;
46e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
46f0: 28 70 61 73 73 20 6e 2f 61 20 64 65 6c 65 74 65 (pass n/a delete
4700: 64 29 20 20 20 20 20 70 61 73 73 29 0a 3b 3b 20 d) pass).;;
4710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4720: 28 77 61 72 6e 29 20 20 20 20 20 20 20 20 20 20 (warn)
4730: 20 20 20 20 20 20 20 77 61 72 6e 29 0a 3b 3b 20 warn).;;
4740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4750: 28 66 61 69 6c 29 20 20 20 20 20 20 20 20 20 20 (fail)
4760: 20 20 20 20 20 20 20 66 61 69 6c 29 0a 3b 3b 20 fail).;;
4770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4780: 28 63 68 65 63 6b 29 20 20 20 20 20 20 20 20 20 (check)
4790: 20 20 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b 20 check).;;
47a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
47b0: 28 77 61 69 76 65 64 29 20 20 20 20 20 20 20 20 (waived)
47c0: 20 20 20 20 20 77 61 69 76 65 64 29 0a 3b 3b 20 waived).;;
47d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
47e0: 28 73 6b 69 70 29 20 20 20 20 20 20 20 20 20 20 (skip)
47f0: 20 20 20 20 20 20 20 73 6b 69 70 29 0a 3b 3b 20 skip).;;
4800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4810: 28 73 74 75 63 6b 2f 64 65 61 64 29 20 20 20 20 (stuck/dead)
4820: 20 20 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b 20 stuck).;;
4830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4840: 28 61 62 6f 72 74 29 20 20 20 20 20 20 20 20 20 (abort)
4850: 20 20 20 20 20 20 61 62 6f 72 74 29 0a 3b 3b 20 abort).;;
4860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4870: 65 6c 73 65 20 20 20 20 20 20 20 20 75 6e 6b 6e else unkn
4880: 6f 77 6e 2d 65 72 72 6f 72 2d 34 29 29 29 0a 3b own-error-4))).;
4890: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ; ((
48a0: 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 warn).;;
48b0: 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 74 61 (case nsta
48c0: 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 te.;;
48d0: 20 20 20 20 20 28 28 70 61 73 73 20 77 61 72 6e ((pass warn
48e0: 20 6e 2f 61 20 73 6b 69 70 20 64 65 6c 65 74 65 n/a skip delete
48f0: 64 29 20 20 20 77 61 72 6e 29 0a 3b 3b 20 20 20 d) warn).;;
4900: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 66 ((f
4910: 61 69 6c 29 20 20 20 20 20 20 20 20 20 20 20 20 ail)
4920: 20 20 20 20 20 20 20 20 20 20 20 20 20 66 61 69 fai
4930: 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 l).;;
4940: 20 20 20 20 20 28 28 63 68 65 63 6b 29 20 20 20 ((check)
4950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4960: 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b 20 20 20 check).;;
4970: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 77 ((w
4980: 61 69 76 65 64 29 20 20 20 20 20 20 20 20 20 20 aived)
4990: 20 20 20 20 20 20 20 20 20 20 20 77 61 69 76 65 waive
49a0: 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 d).;;
49b0: 20 20 20 20 20 28 28 73 74 75 63 6b 2f 64 65 61 ((stuck/dea
49c0: 64 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d)
49d0: 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b 20 20 20 stuck).;;
49e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
49f0: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
4a00: 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d unknown-error-
4a10: 35 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 5))).;;
4a20: 20 20 20 20 28 28 66 61 69 6c 29 0a 3b 3b 20 20 ((fail).;;
4a30: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 (cas
4a40: 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 e nstate.;;
4a50: 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 73 ((pas
4a60: 73 20 77 61 72 6e 20 66 61 69 6c 20 63 68 65 63 s warn fail chec
4a70: 6b 20 6e 2f 61 20 77 61 69 76 65 64 20 73 6b 69 k n/a waived ski
4a80: 70 20 64 65 6c 65 74 65 64 20 73 74 75 63 6b 2f p deleted stuck/
4a90: 64 65 61 64 20 73 74 75 63 6b 29 20 20 66 61 69 dead stuck) fai
4aa0: 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 l).;;
4ab0: 20 20 20 20 20 28 28 61 62 6f 72 74 29 20 20 20 ((abort)
4ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4af0: 20 20 20 20 20 20 61 62 6f 72 74 29 0a 3b 3b 20 abort).;;
4b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4b10: 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 else
4b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b40: 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 unknown-er
4b50: 72 6f 72 2d 36 29 29 29 0a 3b 3b 20 20 20 20 20 ror-6))).;;
4b60: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 (else
4b70: 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 37 unknown-error-7
4b80: 29 29 29 0a 3b 3b 20 20 20 20 20 28 63 6f 6e 73 ))).;; (cons
4b90: 20 0a 3b 3b 20 20 20 20 20 20 28 69 66 20 6e 73 .;; (if ns
4ba0: 74 61 74 65 20 20 28 73 79 6d 62 6f 6c 2d 3e 73 tate (symbol->s
4bb0: 74 72 69 6e 67 20 6e 73 74 61 74 65 29 20 20 6e tring nstate) n
4bc0: 73 74 61 74 65 29 0a 3b 3b 20 20 20 20 20 20 28 state).;; (
4bd0: 69 66 20 6e 73 74 61 74 75 73 20 28 73 79 6d 62 if nstatus (symb
4be0: 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 73 74 61 74 ol->string nstat
4bf0: 75 73 29 20 6e 73 74 61 74 75 73 29 29 29 29 0a us) nstatus)))).
4c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
4c10: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
4c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c50: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 45 20 ========.;; D E
4c60: 42 20 55 20 47 20 47 20 49 20 4e 20 47 20 20 20 B U G G I N G
4c70: 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d S T U F F .;;===
4c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4cc0: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 76 65 ===..(define *ve
4cd0: 72 62 6f 73 69 74 79 2a 20 20 20 20 20 20 20 20 rbosity*
4ce0: 20 31 29 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 67 1).(define *log
4cf0: 67 69 6e 67 2a 20 20 20 20 20 20 20 20 20 20 20 ging*
4d00: 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 #f)..(define (ge
4d10: 74 2d 77 69 74 68 2d 64 65 66 61 75 6c 74 20 76 t-with-default v
4d20: 61 6c 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c al default). (l
4d30: 65 74 20 28 28 76 61 6c 20 28 61 72 67 73 3a 67 et ((val (args:g
4d40: 65 74 2d 61 72 67 20 76 61 6c 29 29 29 0a 20 20 et-arg val))).
4d50: 20 20 28 69 66 20 76 61 6c 20 76 61 6c 20 64 65 (if val val de
4d60: 66 61 75 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e fault)))..(defin
4d70: 65 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 e (assoc/default
4d80: 20 6b 65 79 20 6c 73 74 20 2e 20 64 65 66 61 75 key lst . defau
4d90: 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 lt). (let ((res
4da0: 20 28 61 73 73 6f 63 20 6b 65 79 20 6c 73 74 29 (assoc key lst)
4db0: 29 29 0a 20 20 20 20 28 69 66 20 72 65 73 20 28 )). (if res (
4dc0: 63 61 64 72 20 72 65 73 29 28 69 66 20 28 6e 75 cadr res)(if (nu
4dd0: 6c 6c 3f 20 64 65 66 61 75 6c 74 29 20 23 66 20 ll? default) #f
4de0: 28 63 61 72 20 64 65 66 61 75 6c 74 29 29 29 29 (car default))))
4df0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
4e00: 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 on:get-testsuite
4e10: 2d 6e 61 6d 65 29 0a 20 20 28 6f 72 20 28 63 6f -name). (or (co
4e20: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
4e30: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
4e40: 20 22 74 65 73 74 73 75 69 74 65 22 20 29 0a 20 "testsuite" ).
4e50: 20 20 20 20 20 28 69 66 20 2a 74 6f 70 70 61 74 (if *toppat
4e60: 68 2a 20 0a 20 20 20 20 20 20 20 20 20 20 28 70 h* . (p
4e70: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 2a 74 6f athname-file *to
4e80: 70 70 61 74 68 2a 29 0a 20 20 20 20 20 20 20 20 ppath*).
4e90: 20 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 (pathname-file
4ea0: 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
4eb0: 6f 72 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ory)))))..(defin
4ec0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 e (common:get-db
4ed0: 2d 74 6d 70 2d 61 72 65 61 29 0a 20 20 28 69 66 -tmp-area). (if
4ee0: 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 68 2a *db-cache-path*
4ef0: 0a 20 20 20 20 20 20 2a 64 62 2d 63 61 63 68 65 . *db-cache
4f00: 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 28 6c 65 -path*. (le
4f10: 74 20 28 28 64 62 70 61 74 68 20 28 63 72 65 61 t ((dbpath (crea
4f20: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 28 63 6f te-directory (co
4f30: 6e 63 20 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 nc "/tmp/" (curr
4f40: 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 0a 09 ent-user-name)..
4f50: 09 09 09 09 20 20 20 20 22 2f 6d 65 67 61 74 65 .... "/megate
4f60: 73 74 5f 6c 6f 63 61 6c 64 62 2f 22 0a 09 09 09 st_localdb/"....
4f70: 09 09 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 .. (common:ge
4f80: 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 t-testsuite-name
4f90: 29 20 22 2f 22 0a 09 09 09 09 09 20 20 20 20 28 ) "/"...... (
4fa0: 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 string-translate
4fb0: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 22 20 22 *toppath* "/" "
4fc0: 2e 22 29 29 20 23 74 29 29 29 0a 09 28 73 65 74 .")) #t)))..(set
4fd0: 21 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 68 ! *db-cache-path
4fe0: 2a 20 64 62 70 61 74 68 29 0a 09 64 62 70 61 74 * dbpath)..dbpat
4ff0: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 h)))..(define (c
5000: 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 70 ommon:get-area-p
5010: 61 74 68 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 ath-signature).
5020: 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 (message-digest
5030: 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 -string (md5-pri
5040: 6d 69 74 69 76 65 29 20 2a 74 6f 70 70 61 74 68 mitive) *toppath
5050: 2a 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d *))..;;=========
5060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
50a0: 20 45 20 58 20 49 20 54 20 20 20 48 20 41 20 4e E X I T H A N
50b0: 20 44 20 4c 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d D L I N G.;;===
50c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
50f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5100: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f ===..(define (co
5110: 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 6e 63 3f 29 0a mmon:run-sync?).
5120: 20 20 28 6c 65 74 20 28 28 6f 68 68 20 28 63 6f (let ((ohh (co
5130: 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 mmon:on-homehost
5140: 3f 29 29 0a 09 28 73 72 76 20 28 61 72 67 73 3a ?))..(srv (args:
5150: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
5160: 22 29 29 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 "))). ;; (deb
5170: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
5180: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5190: 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 t* "common:run-s
51a0: 79 6e 63 3f 20 6f 68 68 3d 22 20 6f 68 68 20 22 ync? ohh=" ohh "
51b0: 2c 20 73 72 76 3d 22 20 73 72 76 29 0a 20 20 20 , srv=" srv).
51c0: 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e (and (common:on
51d0: 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 28 61 -homehost?).. (a
51e0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 rgs:get-arg "-se
51f0: 72 76 65 72 22 29 29 29 29 0a 0a 3b 3b 3b 3b 20 rver"))))..;;;;
5200: 72 75 6e 2d 69 64 73 0a 3b 3b 20 20 20 20 69 66 run-ids.;; if
5210: 20 23 66 20 75 73 65 20 2a 64 62 2d 6c 6f 63 61 #f use *db-loca
5220: 6c 2d 73 79 6e 63 2a 20 3a 20 6f 72 20 27 6c 6f l-sync* : or 'lo
5230: 63 61 6c 2d 73 79 6e 63 2d 66 6c 61 67 73 0a 3b cal-sync-flags.;
5240: 3b 20 20 20 20 69 66 20 23 74 20 75 73 65 20 74 ; if #t use t
5250: 69 6d 65 73 74 61 6d 70 73 20 20 20 20 20 20 3a imestamps :
5260: 20 6f 72 20 27 74 69 6d 65 73 74 61 6d 70 73 0a or 'timestamps.
5270: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
5280: 73 79 6e 63 2d 74 6f 2d 6d 65 67 61 74 65 73 74 sync-to-megatest
5290: 2e 64 62 20 64 62 73 74 72 75 63 74 29 20 0a 20 .db dbstruct) .
52a0: 20 28 6c 65 74 20 28 28 73 74 61 72 74 2d 74 69 (let ((start-ti
52b0: 6d 65 20 20 20 20 20 20 20 20 20 28 63 75 72 72 me (curr
52c0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 28 ent-seconds))..(
52d0: 72 65 73 20 20 20 20 20 20 20 20 20 20 20 20 20 res
52e0: 20 20 20 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d (db:multi-db-
52f0: 73 79 6e 63 20 64 62 73 74 72 75 63 74 20 27 6e sync dbstruct 'n
5300: 65 77 32 6f 6c 64 29 29 29 0a 20 20 20 20 28 6c ew2old))). (l
5310: 65 74 20 28 28 73 79 6e 63 2d 74 69 6d 65 20 28 et ((sync-time (
5320: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
5330: 64 73 29 20 73 74 61 72 74 2d 74 69 6d 65 29 29 ds) start-time))
5340: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
5350: 72 69 6e 74 2d 69 6e 66 6f 20 33 20 2a 64 65 66 rint-info 3 *def
5360: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5370: 53 79 6e 63 20 6f 66 20 6e 65 77 64 62 20 74 6f Sync of newdb to
5380: 20 6f 6c 64 64 62 20 63 6f 6d 70 6c 65 74 65 64 olddb completed
5390: 20 69 6e 20 22 20 73 79 6e 63 2d 74 69 6d 65 20 in " sync-time
53a0: 22 20 73 65 63 6f 6e 64 73 22 29 0a 20 20 20 20 " seconds").
53b0: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f (if (common:lo
53c0: 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 w-noise-print 30
53d0: 20 22 73 79 6e 63 20 6e 65 77 20 74 6f 20 6f 6c "sync new to ol
53e0: 64 22 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 d").. (debug:pr
53f0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
5400: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 ult-log-port* "S
5410: 79 6e 63 20 6f 66 20 6e 65 77 64 62 20 74 6f 20 ync of newdb to
5420: 6f 6c 64 64 62 20 63 6f 6d 70 6c 65 74 65 64 20 olddb completed
5430: 69 6e 20 22 20 73 79 6e 63 2d 74 69 6d 65 20 22 in " sync-time "
5440: 20 73 65 63 6f 6e 64 73 22 29 29 29 0a 20 20 20 seconds"))).
5450: 20 72 65 73 29 29 0a 0a 3b 3b 20 63 75 72 72 65 res))..;; curre
5460: 6e 74 6c 79 20 74 68 65 20 70 72 69 6d 61 72 79 ntly the primary
5470: 20 6a 6f 62 20 6f 66 20 74 68 65 20 77 61 74 63 job of the watc
5480: 68 64 6f 67 20 69 73 20 74 6f 20 72 75 6e 20 74 hdog is to run t
5490: 68 65 20 73 79 6e 63 20 62 61 63 6b 20 74 6f 20 he sync back to
54a0: 6d 65 67 61 74 65 73 74 2e 64 62 20 66 72 6f 6d megatest.db from
54b0: 20 74 68 65 20 64 62 20 69 6e 20 2f 74 6d 70 0a the db in /tmp.
54c0: 3b 3b 20 69 66 20 77 65 20 61 72 65 20 6f 6e 20 ;; if we are on
54d0: 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 61 6e 64 the homehost and
54e0: 20 77 65 20 61 72 65 20 61 20 73 65 72 76 65 72 we are a server
54f0: 20 28 62 79 20 64 65 66 69 6e 69 74 69 6f 6e 20 (by definition
5500: 77 65 20 61 72 65 20 6f 6e 20 74 68 65 20 68 6f we are on the ho
5510: 6d 65 68 6f 73 74 20 69 66 20 77 65 20 61 72 65 mehost if we are
5520: 20 61 20 73 65 72 76 65 72 29 0a 3b 3b 0a 28 64 a server).;;.(d
5530: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 efine (common:wa
5540: 74 63 68 64 6f 67 29 0a 20 20 28 74 68 72 65 61 tchdog). (threa
5550: 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 20 3b d-sleep! 0.05) ;
5560: 3b 20 64 65 6c 61 79 20 66 6f 72 20 73 74 61 72 ; delay for star
5570: 74 75 70 0a 20 20 28 6c 65 74 20 28 28 6c 65 67 tup. (let ((leg
5580: 61 63 79 2d 73 79 6e 63 20 28 63 6f 6d 6d 6f 6e acy-sync (common
5590: 3a 72 75 6e 2d 73 79 6e 63 3f 29 29 0a 09 28 64 :run-sync?))..(d
55a0: 65 62 75 67 2d 6d 6f 64 65 20 20 28 64 65 62 75 ebug-mode (debu
55b0: 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 29 g:debug-mode 1))
55c0: 0a 09 28 6c 61 73 74 2d 74 69 6d 65 20 20 20 28 ..(last-time (
55d0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
55e0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
55f0: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
5600: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
5610: 61 74 63 68 64 6f 67 20 73 74 61 72 74 69 6e 67 atchdog starting
5620: 2e 20 6c 65 67 61 63 79 2d 73 79 6e 63 20 69 73 . legacy-sync is
5630: 20 22 20 6c 65 67 61 63 79 2d 73 79 6e 63 29 0a " legacy-sync).
5640: 20 20 20 20 28 69 66 20 6c 65 67 61 63 79 2d 73 (if legacy-s
5650: 79 6e 63 0a 09 28 6c 65 74 20 28 28 64 62 73 74 ync..(let ((dbst
5660: 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 29 29 ruct (db:setup))
5670: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
5680: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5690: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 t-log-port* "Ser
56a0: 76 65 72 20 72 75 6e 6e 69 6e 67 2c 20 70 65 72 ver running, per
56b0: 69 6f 64 69 63 20 73 79 6e 63 20 73 74 61 72 74 iodic sync start
56c0: 65 64 2e 22 29 0a 09 20 20 28 6c 65 74 20 6c 6f ed.").. (let lo
56d0: 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b 20 73 79 op ().. ;; sy
56e0: 6e 63 20 66 6f 72 20 66 69 6c 65 73 79 73 74 65 nc for filesyste
56f0: 6d 20 6c 6f 63 61 6c 20 64 62 20 77 72 69 74 65 m local db write
5700: 73 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 s.. ;;.. (
5710: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
5720: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
5730: 2a 29 0a 09 20 20 20 20 28 6c 65 74 2a 20 28 28 *).. (let* ((
5740: 6e 65 65 64 2d 73 79 6e 63 20 20 20 20 20 20 20 need-sync
5750: 20 28 3e 3d 20 2a 64 62 2d 6c 61 73 74 2d 77 72 (>= *db-last-wr
5760: 69 74 65 2a 20 2a 64 62 2d 6c 61 73 74 2d 73 79 ite* *db-last-sy
5770: 6e 63 2a 29 29 20 3b 3b 20 6e 6f 20 73 79 6e 63 nc*)) ;; no sync
5780: 20 73 69 6e 63 65 20 6c 61 73 74 20 77 72 69 74 since last writ
5790: 65 0a 09 09 20 20 20 28 73 79 6e 63 2d 69 6e 2d e... (sync-in-
57a0: 70 72 6f 67 72 65 73 73 20 2a 64 62 2d 73 79 6e progress *db-syn
57b0: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 29 0a c-in-progress*).
57c0: 09 09 20 20 20 28 73 68 6f 75 6c 64 2d 73 79 6e .. (should-syn
57d0: 63 20 20 20 20 20 20 28 3e 20 28 2d 20 28 63 75 c (> (- (cu
57e0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a rrent-seconds) *
57f0: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 20 35 db-last-sync*) 5
5800: 29 29 20 3b 3b 20 73 79 6e 63 20 65 76 65 72 79 )) ;; sync every
5810: 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 6d 69 five seconds mi
5820: 6e 69 6d 75 6d 0a 09 09 20 20 20 28 77 69 6c 6c nimum... (will
5830: 2d 73 79 6e 63 20 20 20 20 20 20 20 20 28 61 6e -sync (an
5840: 64 20 28 6f 72 20 6e 65 65 64 2d 73 79 6e 63 20 d (or need-sync
5850: 73 68 6f 75 6c 64 2d 73 79 6e 63 29 0a 09 09 09 should-sync)....
5860: 09 09 20 20 28 6e 6f 74 20 73 79 6e 63 2d 69 6e .. (not sync-in
5870: 2d 70 72 6f 67 72 65 73 73 29 29 29 0a 09 09 20 -progress)))...
5880: 20 20 28 73 74 61 72 74 2d 74 69 6d 65 20 20 20 (start-time
5890: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (current-sec
58a0: 6f 6e 64 73 29 29 29 0a 09 20 20 20 20 20 20 3b onds))).. ;
58b0: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ; (debug:print-i
58c0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
58d0: 6f 67 2d 70 6f 72 74 2a 20 22 6e 65 65 64 2d 73 og-port* "need-s
58e0: 79 6e 63 3a 20 22 20 6e 65 65 64 2d 73 79 6e 63 ync: " need-sync
58f0: 20 22 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 " sync-in-progr
5900: 65 73 73 3a 20 22 20 73 79 6e 63 2d 69 6e 2d 70 ess: " sync-in-p
5910: 72 6f 67 72 65 73 73 20 22 20 73 68 6f 75 6c 64 rogress " should
5920: 2d 73 79 6e 63 3a 20 22 20 73 68 6f 75 6c 64 2d -sync: " should-
5930: 73 79 6e 63 20 22 20 77 69 6c 6c 2d 73 79 6e 63 sync " will-sync
5940: 3a 20 22 20 77 69 6c 6c 2d 73 79 6e 63 29 0a 09 : " will-sync)..
5950: 20 20 20 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 (if will-s
5960: 79 6e 63 20 28 73 65 74 21 20 2a 64 62 2d 73 79 ync (set! *db-sy
5970: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 nc-in-progress*
5980: 23 74 29 29 0a 09 20 20 20 20 20 20 28 6d 75 74 #t)).. (mut
5990: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d ex-unlock! *db-m
59a0: 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a ulti-sync-mutex*
59b0: 29 0a 09 20 20 20 20 20 20 28 69 66 20 77 69 6c ).. (if wil
59c0: 6c 2d 73 79 6e 63 0a 09 09 20 20 28 6c 65 74 20 l-sync... (let
59d0: 28 28 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a 73 79 ((res (common:sy
59e0: 6e 63 2d 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 nc-to-megatest.d
59f0: 62 20 64 62 73 74 72 75 63 74 29 29 29 20 3b 3b b dbstruct))) ;;
5a00: 20 64 69 64 20 77 65 20 73 79 6e 63 20 61 6e 79 did we sync any
5a10: 20 64 61 74 61 3f 20 49 66 20 73 6f 20 6e 65 65 data? If so nee
5a20: 64 20 74 6f 20 73 65 74 20 74 68 65 20 64 62 20 d to set the db
5a30: 74 6f 75 63 68 65 64 20 66 6c 61 67 20 74 6f 20 touched flag to
5a40: 6b 65 65 70 20 74 68 65 20 73 65 72 76 65 72 20 keep the server
5a50: 61 6c 69 76 65 0a 09 09 20 20 20 20 28 69 66 20 alive... (if
5a60: 28 3e 20 72 65 73 20 30 29 20 3b 3b 20 73 6f 6d (> res 0) ;; som
5a70: 65 20 72 65 63 6f 72 64 73 20 77 65 72 65 20 74 e records were t
5a80: 72 61 6e 73 66 65 72 72 65 64 2c 20 6b 65 65 70 ransferred, keep
5a90: 20 74 68 65 20 64 62 20 61 6c 69 76 65 0a 09 09 the db alive...
5aa0: 09 28 62 65 67 69 6e 0a 09 09 09 20 20 28 6d 75 .(begin.... (mu
5ab0: 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 tex-lock! *heart
5ac0: 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 beat-mutex*)....
5ad0: 20 20 28 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 (set! *db-last
5ae0: 2d 61 63 63 65 73 73 2a 20 28 63 75 72 72 65 6e -access* (curren
5af0: 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 09 20 t-seconds))....
5b00: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
5b10: 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 74 65 78 *heartbeat-mutex
5b20: 2a 29 0a 09 09 09 20 20 28 64 65 62 75 67 3a 70 *).... (debug:p
5b30: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
5b40: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5b50: 73 79 6e 63 20 63 61 6c 6c 65 64 2c 20 22 20 72 sync called, " r
5b60: 65 73 20 22 20 72 65 63 6f 72 64 73 20 74 72 61 es " records tra
5b70: 6e 73 66 65 72 72 65 64 2e 22 29 29 0a 09 09 09 nsferred."))....
5b80: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5b90: 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 2 *default-log
5ba0: 2d 70 6f 72 74 2a 20 22 73 79 6e 63 20 63 61 6c -port* "sync cal
5bb0: 6c 65 64 20 62 75 74 20 7a 65 72 6f 20 72 65 63 led but zero rec
5bc0: 6f 72 64 73 20 74 72 61 6e 73 66 65 72 72 65 64 ords transferred
5bd0: 22 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 ")))).. (if
5be0: 20 77 69 6c 6c 2d 73 79 6e 63 0a 09 09 20 20 28 will-sync... (
5bf0: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 6d 75 74 begin... (mut
5c00: 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c ex-lock! *db-mul
5c10: 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a ti-sync-mutex*).
5c20: 09 09 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d .. (set! *db-
5c30: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
5c40: 2a 20 23 66 29 0a 09 09 20 20 20 20 28 73 65 74 * #f)... (set
5c50: 21 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a ! *db-last-sync*
5c60: 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 09 09 20 start-time)...
5c70: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
5c80: 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 ! *db-multi-sync
5c90: 2d 6d 75 74 65 78 2a 29 29 29 0a 09 20 20 20 20 -mutex*)))..
5ca0: 20 20 28 69 66 20 28 61 6e 64 20 64 65 62 75 67 (if (and debug
5cb0: 2d 6d 6f 64 65 0a 09 09 20 20 20 20 20 20 20 28 -mode... (
5cc0: 3e 20 28 2d 20 73 74 61 72 74 2d 74 69 6d 65 20 > (- start-time
5cd0: 6c 61 73 74 2d 74 69 6d 65 29 20 36 30 29 29 0a last-time) 60)).
5ce0: 09 09 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 .. (begin...
5cf0: 20 28 73 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 (set! last-time
5d00: 20 73 74 61 72 74 2d 74 69 6d 65 29 0a 09 09 20 start-time)...
5d10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
5d20: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
5d30: 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 69 6d 65 73 log-port* "times
5d40: 74 61 6d 70 20 2d 3e 20 22 20 28 73 65 63 6f 6e tamp -> " (secon
5d50: 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 ds->time-string
5d60: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
5d70: 29 29 20 22 2c 20 74 69 6d 65 20 73 69 6e 63 65 )) ", time since
5d80: 20 73 74 61 72 74 20 2d 3e 20 22 20 28 73 65 63 start -> " (sec
5d90: 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 onds->hr-min-sec
5da0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
5db0: 6f 6e 64 73 29 20 2a 74 69 6d 65 2d 7a 65 72 6f onds) *time-zero
5dc0: 2a 29 29 29 29 29 29 0a 09 20 20 20 20 0a 09 20 *)))))).. ..
5dd0: 20 20 20 3b 3b 20 6b 65 65 70 20 67 6f 69 6e 67 ;; keep going
5de0: 20 75 6e 6c 65 73 73 20 74 69 6d 65 20 74 6f 20 unless time to
5df0: 65 78 69 74 0a 09 20 20 20 20 3b 3b 0a 09 20 20 exit.. ;;..
5e00: 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 69 6d 65 (if (not *time
5e10: 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 09 28 6c 65 -to-exit*)...(le
5e20: 74 20 64 65 6c 61 79 2d 6c 6f 6f 70 20 28 28 63 t delay-loop ((c
5e30: 6f 75 6e 74 20 30 29 29 0a 09 09 20 20 28 69 66 ount 0))... (if
5e40: 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d 65 (and (not *time
5e50: 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 09 09 20 20 -to-exit*)....
5e60: 20 28 3c 20 63 6f 75 6e 74 20 34 29 29 20 3b 3b (< count 4)) ;;
5e70: 20 77 61 73 20 31 31 2c 20 63 68 61 6e 67 69 6e was 11, changin
5e80: 67 20 74 6f 20 34 2e 20 0a 09 09 20 20 20 20 20 g to 4. ...
5e90: 20 28 62 65 67 69 6e 0a 09 09 09 28 74 68 72 65 (begin....(thre
5ea0: 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 09 09 ad-sleep! 1)....
5eb0: 28 64 65 6c 61 79 2d 6c 6f 6f 70 20 28 2b 20 63 (delay-loop (+ c
5ec0: 6f 75 6e 74 20 31 29 29 29 29 0a 09 09 20 20 28 ount 1))))... (
5ed0: 6c 6f 6f 70 29 29 29 0a 09 20 20 20 20 28 69 66 loop))).. (if
5ee0: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
5ef0: 73 65 2d 70 72 69 6e 74 20 33 30 29 0a 09 09 28 se-print 30)...(
5f00: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5f10: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
5f20: 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 77 port* "Exiting w
5f30: 61 74 63 68 64 6f 67 20 74 69 6d 65 72 2c 20 2a atchdog timer, *
5f40: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3d 20 time-to-exit* =
5f50: 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a " *time-to-exit*
5f60: 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 )))))))..(define
5f70: 20 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 (std-exit-proce
5f80: 64 75 72 65 29 0a 20 20 0a 20 20 28 6c 65 74 20 dure). . (let
5f90: 28 28 6e 6f 2d 68 75 72 72 79 20 20 28 69 66 20 ((no-hurry (if
5fa0: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3b *time-to-exit* ;
5fb0: 3b 20 68 75 72 72 79 20 75 70 0a 09 09 20 20 20 ; hurry up...
5fc0: 20 20 20 20 23 66 0a 09 09 20 20 20 20 20 20 20 #f...
5fd0: 28 62 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 (begin.... (set!
5fe0: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 *time-to-exit*
5ff0: 23 74 29 0a 09 09 09 20 23 74 29 29 29 29 0a 20 #t).... #t)))).
6000: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
6010: 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d info 4 *default-
6020: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 61 72 74 log-port* "start
6030: 69 6e 67 20 65 78 69 74 20 70 72 6f 63 65 73 73 ing exit process
6040: 2c 20 66 69 6e 61 6c 69 7a 69 6e 67 20 64 61 74 , finalizing dat
6050: 61 62 61 73 65 73 2e 22 29 0a 20 20 20 20 28 69 abases."). (i
6060: 66 20 28 61 6e 64 20 6e 6f 2d 68 75 72 72 79 20 f (and no-hurry
6070: 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 (debug:debug-mod
6080: 65 20 31 38 29 29 0a 09 28 72 6d 74 3a 70 72 69 e 18))..(rmt:pri
6090: 6e 74 2d 64 62 2d 73 74 61 74 73 29 29 0a 20 20 nt-db-stats)).
60a0: 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 (let ((th1 (ma
60b0: 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 ke-thread (lambd
60c0: 61 20 28 29 20 3b 3b 20 74 68 72 65 61 64 20 66 a () ;; thread f
60d0: 6f 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 2c 20 or cleaning up,
60e0: 67 69 76 65 20 69 74 20 66 69 76 65 20 73 65 63 give it five sec
60f0: 6f 6e 64 73 0a 09 09 09 20 20 20 20 20 20 28 69 onds.... (i
6100: 66 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 20 f *dbstruct-db*
6110: 28 64 62 3a 63 6c 6f 73 65 2d 61 6c 6c 20 2a 64 (db:close-all *d
6120: 62 73 74 72 75 63 74 2d 64 62 2a 29 29 20 3b 3b bstruct-db*)) ;;
6130: 20 6f 6e 65 20 73 65 63 6f 6e 64 20 61 6c 6c 6f one second allo
6140: 63 61 74 65 64 0a 09 09 09 20 20 20 20 20 20 28 cated.... (
6150: 69 66 20 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 if *task-db*
6160: 0a 09 09 09 09 20 20 28 6c 65 74 20 28 28 64 62 ..... (let ((db
6170: 20 28 63 64 72 20 2a 74 61 73 6b 2d 64 62 2a 29 (cdr *task-db*)
6180: 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 20 28 ))..... (if (
6190: 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 73 65 sqlite3:database
61a0: 3f 20 64 62 29 0a 09 09 09 09 09 28 62 65 67 69 ? db)......(begi
61b0: 6e 0a 09 09 09 09 09 20 20 28 73 71 6c 69 74 65 n...... (sqlite
61c0: 33 3a 69 6e 74 65 72 72 75 70 74 21 20 64 62 29 3:interrupt! db)
61d0: 0a 09 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 ...... (sqlite3
61e0: 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 20 23 74 :finalize! db #t
61f0: 29 0a 09 09 09 09 09 20 20 3b 3b 20 28 76 65 63 )...... ;; (vec
6200: 74 6f 72 2d 73 65 74 21 20 2a 74 61 73 6b 2d 64 tor-set! *task-d
6210: 62 2a 20 30 20 23 66 29 0a 09 09 09 09 09 20 20 b* 0 #f)......
6220: 28 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 (set! *task-db*
6230: 23 66 29 29 29 29 29 0a 09 09 09 20 20 20 20 20 #f)))))....
6240: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
6250: 6f 72 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 ort *default-log
6260: 2d 70 6f 72 74 2a 29 0a 09 09 09 20 20 20 20 20 -port*)....
6270: 20 28 73 65 74 21 20 2a 64 65 66 61 75 6c 74 2d (set! *default-
6280: 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 65 log-port* (curre
6290: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 nt-error-port)))
62a0: 20 22 43 6c 65 61 6e 75 70 20 64 62 20 65 78 69 "Cleanup db exi
62b0: 74 20 74 68 72 65 61 64 22 29 29 0a 09 20 20 28 t thread")).. (
62c0: 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th2 (make-thread
62d0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
62e0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
62f0: 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 4 *default-log
6300: 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d 70 74 69 -port* "Attempti
6310: 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e 20 50 ng clean exit. P
6320: 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 6e 74 lease be patient
6330: 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 77 20 and wait a few
6340: 73 65 63 6f 6e 64 73 2e 2e 2e 22 29 0a 09 09 09 seconds...")....
6350: 20 20 20 20 20 20 28 69 66 20 6e 6f 2d 68 75 72 (if no-hur
6360: 72 79 0a 09 09 09 09 20 20 28 74 68 72 65 61 64 ry..... (thread
6370: 2d 73 6c 65 65 70 21 20 35 29 20 3b 3b 20 67 69 -sleep! 5) ;; gi
6380: 76 65 20 74 68 65 20 63 6c 65 61 6e 20 75 70 20 ve the clean up
6390: 66 65 77 20 73 65 63 6f 6e 64 73 20 74 6f 20 64 few seconds to d
63a0: 6f 20 69 74 27 73 20 73 74 75 66 66 0a 09 09 09 o it's stuff....
63b0: 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 . (thread-sleep
63c0: 21 20 32 29 29 0a 09 09 09 20 20 20 20 20 20 28 ! 2)).... (
63d0: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
63e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
63f0: 20 22 20 2e 2e 2e 20 64 6f 6e 65 22 29 0a 09 09 " ... done")...
6400: 09 20 20 20 20 20 20 29 0a 09 09 09 20 20 20 20 . )....
6410: 22 63 6c 65 61 6e 20 65 78 69 74 22 29 29 29 0a "clean exit"))).
6420: 0a 20 20 20 20 20 20 3b 3b 20 6c 65 74 27 73 20 . ;; let's
6430: 74 72 79 20 74 6f 20 63 6c 65 61 6e 20 75 70 20 try to clean up
6440: 6f 70 65 6e 20 73 6f 63 6b 65 74 73 0a 20 20 20 open sockets.
6450: 20 20 20 28 69 66 20 2a 72 75 6e 72 65 6d 6f 74 (if *runremot
6460: 65 2a 0a 20 20 20 20 20 20 20 20 20 20 28 63 61 e*. (ca
6470: 73 65 20 28 72 65 6d 6f 74 65 2d 74 72 61 6e 73 se (remote-trans
6480: 70 6f 72 74 20 2a 72 75 6e 72 65 6d 6f 74 65 2a port *runremote*
6490: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ). ((
64a0: 68 74 74 70 29 20 23 74 29 0a 20 20 20 20 20 20 http) #t).
64b0: 20 20 20 20 20 20 28 28 72 70 63 29 20 20 28 72 ((rpc) (r
64c0: 70 63 3a 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e pc:close-all-con
64d0: 6e 65 63 74 69 6f 6e 73 21 29 29 0a 20 20 20 20 nections!)).
64e0: 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 (else.
64f0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
6500: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
6510: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6520: 2a 20 22 54 72 61 6e 73 70 6f 72 74 20 22 28 72 * "Transport "(r
6530: 65 6d 6f 74 65 2d 74 72 61 6e 73 70 6f 72 74 20 emote-transport
6540: 2a 72 75 6e 72 65 6d 6f 74 65 2a 29 22 20 6e 6f *runremote*)" no
6550: 74 20 73 75 70 70 6f 72 74 65 64 22 29 29 29 29 t supported"))))
6560: 0a 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d .. (thread-
6570: 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 start! th1).
6580: 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 (thread-start!
6590: 20 74 68 32 29 0a 20 20 20 20 20 20 28 74 68 72 th2). (thr
65a0: 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 29 29 ead-join! th1)))
65b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d )..(define (std-
65c0: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 signal-handler s
65d0: 69 67 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 ignum). ;; (sig
65e0: 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d nal-mask! signum
65f0: 29 0a 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d ). (set! *time-
6600: 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 28 to-exit* #t). (
6610: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
6620: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
6630: 2d 70 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 -port* "Received
6640: 20 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d signal " signum
6650: 20 22 20 65 78 69 74 69 6e 67 20 70 72 6f 6d 70 " exiting promp
6660: 74 6c 79 22 29 0a 20 20 3b 3b 20 28 73 74 64 2d tly"). ;; (std-
6670: 65 78 69 74 2d 70 72 6f 63 65 64 75 72 65 29 20 exit-procedure)
6680: 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 20 6e 65 65 ;; shouldn't nee
6690: 64 20 74 68 69 73 20 73 69 6e 63 65 20 77 65 20 d this since we
66a0: 61 72 65 20 65 78 69 74 69 6e 67 20 61 6e 64 20 are exiting and
66b0: 69 74 20 77 69 6c 6c 20 62 65 20 63 61 6c 6c 65 it will be calle
66c0: 64 20 61 6e 79 77 61 79 0a 20 20 28 65 78 69 74 d anyway. (exit
66d0: 29 29 0a 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d ))..(set-signal-
66e0: 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f handler! signal/
66f0: 69 6e 74 20 20 73 74 64 2d 73 69 67 6e 61 6c 2d int std-signal-
6700: 68 61 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 43 0a handler) ;; ^C.
6710: 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 (set-signal-hand
6720: 6c 65 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 6d ler! signal/term
6730: 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 std-signal-hand
6740: 6c 65 72 29 0a 3b 3b 20 28 73 65 74 2d 73 69 67 ler).;; (set-sig
6750: 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 nal-handler! sig
6760: 6e 61 6c 2f 73 74 6f 70 20 73 74 64 2d 73 69 67 nal/stop std-sig
6770: 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b nal-handler) ;;
6780: 20 5e 5a 20 4e 4f 2c 20 64 6f 20 4e 4f 54 20 68 ^Z NO, do NOT h
6790: 61 6e 64 6c 65 20 5e 5a 21 0a 0a 3b 3b 3d 3d 3d andle ^Z!..;;===
67a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
67b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
67c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
67d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
67e0: 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 43 20 20 ===.;; M I S C
67f0: 20 55 20 54 20 49 20 4c 20 53 0a 3b 3b 3d 3d 3d U T I L S.;;===
6800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6840: 3d 3d 3d 0a 0a 3b 3b 20 6f 6e 65 2d 6f 66 20 61 ===..;; one-of a
6850: 72 67 73 20 64 65 66 69 6e 65 64 0a 28 64 65 66 rgs defined.(def
6860: 69 6e 65 20 28 61 72 67 73 2d 64 65 66 69 6e 65 ine (args-define
6870: 64 3f 20 2e 20 70 61 72 61 6d 29 0a 20 20 28 6c d? . param). (l
6880: 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 et ((res #f)).
6890: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
68a0: 20 20 28 6c 61 6d 62 64 61 20 28 61 72 67 29 0a (lambda (arg).
68b0: 20 20 20 20 20 20 20 28 69 66 20 28 61 72 67 73 (if (args
68c0: 3a 67 65 74 2d 61 72 67 20 61 72 67 29 28 73 65 :get-arg arg)(se
68d0: 74 21 20 72 65 73 20 23 74 29 29 29 0a 20 20 20 t! res #t))).
68e0: 20 20 70 61 72 61 6d 29 0a 20 20 20 20 72 65 73 param). res
68f0: 29 29 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 73 ))..;; convert s
6900: 74 75 66 66 20 74 6f 20 61 20 6e 75 6d 62 65 72 tuff to a number
6910: 20 69 66 20 70 6f 73 73 69 62 6c 65 0a 28 64 65 if possible.(de
6920: 66 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 fine (any->numbe
6930: 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 20 0a r val). (cond .
6940: 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c ((number? val
6950: 29 20 76 61 6c 29 0a 20 20 20 28 28 73 74 72 69 ) val). ((stri
6960: 6e 67 3f 20 76 61 6c 29 20 28 73 74 72 69 6e 67 ng? val) (string
6970: 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 ->number val)).
6980: 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 ((symbol? val)
6990: 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 73 (any->number (s
69a0: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 ymbol->string va
69b0: 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 20 23 66 l))). (else #f
69c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 6e )))..(define (an
69d0: 79 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 6f 73 y->number-if-pos
69e0: 73 69 62 6c 65 20 76 61 6c 29 0a 20 20 28 6c 65 sible val). (le
69f0: 74 20 28 28 6e 75 6d 20 28 61 6e 79 2d 3e 6e 75 t ((num (any->nu
6a00: 6d 62 65 72 20 76 61 6c 29 29 29 0a 20 20 20 20 mber val))).
6a10: 28 69 66 20 6e 75 6d 20 6e 75 6d 20 76 61 6c 29 (if num num val)
6a20: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 74 ))..(define (pat
6a30: 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 69 74 65 t-list-match ite
6a40: 6d 20 70 61 74 74 73 29 0a 20 20 28 64 65 62 75 m patts). (debu
6a50: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a g:print-info 8 *
6a60: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6a70: 2a 20 22 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 * "patt-list-mat
6a80: 63 68 20 69 74 65 6d 3d 22 20 69 74 65 6d 20 22 ch item=" item "
6a90: 20 70 61 74 74 73 3d 22 20 70 61 74 74 73 29 0a patts=" patts).
6aa0: 20 20 28 69 66 20 28 61 6e 64 20 69 74 65 6d 20 (if (and item
6ab0: 70 61 74 74 73 29 20 20 3b 3b 20 68 65 72 65 20 patts) ;; here
6ac0: 77 65 20 61 72 65 20 66 69 6c 74 65 72 69 6e 67 we are filtering
6ad0: 20 66 6f 72 20 6d 61 74 63 68 65 73 20 77 69 74 for matches wit
6ae0: 68 20 69 74 65 6d 20 70 61 74 74 65 72 6e 73 0a h item patterns.
6af0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
6b00: 20 23 66 29 29 20 20 20 3b 3b 20 6c 6f 6f 6b 20 #f)) ;; look
6b10: 74 68 72 6f 75 67 68 20 61 6c 6c 20 74 68 65 20 through all the
6b20: 69 74 65 6d 2d 70 61 74 74 73 20 69 66 20 64 65 item-patts if de
6b30: 66 69 6e 65 64 2c 20 66 6f 72 6d 61 74 20 69 73 fined, format is
6b40: 20 70 61 74 74 31 2c 70 61 74 74 32 2c 70 61 74 patt1,patt2,pat
6b50: 74 33 20 2e 2e 2e 20 77 69 6c 64 63 61 72 64 20 t3 ... wildcard
6b60: 69 73 20 25 0a 09 28 66 6f 72 2d 65 61 63 68 20 is %..(for-each
6b70: 0a 09 20 28 6c 61 6d 62 64 61 20 28 70 61 74 74 .. (lambda (patt
6b80: 29 0a 09 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 ).. (let ((mod
6b90: 70 61 74 74 20 28 73 74 72 69 6e 67 2d 73 75 62 patt (string-sub
6ba0: 73 74 69 74 75 74 65 20 22 25 22 20 22 2e 2a 22 stitute "%" ".*"
6bb0: 20 70 61 74 74 20 23 74 29 29 29 0a 09 20 20 20 patt #t)))..
6bc0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6bd0: 6e 66 6f 20 31 30 20 2a 64 65 66 61 75 6c 74 2d nfo 10 *default-
6be0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 20 log-port* "patt
6bf0: 22 20 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 " patt " modpatt
6c00: 20 22 20 6d 6f 64 70 61 74 74 29 0a 09 20 20 20 " modpatt)..
6c10: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
6c20: 74 63 68 20 28 72 65 67 65 78 70 20 6d 6f 64 70 tch (regexp modp
6c30: 61 74 74 29 20 69 74 65 6d 29 0a 09 09 20 28 73 att) item)... (s
6c40: 65 74 21 20 72 65 73 20 23 74 29 29 29 29 0a 09 et! res #t))))..
6c50: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 (string-split p
6c60: 61 74 74 73 20 22 2c 22 29 29 0a 09 72 65 73 29 atts ","))..res)
6c70: 0a 20 20 20 20 20 20 23 74 29 29 0a 0a 3b 3b 20 . #t))..;;
6c80: 28 6d 61 70 20 70 72 69 6e 74 20 28 6d 61 70 20 (map print (map
6c90: 63 61 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d car (hash-table-
6ca0: 3e 61 6c 69 73 74 20 28 72 65 61 64 2d 63 6f 6e >alist (read-con
6cb0: 66 69 67 20 22 72 75 6e 63 6f 6e 66 69 67 73 2e fig "runconfigs.
6cc0: 63 6f 6e 66 69 67 22 20 23 66 20 23 74 29 29 29 config" #f #t)))
6cd0: 29 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ).(define (commo
6ce0: 6e 3a 67 65 74 2d 72 75 6e 63 6f 6e 66 69 67 2d n:get-runconfig-
6cf0: 74 61 72 67 65 74 73 20 23 21 6b 65 79 20 28 63 targets #!key (c
6d00: 6f 6e 66 69 67 66 20 23 66 29 29 0a 20 20 28 6c onfigf #f)). (l
6d10: 65 74 20 28 28 74 61 72 67 73 20 20 20 20 20 20 et ((targs
6d20: 20 28 73 6f 72 74 20 28 6d 61 70 20 63 61 72 20 (sort (map car
6d30: 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
6d40: 73 74 0a 09 09 09 09 20 20 20 20 20 28 6f 72 20 st..... (or
6d50: 63 6f 6e 66 69 67 66 0a 09 09 09 09 09 20 28 72 configf...... (r
6d60: 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 ead-config (conc
6d70: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
6d80: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
6d90: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 20 ....... #f
6da0: 23 74 29 0a 09 09 09 09 09 20 28 6d 61 6b 65 2d #t)...... (make-
6db0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 hash-table))))..
6dc0: 09 09 20 20 20 73 74 72 69 6e 67 3c 3f 29 29 0a .. string<?)).
6dd0: 09 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 61 .(target-patt (a
6de0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
6df0: 72 67 65 74 22 29 29 29 0a 20 20 20 20 28 69 66 rget"))). (if
6e00: 20 74 61 72 67 65 74 2d 70 61 74 74 0a 09 28 66 target-patt..(f
6e10: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
6e20: 29 0a 09 09 20 20 28 70 61 74 74 2d 6c 69 73 74 )... (patt-list
6e30: 2d 6d 61 74 63 68 20 78 20 74 61 72 67 65 74 2d -match x target-
6e40: 70 61 74 74 29 29 0a 09 09 74 61 72 67 73 29 0a patt))...targs).
6e50: 09 74 61 72 67 73 29 29 29 0a 0a 3b 3b 20 27 28 .targs)))..;; '(
6e60: 70 72 69 6e 74 20 28 73 74 72 69 6e 67 2d 69 6e print (string-in
6e70: 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 tersperse (map c
6e80: 61 64 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d adr (hash-table-
6e90: 72 65 66 2f 64 65 66 61 75 6c 74 20 28 72 65 61 ref/default (rea
6ea0: 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 d-config "megate
6eb0: 73 74 2e 63 6f 6e 66 69 67 22 20 5c 23 66 20 5c st.config" \#f \
6ec0: 23 74 29 20 22 64 69 73 6b 73 22 20 27 22 27 22 #t) "disks" '"'"
6ed0: 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 20 22 '("none" ""))) "
6ee0: 5c 6e 22 29 29 27 0a 28 64 65 66 69 6e 65 20 28 \n"))'.(define (
6ef0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 73 common:get-disks
6f00: 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 #!key (configf
6f10: 23 66 29 29 0a 20 20 28 68 61 73 68 2d 74 61 62 #f)). (hash-tab
6f20: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 0a le-ref/default .
6f30: 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 20 28 (or configf (
6f40: 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 read-config "meg
6f50: 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 23 66 atest.config" #f
6f60: 20 23 74 29 29 0a 20 20 20 22 64 69 73 6b 73 22 #t)). "disks"
6f70: 20 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 0a '("none" ""))).
6f80: 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 73 74 .;; return first
6f90: 20 63 6f 6d 6d 61 6e 64 20 74 68 61 74 20 65 78 command that ex
6fa0: 69 73 74 73 2c 20 65 6c 73 65 20 23 66 0a 3b 3b ists, else #f.;;
6fb0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
6fc0: 3a 77 68 69 63 68 20 63 6d 64 73 29 0a 20 20 28 :which cmds). (
6fd0: 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a if (null? cmds).
6fe0: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
6ff0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
7000: 63 61 72 20 63 6d 64 73 29 29 0a 09 09 20 28 74 car cmds))... (t
7010: 61 6c 20 28 63 64 72 20 63 6d 64 73 29 29 29 0a al (cdr cmds))).
7020: 09 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 74 .(let ((res (wit
7030: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
7040: 65 20 28 63 6f 6e 63 20 22 77 68 69 63 68 20 22 e (conc "which "
7050: 20 68 65 64 29 20 72 65 61 64 2d 6c 69 6e 65 29 hed) read-line)
7060: 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 28 )).. (if (and (
7070: 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 string? res)...
7080: 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 (file-exists?
7090: 72 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 73 res)).. res
70a0: 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c .. (if (nul
70b0: 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 l? tal)... #f..
70c0: 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
70d0: 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
70e0: 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 63 )). .(define (c
70f0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c ommon:get-instal
7100: 6c 2d 61 72 65 61 29 0a 20 20 28 6c 65 74 20 28 l-area). (let (
7110: 28 65 78 65 2d 70 61 74 68 20 28 63 61 72 20 28 (exe-path (car (
7120: 61 72 67 76 29 29 29 29 0a 20 20 20 20 28 69 66 argv)))). (if
7130: 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 65 (file-exists? e
7140: 78 65 2d 70 61 74 68 29 0a 09 28 68 61 6e 64 6c xe-path)..(handl
7150: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 65 e-exceptions.. e
7160: 78 6e 0a 09 20 23 66 0a 09 20 28 70 61 74 68 6e xn.. #f.. (pathn
7170: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 0a 09 20 ame-directory..
7180: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
7190: 74 6f 72 79 20 0a 09 20 20 20 28 70 61 74 68 6e tory .. (pathn
71a0: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 65 78 ame-directory ex
71b0: 65 2d 70 61 74 68 29 29 29 29 0a 09 23 66 29 29 e-path))))..#f))
71c0: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 )..;; return fir
71d0: 73 74 20 70 61 74 68 20 74 68 61 74 20 63 61 6e st path that can
71e0: 20 62 65 20 63 72 65 61 74 65 64 20 6f 72 20 61 be created or a
71f0: 6c 72 65 61 64 79 20 65 78 69 73 74 73 20 61 6e lready exists an
7200: 64 20 69 73 20 77 72 69 74 61 62 6c 65 0a 3b 3b d is writable.;;
7210: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
7220: 3a 67 65 74 2d 63 72 65 61 74 65 2d 77 72 69 74 :get-create-writ
7230: 65 61 62 6c 65 2d 64 69 72 20 64 69 72 73 29 0a eable-dir dirs).
7240: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 69 72 (if (null? dir
7250: 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 s). #f.
7260: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
7270: 64 20 28 63 61 72 20 64 69 72 73 29 29 0a 09 09 d (car dirs))...
7280: 20 28 74 61 6c 20 28 63 64 72 20 64 69 72 73 29 (tal (cdr dirs)
7290: 29 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 ))..(let ((res (
72a0: 6f 72 20 28 61 6e 64 20 28 64 69 72 65 63 74 6f or (and (directo
72b0: 72 79 3f 20 68 65 64 29 0a 09 09 09 20 20 20 20 ry? hed)....
72c0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
72d0: 73 73 3f 20 68 65 64 29 0a 09 09 09 20 20 20 20 ss? hed)....
72e0: 68 65 64 29 0a 09 09 20 20 20 20 20 20 20 28 68 hed)... (h
72f0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
7300: 0a 09 09 09 65 78 6e 0a 09 09 09 23 66 0a 09 09 ....exn....#f...
7310: 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f .(create-directo
7320: 72 79 20 68 65 64 20 23 74 29 29 29 29 29 0a 09 ry hed #t)))))..
7330: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
7340: 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 28 64 ng? res)... (d
7350: 69 72 65 63 74 6f 72 79 3f 20 72 65 73 29 29 0a irectory? res)).
7360: 09 20 20 20 20 20 20 72 65 73 0a 09 20 20 20 20 . res..
7370: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
7380: 29 0a 09 09 20 20 23 66 0a 09 09 20 20 28 6c 6f )... #f... (lo
7390: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
73a0: 20 74 61 6c 29 29 29 29 29 29 29 29 0a 20 20 0a tal)))))))). .
73b0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
73c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
73d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
73e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
73f0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 20 ========.;; T A
7400: 52 20 47 20 45 20 54 20 53 20 20 2c 20 20 20 53 R G E T S , S
7410: 20 54 20 41 20 54 20 45 20 2c 20 20 20 53 20 54 T A T E , S T
7420: 20 41 20 54 20 55 20 53 20 2c 20 20 20 0a 3b 3b A T U S , .;;
7430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7440: 20 20 20 20 52 20 55 20 4e 20 4e 20 41 20 4d 20 R U N N A M
7450: 45 20 20 20 20 41 20 4e 20 44 20 20 20 54 20 45 E A N D T E
7460: 20 53 20 54 20 50 20 41 20 54 20 54 0a 3b 3b 3d S T P A T T.;;=
7470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
74b0: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 4c 6f 6f 6b 75 70 =====..;; Lookup
74c0: 20 61 20 76 61 6c 75 65 20 69 6e 20 72 75 6e 63 a value in runc
74d0: 6f 6e 66 69 67 73 20 62 61 73 65 64 20 6f 6e 20 onfigs based on
74e0: 2d 72 65 71 74 61 72 67 20 6f 72 20 2d 74 61 72 -reqtarg or -tar
74f0: 67 65 74 0a 28 64 65 66 69 6e 65 20 28 72 75 6e get.(define (run
7500: 63 6f 6e 66 69 67 73 2d 67 65 74 20 63 6f 6e 66 configs-get conf
7510: 69 67 20 76 61 72 29 0a 20 20 28 6c 65 74 20 28 ig var). (let (
7520: 28 74 61 72 67 20 28 63 6f 6d 6d 6f 6e 3a 61 72 (targ (common:ar
7530: 67 73 2d 67 65 74 2d 74 61 72 67 65 74 29 29 29 gs-get-target)))
7540: 20 3b 3b 20 28 6f 72 20 28 61 72 67 73 3a 67 65 ;; (or (args:ge
7550: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
7560: 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 )(args:get-arg "
7570: 2d 74 61 72 67 65 74 22 29 28 67 65 74 65 6e 76 -target")(getenv
7580: 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 29 29 "MT_TARGET"))))
7590: 0a 20 20 20 20 28 69 66 20 74 61 72 67 0a 09 28 . (if targ..(
75a0: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
75b0: 75 70 20 63 6f 6e 66 69 67 20 74 61 72 67 20 76 up config targ v
75c0: 61 72 29 0a 09 20 20 20 20 28 63 6f 6e 66 69 67 ar).. (config
75d0: 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 f:lookup config
75e0: 22 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 0a "default" var)).
75f0: 09 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 .(configf:lookup
7600: 20 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 config "default
7610: 22 20 76 61 72 29 29 29 29 0a 0a 28 64 65 66 69 " var))))..(defi
7620: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d ne (common:args-
7630: 67 65 74 2d 73 74 61 74 65 29 0a 20 20 28 6f 72 get-state). (or
7640: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7650: 2d 73 74 61 74 65 22 29 28 61 72 67 73 3a 67 65 -state")(args:ge
7660: 74 2d 61 72 67 20 22 3a 73 74 61 74 65 22 29 29 t-arg ":state"))
7670: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
7680: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 on:args-get-stat
7690: 75 73 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a us). (or (args:
76a0: 67 65 74 2d 61 72 67 20 22 2d 73 74 61 74 75 73 get-arg "-status
76b0: 22 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ")(args:get-arg
76c0: 22 3a 73 74 61 74 75 73 22 29 29 29 0a 0a 28 64 ":status")))..(d
76d0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 efine (common:ar
76e0: 67 73 2d 67 65 74 2d 74 65 73 74 70 61 74 74 20 gs-get-testpatt
76f0: 72 63 6f 6e 66 29 0a 20 20 28 6c 65 74 2a 20 28 rconf). (let* (
7700: 28 72 74 65 73 74 70 61 74 74 20 20 20 20 20 28 (rtestpatt (
7710: 69 66 20 72 63 6f 6e 66 20 28 72 75 6e 63 6f 6e if rconf (runcon
7720: 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 20 22 figs-get rconf "
7730: 54 45 53 54 50 41 54 54 22 29 20 23 66 29 29 0a TESTPATT") #f)).
7740: 09 20 28 61 72 67 73 2d 74 65 73 74 70 61 74 74 . (args-testpatt
7750: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
7760: 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 29 0a rg "-testpatt").
7770: 09 09 09 20 20 20 20 28 61 72 67 73 3a 67 65 74 ... (args:get
7780: 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 -arg "-runtests"
7790: 29 0a 09 09 09 20 20 20 20 22 25 22 29 29 0a 09 ).... "%"))..
77a0: 20 28 74 65 73 74 70 61 74 74 20 20 20 20 28 6f (testpatt (o
77b0: 72 20 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 61 r (and (equal? a
77c0: 72 67 73 2d 74 65 73 74 70 61 74 74 20 22 25 22 rgs-testpatt "%"
77d0: 29 0a 09 09 09 20 20 20 20 20 20 20 72 74 65 73 ).... rtes
77e0: 74 70 61 74 74 29 0a 09 09 09 20 20 61 72 67 73 tpatt).... args
77f0: 2d 74 65 73 74 70 61 74 74 29 29 29 0a 20 20 20 -testpatt))).
7800: 20 28 69 66 20 72 74 65 73 74 70 61 74 74 20 28 (if rtestpatt (
7810: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7820: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7830: 70 6f 72 74 2a 20 22 54 45 53 54 50 41 54 54 20 port* "TESTPATT
7840: 66 72 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 3a from runconfigs:
7850: 20 22 20 72 74 65 73 74 70 61 74 74 29 29 0a 20 " rtestpatt)).
7860: 20 20 20 74 65 73 74 70 61 74 74 29 29 0a 0a 28 testpatt))..(
7870: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
7880: 65 74 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 20 28 et-linktree). (
7890: 6f 72 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c or (getenv "MT_L
78a0: 49 4e 4b 54 52 45 45 22 29 0a 20 20 20 20 20 20 INKTREE").
78b0: 28 69 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a (if *configdat*.
78c0: 09 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b . (configf:look
78d0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
78e0: 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 setup" "linktree
78f0: 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 "))))..(define (
7900: 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d common:args-get-
7910: 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 runname). (let
7920: 28 28 72 65 73 20 28 6f 72 20 28 61 72 67 73 3a ((res (or (args:
7930: 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d get-arg "-runnam
7940: 65 22 29 0a 09 09 20 28 61 72 67 73 3a 67 65 74 e")... (args:get
7950: 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 -arg ":runname")
7960: 0a 09 09 20 28 67 65 74 65 6e 76 20 22 4d 54 5f ... (getenv "MT_
7970: 52 55 4e 4e 41 4d 45 22 29 29 29 29 0a 20 20 20 RUNNAME")))).
7980: 20 3b 3b 20 28 69 66 20 72 65 73 20 28 73 65 74 ;; (if res (set
7990: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
79a0: 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 4e 41 4d iable "MT_RUNNAM
79b0: 45 22 20 72 65 73 29 29 20 3b 3b 20 6e 6f 74 20 E" res)) ;; not
79c0: 73 75 72 65 20 69 66 20 74 68 69 73 20 69 73 20 sure if this is
79d0: 61 20 67 6f 6f 64 20 69 64 65 61 2e 20 73 69 64 a good idea. sid
79e0: 65 20 65 66 66 65 63 74 20 61 6e 64 20 61 6c 6c e effect and all
79f0: 20 2e 2e 2e 0a 20 20 20 20 72 65 73 29 29 0a 0a .... res))..
7a00: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
7a10: 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 74 20 args-get-target
7a20: 23 21 6b 65 79 20 28 73 70 6c 69 74 20 23 66 29 #!key (split #f)
7a30: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 ). (let* ((keys
7a40: 20 20 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 (if (hash-ta
7a50: 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 61 74 2a ble? *configdat*
7a60: 29 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 ) (keys:config-g
7a70: 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 et-fields *confi
7a80: 67 64 61 74 2a 29 20 27 28 29 29 29 0a 09 20 28 gdat*) '())).. (
7a90: 6e 75 6d 6b 65 79 73 20 28 6c 65 6e 67 74 68 20 numkeys (length
7aa0: 6b 65 79 73 29 29 0a 09 20 28 74 61 72 67 65 74 keys)).. (target
7ab0: 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d (or (args:get-
7ac0: 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a arg "-reqtarg").
7ad0: 09 09 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 .. (args:ge
7ae0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
7af0: 0a 09 09 20 20 20 20 20 20 28 67 65 74 65 6e 76 ... (getenv
7b00: 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 29 0a "MT_TARGET"))).
7b10: 09 20 28 74 6c 69 73 74 20 20 20 28 69 66 20 74 . (tlist (if t
7b20: 61 72 67 65 74 20 28 73 74 72 69 6e 67 2d 73 70 arget (string-sp
7b30: 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 20 23 lit target "/" #
7b40: 74 29 20 27 28 29 29 29 0a 09 20 28 76 61 6c 69 t) '())).. (vali
7b50: 64 20 20 20 28 69 66 20 74 61 72 67 65 74 0a 09 d (if target..
7b60: 09 20 20 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c . (or (null
7b70: 3f 20 6b 65 79 73 29 20 3b 3b 20 70 72 6f 62 61 ? keys) ;; proba
7b80: 62 6c 79 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 6f bly don't know o
7b90: 75 72 20 6b 65 79 73 20 79 65 74 0a 09 09 09 20 ur keys yet....
7ba0: 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c (and (not (null
7bb0: 3f 20 74 6c 69 73 74 29 29 0a 09 09 09 20 20 20 ? tlist))....
7bc0: 20 20 20 20 28 65 71 3f 20 6e 75 6d 6b 65 79 73 (eq? numkeys
7bd0: 20 28 6c 65 6e 67 74 68 20 74 6c 69 73 74 29 29 (length tlist))
7be0: 0a 09 09 09 20 20 20 20 20 20 20 28 6e 75 6c 6c .... (null
7bf0: 3f 20 28 66 69 6c 74 65 72 20 73 74 72 69 6e 67 ? (filter string
7c00: 2d 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 29 29 29 -null? tlist))))
7c10: 0a 09 09 20 20 20 20 20 20 23 66 29 29 29 0a 20 ... #f))).
7c20: 20 20 20 28 69 66 20 76 61 6c 69 64 0a 09 28 69 (if valid..(i
7c30: 66 20 73 70 6c 69 74 0a 09 20 20 20 20 74 6c 69 f split.. tli
7c40: 73 74 0a 09 20 20 20 20 74 61 72 67 65 74 29 0a st.. target).
7c50: 09 28 69 66 20 74 61 72 67 65 74 0a 09 20 20 20 .(if target..
7c60: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
7c70: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
7c80: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
7c90: 2d 70 6f 72 74 2a 20 22 49 6e 76 61 6c 69 64 20 -port* "Invalid
7ca0: 74 61 72 67 65 74 2c 20 73 70 61 63 65 73 20 6f target, spaces o
7cb0: 72 20 62 6c 61 6e 6b 73 20 6e 6f 74 20 61 6c 6c r blanks not all
7cc0: 6f 77 65 64 20 5c 22 22 20 74 61 72 67 65 74 20 owed \"" target
7cd0: 22 5c 22 2c 20 74 61 72 67 65 74 20 73 68 6f 75 "\", target shou
7ce0: 6c 64 20 62 65 3a 20 22 20 28 73 74 72 69 6e 67 ld be: " (string
7cf0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 -intersperse key
7d00: 73 20 22 2f 22 29 20 22 2c 20 68 61 76 65 20 22 s "/") ", have "
7d10: 20 74 6c 69 73 74 20 22 20 66 6f 72 20 65 6c 65 tlist " for ele
7d20: 6d 65 6e 74 73 22 29 0a 09 20 20 20 20 20 20 23 ments").. #
7d30: 66 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a 0a f).. #f))))..
7d40: 3b 3b 20 6c 6f 67 69 63 20 66 6f 72 20 67 65 74 ;; logic for get
7d50: 74 69 6e 67 20 68 6f 6d 65 68 6f 73 74 2e 20 52 ting homehost. R
7d60: 65 74 75 72 6e 73 20 28 68 6f 73 74 20 2e 20 61 eturns (host . a
7d70: 74 2d 68 6f 6d 65 29 0a 3b 3b 20 49 46 20 2a 74 t-home).;; IF *t
7d80: 6f 70 70 61 74 68 2a 20 69 73 20 6e 6f 74 20 73 oppath* is not s
7d90: 65 74 2c 20 77 61 69 74 20 75 70 20 74 6f 20 66 et, wait up to f
7da0: 69 76 65 20 73 65 63 6f 6e 64 73 20 74 72 79 69 ive seconds tryi
7db0: 6e 67 20 65 76 65 72 79 20 74 77 6f 20 73 65 63 ng every two sec
7dc0: 6f 6e 64 73 0a 3b 3b 20 28 74 68 69 73 20 69 73 onds.;; (this is
7dd0: 20 74 6f 20 61 63 63 6f 6d 6f 64 61 74 65 20 74 to accomodate t
7de0: 68 65 20 77 61 74 63 68 64 6f 67 29 0a 3b 3b 0a he watchdog).;;.
7df0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
7e00: 67 65 74 2d 68 6f 6d 65 68 6f 73 74 20 23 21 6b get-homehost #!k
7e10: 65 79 20 28 74 72 79 6e 75 6d 20 35 29 29 0a 20 ey (trynum 5)).
7e20: 20 3b 3b 20 63 61 6c 6c 65 64 20 6f 66 74 65 6e ;; called often
7e30: 20 65 73 70 65 63 69 61 6c 6c 79 20 61 74 20 73 especially at s
7e40: 74 61 72 74 20 75 70 2e 20 75 73 65 20 6d 75 74 tart up. use mut
7e50: 65 78 20 74 6f 20 65 6c 69 6d 69 6e 61 74 65 20 ex to eliminate
7e60: 63 6f 6c 6c 69 73 69 6f 6e 73 0a 20 20 28 6d 75 collisions. (mu
7e70: 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 tex-lock! *homeh
7e80: 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 63 ost-mutex*). (c
7e90: 6f 6e 64 0a 20 20 20 28 2a 68 6f 6d 65 2d 68 6f ond. (*home-ho
7ea0: 73 74 2a 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 st*. (mutex-u
7eb0: 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 nlock! *homehost
7ec0: 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 2a 68 6f -mutex*). *ho
7ed0: 6d 65 2d 68 6f 73 74 2a 29 0a 20 20 20 28 28 6e me-host*). ((n
7ee0: 6f 74 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 ot *toppath*).
7ef0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
7f00: 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 *homehost-mutex
7f10: 2a 29 0a 20 20 20 20 28 6c 61 75 6e 63 68 3a 73 *). (launch:s
7f20: 65 74 75 70 29 20 3b 3b 20 73 61 66 65 6c 79 20 etup) ;; safely
7f30: 6d 75 74 65 78 65 64 20 6e 6f 77 0a 20 20 20 20 mutexed now.
7f40: 28 69 66 20 28 3e 20 74 72 79 6e 75 6d 20 30 29 (if (> trynum 0)
7f50: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 74 68 72 ..(begin.. (thr
7f60: 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 20 ead-sleep! 2)..
7f70: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d (common:get-hom
7f80: 65 68 6f 73 74 20 74 72 79 6e 75 6d 3a 20 28 2d ehost trynum: (-
7f90: 20 74 72 79 6e 75 6d 20 31 29 29 29 0a 09 23 66 trynum 1)))..#f
7fa0: 29 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 20 )). (else.
7fb0: 28 6c 65 74 2a 20 28 28 63 75 72 72 68 6f 73 74 (let* ((currhost
7fc0: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
7fd0: 29 0a 09 20 20 20 28 62 65 73 74 61 64 72 73 20 ).. (bestadrs
7fe0: 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
7ff0: 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 63 -guess-address c
8000: 75 72 72 68 6f 73 74 29 29 0a 09 20 20 20 3b 3b urrhost)).. ;;
8010: 20 66 69 72 73 74 20 6c 6f 6f 6b 20 69 6e 20 63 first look in c
8020: 6f 6e 66 69 67 2c 20 74 68 65 6e 20 6c 6f 6f 6b onfig, then look
8030: 20 69 6e 20 66 69 6c 65 20 2e 68 6f 6d 65 68 6f in file .homeho
8040: 73 74 2c 20 63 72 65 61 74 65 20 69 74 20 69 66 st, create it if
8050: 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 20 20 20 28 not found.. (
8060: 68 6f 6d 65 68 6f 73 74 20 28 6f 72 20 28 63 6f homehost (or (co
8070: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
8080: 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 nfigdat* "server
8090: 22 20 22 68 6f 6d 65 68 6f 73 74 22 20 29 0a 09 " "homehost" )..
80a0: 09 09 20 28 6c 65 74 20 28 28 68 68 66 20 28 63 .. (let ((hhf (c
80b0: 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f onc *toppath* "/
80c0: 2e 68 6f 6d 65 68 6f 73 74 22 29 29 29 0a 09 09 .homehost")))...
80d0: 09 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 . (if (file-ex
80e0: 69 73 74 73 3f 20 68 68 66 29 0a 09 09 09 20 20 ists? hhf)....
80f0: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
8100: 2d 66 72 6f 6d 2d 66 69 6c 65 20 68 68 66 20 72 -from-file hhf r
8110: 65 61 64 2d 6c 69 6e 65 29 0a 09 09 09 20 20 20 ead-line)....
8120: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 77 72 (if (file-wr
8130: 69 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 ite-access? *top
8140: 70 61 74 68 2a 29 0a 09 09 09 09 20 20 20 28 62 path*)..... (b
8150: 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 28 77 egin..... (w
8160: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 ith-output-to-fi
8170: 6c 65 20 68 68 66 0a 09 09 09 09 20 20 20 20 20 le hhf.....
8180: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 (lambda ()....
8190: 09 09 20 28 70 72 69 6e 74 20 62 65 73 74 61 64 .. (print bestad
81a0: 72 73 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 rs)))..... (
81b0: 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 begin.....
81c0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
81d0: 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a *homehost-mutex*
81e0: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 61 )..... (ca
81f0: 72 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f r (common:get-ho
8200: 6d 65 68 6f 73 74 29 29 29 29 0a 09 09 09 09 20 mehost)))).....
8210: 20 20 23 66 29 29 29 29 29 0a 09 20 20 20 28 61 #f))))).. (a
8220: 74 2d 68 6f 6d 65 20 20 28 6f 72 20 28 65 71 75 t-home (or (equ
8230: 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 63 75 72 al? homehost cur
8240: 72 68 6f 73 74 29 0a 09 09 09 20 28 65 71 75 61 rhost).... (equa
8250: 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 62 65 73 74 l? homehost best
8260: 61 64 72 73 29 29 29 29 0a 20 20 20 20 20 20 28 adrs)))). (
8270: 73 65 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a set! *home-host*
8280: 20 28 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 74 20 (cons homehost
8290: 61 74 2d 68 6f 6d 65 29 29 0a 20 20 20 20 20 20 at-home)).
82a0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
82b0: 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 homehost-mutex*)
82c0: 0a 20 20 20 20 20 20 2a 68 6f 6d 65 2d 68 6f 73 . *home-hos
82d0: 74 2a 29 29 29 29 0a 0a 3b 3b 20 61 6d 20 49 20 t*))))..;; am I
82e0: 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 3f on the homehost?
82f0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
8300: 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f mon:on-homehost?
8310: 29 0a 20 20 28 6c 65 74 20 28 28 68 68 20 28 63 ). (let ((hh (c
8320: 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f ommon:get-homeho
8330: 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 68 68 st))). (if hh
8340: 0a 09 28 63 64 72 20 68 68 29 0a 09 23 66 29 29 ..(cdr hh)..#f))
8350: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
8360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d ===========.;; M
83a0: 20 49 20 53 20 43 20 20 20 4c 20 49 20 53 20 54 I S C L I S T
83b0: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
83c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
83f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
8400: 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 61 20 61 items in lista a
8410: 72 65 20 6d 61 74 63 68 65 64 20 76 61 6c 75 65 re matched value
8420: 20 61 6e 64 20 70 6f 73 69 74 69 6f 6e 20 69 6e and position in
8430: 20 6c 69 73 74 62 0a 3b 3b 20 72 65 74 75 72 6e listb.;; return
8440: 20 74 68 65 20 72 65 6d 61 69 6e 69 6e 67 20 69 the remaining i
8450: 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 6f 72 tems in listb or
8460: 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 #f.;;.(define (
8470: 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 69 73 2d 73 common:list-is-s
8480: 75 62 6c 69 73 74 20 6c 69 73 74 61 20 6c 69 73 ublist lista lis
8490: 74 62 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f tb). (if (null?
84a0: 20 6c 69 73 74 61 29 0a 20 20 20 20 20 20 6c 69 lista). li
84b0: 73 74 62 20 3b 3b 20 61 6c 6c 20 69 74 65 6d 73 stb ;; all items
84c0: 20 69 6e 20 6c 69 73 74 62 20 61 72 65 20 22 72 in listb are "r
84d0: 65 6d 61 69 6e 69 6e 67 22 0a 20 20 20 20 20 20 emaining".
84e0: 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 6c (if (> (length l
84f0: 69 73 74 61 29 28 6c 65 6e 67 74 68 20 6c 69 73 ista)(length lis
8500: 74 62 29 29 20 0a 09 20 20 23 66 0a 09 20 20 28 tb)) .. #f.. (
8510: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 61 20 let loop ((heda
8520: 28 63 61 72 20 6c 69 73 74 61 29 29 0a 09 09 20 (car lista))...
8530: 20 20 20 20 28 74 61 6c 61 20 28 63 64 72 20 6c (tala (cdr l
8540: 69 73 74 61 29 29 0a 09 09 20 20 20 20 20 28 68 ista))... (h
8550: 65 64 62 20 28 63 61 72 20 6c 69 73 74 62 29 29 edb (car listb))
8560: 0a 09 09 20 20 20 20 20 28 74 61 6c 62 20 28 63 ... (talb (c
8570: 64 72 20 6c 69 73 74 62 29 29 29 0a 09 20 20 20 dr listb)))..
8580: 20 28 69 66 20 28 65 71 75 61 6c 3f 20 68 65 64 (if (equal? hed
8590: 61 20 68 65 64 62 29 0a 09 09 28 69 66 20 28 6e a hedb)...(if (n
85a0: 75 6c 6c 3f 20 74 61 6c 61 29 20 3b 3b 20 77 65 ull? tala) ;; we
85b0: 20 61 72 65 20 64 6f 6e 65 0a 09 09 20 20 20 20 are done...
85c0: 74 61 6c 62 0a 09 09 20 20 20 20 28 6c 6f 6f 70 talb... (loop
85d0: 20 28 63 61 72 20 74 61 6c 61 29 0a 09 09 09 20 (car tala)....
85e0: 20 28 63 64 72 20 74 61 6c 61 29 0a 09 09 09 20 (cdr tala)....
85f0: 20 28 63 61 72 20 74 61 6c 62 29 0a 09 09 09 20 (car talb)....
8600: 20 0a 09 09 09 20 20 28 63 64 72 20 74 61 6c 62 .... (cdr talb
8610: 29 29 29 0a 09 09 23 66 29 29 29 29 29 0a 0a 3b )))...#f)))))..;
8620: 3b 20 4e 65 65 64 65 64 20 66 6f 72 20 6c 6f 6e ; Needed for lon
8630: 67 20 6c 69 73 74 73 20 74 6f 20 62 65 20 73 6f g lists to be so
8640: 72 74 65 64 20 77 68 65 72 65 20 28 61 70 70 6c rted where (appl
8650: 79 20 6d 61 78 20 2e 2e 2e 20 29 20 64 69 65 73 y max ... ) dies
8660: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
8670: 6d 6f 6e 3a 6d 61 78 20 69 6e 6c 73 74 29 0a 20 mon:max inlst).
8680: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6d 61 78 (let loop ((max
8690: 2d 76 61 6c 20 28 63 61 72 20 69 6e 6c 73 74 29 -val (car inlst)
86a0: 29 0a 09 20 20 20 20 20 28 68 65 64 20 20 20 20 ).. (hed
86b0: 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 (car inlst))..
86c0: 20 20 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 (tal (cd
86d0: 72 20 69 6e 6c 73 74 29 29 29 0a 20 20 20 20 28 r inlst))). (
86e0: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
86f0: 61 6c 29 29 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 al))..(loop (max
8700: 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 0a 09 20 hed max-val)..
8710: 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 0a 09 (car tal)..
8720: 20 20 20 20 20 20 28 63 64 72 20 74 61 6c 29 29 (cdr tal))
8730: 0a 09 28 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 ..(max hed max-v
8740: 61 6c 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d al))))..;; get m
8750: 69 6e 20 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e in or max, use >
8760: 20 66 6f 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 for max and < f
8770: 6f 72 20 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 or min, this wor
8780: 6b 73 20 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 ks around the li
8790: 6d 69 74 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b mits on apply.;;
87a0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
87b0: 3a 6d 69 6e 2d 6d 61 78 20 63 6f 6d 70 20 6c 73 :min-max comp ls
87c0: 74 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 t). (if (null?
87d0: 6c 73 74 29 0a 20 20 20 20 20 20 23 66 20 3b 3b lst). #f ;;
87e0: 20 62 65 74 74 65 72 20 74 68 61 6e 20 61 6e 20 better than an
87f0: 65 78 63 65 70 74 69 6f 6e 20 66 6f 72 20 6d 79 exception for my
8800: 20 6e 65 65 64 73 0a 20 20 20 20 20 20 28 66 6f needs. (fo
8810: 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ld (lambda (a b)
8820: 0a 09 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d .. (if (com
8830: 70 20 61 20 62 29 20 61 20 62 29 29 0a 09 20 20 p a b) a b))..
8840: 20 20 28 63 61 72 20 6c 73 74 29 0a 09 20 20 20 (car lst)..
8850: 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 70 61 74 68 lst)))..;; path
8860: 20 6c 69 73 74 20 74 6f 20 68 61 73 68 2d 74 61 list to hash-ta
8870: 62 6c 65 20 74 72 65 65 0a 3b 3b 20 20 20 28 28 ble tree.;; ((
8880: 61 20 62 20 63 29 28 61 20 62 20 64 29 28 65 20 a b c)(a b d)(e
8890: 62 20 63 29 29 20 3d 3e 20 28 28 61 20 28 62 20 b c)) => ((a (b
88a0: 28 64 29 20 28 63 29 29 29 20 28 65 20 28 62 20 (d) (c))) (e (b
88b0: 28 63 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e (c)))).;;.(defin
88c0: 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e e (common:list->
88d0: 68 74 72 65 65 20 6c 73 74 29 0a 20 20 28 6c 65 htree lst). (le
88e0: 74 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 t ((resh (make-h
88f0: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
8900: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
8910: 28 6c 61 6d 62 64 61 20 28 69 6e 6c 73 74 29 0a (lambda (inlst).
8920: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop
8930: 20 28 28 68 74 20 20 72 65 73 68 29 0a 09 09 20 ((ht resh)...
8940: 20 28 68 65 64 20 28 63 61 72 20 69 6e 6c 73 74 (hed (car inlst
8950: 29 29 0a 09 09 20 20 28 74 61 6c 20 28 63 64 72 ))... (tal (cdr
8960: 20 69 6e 6c 73 74 29 29 29 0a 09 20 28 69 66 20 inlst))).. (if
8970: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
8980: 64 65 66 61 75 6c 74 20 68 74 20 68 65 64 20 23 default ht hed #
8990: 66 29 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f f).. (if (no
89a0: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
89b0: 09 20 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 . (loop (hash-ta
89c0: 62 6c 65 2d 72 65 66 20 68 74 20 68 65 64 29 0a ble-ref ht hed).
89d0: 09 09 20 20 20 20 20 20 20 28 63 61 72 20 74 61 .. (car ta
89e0: 6c 29 0a 09 09 20 20 20 20 20 20 20 28 63 64 72 l)... (cdr
89f0: 20 74 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 tal))).. (b
8a00: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 68 61 egin.. (ha
8a10: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 sh-table-set! ht
8a20: 20 68 65 64 20 28 6d 61 6b 65 2d 68 61 73 68 2d hed (make-hash-
8a30: 74 61 62 6c 65 29 29 0a 09 20 20 20 20 20 20 20 table))..
8a40: 28 6c 6f 6f 70 20 68 74 20 68 65 64 20 74 61 6c (loop ht hed tal
8a50: 29 29 29 29 29 0a 20 20 20 20 20 6c 73 74 29 0a ))))). lst).
8a60: 20 20 20 20 72 65 73 68 29 29 0a 0a 3b 3b 20 68 resh))..;; h
8a70: 61 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 ash-table tree t
8a80: 6f 20 68 74 6d 6c 20 6c 69 73 74 20 74 72 65 65 o html list tree
8a90: 0a 3b 3b 0a 3b 3b 20 20 20 74 69 70 66 75 6e 63 .;;.;; tipfunc
8aa0: 20 74 61 6b 65 73 20 74 77 6f 20 70 61 72 61 6d takes two param
8ab0: 65 74 65 72 73 3a 20 79 20 74 68 65 20 74 69 70 eters: y the tip
8ac0: 20 76 61 6c 75 65 20 61 6e 64 20 70 61 74 68 20 value and path
8ad0: 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 61 74 the path to that
8ae0: 20 70 6f 69 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e point.;;.(defin
8af0: 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d e (common:htree-
8b00: 3e 68 74 6d 6c 20 68 74 20 70 61 74 68 20 74 69 >html ht path ti
8b10: 70 66 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 pfunc). (let ((
8b20: 64 61 74 6c 69 73 74 20 09 28 73 6f 72 74 20 28 datlist .(sort (
8b30: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
8b40: 74 20 68 74 29 0a 20 20 20 20 20 20 20 20 20 20 t ht).
8b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b60: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
8b70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
8b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8b90: 20 20 28 73 74 72 69 6e 67 3c 20 28 63 61 72 20 (string< (car
8ba0: 61 29 28 63 61 72 20 62 29 29 29 29 29 29 0a 20 a)(car b)))))).
8bb0: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 (if (null? da
8bc0: 74 6c 69 73 74 29 0a 20 20 20 20 09 28 74 69 70 tlist). .(tip
8bd0: 66 75 6e 63 20 23 66 20 70 61 74 68 29 20 3b 3b func #f path) ;;
8be0: 20 72 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 really shouldn'
8bf0: 74 20 67 65 74 20 68 65 72 65 0a 09 28 73 3a 75 t get here..(s:u
8c00: 6c 0a 09 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 l.. (map (lambda
8c10: 20 28 78 29 0a 09 09 28 6c 65 74 2a 20 28 28 6c (x)...(let* ((l
8c20: 65 76 65 6c 6e 61 6d 65 20 28 63 61 72 20 78 29 evelname (car x)
8c30: 29 0a 09 09 20 20 20 20 20 20 20 28 79 20 20 20 )... (y
8c40: 20 20 20 20 20 20 28 63 64 72 20 78 29 29 0a 09 (cdr x))..
8c50: 09 20 20 20 20 20 20 20 28 6e 65 77 70 61 74 68 . (newpath
8c60: 20 20 20 28 61 70 70 65 6e 64 20 70 61 74 68 20 (append path
8c70: 28 6c 69 73 74 20 6c 65 76 65 6c 6e 61 6d 65 29 (list levelname)
8c80: 29 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 61 ))... (lea
8c90: 66 20 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 f (or (not
8ca0: 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 29 (hash-table? y))
8cb0: 0a 09 09 09 09 20 20 20 20 20 20 28 6e 75 6c 6c ..... (null
8cc0: 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 ? (hash-table-ke
8cd0: 79 73 20 79 29 29 29 29 29 0a 09 09 20 20 28 69 ys y)))))... (i
8ce0: 66 20 6c 65 61 66 0a 09 09 20 20 20 20 20 20 28 f leaf... (
8cf0: 73 3a 6c 69 20 28 74 69 70 66 75 6e 63 20 79 20 s:li (tipfunc y
8d00: 6e 65 77 70 61 74 68 29 29 0a 09 09 20 20 20 20 newpath))...
8d10: 20 20 28 73 3a 6c 69 0a 09 09 20 20 20 20 20 20 (s:li...
8d20: 20 28 6c 69 73 74 20 0a 09 09 09 6c 65 76 65 6c (list ....level
8d30: 6e 61 6d 65 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a name....(common:
8d40: 68 74 72 65 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 htree->html y ne
8d50: 77 70 61 74 68 20 74 69 70 66 75 6e 63 29 29 29 wpath tipfunc)))
8d60: 29 29 29 0a 09 20 20 20 20 20 20 64 61 74 6c 69 ))).. datli
8d70: 73 74 29 29 29 29 29 0a 0a 3b 3b 20 68 61 73 68 st)))))..;; hash
8d80: 2d 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 61 -table tree to a
8d90: 6c 69 73 74 20 74 72 65 65 0a 3b 3b 0a 28 64 65 list tree.;;.(de
8da0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 fine (common:htr
8db0: 65 65 2d 3e 61 74 72 65 65 20 68 74 29 0a 20 20 ee->atree ht).
8dc0: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
8dd0: 0a 09 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 .. (cons (car x)
8de0: 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
8df0: 79 20 28 63 64 72 20 78 29 29 29 0a 09 09 20 28 y (cdr x)))... (
8e00: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 if (hash-table?
8e10: 79 29 0a 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f y)... (commo
8e20: 6e 3a 68 74 72 65 65 2d 3e 61 74 72 65 65 20 79 n:htree->atree y
8e30: 29 0a 09 09 20 20 20 20 20 79 29 29 29 29 0a 20 )... y)))).
8e40: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
8e50: 65 2d 3e 61 6c 69 73 74 20 68 74 29 29 29 0a 0a e->alist ht)))..
8e60: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ea0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 ========.;; M U
8eb0: 4e 20 47 20 45 20 20 20 44 20 41 20 54 20 41 20 N G E D A T A
8ec0: 20 20 49 20 4e 20 54 20 4f 20 20 20 4e 20 49 20 I N T O N I
8ed0: 43 20 45 20 20 20 46 20 4f 20 52 20 4d 20 53 0a C E F O R M S.
8ee0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
8ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8f20: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e ========..;; Gen
8f30: 65 72 61 74 65 20 61 6e 20 69 6e 64 65 78 20 66 erate an index f
8f40: 6f 72 20 61 20 73 70 61 72 73 65 20 6c 69 73 74 or a sparse list
8f50: 20 6f 66 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b of key values.;
8f60: 3b 20 20 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 ; ( (rowname1
8f70: 63 6f 6c 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 colname1 val1)(r
8f80: 6f 77 6e 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 owname2 colname2
8f90: 20 76 61 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d val2) ).;;.;; =
8fa0: 3e 20 0a 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f > .;;.;; ( (ro
8fb0: 77 6e 61 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d wname1 0)(rownam
8fc0: 65 32 20 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 e2 1)) ;; row
8fd0: 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 names -> num.;;
8fe0: 20 20 20 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 (colname1 0)
8ff0: 28 63 6f 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 (colname2 1)) )
9000: 20 3b 3b 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 ;; colnames ->
9010: 6e 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f num.;; .;; optio
9020: 6e 61 6c 20 61 70 70 6c 79 20 70 72 6f 63 20 74 nal apply proc t
9030: 6f 20 72 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 o rownum colnum
9040: 76 61 6c 75 65 0a 28 64 65 66 69 6e 65 20 28 63 value.(define (c
9050: 6f 6d 6d 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 ommon:sparse-lis
9060: 74 2d 67 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 t-generate-index
9070: 20 64 61 74 61 20 23 21 6b 65 79 20 28 70 72 6f data #!key (pro
9080: 63 20 23 66 29 29 0a 20 20 28 69 66 20 28 6e 75 c #f)). (if (nu
9090: 6c 6c 3f 20 64 61 74 61 29 0a 20 20 20 20 20 20 ll? data).
90a0: 28 6c 69 73 74 20 27 28 29 20 27 28 29 29 0a 20 (list '() '()).
90b0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
90c0: 28 68 65 64 20 28 63 61 72 20 64 61 74 61 29 29 (hed (car data))
90d0: 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 64 61 ... (tal (cdr da
90e0: 74 61 29 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 ta))... (rowname
90f0: 73 20 27 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 s '())... (colna
9100: 6d 65 73 20 27 28 29 29 0a 09 09 20 28 72 6f 77 mes '())... (row
9110: 6e 75 6d 20 20 20 30 29 0a 09 09 20 28 63 6f 6c num 0)... (col
9120: 6e 75 6d 20 20 20 30 29 29 0a 09 28 6c 65 74 2a num 0))..(let*
9130: 20 28 28 72 6f 77 6b 65 79 20 20 20 20 20 20 20 ((rowkey
9140: 20 20 20 28 63 61 72 20 20 20 68 65 64 29 29 0a (car hed)).
9150: 09 20 20 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 . (colkey
9160: 20 20 20 20 20 20 20 20 20 28 63 61 64 72 20 20 (cadr
9170: 68 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 76 hed)).. (v
9180: 61 6c 75 65 20 20 20 20 20 20 20 20 20 20 20 28 alue (
9190: 63 61 64 64 72 20 68 65 64 29 29 0a 09 20 20 20 caddr hed))..
91a0: 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d 72 6f (existing-ro
91b0: 77 64 61 74 20 28 61 73 73 6f 63 20 72 6f 77 6b wdat (assoc rowk
91c0: 65 79 20 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 ey rownames))..
91d0: 20 20 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d (existing-
91e0: 63 6f 6c 64 61 74 20 28 61 73 73 6f 63 20 63 6f coldat (assoc co
91f0: 6c 6b 65 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a lkey colnames)).
9200: 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 72 6f . (curr-ro
9210: 77 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 wnum (if exi
9220: 73 74 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 sting-rowdat row
9230: 6e 75 6d 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 num (+ rownum 1)
9240: 29 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 )).. (curr
9250: 2d 63 6f 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 -colnum (if
9260: 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 existing-coldat
9270: 63 6f 6c 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d colnum (+ colnum
9280: 20 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 1))).. (n
9290: 65 77 2d 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 ew-rownames (
92a0: 69 66 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 if existing-rowd
92b0: 61 74 20 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e at rownames (con
92c0: 73 20 28 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 s (list rowkey c
92d0: 75 72 72 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e urr-rownum) rown
92e0: 61 6d 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 ames)))..
92f0: 28 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 (new-colnames
9300: 20 28 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f (if existing-co
9310: 6c 64 61 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 ldat colnames (c
9320: 6f 6e 73 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 ons (list colkey
9330: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f curr-colnum) co
9340: 6c 6e 61 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b lnames)))).. ;;
9350: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
9360: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
9370: 67 2d 70 6f 72 74 2a 20 22 50 72 6f 63 65 73 73 g-port* "Process
9380: 69 6e 67 20 72 65 63 6f 72 64 3a 20 22 20 68 65 ing record: " he
9390: 64 20 29 0a 09 20 20 28 69 66 20 70 72 6f 63 20 d ).. (if proc
93a0: 28 70 72 6f 63 20 63 75 72 72 2d 72 6f 77 6e 75 (proc curr-rownu
93b0: 6d 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f m curr-colnum ro
93c0: 77 6b 65 79 20 63 6f 6c 6b 65 79 20 76 61 6c 75 wkey colkey valu
93d0: 65 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c e)).. (if (null
93e0: 3f 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 6c ? tal).. (l
93f0: 69 73 74 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 ist new-rownames
9400: 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 new-colnames)..
9410: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
9420: 20 74 61 6c 29 0a 09 09 20 20 20 20 28 63 64 72 tal)... (cdr
9430: 20 74 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 2d tal)... new-
9440: 72 6f 77 6e 61 6d 65 73 0a 09 09 20 20 20 20 6e rownames... n
9450: 65 77 2d 63 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 ew-colnames...
9460: 20 20 28 69 66 20 28 3e 20 63 75 72 72 2d 72 6f (if (> curr-ro
9470: 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 20 63 75 72 wnum rownum) cur
9480: 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 r-rownum rownum)
9490: 0a 09 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 ... (if (> cu
94a0: 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d rr-colnum colnum
94b0: 29 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f ) curr-colnum co
94c0: 6c 6e 75 6d 29 0a 09 09 20 20 20 20 29 29 29 29 lnum)... ))))
94d0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
94e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
9520: 53 20 59 20 53 20 54 20 45 20 4d 20 20 20 53 20 S Y S T E M S
9530: 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d T U F F.;;======
9540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9580: 0a 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 ..;; lazy-safe g
9590: 65 74 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 et file mod time
95a0: 2e 20 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 . on any error (
95b0: 66 69 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e file not existin
95c0: 67 20 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 g etc.) return 0
95d0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
95e0: 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 mon:lazy-modific
95f0: 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 ation-time fpath
9600: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
9610: 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 ptions. exn.
9620: 20 30 0a 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 0. (file-modi
9630: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 fication-time fp
9640: 61 74 68 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 ath)))..;; retur
9650: 6e 20 61 20 6e 69 63 65 20 63 6c 65 61 6e 20 70 n a nice clean p
9660: 61 74 68 6e 61 6d 65 20 6d 61 64 65 20 61 62 73 athname made abs
9670: 6f 6c 75 74 65 0a 28 64 65 66 69 6e 65 20 28 63 olute.(define (c
9680: 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 ommon:nice-path
9690: 64 69 72 29 0a 20 20 28 6c 65 74 20 28 28 6d 61 dir). (let ((ma
96a0: 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 tch (string-matc
96b0: 68 20 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c h "^(~[^\\/]*)(\
96c0: 5c 2f 2e 2a 7c 29 24 22 20 64 69 72 29 29 29 0a \/.*|)$" dir))).
96d0: 20 20 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b (if match ;;
96e0: 20 75 73 69 6e 67 20 7e 20 66 6f 72 20 68 6f 6d using ~ for hom
96f0: 65 3f 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 e?..(common:nice
9700: 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d -path (conc (com
9710: 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 mon:read-link-f
9720: 28 63 61 64 72 20 6d 61 74 63 68 29 29 20 22 2f (cadr match)) "/
9730: 22 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 " (caddr match))
9740: 29 0a 09 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 )..(normalize-pa
9750: 74 68 6e 61 6d 65 20 28 69 66 20 28 61 62 73 6f thname (if (abso
9760: 6c 75 74 65 2d 70 61 74 68 6e 61 6d 65 3f 20 64 lute-pathname? d
9770: 69 72 29 0a 09 09 09 09 64 69 72 0a 09 09 09 09 ir).....dir.....
9780: 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 64 (conc (current-d
9790: 69 72 65 63 74 6f 72 79 29 20 22 2f 22 20 64 69 irectory) "/" di
97a0: 72 29 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 r))))))..;; make
97b0: 20 22 6e 69 63 65 2d 70 61 74 68 22 20 61 76 61 "nice-path" ava
97c0: 69 6c 61 62 6c 65 20 69 6e 20 63 6f 6e 66 69 67 ilable in config
97d0: 20 66 69 6c 65 73 20 61 6e 64 20 74 68 65 20 72 files and the r
97e0: 65 70 6c 0a 28 64 65 66 69 6e 65 20 6e 69 63 65 epl.(define nice
97f0: 2d 70 61 74 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 -path common:nic
9800: 65 2d 70 61 74 68 29 0a 0a 28 64 65 66 69 6e 65 e-path)..(define
9810: 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 (common:read-li
9820: 6e 6b 2d 66 20 70 61 74 68 29 0a 20 20 28 68 61 nk-f path). (ha
9830: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
9840: 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 exn.
9850: 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 (begin..(debug:p
9860: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
9870: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
9880: 22 63 6f 6d 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f "command \"/bin/
9890: 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 readlink -f " pa
98a0: 74 68 20 22 5c 22 20 66 61 69 6c 65 64 2e 22 29 th "\" failed.")
98b0: 0a 09 70 61 74 68 29 20 3b 3b 20 6a 75 73 74 20 ..path) ;; just
98c0: 67 69 76 65 20 75 70 0a 20 20 20 20 28 77 69 74 give up. (wit
98d0: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
98e0: 65 0a 09 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 e..(conc "/bin/r
98f0: 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 eadlink -f " pat
9900: 68 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 h). (lambda
9910: 20 28 29 0a 09 28 72 65 61 64 2d 6c 69 6e 65 29 ()..(read-line)
9920: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 ))))..(define (g
9930: 65 74 2d 63 70 75 2d 6c 6f 61 64 20 23 21 6b 65 et-cpu-load #!ke
9940: 79 20 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 y (remote-host #
9950: 66 29 29 0a 20 20 28 63 61 72 20 28 63 6f 6d 6d f)). (car (comm
9960: 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 on:get-cpu-load
9970: 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 3b remote-host))).;
9980: 3b 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 ; (let* ((load
9990: 2d 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d -res (process:cm
99a0: 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 d-run->list "upt
99b0: 69 6d 65 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 ime")).;; . (loa
99c0: 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 6c d-rx (regexp "l
99d0: 6f 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b oad average:\\s+
99e0: 28 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 (\\d+)")).;; . (
99f0: 63 70 75 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b cpu-load #f)).;;
9a00: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
9a10: 6c 61 6d 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 lambda (l).;; ..
9a20: 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 (let ((match (st
9a30: 72 69 6e 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 ring-search load
9a40: 2d 72 78 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 -rx l))).;; ..
9a50: 28 69 66 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 (if match.;; ..
9a60: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 (let ((newv
9a70: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 al (string->numb
9a80: 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 er (cadr match))
9a90: 29 29 0a 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 )).;; ...(if (nu
9aa0: 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b mber? newval).;;
9ab0: 20 09 09 09 20 20 20 20 28 73 65 74 21 20 63 70 ... (set! cp
9ac0: 75 2d 6c 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 u-load newval)))
9ad0: 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 ))).;; . (c
9ae0: 61 72 20 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b ar load-res)).;;
9af0: 20 20 20 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a cpu-load)).
9b00: 0a 3b 3b 20 67 65 74 20 63 70 75 20 6c 6f 61 64 .;; get cpu load
9b10: 20 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d by reading from
9b20: 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 /proc/loadavg,
9b30: 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 return all three
9b40: 20 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 values.;;.(defi
9b50: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 ne (common:get-c
9b60: 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 pu-load remote-h
9b70: 6f 73 74 29 0a 20 20 28 69 66 20 72 65 6d 6f 74 ost). (if remot
9b80: 65 2d 68 6f 73 74 0a 20 20 20 20 20 20 28 6d 61 e-host. (ma
9b90: 70 20 28 6c 61 6d 62 64 61 20 28 72 65 73 29 0a p (lambda (res).
9ba0: 09 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f . (if (eof-o
9bb0: 62 6a 65 63 74 3f 20 72 65 73 29 20 39 65 39 39 bject? res) 9e99
9bc0: 20 72 65 73 29 29 0a 09 20 20 20 28 77 69 74 68 res)).. (with
9bd0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
9be0: 20 0a 09 20 20 20 20 28 63 6f 6e 63 20 22 73 73 .. (conc "ss
9bf0: 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 h " remote-host
9c00: 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 " cat /proc/load
9c10: 61 76 67 22 29 0a 09 20 20 20 20 28 6c 61 6d 62 avg").. (lamb
9c20: 64 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 da ()(list (read
9c30: 29 28 72 65 61 64 29 28 72 65 61 64 29 29 29 29 )(read)(read))))
9c40: 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e ). (with-in
9c50: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f put-from-file "/
9c60: 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 0a 09 proc/loadavg" ..
9c70: 28 6c 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 (lambda ()(list
9c80: 28 72 65 61 64 29 28 72 65 61 64 29 28 72 65 61 (read)(read)(rea
9c90: 64 29 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 d))))))..;; get
9ca0: 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c normalized cpu l
9cb0: 6f 61 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 oad by reading f
9cc0: 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 rom /proc/loadav
9cd0: 67 20 61 6e 64 20 2f 70 72 6f 63 2f 63 70 75 69 g and /proc/cpui
9ce0: 6e 66 6f 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 nfo return all t
9cf0: 68 72 65 65 20 76 61 6c 75 65 73 20 61 6e 64 20 hree values and
9d00: 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 the number of re
9d10: 61 6c 20 63 70 75 73 20 61 6e 64 20 74 68 65 20 al cpus and the
9d20: 6e 75 6d 62 65 72 20 6f 66 20 74 68 72 65 61 64 number of thread
9d30: 73 0a 3b 3b 20 72 65 74 75 72 6e 73 20 6c 69 73 s.;; returns lis
9d40: 74 20 28 6e 6f 72 6d 61 6c 69 7a 65 64 2d 70 72 t (normalized-pr
9d50: 6f 63 2d 6c 6f 61 64 20 6e 6f 72 6d 61 6c 69 7a oc-load normaliz
9d60: 65 64 2d 63 6f 72 65 2d 6c 6f 61 64 20 31 6d 20 ed-core-load 1m
9d70: 35 6d 20 31 35 6d 20 6e 63 6f 72 65 73 20 6e 74 5m 15m ncores nt
9d80: 68 72 65 61 64 73 29 0a 3b 3b 0a 28 64 65 66 69 hreads).;;.(defi
9d90: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e ne (common:get-n
9da0: 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f ormalized-cpu-lo
9db0: 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a ad remote-host).
9dc0: 20 20 28 6c 65 74 20 28 28 64 61 74 61 20 28 69 (let ((data (i
9dd0: 66 20 72 65 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 f remote-host.
9de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9df0: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
9e00: 2d 70 69 70 65 20 0a 20 20 20 20 20 20 20 20 20 -pipe .
9e10: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 (conc
9e20: 22 73 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f "ssh " remote-ho
9e30: 73 74 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c st " cat /proc/l
9e40: 6f 61 64 61 76 67 3b 63 61 74 20 2f 70 72 6f 63 oadavg;cat /proc
9e50: 2f 63 70 75 69 6e 66 6f 3b 65 63 68 6f 20 65 6e /cpuinfo;echo en
9e60: 64 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 d").
9e70: 20 20 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 read-line
9e80: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s).
9e90: 20 20 20 20 20 28 61 70 70 65 6e 64 20 0a 20 20 (append .
9ea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9eb0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
9ec0: 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 6c 6f m-file "/proc/lo
9ed0: 61 64 61 76 67 22 20 0a 20 20 20 20 20 20 20 20 adavg" .
9ee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 61 rea
9ef0: 64 2d 6c 69 6e 65 73 29 0a 20 20 20 20 20 20 20 d-lines).
9f00: 20 20 20 20 20 20 20 20 20 20 20 20 28 77 69 74 (wit
9f10: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c h-input-from-fil
9f20: 65 20 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f e "/proc/cpuinfo
9f30: 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ".
9f40: 20 20 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 read-line
9f50: 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 s).
9f60: 20 20 20 20 20 20 28 6c 69 73 74 20 22 65 6e 64 (list "end
9f70: 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c ")))). (l
9f80: 6f 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 oad-rx (regexp
9f90: 22 5e 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 "^([\\d\\.]+)\\s
9fa0: 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b +([\\d\\.]+)\\s+
9fb0: 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e ([\\d\\.]+)\\s+.
9fc0: 2a 24 22 29 29 0a 20 20 20 20 20 20 20 20 28 70 *$")). (p
9fd0: 72 6f 63 2d 72 78 20 20 28 72 65 67 65 78 70 20 roc-rx (regexp
9fe0: 22 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a "^processor\\s+:
9ff0: 5c 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 \\s+(\\d+)\\s*$"
a000: 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f 72 65 )). (core
a010: 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 63 -rx (regexp "^c
a020: 6f 72 65 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 ore id\\s+:\\s+(
a030: 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 \\d+)\\s*$")).
a040: 20 20 20 20 20 20 28 70 68 79 73 2d 72 78 20 20 (phys-rx
a050: 28 72 65 67 65 78 70 20 22 5e 70 68 79 73 69 63 (regexp "^physic
a060: 61 6c 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c al id\\s+:\\s+(\
a070: 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 \d+)\\s*$")).
a080: 20 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 20 28 (max-num (
a090: 6c 61 6d 62 64 61 20 28 70 20 6e 29 28 6d 61 78 lambda (p n)(max
a0a0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
a0b0: 20 70 29 20 6e 29 29 29 29 0a 20 20 20 20 3b 3b p) n)))). ;;
a0c0: 20 28 70 72 69 6e 74 20 22 64 61 74 61 3d 22 20 (print "data="
a0d0: 64 61 74 61 29 0a 20 20 20 20 28 69 66 20 28 6e data). (if (n
a0e0: 75 6c 6c 3f 20 64 61 74 61 29 20 3b 3b 20 73 6f ull? data) ;; so
a0f0: 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f mething went wro
a100: 6e 67 0a 20 20 20 20 20 20 20 20 23 66 0a 20 20 ng. #f.
a110: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
a120: 28 28 68 65 64 20 20 20 20 20 20 28 63 61 72 20 ((hed (car
a130: 64 61 74 61 29 29 0a 20 20 20 20 20 20 20 20 20 data)).
a140: 20 20 20 20 20 20 20 20 20 20 28 74 61 6c 20 20 (tal
a150: 20 20 20 20 28 63 64 72 20 64 61 74 61 29 29 0a (cdr data)).
a160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a170: 20 20 20 28 6c 6f 61 64 73 20 20 20 20 23 66 29 (loads #f)
a180: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a190: 20 20 20 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 (proc-num 0)
a1a0: 20 20 3b 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 ;; processor i
a1b0: 6e 63 6c 75 64 65 73 20 74 68 72 65 61 64 73 0a ncludes threads.
a1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a1d0: 20 20 20 28 70 68 79 73 2d 6e 75 6d 20 30 29 20 (phys-num 0)
a1e0: 20 3b 3b 20 70 68 79 73 69 63 61 6c 20 63 68 69 ;; physical chi
a1f0: 70 20 6f 6e 20 6d 6f 74 68 65 72 62 6f 61 72 64 p on motherboard
a200: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a210: 20 20 20 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 (core-num 0)
a220: 29 20 3b 3b 20 63 6f 72 65 0a 20 20 20 20 20 20 ) ;; core.
a230: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 68 65 ;; (print he
a240: 64 20 22 2c 20 22 20 6c 6f 61 64 73 20 22 2c 20 d ", " loads ",
a250: 22 20 70 72 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 " proc-num ", "
a260: 70 68 79 73 2d 6e 75 6d 20 22 2c 20 22 20 63 6f phys-num ", " co
a270: 72 65 2d 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 re-num).
a280: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
a290: 29 20 3b 3b 20 68 61 76 65 20 61 6c 6c 20 6f 75 ) ;; have all ou
a2a0: 72 20 64 61 74 61 2c 20 63 61 6c 63 75 6c 61 74 r data, calculat
a2b0: 65 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 e normalized loa
a2c0: 64 20 61 6e 64 20 72 65 74 75 72 6e 20 72 65 73 d and return res
a2d0: 75 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 ult.
a2e0: 20 20 28 6c 65 74 2a 20 28 28 61 63 74 2d 70 72 (let* ((act-pr
a2f0: 6f 63 20 28 2b 20 70 72 6f 63 2d 6e 75 6d 20 31 oc (+ proc-num 1
a300: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
a310: 20 20 20 20 20 20 20 20 28 61 63 74 2d 70 68 79 (act-phy
a320: 73 20 28 2b 20 70 68 79 73 2d 6e 75 6d 20 31 29 s (+ phys-num 1)
a330: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a340: 20 20 20 20 20 20 20 28 61 63 74 2d 63 6f 72 65 (act-core
a350: 20 28 2b 20 63 6f 72 65 2d 6e 75 6d 20 31 29 29 (+ core-num 1))
a360: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a370: 20 20 20 20 20 20 28 61 64 6a 2d 70 72 6f 63 2d (adj-proc-
a380: 6c 6f 61 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 load (/ (car loa
a390: 64 73 29 20 61 63 74 2d 70 72 6f 63 29 29 0a 20 ds) act-proc)).
a3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a3b0: 20 20 20 20 28 61 64 6a 2d 63 6f 72 65 2d 6c 6f (adj-core-lo
a3c0: 61 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 ad (/ (car loads
a3d0: 29 20 61 63 74 2d 63 6f 72 65 29 29 29 0a 20 20 ) act-core))).
a3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
a3f0: 70 70 65 6e 64 20 28 6c 69 73 74 20 28 63 6f 6e ppend (list (con
a400: 73 20 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 s 'adj-proc-load
a410: 20 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a adj-proc-load).
a420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a430: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
a440: 6f 6e 73 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f ons 'adj-core-lo
a450: 61 64 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 ad adj-core-load
a460: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
a470: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
a480: 20 28 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 (cons '1m-load
a490: 28 63 61 72 20 6c 6f 61 64 73 29 29 0a 20 20 20 (car loads)).
a4a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a4b0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
a4c0: 20 27 35 6d 2d 6c 6f 61 64 20 28 63 61 64 72 20 '5m-load (cadr
a4d0: 6c 6f 61 64 73 29 29 0a 20 20 20 20 20 20 20 20 loads)).
a4e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a4f0: 20 20 20 20 20 20 28 63 6f 6e 73 20 27 31 35 6d (cons '15m
a500: 2d 6c 6f 61 64 20 28 63 61 64 64 72 20 6c 6f 61 -load (caddr loa
a510: 64 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 ds))).
a520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
a530: 69 73 74 20 28 63 6f 6e 73 20 27 70 72 6f 63 20 ist (cons 'proc
a540: 61 63 74 2d 70 72 6f 63 29 0a 20 20 20 20 20 20 act-proc).
a550: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a560: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 63 (cons 'c
a570: 6f 72 65 20 61 63 74 2d 63 6f 72 65 29 0a 20 20 ore act-core).
a580: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a590: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
a5a0: 73 20 27 70 68 79 73 20 61 63 74 2d 70 68 79 73 s 'phys act-phys
a5b0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
a5c0: 20 20 20 28 72 65 67 65 78 2d 63 61 73 65 0a 20 (regex-case.
a5d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 65 he
a5e0: 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d.
a5f0: 20 28 6c 6f 61 64 2d 72 78 20 20 28 20 78 20 6c (load-rx ( x l
a600: 31 20 6c 35 20 6c 31 35 20 29 20 28 6c 6f 6f 70 1 l5 l15 ) (loop
a610: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
a620: 61 6c 29 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e al)(map string->
a630: 6e 75 6d 62 65 72 20 28 6c 69 73 74 20 6c 31 20 number (list l1
a640: 6c 35 20 6c 31 35 29 29 20 70 72 6f 63 2d 6e 75 l5 l15)) proc-nu
a650: 6d 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d m phys-num core-
a660: 6e 75 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 num)).
a670: 20 20 20 20 20 28 70 72 6f 63 2d 72 78 20 20 28 (proc-rx (
a680: 20 78 20 70 20 20 20 20 20 20 20 20 20 29 20 28 x p ) (
a690: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
a6a0: 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 dr tal) loads
a6b0: 20 20 20 20 20 20 20 20 28 6d 61 78 2d 6e 75 6d (max-num
a6c0: 20 70 20 70 72 6f 63 2d 6e 75 6d 29 20 70 68 79 p proc-num) phy
a6d0: 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 s-num core-num))
a6e0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a6f0: 28 70 68 79 73 2d 72 78 20 20 28 20 78 20 70 20 (phys-rx ( x p
a700: 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 ) (loop
a710: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
a720: 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 l) loads
a730: 20 20 20 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 proc-num (max
a740: 2d 6e 75 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 -num p phys-num)
a750: 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 core-num)).
a760: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 72 65 (core
a770: 2d 72 78 20 20 28 20 78 20 63 20 20 20 20 20 20 -rx ( x c
a780: 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 ) (loop (car
a790: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f tal)(cdr tal) lo
a7a0: 61 64 73 20 20 20 20 20 20 20 20 20 20 20 70 72 ads pr
a7b0: 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 oc-num phys-num
a7c0: 28 6d 61 78 2d 6e 75 6d 20 63 20 63 6f 72 65 2d (max-num c core-
a7d0: 6e 75 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 num))).
a7e0: 20 20 20 20 20 20 28 65 6c 73 65 20 0a 20 20 20 (else .
a7f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
a800: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
a810: 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ;; (print
a820: 22 4e 4f 20 4d 41 54 43 48 3a 20 22 20 68 65 64 "NO MATCH: " hed
a830: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a840: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
a850: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 al)(cdr tal) loa
a860: 64 73 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 ds proc-num phys
a870: 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 29 -num core-num)))
a880: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
a890: 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 69 6e (common:unix-pin
a8a0: 67 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c g hostname). (l
a8b0: 65 74 20 28 28 72 65 73 20 28 73 79 73 74 65 6d et ((res (system
a8c0: 20 28 63 6f 6e 63 20 22 70 69 6e 67 20 2d 63 20 (conc "ping -c
a8d0: 31 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 20 3e 1 " hostname " >
a8e0: 20 2f 64 65 76 2f 6e 75 6c 6c 22 29 29 29 29 0a /dev/null")))).
a8f0: 20 20 20 20 28 65 71 3f 20 72 65 73 20 30 29 29 (eq? res 0))
a900: 29 0a 0a 3b 3b 20 69 64 65 61 6c 6c 79 20 70 75 )..;; ideally pu
a910: 74 20 61 6c 6c 20 74 68 69 73 20 69 6e 66 6f 20 t all this info
a920: 69 6e 74 6f 20 74 68 65 20 64 62 2c 20 6e 6f 20 into the db, no
a930: 6e 65 65 64 20 74 6f 20 70 72 65 73 65 72 76 65 need to preserve
a940: 20 69 74 20 61 63 72 6f 73 73 20 6d 6f 76 69 6e it across movin
a950: 67 20 68 6f 6d 65 68 6f 73 74 0a 3b 3b 0a 28 64 g homehost.;;.(d
a960: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
a970: 74 2d 6c 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 t-least-loaded-h
a980: 6f 73 74 20 68 6f 73 74 73 2d 72 61 77 29 0a 20 ost hosts-raw).
a990: 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 73 20 28 (let* ((hosts (
a9a0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
a9b0: 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 x).
a9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
a9d0: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
a9e0: 78 70 20 22 5e 5c 5c 53 2b 24 22 29 20 78 29 29 xp "^\\S+$") x))
a9f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
aa00: 20 20 20 20 20 20 20 20 20 68 6f 73 74 73 2d 72 hosts-r
aa10: 61 77 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e aw))). (if (n
aa20: 75 6c 6c 3f 20 68 6f 73 74 73 29 0a 20 20 20 20 ull? hosts).
aa30: 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 3b #f. ;
aa40: 3b 0a 20 20 20 20 20 20 20 20 3b 3b 20 73 74 61 ;. ;; sta
aa50: 74 65 67 79 3a 0a 20 20 20 20 20 20 20 20 3b 3b tegy:. ;;
aa60: 20 20 20 20 73 6f 72 74 20 62 79 20 6c 61 73 74 sort by last
aa70: 2d 75 73 65 64 20 61 6e 64 20 6e 6f 72 6d 61 6c -used and normal
aa80: 69 7a 65 64 2d 6c 6f 61 64 0a 20 20 20 20 20 20 ized-load.
aa90: 20 20 3b 3b 20 20 20 20 69 66 20 6c 61 73 74 2d ;; if last-
aaa0: 75 70 64 61 74 65 64 20 3e 20 31 35 20 73 65 63 updated > 15 sec
aab0: 6f 6e 64 73 20 74 68 65 6e 20 72 65 2d 75 70 64 onds then re-upd
aac0: 61 74 65 0a 20 20 20 20 20 20 20 20 3b 3b 20 20 ate. ;;
aad0: 20 20 74 61 6b 65 20 74 68 65 20 68 6f 73 74 20 take the host
aae0: 77 69 74 68 20 74 68 65 20 6c 6f 77 65 73 74 20 with the lowest
aaf0: 6c 6f 61 64 20 77 69 74 68 20 74 68 65 20 6c 6f load with the lo
ab00: 77 65 73 74 20 6c 61 73 74 2d 75 73 65 64 20 28 west last-used (
ab10: 69 2e 65 2e 20 6e 6f 74 20 75 73 65 64 20 66 6f i.e. not used fo
ab20: 72 20 6c 6f 6e 67 65 73 74 20 74 69 6d 65 29 0a r longest time).
ab30: 20 20 20 20 20 20 20 20 3b 3b 0a 20 20 20 20 20 ;;.
ab40: 20 20 20 28 6c 65 74 20 28 28 62 65 73 74 2d 68 (let ((best-h
ab50: 6f 73 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 ost #f).
ab60: 20 20 20 20 20 20 28 63 75 72 72 2d 74 69 6d 65 (curr-time
ab70: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
ab80: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 28 s))). (
ab90: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 20 20 for-each.
aba0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 6f 73 (lambda (hos
abb0: 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 20 20 tname).
abc0: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 63 20 (let* ((rec
abd0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 20 28 (let ((h (
abe0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
abf0: 65 66 61 75 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 efault *host-loa
ac00: 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 23 66 29 ds* hostname #f)
ac10: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
ac20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ac30: 20 20 20 20 28 69 66 20 68 0a 20 20 20 20 20 20 (if h.
ac40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ac50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 h
ac60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ac70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ac80: 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 20 28 (let ((h (
ac90: 6d 61 6b 65 2d 68 6f 73 74 29 29 29 0a 20 20 20 make-host))).
aca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
acb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
acc0: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
acd0: 73 65 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 set! *host-loads
ace0: 2a 20 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 20 * hostname h).
acf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad10: 20 20 20 20 20 68 29 29 29 29 0a 20 20 20 20 20 h)))).
ad20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
ad30: 3b 20 69 66 20 68 6f 73 74 20 68 61 73 6e 27 74 ; if host hasn't
ad40: 20 62 65 65 6e 20 70 69 6e 67 65 64 20 69 6e 20 been pinged in
ad50: 31 35 20 73 65 63 20 75 70 64 61 74 65 20 69 74 15 sec update it
ad60: 27 73 20 64 61 74 61 0a 20 20 20 20 20 20 20 20 's data.
ad70: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 69 6e (pin
ad80: 67 2d 67 6f 6f 64 20 28 69 66 20 28 3c 20 28 2d g-good (if (< (-
ad90: 20 63 75 72 72 2d 74 69 6d 65 20 28 68 6f 73 74 curr-time (host
ada0: 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 72 65 63 -last-update rec
adb0: 29 29 20 31 35 29 0a 20 20 20 20 20 20 20 20 20 )) 15).
adc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
add0: 20 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d (host-
ade0: 72 65 61 63 68 61 62 6c 65 20 72 65 63 29 0a 20 reachable rec).
adf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae10: 20 20 28 6f 72 20 28 68 6f 73 74 2d 72 65 61 63 (or (host-reac
ae20: 68 61 62 6c 65 20 72 65 63 29 0a 20 20 20 20 20 hable rec).
ae30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae50: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
ae60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ae80: 20 20 28 68 6f 73 74 2d 72 65 61 63 68 61 62 6c (host-reachabl
ae90: 65 2d 73 65 74 21 20 72 65 63 20 28 63 6f 6d 6d e-set! rec (comm
aea0: 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 20 68 6f 73 on:unix-ping hos
aeb0: 74 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 tname)).
aec0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aee0: 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 (host-last-upda
aef0: 74 65 2d 73 65 74 21 20 72 65 63 20 63 75 72 72 te-set! rec curr
af00: 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 20 -time).
af10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af30: 28 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f (host-last-cpulo
af40: 61 64 2d 73 65 74 21 20 72 65 63 20 28 63 6f 6d ad-set! rec (com
af50: 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a mon:get-normaliz
af60: 65 64 2d 63 70 75 2d 6c 6f 61 64 20 68 6f 73 74 ed-cpu-load host
af70: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
af80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
afa0: 28 68 6f 73 74 2d 72 65 61 63 68 61 62 6c 65 20 (host-reachable
afb0: 72 65 63 29 29 29 29 29 29 0a 20 20 20 20 20 20 rec)))))).
afc0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 (cond.
afd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
afe0: 28 6e 6f 74 20 62 65 73 74 2d 68 6f 73 74 29 0a (not best-host).
aff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b000: 20 28 73 65 74 21 20 62 65 73 74 2d 68 6f 73 74 (set! best-host
b010: 20 68 6f 73 74 6e 61 6d 65 29 29 0a 20 20 20 20 hostname)).
b020: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 6e ((an
b030: 64 20 70 69 6e 67 2d 67 6f 6f 64 0a 20 20 20 20 d ping-good.
b040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b050: 20 20 28 3c 20 28 61 6c 69 73 74 2d 72 65 66 20 (< (alist-ref
b060: 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 28 'adj-core-load (
b070: 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 host-last-cpuloa
b080: 64 20 72 65 63 29 29 0a 20 20 20 20 20 20 20 20 d rec)).
b090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0a0: 20 28 61 6c 69 73 74 2d 72 65 66 20 27 61 64 6a (alist-ref 'adj
b0b0: 2d 63 6f 72 65 2d 6c 6f 61 64 0a 20 20 20 20 20 -core-load.
b0c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b0e0: 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 host-last-cpuloa
b0f0: 64 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 d (hash-table-re
b100: 66 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 62 f *host-loads* b
b110: 65 73 74 2d 68 6f 73 74 29 29 29 29 29 0a 20 20 est-host))))).
b120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b130: 73 65 74 21 20 62 65 73 74 2d 68 6f 73 74 20 68 set! best-host h
b140: 6f 73 74 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 ostname))))).
b150: 20 20 20 20 20 20 20 20 68 6f 73 74 73 29 0a 20 hosts).
b160: 20 20 20 20 20 20 20 20 20 62 65 73 74 2d 68 6f best-ho
b170: 73 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 st))))..(define
b180: 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 (common:wait-for
b190: 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 -cpuload maxload
b1a0: 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c numcpus waitdel
b1b0: 61 79 20 23 21 6b 65 79 20 28 63 6f 75 6e 74 20 ay #!key (count
b1c0: 31 30 30 30 29 20 28 6d 73 67 20 23 66 29 28 72 1000) (msg #f)(r
b1d0: 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a emote-host #f)).
b1e0: 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 61 76 (let* ((loadav
b1f0: 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 g (common:get-cp
b200: 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f u-load remote-ho
b210: 73 74 29 29 0a 09 20 28 66 69 72 73 74 20 20 20 st)).. (first
b220: 28 63 61 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 (car loadavg))..
b230: 20 28 6e 65 78 74 20 20 20 20 28 63 61 64 72 20 (next (cadr
b240: 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 61 64 6a loadavg)).. (adj
b250: 6c 6f 61 64 20 28 2a 20 6d 61 78 6c 6f 61 64 20 load (* maxload
b260: 6e 75 6d 63 70 75 73 29 29 0a 09 20 28 6c 6f 61 numcpus)).. (loa
b270: 64 6a 6d 70 20 28 2d 20 66 69 72 73 74 20 6e 65 djmp (- first ne
b280: 78 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a xt))). (cond.
b290: 20 20 20 20 20 28 28 61 6e 64 20 28 3e 20 66 69 ((and (> fi
b2a0: 72 73 74 20 61 64 6a 6c 6f 61 64 29 0a 09 20 20 rst adjload)..
b2b0: 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 (> count 0)).
b2c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
b2d0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
b2e0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 -log-port* "wait
b2f0: 69 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 20 ing " waitdelay
b300: 22 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f " seconds due to
b310: 20 6c 6f 61 64 20 22 20 66 69 72 73 74 20 22 20 load " first "
b320: 65 78 63 65 65 64 69 6e 67 20 6d 61 78 20 6f 66 exceeding max of
b330: 20 22 20 61 64 6a 6c 6f 61 64 20 28 69 66 20 6d " adjload (if m
b340: 73 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 20 sg msg "")).
b350: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
b360: 20 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 20 waitdelay).
b370: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 (common:wait-f
b380: 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f or-cpuload maxlo
b390: 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 ad numcpus waitd
b3a0: 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 elay count: (- c
b3b0: 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 28 ount 1))). (
b3c0: 28 61 6e 64 20 28 3e 20 6c 6f 61 64 6a 6d 70 20 (and (> loadjmp
b3d0: 6e 75 6d 63 70 75 73 29 0a 09 20 20 20 28 3e 20 numcpus).. (>
b3e0: 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 20 count 0)).
b3f0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
b400: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
b410: 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 6e 67 20 -port* "waiting
b420: 22 20 77 61 69 74 64 65 6c 61 79 20 22 20 73 65 " waitdelay " se
b430: 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f 61 conds due to loa
b440: 64 20 6a 75 6d 70 20 22 20 6c 6f 61 64 6a 6d 70 d jump " loadjmp
b450: 20 22 20 3e 20 6e 75 6d 63 70 75 73 20 22 20 6e " > numcpus " n
b460: 75 6d 63 70 75 73 20 28 69 66 20 6d 73 67 20 6d umcpus (if msg m
b470: 73 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 sg "")). (t
b480: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 77 61 69 hread-sleep! wai
b490: 74 64 65 6c 61 79 29 0a 20 20 20 20 20 20 28 63 tdelay). (c
b4a0: 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 ommon:wait-for-c
b4b0: 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e puload maxload n
b4c0: 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 umcpus waitdelay
b4d0: 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 count: (- count
b4e0: 20 31 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 1))))))..(defin
b4f0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 e (common:get-nu
b500: 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f m-cpus remote-ho
b510: 73 74 29 0a 20 20 28 6c 65 74 20 28 28 70 72 6f st). (let ((pro
b520: 63 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 28 c (lambda ()...(
b530: 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 6d 63 70 let loop ((numcp
b540: 75 20 30 29 0a 09 09 09 20 20 20 28 69 6e 6c 20 u 0).... (inl
b550: 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 (read-line)))
b560: 0a 09 09 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 ... (if (eof-ob
b570: 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 09 20 20 20 ject? inl)...
b580: 20 20 20 6e 75 6d 63 70 75 0a 09 09 20 20 20 20 numcpu...
b590: 20 20 28 6c 6f 6f 70 20 28 69 66 20 28 73 74 72 (loop (if (str
b5a0: 69 6e 67 2d 6d 61 74 63 68 20 22 5e 70 72 6f 63 ing-match "^proc
b5b0: 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b 5c 5c essor\\s+:\\s+\\
b5c0: 64 2b 24 22 20 69 6e 6c 29 0a 09 09 09 09 28 2b d+$" inl).....(+
b5d0: 20 6e 75 6d 63 70 75 20 31 29 0a 09 09 09 09 6e numcpu 1).....n
b5e0: 75 6d 63 70 75 29 0a 09 09 09 20 20 20 20 28 72 umcpu).... (r
b5f0: 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 29 29 0a ead-line))))))).
b600: 20 20 20 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 (if remote-h
b610: 6f 73 74 0a 09 28 77 69 74 68 2d 69 6e 70 75 74 ost..(with-input
b620: 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 20 28 63 -from-pipe .. (c
b630: 6f 6e 63 20 22 73 73 68 20 22 20 72 65 6d 6f 74 onc "ssh " remot
b640: 65 2d 68 6f 73 74 20 22 20 63 61 74 20 2f 70 72 e-host " cat /pr
b650: 6f 63 2f 63 70 75 69 6e 66 6f 22 29 0a 09 20 70 oc/cpuinfo").. p
b660: 72 6f 63 29 0a 09 28 77 69 74 68 2d 69 6e 70 75 roc)..(with-inpu
b670: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 t-from-file "/pr
b680: 6f 63 2f 63 70 75 69 6e 66 6f 22 20 70 72 6f 63 oc/cpuinfo" proc
b690: 29 29 29 29 0a 0a 3b 3b 20 77 61 69 74 20 66 6f ))))..;; wait fo
b6a0: 72 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 r normalized cpu
b6b0: 20 6c 6f 61 64 20 74 6f 20 64 72 6f 70 20 62 65 load to drop be
b6c0: 6c 6f 77 20 6d 61 78 6c 6f 61 64 0a 3b 3b 0a 28 low maxload.;;.(
b6d0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
b6e0: 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a ait-for-normaliz
b6f0: 65 64 2d 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 ed-load maxload
b700: 23 21 6b 65 79 20 28 6d 73 67 20 23 66 29 28 72 #!key (msg #f)(r
b710: 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a emote-host #f)).
b720: 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 63 70 75 (let ((num-cpu
b730: 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 s (common:get-nu
b740: 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f m-cpus remote-ho
b750: 73 74 29 29 29 0a 20 20 20 20 28 63 6f 6d 6d 6f st))). (commo
b760: 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f n:wait-for-cpulo
b770: 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 2d 63 ad maxload num-c
b780: 70 75 73 20 31 35 20 6d 73 67 3a 20 6d 73 67 29 pus 15 msg: msg)
b790: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 ))..(define (get
b7a0: 2d 75 6e 61 6d 65 20 2e 20 70 61 72 61 6d 73 29 -uname . params)
b7b0: 0a 20 20 28 6c 65 74 2a 20 28 28 75 6e 61 6d 65 . (let* ((uname
b7c0: 2d 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d -res (process:cm
b7d0: 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e d-run->list (con
b7e0: 63 20 22 75 6e 61 6d 65 20 22 20 28 69 66 20 28 c "uname " (if (
b7f0: 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 2d null? params) "-
b800: 61 22 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 a" (car params))
b810: 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 23 66 29 ))).. (uname #f)
b820: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
b830: 20 28 63 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 (car uname-res)
b840: 29 0a 09 22 75 6e 6b 6e 6f 77 6e 22 0a 09 28 63 ).."unknown"..(c
b850: 61 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 29 aar uname-res)))
b860: 29 0a 0a 3b 3b 20 66 6f 72 20 72 65 61 73 6f 6e )..;; for reason
b870: 73 20 49 20 64 6f 6e 27 74 20 75 6e 64 65 72 73 s I don't unders
b880: 74 61 6e 64 20 6d 75 6c 74 69 70 6c 65 20 63 61 tand multiple ca
b890: 6c 6c 73 20 74 6f 20 72 65 61 6c 2d 70 61 74 68 lls to real-path
b8a0: 20 69 6e 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 in parallel thr
b8b0: 65 61 64 73 0a 3b 3b 20 6d 75 73 74 20 62 65 20 eads.;; must be
b8c0: 70 72 6f 74 65 63 74 65 64 20 62 79 20 6d 75 74 protected by mut
b8d0: 65 78 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 exes.;;.(define
b8e0: 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 (common:real-pat
b8f0: 68 20 69 6e 70 61 74 68 29 0a 20 20 3b 3b 20 28 h inpath). ;; (
b900: 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d process:cmd-run-
b910: 77 69 74 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 with-stderr->lis
b920: 74 20 22 72 65 61 64 6c 69 6e 6b 22 20 22 2d 66 t "readlink" "-f
b930: 22 20 69 6e 70 61 74 68 29 29 20 3b 3b 20 63 6d " inpath)) ;; cm
b940: 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b d . params). ;;
b950: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 0a 20 20 (let-values .
b960: 3b 3b 20 20 28 28 28 69 6e 70 20 6f 75 70 20 70 ;; (((inp oup p
b970: 69 64 29 20 28 70 72 6f 63 65 73 73 20 22 72 65 id) (process "re
b980: 61 64 6c 69 6e 6b 22 20 28 6c 69 73 74 20 22 2d adlink" (list "-
b990: 66 22 20 69 6e 70 61 74 68 29 29 29 29 0a 20 20 f" inpath)))).
b9a0: 3b 3b 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ;; (with-input-
b9b0: 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 0a 20 20 from-port inp.
b9c0: 3b 3b 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ;; (let loop
b9d0: 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 ((inl (read-line
b9e0: 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 09 28 )). ;; .(
b9f0: 72 65 73 20 23 66 29 29 0a 20 20 3b 3b 20 20 20 res #f)). ;;
ba00: 20 20 20 28 70 72 69 6e 74 20 22 69 6e 6c 3d 22 (print "inl="
ba10: 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 inl). ;;
ba20: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
ba30: 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 inl). ;;
ba40: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 3b 3b 20 (begin. ;;
ba50: 20 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 (clos
ba60: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 e-input-port inp
ba70: 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ). ;;
ba80: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
ba90: 70 6f 72 74 20 6f 75 70 29 0a 20 20 3b 3b 20 20 port oup). ;;
baa0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ;; (pr
bab0: 6f 63 65 73 73 2d 77 61 69 74 20 70 69 64 29 0a ocess-wait pid).
bac0: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
bad0: 72 65 73 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 res). ;;
bae0: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c (loop (read-l
baf0: 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 29 0a 20 ine) inl)))))).
bb00: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
bb10: 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 72 65 m-pipe (conc "re
bb20: 61 64 6c 69 6e 6b 20 2d 66 20 22 20 69 6e 70 61 adlink -f " inpa
bb30: 74 68 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 0a th) read-line)).
bb40: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
bb50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bb60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bb70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bb80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 =========.;; D I
bb90: 20 53 20 4b 20 20 20 53 20 50 20 41 20 43 20 45 S K S P A C E
bba0: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
bbb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bbc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bbd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bbe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
bbf0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
bc00: 64 69 73 6b 2d 73 70 61 63 65 2d 75 73 65 64 20 disk-space-used
bc10: 66 70 61 74 68 29 0a 20 20 28 77 69 74 68 2d 69 fpath). (with-i
bc20: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 nput-from-pipe (
bc30: 63 6f 6e 63 20 22 2f 75 73 72 2f 62 69 6e 2f 64 conc "/usr/bin/d
bc40: 75 20 2d 73 20 22 20 66 70 61 74 68 29 20 72 65 u -s " fpath) re
bc50: 61 64 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 70 ad))..;; given p
bc60: 61 74 68 20 67 65 74 20 66 72 65 65 20 73 70 61 ath get free spa
bc70: 63 65 2c 20 61 6c 6c 6f 77 73 20 6f 76 65 72 72 ce, allows overr
bc80: 69 64 65 20 69 6e 20 5b 73 65 74 75 70 5d 0a 3b ide in [setup].;
bc90: 3b 20 77 69 74 68 20 66 72 65 65 2d 73 70 61 63 ; with free-spac
bca0: 65 2d 73 63 72 69 70 74 20 2f 70 61 74 68 2f 74 e-script /path/t
bcb0: 6f 2f 73 6f 6d 65 2f 73 63 72 69 70 74 2e 73 68 o/some/script.sh
bcc0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 74 .;;.(define (get
bcd0: 2d 64 66 20 70 61 74 68 29 0a 20 20 28 69 66 20 -df path). (if
bce0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
bcf0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
bd00: 75 70 22 20 22 66 72 65 65 2d 73 70 61 63 65 2d up" "free-space-
bd10: 73 63 72 69 70 74 22 29 0a 20 20 20 20 20 20 28 script"). (
bd20: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
bd30: 70 69 70 65 20 0a 20 20 20 20 20 20 20 28 63 6f pipe . (co
bd40: 6e 63 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b nc (configf:look
bd50: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
bd60: 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 70 61 setup" "free-spa
bd70: 63 65 2d 73 63 72 69 70 74 22 29 20 22 20 22 20 ce-script") " "
bd80: 70 61 74 68 29 0a 20 20 20 20 20 20 20 28 6c 61 path). (la
bd90: 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 74 20 28 mbda ().. (let (
bda0: 28 72 65 73 20 28 72 65 61 64 2d 6c 69 6e 65 29 (res (read-line)
bdb0: 29 29 0a 09 20 20 20 28 69 66 20 28 73 74 72 69 )).. (if (stri
bdc0: 6e 67 3f 20 72 65 73 29 0a 09 20 20 20 20 20 20 ng? res)..
bdd0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
bde0: 20 72 65 73 29 29 29 29 29 0a 20 20 20 20 20 20 res))))).
bdf0: 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 (get-unix-df pat
be00: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 h)))..(define (g
be10: 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 68 29 et-unix-df path)
be20: 0a 20 20 28 6c 65 74 2a 20 28 28 64 66 2d 72 65 . (let* ((df-re
be30: 73 75 6c 74 73 20 28 70 72 6f 63 65 73 73 3a 63 sults (process:c
be40: 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f md-run->list (co
be50: 6e 63 20 22 64 66 20 22 20 70 61 74 68 29 29 29 nc "df " path)))
be60: 0a 09 20 28 73 70 61 63 65 2d 72 78 20 20 20 28 .. (space-rx (
be70: 72 65 67 65 78 70 20 22 28 5b 30 2d 39 5d 2b 29 regexp "([0-9]+)
be80: 5c 5c 73 2b 28 5b 30 2d 39 5d 2b 29 25 22 29 29 \\s+([0-9]+)%"))
be90: 0a 09 20 28 66 72 65 65 73 70 63 20 20 20 20 23 .. (freespc #
bea0: 66 29 29 0a 20 20 20 20 3b 3b 20 28 77 72 69 74 f)). ;; (writ
beb0: 65 20 64 66 2d 72 65 73 75 6c 74 73 29 0a 20 20 e df-results).
bec0: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
bed0: 62 64 61 20 28 6c 29 0a 09 09 28 6c 65 74 20 28 bda (l)...(let (
bee0: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 73 (match (string-s
bef0: 65 61 72 63 68 20 73 70 61 63 65 2d 72 78 20 6c earch space-rx l
bf00: 29 29 29 0a 09 09 20 20 28 69 66 20 6d 61 74 63 )))... (if matc
bf10: 68 20 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 h ... (let
bf20: 28 28 6e 65 77 76 61 6c 20 28 73 74 72 69 6e 67 ((newval (string
bf30: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d ->number (cadr m
bf40: 61 74 63 68 29 29 29 29 0a 09 09 09 28 69 66 20 atch))))....(if
bf50: 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 (number? newval)
bf60: 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 66 72 .... (set! fr
bf70: 65 65 73 70 63 20 6e 65 77 76 61 6c 29 29 29 29 eespc newval))))
bf80: 29 29 0a 09 20 20 20 20 20 20 28 63 61 72 20 64 )).. (car d
bf90: 66 2d 72 65 73 75 6c 74 73 29 29 0a 20 20 20 20 f-results)).
bfa0: 66 72 65 65 73 70 63 29 29 0a 0a 28 64 65 66 69 freespc))..(defi
bfb0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b ne (common:check
bfc0: 2d 73 70 61 63 65 2d 69 6e 2d 64 69 72 20 64 69 -space-in-dir di
bfd0: 72 70 61 74 68 20 72 65 71 75 69 72 65 64 29 0a rpath required).
bfe0: 20 20 28 6c 65 74 2a 20 28 28 64 62 73 70 61 63 (let* ((dbspac
bff0: 65 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 e (if (director
c000: 79 3f 20 64 69 72 70 61 74 68 29 0a 09 09 20 20 y? dirpath)...
c010: 20 20 20 20 20 28 67 65 74 2d 64 66 20 64 69 72 (get-df dir
c020: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 30 path)... 0
c030: 29 29 29 0a 20 20 20 20 28 6c 69 73 74 20 28 3e ))). (list (>
c040: 20 64 62 73 70 61 63 65 20 72 65 71 75 69 72 65 dbspace require
c050: 64 29 0a 09 20 20 64 62 73 70 61 63 65 0a 09 20 d).. dbspace..
c060: 20 72 65 71 75 69 72 65 64 0a 09 20 20 64 69 72 required.. dir
c070: 70 61 74 68 29 29 29 0a 0a 3b 3b 20 63 68 65 63 path)))..;; chec
c080: 6b 20 73 70 61 63 65 20 69 6e 20 64 62 64 69 72 k space in dbdir
c090: 20 61 6e 64 20 69 6e 20 6d 65 67 61 74 65 73 74 and in megatest
c0a0: 20 64 69 72 0a 3b 3b 20 72 65 74 75 72 6e 73 3a dir.;; returns:
c0b0: 20 6f 6b 2f 6e 6f 74 20 64 62 73 70 61 63 65 20 ok/not dbspace
c0c0: 72 65 71 75 69 72 65 64 2d 73 70 61 63 65 0a 3b required-space.;
c0d0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
c0e0: 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 73 n:check-db-dir-s
c0f0: 70 61 63 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 pace). (let* ((
c100: 72 65 71 75 69 72 65 64 20 28 73 74 72 69 6e 67 required (string
c110: 2d 3e 6e 75 6d 62 65 72 20 0a 09 09 20 20 20 20 ->number ...
c120: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
c130: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
c140: 22 73 65 74 75 70 22 20 22 64 62 64 69 72 2d 73 "setup" "dbdir-s
c150: 70 61 63 65 2d 72 65 71 75 69 72 65 64 22 29 0a pace-required").
c160: 09 09 09 22 31 30 30 30 30 30 22 29 29 29 0a 09 ..."100000")))..
c170: 20 28 64 62 64 69 72 20 20 20 20 28 63 6f 6d 6d (dbdir (comm
c180: 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 on:get-db-tmp-ar
c190: 65 61 29 29 20 3b 3b 20 28 64 62 3a 67 65 74 2d ea)) ;; (db:get-
c1a0: 64 62 64 69 72 29 29 0a 09 20 28 74 64 62 73 70 dbdir)).. (tdbsp
c1b0: 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 ace (common:chec
c1c0: 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 72 20 64 k-space-in-dir d
c1d0: 62 64 69 72 20 72 65 71 75 69 72 65 64 29 29 0a bdir required)).
c1e0: 09 20 28 6d 64 62 73 70 61 63 65 20 28 63 6f 6d . (mdbspace (com
c1f0: 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 63 65 2d mon:check-space-
c200: 69 6e 2d 64 69 72 20 2a 74 6f 70 70 61 74 68 2a in-dir *toppath*
c210: 20 72 65 71 75 69 72 65 64 29 29 29 0a 20 20 20 required))).
c220: 20 28 73 6f 72 74 20 28 6c 69 73 74 20 74 64 62 (sort (list tdb
c230: 73 70 61 63 65 20 6d 64 62 73 70 61 63 65 29 20 space mdbspace)
c240: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 (lambda (a b)...
c250: 09 09 20 20 20 20 20 28 3c 20 28 63 61 64 72 20 .. (< (cadr
c260: 61 29 28 63 61 64 72 20 62 29 29 29 29 29 29 0a a)(cadr b)))))).
c270: 20 20 20 20 0a 3b 3b 20 63 68 65 63 6b 20 61 76 .;; check av
c280: 61 69 6c 61 62 6c 65 20 73 70 61 63 65 20 69 6e ailable space in
c290: 20 64 62 64 69 72 2c 20 65 78 69 74 20 69 66 20 dbdir, exit if
c2a0: 69 6e 73 75 66 66 69 63 69 65 6e 74 0a 3b 3b 0a insufficient.;;.
c2b0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
c2c0: 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 61 6e 64 check-db-dir-and
c2d0: 2d 65 78 69 74 2d 69 66 2d 69 6e 73 75 66 66 69 -exit-if-insuffi
c2e0: 63 69 65 6e 74 29 0a 20 20 28 6c 65 74 2a 20 28 cient). (let* (
c2f0: 28 73 70 61 63 65 64 61 74 20 28 63 61 72 20 28 (spacedat (car (
c300: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d common:check-db-
c310: 64 69 72 2d 73 70 61 63 65 29 29 29 20 3b 3b 20 dir-space))) ;;
c320: 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 77 6f 72 look only at wor
c330: 73 74 20 66 6f 72 20 6e 6f 77 0a 09 20 28 69 73 st for now.. (is
c340: 2d 6f 6b 20 20 20 20 28 63 61 72 20 73 70 61 63 -ok (car spac
c350: 65 64 61 74 29 29 0a 09 20 28 64 62 73 70 61 63 edat)).. (dbspac
c360: 65 20 20 28 63 61 64 72 20 73 70 61 63 65 64 61 e (cadr spaceda
c370: 74 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 20 t)).. (required
c380: 28 63 61 64 64 72 20 73 70 61 63 65 64 61 74 29 (caddr spacedat)
c390: 29 0a 09 20 28 64 62 64 69 72 20 20 20 20 28 63 ).. (dbdir (c
c3a0: 61 64 64 64 72 20 73 70 61 63 65 64 61 74 29 29 adddr spacedat))
c3b0: 29 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 ). (if (not i
c3c0: 73 2d 6f 6b 29 0a 09 28 62 65 67 69 6e 0a 09 20 s-ok)..(begin..
c3d0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
c3e0: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
c3f0: 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 73 75 66 66 og-port* "Insuff
c400: 69 63 69 65 6e 74 20 73 70 61 63 65 20 69 6e 20 icient space in
c410: 22 20 64 62 64 69 72 20 22 2c 20 72 65 71 75 69 " dbdir ", requi
c420: 72 65 20 22 20 72 65 71 75 69 72 65 64 20 22 2c re " required ",
c430: 20 68 61 76 65 20 22 20 64 62 73 70 61 63 65 20 have " dbspace
c440: 20 22 2c 20 65 78 69 74 69 6e 67 20 6e 6f 77 2e ", exiting now.
c450: 22 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 ").. (exit 1)))
c460: 29 29 0a 20 20 0a 3b 3b 20 70 61 74 68 73 20 69 )). .;; paths i
c470: 73 20 6c 69 73 74 20 6f 66 20 6c 69 73 74 73 20 s list of lists
c480: 28 28 6e 61 6d 65 20 70 61 74 68 29 20 2e 2e 2e ((name path) ...
c490: 20 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ).;;.(define (c
c4a0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d 77 ommon:get-disk-w
c4b0: 69 74 68 2d 6d 6f 73 74 2d 66 72 65 65 2d 73 70 ith-most-free-sp
c4c0: 61 63 65 20 64 69 73 6b 73 20 6d 69 6e 73 69 7a ace disks minsiz
c4d0: 65 29 0a 20 20 28 6c 65 74 20 28 28 62 65 73 74 e). (let ((best
c4e0: 20 20 20 20 20 23 66 29 0a 09 28 62 65 73 74 73 #f)..(bests
c4f0: 69 7a 65 20 30 29 29 0a 20 20 20 20 28 66 6f 72 ize 0)). (for
c500: 2d 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d -each . (lam
c510: 62 64 61 20 28 64 69 73 6b 2d 6e 75 6d 29 0a 20 bda (disk-num).
c520: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 69 (let* ((di
c530: 72 70 61 74 68 20 20 20 20 28 63 61 64 72 20 28 rpath (cadr (
c540: 61 73 73 6f 63 20 64 69 73 6b 2d 6e 75 6d 20 64 assoc disk-num d
c550: 69 73 6b 73 29 29 29 0a 09 20 20 20 20 20 20 28 isks))).. (
c560: 66 72 65 65 73 70 63 20 20 20 20 28 63 6f 6e 64 freespc (cond
c570: 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 28 64 69 .... ((not (di
c580: 72 65 63 74 6f 72 79 3f 20 64 69 72 70 61 74 68 rectory? dirpath
c590: 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 63 )).... (if (c
c5a0: 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d ommon:low-noise-
c5b0: 70 72 69 6e 74 20 33 30 30 20 22 64 69 73 6b 73 print 300 "disks
c5c0: 20 6e 6f 74 20 61 20 64 69 72 20 22 20 64 69 73 not a dir " dis
c5d0: 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 75 k-num).....(debu
c5e0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
c5f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
c600: 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 RNING: disk " di
c610: 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 68 sk-num " at path
c620: 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c 22 \"" dirpath "\"
c630: 20 69 73 20 6e 6f 74 20 61 20 64 69 72 65 63 74 is not a direct
c640: 6f 72 79 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 ory - ignoring i
c650: 74 2e 22 29 29 0a 09 09 09 20 20 20 20 2d 31 29 t.")).... -1)
c660: 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 28 66 69 .... ((not (fi
c670: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
c680: 20 64 69 72 70 61 74 68 29 29 0a 09 09 09 20 20 dirpath))....
c690: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f (if (common:lo
c6a0: 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 w-noise-print 30
c6b0: 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 77 72 69 0 "disks not wri
c6c0: 74 65 61 62 6c 65 20 22 20 64 69 73 6b 2d 6e 75 teable " disk-nu
c6d0: 6d 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 m).....(debug:pr
c6e0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
c6f0: 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e og-port* "WARNIN
c700: 47 3a 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e G: disk " disk-n
c710: 75 6d 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 um " at path \""
c720: 20 64 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 dirpath "\" is
c730: 6e 6f 74 20 77 72 69 74 65 61 62 6c 65 20 2d 20 not writeable -
c740: 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 29 0a ignoring it.")).
c750: 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 20 20 ... -1)....
c760: 20 28 28 6e 6f 74 20 28 65 71 3f 20 28 73 74 72 ((not (eq? (str
c770: 69 6e 67 2d 72 65 66 20 64 69 72 70 61 74 68 20 ing-ref dirpath
c780: 30 29 20 23 5c 2f 29 29 0a 09 09 09 20 20 20 20 0) #\/))....
c790: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
c7a0: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 noise-print 300
c7b0: 22 64 69 73 6b 73 20 6e 6f 74 20 61 20 70 72 6f "disks not a pro
c7c0: 70 65 72 20 70 61 74 68 20 22 20 64 69 73 6b 2d per path " disk-
c7d0: 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 75 67 3a num).....(debug:
c7e0: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
c7f0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e -log-port* "WARN
c800: 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 73 6b ING: disk " disk
c810: 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 68 20 5c -num " at path \
c820: 22 22 20 64 69 72 70 61 74 68 20 22 5c 22 20 69 "" dirpath "\" i
c830: 73 20 6e 6f 74 20 61 20 66 75 6c 6c 79 20 71 75 s not a fully qu
c840: 61 6c 69 66 69 65 64 20 70 61 74 68 20 2d 20 69 alified path - i
c850: 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 29 0a 09 gnoring it."))..
c860: 09 09 20 20 20 20 2d 31 29 0a 09 09 09 20 20 20 .. -1)....
c870: 28 65 6c 73 65 0a 09 09 09 20 20 20 20 28 67 65 (else.... (ge
c880: 74 2d 64 66 20 64 69 72 70 61 74 68 29 29 29 29 t-df dirpath))))
c890: 29 0a 09 20 28 69 66 20 28 3e 20 66 72 65 65 73 ).. (if (> frees
c8a0: 70 63 20 62 65 73 74 73 69 7a 65 29 0a 09 20 20 pc bestsize)..
c8b0: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
c8c0: 20 20 28 73 65 74 21 20 62 65 73 74 20 20 20 20 (set! best
c8d0: 20 28 63 6f 6e 73 20 64 69 73 6b 2d 6e 75 6d 20 (cons disk-num
c8e0: 64 69 72 70 61 74 68 29 29 0a 09 20 20 20 20 20 dirpath))..
c8f0: 20 20 28 73 65 74 21 20 62 65 73 74 73 69 7a 65 (set! bestsize
c900: 20 66 72 65 65 73 70 63 29 29 29 29 29 0a 20 20 freespc))))).
c910: 20 20 20 28 6d 61 70 20 63 61 72 20 64 69 73 6b (map car disk
c920: 73 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 s)). (if (and
c930: 20 62 65 73 74 20 28 3e 20 62 65 73 74 73 69 7a best (> bestsiz
c940: 65 20 6d 69 6e 73 69 7a 65 29 29 0a 09 62 65 73 e minsize))..bes
c950: 74 0a 09 23 66 29 29 29 20 3b 3b 20 23 66 20 6d t..#f))) ;; #f m
c960: 65 61 6e 73 20 6e 6f 20 64 69 73 6b 20 63 61 6e eans no disk can
c970: 64 69 64 61 74 65 20 66 6f 75 6e 64 0a 0a 3b 3b didate found..;;
c980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c9b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c9c0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 4e 20 56 20 ======.;; E N V
c9d0: 49 20 52 20 4f 20 4e 20 4d 20 45 20 4e 20 54 20 I R O N M E N T
c9e0: 20 20 56 20 41 20 52 20 53 0a 3b 3b 3d 3d 3d 3d V A R S.;;====
c9f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ca30: 3d 3d 0a 09 20 20 20 20 20 20 0a 28 64 65 66 69 ==.. .(defi
ca40: 6e 65 20 28 73 61 76 65 2d 65 6e 76 69 72 6f 6e ne (save-environ
ca50: 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 73 20 66 6e ment-as-files fn
ca60: 61 6d 65 20 23 21 6b 65 79 20 28 69 67 6e 6f 72 ame #!key (ignor
ca70: 65 76 61 72 73 20 28 6c 69 73 74 20 22 55 53 45 evars (list "USE
ca80: 52 22 20 22 48 4f 4d 45 22 20 22 44 49 53 50 4c R" "HOME" "DISPL
ca90: 41 59 22 20 22 4c 53 5f 43 4f 4c 4f 52 53 22 20 AY" "LS_COLORS"
caa0: 22 58 4b 45 59 53 59 4d 44 42 22 20 22 45 44 49 "XKEYSYMDB" "EDI
cab0: 54 4f 52 22 20 22 4d 41 4b 45 46 4c 41 47 53 22 TOR" "MAKEFLAGS"
cac0: 20 22 4d 41 4b 45 46 22 20 22 4d 41 4b 45 4f 56 "MAKEF" "MAKEOV
cad0: 45 52 52 49 44 45 53 22 29 29 29 0a 20 20 28 6c ERRIDES"))). (l
cae0: 65 74 20 28 28 65 6e 76 76 61 72 73 20 28 67 65 et ((envvars (ge
caf0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
cb00: 72 69 61 62 6c 65 73 29 29 0a 20 20 20 20 20 20 riables)).
cb10: 20 20 28 77 68 69 74 65 73 70 20 28 72 65 67 65 (whitesp (rege
cb20: 78 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 2d 39 5f xp "[^a-zA-Z0-9_
cb30: 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 24 5d 22 29 29 0a \\-:,.\\/%$]")).
cb40: 09 28 6d 75 6e 67 65 76 61 6c 20 28 6c 61 6d 62 .(mungeval (lamb
cb50: 64 61 20 28 76 61 6c 29 0a 09 09 20 20 20 20 28 da (val)... (
cb60: 63 6f 6e 64 0a 09 09 20 20 20 20 20 28 28 65 71 cond... ((eq
cb70: 3f 20 76 61 6c 20 23 74 29 20 22 22 29 20 3b 3b ? val #t) "") ;;
cb80: 20 63 6f 6e 76 65 72 74 20 23 74 20 74 6f 20 65 convert #t to e
cb90: 6d 70 74 79 20 73 74 72 69 6e 67 0a 09 09 20 20 mpty string...
cba0: 20 20 20 28 28 65 71 3f 20 76 61 6c 20 23 66 29 ((eq? val #f)
cbb0: 20 23 66 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 #f) ;; convert
cbc0: 23 66 20 74 6f 20 69 74 73 65 6c 66 20 28 73 74 #f to itself (st
cbd0: 69 6c 6c 20 74 68 69 6e 6b 69 6e 67 20 61 62 6f ill thinking abo
cbe0: 75 74 20 74 68 69 73 20 6f 6e 65 0a 09 09 20 20 ut this one...
cbf0: 20 20 20 28 65 6c 73 65 20 76 61 6c 29 29 29 29 (else val))))
cc00: 29 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 ). (with-out
cc10: 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e put-to-file (con
cc20: 63 20 66 6e 61 6d 65 20 22 2e 63 73 68 22 29 0a c fname ".csh").
cc30: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
cc40: 29 0a 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 ). (for
cc50: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b -each (lambda (k
cc60: 65 79 76 61 6c 29 0a 09 09 20 20 20 20 20 20 28 eyval)... (
cc70: 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 28 63 61 let* ((key (ca
cc80: 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 r keyval))....
cc90: 20 20 20 28 76 61 6c 20 20 20 28 63 64 72 20 6b (val (cdr k
cca0: 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 eyval))....
ccb0: 28 64 65 6c 69 6d 20 28 69 66 20 28 73 74 72 69 (delim (if (stri
ccc0: 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 73 ng-search whites
ccd0: 70 20 76 61 6c 29 20 0a 09 09 09 09 09 22 5c 22 p val) ......"\"
cce0: 22 0a 09 09 09 09 09 22 22 29 29 29 0a 09 09 09 "......"")))....
ccf0: 28 70 72 69 6e 74 20 28 69 66 20 28 6d 65 6d 62 (print (if (memb
cd00: 65 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 72 er key ignorevar
cd10: 73 29 0a 09 09 09 09 20 20 20 22 23 20 73 65 74 s)..... "# set
cd20: 65 6e 76 20 22 0a 09 09 09 09 20 20 20 22 73 65 env "..... "se
cd30: 74 65 6e 76 20 22 29 0a 09 09 09 20 20 20 20 20 tenv ")....
cd40: 20 20 6b 65 79 20 22 20 22 20 64 65 6c 69 6d 20 key " " delim
cd50: 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 64 (mungeval val) d
cd60: 65 6c 69 6d 29 29 29 0a 09 09 20 20 20 20 65 6e elim)))... en
cd70: 76 76 61 72 73 29 29 29 0a 20 20 20 20 20 28 77 vvars))). (w
cd80: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 ith-output-to-fi
cd90: 6c 65 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 le (conc fname "
cda0: 2e 73 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 .sh"). (la
cdb0: 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 mbda ().
cdc0: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
cdd0: 62 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 bda (keyval)...
cde0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 (let* ((key
cdf0: 20 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 (car keyval))..
ce00: 09 09 20 20 20 20 20 28 76 61 6c 20 28 63 64 72 .. (val (cdr
ce10: 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 keyval))....
ce20: 20 20 28 64 65 6c 69 6d 20 28 69 66 20 28 73 74 (delim (if (st
ce30: 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 ring-search whit
ce40: 65 73 70 20 76 61 6c 29 20 0a 09 09 09 09 09 22 esp val) ......"
ce50: 5c 22 22 0a 09 09 09 09 09 22 22 29 29 29 0a 09 \""......"")))..
ce60: 09 09 28 70 72 69 6e 74 20 28 69 66 20 28 6d 65 ..(print (if (me
ce70: 6d 62 65 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 mber key ignorev
ce80: 61 72 73 29 0a 09 09 09 09 20 20 20 22 23 20 65 ars)..... "# e
ce90: 78 70 6f 72 74 20 22 0a 09 09 09 09 20 20 20 22 xport "..... "
cea0: 65 78 70 6f 72 74 20 22 29 0a 09 09 09 20 20 20 export ")....
ceb0: 20 20 20 20 6b 65 79 20 22 3d 22 20 64 65 6c 69 key "=" deli
cec0: 6d 20 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 m (mungeval val)
ced0: 20 64 65 6c 69 6d 29 29 29 0a 20 20 20 20 20 20 delim))).
cee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65 6e en
cef0: 76 76 61 72 73 29 29 29 29 29 0a 0a 3b 3b 20 73 vvars)))))..;; s
cf00: 65 74 20 73 6f 6d 65 20 65 6e 76 20 76 61 72 73 et some env vars
cf10: 20 66 72 6f 6d 20 61 6e 20 61 6c 69 73 74 2c 20 from an alist,
cf20: 72 65 74 75 72 6e 20 61 6e 20 61 6c 69 73 74 20 return an alist
cf30: 77 69 74 68 20 6f 72 69 67 69 6e 61 6c 20 76 61 with original va
cf40: 6c 75 65 73 0a 3b 3b 20 28 28 22 56 41 52 22 20 lues.;; (("VAR"
cf50: 22 76 61 6c 75 65 22 29 20 2e 2e 2e 29 0a 28 64 "value") ...).(d
cf60: 65 66 69 6e 65 20 28 61 6c 69 73 74 2d 3e 65 6e efine (alist->en
cf70: 76 2d 76 61 72 73 20 6c 73 74 29 0a 20 20 28 69 v-vars lst). (i
cf80: 66 20 28 6c 69 73 74 3f 20 6c 73 74 29 0a 20 20 f (list? lst).
cf90: 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 (let ((res '
cfa0: 28 29 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 ()))..(for-each
cfb0: 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 (lambda (p)...
cfc0: 20 20 28 6c 65 74 2a 20 28 28 76 61 72 20 28 63 (let* ((var (c
cfd0: 61 72 20 20 70 29 29 0a 09 09 09 20 20 20 28 76 ar p)).... (v
cfe0: 61 6c 20 28 63 61 64 72 20 70 29 29 0a 09 09 09 al (cadr p))....
cff0: 20 20 20 28 70 72 76 20 28 67 65 74 2d 65 6e 76 (prv (get-env
d000: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
d010: 65 20 76 61 72 29 29 29 0a 09 09 20 20 20 20 20 e var)))...
d020: 20 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 (set! res (cons
d030: 20 28 6c 69 73 74 20 76 61 72 20 70 72 76 29 20 (list var prv)
d040: 72 65 73 29 29 0a 09 09 20 20 20 20 20 20 28 69 res))... (i
d050: 66 20 76 61 6c 20 0a 09 09 09 20 20 28 73 65 74 f val .... (set
d060: 65 6e 76 20 76 61 72 20 28 2d 3e 73 74 72 69 6e env var (->strin
d070: 67 20 76 61 6c 29 29 0a 09 09 09 20 20 28 75 6e g val)).... (un
d080: 73 65 74 65 6e 76 20 76 61 72 29 29 29 29 0a 09 setenv var))))..
d090: 09 20 20 6c 73 74 29 0a 09 72 65 73 29 0a 20 20 . lst)..res).
d0a0: 20 20 20 20 27 28 29 29 29 0a 0a 3b 3b 20 63 6c '()))..;; cl
d0b0: 65 61 72 20 76 61 72 73 20 6d 61 74 63 68 69 6e ear vars matchin
d0c0: 67 20 70 61 74 74 65 72 6e 2c 20 72 75 6e 20 70 g pattern, run p
d0d0: 72 6f 63 2c 20 73 65 74 20 76 61 72 73 20 62 61 roc, set vars ba
d0e0: 63 6b 0a 3b 3b 20 69 66 20 70 72 6f 63 20 69 73 ck.;; if proc is
d0f0: 20 61 20 73 74 72 69 6e 67 20 72 75 6e 20 74 68 a string run th
d100: 61 74 20 73 74 72 69 6e 67 20 61 73 20 61 20 63 at string as a c
d110: 6f 6d 6d 61 6e 64 20 77 69 74 68 0a 3b 3b 20 73 ommand with.;; s
d120: 79 73 74 65 6d 2e 0a 3b 3b 0a 28 64 65 66 69 6e ystem..;;.(defin
d130: 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 e (common:withou
d140: 74 2d 76 61 72 73 20 70 72 6f 63 20 2e 20 76 61 t-vars proc . va
d150: 72 2d 70 61 74 74 73 29 0a 20 20 28 6c 65 74 20 r-patts). (let
d160: 28 28 76 61 72 73 20 28 6d 61 6b 65 2d 68 61 73 ((vars (make-has
d170: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 h-table))). (
d180: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
d190: 61 6d 62 64 61 20 28 76 61 72 64 61 74 29 20 3b ambda (vardat) ;
d1a0: 3b 20 65 61 63 68 20 65 6e 76 20 76 61 72 0a 20 ; each env var.
d1b0: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a (for-each.
d1c0: 09 28 6c 61 6d 62 64 61 20 28 76 61 72 2d 70 61 .(lambda (var-pa
d1d0: 74 74 29 0a 09 20 20 28 69 66 20 28 73 74 72 69 tt).. (if (stri
d1e0: 6e 67 2d 6d 61 74 63 68 20 76 61 72 2d 70 61 74 ng-match var-pat
d1f0: 74 20 28 63 61 72 20 76 61 72 64 61 74 29 29 0a t (car vardat)).
d200: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 . (let ((va
d210: 72 20 28 63 61 72 20 76 61 72 64 61 74 29 29 0a r (car vardat)).
d220: 09 09 20 20 20 20 28 76 61 6c 20 28 63 64 72 20 .. (val (cdr
d230: 76 61 72 64 61 74 29 29 29 0a 09 09 28 68 61 73 vardat)))...(has
d240: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 76 61 72 h-table-set! var
d250: 73 20 76 61 72 20 76 61 6c 29 0a 09 09 28 75 6e s var val)...(un
d260: 73 65 74 65 6e 76 20 76 61 72 29 29 29 29 0a 09 setenv var))))..
d270: 76 61 72 2d 70 61 74 74 73 29 29 0a 20 20 20 20 var-patts)).
d280: 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e (get-environmen
d290: 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 t-variables)).
d2a0: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 73 (cond. ((s
d2b0: 74 72 69 6e 67 3f 20 70 72 6f 63 29 28 73 79 73 tring? proc)(sys
d2c0: 74 65 6d 20 70 72 6f 63 29 29 0a 20 20 20 20 20 tem proc)).
d2d0: 28 70 72 6f 63 20 20 20 20 20 20 20 20 20 20 28 (proc (
d2e0: 70 72 6f 63 29 29 29 0a 20 20 20 20 28 68 61 73 proc))). (has
d2f0: 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 h-table-for-each
d300: 0a 20 20 20 20 20 76 61 72 73 0a 20 20 20 20 20 . vars.
d310: 28 6c 61 6d 62 64 61 20 28 76 61 72 20 76 61 6c (lambda (var val
d320: 29 0a 20 20 20 20 20 20 20 28 73 65 74 65 6e 76 ). (setenv
d330: 20 76 61 72 20 76 61 6c 29 29 29 0a 20 20 20 20 var val))).
d340: 76 61 72 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 vars))..(define
d350: 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 61 2d 63 6f (common:run-a-co
d360: 6d 6d 61 6e 64 20 63 6d 64 20 23 21 6b 65 79 20 mmand cmd #!key
d370: 28 77 69 74 68 2d 76 61 72 73 20 23 66 29 29 0a (with-vars #f)).
d380: 20 20 28 6c 65 74 2a 20 28 28 70 72 65 2d 63 6d (let* ((pre-cm
d390: 64 20 20 28 64 74 65 73 74 73 3a 67 65 74 2d 70 d (dtests:get-p
d3a0: 72 65 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 re-command)).
d3b0: 20 20 20 20 20 20 28 70 6f 73 74 2d 63 6d 64 20 (post-cmd
d3c0: 28 64 74 65 73 74 73 3a 67 65 74 2d 70 6f 73 74 (dtests:get-post
d3d0: 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 20 20 -command)).
d3e0: 20 20 20 20 28 66 75 6c 6c 63 6d 64 20 20 28 69 (fullcmd (i
d3f0: 66 20 28 6f 72 20 70 72 65 2d 63 6d 64 20 70 6f f (or pre-cmd po
d400: 73 74 2d 63 6d 64 29 0a 20 20 20 20 20 20 20 20 st-cmd).
d410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d420: 63 6f 6e 63 20 70 72 65 2d 63 6d 64 20 63 6d 64 conc pre-cmd cmd
d430: 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 20 20 post-cmd).
d440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d450: 20 20 28 63 6f 6e 63 20 22 76 69 65 77 73 63 72 (conc "viewscr
d460: 65 65 6e 20 22 20 63 6d 64 29 29 29 29 0a 20 20 een " cmd)))).
d470: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
d480: 6e 66 6f 20 30 32 20 2a 64 65 66 61 75 6c 74 2d nfo 02 *default-
d490: 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 75 6e 6e 69 log-port* "Runni
d4a0: 6e 67 20 63 6f 6d 6d 61 6e 64 3a 20 22 20 66 75 ng command: " fu
d4b0: 6c 6c 63 6d 64 29 0a 20 20 20 20 28 69 66 20 77 llcmd). (if w
d4c0: 69 74 68 2d 76 61 72 73 0a 20 20 20 20 20 20 20 ith-vars.
d4d0: 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 (common:without
d4e0: 2d 76 61 72 73 20 63 6d 64 29 0a 20 20 20 20 20 -vars cmd).
d4f0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f (common:witho
d500: 75 74 2d 76 61 72 73 20 66 75 6c 6c 63 6d 64 20 ut-vars fullcmd
d510: 22 4d 54 5f 2e 2a 22 29 29 29 29 0a 09 09 20 20 "MT_.*"))))...
d520: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
d530: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 49 =========.;; T I
d570: 20 4d 20 45 20 20 20 41 20 4e 20 44 20 20 20 44 M E A N D D
d580: 20 41 20 54 20 45 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d A T E.;;=======
d590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d5a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d5b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d5c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
d5d0: 0a 3b 3b 20 43 6f 6e 76 65 72 74 20 73 74 72 69 .;; Convert stri
d5e0: 6e 67 73 20 6c 69 6b 65 20 22 35 73 20 32 68 20 ngs like "5s 2h
d5f0: 33 6d 22 20 3d 3e 20 36 30 78 36 30 78 32 20 2b 3m" => 60x60x2 +
d600: 20 33 78 36 30 20 2b 20 35 0a 28 64 65 66 69 6e 3x60 + 5.(defin
d610: 65 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 e (common:hms-st
d620: 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 74 73 ring->seconds ts
d630: 74 72 29 0a 20 20 28 6c 65 74 20 28 28 70 61 72 tr). (let ((par
d640: 74 73 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 ts (string-s
d650: 70 6c 69 74 20 74 73 74 72 29 29 0a 09 28 74 69 plit tstr))..(ti
d660: 6d 65 2d 73 65 63 73 20 30 29 0a 09 3b 3b 20 73 me-secs 0)..;; s
d670: 3d 73 65 63 6f 6e 64 73 2c 20 6d 3d 6d 69 6e 75 =seconds, m=minu
d680: 74 65 73 2c 20 68 3d 68 6f 75 72 73 2c 20 64 3d tes, h=hours, d=
d690: 64 61 79 73 0a 09 28 74 72 78 20 20 20 20 20 20 days..(trx
d6a0: 20 28 72 65 67 65 78 70 20 22 28 5c 5c 64 2b 29 (regexp "(\\d+)
d6b0: 28 5b 73 6d 68 64 5d 29 22 29 29 29 0a 20 20 20 ([smhd])"))).
d6c0: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
d6d0: 64 61 20 28 70 61 72 74 29 0a 09 09 28 6c 65 74 da (part)...(let
d6e0: 20 28 28 6d 61 74 63 68 20 20 28 73 74 72 69 6e ((match (strin
d6f0: 67 2d 6d 61 74 63 68 20 74 72 78 20 70 61 72 74 g-match trx part
d700: 29 29 29 0a 09 09 20 20 28 69 66 20 6d 61 74 63 )))... (if matc
d710: 68 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 h... (let (
d720: 28 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (val (string->nu
d730: 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 mber (cadr match
d740: 29 29 29 0a 09 09 09 20 20 20 20 28 75 6e 74 20 ))).... (unt
d750: 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 0a (caddr match))).
d760: 09 09 09 28 69 66 20 76 61 6c 20 0a 09 09 09 20 ...(if val ....
d770: 20 20 20 28 73 65 74 21 20 74 69 6d 65 2d 73 65 (set! time-se
d780: 63 73 20 28 2b 20 74 69 6d 65 2d 73 65 63 73 20 cs (+ time-secs
d790: 28 2a 20 76 61 6c 0a 09 09 09 09 09 09 09 20 20 (* val........
d7a0: 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
d7b0: 3e 73 79 6d 62 6f 6c 20 75 6e 74 29 0a 09 09 09 >symbol unt)....
d7c0: 09 09 09 09 20 20 20 20 20 20 28 28 73 29 20 31 .... ((s) 1
d7d0: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 )........ (
d7e0: 28 6d 29 20 36 30 29 0a 09 09 09 09 09 09 09 20 (m) 60)........
d7f0: 20 20 20 20 20 28 28 68 29 20 28 2a 20 36 30 20 ((h) (* 60
d800: 36 30 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 60))........
d810: 20 20 28 28 64 29 20 28 2a 20 32 34 20 36 30 20 ((d) (* 24 60
d820: 36 30 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 60))........
d830: 20 20 28 65 6c 73 65 20 30 29 29 29 29 29 29 29 (else 0)))))))
d840: 29 29 29 0a 09 20 20 20 20 20 20 70 61 72 74 73 ))).. parts
d850: 29 0a 20 20 20 20 74 69 6d 65 2d 73 65 63 73 29 ). time-secs)
d860: 29 0a 09 09 20 20 20 20 20 20 20 0a 28 64 65 66 )... .(def
d870: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 ine (seconds->hr
d880: 2d 6d 69 6e 2d 73 65 63 20 73 65 63 73 29 0a 20 -min-sec secs).
d890: 20 28 6c 65 74 2a 20 28 28 68 72 73 20 28 71 75 (let* ((hrs (qu
d8a0: 6f 74 69 65 6e 74 20 73 65 63 73 20 33 36 30 30 otient secs 3600
d8b0: 29 29 0a 09 20 28 6d 69 6e 20 28 71 75 6f 74 69 )).. (min (quoti
d8c0: 65 6e 74 20 28 2d 20 73 65 63 73 20 28 2a 20 68 ent (- secs (* h
d8d0: 72 73 20 33 36 30 30 29 29 20 36 30 29 29 0a 09 rs 3600)) 60))..
d8e0: 20 28 73 65 63 20 28 2d 20 73 65 63 73 20 28 2a (sec (- secs (*
d8f0: 20 68 72 73 20 33 36 30 30 29 28 2a 20 6d 69 6e hrs 3600)(* min
d900: 20 36 30 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 60)))). (con
d910: 63 20 28 69 66 20 28 3e 20 68 72 73 20 30 29 28 c (if (> hrs 0)(
d920: 63 6f 6e 63 20 68 72 73 20 22 68 72 20 22 29 20 conc hrs "hr ")
d930: 22 22 29 0a 09 20 20 28 69 66 20 28 3e 20 6d 69 "").. (if (> mi
d940: 6e 20 30 29 28 63 6f 6e 63 20 6d 69 6e 20 22 6d n 0)(conc min "m
d950: 20 22 29 20 20 22 22 29 0a 09 20 20 73 65 63 20 ") "").. sec
d960: 22 73 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 "s")))..(define
d970: 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 (seconds->time-s
d980: 74 72 69 6e 67 20 73 65 63 29 0a 20 20 28 74 69 tring sec). (ti
d990: 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 20 20 20 28 me->string . (
d9a0: 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
d9b0: 69 6d 65 20 73 65 63 29 20 22 25 48 3a 25 4d 3a ime sec) "%H:%M:
d9c0: 25 53 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 %S"))..(define (
d9d0: 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 seconds->work-we
d9e0: 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 ek/day-time sec)
d9f0: 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 . (time->string
da00: 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
da10: 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 77 cal-time sec) "w
da20: 77 25 56 2e 25 75 20 25 48 3a 25 4d 22 29 29 0a w%V.%u %H:%M")).
da30: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
da40: 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 s->work-week/day
da50: 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
da60: 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 tring. (second
da70: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
da80: 63 29 20 22 77 77 25 56 2e 25 75 22 29 29 0a 0a c) "ww%V.%u"))..
da90: 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 (define (seconds
daa0: 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 65 6b ->year-work-week
dab0: 2f 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d /day sec). (tim
dac0: 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 e->string. (se
dad0: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
dae0: 65 20 73 65 63 29 20 22 25 79 77 77 25 56 2e 25 e sec) "%yww%V.%
daf0: 77 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 w"))..(define (s
db00: 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 econds->year-wor
db10: 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 k-week/day-time
db20: 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
db30: 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
db40: 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
db50: 29 20 22 25 59 77 77 25 56 2e 25 77 20 25 48 3a ) "%Yww%V.%w %H:
db60: 25 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 %M"))..(define (
db70: 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 65 seconds->year-we
db80: 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 ek/day-time sec)
db90: 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 . (time->string
dba0: 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
dbb0: 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 cal-time sec) "%
dbc0: 59 77 25 56 2e 25 77 20 25 48 3a 25 4d 22 29 29 Yw%V.%w %H:%M"))
dbd0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e ..(define (secon
dbe0: 64 73 2d 3e 71 75 61 72 74 65 72 20 73 65 63 29 ds->quarter sec)
dbf0: 0a 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 . (case (string
dc00: 2d 3e 6e 75 6d 62 65 72 0a 09 20 28 74 69 6d 65 ->number.. (time
dc10: 2d 3e 73 74 72 69 6e 67 20 0a 09 20 20 28 73 65 ->string .. (se
dc20: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
dc30: 65 20 73 65 63 29 0a 09 20 20 22 25 6d 22 29 29 e sec).. "%m"))
dc40: 0a 20 20 20 20 28 28 31 20 32 20 33 29 20 31 29 . ((1 2 3) 1)
dc50: 0a 20 20 20 20 28 28 34 20 35 20 36 29 20 32 29 . ((4 5 6) 2)
dc60: 0a 20 20 20 20 28 28 37 20 38 20 39 29 20 33 29 . ((7 8 9) 3)
dc70: 0a 20 20 20 20 28 28 31 30 20 31 31 20 31 32 29 . ((10 11 12)
dc80: 20 34 29 0a 20 20 20 20 28 65 6c 73 65 20 23 66 4). (else #f
dc90: 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 73 70 )))..;; given sp
dca0: 61 6e 20 6f 66 20 73 65 63 6f 6e 64 73 20 74 73 an of seconds ts
dcb0: 74 61 72 74 20 74 6f 20 74 65 6e 64 0a 3b 3b 20 tart to tend.;;
dcc0: 66 69 6e 64 20 73 74 61 72 74 20 74 69 6d 65 20 find start time
dcd0: 74 6f 20 6d 61 72 6b 20 61 6e 64 20 6d 61 72 6b to mark and mark
dce0: 20 64 65 6c 74 61 0a 3b 3b 0a 28 64 65 66 69 6e delta.;;.(defin
dcf0: 65 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 73 e (common:find-s
dd00: 74 61 72 74 2d 6d 61 72 6b 2d 61 6e 64 2d 6d 61 tart-mark-and-ma
dd10: 72 6b 2d 64 65 6c 74 61 20 74 73 74 61 72 74 20 rk-delta tstart
dd20: 74 65 6e 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 tend). (let* ((
dd30: 64 65 6c 74 61 74 20 20 20 28 2d 20 28 6d 61 78 deltat (- (max
dd40: 20 74 65 6e 64 20 28 2b 20 74 65 6e 64 20 31 30 tend (+ tend 10
dd50: 29 29 20 74 73 74 61 72 74 29 29 20 3b 3b 20 63 )) tstart)) ;; c
dd60: 61 6e 27 74 20 68 61 6e 64 6c 65 20 72 75 6e 73 an't handle runs
dd70: 20 6f 66 20 6c 65 73 73 20 74 68 61 6e 20 34 20 of less than 4
dd80: 73 65 63 6f 6e 64 73 2e 20 50 61 64 20 69 74 20 seconds. Pad it
dd90: 74 6f 20 31 30 20 73 65 63 6f 6e 64 73 20 2e 2e to 10 seconds ..
dda0: 2e 0a 09 20 28 72 65 73 75 6c 74 20 20 20 23 66 ... (result #f
ddb0: 29 0a 09 20 28 6d 69 6e 20 20 20 20 20 20 36 30 ).. (min 60
ddc0: 29 0a 09 20 28 68 72 20 20 20 20 20 20 20 28 2a ).. (hr (*
ddd0: 20 36 30 20 36 30 29 29 0a 09 20 28 64 61 79 20 60 60)).. (day
dde0: 20 20 20 20 20 28 2a 20 32 34 20 68 72 29 29 0a (* 24 hr)).
ddf0: 09 20 28 79 72 20 20 20 20 20 20 20 28 2a 20 33 . (yr (* 3
de00: 36 35 20 64 61 79 29 29 20 3b 3b 20 79 65 61 72 65 day)) ;; year
de10: 0a 09 20 28 6d 6f 20 20 20 20 20 20 20 28 2f 20 .. (mo (/
de20: 79 72 20 31 32 29 29 0a 09 20 28 77 6b 20 20 20 yr 12)).. (wk
de30: 20 20 20 20 28 2a 20 64 61 79 20 37 29 29 29 0a (* day 7))).
de40: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
de50: 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 61 78 2d (lambda (max-
de60: 62 6c 6b 73 29 0a 20 20 20 20 20 20 20 28 66 6f blks). (fo
de70: 72 2d 65 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 r-each..(lambda
de80: 28 73 70 61 6e 29 20 3b 3b 20 35 20 32 20 31 0a (span) ;; 5 2 1.
de90: 09 20 20 28 69 66 20 28 6e 6f 74 20 72 65 73 75 . (if (not resu
dea0: 6c 74 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d lt).. (for-
deb0: 65 61 63 68 20 0a 09 20 20 20 20 20 20 20 28 6c each .. (l
dec0: 61 6d 62 64 61 20 28 74 69 6d 65 75 6e 69 74 20 ambda (timeunit
ded0: 74 69 6d 65 73 79 6d 29 20 3b 3b 20 79 65 61 72 timesym) ;; year
dee0: 20 6d 6f 6e 74 68 20 64 61 79 20 68 72 20 6d 69 month day hr mi
def0: 6e 20 73 65 63 0a 09 09 20 28 69 66 20 28 6e 6f n sec... (if (no
df00: 74 20 72 65 73 75 6c 74 29 0a 09 09 20 20 20 20 t result)...
df10: 20 28 6c 65 74 2a 20 28 28 74 69 6d 65 2d 62 6c (let* ((time-bl
df20: 6b 20 28 2a 20 73 70 61 6e 20 74 69 6d 65 75 6e k (* span timeun
df30: 69 74 29 29 0a 09 09 09 20 20 20 20 28 6e 75 6d it)).... (num
df40: 2d 62 6c 6b 73 20 28 71 75 6f 74 69 65 6e 74 20 -blks (quotient
df50: 64 65 6c 74 61 74 20 74 69 6d 65 2d 62 6c 6b 29 deltat time-blk)
df60: 29 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 ))... (if
df70: 28 61 6e 64 20 28 3e 20 6e 75 6d 2d 62 6c 6b 73 (and (> num-blks
df80: 20 34 29 28 3c 20 6e 75 6d 2d 62 6c 6b 73 20 6d 4)(< num-blks m
df90: 61 78 2d 62 6c 6b 73 29 29 0a 09 09 09 20 20 20 ax-blks))....
dfa0: 28 6c 65 74 20 28 28 66 69 72 73 74 20 28 2a 20 (let ((first (*
dfb0: 28 71 75 6f 74 69 65 6e 74 20 74 73 74 61 72 74 (quotient tstart
dfc0: 20 74 69 6d 65 2d 62 6c 6b 29 20 74 69 6d 65 2d time-blk) time-
dfd0: 62 6c 6b 29 29 29 0a 09 09 09 20 20 20 20 20 28 blk))).... (
dfe0: 73 65 74 21 20 72 65 73 75 6c 74 20 28 6c 69 73 set! result (lis
dff0: 74 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 20 t span timeunit
e000: 74 69 6d 65 2d 62 6c 6b 20 66 69 72 73 74 20 74 time-blk first t
e010: 69 6d 65 73 79 6d 29 29 0a 09 09 09 20 20 20 20 imesym))....
e020: 20 29 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 ))))).. (
e030: 6c 69 73 74 20 79 72 20 6d 6f 20 77 6b 20 64 61 list yr mo wk da
e040: 79 20 68 72 20 6d 69 6e 20 31 29 0a 09 20 20 20 y hr min 1)..
e050: 20 20 20 20 27 28 20 20 20 20 20 79 20 20 6d 6f '( y mo
e060: 20 77 20 20 64 20 20 20 68 20 20 6d 20 20 20 73 w d h m s
e070: 29 29 29 29 0a 09 28 6c 69 73 74 20 38 20 36 20 ))))..(list 8 6
e080: 35 20 32 20 31 29 29 29 0a 20 20 20 20 20 27 28 5 2 1))). '(
e090: 35 20 31 30 20 31 35 20 32 30 20 33 30 20 34 30 5 10 15 20 30 40
e0a0: 20 35 30 20 35 30 30 29 29 0a 20 20 20 20 28 69 50 500)). (i
e0b0: 66 20 76 61 6c 75 65 73 0a 09 28 61 70 70 6c 79 f values..(apply
e0c0: 20 76 61 6c 75 65 73 20 72 65 73 75 6c 74 29 0a values result).
e0d0: 09 28 76 61 6c 75 65 73 20 30 20 64 61 79 20 31 .(values 0 day 1
e0e0: 20 30 20 27 64 29 29 29 29 0a 09 20 20 20 20 0a 0 'd)))).. .
e0f0: 09 20 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d . ..;;=========
e100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
e140: 20 43 20 4f 20 4c 20 4f 20 52 20 53 0a 3b 3b 3d C O L O R S.;;=
e150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e190: 3d 3d 3d 3d 3d 0a 20 20 20 20 20 20 0a 28 64 65 =====. .(de
e1a0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6e 61 6d fine (common:nam
e1b0: 65 2d 3e 69 75 70 2d 63 6f 6c 6f 72 20 6e 61 6d e->iup-color nam
e1c0: 65 29 0a 20 20 28 63 61 73 65 20 28 73 74 72 69 e). (case (stri
e1d0: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 ng->symbol (stri
e1e0: 6e 67 2d 64 6f 77 6e 63 61 73 65 20 6e 61 6d 65 ng-downcase name
e1f0: 29 29 0a 20 20 20 20 28 28 72 65 64 29 20 20 20 )). ((red)
e200: 20 22 32 32 33 20 33 33 20 34 39 22 29 0a 20 20 "223 33 49").
e210: 20 20 28 28 67 72 65 79 29 20 20 20 22 31 39 32 ((grey) "192
e220: 20 31 39 32 20 31 39 32 22 29 0a 20 20 20 20 28 192 192"). (
e230: 28 6f 72 61 6e 67 65 29 20 22 32 35 35 20 31 37 (orange) "255 17
e240: 32 20 31 33 22 29 0a 20 20 20 20 28 28 70 75 72 2 13"). ((pur
e250: 70 6c 65 29 20 22 54 68 69 73 20 69 73 20 75 6e ple) "This is un
e260: 66 69 6e 69 73 68 65 64 20 2e 2e 2e 22 29 29 29 finished ...")))
e270: 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6f ..;; (define (co
e280: 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 mmon:get-color-f
e290: 6f 72 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 or-state-status
e2a0: 73 74 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b state status).;;
e2b0: 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 (case (string
e2c0: 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 74 65 29 0a ->symbol state).
e2d0: 3b 3b 20 20 20 20 20 28 28 43 4f 4d 50 4c 45 54 ;; ((COMPLET
e2e0: 45 44 29 0a 3b 3b 20 20 20 20 20 20 28 63 61 73 ED).;; (cas
e2f0: 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f e (string->symbo
e300: 6c 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 20 l status).;;
e310: 20 20 20 20 28 28 50 41 53 53 29 20 20 20 20 20 ((PASS)
e320: 20 20 20 22 37 30 20 20 32 34 39 20 37 33 22 29 "70 249 73")
e330: 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 57 41 52 .;; ((WAR
e340: 4e 20 57 41 49 56 45 44 29 20 22 32 35 35 20 31 N WAIVED) "255 1
e350: 37 32 20 31 33 22 29 0a 3b 3b 20 20 20 20 20 20 72 13").;;
e360: 20 20 28 28 53 4b 49 50 29 20 20 20 20 20 20 20 ((SKIP)
e370: 20 22 32 33 30 20 32 33 30 20 30 22 29 0a 3b 3b "230 230 0").;;
e380: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 22 32 (else "2
e390: 32 33 20 33 33 20 34 39 22 29 29 29 0a 3b 3b 20 23 33 49"))).;;
e3a0: 20 20 20 20 28 28 4c 41 55 4e 43 48 45 44 29 20 ((LAUNCHED)
e3b0: 20 20 20 20 20 20 20 20 22 31 30 31 20 31 32 33 "101 123
e3c0: 20 31 34 32 22 29 0a 3b 3b 20 20 20 20 20 28 28 142").;; ((
e3d0: 43 48 45 43 4b 29 20 20 20 20 20 20 20 20 20 20 CHECK)
e3e0: 20 20 22 32 35 35 20 31 30 30 20 35 30 22 29 0a "255 100 50").
e3f0: 3b 3b 20 20 20 20 20 28 28 52 45 4d 4f 54 45 48 ;; ((REMOTEH
e400: 4f 53 54 53 54 41 52 54 29 20 20 22 35 30 20 20 OSTSTART) "50
e410: 31 33 30 20 31 39 35 22 29 0a 3b 3b 20 20 20 20 130 195").;;
e420: 20 28 28 52 55 4e 4e 49 4e 47 29 20 20 20 20 20 ((RUNNING)
e430: 20 20 20 20 20 22 39 20 20 20 31 33 31 20 32 33 "9 131 23
e440: 32 22 29 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 2").;; ((KIL
e450: 4c 52 45 51 29 20 20 20 20 20 20 20 20 20 20 22 LREQ) "
e460: 33 39 20 20 38 32 20 20 32 30 36 22 29 0a 3b 3b 39 82 206").;;
e470: 20 20 20 20 20 28 28 4b 49 4c 4c 45 44 29 20 20 ((KILLED)
e480: 20 20 20 20 20 20 20 20 20 22 32 33 34 20 31 30 "234 10
e490: 31 20 31 37 22 29 0a 3b 3b 20 20 20 20 20 28 28 1 17").;; ((
e4a0: 4e 4f 54 5f 53 54 41 52 54 45 44 29 20 20 20 20 NOT_STARTED)
e4b0: 20 20 22 32 34 30 20 32 34 30 20 32 34 30 22 29 "240 240 240")
e4c0: 0a 3b 3b 20 20 20 20 20 28 65 6c 73 65 20 20 20 .;; (else
e4d0: 20 20 20 20 20 20 20 20 20 20 20 20 22 31 39 32 "192
e4e0: 20 31 39 32 20 31 39 32 22 29 29 29 0a 0a 28 64 192 192")))..(d
e4f0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 69 75 efine (common:iu
e500: 70 2d 63 6f 6c 6f 72 2d 3e 72 67 62 2d 68 65 78 p-color->rgb-hex
e510: 20 69 6e 73 74 72 29 0a 20 20 28 73 74 72 69 6e instr). (strin
e520: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 g-intersperse .
e530: 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 (map (lambda (
e540: 78 29 0a 20 20 20 20 20 20 20 20 20 20 28 6e 75 x). (nu
e550: 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 78 20 31 mber->string x 1
e560: 36 29 29 0a 20 20 20 20 20 20 20 20 28 6d 61 70 6)). (map
e570: 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a string->number.
e580: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
e590: 72 69 6e 67 2d 73 70 6c 69 74 20 69 6e 73 74 72 ring-split instr
e5a0: 29 29 29 0a 20 20 20 22 2f 22 29 29 0a 0a 28 64 ))). "/"))..(d
e5b0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
e5c0: 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 t-color-from-sta
e5d0: 74 75 73 20 73 74 61 74 75 73 29 0a 20 20 28 63 tus status). (c
e5e0: 6f 6e 64 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 ond. ((equal?
e5f0: 73 74 61 74 75 73 20 22 50 41 53 53 22 29 20 20 status "PASS")
e600: 20 20 22 67 72 65 65 6e 22 29 0a 20 20 20 28 28 "green"). ((
e610: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 equal? status "F
e620: 41 49 4c 22 29 20 20 20 20 22 72 65 64 22 29 0a AIL") "red").
e630: 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
e640: 75 73 20 22 57 41 52 4e 22 29 20 20 20 20 22 6f us "WARN") "o
e650: 72 61 6e 67 65 22 29 0a 20 20 20 28 28 65 71 75 range"). ((equ
e660: 61 6c 3f 20 73 74 61 74 75 73 20 22 4b 49 4c 4c al? status "KILL
e670: 45 44 22 29 20 20 22 6f 72 61 6e 67 65 22 29 0a ED") "orange").
e680: 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
e690: 75 73 20 22 4b 49 4c 4c 52 45 51 22 29 20 22 70 us "KILLREQ") "p
e6a0: 75 72 70 6c 65 22 29 0a 20 20 20 28 28 65 71 75 urple"). ((equ
e6b0: 61 6c 3f 20 73 74 61 74 75 73 20 22 52 55 4e 4e al? status "RUNN
e6c0: 49 4e 47 22 29 20 22 62 6c 75 65 22 29 0a 20 20 ING") "blue").
e6d0: 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 ((equal? status
e6e0: 20 22 41 42 4f 52 54 22 29 20 20 20 22 62 72 6f "ABORT") "bro
e6f0: 77 6e 22 29 0a 20 20 20 28 65 6c 73 65 20 22 62 wn"). (else "b
e700: 6c 61 63 6b 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d lack")))..;;====
e710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e750: 3d 3d 0a 3b 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 ==.;; N A N O M
e760: 53 20 47 20 20 20 43 20 4c 20 49 20 45 20 4e 20 S G C L I E N
e770: 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d T.;;============
e780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e7a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e7b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
e7c0: 69 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d ine (server:get-
e7d0: 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 best-guess-addre
e7e0: 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 ss hostname). (
e7f0: 6c 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 let ((res #f)).
e800: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 (for-each .
e810: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 64 72 29 (lambda (adr)
e820: 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 . (if (not
e830: 20 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 2d (eq? (u8vector-
e840: 72 65 66 20 61 64 72 20 30 29 20 31 32 37 29 29 ref adr 0) 127))
e850: 0a 09 20 20 20 28 73 65 74 21 20 72 65 73 20 61 .. (set! res a
e860: 64 72 29 29 29 0a 20 20 20 20 20 3b 3b 20 4e 4f dr))). ;; NO
e870: 54 45 3a 20 54 68 69 73 20 63 61 6e 20 66 61 69 TE: This can fai
e880: 6c 20 77 68 65 6e 20 74 68 65 72 65 20 69 73 20 l when there is
e890: 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f 66 20 74 68 no mention of th
e8a0: 65 20 68 6f 73 74 20 69 6e 20 2f 65 74 63 2f 68 e host in /etc/h
e8b0: 6f 73 74 73 2e 20 46 49 58 4d 45 0a 20 20 20 20 osts. FIXME.
e8c0: 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 (vector->list (
e8d0: 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 hostinfo-address
e8e0: 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f es (hostname->ho
e8f0: 73 74 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 stinfo hostname)
e900: 29 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d ))). (string-
e910: 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 intersperse .
e920: 20 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 (map number->s
e930: 74 72 69 6e 67 0a 09 20 20 28 75 38 76 65 63 74 tring.. (u8vect
e940: 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 20 28 69 66 or->list.. (if
e950: 20 72 65 73 20 72 65 73 20 28 68 6f 73 74 6e 61 res res (hostna
e960: 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 me->ip hostname)
e970: 29 29 29 20 22 2e 22 29 29 29 0a 0a 0a 28 64 65 ))) ".")))...(de
e980: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e fine (common:sen
e990: 64 2d 64 62 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 d-dboard-main-ch
e9a0: 61 6e 67 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 anged). (let* (
e9b0: 28 64 61 73 68 62 6f 61 72 64 2d 69 70 73 20 28 (dashboard-ips (
e9c0: 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 62 6f 61 mddb:get-dashboa
e9d0: 72 64 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d rds))). (for-
e9e0: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
e9f0: 61 20 28 69 70 61 64 72 29 0a 20 20 20 20 20 20 a (ipadr).
ea00: 20 28 6c 65 74 2a 20 28 28 73 6f 63 20 28 63 6f (let* ((soc (co
ea10: 6d 6d 6f 6e 3a 6f 70 65 6e 2d 6e 6d 2d 72 65 71 mmon:open-nm-req
ea20: 20 28 63 6f 6e 63 20 22 74 63 70 3a 2f 2f 22 20 (conc "tcp://"
ea30: 69 70 61 64 72 29 29 29 0a 09 20 20 20 20 20 20 ipadr)))..
ea40: 28 6d 73 67 20 28 63 6f 6e 63 20 22 6d 61 69 6e (msg (conc "main
ea50: 20 22 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 " *toppath*))..
ea60: 20 20 20 20 20 20 28 72 65 73 20 28 63 6f 6d 6d (res (comm
ea70: 6f 6e 3a 6e 6d 2d 73 65 6e 64 2d 72 65 63 65 69 on:nm-send-recei
ea80: 76 65 2d 74 69 6d 65 6f 75 74 20 73 6f 63 20 6d ve-timeout soc m
ea90: 73 67 29 29 29 0a 09 20 28 69 66 20 28 6e 6f 74 sg))).. (if (not
eaa0: 20 72 65 73 29 20 3b 3b 20 63 6f 75 6c 64 6e 27 res) ;; couldn'
eab0: 74 20 72 65 61 63 68 20 74 68 61 74 20 64 61 73 t reach that das
eac0: 68 62 6f 61 72 64 20 2d 20 72 65 6d 6f 76 65 20 hboard - remove
ead0: 69 74 20 66 72 6f 6d 20 64 62 0a 09 20 20 20 20 it from db..
eae0: 20 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 (print "ERROR:
eaf0: 63 6f 75 6c 64 6e 27 74 20 72 65 61 63 68 20 64 couldn't reach d
eb00: 61 73 68 62 6f 61 72 64 20 22 20 69 70 61 64 72 ashboard " ipadr
eb10: 29 29 0a 09 20 72 65 73 29 29 0a 20 20 20 20 20 )).. res)).
eb20: 64 61 73 68 62 6f 61 72 64 2d 69 70 73 29 29 29 dashboard-ips)))
eb30: 0a 20 20 20 20 0a 20 20 20 20 0a 3b 3b 3d 3d 3d . . .;;===
eb40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb80: 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 48 20 42 ===.;; D A S H B
eb90: 20 4f 20 41 20 52 20 44 20 20 20 44 20 42 20 0a O A R D D B .
eba0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
ebb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ebc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ebd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ebe0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
ebf0: 65 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 e (mddb:open-db)
ec00: 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 28 6f . (let* ((db (o
ec10: 70 65 6e 2d 64 61 74 61 62 61 73 65 20 28 63 6f pen-database (co
ec20: 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d nc (get-environm
ec30: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f ent-variable "HO
ec40: 4d 45 22 29 20 22 2f 2e 64 61 73 68 62 6f 61 72 ME") "/.dashboar
ec50: 64 2e 64 62 22 29 29 29 29 0a 20 20 20 20 28 73 d.db")))). (s
ec60: 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 et-busy-handler!
ec70: 20 64 62 20 28 62 75 73 79 2d 74 69 6d 65 6f 75 db (busy-timeou
ec80: 74 20 31 30 30 30 30 29 29 0a 20 20 20 20 28 66 t 10000)). (f
ec90: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
eca0: 6d 62 64 61 20 28 71 72 79 29 0a 20 20 20 20 20 mbda (qry).
ecb0: 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 (exec (sql db
ecc0: 71 72 79 29 29 29 0a 20 20 20 20 20 28 6c 69 73 qry))). (lis
ecd0: 74 20 0a 20 20 20 20 20 20 22 43 52 45 41 54 45 t . "CREATE
ece0: 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
ecf0: 49 53 54 53 20 76 61 72 73 20 20 20 20 20 20 20 ISTS vars
ed00: 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d (id INTEGER PRIM
ed10: 41 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 ARY KEY,key TEXT
ed20: 2c 20 76 61 6c 20 54 45 58 54 2c 20 43 4f 4e 53 , val TEXT, CONS
ed30: 54 52 41 49 4e 54 20 76 61 72 73 63 6f 6e 73 74 TRAINT varsconst
ed40: 72 61 69 6e 74 20 55 4e 49 51 55 45 20 28 6b 65 raint UNIQUE (ke
ed50: 79 29 29 3b 22 0a 20 20 20 20 20 20 22 43 52 45 y));". "CRE
ed60: 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 ATE TABLE IF NOT
ed70: 20 45 58 49 53 54 53 20 64 61 73 68 62 6f 61 72 EXISTS dashboar
ed80: 64 73 20 28 0a 20 20 20 20 20 20 20 20 20 20 69 ds (. i
ed90: 64 20 20 20 20 20 20 20 20 20 49 4e 54 45 47 45 d INTEGE
eda0: 52 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 R PRIMARY KEY,.
edb0: 20 20 20 20 20 20 20 20 20 70 69 64 20 20 20 20 pid
edc0: 20 20 20 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 INTEGER,.
edd0: 20 20 20 20 20 20 20 75 73 65 72 6e 61 6d 65 20 username
ede0: 20 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 TEXT,.
edf0: 20 20 68 6f 73 74 6e 61 6d 65 20 20 20 54 45 58 hostname TEX
ee00: 54 2c 0a 20 20 20 20 20 20 20 20 20 20 69 70 61 T,. ipa
ee10: 64 64 72 20 20 20 20 20 54 45 58 54 2c 0a 20 20 ddr TEXT,.
ee20: 20 20 20 20 20 20 20 20 70 6f 72 74 6e 75 6d 20 portnum
ee30: 20 20 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 INTEGER,.
ee40: 20 20 20 20 20 20 73 74 61 72 74 5f 74 69 6d 65 start_time
ee50: 20 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 55 TIMESTAMP DEFAU
ee60: 4c 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 LT (strftime('%s
ee70: 27 2c 27 6e 6f 77 27 29 29 2c 0a 20 20 20 20 20 ','now')),.
ee80: 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 49 CONSTRAI
ee90: 4e 54 20 68 6f 73 74 70 6f 72 74 20 55 4e 49 51 NT hostport UNIQ
eea0: 55 45 20 28 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 UE (hostname,por
eeb0: 74 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 29 3b tnum). );
eec0: 22 0a 20 20 20 20 20 20 29 29 0a 20 20 20 20 64 ". )). d
eed0: 62 29 29 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 b))..;; register
eee0: 20 61 20 64 61 73 68 62 6f 61 72 64 20 0a 3b 3b a dashboard .;;
eef0: 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 72 .(define (mddb:r
ef00: 65 67 69 73 74 65 72 2d 64 61 73 68 62 6f 61 72 egister-dashboar
ef10: 64 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 d port). (let*
ef20: 28 28 70 69 64 20 20 20 20 20 20 28 63 75 72 72 ((pid (curr
ef30: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
ef40: 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 .. (hostname (ge
ef50: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 t-host-name))..
ef60: 28 69 70 61 64 64 72 20 20 20 28 73 65 72 76 65 (ipaddr (serve
ef70: 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 r:get-best-guess
ef80: 2d 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d -address hostnam
ef90: 65 29 29 0a 09 20 28 75 73 65 72 6e 61 6d 65 20 e)).. (username
efa0: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 (current-user-na
efb0: 6d 65 29 29 20 3b 3b 20 28 63 61 72 20 75 73 65 me)) ;; (car use
efc0: 72 69 6e 66 6f 29 29 29 0a 09 20 28 64 62 20 20 rinfo))).. (db
efd0: 20 20 20 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 (mddb:open-d
efe0: 62 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 b))). (print
eff0: 22 52 65 67 69 73 74 65 72 20 6d 6f 6e 69 74 6f "Register monito
f000: 72 2c 20 70 69 64 3a 20 22 20 70 69 64 20 22 2c r, pid: " pid ",
f010: 20 68 6f 73 74 6e 61 6d 65 3a 20 22 20 68 6f 73 hostname: " hos
f020: 74 6e 61 6d 65 20 22 2c 20 70 6f 72 74 3a 20 22 tname ", port: "
f030: 20 70 6f 72 74 20 22 2c 20 75 73 65 72 6e 61 6d port ", usernam
f040: 65 3a 20 22 20 75 73 65 72 6e 61 6d 65 29 0a 20 e: " username).
f050: 20 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 (exec (sql db
f060: 20 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c "INSERT OR REPL
f070: 41 43 45 20 49 4e 54 4f 20 64 61 73 68 62 6f 61 ACE INTO dashboa
f080: 72 64 73 20 28 70 69 64 2c 75 73 65 72 6e 61 6d rds (pid,usernam
f090: 65 2c 68 6f 73 74 6e 61 6d 65 2c 69 70 61 64 64 e,hostname,ipadd
f0a0: 72 2c 70 6f 72 74 6e 75 6d 29 20 56 41 4c 55 45 r,portnum) VALUE
f0b0: 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 S (?,?,?,?,?);")
f0c0: 0a 09 20 20 20 70 69 64 20 75 73 65 72 6e 61 6d .. pid usernam
f0d0: 65 20 68 6f 73 74 6e 61 6d 65 20 69 70 61 64 64 e hostname ipadd
f0e0: 72 20 70 6f 72 74 29 0a 20 20 20 20 28 63 6c 6f r port). (clo
f0f0: 73 65 2d 64 61 74 61 62 61 73 65 20 64 62 29 29 se-database db))
f100: 29 0a 0a 3b 3b 20 75 6e 72 65 67 69 73 74 65 72 )..;; unregister
f110: 20 61 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 0a 28 64 a monitor.;;.(d
f120: 65 66 69 6e 65 20 28 6d 64 64 62 3a 75 6e 72 65 efine (mddb:unre
f130: 67 69 73 74 65 72 2d 64 61 73 68 62 6f 61 72 64 gister-dashboard
f140: 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 6c host port). (l
f150: 65 74 2a 20 28 28 64 62 20 20 20 20 20 20 28 6d et* ((db (m
f160: 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 ddb:open-db))).
f170: 20 20 20 28 70 72 69 6e 74 20 22 52 65 67 69 73 (print "Regis
f180: 74 65 72 20 75 6e 72 65 67 69 73 74 65 72 20 6d ter unregister m
f190: 6f 6e 69 74 6f 72 2c 20 68 6f 73 74 3a 70 6f 72 onitor, host:por
f1a0: 74 3d 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 t=" host ":" por
f1b0: 74 29 0a 20 20 20 20 28 65 78 65 63 20 28 73 71 t). (exec (sq
f1c0: 6c 20 64 62 20 22 44 45 4c 45 54 45 20 46 52 4f l db "DELETE FRO
f1d0: 4d 20 64 61 73 68 62 6f 61 72 64 73 20 57 48 45 M dashboards WHE
f1e0: 52 45 20 68 6f 73 74 6e 61 6d 65 3d 3f 20 41 4e RE hostname=? AN
f1f0: 44 20 70 6f 72 74 6e 75 6d 3d 3f 3b 22 29 20 68 D portnum=?;") h
f200: 6f 73 74 20 70 6f 72 74 29 0a 20 20 20 20 28 63 ost port). (c
f210: 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 20 64 62 lose-database db
f220: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 72 65 67 69 )))..;; get regi
f230: 73 74 65 72 65 64 20 64 61 73 68 62 6f 61 72 64 stered dashboard
f240: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 s.;;.(define (md
f250: 64 62 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 64 db:get-dashboard
f260: 73 29 0a 20 20 28 6c 65 74 20 28 28 64 62 20 28 s). (let ((db (
f270: 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a mddb:open-db))).
f280: 20 20 20 20 28 71 75 65 72 79 20 66 65 74 63 68 (query fetch
f290: 2d 63 6f 6c 75 6d 6e 0a 09 20 20 20 28 73 71 6c -column.. (sql
f2a0: 20 64 62 20 22 53 45 4c 45 43 54 20 69 70 61 64 db "SELECT ipad
f2b0: 64 72 20 7c 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 dr || ':' || por
f2c0: 74 6e 75 6d 20 46 52 4f 4d 20 64 61 73 68 62 6f tnum FROM dashbo
f2d0: 61 72 64 73 3b 22 29 29 29 29 0a 20 20 20 20 0a ards;")))). .
f2e0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
f2f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f320: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 ========.;; T E
f330: 20 53 20 54 20 20 20 4c 20 41 20 55 20 4e 20 43 S T L A U N C
f340: 20 48 20 49 20 4e 20 47 20 20 20 50 20 45 20 52 H I N G P E R
f350: 20 20 20 49 20 54 20 45 20 4d 20 20 20 57 20 49 I T E M W I
f360: 20 54 20 48 20 20 20 48 20 4f 20 53 20 54 20 20 T H H O S T
f370: 20 54 20 59 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d T Y P E S.;;===
f380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f3a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f3b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f3c0: 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 ===.;; .;; [host
f3d0: 73 5d 0a 3b 3b 20 61 72 6d 20 63 75 62 69 65 30 s].;; arm cubie0
f3e0: 31 20 63 75 62 69 65 30 32 0a 3b 3b 20 78 38 36 1 cubie02.;; x86
f3f0: 5f 36 34 20 7a 65 75 73 20 78 65 6e 61 20 6d 79 _64 zeus xena my
f400: 74 68 30 31 0a 3b 3b 20 61 6c 6c 68 6f 73 74 73 th01.;; allhosts
f410: 20 23 7b 67 20 68 6f 73 74 73 20 61 72 6d 7d 20 #{g hosts arm}
f420: 23 7b 67 20 68 6f 73 74 73 20 78 38 36 5f 36 34 #{g hosts x86_64
f430: 7d 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 2d 74 }.;; .;; [host-t
f440: 79 70 65 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c ypes].;; general
f450: 20 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 20 23 #MTLOWESTLOAD #
f460: 7b 67 20 68 6f 73 74 73 20 61 6c 6c 68 6f 73 74 {g hosts allhost
f470: 73 7d 0a 3b 3b 20 61 72 6d 20 20 20 20 20 23 4d s}.;; arm #M
f480: 54 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 TLOWESTLOAD #{g
f490: 68 6f 73 74 73 20 61 72 6d 7d 0a 3b 3b 20 6e 62 hosts arm}.;; nb
f4a0: 67 65 6e 65 72 61 6c 20 6e 62 6a 6f 62 20 72 75 general nbjob ru
f4b0: 6e 20 4a 4f 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f n JOBCOMMAND -lo
f4c0: 67 20 24 4d 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 g $MT_LINKTREE/$
f4d0: 4d 54 5f 54 41 52 47 45 54 2f 24 4d 54 5f 52 55 MT_TARGET/$MT_RU
f4e0: 4e 4e 41 4d 45 2e 24 4d 54 5f 54 45 53 54 4e 41 NNAME.$MT_TESTNA
f4f0: 4d 45 2d 24 4d 54 5f 49 54 45 4d 5f 50 41 54 48 ME-$MT_ITEM_PATH
f500: 2e 6c 67 6f 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 .lgo.;; .;; [lau
f510: 6e 63 68 65 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 nchers].;; envse
f520: 74 75 70 20 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 tup general.;; x
f530: 6f 72 2f 25 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 or/%/n 4C16G.;;
f540: 25 20 6e 62 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a % nbgeneral.;; .
f550: 3b 3b 20 5b 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b ;; [jobtools].;;
f560: 20 23 20 69 66 20 3d 3d 20 22 79 65 73 22 20 66 # if == "yes" f
f570: 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 77 69 lexi-launcher wi
f580: 6c 6c 20 62 79 70 61 73 73 20 22 6c 61 75 6e 63 ll bypass "launc
f590: 68 65 72 22 20 75 6e 6c 65 73 73 20 6e 6f 20 6d her" unless no m
f5a0: 61 74 63 68 2e 0a 3b 3b 20 66 6c 65 78 69 2d 6c atch..;; flexi-l
f5b0: 61 75 6e 63 68 65 72 20 79 65 73 20 20 0a 3b 3b auncher yes .;;
f5c0: 20 6c 61 75 6e 63 68 65 72 20 6e 62 66 61 6b 65 launcher nbfake
f5d0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
f5e0: 6d 6f 6e 3a 67 65 74 2d 6c 61 75 6e 63 68 65 72 mon:get-launcher
f5f0: 20 63 6f 6e 66 69 67 64 61 74 20 74 65 73 74 6e configdat testn
f600: 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 20 ame itempath).
f610: 28 6c 65 74 20 28 28 66 61 6c 6c 62 61 63 6b 2d (let ((fallback-
f620: 6c 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 launcher (config
f630: 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 f:lookup configd
f640: 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6c at "jobtools" "l
f650: 61 75 6e 63 68 65 72 22 29 29 29 0a 20 20 20 20 auncher"))).
f660: 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 (if (string-sear
f670: 63 68 20 22 5e 79 65 73 22 20 28 63 6f 6e 66 69 ch "^yes" (confi
f680: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
f690: 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 dat "jobtools" "
f6a0: 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 flexi-launcher")
f6b0: 29 20 3b 3b 20 6f 76 65 72 72 69 64 65 73 20 6c ) ;; overrides l
f6c0: 61 75 6e 63 68 65 72 0a 09 3b 3b 20 28 6e 6f 74 auncher..;; (not
f6d0: 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 (equal? (config
f6e0: 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 f:lookup configd
f6f0: 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 at "jobtools" "f
f700: 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 20 lexi-launcher")
f710: 22 6e 6f 22 29 29 29 0a 09 28 6c 65 74 2a 20 28 "no")))..(let* (
f720: 28 6c 61 75 6e 63 68 65 72 73 20 20 20 20 20 20 (launchers
f730: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (hash-table-r
f740: 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 ef/default confi
f750: 67 64 61 74 20 22 6c 61 75 6e 63 68 65 72 73 22 gdat "launchers"
f760: 20 27 28 29 29 29 29 0a 09 20 20 28 69 66 20 28 '()))).. (if (
f770: 6e 75 6c 6c 3f 20 6c 61 75 6e 63 68 65 72 73 29 null? launchers)
f780: 0a 09 20 20 20 20 20 20 66 61 6c 6c 62 61 63 6b .. fallback
f790: 2d 6c 61 75 6e 63 68 65 72 0a 09 20 20 20 20 20 -launcher..
f7a0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
f7b0: 20 28 63 61 72 20 6c 61 75 6e 63 68 65 72 73 29 (car launchers)
f7c0: 29 0a 09 09 09 20 28 74 61 6c 20 28 63 64 72 20 ).... (tal (cdr
f7d0: 6c 61 75 6e 63 68 65 72 73 29 29 29 0a 09 09 28 launchers)))...(
f7e0: 6c 65 74 20 28 28 70 61 74 74 20 20 20 20 20 20 let ((patt
f7f0: 28 63 61 72 20 68 65 64 29 29 0a 09 09 20 20 20 (car hed))...
f800: 20 20 20 28 68 6f 73 74 2d 74 79 70 65 20 28 63 (host-type (c
f810: 61 64 72 20 68 65 64 29 29 29 0a 09 09 20 20 28 adr hed)))... (
f820: 69 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 if (tests:match
f830: 70 61 74 74 20 74 65 73 74 6e 61 6d 65 20 69 74 patt testname it
f840: 65 6d 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 empath)...
f850: 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 67 (begin....(debug
f860: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
f870: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
f880: 20 22 48 61 76 65 20 66 6c 65 78 69 2d 6c 61 75 "Have flexi-lau
f890: 6e 63 68 65 72 20 6d 61 74 63 68 20 66 6f 72 20 ncher match for
f8a0: 22 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 " testname "/" i
f8b0: 74 65 6d 70 61 74 68 20 22 20 3d 20 22 20 68 6f tempath " = " ho
f8c0: 73 74 2d 74 79 70 65 29 0a 09 09 09 28 6c 65 74 st-type)....(let
f8d0: 20 28 28 6c 61 75 6e 63 68 65 72 20 28 63 6f 6e ((launcher (con
f8e0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 figf:lookup conf
f8f0: 69 67 64 61 74 20 22 68 6f 73 74 2d 74 79 70 65 igdat "host-type
f900: 73 22 20 68 6f 73 74 2d 74 79 70 65 29 29 29 0a s" host-type))).
f910: 09 09 09 20 20 28 69 66 20 6c 61 75 6e 63 68 65 ... (if launche
f920: 72 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a r.... (let*
f930: 20 28 28 6c 61 75 6e 63 68 65 72 2d 70 61 72 74 ((launcher-part
f940: 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
f950: 6c 61 75 6e 63 68 65 72 29 29 0a 09 09 09 09 20 launcher)).....
f960: 20 20 20 20 28 6c 61 75 6e 63 68 65 72 2d 65 78 (launcher-ex
f970: 65 20 20 20 28 63 61 72 20 6c 61 75 6e 63 68 65 e (car launche
f980: 72 2d 70 61 72 74 73 29 29 29 0a 09 09 09 09 28 r-parts))).....(
f990: 69 66 20 28 65 71 75 61 6c 3f 20 6c 61 75 6e 63 if (equal? launc
f9a0: 68 65 72 2d 65 78 65 20 22 23 4d 54 4c 4f 57 45 her-exe "#MTLOWE
f9b0: 53 54 4c 4f 41 44 22 29 20 3b 3b 20 74 68 69 73 STLOAD") ;; this
f9c0: 20 69 73 20 6f 75 72 20 73 70 65 63 69 61 6c 20 is our special
f9d0: 63 61 73 65 2c 20 77 65 20 77 69 6c 6c 20 66 69 case, we will fi
f9e0: 6e 64 20 74 68 65 20 6c 6f 77 65 73 74 20 6c 6f nd the lowest lo
f9f0: 61 64 20 61 6e 64 20 63 72 61 66 74 20 61 20 6e ad and craft a n
fa00: 62 66 61 6b 65 20 63 6f 6d 6d 61 6e 64 6c 69 6e bfake commandlin
fa10: 65 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 e..... (let (
fa20: 28 74 61 72 67 2d 68 6f 73 74 20 28 63 6f 6d 6d (targ-host (comm
fa30: 6f 6e 3a 67 65 74 2d 6c 65 61 73 74 2d 6c 6f 61 on:get-least-loa
fa40: 64 65 64 2d 68 6f 73 74 20 28 63 64 72 20 6c 61 ded-host (cdr la
fa50: 75 6e 63 68 65 72 2d 70 61 72 74 73 29 29 29 29 uncher-parts))))
fa60: 0a 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e 63 ..... (conc
fa70: 20 22 72 65 6d 72 75 6e 20 22 20 74 61 72 67 2d "remrun " targ-
fa80: 68 6f 73 74 29 29 0a 09 09 09 09 20 20 20 20 6c host))..... l
fa90: 61 75 6e 63 68 65 72 29 29 0a 09 09 09 20 20 20 auncher))....
faa0: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 (begin.....(d
fab0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
fac0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
fad0: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6e ort* "WARNING: n
fae0: 6f 20 6c 61 75 6e 63 68 65 72 20 66 6f 75 6e 64 o launcher found
faf0: 20 66 6f 72 20 68 6f 73 74 2d 74 79 70 65 20 22 for host-type "
fb00: 20 68 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 09 host-type).....
fb10: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
fb20: 09 09 09 09 20 20 20 20 66 61 6c 6c 62 61 63 6b .... fallback
fb30: 2d 6c 61 75 6e 63 68 65 72 0a 09 09 09 09 20 20 -launcher.....
fb40: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
fb50: 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 )(cdr tal)))))))
fb60: 0a 09 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 6d ... ;; no m
fb70: 61 74 63 68 2c 20 74 72 79 20 61 67 61 69 6e 0a atch, try again.
fb80: 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c .. (if (nul
fb90: 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 66 61 6c l? tal).... fal
fba0: 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 lback-launcher..
fbb0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 .. (loop (car t
fbc0: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
fbd0: 29 29 29 0a 09 66 61 6c 6c 62 61 63 6b 2d 6c 61 )))..fallback-la
fbe0: 75 6e 63 68 65 72 29 29 29 0a 20 20 0a 3b 3b 3d uncher))). .;;=
fbf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fc00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fc10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fc20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fc30: 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 48 =====.;; D A S H
fc40: 20 42 20 4f 20 41 20 52 20 44 20 20 20 55 20 53 B O A R D U S
fc50: 20 45 20 52 20 20 20 56 20 49 20 45 20 57 20 53 E R V I E W S
fc60: 0a 3b 3b 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 3d 3d 3d 3d 3d ================
fca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 =========..;; fi
fcb0: 72 73 74 20 72 65 61 64 20 7e 2f 76 69 65 77 73 rst read ~/views
fcc0: 2e 63 6f 6e 66 69 67 20 69 66 20 69 74 20 65 78 .config if it ex
fcd0: 69 73 74 73 2c 20 74 68 65 6e 20 72 65 61 64 20 ists, then read
fce0: 24 4d 54 52 41 48 2f 76 69 65 77 73 2e 63 6f 6e $MTRAH/views.con
fcf0: 66 69 67 20 69 66 20 69 74 20 65 78 69 73 74 73 fig if it exists
fd00: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
fd10: 6d 6f 6e 3a 6c 6f 61 64 2d 76 69 65 77 73 2d 63 mon:load-views-c
fd20: 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 28 onfig). (let* (
fd30: 28 76 69 65 77 2d 63 66 67 64 61 74 20 20 20 20 (view-cfgdat
fd40: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
fd50: 29 29 0a 09 20 28 68 6f 6d 65 2d 63 66 67 66 69 )).. (home-cfgfi
fd60: 6c 65 20 20 20 28 63 6f 6e 63 20 28 67 65 74 2d le (conc (get-
fd70: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
fd80: 61 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f 2e able "HOME") "/.
fd90: 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 29 mtviews.config")
fda0: 29 0a 09 20 28 6d 74 68 6f 6d 65 2d 63 66 67 66 ).. (mthome-cfgf
fdb0: 69 6c 65 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 ile (conc *toppa
fdc0: 74 68 2a 20 22 2f 2e 6d 74 76 69 65 77 73 2e 63 th* "/.mtviews.c
fdd0: 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 69 onfig"))). (i
fde0: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
fdf0: 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a mthome-cfgfile).
fe00: 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 6d 74 .(read-config mt
fe10: 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 65 home-cfgfile vie
fe20: 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 20 w-cfgdat #t)).
fe30: 20 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 68 65 ;; we load the
fe40: 20 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 20 41 home dir file A
fe50: 46 54 45 52 20 74 68 65 20 4d 54 52 41 48 20 66 FTER the MTRAH f
fe60: 69 6c 65 20 73 6f 20 74 68 65 20 75 73 65 72 20 ile so the user
fe70: 63 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 74 74 can clobber sett
fe80: 69 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e 69 6e ings when runnin
fe90: 67 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 20 g the dashboard
fea0: 69 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 72 65 in read-only are
feb0: 61 73 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 as. (if (file
fec0: 2d 65 78 69 73 74 73 3f 20 68 6f 6d 65 2d 63 66 -exists? home-cf
fed0: 67 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 6f gfile)..(read-co
fee0: 6e 66 69 67 20 68 6f 6d 65 2d 63 66 67 66 69 6c nfig home-cfgfil
fef0: 65 20 76 69 65 77 2d 63 66 67 64 61 74 20 23 74 e view-cfgdat #t
ff00: 29 29 0a 20 20 20 20 76 69 65 77 2d 63 66 67 64 )). view-cfgd
ff10: 61 74 29 29 0a 0a at))..