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 20 73 74 61 63 6b 29 0a 28 72 65 71 75 ils stack).(requ
0270: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 72 65 ire-extension re
0280: 67 65 78 20 70 6f 73 69 78 29 0a 0a 28 72 65 71 gex posix)..(req
0290: 75 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 uire-extension (
02a0: 73 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 srfi 18) extras
02b0: 74 63 70 20 72 70 63 29 0a 0a 28 69 6d 70 6f 72 tcp rpc)..(impor
02c0: 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 t (prefix sqlite
02d0: 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 69 6d 3 sqlite3:)).(im
02e0: 70 6f 72 74 20 28 70 72 65 66 69 78 20 62 61 73 port (prefix bas
02f0: 65 36 34 20 62 61 73 65 36 34 3a 29 29 0a 0a 28 e64 base64:))..(
0300: 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 63 6f declare (unit co
0310: 6d 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 65 mmon))..(include
0320: 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 "common_records
0330: 2e 73 63 6d 22 29 0a 0a 3b 3b 20 28 72 65 71 75 .scm")..;; (requ
0340: 69 72 65 2d 6c 69 62 72 61 72 79 20 6d 61 72 67 ire-library marg
0350: 73 29 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 22 s).;; (include "
0360: 6d 61 72 67 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 margs.scm")..;;
0370: 28 64 65 66 69 6e 65 20 6f 6c 64 2d 65 78 69 74 (define old-exit
0380: 20 65 78 69 74 29 0a 3b 3b 20 0a 3b 3b 20 28 64 exit).;; .;; (d
0390: 65 66 69 6e 65 20 28 65 78 69 74 20 2e 20 63 6f efine (exit . co
03a0: 64 65 29 0a 3b 3b 20 20 20 28 69 66 20 28 6e 75 de).;; (if (nu
03b0: 6c 6c 3f 20 63 6f 64 65 29 0a 3b 3b 20 20 20 20 ll? code).;;
03c0: 20 20 20 28 6f 6c 64 2d 65 78 69 74 29 0a 3b 3b (old-exit).;;
03d0: 20 20 20 20 20 20 20 28 6f 6c 64 2d 65 78 69 74 (old-exit
03e0: 20 63 6f 64 65 29 29 29 0a 0a 28 64 65 66 69 6e code)))..(defin
03f0: 65 20 67 65 74 65 6e 76 20 67 65 74 2d 65 6e 76 e getenv get-env
0400: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
0410: 65 29 0a 28 64 65 66 69 6e 65 20 28 73 61 66 65 e).(define (safe
0420: 2d 73 65 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 -setenv key val)
0430: 0a 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 . (if (and (str
0440: 69 6e 67 3f 20 76 61 6c 29 28 73 74 72 69 6e 67 ing? val)(string
0450: 3f 20 6b 65 79 29 29 0a 20 20 20 20 20 20 28 68 ? key)). (h
0460: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
0470: 0a 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 . exn.
0480: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
0490: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
04a0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 -log-port* "bad
04b0: 76 61 6c 75 65 20 66 6f 72 20 73 65 74 65 6e 76 value for setenv
04c0: 2c 20 6b 65 79 3d 22 20 6b 65 79 20 22 2c 20 76 , key=" key ", v
04d0: 61 6c 75 65 3d 22 20 76 61 6c 29 0a 20 20 20 20 alue=" val).
04e0: 20 20 20 28 73 65 74 65 6e 76 20 6b 65 79 20 76 (setenv key v
04f0: 61 6c 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 al)). (debu
0500: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
0510: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0520: 74 2a 20 22 62 61 64 20 76 61 6c 75 65 20 66 6f t* "bad value fo
0530: 72 20 73 65 74 65 6e 76 2c 20 6b 65 79 3d 22 20 r setenv, key="
0540: 6b 65 79 20 22 2c 20 76 61 6c 75 65 3d 22 20 76 key ", value=" v
0550: 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 al)))..(define h
0560: 6f 6d 65 20 28 67 65 74 65 6e 76 20 22 48 4f 4d ome (getenv "HOM
0570: 45 22 29 29 0a 28 64 65 66 69 6e 65 20 75 73 65 E")).(define use
0580: 72 20 28 67 65 74 65 6e 76 20 22 55 53 45 52 22 r (getenv "USER"
0590: 29 29 0a 0a 3b 3b 20 47 4c 4f 42 41 4c 20 47 4c ))..;; GLOBAL GL
05a0: 45 54 43 48 45 53 0a 0a 3b 3b 20 43 4f 4e 54 45 ETCHES..;; CONTE
05b0: 58 54 53 0a 28 64 65 66 73 74 72 75 63 74 20 63 XTS.(defstruct c
05c0: 78 74 0a 20 20 28 74 61 73 6b 64 62 20 23 66 29 xt. (taskdb #f)
05d0: 0a 20 20 28 63 6d 75 74 65 78 20 28 6d 61 6b 65 . (cmutex (make
05e0: 2d 6d 75 74 65 78 29 29 29 0a 28 64 65 66 69 6e -mutex))).(defin
05f0: 65 20 2a 63 6f 6e 74 65 78 74 73 2a 20 28 6d 61 e *contexts* (ma
0600: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
0610: 28 64 65 66 69 6e 65 20 2a 63 6f 6e 74 65 78 74 (define *context
0620: 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 -mutex* (make-mu
0630: 74 65 78 29 29 0a 0a 3b 3b 20 73 61 66 65 20 6d tex))..;; safe m
0640: 65 74 68 6f 64 20 66 6f 72 20 61 63 63 65 73 73 ethod for access
0650: 69 6e 67 20 61 20 63 6f 6e 74 65 78 74 20 67 69 ing a context gi
0660: 76 65 6e 20 61 20 74 6f 70 70 61 74 68 0a 3b 3b ven a toppath.;;
0670: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
0680: 3a 77 69 74 68 2d 63 78 74 20 74 6f 70 70 61 74 :with-cxt toppat
0690: 68 20 70 72 6f 63 29 0a 20 20 28 6d 75 74 65 78 h proc). (mutex
06a0: 2d 6c 6f 63 6b 21 20 2a 63 6f 6e 74 65 78 74 2d -lock! *context-
06b0: 6d 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 mutex*). (let (
06c0: 28 63 78 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (cxt (hash-table
06d0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f -ref/default *co
06e0: 6e 74 65 78 74 73 2a 20 74 6f 70 70 61 74 68 20 ntexts* toppath
06f0: 23 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e #f))). (if (n
0700: 6f 74 20 63 78 74 29 0a 20 20 20 20 20 20 20 20 ot cxt).
0710: 28 73 65 74 21 20 63 78 74 20 28 6c 65 74 20 28 (set! cxt (let (
0720: 28 78 20 28 6d 61 6b 65 2d 63 78 74 29 29 29 28 (x (make-cxt)))(
0730: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
0740: 2a 63 6f 6e 74 65 78 74 73 2a 20 74 6f 70 70 61 *contexts* toppa
0750: 74 68 20 78 29 20 78 29 29 29 0a 20 20 20 20 28 th x) x))). (
0760: 6c 65 74 20 28 28 63 78 74 2d 6d 75 74 65 78 20 let ((cxt-mutex
0770: 28 63 78 74 2d 6d 75 74 65 78 20 63 78 74 29 29 (cxt-mutex cxt))
0780: 29 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 ). (mutex-u
0790: 6e 6c 6f 63 6b 21 20 2a 63 6f 6e 74 65 78 74 2d nlock! *context-
07a0: 6d 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 6d mutex*). (m
07b0: 75 74 65 78 2d 6c 6f 63 6b 21 20 63 78 74 2d 6d utex-lock! cxt-m
07c0: 75 74 65 78 29 0a 20 20 20 20 20 20 28 6c 65 74 utex). (let
07d0: 20 28 28 72 65 73 20 28 70 72 6f 63 20 63 78 74 ((res (proc cxt
07e0: 29 29 29 0a 20 20 20 20 20 20 20 20 28 6d 75 74 ))). (mut
07f0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 63 78 74 2d 6d ex-unlock! cxt-m
0800: 75 74 65 78 29 0a 20 20 20 20 20 20 20 20 72 65 utex). re
0810: 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 0a 28 s)))). .(
0820: 64 65 66 69 6e 65 20 2a 64 62 2d 6b 65 79 73 2a define *db-keys*
0830: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 #f)..(define *c
0840: 6f 6e 66 69 67 69 6e 66 6f 2a 20 20 20 23 66 29 onfiginfo* #f)
0850: 20 20 20 3b 3b 20 72 61 77 20 72 65 73 75 6c 74 ;; raw result
0860: 73 20 66 72 6f 6d 20 73 65 74 75 70 2c 20 69 6e s from setup, in
0870: 63 6c 75 64 65 73 20 74 6f 70 70 61 74 68 20 61 cludes toppath a
0880: 6e 64 20 74 61 62 6c 65 20 66 72 6f 6d 20 6d 65 nd table from me
0890: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 0a 28 64 gatest.config.(d
08a0: 65 66 69 6e 65 20 2a 72 75 6e 63 6f 6e 66 69 67 efine *runconfig
08b0: 64 61 74 2a 20 23 66 29 20 20 20 3b 3b 20 72 75 dat* #f) ;; ru
08c0: 6e 20 63 6f 6e 66 69 67 73 20 64 61 74 61 0a 28 n configs data.(
08d0: 64 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 64 61 define *configda
08e0: 74 2a 20 20 20 20 23 66 29 20 20 20 3b 3b 20 6d t* #f) ;; m
08f0: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 64 egatest.config d
0900: 61 74 61 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e ata.(define *con
0910: 66 69 67 73 74 61 74 75 73 2a 20 23 66 29 20 20 figstatus* #f)
0920: 20 3b 3b 20 73 74 61 74 75 73 20 6f 66 20 64 61 ;; status of da
0930: 74 61 3b 20 27 66 75 6c 6c 64 61 74 61 20 3a 20 ta; 'fulldata :
0940: 61 6c 6c 20 70 72 6f 63 65 73 73 69 6e 67 20 64 all processing d
0950: 6f 6e 65 2c 20 23 66 20 3a 20 6e 6f 20 64 61 74 one, #f : no dat
0960: 61 20 79 65 74 2c 20 27 70 61 72 74 69 61 6c 64 a yet, 'partiald
0970: 61 74 61 20 3a 20 70 61 72 74 69 61 6c 20 72 65 ata : partial re
0980: 61 64 20 64 6f 6e 65 0a 28 64 65 66 69 6e 65 20 ad done.(define
0990: 2a 74 6f 70 70 61 74 68 2a 20 20 20 20 20 20 23 *toppath* #
09a0: 66 29 0a 28 64 65 66 69 6e 65 20 2a 61 6c 72 65 f).(define *alre
09b0: 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 ady-seen-runconf
09c0: 69 67 2d 69 6e 66 6f 2a 20 23 66 29 0a 0a 28 64 ig-info* #f)..(d
09d0: 65 66 69 6e 65 20 2a 74 65 73 74 2d 6d 65 74 61 efine *test-meta
09e0: 2d 75 70 64 61 74 65 64 2a 20 28 6d 61 6b 65 2d -updated* (make-
09f0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 hash-table)).(de
0a00: 66 69 6e 65 20 2a 67 6c 6f 62 61 6c 65 78 69 74 fine *globalexit
0a10: 73 74 61 74 75 73 2a 20 20 30 29 20 3b 3b 20 61 status* 0) ;; a
0a20: 74 74 65 6d 70 74 20 74 6f 20 77 6f 72 6b 20 61 ttempt to work a
0a30: 72 6f 75 6e 64 20 70 6f 73 73 69 62 6c 65 20 74 round possible t
0a40: 68 72 65 61 64 20 69 73 73 75 65 73 0a 28 64 65 hread issues.(de
0a50: 66 69 6e 65 20 2a 70 61 73 73 6e 75 6d 2a 20 20 fine *passnum*
0a60: 20 20 20 20 20 20 20 20 20 30 29 20 3b 3b 20 77 0) ;; w
0a70: 68 65 6e 20 72 75 6e 6e 69 6e 67 20 74 72 61 63 hen running trac
0a80: 6b 20 63 61 6c 6c 73 20 74 6f 20 72 75 6e 2d 74 k calls to run-t
0a90: 65 73 74 73 20 6f 72 20 73 69 6d 69 6c 61 72 0a ests or similar.
0aa0: 28 64 65 66 69 6e 65 20 2a 61 6c 74 2d 6c 6f 67 (define *alt-log
0ab0: 2d 66 69 6c 65 2a 20 23 66 29 20 20 3b 3b 20 75 -file* #f) ;; u
0ac0: 73 65 64 20 62 79 20 2d 6c 6f 67 0a 28 64 65 66 sed by -log.(def
0ad0: 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f ine *common:deno
0ae0: 69 73 65 2a 20 20 20 20 28 6d 61 6b 65 2d 68 61 ise* (make-ha
0af0: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 66 6f sh-table)) ;; fo
0b00: 72 20 6c 6f 77 20 6e 6f 69 73 65 20 70 72 69 6e r low noise prin
0b10: 74 69 6e 67 0a 28 64 65 66 69 6e 65 20 2a 64 65 ting.(define *de
0b20: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
0b30: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
0b40: 70 6f 72 74 29 29 0a 28 64 65 66 69 6e 65 20 2a port)).(define *
0b50: 74 69 6d 65 2d 7a 65 72 6f 2a 20 28 63 75 72 72 time-zero* (curr
0b60: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b ent-seconds)) ;;
0b70: 20 66 6f 72 20 74 68 65 20 77 61 74 63 68 64 6f for the watchdo
0b80: 67 0a 0a 3b 3b 20 44 41 54 41 42 41 53 45 0a 28 g..;; DATABASE.(
0b90: 64 65 66 69 6e 65 20 2a 64 62 73 74 72 75 63 74 define *dbstruct
0ba0: 2d 64 62 2a 20 20 20 20 20 20 20 20 20 23 66 29 -db* #f)
0bb0: 20 3b 3b 20 75 73 65 64 20 74 6f 20 63 61 63 68 ;; used to cach
0bc0: 65 20 74 68 65 20 64 62 73 74 72 75 63 74 20 69 e the dbstruct i
0bd0: 6e 20 64 62 3a 73 65 74 75 70 2e 20 47 6f 61 6c n db:setup. Goal
0be0: 20 69 73 20 74 6f 20 72 65 6d 6f 76 65 20 74 68 is to remove th
0bf0: 69 73 2e 0a 3b 3b 20 64 62 20 73 74 61 74 73 0a is..;; db stats.
0c00: 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 74 61 74 (define *db-stat
0c10: 73 2a 20 20 20 20 20 20 20 20 20 20 20 20 28 6d s* (m
0c20: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
0c30: 20 3b 3b 20 68 61 73 68 20 6f 66 20 76 65 63 74 ;; hash of vect
0c40: 6f 72 73 20 3c 20 63 6f 75 6e 74 20 64 75 72 61 ors < count dura
0c50: 74 69 6f 6e 2d 74 6f 74 61 6c 20 3e 0a 28 64 65 tion-total >.(de
0c60: 66 69 6e 65 20 2a 64 62 2d 73 74 61 74 73 2d 6d fine *db-stats-m
0c70: 75 74 65 78 2a 20 20 20 20 20 20 28 6d 61 6b 65 utex* (make
0c80: 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 64 62 20 61 -mutex)).;; db a
0c90: 63 63 65 73 73 0a 28 64 65 66 69 6e 65 20 2a 64 ccess.(define *d
0ca0: 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 20 b-last-access*
0cb0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (current-sec
0cc0: 6f 6e 64 73 29 29 20 3b 3b 20 6c 61 73 74 20 64 onds)) ;; last d
0cd0: 62 20 61 63 63 65 73 73 2c 20 75 73 65 64 20 69 b access, used i
0ce0: 6e 20 73 65 72 76 65 72 0a 28 64 65 66 69 6e 65 n server.(define
0cf0: 20 2a 64 62 2d 77 72 69 74 65 2d 61 63 63 65 73 *db-write-acces
0d00: 73 2a 20 20 20 20 20 23 74 29 0a 3b 3b 20 64 62 s* #t).;; db
0d10: 20 73 79 6e 63 0a 28 64 65 66 69 6e 65 20 2a 64 sync.(define *d
0d20: 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 20 20 20 b-last-sync*
0d30: 20 20 20 20 30 29 20 20 20 20 20 20 20 20 20 20 0)
0d40: 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 74 ;; last t
0d50: 69 6d 65 20 74 68 65 20 73 79 6e 63 20 74 6f 20 ime the sync to
0d60: 6d 65 67 61 74 65 73 74 2e 64 62 20 68 61 70 70 megatest.db happ
0d70: 65 6e 65 64 0a 28 64 65 66 69 6e 65 20 2a 64 62 ened.(define *db
0d80: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
0d90: 73 2a 20 23 66 29 20 20 20 20 20 20 20 20 20 20 s* #f)
0da0: 20 20 20 20 20 20 3b 3b 20 69 66 20 74 68 65 72 ;; if ther
0db0: 65 20 69 73 20 61 20 73 79 6e 63 20 69 6e 20 70 e is a sync in p
0dc0: 72 6f 67 72 65 73 73 20 64 6f 20 6e 6f 74 20 74 rogress do not t
0dd0: 72 79 20 74 6f 20 73 74 61 72 74 20 61 6e 6f 74 ry to start anot
0de0: 68 65 72 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d her.(define *db-
0df0: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
0e00: 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 * (make-mutex))
0e10: 20 20 20 20 20 3b 3b 20 70 72 6f 74 65 63 74 20 ;; protect
0e20: 61 63 63 65 73 73 20 74 6f 20 2a 64 62 2d 73 79 access to *db-sy
0e30: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 2c nc-in-progress*,
0e40: 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 0a *db-last-sync*.
0e50: 3b 3b 20 74 61 73 6b 20 64 62 0a 28 64 65 66 69 ;; task db.(defi
0e60: 6e 65 20 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 ne *task-db*
0e70: 20 20 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 #f) ;;
0e80: 28 76 65 63 74 6f 72 20 64 62 20 70 61 74 68 2d (vector db path-
0e90: 74 6f 2d 64 62 29 0a 28 64 65 66 69 6e 65 20 2a to-db).(define *
0ea0: 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 db-access-allowe
0eb0: 64 2a 20 20 20 23 74 29 20 3b 3b 20 66 6c 61 67 d* #t) ;; flag
0ec0: 20 74 6f 20 61 6c 6c 6f 77 20 61 63 63 65 73 73 to allow access
0ed0: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 .(define *db-acc
0ee0: 65 73 73 2d 6d 75 74 65 78 2a 20 20 20 20 20 28 ess-mutex* (
0ef0: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 make-mutex)).(de
0f00: 66 69 6e 65 20 2a 64 62 2d 74 72 61 6e 73 61 63 fine *db-transac
0f10: 74 69 6f 6e 2d 6d 75 74 65 78 2a 20 28 6d 61 6b tion-mutex* (mak
0f20: 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 6e e-mutex)).(defin
0f30: 65 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 68 e *db-cache-path
0f40: 2a 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 * #f).(def
0f50: 69 6e 65 20 2a 64 62 2d 77 69 74 68 2d 64 62 2d ine *db-with-db-
0f60: 6d 75 74 65 78 2a 20 20 20 20 28 6d 61 6b 65 2d mutex* (make-
0f70: 6d 75 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 mutex)).(define
0f80: 2a 64 62 2d 61 70 69 2d 63 61 6c 6c 2d 74 69 6d *db-api-call-tim
0f90: 65 2a 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 e* (make-hash
0fa0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 61 73 68 -table)) ;; hash
0fb0: 20 6f 66 20 63 6f 6d 6d 61 6e 64 20 3d 3e 20 28 of command => (
0fc0: 6c 69 73 74 20 6f 66 20 74 69 6d 65 73 29 0a 0a list of times)..
0fd0: 3b 3b 20 53 45 52 56 45 52 0a 28 64 65 66 69 6e ;; SERVER.(defin
0fe0: 65 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 e *my-client-sig
0ff0: 6e 61 74 75 72 65 2a 20 23 66 29 0a 28 64 65 66 nature* #f).(def
1000: 69 6e 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 ine *transport-t
1010: 79 70 65 2a 20 20 20 20 27 68 74 74 70 29 20 20 ype* 'http)
1020: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 76 ;; ov
1030: 65 72 72 69 64 65 20 77 69 74 68 20 5b 73 65 72 erride with [ser
1040: 76 65 72 5d 20 74 72 61 6e 73 70 6f 72 74 20 68 ver] transport h
1050: 74 74 70 7c 72 70 63 7c 6e 6d 73 67 0a 28 64 65 ttp|rpc|nmsg.(de
1060: 66 69 6e 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a fine *runremote*
1070: 20 20 20 20 20 20 20 20 20 23 66 29 20 20 20 20 #f)
1080: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 ;; i
1090: 66 20 73 65 74 20 75 70 20 66 6f 72 20 73 65 72 f set up for ser
10a0: 76 65 72 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f ver communicatio
10b0: 6e 20 74 68 69 73 20 77 69 6c 6c 20 68 6f 6c 64 n this will hold
10c0: 20 3c 68 6f 73 74 20 70 6f 72 74 3e 0a 28 64 65 <host port>.(de
10d0: 66 69 6e 65 20 2a 6d 61 78 2d 63 61 63 68 65 2d fine *max-cache-
10e0: 73 69 7a 65 2a 20 20 20 20 30 29 0a 28 64 65 66 size* 0).(def
10f0: 69 6e 65 20 2a 6c 6f 67 67 65 64 2d 69 6e 2d 63 ine *logged-in-c
1100: 6c 69 65 6e 74 73 2a 20 28 6d 61 6b 65 2d 68 61 lients* (make-ha
1110: 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 sh-table)).(defi
1120: 6e 65 20 2a 73 65 72 76 65 72 2d 69 64 2a 20 20 ne *server-id*
1130: 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 #f).(defi
1140: 6e 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a ne *server-info*
1150: 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 #f).(defi
1160: 6e 65 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 ne *time-to-exit
1170: 2a 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 * #f).(defi
1180: 6e 65 20 2a 73 65 72 76 65 72 2d 72 75 6e 2a 20 ne *server-run*
1190: 20 20 20 20 20 20 20 23 74 29 0a 28 64 65 66 69 #t).(defi
11a0: 6e 65 20 2a 72 75 6e 2d 69 64 2a 20 20 20 20 20 ne *run-id*
11b0: 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 #f).(defi
11c0: 6e 65 20 2a 73 65 72 76 65 72 2d 6b 69 6e 64 2d ne *server-kind-
11d0: 72 75 6e 2a 20 20 20 28 6d 61 6b 65 2d 68 61 73 run* (make-has
11e0: 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e h-table)).(defin
11f0: 65 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 20 20 e *home-host*
1200: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
1210: 65 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 e *total-non-wri
1220: 74 65 2d 64 65 6c 61 79 2a 20 30 29 0a 28 64 65 te-delay* 0).(de
1230: 66 69 6e 65 20 2a 68 65 61 72 74 62 65 61 74 2d fine *heartbeat-
1240: 6d 75 74 65 78 2a 20 20 20 28 6d 61 6b 65 2d 6d mutex* (make-m
1250: 75 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a utex)).(define *
1260: 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 api-process-requ
1270: 65 73 74 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 64 est-count* 0).(d
1280: 65 66 69 6e 65 20 2a 6d 61 78 2d 61 70 69 2d 70 efine *max-api-p
1290: 72 6f 63 65 73 73 2d 72 65 71 75 65 73 74 73 2a rocess-requests*
12a0: 20 30 29 0a 0a 3b 3b 20 63 6c 69 65 6e 74 0a 28 0)..;; client.(
12b0: 64 65 66 69 6e 65 20 2a 72 6d 74 2d 6d 75 74 65 define *rmt-mute
12c0: 78 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 x* (make
12d0: 2d 6d 75 74 65 78 29 29 20 20 20 20 20 3b 3b 20 -mutex)) ;;
12e0: 72 65 6d 6f 74 65 20 61 63 63 65 73 73 20 63 61 remote access ca
12f0: 6c 6c 73 20 6d 75 74 65 78 20 0a 0a 3b 3b 20 52 lls mutex ..;; R
1300: 50 43 20 74 72 61 6e 73 70 6f 72 74 0a 28 64 65 PC transport.(de
1310: 66 69 6e 65 20 2a 72 70 63 3a 6c 69 73 74 65 6e fine *rpc:listen
1320: 65 72 2a 20 20 20 20 20 20 23 66 29 0a 0a 3b 3b er* #f)..;;
1330: 20 4b 45 59 20 69 6e 66 6f 0a 28 64 65 66 69 6e KEY info.(defin
1340: 65 20 2a 74 61 72 67 65 74 2a 20 20 20 20 20 20 e *target*
1350: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
1360: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 -table)) ;; cach
1370: 65 20 74 68 65 20 74 61 72 67 65 74 20 68 65 72 e the target her
1380: 65 3b 20 74 61 72 67 65 74 20 69 73 20 6b 65 79 e; target is key
1390: 76 61 6c 31 2f 6b 65 79 76 61 6c 32 2f 2e 2e 2e val1/keyval2/...
13a0: 2f 6b 65 79 76 61 6c 4e 0a 28 64 65 66 69 6e 65 /keyvalN.(define
13b0: 20 2a 6b 65 79 73 2a 20 20 20 20 20 20 20 20 20 *keys*
13c0: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
13d0: 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 table)) ;; cache
13e0: 20 74 68 65 20 6b 65 79 73 20 68 65 72 65 0a 28 the keys here.(
13f0: 64 65 66 69 6e 65 20 2a 6b 65 79 76 61 6c 73 2a define *keyvals*
1400: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
1410: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 -hash-table)).(d
1420: 65 66 69 6e 65 20 2a 74 6f 70 74 65 73 74 2d 70 efine *toptest-p
1430: 61 74 68 73 2a 20 20 20 20 20 28 6d 61 6b 65 2d aths* (make-
1440: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1450: 63 61 63 68 65 20 74 6f 70 74 65 73 74 20 70 61 cache toptest pa
1460: 74 68 20 73 65 74 74 69 6e 67 73 20 68 65 72 65 th settings here
1470: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 70 .(define *test-p
1480: 61 74 68 73 2a 20 20 20 20 20 20 20 20 28 6d 61 aths* (ma
1490: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
14a0: 3b 3b 20 63 61 63 68 65 20 74 65 73 74 2d 69 64 ;; cache test-id
14b0: 20 74 6f 20 74 65 73 74 20 72 75 6e 20 70 61 74 to test run pat
14c0: 68 73 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 hs here.(define
14d0: 2a 74 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 *test-ids*
14e0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
14f0: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
1500: 72 75 6e 2d 69 64 2c 20 74 65 73 74 6e 61 6d 65 run-id, testname
1510: 2c 20 61 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 , and item-path
1520: 3d 3e 20 74 65 73 74 2d 69 64 0a 28 64 65 66 69 => test-id.(defi
1530: 6e 65 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 ne *test-info*
1540: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
1550: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 h-table)) ;; cac
1560: 68 65 20 74 68 65 20 74 65 73 74 20 69 6e 66 6f he the test info
1570: 20 72 65 63 6f 72 64 73 2c 20 75 70 64 61 74 65 records, update
1580: 20 74 68 65 20 73 74 61 74 65 2c 20 73 74 61 74 the state, stat
1590: 75 73 2c 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e us, run_duration
15a0: 20 65 74 63 2e 20 66 72 6f 6d 20 74 65 73 74 64 etc. from testd
15b0: 61 74 2e 64 62 0a 0a 28 64 65 66 69 6e 65 20 2a at.db..(define *
15c0: 72 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 run-info-cache*
15d0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
15e0: 61 62 6c 65 29 29 20 3b 3b 20 72 75 6e 20 69 6e able)) ;; run in
15f0: 66 6f 20 69 73 20 73 74 61 62 6c 65 2c 20 6e 6f fo is stable, no
1600: 20 6e 65 65 64 20 74 6f 20 72 65 67 65 74 0a 28 need to reget.(
1610: 64 65 66 69 6e 65 20 2a 6c 61 75 6e 63 68 2d 73 define *launch-s
1620: 65 74 75 70 2d 6d 75 74 65 78 2a 20 28 6d 61 6b etup-mutex* (mak
1630: 65 2d 6d 75 74 65 78 29 29 20 20 20 20 20 3b 3b e-mutex)) ;;
1640: 20 6e 65 65 64 20 74 6f 20 62 65 20 61 62 6c 65 need to be able
1650: 20 74 6f 20 63 61 6c 6c 20 6c 61 75 6e 63 68 3a to call launch:
1660: 73 65 74 75 70 20 6f 66 74 65 6e 20 73 6f 20 6d setup often so m
1670: 75 74 65 78 20 69 74 20 61 6e 64 20 72 65 2d 63 utex it and re-c
1680: 61 6c 6c 20 74 68 65 20 72 65 61 6c 20 64 65 61 all the real dea
1690: 6c 20 6f 6e 6c 79 20 69 66 20 2a 74 6f 70 70 61 l only if *toppa
16a0: 74 68 2a 20 6e 6f 74 20 73 65 74 0a 28 64 65 66 th* not set.(def
16b0: 69 6e 65 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 ine *homehost-mu
16c0: 74 65 78 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d tex* (make-m
16d0: 75 74 65 78 29 29 0a 0a 28 64 65 66 73 74 72 75 utex))..(defstru
16e0: 63 74 20 72 65 6d 6f 74 65 0a 20 20 28 68 68 2d ct remote. (hh-
16f0: 64 61 74 20 20 20 20 20 20 20 20 20 20 20 20 28 dat (
1700: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 common:get-homeh
1710: 6f 73 74 29 29 20 3b 3b 20 68 6f 6d 65 68 6f 73 ost)) ;; homehos
1720: 74 20 72 65 63 6f 72 64 20 28 20 61 64 64 72 20 t record ( addr
1730: 2e 20 68 68 66 6c 61 67 20 29 0a 20 20 28 73 65 . hhflag ). (se
1740: 72 76 65 72 2d 75 72 6c 20 20 20 20 20 20 20 20 rver-url
1750: 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 28 73 (if *toppath* (s
1760: 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 erver:check-if-r
1770: 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a unning *toppath*
1780: 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 3a 63 ))) ;; (server:c
1790: 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 heck-if-running
17a0: 2a 74 6f 70 70 61 74 68 2a 29 20 23 66 29 29 0a *toppath*) #f)).
17b0: 20 20 28 6c 61 73 74 2d 73 65 72 76 65 72 2d 63 (last-server-c
17c0: 68 65 63 6b 20 30 29 20 20 3b 3b 20 6c 61 73 74 heck 0) ;; last
17d0: 20 74 69 6d 65 20 77 65 20 63 68 65 63 6b 65 64 time we checked
17e0: 20 74 6f 20 73 65 65 20 69 66 20 74 68 65 20 73 to see if the s
17f0: 65 72 76 65 72 20 77 61 73 20 61 6c 69 76 65 0a erver was alive.
1800: 20 20 28 63 6f 6e 6e 64 61 74 20 20 20 20 20 20 (conndat
1810: 20 20 20 20 20 23 66 29 0a 20 20 28 74 72 61 6e #f). (tran
1820: 73 70 6f 72 74 20 20 20 20 20 20 20 20 20 2a 74 sport *t
1830: 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a 29 0a ransport-type*).
1840: 20 20 28 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 (server-timeou
1850: 74 20 20 20 20 28 6f 72 20 28 73 65 72 76 65 72 t (or (server
1860: 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 20 31 30 :get-timeout) 10
1870: 30 29 29 29 20 3b 3b 20 64 65 66 61 75 6c 74 20 0))) ;; default
1880: 74 6f 20 31 30 30 20 73 65 63 6f 6e 64 73 0a 0a to 100 seconds..
1890: 3b 3b 20 6c 61 75 6e 63 68 69 6e 67 20 61 6e 64 ;; launching and
18a0: 20 68 6f 73 74 73 0a 28 64 65 66 73 74 72 75 63 hosts.(defstruc
18b0: 74 20 68 6f 73 74 0a 20 20 28 72 65 61 63 68 61 t host. (reacha
18c0: 62 6c 65 20 20 20 20 23 66 29 0a 20 20 28 6c 61 ble #f). (la
18d0: 73 74 2d 75 70 64 61 74 65 20 20 30 29 0a 20 20 st-update 0).
18e0: 28 6c 61 73 74 2d 75 73 65 64 20 20 20 20 30 29 (last-used 0)
18f0: 0a 20 20 28 6c 61 73 74 2d 63 70 75 6c 6f 61 64 . (last-cpuload
1900: 20 31 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 68 1))..(define *h
1910: 6f 73 74 2d 6c 6f 61 64 73 2a 20 20 20 20 20 20 ost-loads*
1920: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1930: 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 65 20 ble))..;; cache
1940: 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 73 environment vars
1950: 20 66 6f 72 20 65 61 63 68 20 72 75 6e 20 68 65 for each run he
1960: 72 65 0a 28 64 65 66 69 6e 65 20 2a 65 6e 76 2d re.(define *env-
1970: 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 vars-by-run-id*
1980: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1990: 29 29 0a 0a 3b 3b 20 54 65 73 74 63 6f 6e 66 69 ))..;; Testconfi
19a0: 67 20 61 6e 64 20 72 75 6e 63 6f 6e 66 69 67 20 g and runconfig
19b0: 63 61 63 68 65 73 2e 20 0a 28 64 65 66 69 6e 65 caches. .(define
19c0: 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 20 *testconfigs*
19d0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
19e0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 65 73 74 -table)) ;; test
19f0: 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 63 6f 6e -name => testcon
1a00: 66 69 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e fig.(define *run
1a10: 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 20 20 20 configs*
1a20: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
1a30: 65 29 29 20 3b 3b 20 74 61 72 67 65 74 20 20 20 e)) ;; target
1a40: 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 0a 0a 3b => runconfig..;
1a50: 3b 20 54 68 69 73 20 69 73 20 61 20 63 61 63 68 ; This is a cach
1a60: 65 20 6f 66 20 70 72 65 2d 72 65 71 73 20 6d 65 e of pre-reqs me
1a70: 74 2c 20 64 6f 6e 27 74 20 72 65 2d 63 61 6c 63 t, don't re-calc
1a80: 20 69 6e 20 63 61 73 65 73 20 77 68 65 72 65 20 in cases where
1a90: 63 61 6c 6c 65 64 20 77 69 74 68 20 73 61 6d 65 called with same
1aa0: 20 70 61 72 61 6d 73 20 6c 65 73 73 20 74 68 61 params less tha
1ab0: 6e 0a 3b 3b 20 66 69 76 65 20 73 65 63 6f 6e 64 n.;; five second
1ac0: 73 20 61 67 6f 0a 28 64 65 66 69 6e 65 20 2a 70 s ago.(define *p
1ad0: 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 63 68 re-reqs-met-cach
1ae0: 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 e* (make-hash-ta
1af0: 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 65 20 ble))..;; cache
1b00: 6f 66 20 76 65 72 62 6f 73 69 74 79 20 67 69 76 of verbosity giv
1b10: 65 6e 20 73 74 72 69 6e 67 0a 3b 3b 0a 28 64 65 en string.;;.(de
1b20: 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 2d fine *verbosity-
1b30: 63 61 63 68 65 2a 20 20 20 20 28 6d 61 6b 65 2d cache* (make-
1b40: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 28 64 hash-table))..(d
1b50: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c efine (common:cl
1b60: 65 61 72 2d 63 61 63 68 65 73 29 0a 20 20 28 73 ear-caches). (s
1b70: 65 74 21 20 2a 74 61 72 67 65 74 2a 20 20 20 20 et! *target*
1b80: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1b90: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1ba0: 65 74 21 20 2a 6b 65 79 73 2a 20 20 20 20 20 20 et! *keys*
1bb0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1bc0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1bd0: 65 74 21 20 2a 6b 65 79 76 61 6c 73 2a 20 20 20 et! *keyvals*
1be0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1bf0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1c00: 65 74 21 20 2a 74 6f 70 74 65 73 74 2d 70 61 74 et! *toptest-pat
1c10: 68 73 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 hs* (make-h
1c20: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1c30: 65 74 21 20 2a 74 65 73 74 2d 70 61 74 68 73 2a et! *test-paths*
1c40: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1c50: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1c60: 65 74 21 20 2a 74 65 73 74 2d 69 64 73 2a 20 20 et! *test-ids*
1c70: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1c80: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1c90: 65 74 21 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 et! *test-info*
1ca0: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1cb0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1cc0: 65 74 21 20 2a 72 75 6e 2d 69 6e 66 6f 2d 63 61 et! *run-info-ca
1cd0: 63 68 65 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 che* (make-h
1ce0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1cf0: 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d 62 79 et! *env-vars-by
1d00: 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 6b 65 2d 68 -run-id* (make-h
1d10: 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 73 ash-table)). (s
1d20: 65 74 21 20 2a 74 65 73 74 2d 69 64 2d 63 61 63 et! *test-id-cac
1d30: 68 65 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 he* (make-h
1d40: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 0a 3b 3b ash-table)))..;;
1d50: 20 47 65 6e 65 72 69 63 20 73 74 72 69 6e 67 20 Generic string
1d60: 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e 65 database.(define
1d70: 20 73 64 62 3a 71 72 79 20 23 66 29 20 3b 3b 20 sdb:qry #f) ;;
1d80: 28 6d 61 6b 65 2d 73 64 62 3a 71 72 79 29 29 20 (make-sdb:qry))
1d90: 3b 3b 20 20 27 69 6e 69 74 20 23 66 29 0a 3b 3b ;; 'init #f).;;
1da0: 20 47 65 6e 65 72 69 63 20 70 61 74 68 20 64 61 Generic path da
1db0: 74 61 62 61 73 65 0a 28 64 65 66 69 6e 65 20 2a tabase.(define *
1dc0: 66 64 62 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e fdb* #f)..(defin
1dd0: 65 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a 20 e *last-launch*
1de0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
1df0: 29 29 20 3b 3b 20 75 73 65 20 66 6f 72 20 74 68 )) ;; use for th
1e00: 72 6f 74 74 6c 69 6e 67 20 74 68 65 20 6c 61 75 rottling the lau
1e10: 6e 63 68 20 72 61 74 65 2e 20 57 6f 75 6c 64 20 nch rate. Would
1e20: 62 65 20 62 65 74 74 65 72 20 74 6f 20 75 73 65 be better to use
1e30: 20 74 68 65 20 64 62 20 61 6e 64 20 6c 61 73 74 the db and last
1e40: 20 74 69 6d 65 20 6f 66 20 61 20 74 65 73 74 20 time of a test
1e50: 69 6e 20 4c 41 55 4e 43 48 45 44 20 73 74 61 74 in LAUNCHED stat
1e60: 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d e...;;==========
1e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
1eb0: 56 20 45 20 52 20 53 20 49 20 4f 20 4e 0a 3b 3b V E R S I O N.;;
1ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f00: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
1f10: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c (common:get-full
1f20: 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 63 6f 6e -version). (con
1f30: 63 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 c megatest-versi
1f40: 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 74 2d on "-" megatest-
1f50: 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a 0a 28 fossil-hash))..(
1f60: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 define (common:v
1f70: 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 ersion-signature
1f80: 29 0a 20 20 28 63 6f 6e 63 20 6d 65 67 61 74 65 ). (conc megate
1f90: 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 28 st-version "-" (
1fa0: 73 75 62 73 74 72 69 6e 67 20 6d 65 67 61 74 65 substring megate
1fb0: 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 20 30 st-fossil-hash 0
1fc0: 20 34 29 29 29 0a 0a 3b 3b 20 66 72 6f 6d 20 6d 4)))..;; from m
1fd0: 65 74 61 64 61 74 20 6c 6f 6f 6b 75 70 20 4d 45 etadat lookup ME
1fe0: 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 0a 3b GATEST_VERSION.;
1ff0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2000: 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:get-last-run-v
2010: 65 72 73 69 6f 6e 29 20 3b 3b 20 52 41 44 54 20 ersion) ;; RADT
2020: 3d 3e 20 48 6f 77 20 64 6f 65 73 20 74 68 69 73 => How does this
2030: 20 77 6f 72 6b 20 69 6e 20 73 65 6e 64 2d 72 65 work in send-re
2040: 63 65 69 76 65 20 66 75 6e 63 74 69 6f 6e 3f 3f ceive function??
2050: 3b 20 61 73 73 75 6d 65 20 69 74 20 69 73 20 74 ; assume it is t
2060: 68 65 20 76 61 6c 75 65 20 73 61 76 65 64 20 69 he value saved i
2070: 6e 20 73 6f 6d 65 20 44 42 0a 20 20 28 72 6d 74 n some DB. (rmt
2080: 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 :get-var "MEGATE
2090: 53 54 5f 56 45 52 53 49 4f 4e 22 29 29 0a 0a 28 ST_VERSION"))..(
20a0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
20b0: 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 et-last-run-vers
20c0: 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 20 28 73 ion-number). (s
20d0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 20 tring->number .
20e0: 20 20 28 73 75 62 73 74 72 69 6e 67 20 28 63 6f (substring (co
20f0: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
2100: 6e 2d 76 65 72 73 69 6f 6e 29 20 30 20 36 29 29 n-version) 0 6))
2110: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
2120: 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e 2d on:set-last-run-
2130: 76 65 72 73 69 6f 6e 29 0a 20 20 28 72 6d 74 3a version). (rmt:
2140: 73 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 53 set-var "MEGATES
2150: 54 5f 56 45 52 53 49 4f 4e 22 20 28 63 6f 6d 6d T_VERSION" (comm
2160: 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 on:version-signa
2170: 74 75 72 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 ture)))..(define
2180: 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e (common:version
2190: 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 28 6e 6f -changed?). (no
21a0: 74 20 28 65 71 75 61 6c 3f 20 28 63 6f 6d 6d 6f t (equal? (commo
21b0: 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:get-last-run-v
21c0: 65 72 73 69 6f 6e 29 0a 09 20 20 20 20 20 20 20 ersion)..
21d0: 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d (common:version-
21e0: 73 69 67 6e 61 74 75 72 65 29 29 29 29 0a 0a 3b signature))))..;
21f0: 3b 20 4d 6f 76 65 20 6d 65 20 65 6c 73 65 77 68 ; Move me elsewh
2200: 65 72 65 20 2e 2e 2e 0a 3b 3b 20 52 41 44 54 20 ere ....;; RADT
2210: 3d 3e 20 57 68 79 20 64 6f 20 77 65 20 6d 65 65 => Why do we mee
2220: 64 20 74 68 65 20 76 65 72 73 69 6f 6e 20 63 68 d the version ch
2230: 65 63 6b 20 68 65 72 65 2c 20 74 68 69 73 20 69 eck here, this i
2240: 73 20 63 61 6c 6c 65 64 20 6f 6e 6c 79 20 69 66 s called only if
2250: 20 76 65 72 73 69 6f 6e 20 6d 69 73 6d 61 0a 3b version misma.;
2260: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2270: 6e 3a 63 6c 65 61 6e 75 70 2d 64 62 20 64 62 73 n:cleanup-db dbs
2280: 74 72 75 63 74 29 0a 20 20 28 64 62 3a 6d 75 6c truct). (db:mul
2290: 74 69 2d 64 62 2d 73 79 6e 63 20 0a 20 20 20 64 ti-db-sync . d
22a0: 62 73 74 72 75 63 74 0a 20 20 20 3b 3b 20 27 6e bstruct. ;; 'n
22b0: 65 77 32 6f 6c 64 0a 20 20 20 27 6b 69 6c 6c 73 ew2old. 'kills
22c0: 65 72 76 65 72 73 0a 20 20 20 27 64 65 6a 75 6e ervers. 'dejun
22d0: 6b 0a 20 20 20 3b 3b 20 27 61 64 6a 2d 74 65 73 k. ;; 'adj-tes
22e0: 74 69 64 73 0a 20 20 20 3b 3b 20 27 6f 6c 64 32 tids. ;; 'old2
22f0: 6e 65 77 0a 20 20 20 27 6e 65 77 32 6f 6c 64 0a new. 'new2old.
2300: 20 20 20 27 73 63 68 65 6d 61 29 0a 20 20 28 69 'schema). (i
2310: 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f f (common:versio
2320: 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 20 20 n-changed?).
2330: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 (common:set-la
2340: 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 29 st-run-version))
2350: 29 0a 0a 3b 3b 20 52 6f 74 61 74 65 20 6c 6f 67 )..;; Rotate log
2360: 73 2c 20 6c 6f 67 69 63 3a 20 0a 3b 3b 20 20 20 s, logic: .;;
2370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 69 66 if
2380: 20 3e 20 35 30 30 6b 20 61 6e 64 20 6f 6c 64 65 > 500k and olde
2390: 72 20 74 68 61 6e 20 31 20 77 65 65 6b 3a 0a 3b r than 1 week:.;
23a0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
23b0: 20 20 20 20 20 20 72 65 6d 6f 76 65 20 70 72 65 remove pre
23c0: 76 69 6f 75 73 20 63 6f 6d 70 72 65 73 73 65 64 vious compressed
23d0: 20 6c 6f 67 20 61 6e 64 20 63 6f 6d 70 72 65 73 log and compres
23e0: 73 20 74 68 69 73 20 6c 6f 67 0a 3b 3b 20 57 41 s this log.;; WA
23f0: 52 4e 49 4e 47 3a 20 54 68 69 73 20 70 72 6f 63 RNING: This proc
2400: 20 6f 70 65 72 61 74 65 73 20 61 73 73 75 6d 69 operates assumi
2410: 6e 67 20 74 68 61 74 20 69 74 20 69 73 20 69 6e ng that it is in
2420: 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 61 the directory a
2430: 62 6f 76 65 20 74 68 65 0a 3b 3b 20 20 20 20 20 bove the.;;
2440: 20 20 20 20 20 6c 6f 67 73 20 64 69 72 65 63 74 logs direct
2450: 6f 72 79 20 79 6f 75 20 77 69 73 68 20 74 6f 20 ory you wish to
2460: 6c 6f 67 2d 72 6f 74 61 74 65 2e 0a 3b 3b 0a 28 log-rotate..;;.(
2470: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 define (common:r
2480: 6f 74 61 74 65 2d 6c 6f 67 73 29 0a 20 20 28 69 otate-logs). (i
2490: 66 20 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 f (not (director
24a0: 79 2d 65 78 69 73 74 73 3f 20 22 6c 6f 67 73 22 y-exists? "logs"
24b0: 29 29 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 ))(create-direct
24c0: 6f 72 79 20 22 6c 6f 67 73 22 29 29 0a 20 20 28 ory "logs")). (
24d0: 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c 64 20 0a directory-fold .
24e0: 20 20 20 28 6c 61 6d 62 64 61 20 28 66 69 6c 65 (lambda (file
24f0: 20 72 65 6d 29 0a 20 20 20 20 20 28 68 61 6e 64 rem). (hand
2500: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
2510: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 28 64 exn. (d
2520: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
2530: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2540: 6f 72 74 2a 20 22 66 61 69 6c 65 64 20 74 6f 20 ort* "failed to
2550: 72 6f 74 61 74 65 20 6c 6f 67 20 22 20 66 69 6c rotate log " fil
2560: 65 20 22 2c 20 70 72 6f 62 61 62 6c 79 20 68 61 e ", probably ha
2570: 6e 64 6c 65 64 20 62 79 20 61 6e 6f 74 68 65 72 ndled by another
2580: 20 70 72 6f 63 65 73 73 2e 22 29 0a 20 20 20 20 process.").
2590: 20 20 28 6c 65 74 2a 20 28 28 66 75 6c 6c 6e 61 (let* ((fullna
25a0: 6d 65 20 28 63 6f 6e 63 20 22 6c 6f 67 73 2f 22 me (conc "logs/"
25b0: 20 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 20 file)).
25c0: 20 20 20 20 20 28 66 69 6c 65 2d 61 67 65 20 28 (file-age (
25d0: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
25e0: 64 73 29 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 ds)(file-modific
25f0: 61 74 69 6f 6e 2d 74 69 6d 65 20 66 75 6c 6c 6e ation-time fulln
2600: 61 6d 65 29 29 29 29 0a 20 20 20 20 20 20 20 20 ame)))).
2610: 28 69 66 20 28 6f 72 20 28 61 6e 64 20 28 73 74 (if (or (and (st
2620: 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 2e 2a 2e ring-match "^.*.
2630: 6c 6f 67 22 20 66 69 6c 65 29 0a 20 20 20 20 20 log" file).
2640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2650: 28 3e 20 28 66 69 6c 65 2d 73 69 7a 65 20 66 75 (> (file-size fu
2660: 6c 6c 6e 61 6d 65 29 20 32 30 30 30 30 30 29 29 llname) 200000))
2670: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2680: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 2d 6d 61 (and (string-ma
2690: 74 63 68 20 22 5e 73 65 72 76 65 72 2d 2e 2a 2e tch "^server-.*.
26a0: 6c 6f 67 22 20 66 69 6c 65 29 0a 20 20 20 20 20 log" file).
26b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
26c0: 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 (> (- (current-s
26d0: 65 63 6f 6e 64 73 29 20 28 66 69 6c 65 2d 6d 6f econds) (file-mo
26e0: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
26f0: 66 75 6c 6c 6e 61 6d 65 29 29 0a 20 20 20 20 20 fullname)).
2700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2710: 20 20 20 28 2a 20 38 20 36 30 20 36 30 29 29 29 (* 8 60 60)))
2720: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ). (l
2730: 65 74 20 28 28 67 7a 66 69 6c 65 20 28 63 6f 6e et ((gzfile (con
2740: 63 20 66 75 6c 6c 6e 61 6d 65 20 22 2e 67 7a 22 c fullname ".gz"
2750: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
2760: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
2770: 74 73 3f 20 67 7a 66 69 6c 65 29 0a 20 20 20 20 ts? gzfile).
2780: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
2790: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
27a0: 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a (debug:
27b0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
27c0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
27d0: 22 72 65 6d 6f 76 69 6e 67 20 22 20 67 7a 66 69 "removing " gzfi
27e0: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
27f0: 20 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 2d (delete-
2800: 66 69 6c 65 20 67 7a 66 69 6c 65 29 29 29 0a 20 file gzfile))).
2810: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
2820: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
2830: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2840: 72 74 2a 20 22 63 6f 6d 70 72 65 73 73 69 6e 67 rt* "compressing
2850: 20 22 20 66 69 6c 65 29 0a 20 20 20 20 20 20 20 " file).
2860: 20 20 20 20 20 20 20 28 73 79 73 74 65 6d 20 28 (system (
2870: 63 6f 6e 63 20 22 67 7a 69 70 20 22 20 66 75 6c conc "gzip " ful
2880: 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 20 20 20 lname))).
2890: 20 20 20 20 20 28 69 66 20 28 3e 20 66 69 6c 65 (if (> file
28a0: 2d 61 67 65 20 28 2a 20 28 73 74 72 69 6e 67 2d -age (* (string-
28b0: 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e >number (or (con
28c0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
28d0: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
28e0: 22 6c 6f 67 2d 65 78 70 69 72 65 2d 64 61 79 73 "log-expire-days
28f0: 22 29 20 22 33 30 22 29 29 20 32 34 20 33 36 30 ") "30")) 24 360
2900: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
2910: 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 (handle-exce
2920: 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 ptions.
2930: 20 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 exn.
2940: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 0a #f.
2950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2960: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 66 75 (delete-file fu
2970: 6c 6c 6e 61 6d 65 29 29 29 29 29 29 29 0a 20 20 llname))))))).
2980: 20 27 28 29 0a 20 20 20 22 6c 6f 67 73 22 29 29 '(). "logs"))
2990: 0a 0a 3b 3b 20 46 6f 72 63 65 20 61 20 6d 65 67 ..;; Force a meg
29a0: 61 74 65 73 74 20 63 6c 65 61 6e 75 70 2d 64 62 atest cleanup-db
29b0: 20 69 66 20 76 65 72 73 69 6f 6e 20 69 73 20 63 if version is c
29c0: 68 61 6e 67 65 64 20 61 6e 64 20 73 6b 69 70 2d hanged and skip-
29d0: 76 65 72 73 69 6f 6e 2d 63 68 65 63 6b 20 6e 6f version-check no
29e0: 74 20 73 70 65 63 69 66 69 65 64 0a 3b 3b 0a 28 t specified.;;.(
29f0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 65 define (common:e
2a00: 78 69 74 2d 6f 6e 2d 76 65 72 73 69 6f 6e 2d 63 xit-on-version-c
2a10: 68 61 6e 67 65 64 29 0a 20 20 28 69 66 20 28 63 hanged). (if (c
2a20: 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 63 68 ommon:version-ch
2a30: 61 6e 67 65 64 3f 29 0a 20 20 20 20 20 20 28 69 anged?). (i
2a40: 66 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d f (common:on-hom
2a50: 65 68 6f 73 74 3f 29 0a 09 20 20 28 6c 65 74 20 ehost?).. (let
2a60: 28 28 6d 74 63 6f 6e 66 20 28 63 6f 6e 63 20 28 ((mtconf (conc (
2a70: 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
2a80: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e variable "MT_RUN
2a90: 5f 41 52 45 41 5f 48 4f 4d 45 22 29 20 22 2f 6d _AREA_HOME") "/m
2aa0: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 egatest.config")
2ab0: 29 0a 09 09 28 64 62 73 74 72 75 63 74 20 28 64 )...(dbstruct (d
2ac0: 62 3a 73 65 74 75 70 29 29 29 0a 09 20 20 20 20 b:setup)))..
2ad0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
2ae0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2af0: 2a 0a 09 09 09 20 22 57 41 52 4e 49 4e 47 3a 20 *.... "WARNING:
2b00: 56 65 72 73 69 6f 6e 20 6d 69 73 6d 61 74 63 68 Version mismatch
2b10: 21 5c 6e 22 0a 09 09 09 20 22 20 20 20 65 78 70 !\n".... " exp
2b20: 65 63 74 65 64 3a 20 22 20 28 63 6f 6d 6d 6f 6e ected: " (common
2b30: 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 :version-signatu
2b40: 72 65 29 20 22 5c 6e 22 0a 09 09 09 20 22 20 20 re) "\n".... "
2b50: 20 67 6f 74 3a 20 20 20 20 20 20 22 20 28 63 6f got: " (co
2b60: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
2b70: 6e 2d 76 65 72 73 69 6f 6e 29 29 0a 09 20 20 20 n-version))..
2b80: 20 28 69 66 20 28 61 6e 64 20 28 66 69 6c 65 2d (if (and (file-
2b90: 65 78 69 73 74 73 3f 20 6d 74 63 6f 6e 66 29 0a exists? mtconf).
2ba0: 09 09 20 20 20 20 20 28 65 71 3f 20 28 63 75 72 .. (eq? (cur
2bb0: 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 28 66 69 rent-user-id)(fi
2bc0: 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 6f 6e 66 29 le-owner mtconf)
2bd0: 29 29 20 3b 3b 20 73 61 66 65 20 74 6f 20 72 75 )) ;; safe to ru
2be0: 6e 20 2d 63 6c 65 61 6e 75 70 2d 64 62 0a 09 09 n -cleanup-db...
2bf0: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu
2c00: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
2c10: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 lt-log-port* "
2c20: 20 49 20 73 65 65 20 79 6f 75 20 61 72 65 20 74 I see you are t
2c30: 68 65 20 6f 77 6e 65 72 20 6f 66 20 6d 65 67 61 he owner of mega
2c40: 74 65 73 74 2e 63 6f 6e 66 69 67 2c 20 61 74 74 test.config, att
2c50: 65 6d 70 74 69 6e 67 20 74 6f 20 63 6c 65 61 6e empting to clean
2c60: 75 70 20 61 6e 64 20 72 65 73 65 74 20 74 6f 20 up and reset to
2c70: 6e 65 77 20 76 65 72 73 69 6f 6e 22 29 0a 09 09 new version")...
2c80: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
2c90: 69 6f 6e 73 0a 09 09 20 20 20 65 78 6e 0a 09 09 ions... exn...
2ca0: 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 (begin...
2cb0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2cc0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2cd0: 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 73 77 t* "Failed to sw
2ce0: 69 74 63 68 20 76 65 72 73 69 6f 6e 73 2e 22 29 itch versions.")
2cf0: 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 ... (debug:p
2d00: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2d10: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d 65 73 73 log-port* " mess
2d20: 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 age: " ((conditi
2d30: 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 on-property-acce
2d40: 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 ssor 'exn 'messa
2d50: 67 65 29 20 65 78 6e 29 29 0a 09 09 20 20 20 20 ge) exn))...
2d60: 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 (print-call-cha
2d70: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
2d80: 72 2d 70 6f 72 74 29 29 0a 09 09 20 20 20 20 20 r-port))...
2d90: 28 65 78 69 74 20 31 29 29 0a 09 09 20 20 20 28 (exit 1))... (
2da0: 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 70 2d 64 common:cleanup-d
2db0: 62 20 64 62 73 74 72 75 63 74 29 29 29 0a 09 09 b dbstruct)))...
2dc0: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu
2dd0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
2de0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 74 lt-log-port* " t
2df0: 6f 20 73 77 69 74 63 68 20 76 65 72 73 69 6f 6e o switch version
2e00: 73 20 79 6f 75 20 63 61 6e 20 72 75 6e 3a 20 5c s you can run: \
2e10: 22 6d 65 67 61 74 65 73 74 20 2d 63 6c 65 61 6e "megatest -clean
2e20: 75 70 2d 64 62 5c 22 22 29 0a 09 09 20 20 28 65 up-db\"")... (e
2e30: 78 69 74 20 31 29 29 29 29 0a 09 20 20 28 62 65 xit 1)))).. (be
2e40: 67 69 6e 0a 09 20 20 20 20 28 64 65 62 75 67 3a gin.. (debug:
2e50: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
2e60: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f -log-port* "ERRO
2e70: 52 3a 20 63 61 6e 6e 6f 74 20 6d 69 67 72 61 74 R: cannot migrat
2e80: 65 20 76 65 72 73 69 6f 6e 20 75 6e 6c 65 73 73 e version unless
2e90: 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 2e 20 45 78 on homehost. Ex
2ea0: 69 74 69 6e 67 2e 22 29 0a 09 20 20 20 20 28 65 iting.").. (e
2eb0: 78 69 74 20 31 29 29 29 29 29 0a 0a 3b 3b 3d 3d xit 1)))))..;;==
2ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f00: 3d 3d 3d 3d 0a 3b 3b 20 53 20 50 20 41 20 52 20 ====.;; S P A R
2f10: 53 20 45 20 20 20 41 20 52 20 52 20 41 20 59 20 S E A R R A Y
2f20: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
2f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
2f70: 69 6e 65 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 ine (make-sparse
2f80: 2d 61 72 72 61 79 29 0a 20 20 28 6c 65 74 20 28 -array). (let (
2f90: 28 61 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d (a (make-sparse-
2fa0: 76 65 63 74 6f 72 29 29 29 0a 20 20 20 20 28 73 vector))). (s
2fb0: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 parse-vector-set
2fc0: 21 20 61 20 30 20 28 6d 61 6b 65 2d 73 70 61 72 ! a 0 (make-spar
2fd0: 73 65 2d 76 65 63 74 6f 72 29 29 0a 20 20 20 20 se-vector)).
2fe0: 61 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 a))..(define (sp
2ff0: 61 72 73 65 2d 61 72 72 61 79 3f 20 61 29 0a 20 arse-array? a).
3000: 20 28 61 6e 64 20 28 73 70 61 72 73 65 2d 76 65 (and (sparse-ve
3010: 63 74 6f 72 3f 20 61 29 0a 20 20 20 20 20 20 20 ctor? a).
3020: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 3f 20 (sparse-vector?
3030: 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 (sparse-vector-r
3040: 65 66 20 61 20 30 29 29 29 29 0a 0a 28 64 65 66 ef a 0))))..(def
3050: 69 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 ine (sparse-arra
3060: 79 2d 72 65 66 20 61 20 78 20 79 29 0a 20 20 28 y-ref a x y). (
3070: 6c 65 74 20 28 28 72 6f 77 20 28 73 70 61 72 73 let ((row (spars
3080: 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 78 e-vector-ref a x
3090: 29 29 29 0a 20 20 20 20 28 69 66 20 72 6f 77 0a ))). (if row.
30a0: 09 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d .(sparse-vector-
30b0: 72 65 66 20 72 6f 77 20 79 29 0a 09 23 66 29 29 ref row y)..#f))
30c0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 61 72 )..(define (spar
30d0: 73 65 2d 61 72 72 61 79 2d 73 65 74 21 20 61 20 se-array-set! a
30e0: 78 20 79 20 76 61 6c 29 0a 20 20 28 6c 65 74 20 x y val). (let
30f0: 28 28 72 6f 77 20 28 73 70 61 72 73 65 2d 76 65 ((row (sparse-ve
3100: 63 74 6f 72 2d 72 65 66 20 61 20 78 29 29 29 0a ctor-ref a x))).
3110: 20 20 20 20 28 69 66 20 72 6f 77 0a 09 28 73 70 (if row..(sp
3120: 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 arse-vector-set!
3130: 20 72 6f 77 20 79 20 76 61 6c 29 0a 09 28 6c 65 row y val)..(le
3140: 74 20 28 28 6e 65 77 2d 72 6f 77 20 28 6d 61 6b t ((new-row (mak
3150: 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 e-sparse-vector)
3160: 29 29 0a 09 20 20 28 73 70 61 72 73 65 2d 76 65 )).. (sparse-ve
3170: 63 74 6f 72 2d 73 65 74 21 20 61 20 78 20 6e 65 ctor-set! a x ne
3180: 77 2d 72 6f 77 29 0a 09 20 20 28 73 70 61 72 73 w-row).. (spars
3190: 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 6e 65 e-vector-set! ne
31a0: 77 2d 72 6f 77 20 79 20 76 61 6c 29 29 29 29 29 w-row y val)))))
31b0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
31c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c 20 ==========.;; L
3200: 4f 20 43 20 4b 20 45 20 52 20 53 20 20 20 41 20 O C K E R S A
3210: 4e 20 44 20 20 20 42 20 4c 20 4f 20 43 20 4b 20 N D B L O C K
3220: 45 20 52 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d E R S .;;=======
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 0a ===============.
3270: 0a 3b 3b 20 62 6c 6f 63 6b 20 66 75 72 74 68 65 .;; block furthe
3280: 72 20 61 63 63 65 73 73 65 73 20 74 6f 20 64 61 r accesses to da
3290: 74 61 62 61 73 65 73 2e 20 43 61 6c 6c 20 74 68 tabases. Call th
32a0: 69 73 20 62 65 66 6f 72 65 20 73 68 75 74 74 69 is before shutti
32b0: 6e 67 20 64 62 20 64 6f 77 6e 0a 28 64 65 66 69 ng db down.(defi
32c0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 2d 62 6c ne (common:db-bl
32d0: 6f 63 6b 2d 66 75 72 74 68 65 72 2d 71 75 65 72 ock-further-quer
32e0: 69 65 73 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f ies). (mutex-lo
32f0: 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d ck! *db-access-m
3300: 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a utex*). (set! *
3310: 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 db-access-allowe
3320: 64 2a 20 23 66 29 0a 20 20 28 6d 75 74 65 78 2d d* #f). (mutex-
3330: 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 unlock! *db-acce
3340: 73 73 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 ss-mutex*))..(de
3350: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 2d fine (common:db-
3360: 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 3f 29 access-allowed?)
3370: 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 62 . (let ((val (b
3380: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 6d 75 egin.. (mu
3390: 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 tex-lock! *db-ac
33a0: 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a 09 20 20 cess-mutex*)..
33b0: 20 20 20 20 20 2a 64 62 2d 61 63 63 65 73 73 2d *db-access-
33c0: 61 6c 6c 6f 77 65 64 2a 0a 09 20 20 20 20 20 20 allowed*..
33d0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
33e0: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
33f0: 2a 29 29 29 29 0a 20 20 20 20 76 61 6c 29 29 0a *)))). val)).
3400: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 55 20 53 =========.;; U S
3450: 20 45 20 46 20 55 20 4c 20 20 20 53 20 54 20 55 E F U L S T U
3460: 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d F F.;;=========
3470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
34b0: 3b 20 63 6f 6e 76 65 72 74 20 74 68 69 6e 67 73 ; convert things
34c0: 20 74 6f 20 61 6e 20 61 6c 69 73 74 20 6f 72 20 to an alist or
34d0: 61 73 73 6f 63 20 6c 69 73 74 2c 20 23 66 20 67 assoc list, #f g
34e0: 65 74 73 20 63 6f 6e 76 65 72 74 65 64 20 74 6f ets converted to
34f0: 20 22 22 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 "".;;.(define (
3500: 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 common:to-alist
3510: 64 61 74 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 dat). (cond.
3520: 28 28 6c 69 73 74 3f 20 64 61 74 29 20 20 20 28 ((list? dat) (
3530: 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c map common:to-al
3540: 69 73 74 20 64 61 74 29 29 0a 20 20 20 28 28 76 ist dat)). ((v
3550: 65 63 74 6f 72 3f 20 64 61 74 29 0a 20 20 20 20 ector? dat).
3560: 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 (map common:to-a
3570: 6c 69 73 74 20 28 76 65 63 74 6f 72 2d 3e 6c 69 list (vector->li
3580: 73 74 20 64 61 74 29 29 29 0a 20 20 20 28 28 70 st dat))). ((p
3590: 61 69 72 3f 20 64 61 74 29 0a 20 20 20 20 28 63 air? dat). (c
35a0: 6f 6e 73 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 ons (common:to-a
35b0: 6c 69 73 74 20 28 63 61 72 20 64 61 74 29 29 0a list (car dat)).
35c0: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c . (common:to-al
35d0: 69 73 74 20 28 63 64 72 20 64 61 74 29 29 29 29 ist (cdr dat))))
35e0: 0a 20 20 20 28 28 68 61 73 68 2d 74 61 62 6c 65 . ((hash-table
35f0: 3f 20 64 61 74 29 0a 20 20 20 20 28 6d 61 70 20 ? dat). (map
3600: 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 common:to-alist
3610: 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 (hash-table->ali
3620: 73 74 20 64 61 74 29 29 29 0a 20 20 20 28 65 6c st dat))). (el
3630: 73 65 0a 20 20 20 20 28 69 66 20 64 61 74 0a 09 se. (if dat..
3640: 64 61 74 0a 09 22 22 29 29 29 29 0a 0a 28 64 65 dat..""))))..(de
3650: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 fine (common:low
3660: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 77 61 69 -noise-print wai
3670: 74 76 61 6c 20 2e 20 6b 65 79 73 29 0a 20 20 28 tval . keys). (
3680: 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 20 20 let* ((key
3690: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
36a0: 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 6b 65 rse (map conc ke
36b0: 79 73 29 20 22 2d 22 20 29 29 0a 09 20 28 6c 61 ys) "-" )).. (la
36c0: 73 74 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 sttime (hash-tab
36d0: 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a le-ref/default *
36e0: 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 common:denoise*
36f0: 6b 65 79 20 30 29 29 0a 09 20 28 63 75 72 72 74 key 0)).. (currt
3700: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
3710: 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 69 66 20 onds))). (if
3720: 28 3e 20 28 2d 20 63 75 72 72 74 69 6d 65 20 6c (> (- currtime l
3730: 61 73 74 74 69 6d 65 29 20 77 61 69 74 76 61 6c asttime) waitval
3740: 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 68 61 )..(begin.. (ha
3750: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 63 sh-table-set! *c
3760: 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 6b ommon:denoise* k
3770: 65 79 20 63 75 72 72 74 69 6d 65 29 0a 09 20 20 ey currtime)..
3780: 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 #t)..#f)))..(def
3790: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
37a0: 6d 65 67 61 74 65 73 74 2d 65 78 65 29 0a 20 20 megatest-exe).
37b0: 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d 54 5f (or (getenv "MT_
37c0: 4d 45 47 41 54 45 53 54 22 29 20 22 6d 65 67 61 MEGATEST") "mega
37d0: 74 65 73 74 22 29 29 0a 0a 28 64 65 66 69 6e 65 test"))..(define
37e0: 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 65 6e (common:read-en
37f0: 63 6f 64 65 64 2d 73 74 72 69 6e 67 20 69 6e 73 coded-string ins
3800: 74 72 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 tr). (handle-ex
3810: 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a ceptions. exn.
3820: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
3830: 74 69 6f 6e 73 0a 20 20 20 20 65 78 6e 0a 20 20 tions. exn.
3840: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 28 (begin. (
3850: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
3860: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
3870: 2d 70 6f 72 74 2a 20 22 72 65 63 65 69 76 65 64 -port* "received
3880: 20 62 61 64 20 65 6e 63 6f 64 65 64 20 73 74 72 bad encoded str
3890: 69 6e 67 20 5c 22 22 20 69 6e 73 74 72 20 22 5c ing \"" instr "\
38a0: 22 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 ", message: " ((
38b0: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
38c0: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
38d0: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
38e0: 0a 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 . (print-ca
38f0: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
3900: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 t-error-port)).
3910: 20 20 20 20 20 23 66 29 0a 20 20 20 20 28 72 65 #f). (re
3920: 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 ad (open-input-s
3930: 74 72 69 6e 67 20 28 62 61 73 65 36 34 3a 62 61 tring (base64:ba
3940: 73 65 36 34 2d 64 65 63 6f 64 65 20 69 6e 73 74 se64-decode inst
3950: 72 29 29 29 29 0a 20 20 20 28 72 65 61 64 20 28 r)))). (read (
3960: 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 6e open-input-strin
3970: 67 20 28 7a 33 3a 64 65 63 6f 64 65 2d 62 75 66 g (z3:decode-buf
3980: 66 65 72 20 28 62 61 73 65 36 34 3a 62 61 73 65 fer (base64:base
3990: 36 34 2d 64 65 63 6f 64 65 20 69 6e 73 74 72 29 64-decode instr)
39a0: 29 29 29 29 29 0a 0a 3b 3b 20 64 6f 74 2d 6c 6f )))))..;; dot-lo
39b0: 63 6b 69 6e 67 20 65 67 67 20 73 65 65 6d 73 20 cking egg seems
39c0: 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c 20 75 73 69 not to work, usi
39d0: 6e 67 20 74 68 69 73 20 66 6f 72 20 6e 6f 77 0a ng this for now.
39e0: 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 73 20 6f 6c ;; if lock is ol
39f0: 64 65 72 20 74 68 61 6e 20 65 78 70 69 72 65 2d der than expire-
3a00: 74 69 6d 65 20 74 68 65 6e 20 72 65 6d 6f 76 65 time then remove
3a10: 20 69 74 20 61 6e 64 20 74 72 79 20 61 67 61 69 it and try agai
3a20: 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 74 68 65 20 n.;; to get the
3a30: 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 lock.;;.(define
3a40: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
3a50: 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 23 ile-lock fname #
3a60: 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 6d !key (expire-tim
3a70: 65 20 33 30 30 29 29 0a 20 20 28 69 66 20 28 66 e 300)). (if (f
3a80: 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d ile-exists? fnam
3a90: 65 29 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 e). (if (>
3aa0: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
3ab0: 6e 64 73 29 28 66 69 6c 65 2d 6d 6f 64 69 66 69 nds)(file-modifi
3ac0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 6e 61 6d cation-time fnam
3ad0: 65 29 29 20 65 78 70 69 72 65 2d 74 69 6d 65 29 e)) expire-time)
3ae0: 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 .. (begin..
3af0: 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e (delete-file* fn
3b00: 61 6d 65 29 0a 09 20 20 20 20 28 63 6f 6d 6d 6f ame).. (commo
3b10: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f n:simple-file-lo
3b20: 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d ck fname expire-
3b30: 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d time: expire-tim
3b40: 65 29 29 0a 09 20 20 23 66 29 0a 20 20 20 20 20 e)).. #f).
3b50: 20 28 6c 65 74 20 28 28 6b 65 79 2d 73 74 72 69 (let ((key-stri
3b60: 6e 67 20 28 63 6f 6e 63 20 28 67 65 74 2d 68 6f ng (conc (get-ho
3b70: 73 74 2d 6e 61 6d 65 29 20 22 2d 22 20 28 63 75 st-name) "-" (cu
3b80: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
3b90: 29 29 29 29 0a 09 28 77 69 74 68 2d 6f 75 74 70 ))))..(with-outp
3ba0: 75 74 2d 74 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 ut-to-file fname
3bb0: 0a 09 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 .. (lambda ()..
3bc0: 20 20 20 20 28 70 72 69 6e 74 20 6b 65 79 2d 73 (print key-s
3bd0: 74 72 69 6e 67 29 29 29 0a 09 28 74 68 72 65 61 tring)))..(threa
3be0: 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 29 0a 09 d-sleep! 0.25)..
3bf0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
3c00: 3f 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 28 77 ? fname).. (w
3c10: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
3c20: 69 6c 65 20 66 6e 61 6d 65 0a 09 20 20 20 20 20 ile fname..
3c30: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 28 65 (lambda ()...(e
3c40: 71 75 61 6c 3f 20 6b 65 79 2d 73 74 72 69 6e 67 qual? key-string
3c50: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 0a (read-line)))).
3c60: 09 20 20 20 20 23 66 29 29 29 29 0a 09 0a 28 64 . #f))))...(d
3c70: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 efine (common:si
3c80: 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 mple-file-releas
3c90: 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 29 0a 20 20 e-lock fname).
3ca0: 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e (delete-file* fn
3cb0: 61 6d 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ame))..;;=======
3cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3d00: 3b 3b 20 53 20 54 20 41 20 54 20 45 20 53 20 20 ;; S T A T E S
3d10: 20 41 20 4e 20 44 20 20 20 53 20 54 20 41 20 54 A N D S T A T
3d20: 20 55 20 53 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d U S E S.;;=====
3d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d70: 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d =..(define *comm
3d80: 6f 6e 3a 73 74 64 2d 73 74 61 74 65 73 2a 20 20 on:std-states*
3d90: 20 0a 20 20 27 28 28 30 20 22 41 52 43 48 49 56 . '((0 "ARCHIV
3da0: 45 44 22 29 0a 20 20 20 20 28 31 20 22 53 54 55 ED"). (1 "STU
3db0: 43 4b 22 29 0a 20 20 20 20 28 32 20 22 4b 49 4c CK"). (2 "KIL
3dc0: 4c 52 45 51 22 29 0a 20 20 20 20 28 33 20 22 4b LREQ"). (3 "K
3dd0: 49 4c 4c 45 44 22 29 0a 20 20 20 20 28 34 20 22 ILLED"). (4 "
3de0: 4e 4f 54 5f 53 54 41 52 54 45 44 22 29 0a 20 20 NOT_STARTED").
3df0: 20 20 28 35 20 22 43 4f 4d 50 4c 45 54 45 44 22 (5 "COMPLETED"
3e00: 29 0a 20 20 20 20 28 36 20 22 4c 41 55 4e 43 48 ). (6 "LAUNCH
3e10: 45 44 22 29 0a 20 20 20 20 28 37 20 22 52 45 4d ED"). (7 "REM
3e20: 4f 54 45 48 4f 53 54 53 54 41 52 54 22 29 0a 20 OTEHOSTSTART").
3e30: 20 20 20 28 38 20 22 52 55 4e 4e 49 4e 47 22 29 (8 "RUNNING")
3e40: 0a 20 20 20 20 29 29 0a 0a 28 64 65 66 69 6e 65 . ))..(define
3e50: 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 *common:std-sta
3e60: 74 75 73 65 73 2a 0a 20 20 27 28 3b 3b 20 28 30 tuses*. '(;; (0
3e70: 20 22 44 45 4c 45 54 45 44 22 29 0a 20 20 20 20 "DELETED").
3e80: 28 31 20 22 6e 2f 61 22 29 0a 20 20 20 20 28 32 (1 "n/a"). (2
3e90: 20 22 50 41 53 53 22 29 0a 20 20 20 20 28 33 20 "PASS"). (3
3ea0: 22 43 48 45 43 4b 22 29 0a 20 20 20 20 28 34 20 "CHECK"). (4
3eb0: 22 53 4b 49 50 22 29 0a 20 20 20 20 28 35 20 22 "SKIP"). (5 "
3ec0: 57 41 52 4e 22 29 0a 20 20 20 20 28 36 20 22 57 WARN"). (6 "W
3ed0: 41 49 56 45 44 22 29 0a 20 20 20 20 28 37 20 22 AIVED"). (7 "
3ee0: 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 20 20 20 STUCK/DEAD").
3ef0: 20 28 38 20 22 46 41 49 4c 22 29 0a 20 20 20 20 (8 "FAIL").
3f00: 28 39 20 22 41 42 4f 52 54 22 29 29 29 0a 0a 28 (9 "ABORT")))..(
3f10: 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 65 define *common:e
3f20: 6e 64 65 64 2d 73 74 61 74 65 73 2a 20 20 20 20 nded-states*
3f30: 20 20 20 3b 3b 20 73 74 61 74 65 73 20 77 68 69 ;; states whi
3f40: 63 68 20 69 6e 64 69 63 61 74 65 20 74 68 65 20 ch indicate the
3f50: 74 65 73 74 20 69 73 20 73 74 6f 70 70 65 64 20 test is stopped
3f60: 61 6e 64 20 77 69 6c 6c 20 6e 6f 74 20 70 72 6f and will not pro
3f70: 63 65 65 64 0a 20 20 27 28 22 43 4f 4d 50 4c 45 ceed. '("COMPLE
3f80: 54 45 44 22 20 22 41 52 43 48 49 56 45 44 22 20 TED" "ARCHIVED"
3f90: 22 4b 49 4c 4c 45 44 22 20 22 4b 49 4c 4c 52 45 "KILLED" "KILLRE
3fa0: 51 22 20 22 53 54 55 43 4b 22 20 22 49 4e 43 4f Q" "STUCK" "INCO
3fb0: 4d 50 4c 45 54 45 22 29 29 0a 0a 28 64 65 66 69 MPLETE"))..(defi
3fc0: 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 62 61 64 6c 79 ne *common:badly
3fd0: 2d 65 6e 64 65 64 2d 73 74 61 74 65 73 2a 20 3b -ended-states* ;
3fe0: 3b 20 74 68 65 73 65 20 72 6f 6c 6c 20 75 70 20 ; these roll up
3ff0: 61 73 20 43 48 45 43 4b 2c 20 69 2e 65 2e 20 72 as CHECK, i.e. r
4000: 65 73 75 6c 74 73 20 6e 65 65 64 20 74 6f 20 62 esults need to b
4010: 65 20 63 68 65 63 6b 65 64 0a 20 20 27 28 22 4b e checked. '("K
4020: 49 4c 4c 45 44 22 20 22 4b 49 4c 4c 52 45 51 22 ILLED" "KILLREQ"
4030: 20 22 53 54 55 43 4b 22 20 22 49 4e 43 4f 4d 50 "STUCK" "INCOMP
4040: 4c 45 54 45 22 20 22 44 45 41 44 22 29 29 0a 0a LETE" "DEAD"))..
4050: 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a (define *common:
4060: 72 75 6e 6e 69 6e 67 2d 73 74 61 74 65 73 2a 20 running-states*
4070: 20 20 20 20 3b 3b 20 74 65 73 74 20 69 73 20 65 ;; test is e
4080: 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f 72 ither running or
4090: 20 63 61 6e 20 62 65 20 72 75 6e 0a 20 20 27 28 can be run. '(
40a0: 22 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 "RUNNING" "REMOT
40b0: 45 48 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 EHOSTSTART" "LAU
40c0: 4e 43 48 45 44 22 29 29 0a 0a 28 64 65 66 69 6e NCHED"))..(defin
40d0: 65 20 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 e *common:cant-r
40e0: 75 6e 2d 73 74 61 74 65 73 2a 20 20 20 20 3b 3b un-states* ;;
40f0: 20 54 68 65 73 65 20 61 72 65 20 73 74 6f 70 70 These are stopp
4100: 69 6e 67 20 63 6f 6e 64 69 74 69 6f 6e 73 20 74 ing conditions t
4110: 68 61 74 20 70 72 65 76 65 6e 74 20 61 20 74 65 hat prevent a te
4120: 73 74 20 66 72 6f 6d 20 62 65 69 6e 67 20 72 75 st from being ru
4130: 6e 0a 20 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 n. '("COMPLETED
4140: 22 20 22 4b 49 4c 4c 45 44 22 20 22 55 4e 4b 4e " "KILLED" "UNKN
4150: 4f 57 4e 22 20 22 49 4e 43 4f 4d 50 4c 45 54 45 OWN" "INCOMPLETE
4160: 22 20 22 41 52 43 48 49 56 45 44 22 29 29 0a 0a " "ARCHIVED"))..
4170: 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a (define *common:
4180: 6e 6f 74 2d 73 74 61 72 74 65 64 2d 6f 6b 2d 73 not-started-ok-s
4190: 74 61 74 75 73 65 73 2a 20 3b 3b 20 69 66 20 6e tatuses* ;; if n
41a0: 6f 74 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 ot one of these
41b0: 73 74 61 74 75 73 65 73 20 77 68 65 6e 20 69 6e statuses when in
41c0: 20 6e 6f 74 5f 73 74 61 72 74 65 64 20 73 74 61 not_started sta
41d0: 74 65 20 74 72 65 61 74 20 61 73 20 64 65 61 64 te treat as dead
41e0: 0a 20 20 27 28 22 6e 2f 61 22 20 22 6e 61 22 20 . '("n/a" "na"
41f0: 22 50 41 53 53 22 20 22 46 41 49 4c 22 20 22 57 "PASS" "FAIL" "W
4200: 41 52 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 ARN" "CHECK" "WA
4210: 49 56 45 44 22 20 22 44 45 41 44 22 20 22 53 4b IVED" "DEAD" "SK
4220: 49 50 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 IP"))..(define (
4230: 63 6f 6d 6d 6f 6e 3a 73 70 65 63 69 61 6c 2d 73 common:special-s
4240: 6f 72 74 20 69 74 65 6d 73 20 6f 72 64 65 72 20 ort items order
4250: 63 6f 6d 70 29 0a 20 20 28 6c 65 74 20 28 28 69 comp). (let ((i
4260: 74 65 6d 73 2d 6f 72 64 65 72 20 28 6d 61 70 20 tems-order (map
4270: 72 65 76 65 72 73 65 20 6f 72 64 65 72 29 29 0a reverse order)).
4280: 20 20 20 20 20 20 20 20 28 61 63 6f 6d 70 20 20 (acomp
4290: 20 20 20 20 20 28 6f 72 20 63 6f 6d 70 20 3e 29 (or comp >)
42a0: 29 29 0a 20 20 20 20 28 73 6f 72 74 20 69 74 65 )). (sort ite
42b0: 6d 73 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 ms. (lamb
42c0: 64 61 20 28 61 20 62 29 0a 20 20 20 20 20 20 20 da (a b).
42d0: 20 20 20 28 6c 65 74 20 28 28 61 2d 6e 75 6d 20 (let ((a-num
42e0: 28 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f 63 (cadr (or (assoc
42f0: 20 61 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 20 a items-order)
4300: 27 28 30 20 30 29 29 29 29 0a 20 20 20 20 20 20 '(0 0)))).
4310: 20 20 20 20 20 20 20 20 20 20 28 62 2d 6e 75 6d (b-num
4320: 20 28 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f (cadr (or (asso
4330: 63 20 62 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 c b items-order)
4340: 20 27 28 30 20 30 29 29 29 29 29 0a 20 20 20 20 '(0 0))))).
4350: 20 20 20 20 20 20 20 20 28 61 63 6f 6d 70 20 61 (acomp a
4360: 2d 6e 75 6d 20 62 2d 6e 75 6d 29 29 29 29 29 29 -num b-num))))))
4370: 0a 0a 3b 3b 20 3b 3b 20 67 69 76 65 6e 20 61 20 ..;; ;; given a
4380: 74 6f 70 6c 65 76 65 6c 20 77 69 74 68 20 63 75 toplevel with cu
4390: 72 72 73 74 61 74 65 2c 20 63 75 72 72 73 74 61 rrstate, currsta
43a0: 74 75 73 20 61 70 70 6c 79 20 73 74 61 74 65 20 tus apply state
43b0: 61 6e 64 20 73 74 61 74 75 73 0a 3b 3b 20 3b 3b and status.;; ;;
43c0: 20 20 3d 3e 20 28 6e 65 77 73 74 61 74 65 20 2e => (newstate .
43d0: 20 6e 65 77 73 74 61 74 75 73 29 0a 3b 3b 20 28 newstatus).;; (
43e0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 define (common:a
43f0: 70 70 6c 79 2d 73 74 61 74 65 2d 73 74 61 74 75 pply-state-statu
4400: 73 20 63 75 72 72 73 74 61 74 65 20 63 75 72 72 s currstate curr
4410: 73 74 61 74 75 73 20 73 74 61 74 65 20 73 74 61 status state sta
4420: 74 75 73 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 tus).;; (let*
4430: 28 28 63 73 74 61 74 65 20 20 28 73 74 72 69 6e ((cstate (strin
4440: 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e g->symbol (strin
4450: 67 2d 64 6f 77 6e 63 61 73 65 20 63 75 72 72 73 g-downcase currs
4460: 74 61 74 65 29 29 29 0a 3b 3b 20 20 20 20 20 20 tate))).;;
4470: 20 20 20 20 28 63 73 74 61 74 75 73 20 28 73 74 (cstatus (st
4480: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 ring->symbol (st
4490: 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 63 75 ring-downcase cu
44a0: 72 72 73 74 61 74 75 73 29 29 29 0a 3b 3b 20 20 rrstatus))).;;
44b0: 20 20 20 20 20 20 20 20 28 73 73 74 61 74 65 20 (sstate
44c0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
44d0: 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 (string-downcas
44e0: 65 20 73 74 61 74 65 29 29 29 0a 3b 3b 20 20 20 e state))).;;
44f0: 20 20 20 20 20 20 20 28 73 73 74 61 74 75 73 20 (sstatus
4500: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
4510: 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 (string-downcase
4520: 20 73 74 61 74 75 73 29 29 29 0a 3b 3b 20 20 20 status))).;;
4530: 20 20 20 20 20 20 20 28 6e 73 74 61 74 65 20 20 (nstate
4540: 23 66 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 #f).;;
4550: 28 6e 73 74 61 74 75 73 20 23 66 29 29 0a 3b 3b (nstatus #f)).;;
4560: 20 20 20 20 20 28 73 65 74 21 20 6e 73 74 61 74 (set! nstat
4570: 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 e.;; (
4580: 63 61 73 65 20 63 73 74 61 74 65 0a 3b 3b 20 20 case cstate.;;
4590: 20 20 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d ((com
45a0: 70 6c 65 74 65 64 20 6e 6f 74 5f 73 74 61 72 74 pleted not_start
45b0: 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 ed killed killre
45c0: 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 65 64 q stuck archived
45d0: 29 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ) .;;
45e0: 20 20 20 28 63 61 73 65 20 73 73 74 61 74 65 20 (case sstate
45f0: 3b 3b 20 63 6f 6d 70 6c 65 74 65 64 20 2d 3e 20 ;; completed ->
4600: 73 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 sstate.;;
4610: 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c ((compl
4620: 65 74 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c eted killed kill
4630: 72 65 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 req stuck archiv
4640: 65 64 29 20 63 6f 6d 70 6c 65 74 65 64 29 0a 3b ed) completed).;
4650: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4660: 20 28 28 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 ((running remot
4670: 65 68 6f 73 74 73 74 61 72 74 20 6c 61 75 6e 63 ehoststart launc
4680: 68 65 64 29 20 20 20 20 20 20 20 20 72 75 6e 6e hed) runn
4690: 69 6e 67 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ing).;;
46a0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
46b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
46d0: 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d unknown-error-
46e0: 31 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 1))).;;
46f0: 20 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 65 ((running re
4700: 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 20 6c 61 motehoststart la
4710: 75 6e 63 68 65 64 29 0a 3b 3b 20 20 20 20 20 20 unched).;;
4720: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 73 73 (case ss
4730: 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 tate.;;
4740: 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c 65 74 ((complet
4750: 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 ed killed killre
4760: 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 65 64 q stuck archived
4770: 29 20 23 66 29 20 3b 3b 20 6e 65 65 64 20 74 6f ) #f) ;; need to
4780: 20 6c 6f 6f 6b 20 61 74 20 61 6c 6c 20 69 74 65 look at all ite
4790: 6d 73 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 ms.;;
47a0: 20 20 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 ((running r
47b0: 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 20 6c emotehoststart l
47c0: 61 75 6e 63 68 65 64 29 20 20 20 20 20 20 20 20 aunched)
47d0: 72 75 6e 6e 69 6e 67 29 0a 3b 3b 20 20 20 20 20 running).;;
47e0: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
47f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4810: 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 unknown-er
4820: 72 6f 72 2d 32 29 29 29 0a 3b 3b 20 20 20 20 20 ror-2))).;;
4830: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 75 6e (else un
4840: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 33 29 29 29 known-error-3)))
4850: 0a 3b 3b 20 20 20 20 20 28 73 65 74 21 20 6e 73 .;; (set! ns
4860: 74 61 74 75 73 0a 3b 3b 20 20 20 20 20 20 20 20 tatus.;;
4870: 20 20 20 28 63 61 73 65 20 73 73 74 61 74 75 73 (case sstatus
4880: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4890: 28 28 70 61 73 73 29 0a 3b 3b 20 20 20 20 20 20 ((pass).;;
48a0: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 (case ns
48b0: 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 tate.;;
48c0: 20 20 20 20 20 20 20 28 28 70 61 73 73 20 6e 2f ((pass n/
48d0: 61 20 64 65 6c 65 74 65 64 29 20 20 20 20 20 70 a deleted) p
48e0: 61 73 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ass).;;
48f0: 20 20 20 20 20 20 20 28 28 77 61 72 6e 29 20 20 ((warn)
4900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 77 w
4910: 61 72 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 arn).;;
4920: 20 20 20 20 20 20 20 28 28 66 61 69 6c 29 20 20 ((fail)
4930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66 f
4940: 61 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ail).;;
4950: 20 20 20 20 20 20 20 28 28 63 68 65 63 6b 29 20 ((check)
4960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 63 68 ch
4970: 65 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 eck).;;
4980: 20 20 20 20 20 20 20 28 28 77 61 69 76 65 64 29 ((waived)
4990: 20 20 20 20 20 20 20 20 20 20 20 20 20 77 61 69 wai
49a0: 76 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ved).;;
49b0: 20 20 20 20 20 20 20 28 28 73 6b 69 70 29 20 20 ((skip)
49c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 73 s
49d0: 6b 69 70 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 kip).;;
49e0: 20 20 20 20 20 20 20 28 28 73 74 75 63 6b 2f 64 ((stuck/d
49f0: 65 61 64 29 20 20 20 20 20 20 20 20 20 20 73 74 ead) st
4a00: 75 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 uck).;;
4a10: 20 20 20 20 20 20 20 28 28 61 62 6f 72 74 29 20 ((abort)
4a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 62 ab
4a30: 6f 72 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ort).;;
4a40: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
4a50: 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f unknown-erro
4a60: 72 2d 34 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 r-4))).;;
4a70: 20 20 20 20 20 20 28 28 77 61 72 6e 29 0a 3b 3b ((warn).;;
4a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
4a90: 61 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 ase nstate.;;
4aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 ((p
4ab0: 61 73 73 20 77 61 72 6e 20 6e 2f 61 20 73 6b 69 ass warn n/a ski
4ac0: 70 20 64 65 6c 65 74 65 64 29 20 20 20 77 61 72 p deleted) war
4ad0: 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 n).;;
4ae0: 20 20 20 20 20 28 28 66 61 69 6c 29 20 20 20 20 ((fail)
4af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b00: 20 20 20 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 fail).;;
4b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 ((c
4b20: 68 65 63 6b 29 20 20 20 20 20 20 20 20 20 20 20 heck)
4b30: 20 20 20 20 20 20 20 20 20 20 20 20 63 68 65 63 chec
4b40: 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 k).;;
4b50: 20 20 20 20 20 28 28 77 61 69 76 65 64 29 20 20 ((waived)
4b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b70: 20 20 20 77 61 69 76 65 64 29 0a 3b 3b 20 20 20 waived).;;
4b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 ((s
4b90: 74 75 63 6b 2f 64 65 61 64 29 20 20 20 20 20 20 tuck/dead)
4ba0: 20 20 20 20 20 20 20 20 20 20 20 20 73 74 75 63 stuc
4bb0: 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 k).;;
4bc0: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
4bd0: 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 unknow
4be0: 6e 2d 65 72 72 6f 72 2d 35 29 29 29 0a 3b 3b 20 n-error-5))).;;
4bf0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 66 61 ((fa
4c00: 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 il).;;
4c10: 20 20 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 (case nstate
4c20: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4c30: 20 20 20 28 28 70 61 73 73 20 77 61 72 6e 20 66 ((pass warn f
4c40: 61 69 6c 20 63 68 65 63 6b 20 6e 2f 61 20 77 61 ail check n/a wa
4c50: 69 76 65 64 20 73 6b 69 70 20 64 65 6c 65 74 65 ived skip delete
4c60: 64 20 73 74 75 63 6b 2f 64 65 61 64 20 73 74 75 d stuck/dead stu
4c70: 63 6b 29 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 ck) fail).;;
4c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 ((a
4c90: 62 6f 72 74 29 20 20 20 20 20 20 20 20 20 20 20 bort)
4ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 61 62 ab
4cd0: 6f 72 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 ort).;;
4ce0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 (else
4cf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 75 6e un
4d20: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 36 29 29 29 known-error-6)))
4d30: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4d40: 28 65 6c 73 65 20 20 20 20 75 6e 6b 6e 6f 77 6e (else unknown
4d50: 2d 65 72 72 6f 72 2d 37 29 29 29 0a 3b 3b 20 20 -error-7))).;;
4d60: 20 20 20 28 63 6f 6e 73 20 0a 3b 3b 20 20 20 20 (cons .;;
4d70: 20 20 28 69 66 20 6e 73 74 61 74 65 20 20 28 73 (if nstate (s
4d80: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 73 ymbol->string ns
4d90: 74 61 74 65 29 20 20 6e 73 74 61 74 65 29 0a 3b tate) nstate).;
4da0: 3b 20 20 20 20 20 20 28 69 66 20 6e 73 74 61 74 ; (if nstat
4db0: 75 73 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 us (symbol->stri
4dc0: 6e 67 20 6e 73 74 61 74 75 73 29 20 6e 73 74 61 ng nstatus) nsta
4dd0: 74 75 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 tus)))).
4de0: 20 20 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d .;;======
4df0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e30: 0a 3b 3b 20 44 20 45 20 42 20 55 20 47 20 47 20 .;; D E B U G G
4e40: 49 20 4e 20 47 20 20 20 53 20 54 20 55 20 46 20 I N G S T U F
4e50: 46 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F .;;===========
4e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
4ea0: 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 2a fine *verbosity*
4eb0: 20 20 20 20 20 20 20 20 20 31 29 0a 28 64 65 66 1).(def
4ec0: 69 6e 65 20 2a 6c 6f 67 67 69 6e 67 2a 20 20 20 ine *logging*
4ed0: 20 20 20 20 20 20 20 20 23 66 29 0a 0a 28 64 65 #f)..(de
4ee0: 66 69 6e 65 20 28 67 65 74 2d 77 69 74 68 2d 64 fine (get-with-d
4ef0: 65 66 61 75 6c 74 20 76 61 6c 20 64 65 66 61 75 efault val defau
4f00: 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c lt). (let ((val
4f10: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 76 (args:get-arg v
4f20: 61 6c 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 al))). (if va
4f30: 6c 20 76 61 6c 20 64 65 66 61 75 6c 74 29 29 29 l val default)))
4f40: 0a 0a 28 64 65 66 69 6e 65 20 28 61 73 73 6f 63 ..(define (assoc
4f50: 2f 64 65 66 61 75 6c 74 20 6b 65 79 20 6c 73 74 /default key lst
4f60: 20 2e 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c . default). (l
4f70: 65 74 20 28 28 72 65 73 20 28 61 73 73 6f 63 20 et ((res (assoc
4f80: 6b 65 79 20 6c 73 74 29 29 29 0a 20 20 20 20 28 key lst))). (
4f90: 69 66 20 72 65 73 20 28 63 61 64 72 20 72 65 73 if res (cadr res
4fa0: 29 28 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 )(if (null? defa
4fb0: 75 6c 74 29 20 23 66 20 28 63 61 72 20 64 65 66 ult) #f (car def
4fc0: 61 75 6c 74 29 29 29 29 29 0a 0a 28 64 65 66 69 ault)))))..(defi
4fd0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 ne (common:get-t
4fe0: 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a 20 estsuite-name).
4ff0: 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (or (configf:lo
5000: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
5010: 20 22 73 65 74 75 70 22 20 22 74 65 73 74 73 75 "setup" "testsu
5020: 69 74 65 22 20 29 0a 20 20 20 20 20 20 28 69 66 ite" ). (if
5030: 20 2a 74 6f 70 70 61 74 68 2a 20 0a 20 20 20 20 *toppath* .
5040: 20 20 20 20 20 20 28 70 61 74 68 6e 61 6d 65 2d (pathname-
5050: 66 69 6c 65 20 2a 74 6f 70 70 61 74 68 2a 29 0a file *toppath*).
5060: 20 20 20 20 20 20 20 20 20 20 28 70 61 74 68 6e (pathn
5070: 61 6d 65 2d 66 69 6c 65 20 28 63 75 72 72 65 6e ame-file (curren
5080: 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 29 29 t-directory)))))
5090: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
50a0: 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 n:get-db-tmp-are
50b0: 61 29 0a 20 20 28 69 66 20 2a 64 62 2d 63 61 63 a). (if *db-cac
50c0: 68 65 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 2a he-path*. *
50d0: 64 62 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 db-cache-path*.
50e0: 20 20 20 20 20 28 6c 65 74 20 28 28 64 62 70 61 (let ((dbpa
50f0: 74 68 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 th (create-direc
5100: 74 6f 72 79 20 28 63 6f 6e 63 20 22 2f 74 6d 70 tory (conc "/tmp
5110: 2f 22 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 /" (current-user
5120: 2d 6e 61 6d 65 29 0a 09 09 09 09 09 20 20 20 20 -name)......
5130: 22 2f 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c "/megatest_local
5140: 64 62 2f 22 0a 09 09 09 09 09 20 20 20 20 28 63 db/"...... (c
5150: 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 ommon:get-testsu
5160: 69 74 65 2d 6e 61 6d 65 29 20 22 2f 22 0a 09 09 ite-name) "/"...
5170: 09 09 09 20 20 20 20 28 73 74 72 69 6e 67 2d 74 ... (string-t
5180: 72 61 6e 73 6c 61 74 65 20 2a 74 6f 70 70 61 74 ranslate *toppat
5190: 68 2a 20 22 2f 22 20 22 2e 22 29 29 20 23 74 29 h* "/" ".")) #t)
51a0: 29 29 0a 09 28 73 65 74 21 20 2a 64 62 2d 63 61 ))..(set! *db-ca
51b0: 63 68 65 2d 70 61 74 68 2a 20 64 62 70 61 74 68 che-path* dbpath
51c0: 29 0a 09 64 62 70 61 74 68 29 29 29 0a 0a 28 64 )..dbpath)))..(d
51d0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
51e0: 74 2d 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e t-area-path-sign
51f0: 61 74 75 72 65 29 0a 20 20 28 6d 65 73 73 61 67 ature). (messag
5200: 65 2d 64 69 67 65 73 74 2d 73 74 72 69 6e 67 20 e-digest-string
5210: 28 6d 64 35 2d 70 72 69 6d 69 74 69 76 65 29 20 (md5-primitive)
5220: 2a 74 6f 70 70 61 74 68 2a 29 29 0a 0a 3b 3b 3d *toppath*))..;;=
5230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5270: 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 58 20 49 20 54 =====.;; E X I T
5280: 20 20 20 48 20 41 20 4e 20 44 20 4c 20 49 20 4e H A N D L I N
5290: 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d G.;;===========
52a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
52e0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e fine (common:run
52f0: 2d 73 79 6e 63 3f 29 0a 20 20 20 20 28 61 6e 64 -sync?). (and
5300: 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 (common:on-home
5310: 68 6f 73 74 3f 29 0a 09 20 28 61 72 67 73 3a 67 host?).. (args:g
5320: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
5330: 29 29 29 0a 0a 3b 3b 20 20 20 28 6c 65 74 20 28 )))..;; (let (
5340: 28 6f 68 68 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d (ohh (common:on-
5350: 68 6f 6d 65 68 6f 73 74 3f 29 29 0a 3b 3b 20 09 homehost?)).;; .
5360: 28 73 72 76 20 28 61 72 67 73 3a 67 65 74 2d 61 (srv (args:get-a
5370: 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 29 0a rg "-server"))).
5380: 3b 3b 20 20 20 20 20 28 61 6e 64 20 6f 68 68 20 ;; (and ohh
5390: 73 72 76 29 29 29 0a 20 20 20 20 3b 3b 20 28 64 srv))). ;; (d
53a0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
53b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
53c0: 6f 72 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 75 6e ort* "common:run
53d0: 2d 73 79 6e 63 3f 20 6f 68 68 3d 22 20 6f 68 68 -sync? ohh=" ohh
53e0: 20 22 2c 20 73 72 76 3d 22 20 73 72 76 29 0a 0a ", srv=" srv)..
53f0: 3b 3b 3b 3b 20 72 75 6e 2d 69 64 73 0a 3b 3b 20 ;;;; run-ids.;;
5400: 20 20 20 69 66 20 23 66 20 75 73 65 20 2a 64 62 if #f use *db
5410: 2d 6c 6f 63 61 6c 2d 73 79 6e 63 2a 20 3a 20 6f -local-sync* : o
5420: 72 20 27 6c 6f 63 61 6c 2d 73 79 6e 63 2d 66 6c r 'local-sync-fl
5430: 61 67 73 0a 3b 3b 20 20 20 20 69 66 20 23 74 20 ags.;; if #t
5440: 75 73 65 20 74 69 6d 65 73 74 61 6d 70 73 20 20 use timestamps
5450: 20 20 20 20 3a 20 6f 72 20 27 74 69 6d 65 73 74 : or 'timest
5460: 61 6d 70 73 0a 28 64 65 66 69 6e 65 20 28 63 6f amps.(define (co
5470: 6d 6d 6f 6e 3a 73 79 6e 63 2d 74 6f 2d 6d 65 67 mmon:sync-to-meg
5480: 61 74 65 73 74 2e 64 62 20 64 62 73 74 72 75 63 atest.db dbstruc
5490: 74 29 20 0a 20 20 28 6c 65 74 20 28 28 73 74 61 t) . (let ((sta
54a0: 72 74 2d 74 69 6d 65 20 20 20 20 20 20 20 20 20 rt-time
54b0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
54c0: 29 29 0a 09 28 72 65 73 20 20 20 20 20 20 20 20 ))..(res
54d0: 20 20 20 20 20 20 20 20 28 64 62 3a 6d 75 6c 74 (db:mult
54e0: 69 2d 64 62 2d 73 79 6e 63 20 64 62 73 74 72 75 i-db-sync dbstru
54f0: 63 74 20 27 6e 65 77 32 6f 6c 64 29 29 29 0a 20 ct 'new2old))).
5500: 20 20 20 28 6c 65 74 20 28 28 73 79 6e 63 2d 74 (let ((sync-t
5510: 69 6d 65 20 28 2d 20 28 63 75 72 72 65 6e 74 2d ime (- (current-
5520: 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d 74 seconds) start-t
5530: 69 6d 65 29 29 29 0a 20 20 20 20 20 20 28 64 65 ime))). (de
5540: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 bug:print-info 3
5550: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5560: 72 74 2a 20 22 53 79 6e 63 20 6f 66 20 6e 65 77 rt* "Sync of new
5570: 64 62 20 74 6f 20 6f 6c 64 64 62 20 63 6f 6d 70 db to olddb comp
5580: 6c 65 74 65 64 20 69 6e 20 22 20 73 79 6e 63 2d leted in " sync-
5590: 74 69 6d 65 20 22 20 73 65 63 6f 6e 64 73 20 70 time " seconds p
55a0: 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f id="(current-pro
55b0: 63 65 73 73 2d 69 64 29 29 0a 20 20 20 20 20 20 cess-id)).
55c0: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d (if (common:low-
55d0: 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 20 22 noise-print 30 "
55e0: 73 79 6e 63 20 6e 65 77 20 74 6f 20 6f 6c 64 22 sync new to old"
55f0: 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ).. (debug:prin
5600: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5610: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 79 6e t-log-port* "Syn
5620: 63 20 6f 66 20 6e 65 77 64 62 20 74 6f 20 6f 6c c of newdb to ol
5630: 64 64 62 20 63 6f 6d 70 6c 65 74 65 64 20 69 6e ddb completed in
5640: 20 22 20 73 79 6e 63 2d 74 69 6d 65 20 22 20 73 " sync-time " s
5650: 65 63 6f 6e 64 73 20 70 69 64 3d 22 28 63 75 72 econds pid="(cur
5660: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
5670: 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a 0a 0a ))). res))...
5680: 0a 0a 28 64 65 66 69 6e 65 20 2a 77 64 6e 75 6d ..(define *wdnum
5690: 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 77 64 * 0).(define *wd
56a0: 6e 75 6d 2a 6d 75 74 65 78 20 28 6d 61 6b 65 2d num*mutex (make-
56b0: 6d 75 74 65 78 29 29 0a 3b 3b 20 63 75 72 72 65 mutex)).;; curre
56c0: 6e 74 6c 79 20 74 68 65 20 70 72 69 6d 61 72 79 ntly the primary
56d0: 20 6a 6f 62 20 6f 66 20 74 68 65 20 77 61 74 63 job of the watc
56e0: 68 64 6f 67 20 69 73 20 74 6f 20 72 75 6e 20 74 hdog is to run t
56f0: 68 65 20 73 79 6e 63 20 62 61 63 6b 20 74 6f 20 he sync back to
5700: 6d 65 67 61 74 65 73 74 2e 64 62 20 66 72 6f 6d megatest.db from
5710: 20 74 68 65 20 64 62 20 69 6e 20 2f 74 6d 70 0a the db in /tmp.
5720: 3b 3b 20 69 66 20 77 65 20 61 72 65 20 6f 6e 20 ;; if we are on
5730: 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 61 6e 64 the homehost and
5740: 20 77 65 20 61 72 65 20 61 20 73 65 72 76 65 72 we are a server
5750: 20 28 62 79 20 64 65 66 69 6e 69 74 69 6f 6e 20 (by definition
5760: 77 65 20 61 72 65 20 6f 6e 20 74 68 65 20 68 6f we are on the ho
5770: 6d 65 68 6f 73 74 20 69 66 20 77 65 20 61 72 65 mehost if we are
5780: 20 61 20 73 65 72 76 65 72 29 0a 3b 3b 0a 28 64 a server).;;.(d
5790: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 efine (common:wa
57a0: 74 63 68 64 6f 67 29 0a 20 20 28 74 68 72 65 61 tchdog). (threa
57b0: 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 20 3b d-sleep! 0.05) ;
57c0: 3b 20 64 65 6c 61 79 20 66 6f 72 20 73 74 61 72 ; delay for star
57d0: 74 75 70 0a 20 20 28 6c 65 74 20 28 28 6c 65 67 tup. (let ((leg
57e0: 61 63 79 2d 73 79 6e 63 20 28 63 6f 6d 6d 6f 6e acy-sync (common
57f0: 3a 72 75 6e 2d 73 79 6e 63 3f 29 29 0a 09 28 64 :run-sync?))..(d
5800: 65 62 75 67 2d 6d 6f 64 65 20 20 28 64 65 62 75 ebug-mode (debu
5810: 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 29 g:debug-mode 1))
5820: 0a 09 28 6c 61 73 74 2d 74 69 6d 65 20 20 20 28 ..(last-time (
5830: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
5840: 29 0a 20 20 20 20 20 20 20 20 28 74 68 69 73 2d ). (this-
5850: 77 64 2d 6e 75 6d 20 20 20 20 20 28 62 65 67 69 wd-num (begi
5860: 6e 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a n (mutex-lock! *
5870: 77 64 6e 75 6d 2a 6d 75 74 65 78 29 20 28 6c 65 wdnum*mutex) (le
5880: 74 20 28 28 78 20 2a 77 64 6e 75 6d 2a 29 29 20 t ((x *wdnum*))
5890: 28 73 65 74 21 20 2a 77 64 6e 75 6d 2a 20 28 61 (set! *wdnum* (a
58a0: 64 64 31 20 2a 77 64 6e 75 6d 2a 29 29 20 28 6d dd1 *wdnum*)) (m
58b0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 77 64 utex-unlock! *wd
58c0: 6e 75 6d 2a 6d 75 74 65 78 29 20 78 29 29 29 29 num*mutex) x))))
58d0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
58e0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
58f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 74 t-log-port* "wat
5900: 63 68 64 6f 67 20 73 74 61 72 74 69 6e 67 2e 20 chdog starting.
5910: 6c 65 67 61 63 79 2d 73 79 6e 63 20 69 73 20 22 legacy-sync is "
5920: 20 6c 65 67 61 63 79 2d 73 79 6e 63 22 20 70 69 legacy-sync" pi
5930: 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 d="(current-proc
5940: 65 73 73 2d 69 64 29 22 20 74 68 69 73 2d 77 64 ess-id)" this-wd
5950: 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 64 2d 6e 75 -num="this-wd-nu
5960: 6d 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 m). (if (and
5970: 6c 65 67 61 63 79 2d 73 79 6e 63 20 28 6e 6f 74 legacy-sync (not
5980: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 *time-to-exit*)
5990: 29 0a 09 28 6c 65 74 2a 20 28 28 64 62 73 74 72 )..(let* ((dbstr
59a0: 75 63 74 20 28 64 62 3a 73 65 74 75 70 29 29 0a uct (db:setup)).
59b0: 09 20 20 20 20 20 20 20 28 6d 74 64 62 20 20 20 . (mtdb
59c0: 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d (dbr:dbstruct-
59d0: 6d 74 64 62 20 64 62 73 74 72 75 63 74 29 29 0a mtdb dbstruct)).
59e0: 09 20 20 20 20 20 20 20 28 6d 74 70 61 74 68 20 . (mtpath
59f0: 20 20 28 64 62 3a 64 62 64 61 74 2d 67 65 74 2d (db:dbdat-get-
5a00: 70 61 74 68 20 6d 74 64 62 29 29 29 0a 09 20 20 path mtdb)))..
5a10: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5a20: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
5a30: 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 72 -port* "Server r
5a40: 75 6e 6e 69 6e 67 2c 20 70 65 72 69 6f 64 69 63 unning, periodic
5a50: 20 73 79 6e 63 20 73 74 61 72 74 65 64 2e 22 29 sync started.")
5a60: 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 .. (let loop ()
5a70: 0a 09 20 20 20 20 3b 3b 20 73 79 6e 63 20 66 6f .. ;; sync fo
5a80: 72 20 66 69 6c 65 73 79 73 74 65 6d 20 6c 6f 63 r filesystem loc
5a90: 61 6c 20 64 62 20 77 72 69 74 65 73 0a 09 20 20 al db writes..
5aa0: 20 20 3b 3b 0a 09 20 20 20 20 28 6d 75 74 65 78 ;;.. (mutex
5ab0: 2d 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 -lock! *db-multi
5ac0: 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 20 -sync-mutex*)..
5ad0: 20 20 20 28 6c 65 74 2a 20 28 28 6e 65 65 64 2d (let* ((need-
5ae0: 73 79 6e 63 20 20 20 20 20 20 20 20 28 3e 3d 20 sync (>=
5af0: 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a *db-last-access*
5b00: 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 *db-last-sync*)
5b10: 29 20 3b 3b 20 6e 6f 20 73 79 6e 63 20 73 69 6e ) ;; no sync sin
5b20: 63 65 20 6c 61 73 74 20 77 72 69 74 65 0a 09 09 ce last write...
5b30: 20 20 20 28 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 (sync-in-prog
5b40: 72 65 73 73 20 2a 64 62 2d 73 79 6e 63 2d 69 6e ress *db-sync-in
5b50: 2d 70 72 6f 67 72 65 73 73 2a 29 0a 09 09 20 20 -progress*)...
5b60: 20 28 73 68 6f 75 6c 64 2d 73 79 6e 63 20 20 20 (should-sync
5b70: 20 20 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 69 (and (not *ti
5b80: 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 20 20 me-to-exit*).
5b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ba0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bb0: 20 20 20 20 20 20 20 28 3e 20 28 2d 20 28 63 75 (> (- (cu
5bc0: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a rrent-seconds) *
5bd0: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 20 35 db-last-sync*) 5
5be0: 29 29 29 20 3b 3b 20 73 79 6e 63 20 65 76 65 72 ))) ;; sync ever
5bf0: 79 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 6d y five seconds m
5c00: 69 6e 69 6d 75 6d 0a 09 09 20 20 20 28 73 74 61 inimum... (sta
5c10: 72 74 2d 74 69 6d 65 20 20 20 20 20 20 20 28 63 rt-time (c
5c20: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
5c30: 0a 09 09 20 20 20 28 6d 74 2d 6d 6f 64 2d 74 69 ... (mt-mod-ti
5c40: 6d 65 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f me (file-mo
5c50: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
5c60: 6d 74 70 61 74 68 29 29 0a 09 09 20 20 20 28 72 mtpath))... (r
5c70: 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 20 20 ecently-synced
5c80: 28 3e 20 28 2d 20 73 74 61 72 74 2d 74 69 6d 65 (> (- start-time
5c90: 20 6d 74 2d 6d 6f 64 2d 74 69 6d 65 29 20 34 29 mt-mod-time) 4)
5ca0: 29 0a 09 09 20 20 20 28 77 69 6c 6c 2d 73 79 6e )... (will-syn
5cb0: 63 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 6f c (and (o
5cc0: 72 20 6e 65 65 64 2d 73 79 6e 63 20 73 68 6f 75 r need-sync shou
5cd0: 6c 64 2d 73 79 6e 63 29 0a 09 09 09 09 09 20 20 ld-sync)......
5ce0: 28 6e 6f 74 20 73 79 6e 63 2d 69 6e 2d 70 72 6f (not sync-in-pro
5cf0: 67 72 65 73 73 29 0a 09 09 09 09 09 20 20 28 6e gress)...... (n
5d00: 6f 74 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 ot recently-sync
5d10: 65 64 29 29 29 29 0a 09 20 20 20 20 20 20 3b 3b ed)))).. ;;
5d20: 20 28 69 66 20 72 65 63 65 6e 74 6c 79 2d 73 79 (if recently-sy
5d30: 6e 63 65 64 20 28 64 65 62 75 67 3a 70 72 69 6e nced (debug:prin
5d40: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5d50: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 6b 69 t-log-port* "Ski
5d60: 70 70 69 6e 67 20 73 79 6e 63 20 64 75 65 20 74 pping sync due t
5d70: 6f 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 o recently-synce
5d80: 64 20 66 6c 61 67 3d 22 20 72 65 63 65 6e 74 6c d flag=" recentl
5d90: 79 2d 73 79 6e 63 65 64 29 29 0a 09 20 20 20 20 y-synced))..
5da0: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
5db0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5dc0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 65 65 t-log-port* "nee
5dd0: 64 2d 73 79 6e 63 3a 20 22 20 6e 65 65 64 2d 73 d-sync: " need-s
5de0: 79 6e 63 20 22 20 73 79 6e 63 2d 69 6e 2d 70 72 ync " sync-in-pr
5df0: 6f 67 72 65 73 73 3a 20 22 20 73 79 6e 63 2d 69 ogress: " sync-i
5e00: 6e 2d 70 72 6f 67 72 65 73 73 20 22 20 73 68 6f n-progress " sho
5e10: 75 6c 64 2d 73 79 6e 63 3a 20 22 20 73 68 6f 75 uld-sync: " shou
5e20: 6c 64 2d 73 79 6e 63 20 22 20 77 69 6c 6c 2d 73 ld-sync " will-s
5e30: 79 6e 63 3a 20 22 20 77 69 6c 6c 2d 73 79 6e 63 ync: " will-sync
5e40: 29 0a 09 20 20 20 20 20 20 28 69 66 20 77 69 6c ).. (if wil
5e50: 6c 2d 73 79 6e 63 20 28 73 65 74 21 20 2a 64 62 l-sync (set! *db
5e60: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
5e70: 73 2a 20 23 74 29 29 0a 09 20 20 20 20 20 20 28 s* #t)).. (
5e80: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 mutex-unlock! *d
5e90: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
5ea0: 65 78 2a 29 0a 09 20 20 20 20 20 20 28 69 66 20 ex*).. (if
5eb0: 77 69 6c 6c 2d 73 79 6e 63 0a 09 09 20 20 28 6c will-sync... (l
5ec0: 65 74 20 28 28 72 65 73 20 28 63 6f 6d 6d 6f 6e et ((res (common
5ed0: 3a 73 79 6e 63 2d 74 6f 2d 6d 65 67 61 74 65 73 :sync-to-megates
5ee0: 74 2e 64 62 20 64 62 73 74 72 75 63 74 29 29 29 t.db dbstruct)))
5ef0: 20 3b 3b 20 64 69 64 20 77 65 20 73 79 6e 63 20 ;; did we sync
5f00: 61 6e 79 20 64 61 74 61 3f 20 49 66 20 73 6f 20 any data? If so
5f10: 6e 65 65 64 20 74 6f 20 73 65 74 20 74 68 65 20 need to set the
5f20: 64 62 20 74 6f 75 63 68 65 64 20 66 6c 61 67 20 db touched flag
5f30: 74 6f 20 6b 65 65 70 20 74 68 65 20 73 65 72 76 to keep the serv
5f40: 65 72 20 61 6c 69 76 65 0a 09 09 20 20 20 20 28 er alive... (
5f50: 69 66 20 28 3e 20 72 65 73 20 30 29 20 3b 3b 20 if (> res 0) ;;
5f60: 73 6f 6d 65 20 72 65 63 6f 72 64 73 20 77 65 72 some records wer
5f70: 65 20 74 72 61 6e 73 66 65 72 72 65 64 2c 20 6b e transferred, k
5f80: 65 65 70 20 74 68 65 20 64 62 20 61 6c 69 76 65 eep the db alive
5f90: 0a 09 09 09 28 62 65 67 69 6e 0a 09 09 09 20 20 ....(begin....
5fa0: 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 65 (mutex-lock! *he
5fb0: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
5fc0: 09 09 09 20 20 28 73 65 74 21 20 2a 64 62 2d 6c ... (set! *db-l
5fd0: 61 73 74 2d 61 63 63 65 73 73 2a 20 28 63 75 72 ast-access* (cur
5fe0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 rent-seconds))..
5ff0: 09 09 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 .. (mutex-unloc
6000: 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d 75 k! *heartbeat-mu
6010: 74 65 78 2a 29 0a 09 09 09 20 20 28 64 65 62 75 tex*).... (debu
6020: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
6030: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6040: 2a 20 22 73 79 6e 63 20 63 61 6c 6c 65 64 2c 20 * "sync called,
6050: 22 20 72 65 73 20 22 20 72 65 63 6f 72 64 73 20 " res " records
6060: 74 72 61 6e 73 66 65 72 72 65 64 2e 22 29 29 0a transferred.")).
6070: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
6080: 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d info 2 *default-
6090: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 79 6e 63 20 log-port* "sync
60a0: 63 61 6c 6c 65 64 20 62 75 74 20 7a 65 72 6f 20 called but zero
60b0: 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 65 72 records transfer
60c0: 72 65 64 22 29 29 29 29 0a 09 20 20 20 20 20 20 red"))))..
60d0: 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 0a 09 09 (if will-sync...
60e0: 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 (begin... (
60f0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
6100: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
6110: 2a 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 2a *)... (set! *
6120: 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 db-sync-in-progr
6130: 65 73 73 2a 20 23 66 29 0a 09 09 20 20 20 20 28 ess* #f)... (
6140: 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 73 79 set! *db-last-sy
6150: 6e 63 2a 20 73 74 61 72 74 2d 74 69 6d 65 29 0a nc* start-time).
6160: 09 09 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c .. (mutex-unl
6170: 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 ock! *db-multi-s
6180: 79 6e 63 2d 6d 75 74 65 78 2a 29 29 29 0a 09 20 ync-mutex*)))..
6190: 20 20 20 20 20 28 69 66 20 28 61 6e 64 20 64 65 (if (and de
61a0: 62 75 67 2d 6d 6f 64 65 0a 09 09 20 20 20 20 20 bug-mode...
61b0: 20 20 28 3e 20 28 2d 20 73 74 61 72 74 2d 74 69 (> (- start-ti
61c0: 6d 65 20 6c 61 73 74 2d 74 69 6d 65 29 20 36 30 me last-time) 60
61d0: 29 29 0a 09 09 20 20 28 62 65 67 69 6e 0a 09 09 ))... (begin...
61e0: 20 20 20 20 28 73 65 74 21 20 6c 61 73 74 2d 74 (set! last-t
61f0: 69 6d 65 20 73 74 61 72 74 2d 74 69 6d 65 29 0a ime start-time).
6200: 09 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 .. (debug:pri
6210: 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 nt-info 4 *defau
6220: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 69 lt-log-port* "ti
6230: 6d 65 73 74 61 6d 70 20 2d 3e 20 22 20 28 73 65 mestamp -> " (se
6240: 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 conds->time-stri
6250: 6e 67 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f ng (current-seco
6260: 6e 64 73 29 29 20 22 2c 20 74 69 6d 65 20 73 69 nds)) ", time si
6270: 6e 63 65 20 73 74 61 72 74 20 2d 3e 20 22 20 28 nce start -> " (
6280: 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d seconds->hr-min-
6290: 73 65 63 20 28 2d 20 28 63 75 72 72 65 6e 74 2d sec (- (current-
62a0: 73 65 63 6f 6e 64 73 29 20 2a 74 69 6d 65 2d 7a seconds) *time-z
62b0: 65 72 6f 2a 29 29 29 29 29 29 0a 09 20 20 20 20 ero*))))))..
62c0: 0a 09 20 20 20 20 3b 3b 20 6b 65 65 70 20 67 6f .. ;; keep go
62d0: 69 6e 67 20 75 6e 6c 65 73 73 20 74 69 6d 65 20 ing unless time
62e0: 74 6f 20 65 78 69 74 0a 09 20 20 20 20 3b 3b 0a to exit.. ;;.
62f0: 09 20 20 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 . (if (not *t
6300: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 09 ime-to-exit*)...
6310: 28 6c 65 74 20 64 65 6c 61 79 2d 6c 6f 6f 70 20 (let delay-loop
6320: 28 28 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 ((count 0)).
6330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
6340: 28 42 42 3e 20 22 64 65 6c 61 79 2d 6c 6f 6f 70 (BB> "delay-loop
6350: 20 74 6f 70 3b 20 63 6f 75 6e 74 3d 22 63 6f 75 top; count="cou
6360: 6e 74 22 20 70 69 64 3d 22 28 63 75 72 72 65 6e nt" pid="(curren
6370: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 74 t-process-id)" t
6380: 68 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 his-wd-num="this
6390: 2d 77 64 2d 6e 75 6d 22 20 2a 74 69 6d 65 2d 74 -wd-num" *time-t
63a0: 6f 2d 65 78 69 74 2a 3d 22 2a 74 69 6d 65 2d 74 o-exit*="*time-t
63b0: 6f 2d 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 o-exit*).
63c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63f0: 20 20 20 20 20 0a 09 09 20 20 28 69 66 20 28 61 ... (if (a
6400: 6e 64 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f nd (not *time-to
6410: 2d 65 78 69 74 2a 29 0a 09 09 09 20 20 20 28 3c -exit*).... (<
6420: 20 63 6f 75 6e 74 20 34 29 29 20 3b 3b 20 77 61 count 4)) ;; wa
6430: 73 20 31 31 2c 20 63 68 61 6e 67 69 6e 67 20 74 s 11, changing t
6440: 6f 20 34 2e 20 0a 09 09 20 20 20 20 20 20 28 62 o 4. ... (b
6450: 65 67 69 6e 0a 09 09 09 28 74 68 72 65 61 64 2d egin....(thread-
6460: 73 6c 65 65 70 21 20 31 29 0a 09 09 09 28 64 65 sleep! 1)....(de
6470: 6c 61 79 2d 6c 6f 6f 70 20 28 2b 20 63 6f 75 6e lay-loop (+ coun
6480: 74 20 31 29 29 29 29 0a 09 09 20 20 28 69 66 20 t 1))))... (if
6490: 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 (not *time-to-ex
64a0: 69 74 2a 29 20 28 6c 6f 6f 70 29 29 29 29 0a 09 it*) (loop))))..
64b0: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
64c0: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
64d0: 33 30 29 0a 09 09 28 64 65 62 75 67 3a 70 72 69 30)...(debug:pri
64e0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
64f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 78 lt-log-port* "Ex
6500: 69 74 69 6e 67 20 77 61 74 63 68 64 6f 67 20 74 iting watchdog t
6510: 69 6d 65 72 2c 20 2a 74 69 6d 65 2d 74 6f 2d 65 imer, *time-to-e
6520: 78 69 74 2a 20 3d 20 22 20 2a 74 69 6d 65 2d 74 xit* = " *time-t
6530: 6f 2d 65 78 69 74 2a 22 20 70 69 64 3d 22 28 63 o-exit*" pid="(c
6540: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
6550: 64 29 22 20 74 68 69 73 2d 77 64 2d 6e 75 6d 3d d)" this-wd-num=
6560: 22 74 68 69 73 2d 77 64 2d 6e 75 6d 29 29 29 29 "this-wd-num))))
6570: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 )))..(define (st
6580: 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 72 65 d-exit-procedure
6590: 29 0a 20 20 28 6f 6e 2d 65 78 69 74 20 28 6c 61 ). (on-exit (la
65a0: 6d 62 64 61 20 28 29 20 30 29 29 0a 20 20 3b 3b mbda () 0)). ;;
65b0: 28 42 42 3e 20 22 73 74 64 2d 65 78 69 74 2d 70 (BB> "std-exit-p
65c0: 72 6f 63 65 64 75 72 65 20 63 61 6c 6c 65 64 3b rocedure called;
65d0: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 3d *time-to-exit*=
65e0: 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 "*time-to-exit*)
65f0: 0a 20 20 28 6c 65 74 20 28 28 6e 6f 2d 68 75 72 . (let ((no-hur
6600: 72 79 20 20 28 69 66 20 2a 74 69 6d 65 2d 74 6f ry (if *time-to
6610: 2d 65 78 69 74 2a 20 3b 3b 20 68 75 72 72 79 20 -exit* ;; hurry
6620: 75 70 0a 09 09 20 20 20 20 20 20 20 23 66 0a 09 up... #f..
6630: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
6640: 09 09 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 .. (set! *time-t
6650: 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 09 09 20 o-exit* #t)....
6660: 23 74 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 #t)))). (debu
6670: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
6680: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6690: 2a 20 22 73 74 61 72 74 69 6e 67 20 65 78 69 74 * "starting exit
66a0: 20 70 72 6f 63 65 73 73 2c 20 66 69 6e 61 6c 69 process, finali
66b0: 7a 69 6e 67 20 64 61 74 61 62 61 73 65 73 2e 22 zing databases."
66c0: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 6e ). (if (and n
66d0: 6f 2d 68 75 72 72 79 20 28 64 65 62 75 67 3a 64 o-hurry (debug:d
66e0: 65 62 75 67 2d 6d 6f 64 65 20 31 38 29 29 0a 09 ebug-mode 18))..
66f0: 28 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 (rmt:print-db-st
6700: 61 74 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 ats)). (let (
6710: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa
6720: 64 20 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b 20 d (lambda () ;;
6730: 74 68 72 65 61 64 20 66 6f 72 20 63 6c 65 61 6e thread for clean
6740: 69 6e 67 20 75 70 2c 20 67 69 76 65 20 69 74 20 ing up, give it
6750: 66 69 76 65 20 73 65 63 6f 6e 64 73 0a 20 20 20 five seconds.
6760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6770: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 2a (if *
6780: 64 62 73 74 72 75 63 74 2d 64 62 2a 20 28 64 62 dbstruct-db* (db
6790: 3a 63 6c 6f 73 65 2d 61 6c 6c 20 2a 64 62 73 74 :close-all *dbst
67a0: 72 75 63 74 2d 64 62 2a 29 29 20 3b 3b 20 6f 6e ruct-db*)) ;; on
67b0: 65 20 73 65 63 6f 6e 64 20 61 6c 6c 6f 63 61 74 e second allocat
67c0: 65 64 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ed.... (if
67d0: 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 0a 09 09 *task-db* ...
67e0: 09 09 20 20 28 6c 65 74 20 28 28 64 62 20 28 63 .. (let ((db (c
67f0: 64 72 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 0a dr *task-db*))).
6800: 09 09 09 09 20 20 20 20 28 69 66 20 28 73 71 6c .... (if (sql
6810: 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 64 ite3:database? d
6820: 62 29 0a 09 09 09 09 09 28 62 65 67 69 6e 0a 09 b)......(begin..
6830: 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 69 .... (sqlite3:i
6840: 6e 74 65 72 72 75 70 74 21 20 64 62 29 0a 09 09 nterrupt! db)...
6850: 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 66 69 ... (sqlite3:fi
6860: 6e 61 6c 69 7a 65 21 20 64 62 20 23 74 29 0a 09 nalize! db #t)..
6870: 09 09 09 09 20 20 3b 3b 20 28 76 65 63 74 6f 72 .... ;; (vector
6880: 2d 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 -set! *task-db*
6890: 30 20 23 66 29 0a 09 09 09 09 09 20 20 28 73 65 0 #f)...... (se
68a0: 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 23 66 29 t! *task-db* #f)
68b0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
68c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
68d0: 20 20 20 28 69 66 20 28 61 6e 64 20 2a 72 75 6e (if (and *run
68e0: 72 65 6d 6f 74 65 2a 0a 20 20 20 20 20 20 20 20 remote*.
68f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6910: 72 65 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 2a remote-conndat *
6920: 72 75 6e 72 65 6d 6f 74 65 2a 29 29 0a 20 20 20 runremote*)).
6930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6950: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
6960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6970: 20 20 20 20 20 20 20 20 20 20 28 68 74 74 70 2d (http-
6980: 63 6c 69 65 6e 74 23 63 6c 6f 73 65 2d 61 6c 6c client#close-all
6990: 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 -connections!)))
69a0: 20 3b 3b 20 66 6f 72 20 68 74 74 70 2d 63 6c 69 ;; for http-cli
69b0: 65 6e 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 ent.
69c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69d0: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
69e0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
69f0: 74 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f t* (current-erro
6a00: 72 2d 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 r-port))).
6a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a20: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f (clo
6a30: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 2a se-output-port *
6a40: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6a50: 2a 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 *)).... (se
6a60: 74 21 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d t! *default-log-
6a70: 70 6f 72 74 2a 20 28 63 75 72 72 65 6e 74 2d 65 port* (current-e
6a80: 72 72 6f 72 2d 70 6f 72 74 29 29 29 20 22 43 6c rror-port))) "Cl
6a90: 65 61 6e 75 70 20 64 62 20 65 78 69 74 20 74 68 eanup db exit th
6aa0: 72 65 61 64 22 29 29 0a 09 20 20 28 74 68 32 20 read")).. (th2
6ab0: 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 (make-thread (la
6ac0: 6d 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 mbda ()....
6ad0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 (debug:print 4
6ae0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6af0: 74 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 20 63 t* "Attempting c
6b00: 6c 65 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 lean exit. Pleas
6b10: 65 20 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 e be patient and
6b20: 20 77 61 69 74 20 61 20 66 65 77 20 73 65 63 6f wait a few seco
6b30: 6e 64 73 2e 2e 2e 22 29 0a 09 09 09 20 20 20 20 nds...")....
6b40: 20 20 28 69 66 20 6e 6f 2d 68 75 72 72 79 0a 20 (if no-hurry.
6b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b70: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
6b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b90: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 68 72 (thr
6ba0: 65 61 64 2d 73 6c 65 65 70 21 20 35 29 29 20 3b ead-sleep! 5)) ;
6bb0: 3b 20 67 69 76 65 20 74 68 65 20 63 6c 65 61 6e ; give the clean
6bc0: 20 75 70 20 66 65 77 20 73 65 63 6f 6e 64 73 20 up few seconds
6bd0: 74 6f 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 to do it's stuff
6be0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6c00: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
6c10: 09 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c .... (thread-sl
6c20: 65 65 70 21 20 32 29 29 29 0a 20 20 20 20 20 20 eep! 2))).
6c30: 09 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a ... (debug:
6c40: 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 print 4 *default
6c50: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e -log-port* " ...
6c60: 20 64 6f 6e 65 22 29 0a 20 20 20 20 20 20 09 09 done"). ..
6c70: 09 20 20 20 20 20 20 29 0a 09 09 09 20 20 20 20 . )....
6c80: 22 63 6c 65 61 6e 20 65 78 69 74 22 29 29 29 0a "clean exit"))).
6c90: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 (thread-st
6ca0: 61 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 art! th1).
6cb0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
6cc0: 68 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 h2). (threa
6cd0: 64 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 20 20 20 d-join! th1).
6ce0: 20 20 20 29 0a 20 20 20 20 29 0a 0a 20 20 30 29 ). ).. 0)
6cf0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d 73 ..(define (std-s
6d00: 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 ignal-handler si
6d10: 67 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 6e gnum). ;; (sign
6d20: 61 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 al-mask! signum)
6d30: 0a 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 . (set! *time-t
6d40: 6f 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 3b 3b o-exit* #t). ;;
6d50: 28 42 42 3e 20 22 67 6f 74 20 73 69 67 6e 61 6c (BB> "got signal
6d60: 20 22 73 69 67 6e 75 6d 29 0a 20 20 28 64 65 62 "signum). (deb
6d70: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
6d80: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6d90: 72 74 2a 20 22 52 65 63 65 69 76 65 64 20 73 69 rt* "Received si
6da0: 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 20 gnal " signum "
6db0: 65 78 69 74 69 6e 67 20 70 72 6f 6d 70 74 6c 79 exiting promptly
6dc0: 22 29 0a 20 20 3b 3b 20 28 73 74 64 2d 65 78 69 "). ;; (std-exi
6dd0: 74 2d 70 72 6f 63 65 64 75 72 65 29 20 3b 3b 20 t-procedure) ;;
6de0: 73 68 6f 75 6c 64 6e 27 74 20 6e 65 65 64 20 74 shouldn't need t
6df0: 68 69 73 20 73 69 6e 63 65 20 77 65 20 61 72 65 his since we are
6e00: 20 65 78 69 74 69 6e 67 20 61 6e 64 20 69 74 20 exiting and it
6e10: 77 69 6c 6c 20 62 65 20 63 61 6c 6c 65 64 20 61 will be called a
6e20: 6e 79 77 61 79 0a 20 20 28 65 78 69 74 29 29 0a nyway. (exit)).
6e30: 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e .(set-signal-han
6e40: 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e 74 dler! signal/int
6e50: 20 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e std-signal-han
6e60: 64 6c 65 72 29 20 20 3b 3b 20 5e 43 0a 28 73 65 dler) ;; ^C.(se
6e70: 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 t-signal-handler
6e80: 21 20 73 69 67 6e 61 6c 2f 74 65 72 6d 20 73 74 ! signal/term st
6e90: 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 d-signal-handler
6ea0: 29 0a 3b 3b 20 28 73 65 74 2d 73 69 67 6e 61 6c ).;; (set-signal
6eb0: 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c -handler! signal
6ec0: 2f 73 74 6f 70 20 73 74 64 2d 73 69 67 6e 61 6c /stop std-signal
6ed0: 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 5a -handler) ;; ^Z
6ee0: 20 4e 4f 2c 20 64 6f 20 4e 4f 54 20 68 61 6e 64 NO, do NOT hand
6ef0: 6c 65 20 5e 5a 21 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d le ^Z!..;;======
6f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f40: 0a 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 55 20 .;; M I S C U
6f50: 54 20 49 20 4c 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d T I L S.;;======
6f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6fa0: 0a 0a 3b 3b 20 6f 6e 65 2d 6f 66 20 61 72 67 73 ..;; one-of args
6fb0: 20 64 65 66 69 6e 65 64 0a 28 64 65 66 69 6e 65 defined.(define
6fc0: 20 28 61 72 67 73 2d 64 65 66 69 6e 65 64 3f 20 (args-defined?
6fd0: 2e 20 70 61 72 61 6d 29 0a 20 20 28 6c 65 74 20 . param). (let
6fe0: 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 ((res #f)). (
6ff0: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
7000: 6c 61 6d 62 64 61 20 28 61 72 67 29 0a 20 20 20 lambda (arg).
7010: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
7020: 74 2d 61 72 67 20 61 72 67 29 28 73 65 74 21 20 t-arg arg)(set!
7030: 72 65 73 20 23 74 29 29 29 0a 20 20 20 20 20 70 res #t))). p
7040: 61 72 61 6d 29 0a 20 20 20 20 72 65 73 29 29 0a aram). res)).
7050: 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 73 74 75 66 .;; convert stuf
7060: 66 20 74 6f 20 61 20 6e 75 6d 62 65 72 20 69 66 f to a number if
7070: 20 70 6f 73 73 69 62 6c 65 0a 28 64 65 66 69 6e possible.(defin
7080: 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 e (any->number v
7090: 61 6c 29 0a 20 20 28 63 6f 6e 64 20 0a 20 20 20 al). (cond .
70a0: 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 20 76 ((number? val) v
70b0: 61 6c 29 0a 20 20 20 28 28 73 74 72 69 6e 67 3f al). ((string?
70c0: 20 76 61 6c 29 20 28 73 74 72 69 6e 67 2d 3e 6e val) (string->n
70d0: 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 20 20 28 umber val)). (
70e0: 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 20 28 61 (symbol? val) (a
70f0: 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 73 79 6d 62 ny->number (symb
7100: 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c 29 29 ol->string val))
7110: 29 0a 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 ). (else #f)))
7120: 0a 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 2d 3e ..(define (any->
7130: 6e 75 6d 62 65 72 2d 69 66 2d 70 6f 73 73 69 62 number-if-possib
7140: 6c 65 20 76 61 6c 29 0a 20 20 28 6c 65 74 20 28 le val). (let (
7150: 28 6e 75 6d 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 (num (any->numbe
7160: 72 20 76 61 6c 29 29 29 0a 20 20 20 20 28 69 66 r val))). (if
7170: 20 6e 75 6d 20 6e 75 6d 20 76 61 6c 29 29 29 0a num num val))).
7180: 0a 28 64 65 66 69 6e 65 20 28 70 61 74 74 2d 6c .(define (patt-l
7190: 69 73 74 2d 6d 61 74 63 68 20 69 74 65 6d 20 70 ist-match item p
71a0: 61 74 74 73 29 0a 20 20 28 64 65 62 75 67 3a 70 atts). (debug:p
71b0: 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 65 66 rint-info 8 *def
71c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
71d0: 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 patt-list-match
71e0: 69 74 65 6d 3d 22 20 69 74 65 6d 20 22 20 70 61 item=" item " pa
71f0: 74 74 73 3d 22 20 70 61 74 74 73 29 0a 20 20 28 tts=" patts). (
7200: 69 66 20 28 61 6e 64 20 69 74 65 6d 20 70 61 74 if (and item pat
7210: 74 73 29 20 20 3b 3b 20 68 65 72 65 20 77 65 20 ts) ;; here we
7220: 61 72 65 20 66 69 6c 74 65 72 69 6e 67 20 66 6f are filtering fo
7230: 72 20 6d 61 74 63 68 65 73 20 77 69 74 68 20 69 r matches with i
7240: 74 65 6d 20 70 61 74 74 65 72 6e 73 0a 20 20 20 tem patterns.
7250: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 (let ((res #f
7260: 29 29 20 20 20 3b 3b 20 6c 6f 6f 6b 20 74 68 72 )) ;; look thr
7270: 6f 75 67 68 20 61 6c 6c 20 74 68 65 20 69 74 65 ough all the ite
7280: 6d 2d 70 61 74 74 73 20 69 66 20 64 65 66 69 6e m-patts if defin
7290: 65 64 2c 20 66 6f 72 6d 61 74 20 69 73 20 70 61 ed, format is pa
72a0: 74 74 31 2c 70 61 74 74 32 2c 70 61 74 74 33 20 tt1,patt2,patt3
72b0: 2e 2e 2e 20 77 69 6c 64 63 61 72 64 20 69 73 20 ... wildcard is
72c0: 25 0a 09 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 %..(for-each ..
72d0: 28 6c 61 6d 62 64 61 20 28 70 61 74 74 29 0a 09 (lambda (patt)..
72e0: 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 70 61 74 (let ((modpat
72f0: 74 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 69 t (string-substi
7300: 74 75 74 65 20 22 25 22 20 22 2e 2a 22 20 70 61 tute "%" ".*" pa
7310: 74 74 20 23 74 29 29 29 0a 09 20 20 20 20 20 28 tt #t))).. (
7320: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7330: 20 31 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 10 *default-log
7340: 2d 70 6f 72 74 2a 20 22 70 61 74 74 20 22 20 70 -port* "patt " p
7350: 61 74 74 20 22 20 6d 6f 64 70 61 74 74 20 22 20 att " modpatt "
7360: 6d 6f 64 70 61 74 74 29 0a 09 20 20 20 20 20 28 modpatt).. (
7370: 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 if (string-match
7380: 20 28 72 65 67 65 78 70 20 6d 6f 64 70 61 74 74 (regexp modpatt
7390: 29 20 69 74 65 6d 29 0a 09 09 20 28 73 65 74 21 ) item)... (set!
73a0: 20 72 65 73 20 23 74 29 29 29 29 0a 09 20 28 73 res #t)))).. (s
73b0: 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 74 74 tring-split patt
73c0: 73 20 22 2c 22 29 29 0a 09 72 65 73 29 0a 20 20 s ","))..res).
73d0: 20 20 20 20 23 74 29 29 0a 0a 3b 3b 20 28 6d 61 #t))..;; (ma
73e0: 70 20 70 72 69 6e 74 20 28 6d 61 70 20 63 61 72 p print (map car
73f0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
7400: 69 73 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 ist (read-config
7410: 20 22 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "runconfigs.con
7420: 66 69 67 22 20 23 66 20 23 74 29 29 29 29 0a 28 fig" #f #t)))).(
7430: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
7440: 65 74 2d 72 75 6e 63 6f 6e 66 69 67 2d 74 61 72 et-runconfig-tar
7450: 67 65 74 73 20 23 21 6b 65 79 20 28 63 6f 6e 66 gets #!key (conf
7460: 69 67 66 20 23 66 29 29 0a 20 20 28 6c 65 74 20 igf #f)). (let
7470: 28 28 74 61 72 67 73 20 20 20 20 20 20 20 28 73 ((targs (s
7480: 6f 72 74 20 28 6d 61 70 20 63 61 72 20 28 68 61 ort (map car (ha
7490: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 0a sh-table->alist.
74a0: 09 09 09 09 20 20 20 20 20 28 6f 72 20 63 6f 6e .... (or con
74b0: 66 69 67 66 0a 09 09 09 09 09 20 28 72 65 61 64 figf...... (read
74c0: 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 2a 74 -config (conc *t
74d0: 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e oppath* "/runcon
74e0: 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 0a 09 09 figs.config")...
74f0: 09 09 09 09 20 20 20 20 20 20 23 66 20 23 74 29 .... #f #t)
7500: 0a 09 09 09 09 09 20 28 6d 61 6b 65 2d 68 61 73 ...... (make-has
7510: 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 09 09 20 h-table))))....
7520: 20 20 73 74 72 69 6e 67 3c 3f 29 29 0a 09 28 74 string<?))..(t
7530: 61 72 67 65 74 2d 70 61 74 74 20 28 61 72 67 73 arget-patt (args
7540: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
7550: 74 22 29 29 29 0a 20 20 20 20 28 69 66 20 74 61 t"))). (if ta
7560: 72 67 65 74 2d 70 61 74 74 0a 09 28 66 69 6c 74 rget-patt..(filt
7570: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
7580: 09 20 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 . (patt-list-ma
7590: 74 63 68 20 78 20 74 61 72 67 65 74 2d 70 61 74 tch x target-pat
75a0: 74 29 29 0a 09 09 74 61 72 67 73 29 0a 09 74 61 t))...targs)..ta
75b0: 72 67 73 29 29 29 0a 0a 3b 3b 20 27 28 70 72 69 rgs)))..;; '(pri
75c0: 6e 74 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 nt (string-inter
75d0: 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 64 72 sperse (map cadr
75e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
75f0: 2f 64 65 66 61 75 6c 74 20 28 72 65 61 64 2d 63 /default (read-c
7600: 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 73 74 2e onfig "megatest.
7610: 63 6f 6e 66 69 67 22 20 5c 23 66 20 5c 23 74 29 config" \#f \#t)
7620: 20 22 64 69 73 6b 73 22 20 27 22 27 22 27 28 22 "disks" '"'"'("
7630: 6e 6f 6e 65 22 20 22 22 29 29 29 20 22 5c 6e 22 none" ""))) "\n"
7640: 29 29 27 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))'.(define (com
7650: 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 73 20 23 21 mon:get-disks #!
7660: 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 29 key (configf #f)
7670: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
7680: 72 65 66 2f 64 65 66 61 75 6c 74 20 0a 20 20 20 ref/default .
7690: 28 6f 72 20 63 6f 6e 66 69 67 66 20 28 72 65 61 (or configf (rea
76a0: 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 d-config "megate
76b0: 73 74 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 74 st.config" #f #t
76c0: 29 29 0a 20 20 20 22 64 69 73 6b 73 22 20 27 28 )). "disks" '(
76d0: 22 6e 6f 6e 65 22 20 22 22 29 29 29 0a 0a 3b 3b "none" "")))..;;
76e0: 20 72 65 74 75 72 6e 20 66 69 72 73 74 20 63 6f return first co
76f0: 6d 6d 61 6e 64 20 74 68 61 74 20 65 78 69 73 74 mmand that exist
7700: 73 2c 20 65 6c 73 65 20 23 66 0a 3b 3b 0a 28 64 s, else #f.;;.(d
7710: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 68 efine (common:wh
7720: 69 63 68 20 63 6d 64 73 29 0a 20 20 28 69 66 20 ich cmds). (if
7730: 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a 20 20 20 (null? cmds).
7740: 20 20 20 23 66 0a 20 20 20 20 20 20 28 6c 65 74 #f. (let
7750: 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
7760: 20 63 6d 64 73 29 29 0a 09 09 20 28 74 61 6c 20 cmds))... (tal
7770: 28 63 64 72 20 63 6d 64 73 29 29 29 0a 09 28 6c (cdr cmds)))..(l
7780: 65 74 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 et ((res (with-i
7790: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 nput-from-pipe (
77a0: 63 6f 6e 63 20 22 77 68 69 63 68 20 22 20 68 65 conc "which " he
77b0: 64 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a d) read-line))).
77c0: 09 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 . (if (and (str
77d0: 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 28 ing? res)... (
77e0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 73 file-exists? res
77f0: 29 29 0a 09 20 20 20 20 20 20 72 65 73 0a 09 20 )).. res..
7800: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
7810: 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 20 tal)... #f...
7820: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
7830: 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a cdr tal)))))))).
7840: 20 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d .(define (comm
7850: 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c 6c 2d 61 on:get-install-a
7860: 72 65 61 29 0a 20 20 28 6c 65 74 20 28 28 65 78 rea). (let ((ex
7870: 65 2d 70 61 74 68 20 28 63 61 72 20 28 61 72 67 e-path (car (arg
7880: 76 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 v)))). (if (f
7890: 69 6c 65 2d 65 78 69 73 74 73 3f 20 65 78 65 2d ile-exists? exe-
78a0: 70 61 74 68 29 0a 09 28 68 61 6e 64 6c 65 2d 65 path)..(handle-e
78b0: 78 63 65 70 74 69 6f 6e 73 0a 09 20 65 78 6e 0a xceptions.. exn.
78c0: 09 20 23 66 0a 09 20 28 70 61 74 68 6e 61 6d 65 . #f.. (pathname
78d0: 2d 64 69 72 65 63 74 6f 72 79 0a 09 20 20 28 70 -directory.. (p
78e0: 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 athname-director
78f0: 79 20 0a 09 20 20 20 28 70 61 74 68 6e 61 6d 65 y .. (pathname
7900: 2d 64 69 72 65 63 74 6f 72 79 20 65 78 65 2d 70 -directory exe-p
7910: 61 74 68 29 29 29 29 0a 09 23 66 29 29 29 0a 0a ath))))..#f)))..
7920: 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 73 74 20 ;; return first
7930: 70 61 74 68 20 74 68 61 74 20 63 61 6e 20 62 65 path that can be
7940: 20 63 72 65 61 74 65 64 20 6f 72 20 61 6c 72 65 created or alre
7950: 61 64 79 20 65 78 69 73 74 73 20 61 6e 64 20 69 ady exists and i
7960: 73 20 77 72 69 74 61 62 6c 65 0a 3b 3b 0a 28 64 s writable.;;.(d
7970: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
7980: 74 2d 63 72 65 61 74 65 2d 77 72 69 74 65 61 62 t-create-writeab
7990: 6c 65 2d 64 69 72 20 64 69 72 73 29 0a 20 20 28 le-dir dirs). (
79a0: 69 66 20 28 6e 75 6c 6c 3f 20 64 69 72 73 29 0a if (null? dirs).
79b0: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
79c0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
79d0: 63 61 72 20 64 69 72 73 29 29 0a 09 09 20 28 74 car dirs))... (t
79e0: 61 6c 20 28 63 64 72 20 64 69 72 73 29 29 29 0a al (cdr dirs))).
79f0: 09 28 6c 65 74 20 28 28 72 65 73 20 28 6f 72 20 .(let ((res (or
7a00: 28 61 6e 64 20 28 64 69 72 65 63 74 6f 72 79 3f (and (directory?
7a10: 20 68 65 64 29 0a 09 09 09 20 20 20 20 28 66 69 hed).... (fi
7a20: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
7a30: 20 68 65 64 29 0a 09 09 09 20 20 20 20 68 65 64 hed).... hed
7a40: 29 0a 09 09 20 20 20 20 20 20 20 28 68 61 6e 64 )... (hand
7a50: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
7a60: 09 65 78 6e 0a 09 09 09 23 66 0a 09 09 09 28 63 .exn....#f....(c
7a70: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
7a80: 68 65 64 20 23 74 29 29 29 29 29 0a 09 20 20 28 hed #t))))).. (
7a90: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
7aa0: 20 72 65 73 29 0a 09 09 20 20 20 28 64 69 72 65 res)... (dire
7ab0: 63 74 6f 72 79 3f 20 72 65 73 29 29 0a 09 20 20 ctory? res))..
7ac0: 20 20 20 20 72 65 73 0a 09 20 20 20 20 20 20 28 res.. (
7ad0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
7ae0: 09 20 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 . #f... (loop
7af0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
7b00: 6c 29 29 29 29 29 29 29 29 0a 20 20 0a 3b 3b 3d l)))))))). .;;=
7b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b50: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 20 52 20 47 =====.;; T A R G
7b60: 20 45 20 54 20 53 20 20 2c 20 20 20 53 20 54 20 E T S , S T
7b70: 41 20 54 20 45 20 2c 20 20 20 53 20 54 20 41 20 A T E , S T A
7b80: 54 20 55 20 53 20 2c 20 20 20 0a 3b 3b 20 20 20 T U S , .;;
7b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ba0: 20 52 20 55 20 4e 20 4e 20 41 20 4d 20 45 20 20 R U N N A M E
7bb0: 20 20 41 20 4e 20 44 20 20 20 54 20 45 20 53 20 A N D T E S
7bc0: 54 20 50 20 41 20 54 20 54 0a 3b 3b 3d 3d 3d 3d T P A T T.;;====
7bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7bf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7c10: 3d 3d 0a 0a 3b 3b 20 4c 6f 6f 6b 75 70 20 61 20 ==..;; Lookup a
7c20: 76 61 6c 75 65 20 69 6e 20 72 75 6e 63 6f 6e 66 value in runconf
7c30: 69 67 73 20 62 61 73 65 64 20 6f 6e 20 2d 72 65 igs based on -re
7c40: 71 74 61 72 67 20 6f 72 20 2d 74 61 72 67 65 74 qtarg or -target
7c50: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 63 6f 6e .(define (runcon
7c60: 66 69 67 73 2d 67 65 74 20 63 6f 6e 66 69 67 20 figs-get config
7c70: 76 61 72 29 0a 20 20 28 6c 65 74 20 28 28 74 61 var). (let ((ta
7c80: 72 67 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d rg (common:args-
7c90: 67 65 74 2d 74 61 72 67 65 74 29 29 29 20 3b 3b get-target))) ;;
7ca0: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
7cb0: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 28 61 rg "-reqtarg")(a
7cc0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
7cd0: 72 67 65 74 22 29 28 67 65 74 65 6e 76 20 22 4d rget")(getenv "M
7ce0: 54 5f 54 41 52 47 45 54 22 29 29 29 29 0a 20 20 T_TARGET")))).
7cf0: 20 20 28 69 66 20 74 61 72 67 0a 09 28 6f 72 20 (if targ..(or
7d00: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
7d10: 63 6f 6e 66 69 67 20 74 61 72 67 20 76 61 72 29 config targ var)
7d20: 0a 09 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c .. (configf:l
7d30: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 64 65 ookup config "de
7d40: 66 61 75 6c 74 22 20 76 61 72 29 29 0a 09 28 63 fault" var))..(c
7d50: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
7d60: 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 20 76 nfig "default" v
7d70: 61 72 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ar))))..(define
7d80: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
7d90: 2d 73 74 61 74 65 29 0a 20 20 28 6f 72 20 28 61 -state). (or (a
7da0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 rgs:get-arg "-st
7db0: 61 74 65 22 29 28 61 72 67 73 3a 67 65 74 2d 61 ate")(args:get-a
7dc0: 72 67 20 22 3a 73 74 61 74 65 22 29 29 29 0a 0a rg ":state")))..
7dd0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
7de0: 61 72 67 73 2d 67 65 74 2d 73 74 61 74 75 73 29 args-get-status)
7df0: 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 . (or (args:get
7e00: 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 28 -arg "-status")(
7e10: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
7e20: 74 61 74 75 73 22 29 29 29 0a 0a 28 64 65 66 69 tatus")))..(defi
7e30: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d ne (common:args-
7e40: 67 65 74 2d 74 65 73 74 70 61 74 74 20 72 63 6f get-testpatt rco
7e50: 6e 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 61 nf). (let* ((ta
7e60: 67 65 78 70 72 20 28 61 72 67 73 3a 67 65 74 2d gexpr (args:get-
7e70: 61 72 67 20 22 2d 74 61 67 65 78 70 72 22 29 29 arg "-tagexpr"))
7e80: 0a 20 20 20 20 20 20 20 20 20 28 74 61 67 73 2d . (tags-
7e90: 74 65 73 74 70 61 74 74 20 28 69 66 20 74 61 67 testpatt (if tag
7ea0: 65 78 70 72 20 28 73 74 72 69 6e 67 2d 6a 6f 69 expr (string-joi
7eb0: 6e 20 28 72 75 6e 73 3a 67 65 74 2d 74 65 73 74 n (runs:get-test
7ec0: 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 67 73 20 s-matching-tags
7ed0: 74 61 67 65 78 70 72 29 20 22 2c 22 29 20 23 66 tagexpr) ",") #f
7ee0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 )). (tes
7ef0: 74 70 61 74 74 2d 6b 65 79 20 20 28 69 66 20 28 tpatt-key (if (
7f00: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 2d args:get-arg "--
7f10: 6d 6f 64 65 70 61 74 74 22 29 20 28 61 72 67 73 modepatt") (args
7f20: 3a 67 65 74 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 :get-arg "--mode
7f30: 70 61 74 74 22 29 20 22 54 45 53 54 50 41 54 54 patt") "TESTPATT
7f40: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 ")). (ar
7f50: 67 73 2d 74 65 73 74 70 61 74 74 20 28 6f 72 20 gs-testpatt (or
7f60: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7f70: 74 65 73 74 70 61 74 74 22 29 20 28 61 72 67 73 testpatt") (args
7f80: 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 :get-arg "-runte
7f90: 73 74 73 22 29 20 22 25 22 29 29 0a 20 20 20 20 sts") "%")).
7fa0: 20 20 20 20 20 28 72 74 65 73 74 70 61 74 74 20 (rtestpatt
7fb0: 20 20 20 20 28 69 66 20 72 63 6f 6e 66 20 28 72 (if rconf (r
7fc0: 75 6e 63 6f 6e 66 69 67 73 2d 67 65 74 20 72 63 unconfigs-get rc
7fd0: 6f 6e 66 20 74 65 73 74 70 61 74 74 2d 6b 65 79 onf testpatt-key
7fe0: 29 20 23 66 29 29 29 0a 20 20 20 20 28 63 6f 6e ) #f))). (con
7ff0: 64 0a 20 20 20 20 20 28 74 61 67 73 2d 74 65 73 d. (tags-tes
8000: 74 70 61 74 74 0a 20 20 20 20 20 20 28 64 65 62 tpatt. (deb
8010: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
8020: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8030: 74 2a 20 22 2d 74 61 67 65 78 70 72 20 22 74 61 t* "-tagexpr "ta
8040: 67 65 78 70 72 22 20 73 65 6c 65 63 74 73 20 74 gexpr" selects t
8050: 65 73 74 70 61 74 74 20 22 74 61 67 73 2d 74 65 estpatt "tags-te
8060: 73 74 70 61 74 74 29 0a 20 20 20 20 20 20 74 61 stpatt). ta
8070: 67 73 2d 74 65 73 74 70 61 74 74 29 0a 20 20 20 gs-testpatt).
8080: 20 20 28 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 ((and (equal?
8090: 61 72 67 73 2d 74 65 73 74 70 61 74 74 20 22 25 args-testpatt "%
80a0: 22 29 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 ") rtestpatt).
80b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
80c0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
80d0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
80e0: 70 61 74 74 20 64 65 66 69 6e 65 64 20 69 6e 20 patt defined in
80f0: 22 74 65 73 74 70 61 74 74 2d 6b 65 79 22 20 66 "testpatt-key" f
8100: 72 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 3a 20 rom runconfigs:
8110: 22 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 20 " rtestpatt).
8120: 20 20 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 rtestpatt).
8130: 20 20 20 28 65 6c 73 65 20 61 72 67 73 2d 74 65 (else args-te
8140: 73 74 70 61 74 74 29 29 29 29 0a 20 20 20 20 20 stpatt)))).
8150: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
8160: 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 :get-linktree).
8170: 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d 54 (or (getenv "MT
8180: 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 20 20 20 20 _LINKTREE").
8190: 20 20 28 69 66 20 2a 63 6f 6e 66 69 67 64 61 74 (if *configdat
81a0: 2a 0a 09 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f *.. (configf:lo
81b0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
81c0: 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 "setup" "linktr
81d0: 65 65 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ee"))))..(define
81e0: 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 (common:args-ge
81f0: 74 2d 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 t-runname). (le
8200: 74 20 28 28 72 65 73 20 28 6f 72 20 28 61 72 67 t ((res (or (arg
8210: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e s:get-arg "-runn
8220: 61 6d 65 22 29 0a 09 09 20 28 61 72 67 73 3a 67 ame")... (args:g
8230: 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 et-arg ":runname
8240: 22 29 0a 09 09 20 28 67 65 74 65 6e 76 20 22 4d ")... (getenv "M
8250: 54 5f 52 55 4e 4e 41 4d 45 22 29 29 29 29 0a 20 T_RUNNAME")))).
8260: 20 20 20 3b 3b 20 28 69 66 20 72 65 73 20 28 73 ;; (if res (s
8270: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
8280: 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 4e ariable "MT_RUNN
8290: 41 4d 45 22 20 72 65 73 29 29 20 3b 3b 20 6e 6f AME" res)) ;; no
82a0: 74 20 73 75 72 65 20 69 66 20 74 68 69 73 20 69 t sure if this i
82b0: 73 20 61 20 67 6f 6f 64 20 69 64 65 61 2e 20 73 s a good idea. s
82c0: 69 64 65 20 65 66 66 65 63 74 20 61 6e 64 20 61 ide effect and a
82d0: 6c 6c 20 2e 2e 2e 0a 20 20 20 20 72 65 73 29 29 ll .... res))
82e0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
82f0: 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 n:args-get-targe
8300: 74 20 23 21 6b 65 79 20 28 73 70 6c 69 74 20 23 t #!key (split #
8310: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 f)). (let* ((ke
8320: 79 73 20 20 20 20 28 69 66 20 28 68 61 73 68 2d ys (if (hash-
8330: 74 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 61 table? *configda
8340: 74 2a 29 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 t*) (keys:config
8350: 2d 67 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e -get-fields *con
8360: 66 69 67 64 61 74 2a 29 20 27 28 29 29 29 0a 09 figdat*) '()))..
8370: 20 28 6e 75 6d 6b 65 79 73 20 28 6c 65 6e 67 74 (numkeys (lengt
8380: 68 20 6b 65 79 73 29 29 0a 09 20 28 74 61 72 67 h keys)).. (targ
8390: 65 74 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 et (or (args:ge
83a0: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
83b0: 29 0a 09 09 20 20 20 20 20 20 28 61 72 67 73 3a )... (args:
83c0: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
83d0: 22 29 0a 09 09 20 20 20 20 20 20 28 67 65 74 65 ")... (gete
83e0: 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 nv "MT_TARGET"))
83f0: 29 0a 09 20 28 74 6c 69 73 74 20 20 20 28 69 66 ).. (tlist (if
8400: 20 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 2d target (string-
8410: 73 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 split target "/"
8420: 20 23 74 29 20 27 28 29 29 29 0a 09 20 28 76 61 #t) '())).. (va
8430: 6c 69 64 20 20 20 28 69 66 20 74 61 72 67 65 74 lid (if target
8440: 0a 09 09 20 20 20 20 20 20 28 6f 72 20 28 6e 75 ... (or (nu
8450: 6c 6c 3f 20 6b 65 79 73 29 20 3b 3b 20 70 72 6f ll? keys) ;; pro
8460: 62 61 62 6c 79 20 64 6f 6e 27 74 20 6b 6e 6f 77 bably don't know
8470: 20 6f 75 72 20 6b 65 79 73 20 79 65 74 0a 09 09 our keys yet...
8480: 09 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 . (and (not (nu
8490: 6c 6c 3f 20 74 6c 69 73 74 29 29 0a 09 09 09 20 ll? tlist))....
84a0: 20 20 20 20 20 20 28 65 71 3f 20 6e 75 6d 6b 65 (eq? numke
84b0: 79 73 20 28 6c 65 6e 67 74 68 20 74 6c 69 73 74 ys (length tlist
84c0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e 75 )).... (nu
84d0: 6c 6c 3f 20 28 66 69 6c 74 65 72 20 73 74 72 69 ll? (filter stri
84e0: 6e 67 2d 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 29 ng-null? tlist))
84f0: 29 29 0a 09 09 20 20 20 20 20 20 23 66 29 29 29 ))... #f)))
8500: 0a 20 20 20 20 28 69 66 20 76 61 6c 69 64 0a 09 . (if valid..
8510: 28 69 66 20 73 70 6c 69 74 0a 09 20 20 20 20 74 (if split.. t
8520: 6c 69 73 74 0a 09 20 20 20 20 74 61 72 67 65 74 list.. target
8530: 29 0a 09 28 69 66 20 74 61 72 67 65 74 0a 09 20 )..(if target..
8540: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
8550: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
8560: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
8570: 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 76 61 6c 69 og-port* "Invali
8580: 64 20 74 61 72 67 65 74 2c 20 73 70 61 63 65 73 d target, spaces
8590: 20 6f 72 20 62 6c 61 6e 6b 73 20 6e 6f 74 20 61 or blanks not a
85a0: 6c 6c 6f 77 65 64 20 5c 22 22 20 74 61 72 67 65 llowed \"" targe
85b0: 74 20 22 5c 22 2c 20 74 61 72 67 65 74 20 73 68 t "\", target sh
85c0: 6f 75 6c 64 20 62 65 3a 20 22 20 28 73 74 72 69 ould be: " (stri
85d0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6b ng-intersperse k
85e0: 65 79 73 20 22 2f 22 29 20 22 2c 20 68 61 76 65 eys "/") ", have
85f0: 20 22 20 74 6c 69 73 74 20 22 20 66 6f 72 20 65 " tlist " for e
8600: 6c 65 6d 65 6e 74 73 22 29 0a 09 20 20 20 20 20 lements")..
8610: 20 23 66 29 0a 09 20 20 20 20 23 66 29 29 29 29 #f).. #f))))
8620: 0a 0a 3b 3b 20 6c 6f 67 69 63 20 66 6f 72 20 67 ..;; logic for g
8630: 65 74 74 69 6e 67 20 68 6f 6d 65 68 6f 73 74 2e etting homehost.
8640: 20 52 65 74 75 72 6e 73 20 28 68 6f 73 74 20 2e Returns (host .
8650: 20 61 74 2d 68 6f 6d 65 29 0a 3b 3b 20 49 46 20 at-home).;; IF
8660: 2a 74 6f 70 70 61 74 68 2a 20 69 73 20 6e 6f 74 *toppath* is not
8670: 20 73 65 74 2c 20 77 61 69 74 20 75 70 20 74 6f set, wait up to
8680: 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 74 72 five seconds tr
8690: 79 69 6e 67 20 65 76 65 72 79 20 74 77 6f 20 73 ying every two s
86a0: 65 63 6f 6e 64 73 0a 3b 3b 20 28 74 68 69 73 20 econds.;; (this
86b0: 69 73 20 74 6f 20 61 63 63 6f 6d 6f 64 61 74 65 is to accomodate
86c0: 20 74 68 65 20 77 61 74 63 68 64 6f 67 29 0a 3b the watchdog).;
86d0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
86e0: 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 20 23 n:get-homehost #
86f0: 21 6b 65 79 20 28 74 72 79 6e 75 6d 20 35 29 29 !key (trynum 5))
8700: 0a 20 20 3b 3b 20 63 61 6c 6c 65 64 20 6f 66 74 . ;; called oft
8710: 65 6e 20 65 73 70 65 63 69 61 6c 6c 79 20 61 74 en especially at
8720: 20 73 74 61 72 74 20 75 70 2e 20 75 73 65 20 6d start up. use m
8730: 75 74 65 78 20 74 6f 20 65 6c 69 6d 69 6e 61 74 utex to eliminat
8740: 65 20 63 6f 6c 6c 69 73 69 6f 6e 73 0a 20 20 28 e collisions. (
8750: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 6f 6d mutex-lock! *hom
8760: 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 ehost-mutex*).
8770: 28 63 6f 6e 64 0a 20 20 20 28 2a 68 6f 6d 65 2d (cond. (*home-
8780: 68 6f 73 74 2a 0a 20 20 20 20 28 6d 75 74 65 78 host*. (mutex
8790: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f -unlock! *homeho
87a0: 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 2a st-mutex*). *
87b0: 68 6f 6d 65 2d 68 6f 73 74 2a 29 0a 20 20 20 28 home-host*). (
87c0: 28 6e 6f 74 20 2a 74 6f 70 70 61 74 68 2a 29 0a (not *toppath*).
87d0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
87e0: 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 k! *homehost-mut
87f0: 65 78 2a 29 0a 20 20 20 20 28 6c 61 75 6e 63 68 ex*). (launch
8800: 3a 73 65 74 75 70 29 20 3b 3b 20 73 61 66 65 6c :setup) ;; safel
8810: 79 20 6d 75 74 65 78 65 64 20 6e 6f 77 0a 20 20 y mutexed now.
8820: 20 20 28 69 66 20 28 3e 20 74 72 79 6e 75 6d 20 (if (> trynum
8830: 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 74 0)..(begin.. (t
8840: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a hread-sleep! 2).
8850: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 . (common:get-h
8860: 6f 6d 65 68 6f 73 74 20 74 72 79 6e 75 6d 3a 20 omehost trynum:
8870: 28 2d 20 74 72 79 6e 75 6d 20 31 29 29 29 0a 09 (- trynum 1)))..
8880: 23 66 29 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 #f)). (else.
8890: 20 20 28 6c 65 74 2a 20 28 28 63 75 72 72 68 6f (let* ((currho
88a0: 73 74 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d st (get-host-nam
88b0: 65 29 29 0a 09 20 20 20 28 62 65 73 74 61 64 72 e)).. (bestadr
88c0: 73 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 s (server:get-be
88d0: 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 st-guess-address
88e0: 20 63 75 72 72 68 6f 73 74 29 29 0a 09 20 20 20 currhost))..
88f0: 3b 3b 20 66 69 72 73 74 20 6c 6f 6f 6b 20 69 6e ;; first look in
8900: 20 63 6f 6e 66 69 67 2c 20 74 68 65 6e 20 6c 6f config, then lo
8910: 6f 6b 20 69 6e 20 66 69 6c 65 20 2e 68 6f 6d 65 ok in file .home
8920: 68 6f 73 74 2c 20 63 72 65 61 74 65 20 69 74 20 host, create it
8930: 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 20 20 if not found..
8940: 20 28 68 6f 6d 65 68 6f 73 74 20 28 6f 72 20 28 (homehost (or (
8950: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
8960: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 configdat* "serv
8970: 65 72 22 20 22 68 6f 6d 65 68 6f 73 74 22 20 29 er" "homehost" )
8980: 0a 09 09 09 20 28 6c 65 74 20 28 28 68 68 66 20 .... (let ((hhf
8990: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
89a0: 22 2f 2e 68 6f 6d 65 68 6f 73 74 22 29 29 29 0a "/.homehost"))).
89b0: 09 09 09 20 20 20 28 69 66 20 28 66 69 6c 65 2d ... (if (file-
89c0: 65 78 69 73 74 73 3f 20 68 68 66 29 0a 09 09 09 exists? hhf)....
89d0: 20 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 (with-inp
89e0: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 68 68 66 ut-from-file hhf
89f0: 20 72 65 61 64 2d 6c 69 6e 65 29 0a 09 09 09 20 read-line)....
8a00: 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d (if (file-
8a10: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 write-access? *t
8a20: 6f 70 70 61 74 68 2a 29 0a 09 09 09 09 20 20 20 oppath*).....
8a30: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 (begin.....
8a40: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
8a50: 66 69 6c 65 20 68 68 66 0a 09 09 09 09 20 20 20 file hhf.....
8a60: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
8a70: 09 09 09 09 20 28 70 72 69 6e 74 20 62 65 73 74 .... (print best
8a80: 61 64 72 73 29 29 29 0a 09 09 09 09 20 20 20 20 adrs))).....
8a90: 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 (begin.....
8aa0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
8ab0: 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 ! *homehost-mute
8ac0: 78 2a 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 x*)..... (
8ad0: 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d car (common:get-
8ae0: 68 6f 6d 65 68 6f 73 74 29 29 29 29 0a 09 09 09 homehost))))....
8af0: 09 20 20 20 23 66 29 29 29 29 29 0a 09 20 20 20 . #f)))))..
8b00: 28 61 74 2d 68 6f 6d 65 20 20 28 6f 72 20 28 65 (at-home (or (e
8b10: 71 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 63 qual? homehost c
8b20: 75 72 72 68 6f 73 74 29 0a 09 09 09 20 28 65 71 urrhost).... (eq
8b30: 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 62 65 ual? homehost be
8b40: 73 74 61 64 72 73 29 29 29 29 0a 20 20 20 20 20 stadrs)))).
8b50: 20 28 73 65 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 (set! *home-hos
8b60: 74 2a 20 28 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 t* (cons homehos
8b70: 74 20 61 74 2d 68 6f 6d 65 29 29 0a 20 20 20 20 t at-home)).
8b80: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
8b90: 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 *homehost-mutex
8ba0: 2a 29 0a 20 20 20 20 20 20 2a 68 6f 6d 65 2d 68 *). *home-h
8bb0: 6f 73 74 2a 29 29 29 29 0a 0a 3b 3b 20 61 6d 20 ost*))))..;; am
8bc0: 49 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 I on the homehos
8bd0: 74 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 t?.;;.(define (c
8be0: 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 ommon:on-homehos
8bf0: 74 3f 29 0a 20 20 28 6c 65 74 20 28 28 68 68 20 t?). (let ((hh
8c00: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 (common:get-home
8c10: 68 6f 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 host))). (if
8c20: 68 68 0a 09 28 63 64 72 20 68 68 29 0a 09 23 66 hh..(cdr hh)..#f
8c30: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
8c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
8c80: 20 4d 20 49 20 53 20 43 20 20 20 4c 20 49 20 53 M I S C L I S
8c90: 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;=========
8ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
8ce0: 3b 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 61 ; items in lista
8cf0: 20 61 72 65 20 6d 61 74 63 68 65 64 20 76 61 6c are matched val
8d00: 75 65 20 61 6e 64 20 70 6f 73 69 74 69 6f 6e 20 ue and position
8d10: 69 6e 20 6c 69 73 74 62 0a 3b 3b 20 72 65 74 75 in listb.;; retu
8d20: 72 6e 20 74 68 65 20 72 65 6d 61 69 6e 69 6e 67 rn the remaining
8d30: 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 items in listb
8d40: 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 or #f.;;.(define
8d50: 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 69 73 (common:list-is
8d60: 2d 73 75 62 6c 69 73 74 20 6c 69 73 74 61 20 6c -sublist lista l
8d70: 69 73 74 62 29 0a 20 20 28 69 66 20 28 6e 75 6c istb). (if (nul
8d80: 6c 3f 20 6c 69 73 74 61 29 0a 20 20 20 20 20 20 l? lista).
8d90: 6c 69 73 74 62 20 3b 3b 20 61 6c 6c 20 69 74 65 listb ;; all ite
8da0: 6d 73 20 69 6e 20 6c 69 73 74 62 20 61 72 65 20 ms in listb are
8db0: 22 72 65 6d 61 69 6e 69 6e 67 22 0a 20 20 20 20 "remaining".
8dc0: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
8dd0: 20 6c 69 73 74 61 29 28 6c 65 6e 67 74 68 20 6c lista)(length l
8de0: 69 73 74 62 29 29 20 0a 09 20 20 23 66 0a 09 20 istb)) .. #f..
8df0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
8e00: 61 20 28 63 61 72 20 6c 69 73 74 61 29 29 0a 09 a (car lista))..
8e10: 09 20 20 20 20 20 28 74 61 6c 61 20 28 63 64 72 . (tala (cdr
8e20: 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 20 lista))...
8e30: 28 68 65 64 62 20 28 63 61 72 20 6c 69 73 74 62 (hedb (car listb
8e40: 29 29 0a 09 09 20 20 20 20 20 28 74 61 6c 62 20 ))... (talb
8e50: 28 63 64 72 20 6c 69 73 74 62 29 29 29 0a 09 20 (cdr listb)))..
8e60: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 68 (if (equal? h
8e70: 65 64 61 20 68 65 64 62 29 0a 09 09 28 69 66 20 eda hedb)...(if
8e80: 28 6e 75 6c 6c 3f 20 74 61 6c 61 29 20 3b 3b 20 (null? tala) ;;
8e90: 77 65 20 61 72 65 20 64 6f 6e 65 0a 09 09 20 20 we are done...
8ea0: 20 20 74 61 6c 62 0a 09 09 20 20 20 20 28 6c 6f talb... (lo
8eb0: 6f 70 20 28 63 61 72 20 74 61 6c 61 29 0a 09 09 op (car tala)...
8ec0: 09 20 20 28 63 64 72 20 74 61 6c 61 29 0a 09 09 . (cdr tala)...
8ed0: 09 20 20 28 63 61 72 20 74 61 6c 62 29 0a 09 09 . (car talb)...
8ee0: 09 20 20 0a 09 09 09 20 20 28 63 64 72 20 74 61 . .... (cdr ta
8ef0: 6c 62 29 29 29 0a 09 09 23 66 29 29 29 29 29 0a lb)))...#f))))).
8f00: 0a 3b 3b 20 4e 65 65 64 65 64 20 66 6f 72 20 6c .;; Needed for l
8f10: 6f 6e 67 20 6c 69 73 74 73 20 74 6f 20 62 65 20 ong lists to be
8f20: 73 6f 72 74 65 64 20 77 68 65 72 65 20 28 61 70 sorted where (ap
8f30: 70 6c 79 20 6d 61 78 20 2e 2e 2e 20 29 20 64 69 ply max ... ) di
8f40: 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 es.;;.(define (c
8f50: 6f 6d 6d 6f 6e 3a 6d 61 78 20 69 6e 6c 73 74 29 ommon:max inlst)
8f60: 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6d . (let loop ((m
8f70: 61 78 2d 76 61 6c 20 28 63 61 72 20 69 6e 6c 73 ax-val (car inls
8f80: 74 29 29 0a 09 20 20 20 20 20 28 68 65 64 20 20 t)).. (hed
8f90: 20 20 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a (car inlst)).
8fa0: 09 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 28 . (tal (
8fb0: 63 64 72 20 69 6e 6c 73 74 29 29 29 0a 20 20 20 cdr inlst))).
8fc0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
8fd0: 20 74 61 6c 29 29 0a 09 28 6c 6f 6f 70 20 28 6d tal))..(loop (m
8fe0: 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 0a ax hed max-val).
8ff0: 09 20 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 . (car tal)
9000: 0a 09 20 20 20 20 20 20 28 63 64 72 20 74 61 6c .. (cdr tal
9010: 29 29 0a 09 28 6d 61 78 20 68 65 64 20 6d 61 78 ))..(max hed max
9020: 2d 76 61 6c 29 29 29 29 0a 0a 3b 3b 20 67 65 74 -val))))..;; get
9030: 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 75 73 65 min or max, use
9040: 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e 64 20 3c > for max and <
9050: 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 73 20 77 for min, this w
9060: 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 68 65 20 orks around the
9070: 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 6c 79 0a limits on apply.
9080: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
9090: 6f 6e 3a 6d 69 6e 2d 6d 61 78 20 63 6f 6d 70 20 on:min-max comp
90a0: 6c 73 74 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c lst). (if (null
90b0: 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 23 66 20 ? lst). #f
90c0: 3b 3b 20 62 65 74 74 65 72 20 74 68 61 6e 20 61 ;; better than a
90d0: 6e 20 65 78 63 65 70 74 69 6f 6e 20 66 6f 72 20 n exception for
90e0: 6d 79 20 6e 65 65 64 73 0a 20 20 20 20 20 20 28 my needs. (
90f0: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 20 fold (lambda (a
9100: 62 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 63 b).. (if (c
9110: 6f 6d 70 20 61 20 62 29 20 61 20 62 29 29 0a 09 omp a b) a b))..
9120: 20 20 20 20 28 63 61 72 20 6c 73 74 29 0a 09 20 (car lst)..
9130: 20 20 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 67 65 lst)))..;; ge
9140: 74 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 75 73 t min or max, us
9150: 65 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e 64 20 e > for max and
9160: 3c 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 73 20 < for min, this
9170: 77 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 68 65 works around the
9180: 20 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 6c 79 limits on apply
9190: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
91a0: 6d 6f 6e 3a 73 75 6d 20 6c 73 74 29 0a 20 20 28 mon:sum lst). (
91b0: 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 29 0a 20 if (null? lst).
91c0: 20 20 20 20 20 30 0a 20 20 20 20 20 20 28 66 6f 0. (fo
91d0: 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ld (lambda (a b)
91e0: 0a 09 20 20 20 20 20 20 28 2b 20 61 20 62 29 29 .. (+ a b))
91f0: 0a 09 20 20 20 20 28 63 61 72 20 6c 73 74 29 0a .. (car lst).
9200: 09 20 20 20 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 . lst)))..;;
9210: 70 61 74 68 20 6c 69 73 74 20 74 6f 20 68 61 73 path list to has
9220: 68 2d 74 61 62 6c 65 20 74 72 65 65 0a 3b 3b 20 h-table tree.;;
9230: 20 20 28 28 61 20 62 20 63 29 28 61 20 62 20 64 ((a b c)(a b d
9240: 29 28 65 20 62 20 63 29 29 20 3d 3e 20 28 28 61 )(e b c)) => ((a
9250: 20 28 62 20 28 64 29 20 28 63 29 29 29 20 28 65 (b (d) (c))) (e
9260: 20 28 62 20 28 63 29 29 29 29 0a 3b 3b 0a 28 64 (b (c)))).;;.(d
9270: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 efine (common:li
9280: 73 74 2d 3e 68 74 72 65 65 20 6c 73 74 29 0a 20 st->htree lst).
9290: 20 28 6c 65 74 20 28 28 72 65 73 68 20 28 6d 61 (let ((resh (ma
92a0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
92b0: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
92c0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 6e 6c (lambda (inl
92d0: 73 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 st). (let
92e0: 6c 6f 6f 70 20 28 28 68 74 20 20 72 65 73 68 29 loop ((ht resh)
92f0: 0a 09 09 20 20 28 68 65 64 20 28 63 61 72 20 69 ... (hed (car i
9300: 6e 6c 73 74 29 29 0a 09 09 20 20 28 74 61 6c 20 nlst))... (tal
9310: 28 63 64 72 20 69 6e 6c 73 74 29 29 29 0a 09 20 (cdr inlst)))..
9320: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
9330: 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 68 ref/default ht h
9340: 65 64 20 23 66 29 0a 09 20 20 20 20 20 28 69 66 ed #f).. (if
9350: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
9360: 29 29 0a 09 09 20 28 6c 6f 6f 70 20 28 68 61 73 ))... (loop (has
9370: 68 2d 74 61 62 6c 65 2d 72 65 66 20 68 74 20 68 h-table-ref ht h
9380: 65 64 29 0a 09 09 20 20 20 20 20 20 20 28 63 61 ed)... (ca
9390: 72 20 74 61 6c 29 0a 09 09 20 20 20 20 20 20 20 r tal)...
93a0: 28 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 20 (cdr tal)))..
93b0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
93c0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
93d0: 21 20 68 74 20 68 65 64 20 28 6d 61 6b 65 2d 68 ! ht hed (make-h
93e0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 ash-table))..
93f0: 20 20 20 20 28 6c 6f 6f 70 20 68 74 20 68 65 64 (loop ht hed
9400: 20 74 61 6c 29 29 29 29 29 0a 20 20 20 20 20 6c tal))))). l
9410: 73 74 29 0a 20 20 20 20 72 65 73 68 29 29 0a 0a st). resh))..
9420: 3b 3b 20 68 61 73 68 2d 74 61 62 6c 65 20 74 72 ;; hash-table tr
9430: 65 65 20 74 6f 20 68 74 6d 6c 20 6c 69 73 74 20 ee to html list
9440: 74 72 65 65 0a 3b 3b 0a 3b 3b 20 20 20 74 69 70 tree.;;.;; tip
9450: 66 75 6e 63 20 74 61 6b 65 73 20 74 77 6f 20 70 func takes two p
9460: 61 72 61 6d 65 74 65 72 73 3a 20 79 20 74 68 65 arameters: y the
9470: 20 74 69 70 20 76 61 6c 75 65 20 61 6e 64 20 70 tip value and p
9480: 61 74 68 20 74 68 65 20 70 61 74 68 20 74 6f 20 ath the path to
9490: 74 68 61 74 20 70 6f 69 6e 74 0a 3b 3b 0a 28 64 that point.;;.(d
94a0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 efine (common:ht
94b0: 72 65 65 2d 3e 68 74 6d 6c 20 68 74 20 70 61 74 ree->html ht pat
94c0: 68 20 74 69 70 66 75 6e 63 29 0a 20 20 28 6c 65 h tipfunc). (le
94d0: 74 20 28 28 64 61 74 6c 69 73 74 20 09 28 73 6f t ((datlist .(so
94e0: 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e rt (hash-table->
94f0: 61 6c 69 73 74 20 68 74 29 0a 20 20 20 20 20 20 alist ht).
9500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9510: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
9520: 28 61 20 62 29 0a 20 20 20 20 20 20 20 20 20 20 (a b).
9530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9540: 20 20 20 20 20 20 28 73 74 72 69 6e 67 3c 20 28 (string< (
9550: 63 61 72 20 61 29 28 63 61 72 20 62 29 29 29 29 car a)(car b))))
9560: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c )). (if (null
9570: 3f 20 64 61 74 6c 69 73 74 29 0a 20 20 20 20 09 ? datlist). .
9580: 28 74 69 70 66 75 6e 63 20 23 66 20 70 61 74 68 (tipfunc #f path
9590: 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f 75 ) ;; really shou
95a0: 6c 64 6e 27 74 20 67 65 74 20 68 65 72 65 0a 09 ldn't get here..
95b0: 28 73 3a 75 6c 0a 09 20 28 6d 61 70 20 28 6c 61 (s:ul.. (map (la
95c0: 6d 62 64 61 20 28 78 29 0a 09 09 28 6c 65 74 2a mbda (x)...(let*
95d0: 20 28 28 6c 65 76 65 6c 6e 61 6d 65 20 28 63 61 ((levelname (ca
95e0: 72 20 78 29 29 0a 09 09 20 20 20 20 20 20 20 28 r x))... (
95f0: 79 20 20 20 20 20 20 20 20 20 28 63 64 72 20 78 y (cdr x
9600: 29 29 0a 09 09 20 20 20 20 20 20 20 28 6e 65 77 ))... (new
9610: 70 61 74 68 20 20 20 28 61 70 70 65 6e 64 20 70 path (append p
9620: 61 74 68 20 28 6c 69 73 74 20 6c 65 76 65 6c 6e ath (list leveln
9630: 61 6d 65 29 29 29 0a 09 09 20 20 20 20 20 20 20 ame)))...
9640: 28 6c 65 61 66 20 20 20 20 20 20 28 6f 72 20 28 (leaf (or (
9650: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 3f not (hash-table?
9660: 20 79 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 y))..... (
9670: 6e 75 6c 6c 3f 20 28 68 61 73 68 2d 74 61 62 6c null? (hash-tabl
9680: 65 2d 6b 65 79 73 20 79 29 29 29 29 29 0a 09 09 e-keys y)))))...
9690: 20 20 28 69 66 20 6c 65 61 66 0a 09 09 20 20 20 (if leaf...
96a0: 20 20 20 28 73 3a 6c 69 20 28 74 69 70 66 75 6e (s:li (tipfun
96b0: 63 20 79 20 6e 65 77 70 61 74 68 29 29 0a 09 09 c y newpath))...
96c0: 20 20 20 20 20 20 28 73 3a 6c 69 0a 09 09 20 20 (s:li...
96d0: 20 20 20 20 20 28 6c 69 73 74 20 0a 09 09 09 6c (list ....l
96e0: 65 76 65 6c 6e 61 6d 65 0a 09 09 09 28 63 6f 6d evelname....(com
96f0: 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 mon:htree->html
9700: 79 20 6e 65 77 70 61 74 68 20 74 69 70 66 75 6e y newpath tipfun
9710: 63 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 64 c)))))).. d
9720: 61 74 6c 69 73 74 29 29 29 29 29 0a 0a 3b 3b 20 atlist)))))..;;
9730: 68 61 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 hash-table tree
9740: 74 6f 20 61 6c 69 73 74 20 74 72 65 65 0a 3b 3b to alist tree.;;
9750: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
9760: 3a 68 74 72 65 65 2d 3e 61 74 72 65 65 20 68 74 :htree->atree ht
9770: 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 ). (map (lambda
9780: 20 28 78 29 0a 09 20 28 63 6f 6e 73 20 28 63 61 (x).. (cons (ca
9790: 72 20 78 29 0a 09 20 20 20 20 20 20 20 28 6c 65 r x).. (le
97a0: 74 20 28 28 79 20 28 63 64 72 20 78 29 29 29 0a t ((y (cdr x))).
97b0: 09 09 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 .. (if (hash-tab
97c0: 6c 65 3f 20 79 29 0a 09 09 20 20 20 20 20 28 63 le? y)... (c
97d0: 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 61 74 72 ommon:htree->atr
97e0: 65 65 20 79 29 0a 09 09 20 20 20 20 20 79 29 29 ee y)... y))
97f0: 29 29 0a 20 20 20 20 20 20 20 28 68 61 73 68 2d )). (hash-
9800: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 74 29 table->alist ht)
9810: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
9820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
9860: 4d 20 55 20 4e 20 47 20 45 20 20 20 44 20 41 20 M U N G E D A
9870: 54 20 41 20 20 20 49 20 4e 20 54 20 4f 20 20 20 T A I N T O
9880: 4e 20 49 20 43 20 45 20 20 20 46 20 4f 20 52 20 N I C E F O R
9890: 4d 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d M S.;;==========
98a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
98e0: 20 47 65 6e 65 72 61 74 65 20 61 6e 20 69 6e 64 Generate an ind
98f0: 65 78 20 66 6f 72 20 61 20 73 70 61 72 73 65 20 ex for a sparse
9900: 6c 69 73 74 20 6f 66 20 6b 65 79 20 76 61 6c 75 list of key valu
9910: 65 73 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e 61 es.;; ( (rowna
9920: 6d 65 31 20 63 6f 6c 6e 61 6d 65 31 20 76 61 6c me1 colname1 val
9930: 31 29 28 72 6f 77 6e 61 6d 65 32 20 63 6f 6c 6e 1)(rowname2 coln
9940: 61 6d 65 32 20 76 61 6c 32 29 20 29 0a 3b 3b 0a ame2 val2) ).;;.
9950: 3b 3b 20 3d 3e 20 0a 3b 3b 0a 3b 3b 20 20 20 28 ;; => .;;.;; (
9960: 20 28 72 6f 77 6e 61 6d 65 31 20 30 29 28 72 6f (rowname1 0)(ro
9970: 77 6e 61 6d 65 32 20 31 29 29 20 20 20 20 3b 3b wname2 1)) ;;
9980: 20 72 6f 77 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d rownames -> num
9990: 0a 3b 3b 20 20 20 20 20 28 63 6f 6c 6e 61 6d 65 .;; (colname
99a0: 31 20 30 29 28 63 6f 6c 6e 61 6d 65 32 20 31 29 1 0)(colname2 1)
99b0: 29 20 29 20 20 3b 3b 20 63 6f 6c 6e 61 6d 65 73 ) ) ;; colnames
99c0: 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f -> num.;; .;; o
99d0: 70 74 69 6f 6e 61 6c 20 61 70 70 6c 79 20 70 72 ptional apply pr
99e0: 6f 63 20 74 6f 20 72 6f 77 6e 75 6d 20 63 6f 6c oc to rownum col
99f0: 6e 75 6d 20 76 61 6c 75 65 0a 28 64 65 66 69 6e num value.(defin
9a00: 65 20 28 63 6f 6d 6d 6f 6e 3a 73 70 61 72 73 65 e (common:sparse
9a10: 2d 6c 69 73 74 2d 67 65 6e 65 72 61 74 65 2d 69 -list-generate-i
9a20: 6e 64 65 78 20 64 61 74 61 20 23 21 6b 65 79 20 ndex data #!key
9a30: 28 70 72 6f 63 20 23 66 29 29 0a 20 20 28 69 66 (proc #f)). (if
9a40: 20 28 6e 75 6c 6c 3f 20 64 61 74 61 29 0a 20 20 (null? data).
9a50: 20 20 20 20 28 6c 69 73 74 20 27 28 29 20 27 28 (list '() '(
9a60: 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f )). (let lo
9a70: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 64 61 op ((hed (car da
9a80: 74 61 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 ta))... (tal (cd
9a90: 72 20 64 61 74 61 29 29 0a 09 09 20 28 72 6f 77 r data))... (row
9aa0: 6e 61 6d 65 73 20 27 28 29 29 0a 09 09 20 28 63 names '())... (c
9ab0: 6f 6c 6e 61 6d 65 73 20 27 28 29 29 0a 09 09 20 olnames '())...
9ac0: 28 72 6f 77 6e 75 6d 20 20 20 30 29 0a 09 09 20 (rownum 0)...
9ad0: 28 63 6f 6c 6e 75 6d 20 20 20 30 29 29 0a 09 28 (colnum 0))..(
9ae0: 6c 65 74 2a 20 28 28 72 6f 77 6b 65 79 20 20 20 let* ((rowkey
9af0: 20 20 20 20 20 20 20 28 63 61 72 20 20 20 68 65 (car he
9b00: 64 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6c d)).. (col
9b10: 6b 65 79 20 20 20 20 20 20 20 20 20 20 28 63 61 key (ca
9b20: 64 72 20 20 68 65 64 29 29 0a 09 20 20 20 20 20 dr hed))..
9b30: 20 20 28 76 61 6c 75 65 20 20 20 20 20 20 20 20 (value
9b40: 20 20 20 28 63 61 64 64 72 20 68 65 64 29 29 0a (caddr hed)).
9b50: 09 20 20 20 20 20 20 20 28 65 78 69 73 74 69 6e . (existin
9b60: 67 2d 72 6f 77 64 61 74 20 28 61 73 73 6f 63 20 g-rowdat (assoc
9b70: 72 6f 77 6b 65 79 20 72 6f 77 6e 61 6d 65 73 29 rowkey rownames)
9b80: 29 0a 09 20 20 20 20 20 20 20 28 65 78 69 73 74 ).. (exist
9b90: 69 6e 67 2d 63 6f 6c 64 61 74 20 28 61 73 73 6f ing-coldat (asso
9ba0: 63 20 63 6f 6c 6b 65 79 20 63 6f 6c 6e 61 6d 65 c colkey colname
9bb0: 73 29 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 s)).. (cur
9bc0: 72 2d 72 6f 77 6e 75 6d 20 20 20 20 20 28 69 66 r-rownum (if
9bd0: 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 existing-rowdat
9be0: 20 72 6f 77 6e 75 6d 20 28 2b 20 72 6f 77 6e 75 rownum (+ rownu
9bf0: 6d 20 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 m 1))).. (
9c00: 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 20 20 20 20 curr-colnum
9c10: 28 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c (if existing-col
9c20: 64 61 74 20 63 6f 6c 6e 75 6d 20 28 2b 20 63 6f dat colnum (+ co
9c30: 6c 6e 75 6d 20 31 29 29 29 0a 09 20 20 20 20 20 lnum 1)))..
9c40: 20 20 28 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 (new-rownames
9c50: 20 20 20 28 69 66 20 65 78 69 73 74 69 6e 67 2d (if existing-
9c60: 72 6f 77 64 61 74 20 72 6f 77 6e 61 6d 65 73 20 rowdat rownames
9c70: 28 63 6f 6e 73 20 28 6c 69 73 74 20 72 6f 77 6b (cons (list rowk
9c80: 65 79 20 63 75 72 72 2d 72 6f 77 6e 75 6d 29 20 ey curr-rownum)
9c90: 72 6f 77 6e 61 6d 65 73 29 29 29 0a 09 20 20 20 rownames)))..
9ca0: 20 20 20 20 28 6e 65 77 2d 63 6f 6c 6e 61 6d 65 (new-colname
9cb0: 73 20 20 20 20 28 69 66 20 65 78 69 73 74 69 6e s (if existin
9cc0: 67 2d 63 6f 6c 64 61 74 20 63 6f 6c 6e 61 6d 65 g-coldat colname
9cd0: 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 63 6f s (cons (list co
9ce0: 6c 6b 65 79 20 63 75 72 72 2d 63 6f 6c 6e 75 6d lkey curr-colnum
9cf0: 29 20 63 6f 6c 6e 61 6d 65 73 29 29 29 29 0a 09 ) colnames))))..
9d00: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
9d10: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
9d20: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 72 6f t-log-port* "Pro
9d30: 63 65 73 73 69 6e 67 20 72 65 63 6f 72 64 3a 20 cessing record:
9d40: 22 20 68 65 64 20 29 0a 09 20 20 28 69 66 20 70 " hed ).. (if p
9d50: 72 6f 63 20 28 70 72 6f 63 20 63 75 72 72 2d 72 roc (proc curr-r
9d60: 6f 77 6e 75 6d 20 63 75 72 72 2d 63 6f 6c 6e 75 ownum curr-colnu
9d70: 6d 20 72 6f 77 6b 65 79 20 63 6f 6c 6b 65 79 20 m rowkey colkey
9d80: 76 61 6c 75 65 29 29 0a 09 20 20 28 69 66 20 28 value)).. (if (
9d90: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 null? tal)..
9da0: 20 20 28 6c 69 73 74 20 6e 65 77 2d 72 6f 77 6e (list new-rown
9db0: 61 6d 65 73 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 ames new-colname
9dc0: 73 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 s).. (loop
9dd0: 28 63 61 72 20 74 61 6c 29 0a 09 09 20 20 20 20 (car tal)...
9de0: 28 63 64 72 20 74 61 6c 29 0a 09 09 20 20 20 20 (cdr tal)...
9df0: 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 0a 09 09 20 new-rownames...
9e00: 20 20 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 0a new-colnames.
9e10: 09 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 .. (if (> cur
9e20: 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 r-rownum rownum)
9e30: 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 curr-rownum row
9e40: 6e 75 6d 29 0a 09 09 20 20 20 20 28 69 66 20 28 num)... (if (
9e50: 3e 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f > curr-colnum co
9e60: 6c 6e 75 6d 29 20 63 75 72 72 2d 63 6f 6c 6e 75 lnum) curr-colnu
9e70: 6d 20 63 6f 6c 6e 75 6d 29 0a 09 09 20 20 20 20 m colnum)...
9e80: 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))))))..;;======
9e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ed0: 0a 3b 3b 20 53 20 59 20 53 20 54 20 45 20 4d 20 .;; S Y S T E M
9ee0: 20 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d S T U F F.;;==
9ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f30: 3d 3d 3d 3d 0a 0a 3b 3b 20 6c 61 7a 79 2d 73 61 ====..;; lazy-sa
9f40: 66 65 20 67 65 74 20 66 69 6c 65 20 6d 6f 64 20 fe get file mod
9f50: 74 69 6d 65 2e 20 6f 6e 20 61 6e 79 20 65 72 72 time. on any err
9f60: 6f 72 20 28 66 69 6c 65 20 6e 6f 74 20 65 78 69 or (file not exi
9f70: 73 74 69 6e 67 20 65 74 63 2e 29 20 72 65 74 75 sting etc.) retu
9f80: 72 6e 20 30 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 rn 0.;;.(define
9f90: 28 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 (common:lazy-mod
9fa0: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
9fb0: 70 61 74 68 29 0a 20 20 28 68 61 6e 64 6c 65 2d path). (handle-
9fc0: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 exceptions. ex
9fd0: 6e 0a 20 20 20 30 0a 20 20 20 28 66 69 6c 65 2d n. 0. (file-
9fe0: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
9ff0: 65 20 66 70 61 74 68 29 29 29 0a 0a 3b 3b 20 66 e fpath)))..;; f
a000: 69 6e 64 20 74 69 6d 65 73 74 61 6d 70 20 6f 66 ind timestamp of
a010: 20 6e 65 77 65 73 74 20 66 69 6c 65 20 61 73 73 newest file ass
a020: 6f 63 69 61 74 65 64 20 77 69 74 68 20 61 20 73 ociated with a s
a030: 71 6c 69 74 65 20 64 62 20 66 69 6c 65 0a 28 64 qlite db file.(d
a040: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 61 efine (common:la
a050: 7a 79 2d 73 71 6c 69 74 65 2d 64 62 2d 6d 6f 64 zy-sqlite-db-mod
a060: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
a070: 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 path). (let* ((
a080: 67 6c 6f 62 2d 6c 69 73 74 20 28 68 61 6e 64 6c glob-list (handl
a090: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
a0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0b0: 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 20 exn.
a0c0: 20 20 20 20 20 20 20 20 20 27 28 22 2f 6e 6f 2f '("/no/
a0d0: 73 75 63 68 2f 66 69 6c 65 22 29 0a 20 20 20 20 such/file").
a0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a0f0: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 66 70 61 74 (glob (conc fpat
a100: 68 20 22 2a 22 29 29 29 29 0a 20 20 20 20 20 20 h "*")))).
a110: 20 20 20 28 66 69 6c 65 2d 6c 69 73 74 20 28 69 (file-list (i
a120: 66 20 28 65 71 3f 20 30 20 28 6c 65 6e 67 74 68 f (eq? 0 (length
a130: 20 67 6c 6f 62 2d 6c 69 73 74 29 29 0a 20 20 20 glob-list)).
a140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a150: 20 20 20 20 20 27 28 22 2f 6e 6f 2f 73 75 63 68 '("/no/such
a160: 2f 66 69 6c 65 22 29 0a 20 20 20 20 20 20 20 20 /file").
a170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a180: 67 6c 6f 62 2d 6c 69 73 74 29 29 29 0a 20 20 28 glob-list))). (
a190: 61 70 70 6c 79 20 6d 61 78 0a 20 20 20 28 6d 61 apply max. (ma
a1a0: 70 0a 20 20 20 20 63 6f 6d 6d 6f 6e 3a 6c 61 7a p. common:laz
a1b0: 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 y-modification-t
a1c0: 69 6d 65 20 0a 20 20 20 20 66 69 6c 65 2d 6c 69 ime . file-li
a1d0: 73 74 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 st))))..;; retur
a1e0: 6e 20 61 20 6e 69 63 65 20 63 6c 65 61 6e 20 70 n a nice clean p
a1f0: 61 74 68 6e 61 6d 65 20 6d 61 64 65 20 61 62 73 athname made abs
a200: 6f 6c 75 74 65 0a 28 64 65 66 69 6e 65 20 28 63 olute.(define (c
a210: 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 ommon:nice-path
a220: 64 69 72 29 0a 20 20 28 6c 65 74 20 28 28 6d 61 dir). (let ((ma
a230: 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 tch (string-matc
a240: 68 20 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c h "^(~[^\\/]*)(\
a250: 5c 2f 2e 2a 7c 29 24 22 20 64 69 72 29 29 29 0a \/.*|)$" dir))).
a260: 20 20 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b (if match ;;
a270: 20 75 73 69 6e 67 20 7e 20 66 6f 72 20 68 6f 6d using ~ for hom
a280: 65 3f 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 e?..(common:nice
a290: 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d -path (conc (com
a2a0: 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 mon:read-link-f
a2b0: 28 63 61 64 72 20 6d 61 74 63 68 29 29 20 22 2f (cadr match)) "/
a2c0: 22 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 " (caddr match))
a2d0: 29 0a 09 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 )..(normalize-pa
a2e0: 74 68 6e 61 6d 65 20 28 69 66 20 28 61 62 73 6f thname (if (abso
a2f0: 6c 75 74 65 2d 70 61 74 68 6e 61 6d 65 3f 20 64 lute-pathname? d
a300: 69 72 29 0a 09 09 09 09 64 69 72 0a 09 09 09 09 ir).....dir.....
a310: 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 64 (conc (current-d
a320: 69 72 65 63 74 6f 72 79 29 20 22 2f 22 20 64 69 irectory) "/" di
a330: 72 29 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 r))))))..;; make
a340: 20 22 6e 69 63 65 2d 70 61 74 68 22 20 61 76 61 "nice-path" ava
a350: 69 6c 61 62 6c 65 20 69 6e 20 63 6f 6e 66 69 67 ilable in config
a360: 20 66 69 6c 65 73 20 61 6e 64 20 74 68 65 20 72 files and the r
a370: 65 70 6c 0a 28 64 65 66 69 6e 65 20 6e 69 63 65 epl.(define nice
a380: 2d 70 61 74 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 -path common:nic
a390: 65 2d 70 61 74 68 29 0a 0a 28 64 65 66 69 6e 65 e-path)..(define
a3a0: 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 (common:read-li
a3b0: 6e 6b 2d 66 20 70 61 74 68 29 0a 20 20 28 68 61 nk-f path). (ha
a3c0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
a3d0: 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 exn.
a3e0: 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 (begin..(debug:p
a3f0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
a400: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
a410: 22 63 6f 6d 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f "command \"/bin/
a420: 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 readlink -f " pa
a430: 74 68 20 22 5c 22 20 66 61 69 6c 65 64 2e 22 29 th "\" failed.")
a440: 0a 09 70 61 74 68 29 20 3b 3b 20 6a 75 73 74 20 ..path) ;; just
a450: 67 69 76 65 20 75 70 0a 20 20 20 20 28 77 69 74 give up. (wit
a460: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
a470: 65 0a 09 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 e..(conc "/bin/r
a480: 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 eadlink -f " pat
a490: 68 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 h). (lambda
a4a0: 20 28 29 0a 09 28 72 65 61 64 2d 6c 69 6e 65 29 ()..(read-line)
a4b0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 ))))..(define (g
a4c0: 65 74 2d 63 70 75 2d 6c 6f 61 64 20 23 21 6b 65 et-cpu-load #!ke
a4d0: 79 20 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 y (remote-host #
a4e0: 66 29 29 0a 20 20 28 63 61 72 20 28 63 6f 6d 6d f)). (car (comm
a4f0: 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 on:get-cpu-load
a500: 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 3b remote-host))).;
a510: 3b 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 ; (let* ((load
a520: 2d 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d -res (process:cm
a530: 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 d-run->list "upt
a540: 69 6d 65 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 ime")).;; . (loa
a550: 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 6c d-rx (regexp "l
a560: 6f 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b oad average:\\s+
a570: 28 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 (\\d+)")).;; . (
a580: 63 70 75 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b cpu-load #f)).;;
a590: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
a5a0: 6c 61 6d 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 lambda (l).;; ..
a5b0: 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 (let ((match (st
a5c0: 72 69 6e 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 ring-search load
a5d0: 2d 72 78 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 -rx l))).;; ..
a5e0: 28 69 66 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 (if match.;; ..
a5f0: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 (let ((newv
a600: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 al (string->numb
a610: 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 er (cadr match))
a620: 29 29 0a 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 )).;; ...(if (nu
a630: 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b mber? newval).;;
a640: 20 09 09 09 20 20 20 20 28 73 65 74 21 20 63 70 ... (set! cp
a650: 75 2d 6c 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 u-load newval)))
a660: 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 ))).;; . (c
a670: 61 72 20 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b ar load-res)).;;
a680: 20 20 20 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a cpu-load)).
a690: 0a 3b 3b 20 67 65 74 20 63 70 75 20 6c 6f 61 64 .;; get cpu load
a6a0: 20 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d by reading from
a6b0: 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 /proc/loadavg,
a6c0: 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 return all three
a6d0: 20 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 values.;;.(defi
a6e0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 ne (common:get-c
a6f0: 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 pu-load remote-h
a700: 6f 73 74 29 0a 20 20 28 69 66 20 72 65 6d 6f 74 ost). (if remot
a710: 65 2d 68 6f 73 74 0a 20 20 20 20 20 20 28 6d 61 e-host. (ma
a720: 70 20 28 6c 61 6d 62 64 61 20 28 72 65 73 29 0a p (lambda (res).
a730: 09 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f . (if (eof-o
a740: 62 6a 65 63 74 3f 20 72 65 73 29 20 39 65 39 39 bject? res) 9e99
a750: 20 72 65 73 29 29 0a 09 20 20 20 28 77 69 74 68 res)).. (with
a760: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
a770: 20 0a 09 20 20 20 20 28 63 6f 6e 63 20 22 73 73 .. (conc "ss
a780: 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 h " remote-host
a790: 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 " cat /proc/load
a7a0: 61 76 67 22 29 0a 09 20 20 20 20 28 6c 61 6d 62 avg").. (lamb
a7b0: 64 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 da ()(list (read
a7c0: 29 28 72 65 61 64 29 28 72 65 61 64 29 29 29 29 )(read)(read))))
a7d0: 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e ). (with-in
a7e0: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f put-from-file "/
a7f0: 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 0a 09 proc/loadavg" ..
a800: 28 6c 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 (lambda ()(list
a810: 28 72 65 61 64 29 28 72 65 61 64 29 28 72 65 61 (read)(read)(rea
a820: 64 29 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 d))))))..;; get
a830: 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c normalized cpu l
a840: 6f 61 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 oad by reading f
a850: 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 rom /proc/loadav
a860: 67 20 61 6e 64 20 2f 70 72 6f 63 2f 63 70 75 69 g and /proc/cpui
a870: 6e 66 6f 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 nfo return all t
a880: 68 72 65 65 20 76 61 6c 75 65 73 20 61 6e 64 20 hree values and
a890: 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 the number of re
a8a0: 61 6c 20 63 70 75 73 20 61 6e 64 20 74 68 65 20 al cpus and the
a8b0: 6e 75 6d 62 65 72 20 6f 66 20 74 68 72 65 61 64 number of thread
a8c0: 73 0a 3b 3b 20 72 65 74 75 72 6e 73 20 61 6c 69 s.;; returns ali
a8d0: 73 74 20 27 28 28 61 64 6a 2d 63 70 75 2d 6c 6f st '((adj-cpu-lo
a8e0: 61 64 20 2e 20 6e 6f 72 6d 61 6c 69 7a 65 64 2d ad . normalized-
a8f0: 70 72 6f 63 2d 6c 6f 61 64 29 20 2e 2e 2e 20 65 proc-load) ... e
a900: 74 63 2e 0a 3b 3b 20 20 6b 65 79 73 3a 20 61 64 tc..;; keys: ad
a910: 6a 2d 70 72 6f 63 2d 6c 6f 61 64 2c 20 61 64 6a j-proc-load, adj
a920: 2d 63 6f 72 65 2d 6c 6f 61 64 2c 20 31 6d 2d 6c -core-load, 1m-l
a930: 6f 61 64 2c 20 35 6d 2d 6c 6f 61 64 2c 20 31 35 oad, 5m-load, 15
a940: 6d 2d 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e m-load.;;.(defin
a950: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f e (common:get-no
a960: 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 rmalized-cpu-loa
a970: 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 d remote-host).
a980: 20 28 6c 65 74 20 28 28 64 61 74 61 20 28 69 66 (let ((data (if
a990: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 remote-host.
a9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a9b0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
a9c0: 70 69 70 65 20 0a 20 20 20 20 20 20 20 20 20 20 pipe .
a9d0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 (conc "
a9e0: 73 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 ssh " remote-hos
a9f0: 74 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f t " cat /proc/lo
aa00: 61 64 61 76 67 3b 63 61 74 20 2f 70 72 6f 63 2f adavg;cat /proc/
aa10: 63 70 75 69 6e 66 6f 3b 65 63 68 6f 20 65 6e 64 cpuinfo;echo end
aa20: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
aa30: 20 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 read-lines
aa40: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
aa50: 20 20 20 20 28 61 70 70 65 6e 64 20 0a 20 20 20 (append .
aa60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa70: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
aa80: 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 6c 6f 61 -file "/proc/loa
aa90: 64 61 76 67 22 20 0a 20 20 20 20 20 20 20 20 20 davg" .
aaa0: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 61 64 read
aab0: 2d 6c 69 6e 65 73 29 0a 20 20 20 20 20 20 20 20 -lines).
aac0: 20 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 (with
aad0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
aae0: 20 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 "/proc/cpuinfo"
aaf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
ab00: 20 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 read-lines
ab10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
ab20: 20 20 20 20 20 28 6c 69 73 74 20 22 65 6e 64 22 (list "end"
ab30: 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c 6f )))). (lo
ab40: 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 ad-rx (regexp "
ab50: 5e 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b ^([\\d\\.]+)\\s+
ab60: 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 ([\\d\\.]+)\\s+(
ab70: 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e 2a [\\d\\.]+)\\s+.*
ab80: 24 22 29 29 0a 20 20 20 20 20 20 20 20 28 70 72 $")). (pr
ab90: 6f 63 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 oc-rx (regexp "
aba0: 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c ^processor\\s+:\
abb0: 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 \s+(\\d+)\\s*$")
abc0: 29 0a 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d ). (core-
abd0: 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 63 6f rx (regexp "^co
abe0: 72 65 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c re id\\s+:\\s+(\
abf0: 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 \d+)\\s*$")).
ac00: 20 20 20 20 20 28 70 68 79 73 2d 72 78 20 20 28 (phys-rx (
ac10: 72 65 67 65 78 70 20 22 5e 70 68 79 73 69 63 61 regexp "^physica
ac20: 6c 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c l id\\s+:\\s+(\\
ac30: 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 d+)\\s*$")).
ac40: 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 20 28 6c (max-num (l
ac50: 61 6d 62 64 61 20 28 70 20 6e 29 28 6d 61 78 20 ambda (p n)(max
ac60: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
ac70: 70 29 20 6e 29 29 29 29 0a 20 20 20 20 3b 3b 20 p) n)))). ;;
ac80: 28 70 72 69 6e 74 20 22 64 61 74 61 3d 22 20 64 (print "data=" d
ac90: 61 74 61 29 0a 20 20 20 20 28 69 66 20 28 6e 75 ata). (if (nu
aca0: 6c 6c 3f 20 64 61 74 61 29 20 3b 3b 20 73 6f 6d ll? data) ;; som
acb0: 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e ething went wron
acc0: 67 0a 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 g. #f.
acd0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
ace0: 28 68 65 64 20 20 20 20 20 20 28 63 61 72 20 64 (hed (car d
acf0: 61 74 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 ata)).
ad00: 20 20 20 20 20 20 20 20 20 28 74 61 6c 20 20 20 (tal
ad10: 20 20 20 28 63 64 72 20 64 61 74 61 29 29 0a 20 (cdr data)).
ad20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad30: 20 20 28 6c 6f 61 64 73 20 20 20 20 23 66 29 0a (loads #f).
ad40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad50: 20 20 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 20 (proc-num 0)
ad60: 20 3b 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 6e ;; processor in
ad70: 63 6c 75 64 65 73 20 74 68 72 65 61 64 73 0a 20 cludes threads.
ad80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad90: 20 20 28 70 68 79 73 2d 6e 75 6d 20 30 29 20 20 (phys-num 0)
ada0: 3b 3b 20 70 68 79 73 69 63 61 6c 20 63 68 69 70 ;; physical chip
adb0: 20 6f 6e 20 6d 6f 74 68 65 72 62 6f 61 72 64 0a on motherboard.
adc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
add0: 20 20 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 29 (core-num 0))
ade0: 20 3b 3b 20 63 6f 72 65 0a 20 20 20 20 20 20 20 ;; core.
adf0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 ;; (print hed
ae00: 20 22 2c 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 ", " loads ", "
ae10: 20 70 72 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 proc-num ", " p
ae20: 68 79 73 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 hys-num ", " cor
ae30: 65 2d 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 20 e-num).
ae40: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
ae50: 20 3b 3b 20 68 61 76 65 20 61 6c 6c 20 6f 75 72 ;; have all our
ae60: 20 64 61 74 61 2c 20 63 61 6c 63 75 6c 61 74 65 data, calculate
ae70: 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 normalized load
ae80: 20 61 6e 64 20 72 65 74 75 72 6e 20 72 65 73 75 and return resu
ae90: 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 lt.
aea0: 20 28 6c 65 74 2a 20 28 28 61 63 74 2d 70 72 6f (let* ((act-pro
aeb0: 63 20 28 2b 20 70 72 6f 63 2d 6e 75 6d 20 31 29 c (+ proc-num 1)
aec0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
aed0: 20 20 20 20 20 20 20 28 61 63 74 2d 70 68 79 73 (act-phys
aee0: 20 28 2b 20 70 68 79 73 2d 6e 75 6d 20 31 29 29 (+ phys-num 1))
aef0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
af00: 20 20 20 20 20 20 28 61 63 74 2d 63 6f 72 65 20 (act-core
af10: 28 2b 20 63 6f 72 65 2d 6e 75 6d 20 31 29 29 0a (+ core-num 1)).
af20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af30: 20 20 20 20 20 28 61 64 6a 2d 70 72 6f 63 2d 6c (adj-proc-l
af40: 6f 61 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 oad (/ (car load
af50: 73 29 20 61 63 74 2d 70 72 6f 63 29 29 0a 20 20 s) act-proc)).
af60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af70: 20 20 20 28 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 (adj-core-loa
af80: 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 d (/ (car loads)
af90: 20 61 63 74 2d 63 6f 72 65 29 29 29 0a 20 20 20 act-core))).
afa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
afb0: 70 65 6e 64 20 28 6c 69 73 74 20 28 63 6f 6e 73 pend (list (cons
afc0: 20 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 'adj-proc-load
afd0: 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a 20 adj-proc-load).
afe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
b000: 6e 73 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 ns 'adj-core-loa
b010: 64 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 29 d adj-core-load)
b020: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b030: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 (list
b040: 28 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 28 (cons '1m-load (
b050: 63 61 72 20 6c 6f 61 64 73 29 29 0a 20 20 20 20 car loads)).
b060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b070: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
b080: 27 35 6d 2d 6c 6f 61 64 20 28 63 61 64 72 20 6c '5m-load (cadr l
b090: 6f 61 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 oads)).
b0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0b0: 20 20 20 20 20 28 63 6f 6e 73 20 27 31 35 6d 2d (cons '15m-
b0c0: 6c 6f 61 64 20 28 63 61 64 64 72 20 6c 6f 61 64 load (caddr load
b0d0: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s))).
b0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
b0f0: 73 74 20 28 63 6f 6e 73 20 27 70 72 6f 63 20 61 st (cons 'proc a
b100: 63 74 2d 70 72 6f 63 29 0a 20 20 20 20 20 20 20 ct-proc).
b110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b120: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 63 6f (cons 'co
b130: 72 65 20 61 63 74 2d 63 6f 72 65 29 0a 20 20 20 re act-core).
b140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b150: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
b160: 20 27 70 68 79 73 20 61 63 74 2d 70 68 79 73 29 'phys act-phys)
b170: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
b180: 20 20 28 72 65 67 65 78 2d 63 61 73 65 0a 20 20 (regex-case.
b190: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 65 64 hed
b1a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b1b0: 28 6c 6f 61 64 2d 72 78 20 20 28 20 78 20 6c 31 (load-rx ( x l1
b1c0: 20 6c 35 20 6c 31 35 20 29 20 28 6c 6f 6f 70 20 l5 l15 ) (loop
b1d0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
b1e0: 6c 29 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e l)(map string->n
b1f0: 75 6d 62 65 72 20 28 6c 69 73 74 20 6c 31 20 6c umber (list l1 l
b200: 35 20 6c 31 35 29 29 20 70 72 6f 63 2d 6e 75 6d 5 l15)) proc-num
b210: 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e phys-num core-n
b220: 75 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 um)).
b230: 20 20 20 20 28 70 72 6f 63 2d 72 78 20 20 28 20 (proc-rx (
b240: 78 20 70 20 20 20 20 20 20 20 20 20 29 20 28 6c x p ) (l
b250: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
b260: 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 r tal) loads
b270: 20 20 20 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 (max-num
b280: 70 20 70 72 6f 63 2d 6e 75 6d 29 20 70 68 79 73 p proc-num) phys
b290: 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 0a -num core-num)).
b2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b2b0: 70 68 79 73 2d 72 78 20 20 28 20 78 20 70 20 20 phys-rx ( x p
b2c0: 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 ) (loop (
b2d0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
b2e0: 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 ) loads
b2f0: 20 20 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d proc-num (max-
b300: 6e 75 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 20 num p phys-num)
b310: 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 core-num)).
b320: 20 20 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d (core-
b330: 72 78 20 20 28 20 78 20 63 20 20 20 20 20 20 20 rx ( x c
b340: 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 ) (loop (car t
b350: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 al)(cdr tal) loa
b360: 64 73 20 20 20 20 20 20 20 20 20 20 20 70 72 6f ds pro
b370: 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 28 c-num phys-num (
b380: 6d 61 78 2d 6e 75 6d 20 63 20 63 6f 72 65 2d 6e max-num c core-n
b390: 75 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 um))).
b3a0: 20 20 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 (else .
b3b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
b3c0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
b3d0: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
b3e0: 4e 4f 20 4d 41 54 43 48 3a 20 22 20 68 65 64 29 NO MATCH: " hed)
b3f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b400: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
b410: 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 l)(cdr tal) load
b420: 73 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d s proc-num phys-
b430: 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 29 29 num core-num))))
b440: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
b450: 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 common:unix-ping
b460: 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 hostname). (le
b470: 74 20 28 28 72 65 73 20 28 73 79 73 74 65 6d 20 t ((res (system
b480: 28 63 6f 6e 63 20 22 70 69 6e 67 20 2d 63 20 31 (conc "ping -c 1
b490: 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 20 3e 20 " hostname " >
b4a0: 2f 64 65 76 2f 6e 75 6c 6c 22 29 29 29 29 0a 20 /dev/null")))).
b4b0: 20 20 20 28 65 71 3f 20 72 65 73 20 30 29 29 29 (eq? res 0)))
b4c0: 0a 0a 3b 3b 20 69 64 65 61 6c 6c 79 20 70 75 74 ..;; ideally put
b4d0: 20 61 6c 6c 20 74 68 69 73 20 69 6e 66 6f 20 69 all this info i
b4e0: 6e 74 6f 20 74 68 65 20 64 62 2c 20 6e 6f 20 6e nto the db, no n
b4f0: 65 65 64 20 74 6f 20 70 72 65 73 65 72 76 65 20 eed to preserve
b500: 69 74 20 61 63 72 6f 73 73 20 6d 6f 76 69 6e 67 it across moving
b510: 20 68 6f 6d 65 68 6f 73 74 0a 3b 3b 0a 3b 3b 20 homehost.;;.;;
b520: 72 65 74 75 72 6e 20 6c 69 73 74 20 6f 66 0a 3b return list of.;
b530: 3b 20 20 28 20 72 65 61 63 68 61 62 6c 65 3f 20 ; ( reachable?
b540: 63 70 75 6c 6f 61 64 20 75 70 64 61 74 65 2d 74 cpuload update-t
b550: 69 6d 65 20 29 0a 28 64 65 66 69 6e 65 20 28 63 ime ).(define (c
b560: 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 73 74 2d 69 ommon:get-host-i
b570: 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 nfo hostname).
b580: 28 6c 65 74 2a 20 28 28 6c 6f 61 64 69 6e 66 6f (let* ((loadinfo
b590: 20 28 72 6d 74 3a 67 65 74 2d 6c 61 74 65 73 74 (rmt:get-latest
b5a0: 2d 68 6f 73 74 2d 6c 6f 61 64 20 68 6f 73 74 6e -host-load hostn
b5b0: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 ame)). (
b5c0: 6c 6f 61 64 20 28 63 61 72 20 6c 6f 61 64 69 6e load (car loadin
b5d0: 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c fo)). (l
b5e0: 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 20 oad-sample-time
b5f0: 28 63 64 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a (cdr loadinfo)).
b600: 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 (load-s
b610: 61 6d 70 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 ample-age (- (cu
b620: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c rrent-seconds) l
b630: 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 29 oad-sample-time)
b640: 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 ). (load
b650: 69 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 info-timeout-sec
b660: 6f 6e 64 73 20 32 30 29 0a 20 20 20 20 20 20 20 onds 20).
b670: 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 (host-last-upd
b680: 61 74 65 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f ate-timeout-seco
b690: 6e 64 73 20 31 30 29 0a 20 20 20 20 20 20 20 20 nds 10).
b6a0: 20 28 68 6f 73 74 2d 72 65 63 20 28 68 61 73 68 (host-rec (hash
b6b0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
b6c0: 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 lt *host-loads*
b6d0: 68 6f 73 74 6e 61 6d 65 20 23 66 29 29 0a 20 20 hostname #f)).
b6e0: 20 20 20 20 20 20 20 29 0a 20 20 20 20 28 63 6f ). (co
b6f0: 6e 64 0a 20 20 20 20 20 28 28 3c 20 6c 6f 61 64 nd. ((< load
b700: 2d 73 61 6d 70 6c 65 2d 61 67 65 20 6c 6f 61 64 -sample-age load
b710: 69 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 info-timeout-sec
b720: 6f 6e 64 73 29 0a 20 20 20 20 20 20 28 6c 69 73 onds). (lis
b730: 74 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 t #t.
b740: 20 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d load-sample-tim
b750: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f e. lo
b760: 61 64 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 ad)). ((and
b770: 68 6f 73 74 2d 72 65 63 0a 20 20 20 20 20 20 20 host-rec.
b780: 20 20 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d (< (current-
b790: 73 65 63 6f 6e 64 73 29 20 28 2b 20 28 68 6f 73 seconds) (+ (hos
b7a0: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 68 6f t-last-update ho
b7b0: 73 74 2d 72 65 63 29 20 68 6f 73 74 2d 6c 61 73 st-rec) host-las
b7c0: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 t-update-timeout
b7d0: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 -seconds))).
b7e0: 20 20 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 (list #t.
b7f0: 20 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 (host-las
b800: 74 2d 75 70 64 61 74 65 20 68 6f 73 74 2d 72 65 t-update host-re
b810: 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 c). (
b820: 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 host-last-cpuloa
b830: 64 20 68 6f 73 74 2d 72 65 63 20 29 29 29 0a 20 d host-rec ))).
b840: 20 20 20 20 28 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 ((common:uni
b850: 78 2d 70 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 x-ping hostname)
b860: 0a 20 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a . (list #t.
b870: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 (cur
b880: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 rent-seconds).
b890: 20 20 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 (alist
b8a0: 2d 72 65 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c -ref 'adj-core-l
b8b0: 6f 61 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d oad (common:get-
b8c0: 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c normalized-cpu-l
b8d0: 6f 61 64 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 oad hostname))))
b8e0: 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 . (else.
b8f0: 20 20 28 6c 69 73 74 20 23 66 20 30 20 2d 31 29 (list #f 0 -1)
b900: 29 29 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e )))). .(defin
b910: 65 20 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 e (common:update
b920: 2d 68 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c -host-loads-tabl
b930: 65 20 68 6f 73 74 73 2d 72 61 77 29 0a 20 20 28 e hosts-raw). (
b940: 6c 65 74 2a 20 28 28 68 6f 73 74 73 20 28 66 69 let* ((hosts (fi
b950: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
b960: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b970: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 (stri
b980: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
b990: 20 22 5e 5c 5c 53 2b 24 22 29 20 78 29 29 0a 20 "^\\S+$") x)).
b9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b9b0: 20 20 20 20 20 20 20 68 6f 73 74 73 2d 72 61 77 hosts-raw
b9c0: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
b9d0: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
b9e0: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 hostname).
b9f0: 20 28 6c 65 74 2a 20 28 28 72 65 63 20 20 20 20 (let* ((rec
ba00: 20 20 20 28 6c 65 74 20 28 28 68 20 28 68 61 73 (let ((h (has
ba10: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
ba20: 75 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a ult *host-loads*
ba30: 20 68 6f 73 74 6e 61 6d 65 20 23 66 29 29 29 0a hostname #f))).
ba40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba50: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 68 0a (if h.
ba60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 0a h.
ba80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
baa0: 65 74 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 et ((h (make-hos
bab0: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 t))).
bac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bad0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
bae0: 2d 73 65 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 -set! *host-load
baf0: 73 2a 20 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 s* hostname h).
bb00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bb10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 h
bb20: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
bb30: 20 20 20 28 68 6f 73 74 2d 69 6e 66 6f 20 20 20 (host-info
bb40: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (common:ge
bb50: 74 2d 68 6f 73 74 2d 69 6e 66 6f 20 68 6f 73 74 t-host-info host
bb60: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
bb70: 20 20 20 20 20 28 69 73 2d 72 65 61 63 68 61 62 (is-reachab
bb80: 6c 65 20 20 20 20 20 20 28 63 61 72 20 68 6f 73 le (car hos
bb90: 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 t-info)).
bba0: 20 20 20 20 20 20 20 28 6c 61 73 74 2d 72 65 61 (last-rea
bbb0: 63 68 65 64 2d 74 69 6d 65 20 28 63 61 64 72 20 ched-time (cadr
bbc0: 68 6f 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 host-info)).
bbd0: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 (load
bbe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
bbf0: 64 64 72 20 68 6f 73 74 2d 69 6e 66 6f 29 29 29 ddr host-info)))
bc00: 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d . (host-
bc10: 72 65 61 63 68 61 62 6c 65 2d 73 65 74 21 20 20 reachable-set!
bc20: 20 20 72 65 63 20 69 73 2d 72 65 61 63 68 61 62 rec is-reachab
bc30: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f le). (ho
bc40: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 st-last-update-s
bc50: 65 74 21 20 20 72 65 63 20 6c 61 73 74 2d 72 65 et! rec last-re
bc60: 61 63 68 65 64 2d 74 69 6d 65 29 0a 20 20 20 20 ached-time).
bc70: 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d (host-last-
bc80: 63 70 75 6c 6f 61 64 2d 73 65 74 21 20 72 65 63 cpuload-set! rec
bc90: 20 6c 6f 61 64 29 29 29 0a 20 20 20 20 20 68 6f load))). ho
bca0: 73 74 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 sts)))..(define
bcb0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 (common:get-leas
bcc0: 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 20 68 6f t-loaded-host ho
bcd0: 73 74 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a sts-raw). (let*
bce0: 20 28 28 68 6f 73 74 73 20 28 66 69 6c 74 65 72 ((hosts (filter
bcf0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 (lambda (x).
bd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd10: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d (string-m
bd20: 61 74 63 68 20 28 72 65 67 65 78 70 20 22 5e 5c atch (regexp "^\
bd30: 5c 53 2b 24 22 29 20 78 29 29 0a 20 20 20 20 20 \S+$") x)).
bd40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd50: 20 20 20 68 6f 73 74 73 2d 72 61 77 29 29 0a 20 hosts-raw)).
bd60: 20 20 20 20 20 20 20 20 28 62 65 73 74 2d 68 6f (best-ho
bd70: 73 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 st #f).
bd80: 28 62 65 73 74 2d 6c 6f 61 64 20 39 39 39 39 39 (best-load 99999
bd90: 29 0a 20 20 20 20 20 20 20 20 20 28 63 75 72 72 ). (curr
bda0: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
bdb0: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 63 econds))). (c
bdc0: 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 ommon:update-hos
bdd0: 74 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f t-loads-table ho
bde0: 73 74 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 sts). (for-ea
bdf0: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
be00: 28 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 (hostname).
be10: 20 20 28 6c 65 74 2a 20 28 28 72 65 63 0a 20 20 (let* ((rec.
be20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
be30: 74 20 28 28 68 20 28 68 61 73 68 2d 74 61 62 6c t ((h (hash-tabl
be40: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 e-ref/default *h
be50: 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e ost-loads* hostn
be60: 61 6d 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 ame #f))).
be70: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 68 (if h
be80: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
be90: 20 20 20 20 20 20 68 0a 20 20 20 20 20 20 20 20 h.
bea0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
beb0: 74 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 t ((h (make-host
bec0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
bed0: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
bee0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 -table-set! *hos
bef0: 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d t-loads* hostnam
bf00: 65 20 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 e h).
bf10: 20 20 20 20 20 20 20 20 20 20 20 20 68 29 29 29 h)))
bf20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
bf30: 28 72 65 61 63 68 61 62 6c 65 20 28 68 6f 73 74 (reachable (host
bf40: 2d 72 65 61 63 68 61 62 6c 65 20 72 65 63 29 29 -reachable rec))
bf50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
bf60: 6c 6f 61 64 20 20 20 20 20 20 28 68 6f 73 74 2d load (host-
bf70: 6c 61 73 74 2d 63 70 75 6c 6f 61 64 20 20 20 72 last-cpuload r
bf80: 65 63 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 ec))). (
bf90: 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 28 cond. (
bfa0: 28 6e 6f 74 20 72 65 61 63 68 61 62 6c 65 29 20 (not reachable)
bfb0: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 #f). ((
bfc0: 3c 20 28 2b 20 6c 6f 61 64 20 28 2f 20 28 72 61 < (+ load (/ (ra
bfd0: 6e 64 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 ndom 250) 1000))
bfe0: 20 20 20 20 20 20 20 20 20 3b 3b 20 61 64 64 20 ;; add
bff0: 61 20 72 61 6e 64 6f 6d 20 66 61 63 74 6f 72 20 a random factor
c000: 74 6f 20 6b 65 65 70 20 66 72 6f 6d 20 67 65 74 to keep from get
c010: 74 69 6e 67 20 69 6e 20 61 20 72 75 74 0a 20 20 ting in a rut.
c020: 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 62 (+ b
c030: 65 73 74 2d 6c 6f 61 64 20 28 2f 20 28 72 61 6e est-load (/ (ran
c040: 64 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 dom 250) 1000))
c050: 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 ). (s
c060: 65 74 21 20 62 65 73 74 2d 6c 6f 61 64 20 6c 6f et! best-load lo
c070: 61 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ad). (
c080: 73 65 74 21 20 62 65 73 74 2d 68 6f 73 74 20 68 set! best-host h
c090: 6f 73 74 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 ostname))))).
c0a0: 20 20 68 6f 73 74 73 29 0a 20 20 20 20 62 65 73 hosts). bes
c0b0: 74 2d 68 6f 73 74 29 29 0a 0a 0a 0a 0a 28 64 65 t-host)).....(de
c0c0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 fine (common:wai
c0d0: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
c0e0: 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 xload numcpus wa
c0f0: 69 74 64 65 6c 61 79 20 23 21 6b 65 79 20 28 63 itdelay #!key (c
c100: 6f 75 6e 74 20 31 30 30 30 29 20 28 6d 73 67 20 ount 1000) (msg
c110: 23 66 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 #f)(remote-host
c120: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c #f)). (let* ((l
c130: 6f 61 64 61 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 oadavg (common:g
c140: 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f et-cpu-load remo
c150: 74 65 2d 68 6f 73 74 29 29 0a 09 20 28 66 69 72 te-host)).. (fir
c160: 73 74 20 20 20 28 63 61 72 20 6c 6f 61 64 61 76 st (car loadav
c170: 67 29 29 0a 09 20 28 6e 65 78 74 20 20 20 20 28 g)).. (next (
c180: 63 61 64 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 cadr loadavg))..
c190: 20 28 61 64 6a 6c 6f 61 64 20 28 2a 20 6d 61 78 (adjload (* max
c1a0: 6c 6f 61 64 20 6e 75 6d 63 70 75 73 29 29 0a 09 load numcpus))..
c1b0: 20 28 6c 6f 61 64 6a 6d 70 20 28 2d 20 66 69 72 (loadjmp (- fir
c1c0: 73 74 20 6e 65 78 74 29 29 29 0a 20 20 20 20 28 st next))). (
c1d0: 63 6f 6e 64 0a 20 20 20 20 20 28 28 61 6e 64 20 cond. ((and
c1e0: 28 3e 20 66 69 72 73 74 20 61 64 6a 6c 6f 61 64 (> first adjload
c1f0: 29 0a 09 20 20 20 28 3e 20 63 6f 75 6e 74 20 30 ).. (> count 0
c200: 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a )). (debug:
c210: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
c220: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
c230: 22 77 61 69 74 69 6e 67 20 22 20 77 61 69 74 64 "waiting " waitd
c240: 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 20 64 elay " seconds d
c250: 75 65 20 74 6f 20 6c 6f 61 64 20 22 20 66 69 72 ue to load " fir
c260: 73 74 20 22 20 65 78 63 65 65 64 69 6e 67 20 6d st " exceeding m
c270: 61 78 20 6f 66 20 22 20 61 64 6a 6c 6f 61 64 20 ax of " adjload
c280: 28 69 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 (if msg msg ""))
c290: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
c2a0: 6c 65 65 70 21 20 77 61 69 74 64 65 6c 61 79 29 leep! waitdelay)
c2b0: 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 . (common:w
c2c0: 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 ait-for-cpuload
c2d0: 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 maxload numcpus
c2e0: 77 61 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 3a waitdelay count:
c2f0: 20 28 2d 20 63 6f 75 6e 74 20 31 29 29 29 0a 20 (- count 1))).
c300: 20 20 20 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 ((and (> loa
c310: 64 6a 6d 70 20 6e 75 6d 63 70 75 73 29 0a 09 20 djmp numcpus)..
c320: 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 (> count 0)).
c330: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
c340: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
c350: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
c360: 74 69 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 ting " waitdelay
c370: 20 22 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 " seconds due t
c380: 6f 20 6c 6f 61 64 20 6a 75 6d 70 20 22 20 6c 6f o load jump " lo
c390: 61 64 6a 6d 70 20 22 20 3e 20 6e 75 6d 63 70 75 adjmp " > numcpu
c3a0: 73 20 22 20 6e 75 6d 63 70 75 73 20 28 69 66 20 s " numcpus (if
c3b0: 6d 73 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 msg msg "")).
c3c0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
c3d0: 21 20 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 ! waitdelay).
c3e0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d (common:wait-
c3f0: 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c for-cpuload maxl
c400: 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 oad numcpus wait
c410: 64 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 delay count: (-
c420: 63 6f 75 6e 74 20 31 29 29 29 29 29 29 0a 0a 28 count 1))))))..(
c430: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
c440: 65 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f et-num-cpus remo
c450: 74 65 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 20 te-host). (let
c460: 28 28 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 ((proc (lambda (
c470: 29 0a 09 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 )...(let loop ((
c480: 6e 75 6d 63 70 75 20 30 29 0a 09 09 09 20 20 20 numcpu 0)....
c490: 28 69 6e 6c 20 20 20 20 28 72 65 61 64 2d 6c 69 (inl (read-li
c4a0: 6e 65 29 29 29 0a 09 09 20 20 28 69 66 20 28 65 ne)))... (if (e
c4b0: 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a of-object? inl).
c4c0: 09 09 20 20 20 20 20 20 6e 75 6d 63 70 75 0a 09 .. numcpu..
c4d0: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 69 66 . (loop (if
c4e0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 (string-match "
c4f0: 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c ^processor\\s+:\
c500: 5c 73 2b 5c 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 \s+\\d+$" inl)..
c510: 09 09 09 28 2b 20 6e 75 6d 63 70 75 20 31 29 0a ...(+ numcpu 1).
c520: 09 09 09 09 6e 75 6d 63 70 75 29 0a 09 09 09 20 ....numcpu)....
c530: 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 (read-line)))
c540: 29 29 29 29 0a 20 20 20 20 28 69 66 20 72 65 6d )))). (if rem
c550: 6f 74 65 2d 68 6f 73 74 0a 09 28 77 69 74 68 2d ote-host..(with-
c560: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
c570: 0a 09 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 .. (conc "ssh "
c580: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 remote-host " ca
c590: 74 20 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 t /proc/cpuinfo"
c5a0: 29 0a 09 20 70 72 6f 63 29 0a 09 28 77 69 74 68 ).. proc)..(with
c5b0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
c5c0: 20 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 "/proc/cpuinfo"
c5d0: 20 70 72 6f 63 29 29 29 29 0a 0a 3b 3b 20 77 61 proc))))..;; wa
c5e0: 69 74 20 66 6f 72 20 6e 6f 72 6d 61 6c 69 7a 65 it for normalize
c5f0: 64 20 63 70 75 20 6c 6f 61 64 20 74 6f 20 64 72 d cpu load to dr
c600: 6f 70 20 62 65 6c 6f 77 20 6d 61 78 6c 6f 61 64 op below maxload
c610: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
c620: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 mon:wait-for-nor
c630: 6d 61 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 malized-load max
c640: 6c 6f 61 64 20 23 21 6b 65 79 20 28 6d 73 67 20 load #!key (msg
c650: 23 66 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 #f)(remote-host
c660: 23 66 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 #f)). (let ((nu
c670: 6d 2d 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 m-cpus (common:g
c680: 65 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f et-num-cpus remo
c690: 74 65 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 28 te-host))). (
c6a0: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
c6b0: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
c6c0: 6e 75 6d 2d 63 70 75 73 20 31 35 20 6d 73 67 3a num-cpus 15 msg:
c6d0: 20 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 msg)))..(define
c6e0: 20 28 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 61 (get-uname . pa
c6f0: 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 rams). (let* ((
c700: 75 6e 61 6d 65 2d 72 65 73 20 28 70 72 6f 63 65 uname-res (proce
c710: 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 ss:cmd-run->list
c720: 20 28 63 6f 6e 63 20 22 75 6e 61 6d 65 20 22 20 (conc "uname "
c730: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
c740: 73 29 20 22 2d 61 22 20 28 63 61 72 20 70 61 72 s) "-a" (car par
c750: 61 6d 73 29 29 29 29 29 0a 09 20 28 75 6e 61 6d ams))))).. (unam
c760: 65 20 23 66 29 29 0a 20 20 20 20 28 69 66 20 28 e #f)). (if (
c770: 6e 75 6c 6c 3f 20 28 63 61 72 20 75 6e 61 6d 65 null? (car uname
c780: 2d 72 65 73 29 29 0a 09 22 75 6e 6b 6e 6f 77 6e -res)).."unknown
c790: 22 0a 09 28 63 61 61 72 20 75 6e 61 6d 65 2d 72 "..(caar uname-r
c7a0: 65 73 29 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 72 es))))..;; for r
c7b0: 65 61 73 6f 6e 73 20 49 20 64 6f 6e 27 74 20 75 easons I don't u
c7c0: 6e 64 65 72 73 74 61 6e 64 20 6d 75 6c 74 69 70 nderstand multip
c7d0: 6c 65 20 63 61 6c 6c 73 20 74 6f 20 72 65 61 6c le calls to real
c7e0: 2d 70 61 74 68 20 69 6e 20 70 61 72 61 6c 6c 65 -path in paralle
c7f0: 6c 20 74 68 72 65 61 64 73 0a 3b 3b 20 6d 75 73 l threads.;; mus
c800: 74 20 62 65 20 70 72 6f 74 65 63 74 65 64 20 62 t be protected b
c810: 79 20 6d 75 74 65 78 65 73 0a 3b 3b 0a 28 64 65 y mutexes.;;.(de
c820: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 fine (common:rea
c830: 6c 2d 70 61 74 68 20 69 6e 70 61 74 68 29 0a 20 l-path inpath).
c840: 20 3b 3b 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 ;; (process:cmd
c850: 2d 72 75 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 -run-with-stderr
c860: 2d 3e 6c 69 73 74 20 22 72 65 61 64 6c 69 6e 6b ->list "readlink
c870: 22 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 20 " "-f" inpath))
c880: 3b 3b 20 63 6d 64 20 2e 20 70 61 72 61 6d 73 29 ;; cmd . params)
c890: 0a 20 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 65 . ;; (let-value
c8a0: 73 20 0a 20 20 3b 3b 20 20 28 28 28 69 6e 70 20 s . ;; (((inp
c8b0: 6f 75 70 20 70 69 64 29 20 28 70 72 6f 63 65 73 oup pid) (proces
c8c0: 73 20 22 72 65 61 64 6c 69 6e 6b 22 20 28 6c 69 s "readlink" (li
c8d0: 73 74 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 st "-f" inpath))
c8e0: 29 29 0a 20 20 3b 3b 20 20 28 77 69 74 68 2d 69 )). ;; (with-i
c8f0: 6e 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 nput-from-port i
c900: 6e 70 0a 20 20 3b 3b 20 20 20 20 28 6c 65 74 20 np. ;; (let
c910: 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 loop ((inl (read
c920: 2d 6c 69 6e 65 29 29 0a 20 20 3b 3b 20 20 20 20 -line)). ;;
c930: 20 20 20 09 28 72 65 73 20 23 66 29 29 0a 20 20 .(res #f)).
c940: 3b 3b 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 ;; (print "
c950: 69 6e 6c 3d 22 20 69 6e 6c 29 0a 20 20 3b 3b 20 inl=" inl). ;;
c960: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
c970: 6a 65 63 74 3f 20 69 6e 6c 29 0a 20 20 3b 3b 20 ject? inl). ;;
c980: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
c990: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
c9a0: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
c9b0: 74 20 69 6e 70 29 0a 20 20 3b 3b 20 20 20 20 20 t inp). ;;
c9c0: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 (close-ou
c9d0: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 tput-port oup).
c9e0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 3b ;; ;
c9f0: 3b 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 ; (process-wait
ca00: 70 69 64 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 pid). ;;
ca10: 20 20 20 20 20 72 65 73 29 0a 20 20 3b 3b 20 20 res). ;;
ca20: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 (loop (r
ca30: 65 61 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 ead-line) inl)))
ca40: 29 29 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 ))). (with-inpu
ca50: 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e t-from-pipe (con
ca60: 63 20 22 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 c "readlink -f "
ca70: 20 69 6e 70 61 74 68 29 20 72 65 61 64 2d 6c 69 inpath) read-li
ca80: 6e 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ne))..;;========
ca90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
caa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
cad0: 3b 20 44 20 49 20 53 20 4b 20 20 20 53 20 50 20 ; D I S K S P
cae0: 41 20 43 20 45 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d A C E .;;=======
caf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
cb30: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
cb40: 3a 67 65 74 2d 64 69 73 6b 2d 73 70 61 63 65 2d :get-disk-space-
cb50: 75 73 65 64 20 66 70 61 74 68 29 0a 20 20 28 77 used fpath). (w
cb60: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
cb70: 69 70 65 20 28 63 6f 6e 63 20 22 2f 75 73 72 2f ipe (conc "/usr/
cb80: 62 69 6e 2f 64 75 20 2d 73 20 22 20 66 70 61 74 bin/du -s " fpat
cb90: 68 29 20 72 65 61 64 29 29 0a 0a 3b 3b 20 67 69 h) read))..;; gi
cba0: 76 65 6e 20 70 61 74 68 20 67 65 74 20 66 72 65 ven path get fre
cbb0: 65 20 73 70 61 63 65 2c 20 61 6c 6c 6f 77 73 20 e space, allows
cbc0: 6f 76 65 72 72 69 64 65 20 69 6e 20 5b 73 65 74 override in [set
cbd0: 75 70 5d 0a 3b 3b 20 77 69 74 68 20 66 72 65 65 up].;; with free
cbe0: 2d 73 70 61 63 65 2d 73 63 72 69 70 74 20 2f 70 -space-script /p
cbf0: 61 74 68 2f 74 6f 2f 73 6f 6d 65 2f 73 63 72 69 ath/to/some/scri
cc00: 70 74 2e 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 pt.sh.;;.(define
cc10: 20 28 67 65 74 2d 64 66 20 70 61 74 68 29 0a 20 (get-df path).
cc20: 20 28 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (if (configf:lo
cc30: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
cc40: 20 22 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 "setup" "free-s
cc50: 70 61 63 65 2d 73 63 72 69 70 74 22 29 0a 20 20 pace-script").
cc60: 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
cc70: 66 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 20 from-pipe .
cc80: 20 20 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 66 (conc (configf
cc90: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
cca0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 66 72 65 at* "setup" "fre
ccb0: 65 2d 73 70 61 63 65 2d 73 63 72 69 70 74 22 29 e-space-script")
ccc0: 20 22 20 22 20 70 61 74 68 29 0a 20 20 20 20 20 " " path).
ccd0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 (lambda ().. (
cce0: 6c 65 74 20 28 28 72 65 73 20 28 72 65 61 64 2d let ((res (read-
ccf0: 6c 69 6e 65 29 29 29 0a 09 20 20 20 28 69 66 20 line))).. (if
cd00: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 20 (string? res)..
cd10: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e (string->n
cd20: 75 6d 62 65 72 20 72 65 73 29 29 29 29 29 0a 20 umber res))))).
cd30: 20 20 20 20 20 28 67 65 74 2d 75 6e 69 78 2d 64 (get-unix-d
cd40: 66 20 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 f path)))..(defi
cd50: 6e 65 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 ne (get-unix-df
cd60: 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 path). (let* ((
cd70: 64 66 2d 72 65 73 75 6c 74 73 20 28 70 72 6f 63 df-results (proc
cd80: 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 ess:cmd-run->lis
cd90: 74 20 28 63 6f 6e 63 20 22 64 66 20 22 20 70 61 t (conc "df " pa
cda0: 74 68 29 29 29 0a 09 20 28 73 70 61 63 65 2d 72 th))).. (space-r
cdb0: 78 20 20 20 28 72 65 67 65 78 70 20 22 28 5b 30 x (regexp "([0
cdc0: 2d 39 5d 2b 29 5c 5c 73 2b 28 5b 30 2d 39 5d 2b -9]+)\\s+([0-9]+
cdd0: 29 25 22 29 29 0a 09 20 28 66 72 65 65 73 70 63 )%")).. (freespc
cde0: 20 20 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 #f)). ;;
cdf0: 28 77 72 69 74 65 20 64 66 2d 72 65 73 75 6c 74 (write df-result
ce00: 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s). (for-each
ce10: 20 28 6c 61 6d 62 64 61 20 28 6c 29 0a 09 09 28 (lambda (l)...(
ce20: 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 let ((match (str
ce30: 69 6e 67 2d 73 65 61 72 63 68 20 73 70 61 63 65 ing-search space
ce40: 2d 72 78 20 6c 29 29 29 0a 09 09 20 20 28 69 66 -rx l)))... (if
ce50: 20 6d 61 74 63 68 20 0a 09 09 20 20 20 20 20 20 match ...
ce60: 28 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 (let ((newval (s
ce70: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 tring->number (c
ce80: 61 64 72 20 6d 61 74 63 68 29 29 29 29 0a 09 09 adr match))))...
ce90: 09 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 65 .(if (number? ne
cea0: 77 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 wval).... (se
ceb0: 74 21 20 66 72 65 65 73 70 63 20 6e 65 77 76 61 t! freespc newva
cec0: 6c 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 l)))))).. (
ced0: 63 61 72 20 64 66 2d 72 65 73 75 6c 74 73 29 29 car df-results))
cee0: 0a 20 20 20 20 66 72 65 65 73 70 63 29 29 0a 0a . freespc))..
cef0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
cf00: 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 check-space-in-d
cf10: 69 72 20 64 69 72 70 61 74 68 20 72 65 71 75 69 ir dirpath requi
cf20: 72 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 red). (let* ((d
cf30: 62 73 70 61 63 65 20 20 28 69 66 20 28 64 69 72 bspace (if (dir
cf40: 65 63 74 6f 72 79 3f 20 64 69 72 70 61 74 68 29 ectory? dirpath)
cf50: 0a 09 09 20 20 20 20 20 20 20 28 67 65 74 2d 64 ... (get-d
cf60: 66 20 64 69 72 70 61 74 68 29 0a 09 09 20 20 20 f dirpath)...
cf70: 20 20 20 20 30 29 29 29 0a 20 20 20 20 28 6c 69 0))). (li
cf80: 73 74 20 28 3e 20 64 62 73 70 61 63 65 20 72 65 st (> dbspace re
cf90: 71 75 69 72 65 64 29 0a 09 20 20 64 62 73 70 61 quired).. dbspa
cfa0: 63 65 0a 09 20 20 72 65 71 75 69 72 65 64 0a 09 ce.. required..
cfb0: 20 20 64 69 72 70 61 74 68 29 29 29 0a 0a 3b 3b dirpath)))..;;
cfc0: 20 63 68 65 63 6b 20 73 70 61 63 65 20 69 6e 20 check space in
cfd0: 64 62 64 69 72 20 61 6e 64 20 69 6e 20 6d 65 67 dbdir and in meg
cfe0: 61 74 65 73 74 20 64 69 72 0a 3b 3b 20 72 65 74 atest dir.;; ret
cff0: 75 72 6e 73 3a 20 6f 6b 2f 6e 6f 74 20 64 62 73 urns: ok/not dbs
d000: 70 61 63 65 20 72 65 71 75 69 72 65 64 2d 73 70 pace required-sp
d010: 61 63 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ace.;;.(define (
d020: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d common:check-db-
d030: 64 69 72 2d 73 70 61 63 65 29 0a 20 20 28 6c 65 dir-space). (le
d040: 74 2a 20 28 28 72 65 71 75 69 72 65 64 20 28 73 t* ((required (s
d050: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 09 tring->number ..
d060: 09 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 . (or (config
d070: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
d080: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 64 62 dat* "setup" "db
d090: 64 69 72 2d 73 70 61 63 65 2d 72 65 71 75 69 72 dir-space-requir
d0a0: 65 64 22 29 0a 09 09 09 22 31 30 30 30 30 30 22 ed")...."100000"
d0b0: 29 29 29 0a 09 20 28 64 62 64 69 72 20 20 20 20 ))).. (dbdir
d0c0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 (common:get-db-t
d0d0: 6d 70 2d 61 72 65 61 29 29 20 3b 3b 20 28 64 62 mp-area)) ;; (db
d0e0: 3a 67 65 74 2d 64 62 64 69 72 29 29 0a 09 20 28 :get-dbdir)).. (
d0f0: 74 64 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e tdbspace (common
d100: 3a 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d :check-space-in-
d110: 64 69 72 20 64 62 64 69 72 20 72 65 71 75 69 72 dir dbdir requir
d120: 65 64 29 29 0a 09 20 28 6d 64 62 73 70 61 63 65 ed)).. (mdbspace
d130: 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 (common:check-s
d140: 70 61 63 65 2d 69 6e 2d 64 69 72 20 2a 74 6f 70 pace-in-dir *top
d150: 70 61 74 68 2a 20 72 65 71 75 69 72 65 64 29 29 path* required))
d160: 29 0a 20 20 20 20 28 73 6f 72 74 20 28 6c 69 73 ). (sort (lis
d170: 74 20 74 64 62 73 70 61 63 65 20 6d 64 62 73 70 t tdbspace mdbsp
d180: 61 63 65 29 20 28 6c 61 6d 62 64 61 20 28 61 20 ace) (lambda (a
d190: 62 29 0a 09 09 09 09 20 20 20 20 20 28 3c 20 28 b)..... (< (
d1a0: 63 61 64 72 20 61 29 28 63 61 64 72 20 62 29 29 cadr a)(cadr b))
d1b0: 29 29 29 29 0a 20 20 20 20 0a 3b 3b 20 63 68 65 )))). .;; che
d1c0: 63 6b 20 61 76 61 69 6c 61 62 6c 65 20 73 70 61 ck available spa
d1d0: 63 65 20 69 6e 20 64 62 64 69 72 2c 20 65 78 69 ce in dbdir, exi
d1e0: 74 20 69 66 20 69 6e 73 75 66 66 69 63 69 65 6e t if insufficien
d1f0: 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f t.;;.(define (co
d200: 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 mmon:check-db-di
d210: 72 2d 61 6e 64 2d 65 78 69 74 2d 69 66 2d 69 6e r-and-exit-if-in
d220: 73 75 66 66 69 63 69 65 6e 74 29 0a 20 20 28 6c sufficient). (l
d230: 65 74 2a 20 28 28 73 70 61 63 65 64 61 74 20 28 et* ((spacedat (
d240: 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 car (common:chec
d250: 6b 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 29 29 k-db-dir-space))
d260: 29 20 3b 3b 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 ) ;; look only a
d270: 74 20 77 6f 72 73 74 20 66 6f 72 20 6e 6f 77 0a t worst for now.
d280: 09 20 28 69 73 2d 6f 6b 20 20 20 20 28 63 61 72 . (is-ok (car
d290: 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 spacedat)).. (d
d2a0: 62 73 70 61 63 65 20 20 28 63 61 64 72 20 73 70 bspace (cadr sp
d2b0: 61 63 65 64 61 74 29 29 0a 09 20 28 72 65 71 75 acedat)).. (requ
d2c0: 69 72 65 64 20 28 63 61 64 64 72 20 73 70 61 63 ired (caddr spac
d2d0: 65 64 61 74 29 29 0a 09 20 28 64 62 64 69 72 20 edat)).. (dbdir
d2e0: 20 20 20 28 63 61 64 64 64 72 20 73 70 61 63 65 (cadddr space
d2f0: 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 dat))). (if (
d300: 6e 6f 74 20 69 73 2d 6f 6b 29 0a 09 28 62 65 67 not is-ok)..(beg
d310: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
d320: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
d330: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
d340: 6e 73 75 66 66 69 63 69 65 6e 74 20 73 70 61 63 nsufficient spac
d350: 65 20 69 6e 20 22 20 64 62 64 69 72 20 22 2c 20 e in " dbdir ",
d360: 72 65 71 75 69 72 65 20 22 20 72 65 71 75 69 72 require " requir
d370: 65 64 20 22 2c 20 68 61 76 65 20 22 20 64 62 73 ed ", have " dbs
d380: 70 61 63 65 20 20 22 2c 20 65 78 69 74 69 6e 67 pace ", exiting
d390: 20 6e 6f 77 2e 22 29 0a 09 20 20 28 65 78 69 74 now.").. (exit
d3a0: 20 31 29 29 29 29 29 0a 20 20 0a 3b 3b 20 70 61 1))))). .;; pa
d3b0: 74 68 73 20 69 73 20 6c 69 73 74 20 6f 66 20 6c ths is list of l
d3c0: 69 73 74 73 20 28 28 6e 61 6d 65 20 70 61 74 68 ists ((name path
d3d0: 29 20 2e 2e 2e 20 29 0a 3b 3b 0a 28 64 65 66 69 ) ... ).;;.(defi
d3e0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 ne (common:get-d
d3f0: 69 73 6b 2d 77 69 74 68 2d 6d 6f 73 74 2d 66 72 isk-with-most-fr
d400: 65 65 2d 73 70 61 63 65 20 64 69 73 6b 73 20 6d ee-space disks m
d410: 69 6e 73 69 7a 65 29 0a 20 20 28 6c 65 74 20 28 insize). (let (
d420: 28 62 65 73 74 20 20 20 20 20 23 66 29 0a 09 28 (best #f)..(
d430: 62 65 73 74 73 69 7a 65 20 30 29 29 0a 20 20 20 bestsize 0)).
d440: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
d450: 20 28 6c 61 6d 62 64 61 20 28 64 69 73 6b 2d 6e (lambda (disk-n
d460: 75 6d 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a um). (let*
d470: 20 28 28 64 69 72 70 61 74 68 20 20 20 20 28 63 ((dirpath (c
d480: 61 64 72 20 28 61 73 73 6f 63 20 64 69 73 6b 2d adr (assoc disk-
d490: 6e 75 6d 20 64 69 73 6b 73 29 29 29 0a 09 20 20 num disks)))..
d4a0: 20 20 20 20 28 66 72 65 65 73 70 63 20 20 20 20 (freespc
d4b0: 28 63 6f 6e 64 0a 09 09 09 20 20 20 28 28 6e 6f (cond.... ((no
d4c0: 74 20 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 t (directory? di
d4d0: 72 70 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 rpath)).... (
d4e0: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
d4f0: 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 oise-print 300 "
d500: 64 69 73 6b 73 20 6e 6f 74 20 61 20 64 69 72 20 disks not a dir
d510: 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 " disk-num).....
d520: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
d530: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
d540: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b * "WARNING: disk
d550: 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 " disk-num " at
d560: 20 70 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 path \"" dirpat
d570: 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 64 h "\" is not a d
d580: 69 72 65 63 74 6f 72 79 20 2d 20 69 67 6e 6f 72 irectory - ignor
d590: 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 ing it."))....
d5a0: 20 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f -1).... ((no
d5b0: 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 t (file-write-ac
d5c0: 63 65 73 73 3f 20 64 69 72 70 61 74 68 29 29 0a cess? dirpath)).
d5d0: 09 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d ... (if (comm
d5e0: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
d5f0: 6e 74 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f nt 300 "disks no
d600: 74 20 77 72 69 74 65 61 62 6c 65 20 22 20 64 69 t writeable " di
d610: 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 sk-num).....(deb
d620: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
d630: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
d640: 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 ARNING: disk " d
d650: 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 isk-num " at pat
d660: 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c h \"" dirpath "\
d670: 22 20 69 73 20 6e 6f 74 20 77 72 69 74 65 61 62 " is not writeab
d680: 6c 65 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 le - ignoring it
d690: 2e 22 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a .")).... -1).
d6a0: 09 09 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f ... ((not (eq?
d6b0: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 64 69 72 (string-ref dir
d6c0: 70 61 74 68 20 30 29 20 23 5c 2f 29 29 0a 09 09 path 0) #\/))...
d6d0: 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
d6e0: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
d6f0: 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 300 "disks not
d700: 61 20 70 72 6f 70 65 72 20 70 61 74 68 20 22 20 a proper path "
d710: 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 disk-num).....(d
d720: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
d730: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
d740: 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 "WARNING: disk "
d750: 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 disk-num " at p
d760: 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 ath \"" dirpath
d770: 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 66 75 6c "\" is not a ful
d780: 6c 79 20 71 75 61 6c 69 66 69 65 64 20 70 61 74 ly qualified pat
d790: 68 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e h - ignoring it.
d7a0: 22 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 ")).... -1)..
d7b0: 09 09 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 .. (else....
d7c0: 20 20 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 (get-df dirpat
d7d0: 68 29 29 29 29 29 0a 09 20 28 69 66 20 28 3e 20 h))))).. (if (>
d7e0: 66 72 65 65 73 70 63 20 62 65 73 74 73 69 7a 65 freespc bestsize
d7f0: 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ).. (begin..
d800: 20 20 20 20 20 20 20 28 73 65 74 21 20 62 65 73 (set! bes
d810: 74 20 20 20 20 20 28 63 6f 6e 73 20 64 69 73 6b t (cons disk
d820: 2d 6e 75 6d 20 64 69 72 70 61 74 68 29 29 0a 09 -num dirpath))..
d830: 20 20 20 20 20 20 20 28 73 65 74 21 20 62 65 73 (set! bes
d840: 74 73 69 7a 65 20 66 72 65 65 73 70 63 29 29 29 tsize freespc)))
d850: 29 29 0a 20 20 20 20 20 28 6d 61 70 20 63 61 72 )). (map car
d860: 20 64 69 73 6b 73 29 29 0a 20 20 20 20 28 69 66 disks)). (if
d870: 20 28 61 6e 64 20 62 65 73 74 20 28 3e 20 62 65 (and best (> be
d880: 73 74 73 69 7a 65 20 6d 69 6e 73 69 7a 65 29 29 stsize minsize))
d890: 0a 09 62 65 73 74 0a 09 23 66 29 29 29 20 3b 3b ..best..#f))) ;;
d8a0: 20 23 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 73 #f means no dis
d8b0: 6b 20 63 61 6e 64 69 64 61 74 65 20 66 6f 75 6e k candidate foun
d8c0: 64 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d d..;;===========
d8d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d8e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d8f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 ===========.;; E
d910: 20 4e 20 56 20 49 20 52 20 4f 20 4e 20 4d 20 45 N V I R O N M E
d920: 20 4e 20 54 20 20 20 56 20 41 20 52 20 53 0a 3b N T V A R S.;
d930: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
d940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d970: 3d 3d 3d 3d 3d 3d 3d 0a 09 20 20 20 20 20 20 0a =======.. .
d980: 28 64 65 66 69 6e 65 20 28 73 61 76 65 2d 65 6e (define (save-en
d990: 76 69 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c vironment-as-fil
d9a0: 65 73 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 es fname #!key (
d9b0: 69 67 6e 6f 72 65 76 61 72 73 20 28 6c 69 73 74 ignorevars (list
d9c0: 20 22 55 53 45 52 22 20 22 48 4f 4d 45 22 20 22 "USER" "HOME" "
d9d0: 44 49 53 50 4c 41 59 22 20 22 4c 53 5f 43 4f 4c DISPLAY" "LS_COL
d9e0: 4f 52 53 22 20 22 58 4b 45 59 53 59 4d 44 42 22 ORS" "XKEYSYMDB"
d9f0: 20 22 45 44 49 54 4f 52 22 20 22 4d 41 4b 45 46 "EDITOR" "MAKEF
da00: 4c 41 47 53 22 20 22 4d 41 4b 45 46 22 20 22 4d LAGS" "MAKEF" "M
da10: 41 4b 45 4f 56 45 52 52 49 44 45 53 22 29 29 29 AKEOVERRIDES")))
da20: 0a 20 20 28 6c 65 74 20 28 28 65 6e 76 76 61 72 . (let ((envvar
da30: 73 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 s (get-environme
da40: 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 nt-variables)).
da50: 20 20 20 20 20 20 20 28 77 68 69 74 65 73 70 20 (whitesp
da60: 28 72 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d (regexp "[^a-zA-
da70: 5a 30 2d 39 5f 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 24 Z0-9_\\-:,.\\/%$
da80: 5d 22 29 29 0a 09 28 6d 75 6e 67 65 76 61 6c 20 ]"))..(mungeval
da90: 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 09 09 (lambda (val)...
daa0: 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 (cond...
dab0: 20 28 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 ((eq? val #t) "
dac0: 22 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 74 ") ;; convert #t
dad0: 20 74 6f 20 65 6d 70 74 79 20 73 74 72 69 6e 67 to empty string
dae0: 0a 09 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 ... ((eq? va
daf0: 6c 20 23 66 29 20 23 66 29 20 3b 3b 20 63 6f 6e l #f) #f) ;; con
db00: 76 65 72 74 20 23 66 20 74 6f 20 69 74 73 65 6c vert #f to itsel
db10: 66 20 28 73 74 69 6c 6c 20 74 68 69 6e 6b 69 6e f (still thinkin
db20: 67 20 61 62 6f 75 74 20 74 68 69 73 20 6f 6e 65 g about this one
db30: 0a 09 09 20 20 20 20 20 28 65 6c 73 65 20 76 61 ... (else va
db40: 6c 29 29 29 29 29 0a 20 20 20 20 20 28 77 69 74 l))))). (wit
db50: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
db60: 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 (conc fname ".c
db70: 73 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d sh"). (lam
db80: 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 bda ().
db90: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
dba0: 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 da (keyval)...
dbb0: 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 (let* ((key
dbc0: 20 20 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a (car keyval)).
dbd0: 09 09 09 20 20 20 20 20 28 76 61 6c 20 20 20 28 ... (val (
dbe0: 63 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 cdr keyval))....
dbf0: 20 20 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 (delim (if
dc00: 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 (string-search w
dc10: 68 69 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 hitesp val) ....
dc20: 09 09 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 .."\""......""))
dc30: 29 0a 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 )....(print (if
dc40: 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 6e 6f (member key igno
dc50: 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 20 22 revars)..... "
dc60: 23 20 73 65 74 65 6e 76 20 22 0a 09 09 09 09 20 # setenv ".....
dc70: 20 20 22 73 65 74 65 6e 76 20 22 29 0a 09 09 09 "setenv ")....
dc80: 20 20 20 20 20 20 20 6b 65 79 20 22 20 22 20 64 key " " d
dc90: 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c 20 76 elim (mungeval v
dca0: 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a 09 09 20 al) delim)))...
dcb0: 20 20 20 65 6e 76 76 61 72 73 29 29 29 0a 20 20 envvars))).
dcc0: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
dcd0: 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e to-file (conc fn
dce0: 61 6d 65 20 22 2e 73 68 22 29 0a 20 20 20 20 20 ame ".sh").
dcf0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
dd00: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
dd10: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c (lambda (keyval
dd20: 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 )... (let*
dd30: 28 28 6b 65 79 20 28 63 61 72 20 6b 65 79 76 61 ((key (car keyva
dd40: 6c 29 29 0a 09 09 09 20 20 20 20 20 28 76 61 6c l)).... (val
dd50: 20 28 63 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 (cdr keyval))..
dd60: 09 09 20 20 20 20 20 28 64 65 6c 69 6d 20 28 69 .. (delim (i
dd70: 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 f (string-search
dd80: 20 77 68 69 74 65 73 70 20 76 61 6c 29 20 0a 09 whitesp val) ..
dd90: 09 09 09 09 22 5c 22 22 0a 09 09 09 09 09 22 22 ...."\""......""
dda0: 29 29 29 0a 09 09 09 28 70 72 69 6e 74 20 28 69 )))....(print (i
ddb0: 66 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 f (member key ig
ddc0: 6e 6f 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 norevars).....
ddd0: 20 22 23 20 65 78 70 6f 72 74 20 22 0a 09 09 09 "# export "....
dde0: 09 20 20 20 22 65 78 70 6f 72 74 20 22 29 0a 09 . "export ")..
ddf0: 09 09 20 20 20 20 20 20 20 6b 65 79 20 22 3d 22 .. key "="
de00: 20 64 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c delim (mungeval
de10: 20 76 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a 20 val) delim))).
de20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de30: 20 20 20 65 6e 76 76 61 72 73 29 29 29 29 29 0a envvars))))).
de40: 0a 3b 3b 20 73 65 74 20 73 6f 6d 65 20 65 6e 76 .;; set some env
de50: 20 76 61 72 73 20 66 72 6f 6d 20 61 6e 20 61 6c vars from an al
de60: 69 73 74 2c 20 72 65 74 75 72 6e 20 61 6e 20 61 ist, return an a
de70: 6c 69 73 74 20 77 69 74 68 20 6f 72 69 67 69 6e list with origin
de80: 61 6c 20 76 61 6c 75 65 73 0a 3b 3b 20 28 28 22 al values.;; (("
de90: 56 41 52 22 20 22 76 61 6c 75 65 22 29 20 2e 2e VAR" "value") ..
dea0: 2e 29 0a 28 64 65 66 69 6e 65 20 28 61 6c 69 73 .).(define (alis
deb0: 74 2d 3e 65 6e 76 2d 76 61 72 73 20 6c 73 74 29 t->env-vars lst)
dec0: 0a 20 20 28 69 66 20 28 6c 69 73 74 3f 20 6c 73 . (if (list? ls
ded0: 74 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 t). (let ((
dee0: 72 65 73 20 27 28 29 29 29 0a 09 28 66 6f 72 2d res '()))..(for-
def0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 29 each (lambda (p)
df00: 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 76 ... (let* ((v
df10: 61 72 20 28 63 61 72 20 20 70 29 29 0a 09 09 09 ar (car p))....
df20: 20 20 20 28 76 61 6c 20 28 63 61 64 72 20 70 29 (val (cadr p)
df30: 29 0a 09 09 09 20 20 20 28 70 72 76 20 28 67 65 ).... (prv (ge
df40: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
df50: 72 69 61 62 6c 65 20 76 61 72 29 29 29 0a 09 09 riable var)))...
df60: 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 (set! res
df70: 28 63 6f 6e 73 20 28 6c 69 73 74 20 76 61 72 20 (cons (list var
df80: 70 72 76 29 20 72 65 73 29 29 0a 09 09 20 20 20 prv) res))...
df90: 20 20 20 28 69 66 20 76 61 6c 20 0a 09 09 09 20 (if val ....
dfa0: 20 28 73 65 74 65 6e 76 20 76 61 72 20 28 2d 3e (setenv var (->
dfb0: 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 string val))....
dfc0: 20 20 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 (unsetenv var)
dfd0: 29 29 29 0a 09 09 20 20 6c 73 74 29 0a 09 72 65 )))... lst)..re
dfe0: 73 29 0a 20 20 20 20 20 20 27 28 29 29 29 0a 0a s). '()))..
dff0: 3b 3b 20 63 6c 65 61 72 20 76 61 72 73 20 6d 61 ;; clear vars ma
e000: 74 63 68 69 6e 67 20 70 61 74 74 65 72 6e 2c 20 tching pattern,
e010: 72 75 6e 20 70 72 6f 63 2c 20 73 65 74 20 76 61 run proc, set va
e020: 72 73 20 62 61 63 6b 0a 3b 3b 20 69 66 20 70 72 rs back.;; if pr
e030: 6f 63 20 69 73 20 61 20 73 74 72 69 6e 67 20 72 oc is a string r
e040: 75 6e 20 74 68 61 74 20 73 74 72 69 6e 67 20 61 un that string a
e050: 73 20 61 20 63 6f 6d 6d 61 6e 64 20 77 69 74 68 s a command with
e060: 0a 3b 3b 20 73 79 73 74 65 6d 2e 0a 3b 3b 0a 28 .;; system..;;.(
e070: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
e080: 69 74 68 6f 75 74 2d 76 61 72 73 20 70 72 6f 63 ithout-vars proc
e090: 20 2e 20 76 61 72 2d 70 61 74 74 73 29 0a 20 20 . var-patts).
e0a0: 28 6c 65 74 20 28 28 76 61 72 73 20 28 6d 61 6b (let ((vars (mak
e0b0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
e0c0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
e0d0: 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 64 (lambda (vard
e0e0: 61 74 29 20 3b 3b 20 65 61 63 68 20 65 6e 76 20 at) ;; each env
e0f0: 76 61 72 0a 20 20 20 20 20 20 20 28 66 6f 72 2d var. (for-
e100: 65 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 76 each..(lambda (v
e110: 61 72 2d 70 61 74 74 29 0a 09 20 20 28 69 66 20 ar-patt).. (if
e120: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 76 61 (string-match va
e130: 72 2d 70 61 74 74 20 28 63 61 72 20 76 61 72 64 r-patt (car vard
e140: 61 74 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 at)).. (let
e150: 20 28 28 76 61 72 20 28 63 61 72 20 76 61 72 64 ((var (car vard
e160: 61 74 29 29 0a 09 09 20 20 20 20 28 76 61 6c 20 at))... (val
e170: 28 63 64 72 20 76 61 72 64 61 74 29 29 29 0a 09 (cdr vardat)))..
e180: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
e190: 21 20 76 61 72 73 20 76 61 72 20 76 61 6c 29 0a ! vars var val).
e1a0: 09 09 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 ..(unsetenv var)
e1b0: 29 29 29 0a 09 76 61 72 2d 70 61 74 74 73 29 29 )))..var-patts))
e1c0: 0a 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 . (get-envir
e1d0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 onment-variables
e1e0: 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 )). (cond.
e1f0: 20 20 28 28 73 74 72 69 6e 67 3f 20 70 72 6f 63 ((string? proc
e200: 29 28 73 79 73 74 65 6d 20 70 72 6f 63 29 29 0a )(system proc)).
e210: 20 20 20 20 20 28 70 72 6f 63 20 20 20 20 20 20 (proc
e220: 20 20 20 20 28 70 72 6f 63 29 29 29 0a 20 20 20 (proc))).
e230: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 (hash-table-for
e240: 2d 65 61 63 68 0a 20 20 20 20 20 76 61 72 73 0a -each. vars.
e250: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 (lambda (va
e260: 72 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 r val). (s
e270: 65 74 65 6e 76 20 76 61 72 20 76 61 6c 29 29 29 etenv var val)))
e280: 0a 20 20 20 20 76 61 72 73 29 29 0a 0a 28 64 65 . vars))..(de
e290: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e fine (common:run
e2a0: 2d 61 2d 63 6f 6d 6d 61 6e 64 20 63 6d 64 20 23 -a-command cmd #
e2b0: 21 6b 65 79 20 28 77 69 74 68 2d 76 61 72 73 20 !key (with-vars
e2c0: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 #f)). (let* ((p
e2d0: 72 65 2d 63 6d 64 20 20 28 64 74 65 73 74 73 3a re-cmd (dtests:
e2e0: 67 65 74 2d 70 72 65 2d 63 6f 6d 6d 61 6e 64 29 get-pre-command)
e2f0: 29 0a 20 20 20 20 20 20 20 20 20 28 70 6f 73 74 ). (post
e300: 2d 63 6d 64 20 28 64 74 65 73 74 73 3a 67 65 74 -cmd (dtests:get
e310: 2d 70 6f 73 74 2d 63 6f 6d 6d 61 6e 64 29 29 0a -post-command)).
e320: 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c 63 6d (fullcm
e330: 64 20 20 28 69 66 20 28 6f 72 20 70 72 65 2d 63 d (if (or pre-c
e340: 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 md post-cmd).
e350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e360: 20 20 20 20 28 63 6f 6e 63 20 70 72 65 2d 63 6d (conc pre-cm
e370: 64 20 63 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a d cmd post-cmd).
e380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e390: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 76 69 (conc "vi
e3a0: 65 77 73 63 72 65 65 6e 20 22 20 63 6d 64 29 29 ewscreen " cmd))
e3b0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
e3c0: 69 6e 74 2d 69 6e 66 6f 20 30 32 20 2a 64 65 66 int-info 02 *def
e3d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
e3e0: 52 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 3a Running command:
e3f0: 20 22 20 66 75 6c 6c 63 6d 64 29 0a 20 20 20 20 " fullcmd).
e400: 28 69 66 20 77 69 74 68 2d 76 61 72 73 0a 20 20 (if with-vars.
e410: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 (common:wi
e420: 74 68 6f 75 74 2d 76 61 72 73 20 63 6d 64 29 0a thout-vars cmd).
e430: 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a (common:
e440: 77 69 74 68 6f 75 74 2d 76 61 72 73 20 66 75 6c without-vars ful
e450: 6c 63 6d 64 20 22 4d 54 5f 2e 2a 22 29 29 29 29 lcmd "MT_.*"))))
e460: 0a 09 09 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ... .;;========
e470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
e4b0: 3b 20 54 20 49 20 4d 20 45 20 20 20 41 20 4e 20 ; T I M E A N
e4c0: 44 20 20 20 44 20 41 20 54 20 45 0a 3b 3b 3d 3d D D A T E.;;==
e4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e510: 3d 3d 3d 3d 0a 0a 3b 3b 20 43 6f 6e 76 65 72 74 ====..;; Convert
e520: 20 73 74 72 69 6e 67 73 20 6c 69 6b 65 20 22 35 strings like "5
e530: 73 20 32 68 20 33 6d 22 20 3d 3e 20 36 30 78 36 s 2h 3m" => 60x6
e540: 30 78 32 20 2b 20 33 78 36 30 20 2b 20 35 0a 28 0x2 + 3x60 + 5.(
e550: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 define (common:h
e560: 6d 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e ms-string->secon
e570: 64 73 20 74 73 74 72 29 0a 20 20 28 6c 65 74 20 ds tstr). (let
e580: 28 28 70 61 72 74 73 20 20 20 20 20 28 73 74 72 ((parts (str
e590: 69 6e 67 2d 73 70 6c 69 74 20 74 73 74 72 29 29 ing-split tstr))
e5a0: 0a 09 28 74 69 6d 65 2d 73 65 63 73 20 30 29 0a ..(time-secs 0).
e5b0: 09 3b 3b 20 73 3d 73 65 63 6f 6e 64 73 2c 20 6d .;; s=seconds, m
e5c0: 3d 6d 69 6e 75 74 65 73 2c 20 68 3d 68 6f 75 72 =minutes, h=hour
e5d0: 73 2c 20 64 3d 64 61 79 73 0a 09 28 74 72 78 20 s, d=days..(trx
e5e0: 20 20 20 20 20 20 28 72 65 67 65 78 70 20 22 28 (regexp "(
e5f0: 5c 5c 64 2b 29 28 5b 73 6d 68 64 5d 29 22 29 29 \\d+)([smhd])"))
e600: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
e610: 28 6c 61 6d 62 64 61 20 28 70 61 72 74 29 0a 09 (lambda (part)..
e620: 09 28 6c 65 74 20 28 28 6d 61 74 63 68 20 20 28 .(let ((match (
e630: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 74 72 78 string-match trx
e640: 20 70 61 72 74 29 29 29 0a 09 09 20 20 28 69 66 part)))... (if
e650: 20 6d 61 74 63 68 0a 09 09 20 20 20 20 20 20 28 match... (
e660: 6c 65 74 20 28 28 76 61 6c 20 28 73 74 72 69 6e let ((val (strin
e670: 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 g->number (cadr
e680: 6d 61 74 63 68 29 29 29 0a 09 09 09 20 20 20 20 match)))....
e690: 28 75 6e 74 20 28 63 61 64 64 72 20 6d 61 74 63 (unt (caddr matc
e6a0: 68 29 29 29 0a 09 09 09 28 69 66 20 76 61 6c 20 h)))....(if val
e6b0: 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 74 69 .... (set! ti
e6c0: 6d 65 2d 73 65 63 73 20 28 2b 20 74 69 6d 65 2d me-secs (+ time-
e6d0: 73 65 63 73 20 28 2a 20 76 61 6c 0a 09 09 09 09 secs (* val.....
e6e0: 09 09 09 20 20 20 20 28 63 61 73 65 20 28 73 74 ... (case (st
e6f0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 75 6e 74 ring->symbol unt
e700: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 )........ (
e710: 28 73 29 20 31 29 0a 09 09 09 09 09 09 09 20 20 (s) 1)........
e720: 20 20 20 20 28 28 6d 29 20 36 30 29 0a 09 09 09 ((m) 60)....
e730: 09 09 09 09 20 20 20 20 20 20 28 28 68 29 20 28 .... ((h) (
e740: 2a 20 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 * 60 60)).......
e750: 09 20 20 20 20 20 20 28 28 64 29 20 28 2a 20 32 . ((d) (* 2
e760: 34 20 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 4 60 60)).......
e770: 09 20 20 20 20 20 20 28 65 6c 73 65 20 30 29 29 . (else 0))
e780: 29 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 ))))))))..
e790: 70 61 72 74 73 29 0a 20 20 20 20 74 69 6d 65 2d parts). time-
e7a0: 73 65 63 73 29 29 0a 09 09 20 20 20 20 20 20 20 secs))...
e7b0: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
e7c0: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 s->hr-min-sec se
e7d0: 63 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 cs). (let* ((hr
e7e0: 73 20 28 71 75 6f 74 69 65 6e 74 20 73 65 63 73 s (quotient secs
e7f0: 20 33 36 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 3600)).. (min (
e800: 71 75 6f 74 69 65 6e 74 20 28 2d 20 73 65 63 73 quotient (- secs
e810: 20 28 2a 20 68 72 73 20 33 36 30 30 29 29 20 36 (* hrs 3600)) 6
e820: 30 29 29 0a 09 20 28 73 65 63 20 28 2d 20 73 65 0)).. (sec (- se
e830: 63 73 20 28 2a 20 68 72 73 20 33 36 30 30 29 28 cs (* hrs 3600)(
e840: 2a 20 6d 69 6e 20 36 30 29 29 29 29 0a 20 20 20 * min 60)))).
e850: 20 28 63 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 (conc (if (> hr
e860: 73 20 30 29 28 63 6f 6e 63 20 68 72 73 20 22 68 s 0)(conc hrs "h
e870: 72 20 22 29 20 22 22 29 0a 09 20 20 28 69 66 20 r ") "").. (if
e880: 28 3e 20 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d (> min 0)(conc m
e890: 69 6e 20 22 6d 20 22 29 20 20 22 22 29 0a 09 20 in "m ") "")..
e8a0: 20 73 65 63 20 22 73 22 29 29 29 0a 0a 28 64 65 sec "s")))..(de
e8b0: 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 fine (seconds->t
e8c0: 69 6d 65 2d 73 74 72 69 6e 67 20 73 65 63 29 0a ime-string sec).
e8d0: 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 (time->string
e8e0: 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
e8f0: 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 cal-time sec) "%
e900: 48 3a 25 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 H:%M:%S"))..(def
e910: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f ine (seconds->wo
e920: 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 rk-week/day-time
e930: 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
e940: 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 tring. (second
e950: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
e960: 63 29 20 22 77 77 25 56 2e 25 75 20 25 48 3a 25 c) "ww%V.%u %H:%
e970: 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 M"))..(define (s
e980: 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 econds->work-wee
e990: 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 k/day sec). (ti
e9a0: 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 me->string. (s
e9b0: 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
e9c0: 6d 65 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 me sec) "ww%V.%u
e9d0: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
e9e0: 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b conds->year-work
e9f0: 2d 77 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 -week/day sec).
ea00: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 (time->string.
ea10: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
ea20: 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 79 77 l-time sec) "%yw
ea30: 77 25 56 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 w%V.%w"))..(defi
ea40: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 ne (seconds->yea
ea50: 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d r-work-week/day-
ea60: 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d time sec). (tim
ea70: 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 e->string. (se
ea80: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
ea90: 65 20 73 65 63 29 20 22 25 59 77 77 25 56 2e 25 e sec) "%Yww%V.%
eaa0: 77 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 w %H:%M"))..(def
eab0: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 ine (seconds->ye
eac0: 61 72 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 ar-week/day-time
ead0: 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
eae0: 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 tring. (second
eaf0: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
eb00: 63 29 20 22 25 59 77 25 56 2e 25 77 20 25 48 3a c) "%Yw%V.%w %H:
eb10: 25 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 %M"))..(define (
eb20: 73 65 63 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 seconds->quarter
eb30: 20 73 65 63 29 0a 20 20 28 63 61 73 65 20 28 73 sec). (case (s
eb40: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 tring->number..
eb50: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 09 (time->string ..
eb60: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
eb70: 6c 2d 74 69 6d 65 20 73 65 63 29 0a 09 20 20 22 l-time sec).. "
eb80: 25 6d 22 29 29 0a 20 20 20 20 28 28 31 20 32 20 %m")). ((1 2
eb90: 33 29 20 31 29 0a 20 20 20 20 28 28 34 20 35 20 3) 1). ((4 5
eba0: 36 29 20 32 29 0a 20 20 20 20 28 28 37 20 38 20 6) 2). ((7 8
ebb0: 39 29 20 33 29 0a 20 20 20 20 28 28 31 30 20 31 9) 3). ((10 1
ebc0: 31 20 31 32 29 20 34 29 0a 20 20 20 20 28 65 6c 1 12) 4). (el
ebd0: 73 65 20 23 66 29 29 29 0a 0a 3b 3b 20 67 69 76 se #f)))..;; giv
ebe0: 65 6e 20 73 70 61 6e 20 6f 66 20 73 65 63 6f 6e en span of secon
ebf0: 64 73 20 74 73 74 61 72 74 20 74 6f 20 74 65 6e ds tstart to ten
ec00: 64 0a 3b 3b 20 66 69 6e 64 20 73 74 61 72 74 20 d.;; find start
ec10: 74 69 6d 65 20 74 6f 20 6d 61 72 6b 20 61 6e 64 time to mark and
ec20: 20 6d 61 72 6b 20 64 65 6c 74 61 0a 3b 3b 0a 28 mark delta.;;.(
ec30: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 define (common:f
ec40: 69 6e 64 2d 73 74 61 72 74 2d 6d 61 72 6b 2d 61 ind-start-mark-a
ec50: 6e 64 2d 6d 61 72 6b 2d 64 65 6c 74 61 20 74 73 nd-mark-delta ts
ec60: 74 61 72 74 20 74 65 6e 64 29 0a 20 20 28 6c 65 tart tend). (le
ec70: 74 2a 20 28 28 64 65 6c 74 61 74 20 20 20 28 2d t* ((deltat (-
ec80: 20 28 6d 61 78 20 74 65 6e 64 20 28 2b 20 74 65 (max tend (+ te
ec90: 6e 64 20 31 30 29 29 20 74 73 74 61 72 74 29 29 nd 10)) tstart))
eca0: 20 3b 3b 20 63 61 6e 27 74 20 68 61 6e 64 6c 65 ;; can't handle
ecb0: 20 72 75 6e 73 20 6f 66 20 6c 65 73 73 20 74 68 runs of less th
ecc0: 61 6e 20 34 20 73 65 63 6f 6e 64 73 2e 20 50 61 an 4 seconds. Pa
ecd0: 64 20 69 74 20 74 6f 20 31 30 20 73 65 63 6f 6e d it to 10 secon
ece0: 64 73 20 2e 2e 2e 0a 09 20 28 72 65 73 75 6c 74 ds ..... (result
ecf0: 20 20 20 23 66 29 0a 09 20 28 6d 69 6e 20 20 20 #f).. (min
ed00: 20 20 20 36 30 29 0a 09 20 28 68 72 20 20 20 20 60).. (hr
ed10: 20 20 20 28 2a 20 36 30 20 36 30 29 29 0a 09 20 (* 60 60))..
ed20: 28 64 61 79 20 20 20 20 20 20 28 2a 20 32 34 20 (day (* 24
ed30: 68 72 29 29 0a 09 20 28 79 72 20 20 20 20 20 20 hr)).. (yr
ed40: 20 28 2a 20 33 36 35 20 64 61 79 29 29 20 3b 3b (* 365 day)) ;;
ed50: 20 79 65 61 72 0a 09 20 28 6d 6f 20 20 20 20 20 year.. (mo
ed60: 20 20 28 2f 20 79 72 20 31 32 29 29 0a 09 20 28 (/ yr 12)).. (
ed70: 77 6b 20 20 20 20 20 20 20 28 2a 20 64 61 79 20 wk (* day
ed80: 37 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 7))). (for-ea
ed90: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
eda0: 28 6d 61 78 2d 62 6c 6b 73 29 0a 20 20 20 20 20 (max-blks).
edb0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 (for-each..(la
edc0: 6d 62 64 61 20 28 73 70 61 6e 29 20 3b 3b 20 35 mbda (span) ;; 5
edd0: 20 32 20 31 0a 09 20 20 28 69 66 20 28 6e 6f 74 2 1.. (if (not
ede0: 20 72 65 73 75 6c 74 29 0a 09 20 20 20 20 20 20 result)..
edf0: 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 (for-each ..
ee00: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 69 6d 65 (lambda (time
ee10: 75 6e 69 74 20 74 69 6d 65 73 79 6d 29 20 3b 3b unit timesym) ;;
ee20: 20 79 65 61 72 20 6d 6f 6e 74 68 20 64 61 79 20 year month day
ee30: 68 72 20 6d 69 6e 20 73 65 63 0a 09 09 20 28 69 hr min sec... (i
ee40: 66 20 28 6e 6f 74 20 72 65 73 75 6c 74 29 0a 09 f (not result)..
ee50: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 69 . (let* ((ti
ee60: 6d 65 2d 62 6c 6b 20 28 2a 20 73 70 61 6e 20 74 me-blk (* span t
ee70: 69 6d 65 75 6e 69 74 29 29 0a 09 09 09 20 20 20 imeunit))....
ee80: 20 28 6e 75 6d 2d 62 6c 6b 73 20 28 71 75 6f 74 (num-blks (quot
ee90: 69 65 6e 74 20 64 65 6c 74 61 74 20 74 69 6d 65 ient deltat time
eea0: 2d 62 6c 6b 29 29 29 0a 09 09 20 20 20 20 20 20 -blk)))...
eeb0: 20 28 69 66 20 28 61 6e 64 20 28 3e 20 6e 75 6d (if (and (> num
eec0: 2d 62 6c 6b 73 20 34 29 28 3c 20 6e 75 6d 2d 62 -blks 4)(< num-b
eed0: 6c 6b 73 20 6d 61 78 2d 62 6c 6b 73 29 29 0a 09 lks max-blks))..
eee0: 09 09 20 20 20 28 6c 65 74 20 28 28 66 69 72 73 .. (let ((firs
eef0: 74 20 28 2a 20 28 71 75 6f 74 69 65 6e 74 20 74 t (* (quotient t
ef00: 73 74 61 72 74 20 74 69 6d 65 2d 62 6c 6b 29 20 start time-blk)
ef10: 74 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 09 20 time-blk)))....
ef20: 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 (set! result
ef30: 20 28 6c 69 73 74 20 73 70 61 6e 20 74 69 6d 65 (list span time
ef40: 75 6e 69 74 20 74 69 6d 65 2d 62 6c 6b 20 66 69 unit time-blk fi
ef50: 72 73 74 20 74 69 6d 65 73 79 6d 29 29 0a 09 09 rst timesym))...
ef60: 09 20 20 20 20 20 29 29 29 29 29 0a 09 20 20 20 . )))))..
ef70: 20 20 20 20 28 6c 69 73 74 20 79 72 20 6d 6f 20 (list yr mo
ef80: 77 6b 20 64 61 79 20 68 72 20 6d 69 6e 20 31 29 wk day hr min 1)
ef90: 0a 09 20 20 20 20 20 20 20 27 28 20 20 20 20 20 .. '(
efa0: 79 20 20 6d 6f 20 77 20 20 64 20 20 20 68 20 20 y mo w d h
efb0: 6d 20 20 20 73 29 29 29 29 0a 09 28 6c 69 73 74 m s))))..(list
efc0: 20 38 20 36 20 35 20 32 20 31 29 29 29 0a 20 20 8 6 5 2 1))).
efd0: 20 20 20 27 28 35 20 31 30 20 31 35 20 32 30 20 '(5 10 15 20
efe0: 33 30 20 34 30 20 35 30 20 35 30 30 29 29 0a 20 30 40 50 500)).
eff0: 20 20 20 28 69 66 20 76 61 6c 75 65 73 0a 09 28 (if values..(
f000: 61 70 70 6c 79 20 76 61 6c 75 65 73 20 72 65 73 apply values res
f010: 75 6c 74 29 0a 09 28 76 61 6c 75 65 73 20 30 20 ult)..(values 0
f020: 64 61 79 20 31 20 30 20 27 64 29 29 29 29 0a 09 day 1 0 'd))))..
f030: 20 20 20 20 0a 09 20 20 0a 0a 3b 3b 3d 3d 3d 3d .. ..;;====
f040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f080: 3d 3d 0a 3b 3b 20 43 20 4f 20 4c 20 4f 20 52 20 ==.;; C O L O R
f090: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
f0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 ==========.
f0e0: 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f .(define (commo
f0f0: 6e 3a 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f n:name->iup-colo
f100: 72 20 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 r name). (case
f110: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
f120: 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 (string-downcase
f130: 20 6e 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 name)). ((re
f140: 64 29 20 20 20 20 22 32 32 33 20 33 33 20 34 39 d) "223 33 49
f150: 22 29 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 "). ((grey)
f160: 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 0a "192 192 192").
f170: 20 20 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 ((orange) "2
f180: 35 35 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 55 172 13").
f190: 28 28 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 ((purple) "This
f1a0: 69 73 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e is unfinished ..
f1b0: 2e 22 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e .")))..;; (defin
f1c0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f e (common:get-co
f1d0: 6c 6f 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 lor-for-state-st
f1e0: 61 74 75 73 20 73 74 61 74 65 20 73 74 61 74 75 atus state statu
f1f0: 73 29 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 73 s).;; (case (s
f200: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 tring->symbol st
f210: 61 74 65 29 0a 3b 3b 20 20 20 20 20 28 28 43 4f ate).;; ((CO
f220: 4d 50 4c 45 54 45 44 29 0a 3b 3b 20 20 20 20 20 MPLETED).;;
f230: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
f240: 73 79 6d 62 6f 6c 20 73 74 61 74 75 73 29 0a 3b symbol status).;
f250: 3b 20 20 20 20 20 20 20 20 28 28 50 41 53 53 29 ; ((PASS)
f260: 20 20 20 20 20 20 20 20 22 37 30 20 20 32 34 39 "70 249
f270: 20 37 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 73").;;
f280: 28 28 57 41 52 4e 20 57 41 49 56 45 44 29 20 22 ((WARN WAIVED) "
f290: 32 35 35 20 31 37 32 20 31 33 22 29 0a 3b 3b 20 255 172 13").;;
f2a0: 20 20 20 20 20 20 20 28 28 53 4b 49 50 29 20 20 ((SKIP)
f2b0: 20 20 20 20 20 20 22 32 33 30 20 32 33 30 20 30 "230 230 0
f2c0: 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 65 6c ").;; (el
f2d0: 73 65 20 22 32 32 33 20 33 33 20 34 39 22 29 29 se "223 33 49"))
f2e0: 29 0a 3b 3b 20 20 20 20 20 28 28 4c 41 55 4e 43 ).;; ((LAUNC
f2f0: 48 45 44 29 20 20 20 20 20 20 20 20 20 22 31 30 HED) "10
f300: 31 20 31 32 33 20 31 34 32 22 29 0a 3b 3b 20 20 1 123 142").;;
f310: 20 20 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 ((CHECK)
f320: 20 20 20 20 20 20 20 22 32 35 35 20 31 30 30 20 "255 100
f330: 35 30 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 45 50").;; ((RE
f340: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 MOTEHOSTSTART)
f350: 22 35 30 20 20 31 33 30 20 31 39 35 22 29 0a 3b "50 130 195").;
f360: 3b 20 20 20 20 20 28 28 52 55 4e 4e 49 4e 47 29 ; ((RUNNING)
f370: 20 20 20 20 20 20 20 20 20 20 22 39 20 20 20 31 "9 1
f380: 33 31 20 32 33 32 22 29 0a 3b 3b 20 20 20 20 20 31 232").;;
f390: 28 28 4b 49 4c 4c 52 45 51 29 20 20 20 20 20 20 ((KILLREQ)
f3a0: 20 20 20 20 22 33 39 20 20 38 32 20 20 32 30 36 "39 82 206
f3b0: 22 29 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c ").;; ((KILL
f3c0: 45 44 29 20 20 20 20 20 20 20 20 20 20 20 22 32 ED) "2
f3d0: 33 34 20 31 30 31 20 31 37 22 29 0a 3b 3b 20 20 34 101 17").;;
f3e0: 20 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 ((NOT_STARTED
f3f0: 29 20 20 20 20 20 20 22 32 34 30 20 32 34 30 20 ) "240 240
f400: 32 34 30 22 29 0a 3b 3b 20 20 20 20 20 28 65 6c 240").;; (el
f410: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
f420: 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 29 "192 192 192"))
f430: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
f440: 6f 6e 3a 69 75 70 2d 63 6f 6c 6f 72 2d 3e 72 67 on:iup-color->rg
f450: 62 2d 68 65 78 20 69 6e 73 74 72 29 0a 20 20 28 b-hex instr). (
f460: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
f470: 73 65 20 0a 20 20 20 28 6d 61 70 20 28 6c 61 6d se . (map (lam
f480: 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 bda (x).
f490: 20 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e (number->strin
f4a0: 67 20 78 20 31 36 29 29 0a 20 20 20 20 20 20 20 g x 16)).
f4b0: 20 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 (map string->nu
f4c0: 6d 62 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 mber.
f4d0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
f4e0: 69 6e 73 74 72 29 29 29 0a 20 20 20 22 2f 22 29 instr))). "/")
f4f0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
f500: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
f510: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
f520: 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 65 71 . (cond. ((eq
f530: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 ual? status "PAS
f540: 53 22 29 20 20 20 20 22 67 72 65 65 6e 22 29 0a S") "green").
f550: 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
f560: 75 73 20 22 46 41 49 4c 22 29 20 20 20 20 22 72 us "FAIL") "r
f570: 65 64 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ed"). ((equal?
f580: 20 73 74 61 74 75 73 20 22 57 41 52 4e 22 29 20 status "WARN")
f590: 20 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 "orange").
f5a0: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
f5b0: 22 4b 49 4c 4c 45 44 22 29 20 20 22 6f 72 61 6e "KILLED") "oran
f5c0: 67 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ge"). ((equal?
f5d0: 20 73 74 61 74 75 73 20 22 4b 49 4c 4c 52 45 51 status "KILLREQ
f5e0: 22 29 20 22 70 75 72 70 6c 65 22 29 0a 20 20 20 ") "purple").
f5f0: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
f600: 22 52 55 4e 4e 49 4e 47 22 29 20 22 62 6c 75 65 "RUNNING") "blue
f610: 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 "). ((equal? s
f620: 74 61 74 75 73 20 22 41 42 4f 52 54 22 29 20 20 tatus "ABORT")
f630: 20 22 62 72 6f 77 6e 22 29 0a 20 20 20 28 65 6c "brown"). (el
f640: 73 65 20 22 62 6c 61 63 6b 22 29 29 29 0a 0a 3b se "black")))..;
f650: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
f660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f690: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 20 41 20 4e =======.;; N A N
f6a0: 20 4f 20 4d 20 53 20 47 20 20 20 43 20 4c 20 49 O M S G C L I
f6b0: 20 45 20 4e 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d E N T.;;=======
f6c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
f700: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
f710: 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d :get-best-guess-
f720: 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 address hostname
f730: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 ). (let ((res #
f740: 66 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 f)). (for-eac
f750: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
f760: 28 61 64 72 29 0a 20 20 20 20 20 20 20 28 69 66 (adr). (if
f770: 20 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 (not (eq? (u8ve
f780: 63 74 6f 72 2d 72 65 66 20 61 64 72 20 30 29 20 ctor-ref adr 0)
f790: 31 32 37 29 29 0a 09 20 20 20 28 73 65 74 21 20 127)).. (set!
f7a0: 72 65 73 20 61 64 72 29 29 29 0a 20 20 20 20 20 res adr))).
f7b0: 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 ;; NOTE: This ca
f7c0: 6e 20 66 61 69 6c 20 77 68 65 6e 20 74 68 65 72 n fail when ther
f7d0: 65 20 69 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 e is no mention
f7e0: 6f 66 20 74 68 65 20 68 6f 73 74 20 69 6e 20 2f of the host in /
f7f0: 65 74 63 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 etc/hosts. FIXME
f800: 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c . (vector->l
f810: 69 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 ist (hostinfo-ad
f820: 64 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d dresses (hostnam
f830: 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 e->hostinfo host
f840: 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 28 73 74 name)))). (st
f850: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
f860: 20 0a 20 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 . (map numb
f870: 65 72 2d 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 er->string.. (u
f880: 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 8vector->list..
f890: 20 20 28 69 66 20 72 65 73 20 72 65 73 20 28 68 (if res res (h
f8a0: 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 ostname->ip host
f8b0: 6e 61 6d 65 29 29 29 29 20 22 2e 22 29 29 29 0a name)))) "."))).
f8c0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
f8d0: 6e 3a 73 65 6e 64 2d 64 62 6f 61 72 64 2d 6d 61 n:send-dboard-ma
f8e0: 69 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 6c in-changed). (l
f8f0: 65 74 2a 20 28 28 64 61 73 68 62 6f 61 72 64 2d et* ((dashboard-
f900: 69 70 73 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 ips (mddb:get-da
f910: 73 68 62 6f 61 72 64 73 29 29 29 0a 20 20 20 20 shboards))).
f920: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
f930: 6c 61 6d 62 64 61 20 28 69 70 61 64 72 29 0a 20 lambda (ipadr).
f940: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f (let* ((so
f950: 63 20 28 63 6f 6d 6d 6f 6e 3a 6f 70 65 6e 2d 6e c (common:open-n
f960: 6d 2d 72 65 71 20 28 63 6f 6e 63 20 22 74 63 70 m-req (conc "tcp
f970: 3a 2f 2f 22 20 69 70 61 64 72 29 29 29 0a 09 20 ://" ipadr)))..
f980: 20 20 20 20 20 28 6d 73 67 20 28 63 6f 6e 63 20 (msg (conc
f990: 22 6d 61 69 6e 20 22 20 2a 74 6f 70 70 61 74 68 "main " *toppath
f9a0: 2a 29 29 0a 09 20 20 20 20 20 20 28 72 65 73 20 *)).. (res
f9b0: 28 63 6f 6d 6d 6f 6e 3a 6e 6d 2d 73 65 6e 64 2d (common:nm-send-
f9c0: 72 65 63 65 69 76 65 2d 74 69 6d 65 6f 75 74 20 receive-timeout
f9d0: 73 6f 63 20 6d 73 67 29 29 29 0a 09 20 28 69 66 soc msg))).. (if
f9e0: 20 28 6e 6f 74 20 72 65 73 29 20 3b 3b 20 63 6f (not res) ;; co
f9f0: 75 6c 64 6e 27 74 20 72 65 61 63 68 20 74 68 61 uldn't reach tha
fa00: 74 20 64 61 73 68 62 6f 61 72 64 20 2d 20 72 65 t dashboard - re
fa10: 6d 6f 76 65 20 69 74 20 66 72 6f 6d 20 64 62 0a move it from db.
fa20: 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 . (print "ER
fa30: 52 4f 52 3a 20 63 6f 75 6c 64 6e 27 74 20 72 65 ROR: couldn't re
fa40: 61 63 68 20 64 61 73 68 62 6f 61 72 64 20 22 20 ach dashboard "
fa50: 69 70 61 64 72 29 29 0a 09 20 72 65 73 29 29 0a ipadr)).. res)).
fa60: 20 20 20 20 20 64 61 73 68 62 6f 61 72 64 2d 69 dashboard-i
fa70: 70 73 29 29 29 0a 20 20 20 20 0a 20 20 20 20 0a ps))). . .
fa80: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
fa90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
faa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fac0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 ========.;; D A
fad0: 53 20 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 S H B O A R D
fae0: 44 20 42 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d D B .;;=========
faf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
fb30: 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 6f 70 65 define (mddb:ope
fb40: 6e 2d 64 62 29 0a 20 20 28 6c 65 74 2a 20 28 28 n-db). (let* ((
fb50: 64 62 20 28 6f 70 65 6e 2d 64 61 74 61 62 61 73 db (open-databas
fb60: 65 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 e (conc (get-env
fb70: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
fb80: 65 20 22 48 4f 4d 45 22 29 20 22 2f 2e 64 61 73 e "HOME") "/.das
fb90: 68 62 6f 61 72 64 2e 64 62 22 29 29 29 29 0a 20 hboard.db")))).
fba0: 20 20 20 28 73 65 74 2d 62 75 73 79 2d 68 61 6e (set-busy-han
fbb0: 64 6c 65 72 21 20 64 62 20 28 62 75 73 79 2d 74 dler! db (busy-t
fbc0: 69 6d 65 6f 75 74 20 31 30 30 30 30 29 29 0a 20 imeout 10000)).
fbd0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
fbe0: 20 20 28 6c 61 6d 62 64 61 20 28 71 72 79 29 0a (lambda (qry).
fbf0: 20 20 20 20 20 20 20 28 65 78 65 63 20 28 73 71 (exec (sq
fc00: 6c 20 64 62 20 71 72 79 29 29 29 0a 20 20 20 20 l db qry))).
fc10: 20 28 6c 69 73 74 20 0a 20 20 20 20 20 20 22 43 (list . "C
fc20: 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e REATE TABLE IF N
fc30: 4f 54 20 45 58 49 53 54 53 20 76 61 72 73 20 20 OT EXISTS vars
fc40: 20 20 20 20 20 28 69 64 20 49 4e 54 45 47 45 52 (id INTEGER
fc50: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 PRIMARY KEY,key
fc60: 20 54 45 58 54 2c 20 76 61 6c 20 54 45 58 54 2c TEXT, val TEXT,
fc70: 20 43 4f 4e 53 54 52 41 49 4e 54 20 76 61 72 73 CONSTRAINT vars
fc80: 63 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 constraint UNIQU
fc90: 45 20 28 6b 65 79 29 29 3b 22 0a 20 20 20 20 20 E (key));".
fca0: 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 "CREATE TABLE I
fcb0: 46 20 4e 4f 54 20 45 58 49 53 54 53 20 64 61 73 F NOT EXISTS das
fcc0: 68 62 6f 61 72 64 73 20 28 0a 20 20 20 20 20 20 hboards (.
fcd0: 20 20 20 20 69 64 20 20 20 20 20 20 20 20 20 49 id I
fce0: 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
fcf0: 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 70 69 EY,. pi
fd00: 64 20 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 d INTEGER
fd10: 2c 0a 20 20 20 20 20 20 20 20 20 20 75 73 65 72 ,. user
fd20: 6e 61 6d 65 20 20 20 54 45 58 54 2c 0a 20 20 20 name TEXT,.
fd30: 20 20 20 20 20 20 20 68 6f 73 74 6e 61 6d 65 20 hostname
fd40: 20 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 TEXT,.
fd50: 20 20 69 70 61 64 64 72 20 20 20 20 20 54 45 58 ipaddr TEX
fd60: 54 2c 0a 20 20 20 20 20 20 20 20 20 20 70 6f 72 T,. por
fd70: 74 6e 75 6d 20 20 20 20 49 4e 54 45 47 45 52 2c tnum INTEGER,
fd80: 0a 20 20 20 20 20 20 20 20 20 20 73 74 61 72 74 . start
fd90: 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 _time TIMESTAMP
fda0: 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d DEFAULT (strftim
fdb0: 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a e('%s','now')),.
fdc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e CON
fdd0: 53 54 52 41 49 4e 54 20 68 6f 73 74 70 6f 72 74 STRAINT hostport
fde0: 20 55 4e 49 51 55 45 20 28 68 6f 73 74 6e 61 6d UNIQUE (hostnam
fdf0: 65 2c 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 e,portnum).
fe00: 20 20 20 29 3b 22 0a 20 20 20 20 20 20 29 29 0a );". )).
fe10: 20 20 20 20 64 62 29 29 0a 0a 3b 3b 20 72 65 67 db))..;; reg
fe20: 69 73 74 65 72 20 61 20 64 61 73 68 62 6f 61 72 ister a dashboar
fe30: 64 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d d .;;.(define (m
fe40: 64 64 62 3a 72 65 67 69 73 74 65 72 2d 64 61 73 ddb:register-das
fe50: 68 62 6f 61 72 64 20 70 6f 72 74 29 0a 20 20 28 hboard port). (
fe60: 6c 65 74 2a 20 28 28 70 69 64 20 20 20 20 20 20 let* ((pid
fe70: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
fe80: 2d 69 64 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d -id)).. (hostnam
fe90: 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 e (get-host-name
fea0: 29 29 0a 09 20 28 69 70 61 64 64 72 20 20 20 28 )).. (ipaddr (
feb0: 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d server:get-best-
fec0: 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f guess-address ho
fed0: 73 74 6e 61 6d 65 29 29 0a 09 20 28 75 73 65 72 stname)).. (user
fee0: 6e 61 6d 65 20 28 63 75 72 72 65 6e 74 2d 75 73 name (current-us
fef0: 65 72 2d 6e 61 6d 65 29 29 20 3b 3b 20 28 63 61 er-name)) ;; (ca
ff00: 72 20 75 73 65 72 69 6e 66 6f 29 29 29 0a 09 20 r userinfo)))..
ff10: 28 64 62 20 20 20 20 20 20 28 6d 64 64 62 3a 6f (db (mddb:o
ff20: 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 70 pen-db))). (p
ff30: 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 20 6d rint "Register m
ff40: 6f 6e 69 74 6f 72 2c 20 70 69 64 3a 20 22 20 70 onitor, pid: " p
ff50: 69 64 20 22 2c 20 68 6f 73 74 6e 61 6d 65 3a 20 id ", hostname:
ff60: 22 20 68 6f 73 74 6e 61 6d 65 20 22 2c 20 70 6f " hostname ", po
ff70: 72 74 3a 20 22 20 70 6f 72 74 20 22 2c 20 75 73 rt: " port ", us
ff80: 65 72 6e 61 6d 65 3a 20 22 20 75 73 65 72 6e 61 ername: " userna
ff90: 6d 65 29 0a 20 20 20 20 28 65 78 65 63 20 28 73 me). (exec (s
ffa0: 71 6c 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 ql db "INSERT OR
ffb0: 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 64 61 REPLACE INTO da
ffc0: 73 68 62 6f 61 72 64 73 20 28 70 69 64 2c 75 73 shboards (pid,us
ffd0: 65 72 6e 61 6d 65 2c 68 6f 73 74 6e 61 6d 65 2c ername,hostname,
ffe0: 69 70 61 64 64 72 2c 70 6f 72 74 6e 75 6d 29 20 ipaddr,portnum)
fff0: 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c VALUES (?,?,?,?,
10000 3f 29 3b 22 29 0a 09 20 20 20 70 69 64 20 75 73 ?);").. pid us
10010 65 72 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 20 ername hostname
10020 69 70 61 64 64 72 20 70 6f 72 74 29 0a 20 20 20 ipaddr port).
10030 20 28 63 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 (close-database
10040 20 64 62 29 29 29 0a 0a 3b 3b 20 75 6e 72 65 67 db)))..;; unreg
10050 69 73 74 65 72 20 61 20 6d 6f 6e 69 74 6f 72 0a ister a monitor.
10060 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 ;;.(define (mddb
10070 3a 75 6e 72 65 67 69 73 74 65 72 2d 64 61 73 68 :unregister-dash
10080 62 6f 61 72 64 20 68 6f 73 74 20 70 6f 72 74 29 board host port)
10090 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
100a0 20 20 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 (mddb:open-db
100b0 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 ))). (print "
100c0 52 65 67 69 73 74 65 72 20 75 6e 72 65 67 69 73 Register unregis
100d0 74 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 68 6f 73 ter monitor, hos
100e0 74 3a 70 6f 72 74 3d 22 20 68 6f 73 74 20 22 3a t:port=" host ":
100f0 22 20 70 6f 72 74 29 0a 20 20 20 20 28 65 78 65 " port). (exe
10100 63 20 28 73 71 6c 20 64 62 20 22 44 45 4c 45 54 c (sql db "DELET
10110 45 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 E FROM dashboard
10120 73 20 57 48 45 52 45 20 68 6f 73 74 6e 61 6d 65 s WHERE hostname
10130 3d 3f 20 41 4e 44 20 70 6f 72 74 6e 75 6d 3d 3f =? AND portnum=?
10140 3b 22 29 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 ;") host port).
10150 20 20 20 28 63 6c 6f 73 65 2d 64 61 74 61 62 61 (close-databa
10160 73 65 20 64 62 29 29 29 0a 0a 3b 3b 20 67 65 74 se db)))..;; get
10170 20 72 65 67 69 73 74 65 72 65 64 20 64 61 73 68 registered dash
10180 62 6f 61 72 64 73 0a 3b 3b 0a 28 64 65 66 69 6e boards.;;.(defin
10190 65 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 e (mddb:get-dash
101a0 62 6f 61 72 64 73 29 0a 20 20 28 6c 65 74 20 28 boards). (let (
101b0 28 64 62 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 (db (mddb:open-d
101c0 62 29 29 29 0a 20 20 20 20 28 71 75 65 72 79 20 b))). (query
101d0 66 65 74 63 68 2d 63 6f 6c 75 6d 6e 0a 09 20 20 fetch-column..
101e0 20 28 73 71 6c 20 64 62 20 22 53 45 4c 45 43 54 (sql db "SELECT
101f0 20 69 70 61 64 64 72 20 7c 7c 20 27 3a 27 20 7c ipaddr || ':' |
10200 7c 20 70 6f 72 74 6e 75 6d 20 46 52 4f 4d 20 64 | portnum FROM d
10210 61 73 68 62 6f 61 72 64 73 3b 22 29 29 29 29 0a ashboards;")))).
10220 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=========
10230 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10240 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10250 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10260 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
10270 20 20 54 20 45 20 53 20 54 20 20 20 4c 20 41 20 T E S T L A
10280 55 20 4e 20 43 20 48 20 49 20 4e 20 47 20 20 20 U N C H I N G
10290 50 20 45 20 52 20 20 20 49 20 54 20 45 20 4d 20 P E R I T E M
102a0 20 20 57 20 49 20 54 20 48 20 20 20 48 20 4f 20 W I T H H O
102b0 53 20 54 20 20 20 54 20 59 20 50 20 45 20 53 0a S T T Y P E S.
102c0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
102d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10300 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 ========.;; .;;
10310 5b 68 6f 73 74 73 5d 0a 3b 3b 20 61 72 6d 20 63 [hosts].;; arm c
10320 75 62 69 65 30 31 20 63 75 62 69 65 30 32 0a 3b ubie01 cubie02.;
10330 3b 20 78 38 36 5f 36 34 20 7a 65 75 73 20 78 65 ; x86_64 zeus xe
10340 6e 61 20 6d 79 74 68 30 31 0a 3b 3b 20 61 6c 6c na myth01.;; all
10350 68 6f 73 74 73 20 23 7b 67 20 68 6f 73 74 73 20 hosts #{g hosts
10360 61 72 6d 7d 20 23 7b 67 20 68 6f 73 74 73 20 78 arm} #{g hosts x
10370 38 36 5f 36 34 7d 0a 3b 3b 20 0a 3b 3b 20 5b 68 86_64}.;; .;; [h
10380 6f 73 74 2d 74 79 70 65 73 5d 0a 3b 3b 20 67 65 ost-types].;; ge
10390 6e 65 72 61 6c 20 23 4d 54 4c 4f 57 45 53 54 4c neral #MTLOWESTL
103a0 4f 41 44 20 23 7b 67 20 68 6f 73 74 73 20 61 6c OAD #{g hosts al
103b0 6c 68 6f 73 74 73 7d 0a 3b 3b 20 61 72 6d 20 20 lhosts}.;; arm
103c0 20 20 20 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 #MTLOWESTLOAD
103d0 20 23 7b 67 20 68 6f 73 74 73 20 61 72 6d 7d 0a #{g hosts arm}.
103e0 3b 3b 20 6e 62 67 65 6e 65 72 61 6c 20 6e 62 6a ;; nbgeneral nbj
103f0 6f 62 20 72 75 6e 20 4a 4f 42 43 4f 4d 4d 41 4e ob run JOBCOMMAN
10400 44 20 2d 6c 6f 67 20 24 4d 54 5f 4c 49 4e 4b 54 D -log $MT_LINKT
10410 52 45 45 2f 24 4d 54 5f 54 41 52 47 45 54 2f 24 REE/$MT_TARGET/$
10420 4d 54 5f 52 55 4e 4e 41 4d 45 2e 24 4d 54 5f 54 MT_RUNNAME.$MT_T
10430 45 53 54 4e 41 4d 45 2d 24 4d 54 5f 49 54 45 4d ESTNAME-$MT_ITEM
10440 5f 50 41 54 48 2e 6c 67 6f 0a 3b 3b 20 0a 3b 3b _PATH.lgo.;; .;;
10450 20 5b 6c 61 75 6e 63 68 65 72 73 5d 0a 3b 3b 20 [launchers].;;
10460 65 6e 76 73 65 74 75 70 20 67 65 6e 65 72 61 6c envsetup general
10470 0a 3b 3b 20 78 6f 72 2f 25 2f 6e 20 34 43 31 36 .;; xor/%/n 4C16
10480 47 0a 3b 3b 20 25 20 6e 62 67 65 6e 65 72 61 6c G.;; % nbgeneral
10490 0a 3b 3b 20 0a 3b 3b 20 5b 6a 6f 62 74 6f 6f 6c .;; .;; [jobtool
104a0 73 5d 0a 3b 3b 20 23 20 69 66 20 64 65 66 69 6e s].;; # if defin
104b0 65 64 20 61 6e 64 20 6e 6f 74 20 22 6e 6f 22 20 ed and not "no"
104c0 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 77 flexi-launcher w
104d0 69 6c 6c 20 62 79 70 61 73 73 20 22 6c 61 75 6e ill bypass "laun
104e0 63 68 65 72 22 20 75 6e 6c 65 73 73 20 6e 6f 20 cher" unless no
104f0 6d 61 74 63 68 2e 0a 3b 3b 20 66 6c 65 78 69 2d match..;; flexi-
10500 6c 61 75 6e 63 68 65 72 20 79 65 73 20 20 0a 3b launcher yes .;
10510 3b 20 6c 61 75 6e 63 68 65 72 20 6e 62 66 61 6b ; launcher nbfak
10520 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f e.;;.(define (co
10530 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 75 6e 63 68 65 mmon:get-launche
10540 72 20 63 6f 6e 66 69 67 64 61 74 20 74 65 73 74 r configdat test
10550 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 name itempath).
10560 20 28 6c 65 74 20 28 28 66 61 6c 6c 62 61 63 6b (let ((fallback
10570 2d 6c 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 -launcher (confi
10580 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
10590 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 dat "jobtools" "
105a0 6c 61 75 6e 63 68 65 72 22 29 29 29 0a 20 20 20 launcher"))).
105b0 20 28 69 66 20 28 61 6e 64 20 28 63 6f 6e 66 69 (if (and (confi
105c0 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
105d0 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 dat "jobtools" "
105e0 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 flexi-launcher")
105f0 20 3b 3b 20 6f 76 65 72 72 69 64 65 73 20 6c 61 ;; overrides la
10600 75 6e 63 68 65 72 0a 09 20 20 20 20 20 28 6e 6f uncher.. (no
10610 74 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 t (equal? (confi
10620 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
10630 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 dat "jobtools" "
10640 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 flexi-launcher")
10650 20 22 6e 6f 22 29 29 29 0a 09 28 6c 65 74 2a 20 "no")))..(let*
10660 28 28 6c 61 75 6e 63 68 65 72 73 20 20 20 20 20 ((launchers
10670 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
10680 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 ref/default conf
10690 69 67 64 61 74 20 22 6c 61 75 6e 63 68 65 72 73 igdat "launchers
106a0 22 20 27 28 29 29 29 29 0a 09 20 20 28 69 66 20 " '()))).. (if
106b0 28 6e 75 6c 6c 3f 20 6c 61 75 6e 63 68 65 72 73 (null? launchers
106c0 29 0a 09 20 20 20 20 20 20 66 61 6c 6c 62 61 63 ).. fallbac
106d0 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 20 20 20 20 k-launcher..
106e0 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
106f0 64 20 28 63 61 72 20 6c 61 75 6e 63 68 65 72 73 d (car launchers
10700 29 29 0a 09 09 09 20 28 74 61 6c 20 28 63 64 72 )).... (tal (cdr
10710 20 6c 61 75 6e 63 68 65 72 73 29 29 29 0a 09 09 launchers)))...
10720 28 6c 65 74 20 28 28 70 61 74 74 20 20 20 20 20 (let ((patt
10730 20 28 63 61 72 20 68 65 64 29 29 0a 09 09 20 20 (car hed))...
10740 20 20 20 20 28 68 6f 73 74 2d 74 79 70 65 20 28 (host-type (
10750 63 61 64 72 20 68 65 64 29 29 29 0a 09 09 20 20 cadr hed)))...
10760 28 69 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 (if (tests:match
10770 20 70 61 74 74 20 74 65 73 74 6e 61 6d 65 20 69 patt testname i
10780 74 65 6d 70 61 74 68 29 0a 09 09 20 20 20 20 20 tempath)...
10790 20 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 (begin....(debu
107a0 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
107b0 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
107c0 2a 20 22 48 61 76 65 20 66 6c 65 78 69 2d 6c 61 * "Have flexi-la
107d0 75 6e 63 68 65 72 20 6d 61 74 63 68 20 66 6f 72 uncher match for
107e0 20 22 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 " testname "/"
107f0 69 74 65 6d 70 61 74 68 20 22 20 3d 20 22 20 68 itempath " = " h
10800 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 28 6c 65 ost-type)....(le
10810 74 20 28 28 6c 61 75 6e 63 68 65 72 20 28 63 6f t ((launcher (co
10820 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e nfigf:lookup con
10830 66 69 67 64 61 74 20 22 68 6f 73 74 2d 74 79 70 figdat "host-typ
10840 65 73 22 20 68 6f 73 74 2d 74 79 70 65 29 29 29 es" host-type)))
10850 0a 09 09 09 20 20 28 69 66 20 6c 61 75 6e 63 68 .... (if launch
10860 65 72 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 er.... (let
10870 2a 20 28 28 6c 61 75 6e 63 68 65 72 2d 70 61 72 * ((launcher-par
10880 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ts (string-split
10890 20 6c 61 75 6e 63 68 65 72 29 29 0a 09 09 09 09 launcher)).....
108a0 20 20 20 20 20 28 6c 61 75 6e 63 68 65 72 2d 65 (launcher-e
108b0 78 65 20 20 20 28 63 61 72 20 6c 61 75 6e 63 68 xe (car launch
108c0 65 72 2d 70 61 72 74 73 29 29 29 0a 09 09 09 09 er-parts))).....
108d0 28 69 66 20 28 65 71 75 61 6c 3f 20 6c 61 75 6e (if (equal? laun
108e0 63 68 65 72 2d 65 78 65 20 22 23 4d 54 4c 4f 57 cher-exe "#MTLOW
108f0 45 53 54 4c 4f 41 44 22 29 20 3b 3b 20 74 68 69 ESTLOAD") ;; thi
10900 73 20 69 73 20 6f 75 72 20 73 70 65 63 69 61 6c s is our special
10910 20 63 61 73 65 2c 20 77 65 20 77 69 6c 6c 20 66 case, we will f
10920 69 6e 64 20 74 68 65 20 6c 6f 77 65 73 74 20 6c ind the lowest l
10930 6f 61 64 20 61 6e 64 20 63 72 61 66 74 20 61 20 oad and craft a
10940 6e 62 66 61 6b 65 20 63 6f 6d 6d 61 6e 64 6c 69 nbfake commandli
10950 6e 65 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 ne..... (let
10960 28 28 74 61 72 67 2d 68 6f 73 74 20 28 63 6f 6d ((targ-host (com
10970 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 74 2d 6c 6f mon:get-least-lo
10980 61 64 65 64 2d 68 6f 73 74 20 28 63 64 72 20 6c aded-host (cdr l
10990 61 75 6e 63 68 65 72 2d 70 61 72 74 73 29 29 29 auncher-parts)))
109a0 29 0a 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e )..... (con
109b0 63 20 22 72 65 6d 72 75 6e 20 22 20 74 61 72 67 c "remrun " targ
109c0 2d 68 6f 73 74 29 29 0a 09 09 09 09 20 20 20 20 -host)).....
109d0 6c 61 75 6e 63 68 65 72 29 29 0a 09 09 09 20 20 launcher))....
109e0 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 (begin.....(
109f0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
10a00 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
10a10 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
10a20 6e 6f 20 6c 61 75 6e 63 68 65 72 20 66 6f 75 6e no launcher foun
10a30 64 20 66 6f 72 20 68 6f 73 74 2d 74 79 70 65 20 d for host-type
10a40 22 20 68 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 " host-type)....
10a50 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 .(if (null? tal)
10a60 0a 09 09 09 09 20 20 20 20 66 61 6c 6c 62 61 63 ..... fallbac
10a70 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 09 09 09 20 k-launcher.....
10a80 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
10a90 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
10aa0 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 )... ;; no
10ab0 6d 61 74 63 68 2c 20 74 72 79 20 61 67 61 69 6e match, try again
10ac0 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 ... (if (nu
10ad0 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 66 61 ll? tal).... fa
10ae0 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 0a llback-launcher.
10af0 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
10b00 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
10b10 29 29 29 29 0a 09 66 61 6c 6c 62 61 63 6b 2d 6c ))))..fallback-l
10b20 61 75 6e 63 68 65 72 29 29 29 0a 20 20 0a 3b 3b auncher))). .;;
10b30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b70 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 ======.;; D A S
10b80 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 55 20 H B O A R D U
10b90 53 20 45 20 52 20 20 20 56 20 49 20 45 20 57 20 S E R V I E W
10ba0 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
10bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10bc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10bd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10be0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 ==========..;; f
10bf0 69 72 73 74 20 72 65 61 64 20 7e 2f 76 69 65 77 irst read ~/view
10c00 73 2e 63 6f 6e 66 69 67 20 69 66 20 69 74 20 65 s.config if it e
10c10 78 69 73 74 73 2c 20 74 68 65 6e 20 72 65 61 64 xists, then read
10c20 20 24 4d 54 52 41 48 2f 76 69 65 77 73 2e 63 6f $MTRAH/views.co
10c30 6e 66 69 67 20 69 66 20 69 74 20 65 78 69 73 74 nfig if it exist
10c40 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f s.;;.(define (co
10c50 6d 6d 6f 6e 3a 6c 6f 61 64 2d 76 69 65 77 73 2d mmon:load-views-
10c60 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 config). (let*
10c70 28 28 76 69 65 77 2d 63 66 67 64 61 74 20 20 20 ((view-cfgdat
10c80 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
10c90 65 29 29 0a 09 20 28 68 6f 6d 65 2d 63 66 67 66 e)).. (home-cfgf
10ca0 69 6c 65 20 20 20 28 63 6f 6e 63 20 28 67 65 74 ile (conc (get
10cb0 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
10cc0 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f iable "HOME") "/
10cd0 2e 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 .mtviews.config"
10ce0 29 29 0a 09 20 28 6d 74 68 6f 6d 65 2d 63 66 67 )).. (mthome-cfg
10cf0 66 69 6c 65 20 28 63 6f 6e 63 20 2a 74 6f 70 70 file (conc *topp
10d00 61 74 68 2a 20 22 2f 2e 6d 74 76 69 65 77 73 2e ath* "/.mtviews.
10d10 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 config"))). (
10d20 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
10d30 20 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 mthome-cfgfile)
10d40 0a 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 6d ..(read-config m
10d50 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 thome-cfgfile vi
10d60 65 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 ew-cfgdat #t)).
10d70 20 20 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 68 ;; we load th
10d80 65 20 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 20 e home dir file
10d90 41 46 54 45 52 20 74 68 65 20 4d 54 52 41 48 20 AFTER the MTRAH
10da0 66 69 6c 65 20 73 6f 20 74 68 65 20 75 73 65 72 file so the user
10db0 20 63 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 74 can clobber set
10dc0 74 69 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e 69 tings when runni
10dd0 6e 67 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 ng the dashboard
10de0 20 69 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 72 in read-only ar
10df0 65 61 73 0a 20 20 20 20 28 69 66 20 28 66 69 6c eas. (if (fil
10e00 65 2d 65 78 69 73 74 73 3f 20 68 6f 6d 65 2d 63 e-exists? home-c
10e10 66 67 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 fgfile)..(read-c
10e20 6f 6e 66 69 67 20 68 6f 6d 65 2d 63 66 67 66 69 onfig home-cfgfi
10e30 6c 65 20 76 69 65 77 2d 63 66 67 64 61 74 20 23 le view-cfgdat #
10e40 74 29 29 0a 20 20 20 20 76 69 65 77 2d 63 66 67 t)). view-cfg
10e50 64 61 74 29 29 0a 0a dat))..