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 0a 0a a server).;;...
5790: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
57a0: 72 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f readonly-watchdo
57b0: 67 20 64 62 73 74 72 75 63 74 29 0a 20 20 28 74 g dbstruct). (t
57c0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 hread-sleep! 0.0
57d0: 35 29 20 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 5) ;; delay for
57e0: 73 74 61 72 74 75 70 0a 0a 20 20 3b 3b 20 73 79 startup.. ;; sy
57f0: 6e 63 20 6d 65 67 61 74 65 73 74 2e 64 62 20 74 nc megatest.db t
5800: 6f 20 2f 74 6d 70 2f 2e 2e 2e 2f 6d 65 67 61 74 o /tmp/.../megat
5810: 73 74 2e 64 62 0a 20 20 28 6c 65 74 20 28 28 73 st.db. (let ((s
5820: 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 ync-cool-off-dur
5830: 61 74 69 6f 6e 20 20 20 33 29 0a 20 20 20 20 20 ation 3).
5840: 20 20 20 28 67 6f 6c 64 65 6e 2d 6d 74 64 62 20 (golden-mtdb
5850: 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 (dbr:dbstruc
5860: 74 2d 6d 74 64 62 20 64 62 73 74 72 75 63 74 29 t-mtdb dbstruct)
5870: 29 0a 20 20 20 20 20 20 20 20 28 67 6f 6c 64 65 ). (golde
5880: 6e 2d 6d 74 70 61 74 68 20 20 20 28 64 62 3a 64 n-mtpath (db:d
5890: 62 64 61 74 2d 67 65 74 2d 70 61 74 68 20 6d 74 bdat-get-path mt
58a0: 64 62 29 29 0a 20 20 20 20 20 20 20 20 28 74 6d db)). (tm
58b0: 70 2d 6d 74 64 62 20 20 20 20 20 20 20 20 28 64 p-mtdb (d
58c0: 62 72 3a 64 62 73 74 72 75 63 74 2d 74 6d 70 64 br:dbstruct-tmpd
58d0: 62 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 20 b dbstruct)).
58e0: 20 20 20 20 20 28 74 6d 70 2d 6d 74 70 61 74 68 (tmp-mtpath
58f0: 20 20 20 20 20 20 28 64 62 3a 64 62 64 61 74 2d (db:dbdat-
5900: 67 65 74 2d 70 61 74 68 20 6d 74 64 62 29 29 29 get-path mtdb)))
5910: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
5920: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5930: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 61 t-log-port* "Rea
5940: 64 2d 6f 6e 6c 79 20 70 65 72 69 6f 64 69 63 20 d-only periodic
5950: 73 79 6e 63 20 74 68 72 65 61 64 20 73 74 61 72 sync thread star
5960: 74 65 64 2e 22 29 0a 20 20 20 20 28 6c 65 74 20 ted."). (let
5970: 6c 6f 6f 70 20 28 28 6c 61 73 74 2d 73 79 6e 63 loop ((last-sync
5980: 2d 74 69 6d 65 20 30 29 29 0a 20 20 20 20 20 20 -time 0)).
5990: 28 6c 65 74 2a 20 28 28 64 75 72 61 74 69 6f 6e (let* ((duration
59a0: 2d 73 69 6e 63 65 2d 6c 61 73 74 2d 73 79 6e 63 -since-last-sync
59b0: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
59c0: 6f 6e 64 73 29 20 6c 61 73 74 2d 73 79 6e 63 2d onds) last-sync-
59d0: 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 time))).
59e0: 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 (if (and (not *t
59f0: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 20 ime-to-exit*).
5a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5a10: 3c 20 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 < duration-since
5a20: 2d 6c 61 73 74 2d 73 79 6e 63 20 73 79 6e 63 2d -last-sync sync-
5a30: 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 6f cool-off-duratio
5a40: 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 n)).
5a50: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 (thread-sleep! (
5a60: 2d 20 73 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d - sync-cool-off-
5a70: 64 75 72 61 74 69 6f 6e 20 64 75 72 61 74 69 6f duration duratio
5a80: 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 2d 73 79 6e n-since-last-syn
5a90: 63 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 c))). (if
5aa0: 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 (not *time-to-e
5ab0: 78 69 74 2a 29 0a 20 20 20 20 20 20 20 20 20 20 xit*).
5ac0: 20 20 28 6c 65 74 20 28 28 67 6f 6c 64 65 6e 2d (let ((golden-
5ad0: 6d 74 64 62 2d 6d 74 69 6d 65 20 28 66 69 6c 65 mtdb-mtime (file
5ae0: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
5af0: 6d 65 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 me golden-mtpath
5b00: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
5b10: 20 20 20 20 20 28 74 6d 70 2d 6d 74 64 62 2d 6d (tmp-mtdb-m
5b20: 74 69 6d 65 20 20 20 20 28 66 69 6c 65 2d 6d 6f time (file-mo
5b30: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
5b40: 74 6d 70 2d 6d 74 70 61 74 68 29 29 29 0a 20 20 tmp-mtpath))).
5b50: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
5b60: 28 3e 20 67 6f 6c 64 65 6e 2d 6d 74 64 62 2d 6d (> golden-mtdb-m
5b70: 74 69 6d 65 20 74 6d 70 2d 6d 74 64 62 2d 6d 74 time tmp-mtdb-mt
5b80: 69 6d 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ime).
5b90: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 (let ((re
5ba0: 73 20 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 s (db:multi-db-s
5bb0: 79 6e 63 20 64 62 73 74 72 75 63 74 20 27 6f 6c ync dbstruct 'ol
5bc0: 64 32 6e 65 77 29 29 29 0a 20 20 20 20 20 20 20 d2new))).
5bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
5be0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
5bf0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5c00: 72 74 2a 20 22 72 6f 73 79 6e 63 20 63 61 6c 6c rt* "rosync call
5c10: 65 64 2c 20 22 20 72 65 73 20 22 20 72 65 63 6f ed, " res " reco
5c20: 72 64 73 20 74 72 61 6e 73 66 65 72 72 65 64 2e rds transferred.
5c30: 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ")).
5c40: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 75 72 (loop (cur
5c50: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
5c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 23 74 #t
5c70: 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a )))). (debug:
5c80: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5c90: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5ca0: 22 45 78 69 74 69 6e 67 20 72 65 61 64 6f 6e 6c "Exiting readonl
5cb0: 79 2d 77 61 74 63 68 64 6f 67 20 74 69 6d 65 72 y-watchdog timer
5cc0: 2c 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a , *time-to-exit*
5cd0: 20 3d 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 = " *time-to-ex
5ce0: 69 74 2a 22 20 70 69 64 3d 22 28 63 75 72 72 65 it*" pid="(curre
5cf0: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 nt-process-id)"
5d00: 6d 74 70 61 74 68 3d 22 67 6f 6c 64 65 6e 2d 6d mtpath="golden-m
5d10: 74 70 61 74 68 29 29 29 0a 0a 0a 20 20 20 20 20 tpath)))...
5d20: 20 20 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .(define (com
5d30: 6d 6f 6e 3a 77 72 69 74 61 62 6c 65 2d 77 61 74 mon:writable-wat
5d40: 63 68 64 6f 67 20 64 62 73 74 72 75 63 74 29 0a chdog dbstruct).
5d50: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5d60: 20 30 2e 30 35 29 20 3b 3b 20 64 65 6c 61 79 20 0.05) ;; delay
5d70: 66 6f 72 20 73 74 61 72 74 75 70 0a 20 20 28 6c for startup. (l
5d80: 65 74 20 28 28 6c 65 67 61 63 79 2d 73 79 6e 63 et ((legacy-sync
5d90: 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 6e (common:run-syn
5da0: 63 3f 29 29 0a 09 28 64 65 62 75 67 2d 6d 6f 64 c?))..(debug-mod
5db0: 65 20 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d e (debug:debug-
5dc0: 6d 6f 64 65 20 31 29 29 0a 09 28 6c 61 73 74 2d mode 1))..(last-
5dd0: 74 69 6d 65 20 20 20 28 63 75 72 72 65 6e 74 2d time (current-
5de0: 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 seconds)).
5df0: 20 20 28 74 68 69 73 2d 77 64 2d 6e 75 6d 20 20 (this-wd-num
5e00: 20 20 20 28 62 65 67 69 6e 20 28 6d 75 74 65 78 (begin (mutex
5e10: 2d 6c 6f 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 -lock! *wdnum*mu
5e20: 74 65 78 29 20 28 6c 65 74 20 28 28 78 20 2a 77 tex) (let ((x *w
5e30: 64 6e 75 6d 2a 29 29 20 28 73 65 74 21 20 2a 77 dnum*)) (set! *w
5e40: 64 6e 75 6d 2a 20 28 61 64 64 31 20 2a 77 64 6e dnum* (add1 *wdn
5e50: 75 6d 2a 29 29 20 28 6d 75 74 65 78 2d 75 6e 6c um*)) (mutex-unl
5e60: 6f 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 ock! *wdnum*mute
5e70: 78 29 20 78 29 29 29 29 0a 20 20 20 20 28 64 65 x) x)))). (de
5e80: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 33 bug:print-info 3
5e90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5ea0: 72 74 2a 20 22 77 61 74 63 68 64 6f 67 20 73 74 rt* "watchdog st
5eb0: 61 72 74 69 6e 67 2e 20 6c 65 67 61 63 79 2d 73 arting. legacy-s
5ec0: 79 6e 63 20 69 73 20 22 20 6c 65 67 61 63 79 2d ync is " legacy-
5ed0: 73 79 6e 63 22 20 70 69 64 3d 22 28 63 75 72 72 sync" pid="(curr
5ee0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 ent-process-id)"
5ef0: 20 74 68 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 this-wd-num="th
5f00: 69 73 2d 77 64 2d 6e 75 6d 29 0a 20 20 20 20 28 is-wd-num). (
5f10: 69 66 20 28 61 6e 64 20 6c 65 67 61 63 79 2d 73 if (and legacy-s
5f20: 79 6e 63 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 ync (not *time-t
5f30: 6f 2d 65 78 69 74 2a 29 29 0a 09 28 6c 65 74 2a o-exit*))..(let*
5f40: 20 28 3b 3b 28 64 62 73 74 72 75 63 74 20 28 64 (;;(dbstruct (d
5f50: 62 3a 73 65 74 75 70 29 29 0a 09 20 20 20 20 20 b:setup))..
5f60: 20 20 28 6d 74 64 62 20 20 20 20 20 28 64 62 72 (mtdb (dbr
5f70: 3a 64 62 73 74 72 75 63 74 2d 6d 74 64 62 20 64 :dbstruct-mtdb d
5f80: 62 73 74 72 75 63 74 29 29 0a 09 20 20 20 20 20 bstruct))..
5f90: 20 20 28 6d 74 70 61 74 68 20 20 20 28 64 62 3a (mtpath (db:
5fa0: 64 62 64 61 74 2d 67 65 74 2d 70 61 74 68 20 6d dbdat-get-path m
5fb0: 74 64 62 29 29 29 0a 09 20 20 28 64 65 62 75 67 tdb))).. (debug
5fc0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
5fd0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
5fe0: 20 22 53 65 72 76 65 72 20 72 75 6e 6e 69 6e 67 "Server running
5ff0: 2c 20 70 65 72 69 6f 64 69 63 20 73 79 6e 63 20 , periodic sync
6000: 73 74 61 72 74 65 64 2e 22 29 0a 09 20 20 28 6c started.").. (l
6010: 65 74 20 6c 6f 6f 70 20 28 29 0a 09 20 20 20 20 et loop ()..
6020: 3b 3b 20 73 79 6e 63 20 66 6f 72 20 66 69 6c 65 ;; sync for file
6030: 73 79 73 74 65 6d 20 6c 6f 63 61 6c 20 64 62 20 system local db
6040: 77 72 69 74 65 73 0a 09 20 20 20 20 3b 3b 0a 09 writes.. ;;..
6050: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
6060: 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d *db-multi-sync-
6070: 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 28 6c 65 mutex*).. (le
6080: 74 2a 20 28 28 6e 65 65 64 2d 73 79 6e 63 20 20 t* ((need-sync
6090: 20 20 20 20 20 20 28 3e 3d 20 2a 64 62 2d 6c 61 (>= *db-la
60a0: 73 74 2d 61 63 63 65 73 73 2a 20 2a 64 62 2d 6c st-access* *db-l
60b0: 61 73 74 2d 73 79 6e 63 2a 29 29 20 3b 3b 20 6e ast-sync*)) ;; n
60c0: 6f 20 73 79 6e 63 20 73 69 6e 63 65 20 6c 61 73 o sync since las
60d0: 74 20 77 72 69 74 65 0a 09 09 20 20 20 28 73 79 t write... (sy
60e0: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 20 2a nc-in-progress *
60f0: 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 db-sync-in-progr
6100: 65 73 73 2a 29 0a 09 09 20 20 20 28 73 68 6f 75 ess*)... (shou
6110: 6c 64 2d 73 79 6e 63 20 20 20 20 20 20 28 61 6e ld-sync (an
6120: 64 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d d (not *time-to-
6130: 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 20 20 exit*).
6140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6150: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6160: 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (> (- (current-
6170: 73 65 63 6f 6e 64 73 29 20 2a 64 62 2d 6c 61 73 seconds) *db-las
6180: 74 2d 73 79 6e 63 2a 29 20 35 29 29 29 20 3b 3b t-sync*) 5))) ;;
6190: 20 73 79 6e 63 20 65 76 65 72 79 20 66 69 76 65 sync every five
61a0: 20 73 65 63 6f 6e 64 73 20 6d 69 6e 69 6d 75 6d seconds minimum
61b0: 0a 09 09 20 20 20 28 73 74 61 72 74 2d 74 69 6d ... (start-tim
61c0: 65 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 e (current
61d0: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 -seconds))...
61e0: 28 6d 74 2d 6d 6f 64 2d 74 69 6d 65 20 20 20 20 (mt-mod-time
61f0: 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 (file-modifica
6200: 74 69 6f 6e 2d 74 69 6d 65 20 6d 74 70 61 74 68 tion-time mtpath
6210: 29 29 0a 09 09 20 20 20 28 72 65 63 65 6e 74 6c ))... (recentl
6220: 79 2d 73 79 6e 63 65 64 20 20 28 3e 20 28 2d 20 y-synced (> (-
6230: 73 74 61 72 74 2d 74 69 6d 65 20 6d 74 2d 6d 6f start-time mt-mo
6240: 64 2d 74 69 6d 65 29 20 34 29 29 0a 09 09 20 20 d-time) 4))...
6250: 20 28 77 69 6c 6c 2d 73 79 6e 63 20 20 20 20 20 (will-sync
6260: 20 20 20 28 61 6e 64 20 28 6f 72 20 6e 65 65 64 (and (or need
6270: 2d 73 79 6e 63 20 73 68 6f 75 6c 64 2d 73 79 6e -sync should-syn
6280: 63 29 0a 09 09 09 09 09 20 20 28 6e 6f 74 20 73 c)...... (not s
6290: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 29 ync-in-progress)
62a0: 0a 09 09 09 09 09 20 20 28 6e 6f 74 20 72 65 63 ...... (not rec
62b0: 65 6e 74 6c 79 2d 73 79 6e 63 65 64 29 29 29 29 ently-synced))))
62c0: 0a 09 20 20 20 20 20 20 3b 3b 20 28 69 66 20 72 .. ;; (if r
62d0: 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 20 28 ecently-synced (
62e0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
62f0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6300: 70 6f 72 74 2a 20 22 53 6b 69 70 70 69 6e 67 20 port* "Skipping
6310: 73 79 6e 63 20 64 75 65 20 74 6f 20 72 65 63 65 sync due to rece
6320: 6e 74 6c 79 2d 73 79 6e 63 65 64 20 66 6c 61 67 ntly-synced flag
6330: 3d 22 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 =" recently-sync
6340: 65 64 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 ed)).. ;; (
6350: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6360: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6370: 70 6f 72 74 2a 20 22 6e 65 65 64 2d 73 79 6e 63 port* "need-sync
6380: 3a 20 22 20 6e 65 65 64 2d 73 79 6e 63 20 22 20 : " need-sync "
6390: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
63a0: 3a 20 22 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 : " sync-in-prog
63b0: 72 65 73 73 20 22 20 73 68 6f 75 6c 64 2d 73 79 ress " should-sy
63c0: 6e 63 3a 20 22 20 73 68 6f 75 6c 64 2d 73 79 6e nc: " should-syn
63d0: 63 20 22 20 77 69 6c 6c 2d 73 79 6e 63 3a 20 22 c " will-sync: "
63e0: 20 77 69 6c 6c 2d 73 79 6e 63 29 0a 09 20 20 20 will-sync)..
63f0: 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 (if will-sync
6400: 20 28 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d (set! *db-sync-
6410: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 74 29 in-progress* #t)
6420: 29 0a 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d ).. (mutex-
6430: 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 unlock! *db-mult
6440: 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 i-sync-mutex*)..
6450: 20 20 20 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 (if will-s
6460: 79 6e 63 0a 09 09 20 20 28 6c 65 74 20 28 28 72 ync... (let ((r
6470: 65 73 20 28 63 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d es (common:sync-
6480: 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 62 20 64 to-megatest.db d
6490: 62 73 74 72 75 63 74 29 29 29 20 3b 3b 20 64 69 bstruct))) ;; di
64a0: 64 20 77 65 20 73 79 6e 63 20 61 6e 79 20 64 61 d we sync any da
64b0: 74 61 3f 20 49 66 20 73 6f 20 6e 65 65 64 20 74 ta? If so need t
64c0: 6f 20 73 65 74 20 74 68 65 20 64 62 20 74 6f 75 o set the db tou
64d0: 63 68 65 64 20 66 6c 61 67 20 74 6f 20 6b 65 65 ched flag to kee
64e0: 70 20 74 68 65 20 73 65 72 76 65 72 20 61 6c 69 p the server ali
64f0: 76 65 0a 09 09 20 20 20 20 28 69 66 20 28 3e 20 ve... (if (>
6500: 72 65 73 20 30 29 20 3b 3b 20 73 6f 6d 65 20 72 res 0) ;; some r
6510: 65 63 6f 72 64 73 20 77 65 72 65 20 74 72 61 6e ecords were tran
6520: 73 66 65 72 72 65 64 2c 20 6b 65 65 70 20 74 68 sferred, keep th
6530: 65 20 64 62 20 61 6c 69 76 65 0a 09 09 09 28 62 e db alive....(b
6540: 65 67 69 6e 0a 09 09 09 20 20 28 6d 75 74 65 78 egin.... (mutex
6550: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
6560: 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 28 t-mutex*).... (
6570: 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 set! *db-last-ac
6580: 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 cess* (current-s
6590: 65 63 6f 6e 64 73 29 29 0a 09 09 09 20 20 28 6d econds)).... (m
65a0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he
65b0: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
65c0: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
65d0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
65e0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 79 6e t-log-port* "syn
65f0: 63 20 63 61 6c 6c 65 64 2c 20 22 20 72 65 73 20 c called, " res
6600: 22 20 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 " records transf
6610: 65 72 72 65 64 2e 22 29 29 0a 09 09 09 28 64 65 erred."))....(de
6620: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
6630: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6640: 72 74 2a 20 22 73 79 6e 63 20 63 61 6c 6c 65 64 rt* "sync called
6650: 20 62 75 74 20 7a 65 72 6f 20 72 65 63 6f 72 64 but zero record
6660: 73 20 74 72 61 6e 73 66 65 72 72 65 64 22 29 29 s transferred"))
6670: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 77 69 )).. (if wi
6680: 6c 6c 2d 73 79 6e 63 0a 09 09 20 20 28 62 65 67 ll-sync... (beg
6690: 69 6e 0a 09 09 20 20 20 20 28 6d 75 74 65 78 2d in... (mutex-
66a0: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
66b0: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 09 20 sync-mutex*)...
66c0: 20 20 20 28 73 65 74 21 20 2a 64 62 2d 73 79 6e (set! *db-syn
66d0: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 c-in-progress* #
66e0: 66 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 2a f)... (set! *
66f0: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 73 74 db-last-sync* st
6700: 61 72 74 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 art-time)...
6710: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
6720: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
6730: 74 65 78 2a 29 29 29 0a 09 20 20 20 20 20 20 28 tex*))).. (
6740: 69 66 20 28 61 6e 64 20 64 65 62 75 67 2d 6d 6f if (and debug-mo
6750: 64 65 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 de... (> (
6760: 2d 20 73 74 61 72 74 2d 74 69 6d 65 20 6c 61 73 - start-time las
6770: 74 2d 74 69 6d 65 29 20 36 30 29 29 0a 09 09 20 t-time) 60))...
6780: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 73 (begin... (s
6790: 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 20 73 74 et! last-time st
67a0: 61 72 74 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 art-time)...
67b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
67c0: 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
67d0: 2d 70 6f 72 74 2a 20 22 74 69 6d 65 73 74 61 6d -port* "timestam
67e0: 70 20 2d 3e 20 22 20 28 73 65 63 6f 6e 64 73 2d p -> " (seconds-
67f0: 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 28 63 75 >time-string (cu
6800: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 rrent-seconds))
6810: 22 2c 20 74 69 6d 65 20 73 69 6e 63 65 20 73 74 ", time since st
6820: 61 72 74 20 2d 3e 20 22 20 28 73 65 63 6f 6e 64 art -> " (second
6830: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d s->hr-min-sec (-
6840: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
6850: 73 29 20 2a 74 69 6d 65 2d 7a 65 72 6f 2a 29 29 s) *time-zero*))
6860: 29 29 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 )))).. ..
6870: 3b 3b 20 6b 65 65 70 20 67 6f 69 6e 67 20 75 6e ;; keep going un
6880: 6c 65 73 73 20 74 69 6d 65 20 74 6f 20 65 78 69 less time to exi
6890: 74 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 t.. ;;.. (
68a0: 69 66 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f if (not *time-to
68b0: 2d 65 78 69 74 2a 29 0a 09 09 28 6c 65 74 20 64 -exit*)...(let d
68c0: 65 6c 61 79 2d 6c 6f 6f 70 20 28 28 63 6f 75 6e elay-loop ((coun
68d0: 74 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 0)).
68e0: 20 20 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 ;;(BB> "
68f0: 64 65 6c 61 79 2d 6c 6f 6f 70 20 74 6f 70 3b 20 delay-loop top;
6900: 63 6f 75 6e 74 3d 22 63 6f 75 6e 74 22 20 70 69 count="count" pi
6910: 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 d="(current-proc
6920: 65 73 73 2d 69 64 29 22 20 74 68 69 73 2d 77 64 ess-id)" this-wd
6930: 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 64 2d 6e 75 -num="this-wd-nu
6940: 6d 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 m" *time-to-exit
6950: 2a 3d 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 *="*time-to-exit
6960: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
6970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6980: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
69a0: 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f .. (if (and (no
69b0: 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a t *time-to-exit*
69c0: 29 0a 09 09 09 20 20 20 28 3c 20 63 6f 75 6e 74 ).... (< count
69d0: 20 34 29 29 20 3b 3b 20 77 61 73 20 31 31 2c 20 4)) ;; was 11,
69e0: 63 68 61 6e 67 69 6e 67 20 74 6f 20 34 2e 20 0a changing to 4. .
69f0: 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
6a00: 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
6a10: 20 31 29 0a 09 09 09 28 64 65 6c 61 79 2d 6c 6f 1)....(delay-lo
6a20: 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 op (+ count 1)))
6a30: 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 2a )... (if (not *
6a40: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 20 28 time-to-exit*) (
6a50: 6c 6f 6f 70 29 29 29 29 0a 09 20 20 20 20 28 69 loop)))).. (i
6a60: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
6a70: 69 73 65 2d 70 72 69 6e 74 20 33 30 29 0a 09 09 ise-print 30)...
6a80: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6a90: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
6aa0: 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 -port* "Exiting
6ab0: 77 61 74 63 68 64 6f 67 20 74 69 6d 65 72 2c 20 watchdog timer,
6ac0: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3d *time-to-exit* =
6ad0: 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 " *time-to-exit
6ae0: 2a 22 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 *" pid="(current
6af0: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 74 68 -process-id)" th
6b00: 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 2d is-wd-num="this-
6b10: 77 64 2d 6e 75 6d 29 29 29 29 29 29 29 0a 0a 3b wd-num)))))))..;
6b20: 3b 20 54 4f 44 4f 3a 20 66 6f 72 20 6d 75 6c 74 ; TODO: for mult
6b30: 69 70 6c 65 20 61 72 65 61 73 2c 20 77 65 20 77 iple areas, we w
6b40: 69 6c 6c 20 68 61 76 65 20 6d 75 6c 74 69 70 6c ill have multipl
6b50: 65 20 77 61 74 63 68 64 6f 67 73 3b 20 61 6e 64 e watchdogs; and
6b60: 20 6d 75 6c 74 69 70 6c 65 20 74 68 72 65 61 64 multiple thread
6b70: 73 20 74 6f 20 6d 61 6e 61 67 65 0a 28 64 65 66 s to manage.(def
6b80: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 74 63 ine (common:watc
6b90: 68 64 6f 67 29 0a 20 20 28 6c 65 74 20 28 28 64 hdog). (let ((d
6ba0: 62 73 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 bstruct (db:setu
6bb0: 70 29 29 29 0a 20 20 20 20 28 69 66 20 28 64 62 p))). (if (db
6bc0: 72 3a 64 62 73 74 72 75 63 74 2d 72 65 61 64 2d r:dbstruct-read-
6bd0: 6f 6e 6c 79 20 64 62 73 74 72 75 63 74 29 0a 20 only dbstruct).
6be0: 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 72 (common:r
6bf0: 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 eadonly-watchdog
6c00: 20 64 62 73 74 72 75 63 74 29 0a 20 20 20 20 20 dbstruct).
6c10: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 72 69 74 61 (common:writa
6c20: 62 6c 65 2d 77 61 74 63 68 64 6f 67 20 64 62 73 ble-watchdog dbs
6c30: 74 72 75 63 74 29 29 29 29 0a 0a 0a 28 64 65 66 truct))))...(def
6c40: 69 6e 65 20 28 73 74 64 2d 65 78 69 74 2d 70 72 ine (std-exit-pr
6c50: 6f 63 65 64 75 72 65 29 0a 20 20 28 6f 6e 2d 65 ocedure). (on-e
6c60: 78 69 74 20 28 6c 61 6d 62 64 61 20 28 29 20 30 xit (lambda () 0
6c70: 29 29 0a 20 20 3b 3b 28 42 42 3e 20 22 73 74 64 )). ;;(BB> "std
6c80: 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 72 65 20 -exit-procedure
6c90: 63 61 6c 6c 65 64 3b 20 2a 74 69 6d 65 2d 74 6f called; *time-to
6ca0: 2d 65 78 69 74 2a 3d 22 2a 74 69 6d 65 2d 74 6f -exit*="*time-to
6cb0: 2d 65 78 69 74 2a 29 0a 20 20 28 6c 65 74 20 28 -exit*). (let (
6cc0: 28 6e 6f 2d 68 75 72 72 79 20 20 28 69 66 20 2a (no-hurry (if *
6cd0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3b 3b time-to-exit* ;;
6ce0: 20 68 75 72 72 79 20 75 70 0a 09 09 20 20 20 20 hurry up...
6cf0: 20 20 20 23 66 0a 09 09 20 20 20 20 20 20 20 28 #f... (
6d00: 62 65 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 begin.... (set!
6d10: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 *time-to-exit* #
6d20: 74 29 0a 09 09 09 20 23 74 29 29 29 29 0a 20 20 t).... #t)))).
6d30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6d40: 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 4 *default-l
6d50: 6f 67 2d 70 6f 72 74 2a 20 22 73 74 61 72 74 69 og-port* "starti
6d60: 6e 67 20 65 78 69 74 20 70 72 6f 63 65 73 73 2c ng exit process,
6d70: 20 66 69 6e 61 6c 69 7a 69 6e 67 20 64 61 74 61 finalizing data
6d80: 62 61 73 65 73 2e 22 29 0a 20 20 20 20 28 69 66 bases."). (if
6d90: 20 28 61 6e 64 20 6e 6f 2d 68 75 72 72 79 20 28 (and no-hurry (
6da0: 64 65 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 debug:debug-mode
6db0: 20 31 38 29 29 0a 09 28 72 6d 74 3a 70 72 69 6e 18))..(rmt:prin
6dc0: 74 2d 64 62 2d 73 74 61 74 73 29 29 0a 20 20 20 t-db-stats)).
6dd0: 20 28 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b (let ((th1 (mak
6de0: 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 e-thread (lambda
6df0: 20 28 29 20 3b 3b 20 74 68 72 65 61 64 20 66 6f () ;; thread fo
6e00: 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 2c 20 67 r cleaning up, g
6e10: 69 76 65 20 69 74 20 66 69 76 65 20 73 65 63 6f ive it five seco
6e20: 6e 64 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 nds.
6e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6e40: 20 20 28 69 66 20 2a 64 62 73 74 72 75 63 74 2d (if *dbstruct-
6e50: 64 62 2a 20 28 64 62 3a 63 6c 6f 73 65 2d 61 6c db* (db:close-al
6e60: 6c 20 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 29 l *dbstruct-db*)
6e70: 29 20 3b 3b 20 6f 6e 65 20 73 65 63 6f 6e 64 20 ) ;; one second
6e80: 61 6c 6c 6f 63 61 74 65 64 0a 09 09 09 20 20 20 allocated....
6e90: 20 20 20 28 69 66 20 2a 74 61 73 6b 2d 64 62 2a (if *task-db*
6ea0: 20 20 20 20 0a 09 09 09 09 20 20 28 6c 65 74 20 ..... (let
6eb0: 28 28 64 62 20 28 63 64 72 20 2a 74 61 73 6b 2d ((db (cdr *task-
6ec0: 64 62 2a 29 29 29 0a 09 09 09 09 20 20 20 20 28 db*)))..... (
6ed0: 69 66 20 28 73 71 6c 69 74 65 33 3a 64 61 74 61 if (sqlite3:data
6ee0: 62 61 73 65 3f 20 64 62 29 0a 09 09 09 09 09 28 base? db)......(
6ef0: 62 65 67 69 6e 0a 09 09 09 09 09 20 20 28 73 71 begin...... (sq
6f00: 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 70 74 21 lite3:interrupt!
6f10: 20 64 62 29 0a 09 09 09 09 09 20 20 28 73 71 6c db)...... (sql
6f20: 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 ite3:finalize! d
6f30: 62 20 23 74 29 0a 09 09 09 09 09 20 20 3b 3b 20 b #t)...... ;;
6f40: 28 76 65 63 74 6f 72 2d 73 65 74 21 20 2a 74 61 (vector-set! *ta
6f50: 73 6b 2d 64 62 2a 20 30 20 23 66 29 0a 09 09 09 sk-db* 0 #f)....
6f60: 09 09 20 20 28 73 65 74 21 20 2a 74 61 73 6b 2d .. (set! *task-
6f70: 64 62 2a 20 23 66 29 29 29 29 29 0a 20 20 20 20 db* #f))))).
6f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6f90: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 61 (if (a
6fa0: 6e 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 20 nd *runremote*.
6fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6fd0: 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d 63 6f (remote-co
6fe0: 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d 6f 74 65 nndat *runremote
6ff0: 2a 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 *)).
7000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7010: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
7020: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7030: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7040: 20 28 68 74 74 70 2d 63 6c 69 65 6e 74 23 63 6c (http-client#cl
7050: 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 ose-all-connecti
7060: 6f 6e 73 21 29 29 29 20 3b 3b 20 66 6f 72 20 68 ons!))) ;; for h
7070: 74 74 70 2d 63 6c 69 65 6e 74 0a 20 20 20 20 20 ttp-client.
7080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7090: 20 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f (if (no
70a0: 74 20 28 65 71 3f 20 2a 64 65 66 61 75 6c 74 2d t (eq? *default-
70b0: 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 65 log-port* (curre
70c0: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 nt-error-port)))
70d0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
70e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
70f0: 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 (close-output
7100: 2d 70 6f 72 74 20 2a 64 65 66 61 75 6c 74 2d 6c -port *default-l
7110: 6f 67 2d 70 6f 72 74 2a 29 29 0a 09 09 09 20 20 og-port*))....
7120: 20 20 20 20 28 73 65 74 21 20 2a 64 65 66 61 75 (set! *defau
7130: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 lt-log-port* (cu
7140: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
7150: 29 29 29 20 22 43 6c 65 61 6e 75 70 20 64 62 20 ))) "Cleanup db
7160: 65 78 69 74 20 74 68 72 65 61 64 22 29 29 0a 09 exit thread"))..
7170: 20 20 28 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 (th2 (make-thr
7180: 65 61 64 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 ead (lambda ()..
7190: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
71a0: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
71b0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d log-port* "Attem
71c0: 70 74 69 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 pting clean exit
71d0: 2e 20 50 6c 65 61 73 65 20 62 65 20 70 61 74 69 . Please be pati
71e0: 65 6e 74 20 61 6e 64 20 77 61 69 74 20 61 20 66 ent and wait a f
71f0: 65 77 20 73 65 63 6f 6e 64 73 2e 2e 2e 22 29 0a ew seconds...").
7200: 09 09 09 20 20 20 20 20 20 28 69 66 20 6e 6f 2d ... (if no-
7210: 68 75 72 72 79 0a 20 20 20 20 20 20 20 20 20 20 hurry.
7220: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7230: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
7240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7260: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
7270: 21 20 35 29 29 20 3b 3b 20 67 69 76 65 20 74 68 ! 5)) ;; give th
7280: 65 20 63 6c 65 61 6e 20 75 70 20 66 65 77 20 73 e clean up few s
7290: 65 63 6f 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 econds to do it'
72a0: 73 20 73 74 75 66 66 0a 20 20 20 20 20 20 20 20 s stuff.
72b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
72c0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
72d0: 0a 20 20 20 20 20 20 09 09 09 09 20 20 28 74 68 . .... (th
72e0: 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 29 29 read-sleep! 2)))
72f0: 0a 20 20 20 20 20 20 09 09 09 20 20 20 20 20 20 . ...
7300: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a (debug:print 4 *
7310: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7320: 2a 20 22 20 2e 2e 2e 20 64 6f 6e 65 22 29 0a 20 * " ... done").
7330: 20 20 20 20 20 09 09 09 20 20 20 20 20 20 29 0a ... ).
7340: 09 09 09 20 20 20 20 22 63 6c 65 61 6e 20 65 78 ... "clean ex
7350: 69 74 22 29 29 29 0a 20 20 20 20 20 20 28 74 68 it"))). (th
7360: 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 31 29 read-start! th1)
7370: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
7380: 74 61 72 74 21 20 74 68 32 29 0a 20 20 20 20 20 tart! th2).
7390: 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 (thread-join! t
73a0: 68 31 29 0a 20 20 20 20 20 20 29 0a 20 20 20 20 h1). ).
73b0: 29 0a 0a 20 20 30 29 0a 0a 28 64 65 66 69 6e 65 ).. 0)..(define
73c0: 20 28 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e (std-signal-han
73d0: 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a 20 20 3b dler signum). ;
73e0: 3b 20 28 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 ; (signal-mask!
73f0: 73 69 67 6e 75 6d 29 0a 20 20 28 73 65 74 21 20 signum). (set!
7400: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 *time-to-exit* #
7410: 74 29 0a 20 20 3b 3b 28 42 42 3e 20 22 67 6f 74 t). ;;(BB> "got
7420: 20 73 69 67 6e 61 6c 20 22 73 69 67 6e 75 6d 29 signal "signum)
7430: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
7440: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
7450: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 -log-port* "Rece
7460: 69 76 65 64 20 73 69 67 6e 61 6c 20 22 20 73 69 ived signal " si
7470: 67 6e 75 6d 20 22 20 65 78 69 74 69 6e 67 20 70 gnum " exiting p
7480: 72 6f 6d 70 74 6c 79 22 29 0a 20 20 3b 3b 20 28 romptly"). ;; (
7490: 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 std-exit-procedu
74a0: 72 65 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 re) ;; shouldn't
74b0: 20 6e 65 65 64 20 74 68 69 73 20 73 69 6e 63 65 need this since
74c0: 20 77 65 20 61 72 65 20 65 78 69 74 69 6e 67 20 we are exiting
74d0: 61 6e 64 20 69 74 20 77 69 6c 6c 20 62 65 20 63 and it will be c
74e0: 61 6c 6c 65 64 20 61 6e 79 77 61 79 0a 20 20 28 alled anyway. (
74f0: 65 78 69 74 29 29 0a 0a 28 73 65 74 2d 73 69 67 exit))..(set-sig
7500: 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 nal-handler! sig
7510: 6e 61 6c 2f 69 6e 74 20 20 73 74 64 2d 73 69 67 nal/int std-sig
7520: 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b nal-handler) ;;
7530: 20 5e 43 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d ^C.(set-signal-
7540: 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f handler! signal/
7550: 74 65 72 6d 20 73 74 64 2d 73 69 67 6e 61 6c 2d term std-signal-
7560: 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 28 73 65 74 handler).;; (set
7570: 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 -signal-handler!
7580: 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 74 64 signal/stop std
7590: 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 -signal-handler)
75a0: 20 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 6f 20 4e ;; ^Z NO, do N
75b0: 4f 54 20 68 61 6e 64 6c 65 20 5e 5a 21 0a 0a 3b OT handle ^Z!..;
75c0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
75d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
75f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7600: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 =======.;; M I S
7610: 20 43 20 20 20 55 20 54 20 49 20 4c 20 53 0a 3b C U T I L S.;
7620: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7660: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6f 6e 65 2d =======..;; one-
7670: 6f 66 20 61 72 67 73 20 64 65 66 69 6e 65 64 0a of args defined.
7680: 28 64 65 66 69 6e 65 20 28 61 72 67 73 2d 64 65 (define (args-de
7690: 66 69 6e 65 64 3f 20 2e 20 70 61 72 61 6d 29 0a fined? . param).
76a0: 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 (let ((res #f)
76b0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
76c0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 . (lambda (a
76d0: 72 67 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 rg). (if (
76e0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 61 72 67 args:get-arg arg
76f0: 29 28 73 65 74 21 20 72 65 73 20 23 74 29 29 29 )(set! res #t)))
7700: 0a 20 20 20 20 20 70 61 72 61 6d 29 0a 20 20 20 . param).
7710: 20 72 65 73 29 29 0a 0a 3b 3b 20 63 6f 6e 76 65 res))..;; conve
7720: 72 74 20 73 74 75 66 66 20 74 6f 20 61 20 6e 75 rt stuff to a nu
7730: 6d 62 65 72 20 69 66 20 70 6f 73 73 69 62 6c 65 mber if possible
7740: 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 2d 3e 6e .(define (any->n
7750: 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 6f umber val). (co
7760: 6e 64 20 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f nd . ((number?
7770: 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 val) val). ((
7780: 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 28 73 74 string? val) (st
7790: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c ring->number val
77a0: 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 )). ((symbol?
77b0: 76 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 val) (any->numbe
77c0: 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e r (symbol->strin
77d0: 67 20 76 61 6c 29 29 29 0a 20 20 20 28 65 6c 73 g val))). (els
77e0: 65 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 e #f)))..(define
77f0: 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 2d 69 66 (any->number-if
7800: 2d 70 6f 73 73 69 62 6c 65 20 76 61 6c 29 0a 20 -possible val).
7810: 20 28 6c 65 74 20 28 28 6e 75 6d 20 28 61 6e 79 (let ((num (any
7820: 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 29 0a ->number val))).
7830: 20 20 20 20 28 69 66 20 6e 75 6d 20 6e 75 6d 20 (if num num
7840: 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 val)))..(define
7850: 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 (patt-list-match
7860: 20 69 74 65 6d 20 70 61 74 74 73 29 0a 20 20 28 item patts). (
7870: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7880: 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 8 *default-log-
7890: 70 6f 72 74 2a 20 22 70 61 74 74 2d 6c 69 73 74 port* "patt-list
78a0: 2d 6d 61 74 63 68 20 69 74 65 6d 3d 22 20 69 74 -match item=" it
78b0: 65 6d 20 22 20 70 61 74 74 73 3d 22 20 70 61 74 em " patts=" pat
78c0: 74 73 29 0a 20 20 28 69 66 20 28 61 6e 64 20 69 ts). (if (and i
78d0: 74 65 6d 20 70 61 74 74 73 29 20 20 3b 3b 20 68 tem patts) ;; h
78e0: 65 72 65 20 77 65 20 61 72 65 20 66 69 6c 74 65 ere we are filte
78f0: 72 69 6e 67 20 66 6f 72 20 6d 61 74 63 68 65 73 ring for matches
7900: 20 77 69 74 68 20 69 74 65 6d 20 70 61 74 74 65 with item patte
7910: 72 6e 73 0a 20 20 20 20 20 20 28 6c 65 74 20 28 rns. (let (
7920: 28 72 65 73 20 23 66 29 29 20 20 20 3b 3b 20 6c (res #f)) ;; l
7930: 6f 6f 6b 20 74 68 72 6f 75 67 68 20 61 6c 6c 20 ook through all
7940: 74 68 65 20 69 74 65 6d 2d 70 61 74 74 73 20 69 the item-patts i
7950: 66 20 64 65 66 69 6e 65 64 2c 20 66 6f 72 6d 61 f defined, forma
7960: 74 20 69 73 20 70 61 74 74 31 2c 70 61 74 74 32 t is patt1,patt2
7970: 2c 70 61 74 74 33 20 2e 2e 2e 20 77 69 6c 64 63 ,patt3 ... wildc
7980: 61 72 64 20 69 73 20 25 0a 09 28 66 6f 72 2d 65 ard is %..(for-e
7990: 61 63 68 20 0a 09 20 28 6c 61 6d 62 64 61 20 28 ach .. (lambda (
79a0: 70 61 74 74 29 0a 09 20 20 20 28 6c 65 74 20 28 patt).. (let (
79b0: 28 6d 6f 64 70 61 74 74 20 28 73 74 72 69 6e 67 (modpatt (string
79c0: 2d 73 75 62 73 74 69 74 75 74 65 20 22 25 22 20 -substitute "%"
79d0: 22 2e 2a 22 20 70 61 74 74 20 23 74 29 29 29 0a ".*" patt #t))).
79e0: 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
79f0: 6e 74 2d 69 6e 66 6f 20 31 30 20 2a 64 65 66 61 nt-info 10 *defa
7a00: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 ult-log-port* "p
7a10: 61 74 74 20 22 20 70 61 74 74 20 22 20 6d 6f 64 att " patt " mod
7a20: 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 29 0a patt " modpatt).
7a30: 09 20 20 20 20 20 28 69 66 20 28 73 74 72 69 6e . (if (strin
7a40: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
7a50: 6d 6f 64 70 61 74 74 29 20 69 74 65 6d 29 0a 09 modpatt) item)..
7a60: 09 20 28 73 65 74 21 20 72 65 73 20 23 74 29 29 . (set! res #t))
7a70: 29 29 0a 09 20 28 73 74 72 69 6e 67 2d 73 70 6c )).. (string-spl
7a80: 69 74 20 70 61 74 74 73 20 22 2c 22 29 29 0a 09 it patts ","))..
7a90: 72 65 73 29 0a 20 20 20 20 20 20 23 74 29 29 0a res). #t)).
7aa0: 0a 3b 3b 20 28 6d 61 70 20 70 72 69 6e 74 20 28 .;; (map print (
7ab0: 6d 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 map car (hash-ta
7ac0: 62 6c 65 2d 3e 61 6c 69 73 74 20 28 72 65 61 64 ble->alist (read
7ad0: 2d 63 6f 6e 66 69 67 20 22 72 75 6e 63 6f 6e 66 -config "runconf
7ae0: 69 67 73 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 igs.config" #f #
7af0: 74 29 29 29 29 0a 28 64 65 66 69 6e 65 20 28 63 t)))).(define (c
7b00: 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 75 6e 63 6f 6e ommon:get-runcon
7b10: 66 69 67 2d 74 61 72 67 65 74 73 20 23 21 6b 65 fig-targets #!ke
7b20: 79 20 28 63 6f 6e 66 69 67 66 20 23 66 29 29 0a y (configf #f)).
7b30: 20 20 28 6c 65 74 20 28 28 74 61 72 67 73 20 20 (let ((targs
7b40: 20 20 20 20 20 28 73 6f 72 74 20 28 6d 61 70 20 (sort (map
7b50: 63 61 72 20 28 68 61 73 68 2d 74 61 62 6c 65 2d car (hash-table-
7b60: 3e 61 6c 69 73 74 0a 09 09 09 09 20 20 20 20 20 >alist.....
7b70: 28 6f 72 20 63 6f 6e 66 69 67 66 20 3b 3b 20 4e (or configf ;; N
7b80: 4f 54 45 3a 20 54 68 65 72 65 20 69 73 20 6e 6f OTE: There is no
7b90: 20 76 61 6c 75 65 20 69 6e 20 75 73 69 6e 67 20 value in using
7ba0: 72 75 6e 63 6f 6e 66 69 67 3a 72 65 61 64 20 68 runconfig:read h
7bb0: 65 72 65 2e 0a 09 09 09 09 09 20 28 72 65 61 64 ere....... (read
7bc0: 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 20 2a 74 -config (conc *t
7bd0: 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e 63 6f 6e oppath* "/runcon
7be0: 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 0a 09 09 figs.config")...
7bf0: 09 09 09 09 20 20 20 20 20 20 23 66 20 23 74 29 .... #f #t)
7c00: 0a 09 09 09 09 09 20 28 6d 61 6b 65 2d 68 61 73 ...... (make-has
7c10: 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 09 09 20 h-table))))....
7c20: 20 20 73 74 72 69 6e 67 3c 3f 29 29 0a 09 28 74 string<?))..(t
7c30: 61 72 67 65 74 2d 70 61 74 74 20 28 61 72 67 73 arget-patt (args
7c40: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
7c50: 74 22 29 29 29 0a 20 20 20 20 28 69 66 20 74 61 t"))). (if ta
7c60: 72 67 65 74 2d 70 61 74 74 0a 09 28 66 69 6c 74 rget-patt..(filt
7c70: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 er (lambda (x)..
7c80: 09 20 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 . (patt-list-ma
7c90: 74 63 68 20 78 20 74 61 72 67 65 74 2d 70 61 74 tch x target-pat
7ca0: 74 29 29 0a 09 09 74 61 72 67 73 29 0a 09 74 61 t))...targs)..ta
7cb0: 72 67 73 29 29 29 0a 0a 3b 3b 20 27 28 70 72 69 rgs)))..;; '(pri
7cc0: 6e 74 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 nt (string-inter
7cd0: 73 70 65 72 73 65 20 28 6d 61 70 20 63 61 64 72 sperse (map cadr
7ce0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
7cf0: 2f 64 65 66 61 75 6c 74 20 28 72 65 61 64 2d 63 /default (read-c
7d00: 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 73 74 2e onfig "megatest.
7d10: 63 6f 6e 66 69 67 22 20 5c 23 66 20 5c 23 74 29 config" \#f \#t)
7d20: 20 22 64 69 73 6b 73 22 20 27 22 27 22 27 28 22 "disks" '"'"'("
7d30: 6e 6f 6e 65 22 20 22 22 29 29 29 20 22 5c 6e 22 none" ""))) "\n"
7d40: 29 29 27 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))'.(define (com
7d50: 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 73 20 23 21 mon:get-disks #!
7d60: 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 29 key (configf #f)
7d70: 29 0a 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ). (hash-table-
7d80: 72 65 66 2f 64 65 66 61 75 6c 74 20 0a 20 20 20 ref/default .
7d90: 28 6f 72 20 63 6f 6e 66 69 67 66 20 28 72 65 61 (or configf (rea
7da0: 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 65 d-config "megate
7db0: 73 74 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 74 st.config" #f #t
7dc0: 29 29 0a 20 20 20 22 64 69 73 6b 73 22 20 27 28 )). "disks" '(
7dd0: 22 6e 6f 6e 65 22 20 22 22 29 29 29 0a 0a 3b 3b "none" "")))..;;
7de0: 20 72 65 74 75 72 6e 20 66 69 72 73 74 20 63 6f return first co
7df0: 6d 6d 61 6e 64 20 74 68 61 74 20 65 78 69 73 74 mmand that exist
7e00: 73 2c 20 65 6c 73 65 20 23 66 0a 3b 3b 0a 28 64 s, else #f.;;.(d
7e10: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 68 efine (common:wh
7e20: 69 63 68 20 63 6d 64 73 29 0a 20 20 28 69 66 20 ich cmds). (if
7e30: 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 0a 20 20 20 (null? cmds).
7e40: 20 20 20 23 66 0a 20 20 20 20 20 20 28 6c 65 74 #f. (let
7e50: 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
7e60: 20 63 6d 64 73 29 29 0a 09 09 20 28 74 61 6c 20 cmds))... (tal
7e70: 28 63 64 72 20 63 6d 64 73 29 29 29 0a 09 28 6c (cdr cmds)))..(l
7e80: 65 74 20 28 28 72 65 73 20 28 77 69 74 68 2d 69 et ((res (with-i
7e90: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 nput-from-pipe (
7ea0: 63 6f 6e 63 20 22 77 68 69 63 68 20 22 20 68 65 conc "which " he
7eb0: 64 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a d) read-line))).
7ec0: 09 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 . (if (and (str
7ed0: 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 28 ing? res)... (
7ee0: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 73 file-exists? res
7ef0: 29 29 0a 09 20 20 20 20 20 20 72 65 73 0a 09 20 )).. res..
7f00: 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
7f10: 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 20 tal)... #f...
7f20: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
7f30: 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a cdr tal)))))))).
7f40: 20 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d .(define (comm
7f50: 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c 6c 2d 61 on:get-install-a
7f60: 72 65 61 29 0a 20 20 28 6c 65 74 20 28 28 65 78 rea). (let ((ex
7f70: 65 2d 70 61 74 68 20 28 63 61 72 20 28 61 72 67 e-path (car (arg
7f80: 76 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 v)))). (if (f
7f90: 69 6c 65 2d 65 78 69 73 74 73 3f 20 65 78 65 2d ile-exists? exe-
7fa0: 70 61 74 68 29 0a 09 28 68 61 6e 64 6c 65 2d 65 path)..(handle-e
7fb0: 78 63 65 70 74 69 6f 6e 73 0a 09 20 65 78 6e 0a xceptions.. exn.
7fc0: 09 20 23 66 0a 09 20 28 70 61 74 68 6e 61 6d 65 . #f.. (pathname
7fd0: 2d 64 69 72 65 63 74 6f 72 79 0a 09 20 20 28 70 -directory.. (p
7fe0: 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 athname-director
7ff0: 79 20 0a 09 20 20 20 28 70 61 74 68 6e 61 6d 65 y .. (pathname
8000: 2d 64 69 72 65 63 74 6f 72 79 20 65 78 65 2d 70 -directory exe-p
8010: 61 74 68 29 29 29 29 0a 09 23 66 29 29 29 0a 0a ath))))..#f)))..
8020: 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 73 74 20 ;; return first
8030: 70 61 74 68 20 74 68 61 74 20 63 61 6e 20 62 65 path that can be
8040: 20 63 72 65 61 74 65 64 20 6f 72 20 61 6c 72 65 created or alre
8050: 61 64 79 20 65 78 69 73 74 73 20 61 6e 64 20 69 ady exists and i
8060: 73 20 77 72 69 74 61 62 6c 65 0a 3b 3b 0a 28 64 s writable.;;.(d
8070: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
8080: 74 2d 63 72 65 61 74 65 2d 77 72 69 74 65 61 62 t-create-writeab
8090: 6c 65 2d 64 69 72 20 64 69 72 73 29 0a 20 20 28 le-dir dirs). (
80a0: 69 66 20 28 6e 75 6c 6c 3f 20 64 69 72 73 29 0a if (null? dirs).
80b0: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 28 #f. (
80c0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 let loop ((hed (
80d0: 63 61 72 20 64 69 72 73 29 29 0a 09 09 20 28 74 car dirs))... (t
80e0: 61 6c 20 28 63 64 72 20 64 69 72 73 29 29 29 0a al (cdr dirs))).
80f0: 09 28 6c 65 74 20 28 28 72 65 73 20 28 6f 72 20 .(let ((res (or
8100: 28 61 6e 64 20 28 64 69 72 65 63 74 6f 72 79 3f (and (directory?
8110: 20 68 65 64 29 0a 09 09 09 20 20 20 20 28 66 69 hed).... (fi
8120: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
8130: 20 68 65 64 29 0a 09 09 09 20 20 20 20 68 65 64 hed).... hed
8140: 29 0a 09 09 20 20 20 20 20 20 20 28 68 61 6e 64 )... (hand
8150: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 le-exceptions...
8160: 09 65 78 6e 0a 09 09 09 23 66 0a 09 09 09 28 63 .exn....#f....(c
8170: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
8180: 68 65 64 20 23 74 29 29 29 29 29 0a 09 20 20 28 hed #t))))).. (
8190: 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f if (and (string?
81a0: 20 72 65 73 29 0a 09 09 20 20 20 28 64 69 72 65 res)... (dire
81b0: 63 74 6f 72 79 3f 20 72 65 73 29 29 0a 09 20 20 ctory? res))..
81c0: 20 20 20 20 72 65 73 0a 09 20 20 20 20 20 20 28 res.. (
81d0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
81e0: 09 20 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 . #f... (loop
81f0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
8200: 6c 29 29 29 29 29 29 29 29 0a 20 20 0a 3b 3b 3d l)))))))). .;;=
8210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8250: 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 20 52 20 47 =====.;; T A R G
8260: 20 45 20 54 20 53 20 20 2c 20 20 20 53 20 54 20 E T S , S T
8270: 41 20 54 20 45 20 2c 20 20 20 53 20 54 20 41 20 A T E , S T A
8280: 54 20 55 20 53 20 2c 20 20 20 0a 3b 3b 20 20 20 T U S , .;;
8290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
82a0: 20 52 20 55 20 4e 20 4e 20 41 20 4d 20 45 20 20 R U N N A M E
82b0: 20 20 41 20 4e 20 44 20 20 20 54 20 45 20 53 20 A N D T E S
82c0: 54 20 50 20 41 20 54 20 54 0a 3b 3b 3d 3d 3d 3d T P A T T.;;====
82d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
82f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8310: 3d 3d 0a 0a 3b 3b 20 4c 6f 6f 6b 75 70 20 61 20 ==..;; Lookup a
8320: 76 61 6c 75 65 20 69 6e 20 72 75 6e 63 6f 6e 66 value in runconf
8330: 69 67 73 20 62 61 73 65 64 20 6f 6e 20 2d 72 65 igs based on -re
8340: 71 74 61 72 67 20 6f 72 20 2d 74 61 72 67 65 74 qtarg or -target
8350: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 63 6f 6e .(define (runcon
8360: 66 69 67 73 2d 67 65 74 20 63 6f 6e 66 69 67 20 figs-get config
8370: 76 61 72 29 0a 20 20 28 6c 65 74 20 28 28 74 61 var). (let ((ta
8380: 72 67 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d rg (common:args-
8390: 67 65 74 2d 74 61 72 67 65 74 29 29 29 20 3b 3b get-target))) ;;
83a0: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
83b0: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 28 61 rg "-reqtarg")(a
83c0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
83d0: 72 67 65 74 22 29 28 67 65 74 65 6e 76 20 22 4d rget")(getenv "M
83e0: 54 5f 54 41 52 47 45 54 22 29 29 29 29 0a 20 20 T_TARGET")))).
83f0: 20 20 28 69 66 20 74 61 72 67 0a 09 28 6f 72 20 (if targ..(or
8400: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
8410: 63 6f 6e 66 69 67 20 74 61 72 67 20 76 61 72 29 config targ var)
8420: 0a 09 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c .. (configf:l
8430: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 64 65 ookup config "de
8440: 66 61 75 6c 74 22 20 76 61 72 29 29 0a 09 28 63 fault" var))..(c
8450: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
8460: 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 20 76 nfig "default" v
8470: 61 72 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ar))))..(define
8480: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
8490: 2d 73 74 61 74 65 29 0a 20 20 28 6f 72 20 28 61 -state). (or (a
84a0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 rgs:get-arg "-st
84b0: 61 74 65 22 29 28 61 72 67 73 3a 67 65 74 2d 61 ate")(args:get-a
84c0: 72 67 20 22 3a 73 74 61 74 65 22 29 29 29 0a 0a rg ":state")))..
84d0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
84e0: 61 72 67 73 2d 67 65 74 2d 73 74 61 74 75 73 29 args-get-status)
84f0: 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 . (or (args:get
8500: 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 28 -arg "-status")(
8510: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
8520: 74 61 74 75 73 22 29 29 29 0a 0a 28 64 65 66 69 tatus")))..(defi
8530: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d ne (common:args-
8540: 67 65 74 2d 74 65 73 74 70 61 74 74 20 72 63 6f get-testpatt rco
8550: 6e 66 29 0a 20 20 28 6c 65 74 2a 20 28 28 74 61 nf). (let* ((ta
8560: 67 65 78 70 72 20 28 61 72 67 73 3a 67 65 74 2d gexpr (args:get-
8570: 61 72 67 20 22 2d 74 61 67 65 78 70 72 22 29 29 arg "-tagexpr"))
8580: 0a 20 20 20 20 20 20 20 20 20 28 74 61 67 73 2d . (tags-
8590: 74 65 73 74 70 61 74 74 20 28 69 66 20 74 61 67 testpatt (if tag
85a0: 65 78 70 72 20 28 73 74 72 69 6e 67 2d 6a 6f 69 expr (string-joi
85b0: 6e 20 28 72 75 6e 73 3a 67 65 74 2d 74 65 73 74 n (runs:get-test
85c0: 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 67 73 20 s-matching-tags
85d0: 74 61 67 65 78 70 72 29 20 22 2c 22 29 20 23 66 tagexpr) ",") #f
85e0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 65 73 )). (tes
85f0: 74 70 61 74 74 2d 6b 65 79 20 20 28 69 66 20 28 tpatt-key (if (
8600: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 2d args:get-arg "--
8610: 6d 6f 64 65 70 61 74 74 22 29 20 28 61 72 67 73 modepatt") (args
8620: 3a 67 65 74 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 :get-arg "--mode
8630: 70 61 74 74 22 29 20 22 54 45 53 54 50 41 54 54 patt") "TESTPATT
8640: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 61 72 ")). (ar
8650: 67 73 2d 74 65 73 74 70 61 74 74 20 28 6f 72 20 gs-testpatt (or
8660: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8670: 74 65 73 74 70 61 74 74 22 29 20 28 61 72 67 73 testpatt") (args
8680: 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 74 65 :get-arg "-runte
8690: 73 74 73 22 29 20 22 25 22 29 29 0a 20 20 20 20 sts") "%")).
86a0: 20 20 20 20 20 28 72 74 65 73 74 70 61 74 74 20 (rtestpatt
86b0: 20 20 20 20 28 69 66 20 72 63 6f 6e 66 20 28 72 (if rconf (r
86c0: 75 6e 63 6f 6e 66 69 67 73 2d 67 65 74 20 72 63 unconfigs-get rc
86d0: 6f 6e 66 20 74 65 73 74 70 61 74 74 2d 6b 65 79 onf testpatt-key
86e0: 29 20 23 66 29 29 29 0a 20 20 20 20 28 63 6f 6e ) #f))). (con
86f0: 64 0a 20 20 20 20 20 28 74 61 67 73 2d 74 65 73 d. (tags-tes
8700: 74 70 61 74 74 0a 20 20 20 20 20 20 28 64 65 62 tpatt. (deb
8710: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
8720: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8730: 74 2a 20 22 2d 74 61 67 65 78 70 72 20 22 74 61 t* "-tagexpr "ta
8740: 67 65 78 70 72 22 20 73 65 6c 65 63 74 73 20 74 gexpr" selects t
8750: 65 73 74 70 61 74 74 20 22 74 61 67 73 2d 74 65 estpatt "tags-te
8760: 73 74 70 61 74 74 29 0a 20 20 20 20 20 20 74 61 stpatt). ta
8770: 67 73 2d 74 65 73 74 70 61 74 74 29 0a 20 20 20 gs-testpatt).
8780: 20 20 28 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 ((and (equal?
8790: 61 72 67 73 2d 74 65 73 74 70 61 74 74 20 22 25 args-testpatt "%
87a0: 22 29 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 ") rtestpatt).
87b0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
87c0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
87d0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
87e0: 70 61 74 74 20 64 65 66 69 6e 65 64 20 69 6e 20 patt defined in
87f0: 22 74 65 73 74 70 61 74 74 2d 6b 65 79 22 20 66 "testpatt-key" f
8800: 72 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 3a 20 rom runconfigs:
8810: 22 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 20 " rtestpatt).
8820: 20 20 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 rtestpatt).
8830: 20 20 20 28 65 6c 73 65 20 61 72 67 73 2d 74 65 (else args-te
8840: 73 74 70 61 74 74 29 29 29 29 0a 20 20 20 20 20 stpatt)))).
8850: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
8860: 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 :get-linktree).
8870: 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d 54 (or (getenv "MT
8880: 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 20 20 20 20 _LINKTREE").
8890: 20 20 28 69 66 20 2a 63 6f 6e 66 69 67 64 61 74 (if *configdat
88a0: 2a 0a 09 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f *.. (configf:lo
88b0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
88c0: 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 72 "setup" "linktr
88d0: 65 65 22 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ee"))))..(define
88e0: 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 (common:args-ge
88f0: 74 2d 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 t-runname). (le
8900: 74 20 28 28 72 65 73 20 28 6f 72 20 28 61 72 67 t ((res (or (arg
8910: 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e 6e s:get-arg "-runn
8920: 61 6d 65 22 29 0a 09 09 20 28 61 72 67 73 3a 67 ame")... (args:g
8930: 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d 65 et-arg ":runname
8940: 22 29 0a 09 09 20 28 67 65 74 65 6e 76 20 22 4d ")... (getenv "M
8950: 54 5f 52 55 4e 4e 41 4d 45 22 29 29 29 29 0a 20 T_RUNNAME")))).
8960: 20 20 20 3b 3b 20 28 69 66 20 72 65 73 20 28 73 ;; (if res (s
8970: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
8980: 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 4e ariable "MT_RUNN
8990: 41 4d 45 22 20 72 65 73 29 29 20 3b 3b 20 6e 6f AME" res)) ;; no
89a0: 74 20 73 75 72 65 20 69 66 20 74 68 69 73 20 69 t sure if this i
89b0: 73 20 61 20 67 6f 6f 64 20 69 64 65 61 2e 20 73 s a good idea. s
89c0: 69 64 65 20 65 66 66 65 63 74 20 61 6e 64 20 61 ide effect and a
89d0: 6c 6c 20 2e 2e 2e 0a 20 20 20 20 72 65 73 29 29 ll .... res))
89e0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
89f0: 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 n:args-get-targe
8a00: 74 20 23 21 6b 65 79 20 28 73 70 6c 69 74 20 23 t #!key (split #
8a10: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 f)). (let* ((ke
8a20: 79 73 20 20 20 20 28 69 66 20 28 68 61 73 68 2d ys (if (hash-
8a30: 74 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 61 table? *configda
8a40: 74 2a 29 20 28 6b 65 79 73 3a 63 6f 6e 66 69 67 t*) (keys:config
8a50: 2d 67 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f 6e -get-fields *con
8a60: 66 69 67 64 61 74 2a 29 20 27 28 29 29 29 0a 09 figdat*) '()))..
8a70: 20 28 6e 75 6d 6b 65 79 73 20 28 6c 65 6e 67 74 (numkeys (lengt
8a80: 68 20 6b 65 79 73 29 29 0a 09 20 28 74 61 72 67 h keys)).. (targ
8a90: 65 74 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 et (or (args:ge
8aa0: 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 22 t-arg "-reqtarg"
8ab0: 29 0a 09 09 20 20 20 20 20 20 28 61 72 67 73 3a )... (args:
8ac0: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
8ad0: 22 29 0a 09 09 20 20 20 20 20 20 28 67 65 74 65 ")... (gete
8ae0: 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 29 nv "MT_TARGET"))
8af0: 29 0a 09 20 28 74 6c 69 73 74 20 20 20 28 69 66 ).. (tlist (if
8b00: 20 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 2d target (string-
8b10: 73 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f 22 split target "/"
8b20: 20 23 74 29 20 27 28 29 29 29 0a 09 20 28 76 61 #t) '())).. (va
8b30: 6c 69 64 20 20 20 28 69 66 20 74 61 72 67 65 74 lid (if target
8b40: 0a 09 09 20 20 20 20 20 20 28 6f 72 20 28 6e 75 ... (or (nu
8b50: 6c 6c 3f 20 6b 65 79 73 29 20 3b 3b 20 70 72 6f ll? keys) ;; pro
8b60: 62 61 62 6c 79 20 64 6f 6e 27 74 20 6b 6e 6f 77 bably don't know
8b70: 20 6f 75 72 20 6b 65 79 73 20 79 65 74 0a 09 09 our keys yet...
8b80: 09 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e 75 . (and (not (nu
8b90: 6c 6c 3f 20 74 6c 69 73 74 29 29 0a 09 09 09 20 ll? tlist))....
8ba0: 20 20 20 20 20 20 28 65 71 3f 20 6e 75 6d 6b 65 (eq? numke
8bb0: 79 73 20 28 6c 65 6e 67 74 68 20 74 6c 69 73 74 ys (length tlist
8bc0: 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e 75 )).... (nu
8bd0: 6c 6c 3f 20 28 66 69 6c 74 65 72 20 73 74 72 69 ll? (filter stri
8be0: 6e 67 2d 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 29 ng-null? tlist))
8bf0: 29 29 0a 09 09 20 20 20 20 20 20 23 66 29 29 29 ))... #f)))
8c00: 0a 20 20 20 20 28 69 66 20 76 61 6c 69 64 0a 09 . (if valid..
8c10: 28 69 66 20 73 70 6c 69 74 0a 09 20 20 20 20 74 (if split.. t
8c20: 6c 69 73 74 0a 09 20 20 20 20 74 61 72 67 65 74 list.. target
8c30: 29 0a 09 28 69 66 20 74 61 72 67 65 74 0a 09 20 )..(if target..
8c40: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
8c50: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 (debug:print-er
8c60: 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c ror 0 *default-l
8c70: 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 76 61 6c 69 og-port* "Invali
8c80: 64 20 74 61 72 67 65 74 2c 20 73 70 61 63 65 73 d target, spaces
8c90: 20 6f 72 20 62 6c 61 6e 6b 73 20 6e 6f 74 20 61 or blanks not a
8ca0: 6c 6c 6f 77 65 64 20 5c 22 22 20 74 61 72 67 65 llowed \"" targe
8cb0: 74 20 22 5c 22 2c 20 74 61 72 67 65 74 20 73 68 t "\", target sh
8cc0: 6f 75 6c 64 20 62 65 3a 20 22 20 28 73 74 72 69 ould be: " (stri
8cd0: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 6b ng-intersperse k
8ce0: 65 79 73 20 22 2f 22 29 20 22 2c 20 68 61 76 65 eys "/") ", have
8cf0: 20 22 20 74 6c 69 73 74 20 22 20 66 6f 72 20 65 " tlist " for e
8d00: 6c 65 6d 65 6e 74 73 22 29 0a 09 20 20 20 20 20 lements")..
8d10: 20 23 66 29 0a 09 20 20 20 20 23 66 29 29 29 29 #f).. #f))))
8d20: 0a 0a 3b 3b 20 6c 6f 67 69 63 20 66 6f 72 20 67 ..;; logic for g
8d30: 65 74 74 69 6e 67 20 68 6f 6d 65 68 6f 73 74 2e etting homehost.
8d40: 20 52 65 74 75 72 6e 73 20 28 68 6f 73 74 20 2e Returns (host .
8d50: 20 61 74 2d 68 6f 6d 65 29 0a 3b 3b 20 49 46 20 at-home).;; IF
8d60: 2a 74 6f 70 70 61 74 68 2a 20 69 73 20 6e 6f 74 *toppath* is not
8d70: 20 73 65 74 2c 20 77 61 69 74 20 75 70 20 74 6f set, wait up to
8d80: 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 74 72 five seconds tr
8d90: 79 69 6e 67 20 65 76 65 72 79 20 74 77 6f 20 73 ying every two s
8da0: 65 63 6f 6e 64 73 0a 3b 3b 20 28 74 68 69 73 20 econds.;; (this
8db0: 69 73 20 74 6f 20 61 63 63 6f 6d 6f 64 61 74 65 is to accomodate
8dc0: 20 74 68 65 20 77 61 74 63 68 64 6f 67 29 0a 3b the watchdog).;
8dd0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
8de0: 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 20 23 n:get-homehost #
8df0: 21 6b 65 79 20 28 74 72 79 6e 75 6d 20 35 29 29 !key (trynum 5))
8e00: 0a 20 20 3b 3b 20 63 61 6c 6c 65 64 20 6f 66 74 . ;; called oft
8e10: 65 6e 20 65 73 70 65 63 69 61 6c 6c 79 20 61 74 en especially at
8e20: 20 73 74 61 72 74 20 75 70 2e 20 75 73 65 20 6d start up. use m
8e30: 75 74 65 78 20 74 6f 20 65 6c 69 6d 69 6e 61 74 utex to eliminat
8e40: 65 20 63 6f 6c 6c 69 73 69 6f 6e 73 0a 20 20 28 e collisions. (
8e50: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 6f 6d mutex-lock! *hom
8e60: 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 ehost-mutex*).
8e70: 28 63 6f 6e 64 0a 20 20 20 28 2a 68 6f 6d 65 2d (cond. (*home-
8e80: 68 6f 73 74 2a 0a 20 20 20 20 28 6d 75 74 65 78 host*. (mutex
8e90: 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f -unlock! *homeho
8ea0: 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 20 2a st-mutex*). *
8eb0: 68 6f 6d 65 2d 68 6f 73 74 2a 29 0a 20 20 20 28 home-host*). (
8ec0: 28 6e 6f 74 20 2a 74 6f 70 70 61 74 68 2a 29 0a (not *toppath*).
8ed0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
8ee0: 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 k! *homehost-mut
8ef0: 65 78 2a 29 0a 20 20 20 20 28 6c 61 75 6e 63 68 ex*). (launch
8f00: 3a 73 65 74 75 70 29 20 3b 3b 20 73 61 66 65 6c :setup) ;; safel
8f10: 79 20 6d 75 74 65 78 65 64 20 6e 6f 77 0a 20 20 y mutexed now.
8f20: 20 20 28 69 66 20 28 3e 20 74 72 79 6e 75 6d 20 (if (> trynum
8f30: 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 74 0)..(begin.. (t
8f40: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a hread-sleep! 2).
8f50: 09 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 . (common:get-h
8f60: 6f 6d 65 68 6f 73 74 20 74 72 79 6e 75 6d 3a 20 omehost trynum:
8f70: 28 2d 20 74 72 79 6e 75 6d 20 31 29 29 29 0a 09 (- trynum 1)))..
8f80: 23 66 29 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 #f)). (else.
8f90: 20 20 28 6c 65 74 2a 20 28 28 63 75 72 72 68 6f (let* ((currho
8fa0: 73 74 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d st (get-host-nam
8fb0: 65 29 29 0a 09 20 20 20 28 62 65 73 74 61 64 72 e)).. (bestadr
8fc0: 73 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 s (server:get-be
8fd0: 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 st-guess-address
8fe0: 20 63 75 72 72 68 6f 73 74 29 29 0a 09 20 20 20 currhost))..
8ff0: 3b 3b 20 66 69 72 73 74 20 6c 6f 6f 6b 20 69 6e ;; first look in
9000: 20 63 6f 6e 66 69 67 2c 20 74 68 65 6e 20 6c 6f config, then lo
9010: 6f 6b 20 69 6e 20 66 69 6c 65 20 2e 68 6f 6d 65 ok in file .home
9020: 68 6f 73 74 2c 20 63 72 65 61 74 65 20 69 74 20 host, create it
9030: 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 20 20 if not found..
9040: 20 28 68 6f 6d 65 68 6f 73 74 20 28 6f 72 20 28 (homehost (or (
9050: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
9060: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 76 configdat* "serv
9070: 65 72 22 20 22 68 6f 6d 65 68 6f 73 74 22 20 29 er" "homehost" )
9080: 0a 09 09 09 20 28 6c 65 74 20 28 28 68 68 66 20 .... (let ((hhf
9090: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
90a0: 22 2f 2e 68 6f 6d 65 68 6f 73 74 22 29 29 29 0a "/.homehost"))).
90b0: 09 09 09 20 20 20 28 69 66 20 28 66 69 6c 65 2d ... (if (file-
90c0: 65 78 69 73 74 73 3f 20 68 68 66 29 0a 09 09 09 exists? hhf)....
90d0: 20 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 (with-inp
90e0: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 68 68 66 ut-from-file hhf
90f0: 20 72 65 61 64 2d 6c 69 6e 65 29 0a 09 09 09 20 read-line)....
9100: 20 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d (if (file-
9110: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 write-access? *t
9120: 6f 70 70 61 74 68 2a 29 0a 09 09 09 09 20 20 20 oppath*).....
9130: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 (begin.....
9140: 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d (with-output-to-
9150: 66 69 6c 65 20 68 68 66 0a 09 09 09 09 20 20 20 file hhf.....
9160: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 (lambda ()..
9170: 09 09 09 09 20 28 70 72 69 6e 74 20 62 65 73 74 .... (print best
9180: 61 64 72 73 29 29 29 0a 09 09 09 09 20 20 20 20 adrs))).....
9190: 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 (begin.....
91a0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
91b0: 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 ! *homehost-mute
91c0: 78 2a 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 x*)..... (
91d0: 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d car (common:get-
91e0: 68 6f 6d 65 68 6f 73 74 29 29 29 29 0a 09 09 09 homehost))))....
91f0: 09 20 20 20 23 66 29 29 29 29 29 0a 09 20 20 20 . #f)))))..
9200: 28 61 74 2d 68 6f 6d 65 20 20 28 6f 72 20 28 65 (at-home (or (e
9210: 71 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 63 qual? homehost c
9220: 75 72 72 68 6f 73 74 29 0a 09 09 09 20 28 65 71 urrhost).... (eq
9230: 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 62 65 ual? homehost be
9240: 73 74 61 64 72 73 29 29 29 29 0a 20 20 20 20 20 stadrs)))).
9250: 20 28 73 65 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 (set! *home-hos
9260: 74 2a 20 28 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 t* (cons homehos
9270: 74 20 61 74 2d 68 6f 6d 65 29 29 0a 20 20 20 20 t at-home)).
9280: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
9290: 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 *homehost-mutex
92a0: 2a 29 0a 20 20 20 20 20 20 2a 68 6f 6d 65 2d 68 *). *home-h
92b0: 6f 73 74 2a 29 29 29 29 0a 0a 3b 3b 20 61 6d 20 ost*))))..;; am
92c0: 49 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 I on the homehos
92d0: 74 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 t?.;;.(define (c
92e0: 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 ommon:on-homehos
92f0: 74 3f 29 0a 20 20 28 6c 65 74 20 28 28 68 68 20 t?). (let ((hh
9300: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 (common:get-home
9310: 68 6f 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 host))). (if
9320: 68 68 0a 09 28 63 64 72 20 68 68 29 0a 09 23 66 hh..(cdr hh)..#f
9330: 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d )))..;;=========
9340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
9380: 20 4d 20 49 20 53 20 43 20 20 20 4c 20 49 20 53 M I S C L I S
9390: 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;=========
93a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
93b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
93c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
93d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
93e0: 3b 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 61 ; items in lista
93f0: 20 61 72 65 20 6d 61 74 63 68 65 64 20 76 61 6c are matched val
9400: 75 65 20 61 6e 64 20 70 6f 73 69 74 69 6f 6e 20 ue and position
9410: 69 6e 20 6c 69 73 74 62 0a 3b 3b 20 72 65 74 75 in listb.;; retu
9420: 72 6e 20 74 68 65 20 72 65 6d 61 69 6e 69 6e 67 rn the remaining
9430: 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 items in listb
9440: 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 or #f.;;.(define
9450: 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 69 73 (common:list-is
9460: 2d 73 75 62 6c 69 73 74 20 6c 69 73 74 61 20 6c -sublist lista l
9470: 69 73 74 62 29 0a 20 20 28 69 66 20 28 6e 75 6c istb). (if (nul
9480: 6c 3f 20 6c 69 73 74 61 29 0a 20 20 20 20 20 20 l? lista).
9490: 6c 69 73 74 62 20 3b 3b 20 61 6c 6c 20 69 74 65 listb ;; all ite
94a0: 6d 73 20 69 6e 20 6c 69 73 74 62 20 61 72 65 20 ms in listb are
94b0: 22 72 65 6d 61 69 6e 69 6e 67 22 0a 20 20 20 20 "remaining".
94c0: 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 (if (> (length
94d0: 20 6c 69 73 74 61 29 28 6c 65 6e 67 74 68 20 6c lista)(length l
94e0: 69 73 74 62 29 29 20 0a 09 20 20 23 66 0a 09 20 istb)) .. #f..
94f0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
9500: 61 20 28 63 61 72 20 6c 69 73 74 61 29 29 0a 09 a (car lista))..
9510: 09 20 20 20 20 20 28 74 61 6c 61 20 28 63 64 72 . (tala (cdr
9520: 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 20 lista))...
9530: 28 68 65 64 62 20 28 63 61 72 20 6c 69 73 74 62 (hedb (car listb
9540: 29 29 0a 09 09 20 20 20 20 20 28 74 61 6c 62 20 ))... (talb
9550: 28 63 64 72 20 6c 69 73 74 62 29 29 29 0a 09 20 (cdr listb)))..
9560: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 68 (if (equal? h
9570: 65 64 61 20 68 65 64 62 29 0a 09 09 28 69 66 20 eda hedb)...(if
9580: 28 6e 75 6c 6c 3f 20 74 61 6c 61 29 20 3b 3b 20 (null? tala) ;;
9590: 77 65 20 61 72 65 20 64 6f 6e 65 0a 09 09 20 20 we are done...
95a0: 20 20 74 61 6c 62 0a 09 09 20 20 20 20 28 6c 6f talb... (lo
95b0: 6f 70 20 28 63 61 72 20 74 61 6c 61 29 0a 09 09 op (car tala)...
95c0: 09 20 20 28 63 64 72 20 74 61 6c 61 29 0a 09 09 . (cdr tala)...
95d0: 09 20 20 28 63 61 72 20 74 61 6c 62 29 0a 09 09 . (car talb)...
95e0: 09 20 20 0a 09 09 09 20 20 28 63 64 72 20 74 61 . .... (cdr ta
95f0: 6c 62 29 29 29 0a 09 09 23 66 29 29 29 29 29 0a lb)))...#f))))).
9600: 0a 3b 3b 20 4e 65 65 64 65 64 20 66 6f 72 20 6c .;; Needed for l
9610: 6f 6e 67 20 6c 69 73 74 73 20 74 6f 20 62 65 20 ong lists to be
9620: 73 6f 72 74 65 64 20 77 68 65 72 65 20 28 61 70 sorted where (ap
9630: 70 6c 79 20 6d 61 78 20 2e 2e 2e 20 29 20 64 69 ply max ... ) di
9640: 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 es.;;.(define (c
9650: 6f 6d 6d 6f 6e 3a 6d 61 78 20 69 6e 6c 73 74 29 ommon:max inlst)
9660: 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6d . (let loop ((m
9670: 61 78 2d 76 61 6c 20 28 63 61 72 20 69 6e 6c 73 ax-val (car inls
9680: 74 29 29 0a 09 20 20 20 20 20 28 68 65 64 20 20 t)).. (hed
9690: 20 20 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a (car inlst)).
96a0: 09 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 28 . (tal (
96b0: 63 64 72 20 69 6e 6c 73 74 29 29 29 0a 20 20 20 cdr inlst))).
96c0: 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f (if (not (null?
96d0: 20 74 61 6c 29 29 0a 09 28 6c 6f 6f 70 20 28 6d tal))..(loop (m
96e0: 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 0a ax hed max-val).
96f0: 09 20 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 . (car tal)
9700: 0a 09 20 20 20 20 20 20 28 63 64 72 20 74 61 6c .. (cdr tal
9710: 29 29 0a 09 28 6d 61 78 20 68 65 64 20 6d 61 78 ))..(max hed max
9720: 2d 76 61 6c 29 29 29 29 0a 0a 3b 3b 20 67 65 74 -val))))..;; get
9730: 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 75 73 65 min or max, use
9740: 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e 64 20 3c > for max and <
9750: 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 73 20 77 for min, this w
9760: 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 68 65 20 orks around the
9770: 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 6c 79 0a limits on apply.
9780: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
9790: 6f 6e 3a 6d 69 6e 2d 6d 61 78 20 63 6f 6d 70 20 on:min-max comp
97a0: 6c 73 74 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c lst). (if (null
97b0: 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 23 66 20 ? lst). #f
97c0: 3b 3b 20 62 65 74 74 65 72 20 74 68 61 6e 20 61 ;; better than a
97d0: 6e 20 65 78 63 65 70 74 69 6f 6e 20 66 6f 72 20 n exception for
97e0: 6d 79 20 6e 65 65 64 73 0a 20 20 20 20 20 20 28 my needs. (
97f0: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 20 fold (lambda (a
9800: 62 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 63 b).. (if (c
9810: 6f 6d 70 20 61 20 62 29 20 61 20 62 29 29 0a 09 omp a b) a b))..
9820: 20 20 20 20 28 63 61 72 20 6c 73 74 29 0a 09 20 (car lst)..
9830: 20 20 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 67 65 lst)))..;; ge
9840: 74 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 75 73 t min or max, us
9850: 65 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e 64 20 e > for max and
9860: 3c 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 73 20 < for min, this
9870: 77 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 68 65 works around the
9880: 20 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 6c 79 limits on apply
9890: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
98a0: 6d 6f 6e 3a 73 75 6d 20 6c 73 74 29 0a 20 20 28 mon:sum lst). (
98b0: 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 29 0a 20 if (null? lst).
98c0: 20 20 20 20 20 30 0a 20 20 20 20 20 20 28 66 6f 0. (fo
98d0: 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 ld (lambda (a b)
98e0: 0a 09 20 20 20 20 20 20 28 2b 20 61 20 62 29 29 .. (+ a b))
98f0: 0a 09 20 20 20 20 28 63 61 72 20 6c 73 74 29 0a .. (car lst).
9900: 09 20 20 20 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 . lst)))..;;
9910: 70 61 74 68 20 6c 69 73 74 20 74 6f 20 68 61 73 path list to has
9920: 68 2d 74 61 62 6c 65 20 74 72 65 65 0a 3b 3b 20 h-table tree.;;
9930: 20 20 28 28 61 20 62 20 63 29 28 61 20 62 20 64 ((a b c)(a b d
9940: 29 28 65 20 62 20 63 29 29 20 3d 3e 20 28 28 61 )(e b c)) => ((a
9950: 20 28 62 20 28 64 29 20 28 63 29 29 29 20 28 65 (b (d) (c))) (e
9960: 20 28 62 20 28 63 29 29 29 29 0a 3b 3b 0a 28 64 (b (c)))).;;.(d
9970: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 efine (common:li
9980: 73 74 2d 3e 68 74 72 65 65 20 6c 73 74 29 0a 20 st->htree lst).
9990: 20 28 6c 65 74 20 28 28 72 65 73 68 20 28 6d 61 (let ((resh (ma
99a0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
99b0: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
99c0: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 6e 6c (lambda (inl
99d0: 73 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 st). (let
99e0: 6c 6f 6f 70 20 28 28 68 74 20 20 72 65 73 68 29 loop ((ht resh)
99f0: 0a 09 09 20 20 28 68 65 64 20 28 63 61 72 20 69 ... (hed (car i
9a00: 6e 6c 73 74 29 29 0a 09 09 20 20 28 74 61 6c 20 nlst))... (tal
9a10: 28 63 64 72 20 69 6e 6c 73 74 29 29 29 0a 09 20 (cdr inlst)))..
9a20: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (if (hash-table-
9a30: 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 68 ref/default ht h
9a40: 65 64 20 23 66 29 0a 09 20 20 20 20 20 28 69 66 ed #f).. (if
9a50: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
9a60: 29 29 0a 09 09 20 28 6c 6f 6f 70 20 28 68 61 73 ))... (loop (has
9a70: 68 2d 74 61 62 6c 65 2d 72 65 66 20 68 74 20 68 h-table-ref ht h
9a80: 65 64 29 0a 09 09 20 20 20 20 20 20 20 28 63 61 ed)... (ca
9a90: 72 20 74 61 6c 29 0a 09 09 20 20 20 20 20 20 20 r tal)...
9aa0: 28 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 20 (cdr tal)))..
9ab0: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
9ac0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
9ad0: 21 20 68 74 20 68 65 64 20 28 6d 61 6b 65 2d 68 ! ht hed (make-h
9ae0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 ash-table))..
9af0: 20 20 20 20 28 6c 6f 6f 70 20 68 74 20 68 65 64 (loop ht hed
9b00: 20 74 61 6c 29 29 29 29 29 0a 20 20 20 20 20 6c tal))))). l
9b10: 73 74 29 0a 20 20 20 20 72 65 73 68 29 29 0a 0a st). resh))..
9b20: 3b 3b 20 68 61 73 68 2d 74 61 62 6c 65 20 74 72 ;; hash-table tr
9b30: 65 65 20 74 6f 20 68 74 6d 6c 20 6c 69 73 74 20 ee to html list
9b40: 74 72 65 65 0a 3b 3b 0a 3b 3b 20 20 20 74 69 70 tree.;;.;; tip
9b50: 66 75 6e 63 20 74 61 6b 65 73 20 74 77 6f 20 70 func takes two p
9b60: 61 72 61 6d 65 74 65 72 73 3a 20 79 20 74 68 65 arameters: y the
9b70: 20 74 69 70 20 76 61 6c 75 65 20 61 6e 64 20 70 tip value and p
9b80: 61 74 68 20 74 68 65 20 70 61 74 68 20 74 6f 20 ath the path to
9b90: 74 68 61 74 20 70 6f 69 6e 74 0a 3b 3b 0a 28 64 that point.;;.(d
9ba0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 efine (common:ht
9bb0: 72 65 65 2d 3e 68 74 6d 6c 20 68 74 20 70 61 74 ree->html ht pat
9bc0: 68 20 74 69 70 66 75 6e 63 29 0a 20 20 28 6c 65 h tipfunc). (le
9bd0: 74 20 28 28 64 61 74 6c 69 73 74 20 09 28 73 6f t ((datlist .(so
9be0: 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e rt (hash-table->
9bf0: 61 6c 69 73 74 20 68 74 29 0a 20 20 20 20 20 20 alist ht).
9c00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c10: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
9c20: 28 61 20 62 29 0a 20 20 20 20 20 20 20 20 20 20 (a b).
9c30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9c40: 20 20 20 20 20 20 28 73 74 72 69 6e 67 3c 20 28 (string< (
9c50: 63 61 72 20 61 29 28 63 61 72 20 62 29 29 29 29 car a)(car b))))
9c60: 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c )). (if (null
9c70: 3f 20 64 61 74 6c 69 73 74 29 0a 20 20 20 20 09 ? datlist). .
9c80: 28 74 69 70 66 75 6e 63 20 23 66 20 70 61 74 68 (tipfunc #f path
9c90: 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f 75 ) ;; really shou
9ca0: 6c 64 6e 27 74 20 67 65 74 20 68 65 72 65 0a 09 ldn't get here..
9cb0: 28 73 3a 75 6c 0a 09 20 28 6d 61 70 20 28 6c 61 (s:ul.. (map (la
9cc0: 6d 62 64 61 20 28 78 29 0a 09 09 28 6c 65 74 2a mbda (x)...(let*
9cd0: 20 28 28 6c 65 76 65 6c 6e 61 6d 65 20 28 63 61 ((levelname (ca
9ce0: 72 20 78 29 29 0a 09 09 20 20 20 20 20 20 20 28 r x))... (
9cf0: 79 20 20 20 20 20 20 20 20 20 28 63 64 72 20 78 y (cdr x
9d00: 29 29 0a 09 09 20 20 20 20 20 20 20 28 6e 65 77 ))... (new
9d10: 70 61 74 68 20 20 20 28 61 70 70 65 6e 64 20 70 path (append p
9d20: 61 74 68 20 28 6c 69 73 74 20 6c 65 76 65 6c 6e ath (list leveln
9d30: 61 6d 65 29 29 29 0a 09 09 20 20 20 20 20 20 20 ame)))...
9d40: 28 6c 65 61 66 20 20 20 20 20 20 28 6f 72 20 28 (leaf (or (
9d50: 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 3f not (hash-table?
9d60: 20 79 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 y))..... (
9d70: 6e 75 6c 6c 3f 20 28 68 61 73 68 2d 74 61 62 6c null? (hash-tabl
9d80: 65 2d 6b 65 79 73 20 79 29 29 29 29 29 0a 09 09 e-keys y)))))...
9d90: 20 20 28 69 66 20 6c 65 61 66 0a 09 09 20 20 20 (if leaf...
9da0: 20 20 20 28 73 3a 6c 69 20 28 74 69 70 66 75 6e (s:li (tipfun
9db0: 63 20 79 20 6e 65 77 70 61 74 68 29 29 0a 09 09 c y newpath))...
9dc0: 20 20 20 20 20 20 28 73 3a 6c 69 0a 09 09 20 20 (s:li...
9dd0: 20 20 20 20 20 28 6c 69 73 74 20 0a 09 09 09 6c (list ....l
9de0: 65 76 65 6c 6e 61 6d 65 0a 09 09 09 28 63 6f 6d evelname....(com
9df0: 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 mon:htree->html
9e00: 79 20 6e 65 77 70 61 74 68 20 74 69 70 66 75 6e y newpath tipfun
9e10: 63 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 64 c)))))).. d
9e20: 61 74 6c 69 73 74 29 29 29 29 29 0a 0a 3b 3b 20 atlist)))))..;;
9e30: 68 61 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 hash-table tree
9e40: 74 6f 20 61 6c 69 73 74 20 74 72 65 65 0a 3b 3b to alist tree.;;
9e50: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
9e60: 3a 68 74 72 65 65 2d 3e 61 74 72 65 65 20 68 74 :htree->atree ht
9e70: 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 ). (map (lambda
9e80: 20 28 78 29 0a 09 20 28 63 6f 6e 73 20 28 63 61 (x).. (cons (ca
9e90: 72 20 78 29 0a 09 20 20 20 20 20 20 20 28 6c 65 r x).. (le
9ea0: 74 20 28 28 79 20 28 63 64 72 20 78 29 29 29 0a t ((y (cdr x))).
9eb0: 09 09 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 .. (if (hash-tab
9ec0: 6c 65 3f 20 79 29 0a 09 09 20 20 20 20 20 28 63 le? y)... (c
9ed0: 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 61 74 72 ommon:htree->atr
9ee0: 65 65 20 79 29 0a 09 09 20 20 20 20 20 79 29 29 ee y)... y))
9ef0: 29 29 0a 20 20 20 20 20 20 20 28 68 61 73 68 2d )). (hash-
9f00: 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 74 29 table->alist ht)
9f10: 29 29 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
9f60: 4d 20 55 20 4e 20 47 20 45 20 20 20 44 20 41 20 M U N G E D A
9f70: 54 20 41 20 20 20 49 20 4e 20 54 20 4f 20 20 20 T A I N T O
9f80: 4e 20 49 20 43 20 45 20 20 20 46 20 4f 20 52 20 N I C E F O R
9f90: 4d 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d M S.;;==========
9fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
9fe0: 20 47 65 6e 65 72 61 74 65 20 61 6e 20 69 6e 64 Generate an ind
9ff0: 65 78 20 66 6f 72 20 61 20 73 70 61 72 73 65 20 ex for a sparse
a000: 6c 69 73 74 20 6f 66 20 6b 65 79 20 76 61 6c 75 list of key valu
a010: 65 73 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e 61 es.;; ( (rowna
a020: 6d 65 31 20 63 6f 6c 6e 61 6d 65 31 20 76 61 6c me1 colname1 val
a030: 31 29 28 72 6f 77 6e 61 6d 65 32 20 63 6f 6c 6e 1)(rowname2 coln
a040: 61 6d 65 32 20 76 61 6c 32 29 20 29 0a 3b 3b 0a ame2 val2) ).;;.
a050: 3b 3b 20 3d 3e 20 0a 3b 3b 0a 3b 3b 20 20 20 28 ;; => .;;.;; (
a060: 20 28 72 6f 77 6e 61 6d 65 31 20 30 29 28 72 6f (rowname1 0)(ro
a070: 77 6e 61 6d 65 32 20 31 29 29 20 20 20 20 3b 3b wname2 1)) ;;
a080: 20 72 6f 77 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d rownames -> num
a090: 0a 3b 3b 20 20 20 20 20 28 63 6f 6c 6e 61 6d 65 .;; (colname
a0a0: 31 20 30 29 28 63 6f 6c 6e 61 6d 65 32 20 31 29 1 0)(colname2 1)
a0b0: 29 20 29 20 20 3b 3b 20 63 6f 6c 6e 61 6d 65 73 ) ) ;; colnames
a0c0: 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f -> num.;; .;; o
a0d0: 70 74 69 6f 6e 61 6c 20 61 70 70 6c 79 20 70 72 ptional apply pr
a0e0: 6f 63 20 74 6f 20 72 6f 77 6e 75 6d 20 63 6f 6c oc to rownum col
a0f0: 6e 75 6d 20 76 61 6c 75 65 0a 28 64 65 66 69 6e num value.(defin
a100: 65 20 28 63 6f 6d 6d 6f 6e 3a 73 70 61 72 73 65 e (common:sparse
a110: 2d 6c 69 73 74 2d 67 65 6e 65 72 61 74 65 2d 69 -list-generate-i
a120: 6e 64 65 78 20 64 61 74 61 20 23 21 6b 65 79 20 ndex data #!key
a130: 28 70 72 6f 63 20 23 66 29 29 0a 20 20 28 69 66 (proc #f)). (if
a140: 20 28 6e 75 6c 6c 3f 20 64 61 74 61 29 0a 20 20 (null? data).
a150: 20 20 20 20 28 6c 69 73 74 20 27 28 29 20 27 28 (list '() '(
a160: 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f )). (let lo
a170: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 64 61 op ((hed (car da
a180: 74 61 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 ta))... (tal (cd
a190: 72 20 64 61 74 61 29 29 0a 09 09 20 28 72 6f 77 r data))... (row
a1a0: 6e 61 6d 65 73 20 27 28 29 29 0a 09 09 20 28 63 names '())... (c
a1b0: 6f 6c 6e 61 6d 65 73 20 27 28 29 29 0a 09 09 20 olnames '())...
a1c0: 28 72 6f 77 6e 75 6d 20 20 20 30 29 0a 09 09 20 (rownum 0)...
a1d0: 28 63 6f 6c 6e 75 6d 20 20 20 30 29 29 0a 09 28 (colnum 0))..(
a1e0: 6c 65 74 2a 20 28 28 72 6f 77 6b 65 79 20 20 20 let* ((rowkey
a1f0: 20 20 20 20 20 20 20 28 63 61 72 20 20 20 68 65 (car he
a200: 64 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6c d)).. (col
a210: 6b 65 79 20 20 20 20 20 20 20 20 20 20 28 63 61 key (ca
a220: 64 72 20 20 68 65 64 29 29 0a 09 20 20 20 20 20 dr hed))..
a230: 20 20 28 76 61 6c 75 65 20 20 20 20 20 20 20 20 (value
a240: 20 20 20 28 63 61 64 64 72 20 68 65 64 29 29 0a (caddr hed)).
a250: 09 20 20 20 20 20 20 20 28 65 78 69 73 74 69 6e . (existin
a260: 67 2d 72 6f 77 64 61 74 20 28 61 73 73 6f 63 20 g-rowdat (assoc
a270: 72 6f 77 6b 65 79 20 72 6f 77 6e 61 6d 65 73 29 rowkey rownames)
a280: 29 0a 09 20 20 20 20 20 20 20 28 65 78 69 73 74 ).. (exist
a290: 69 6e 67 2d 63 6f 6c 64 61 74 20 28 61 73 73 6f ing-coldat (asso
a2a0: 63 20 63 6f 6c 6b 65 79 20 63 6f 6c 6e 61 6d 65 c colkey colname
a2b0: 73 29 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 s)).. (cur
a2c0: 72 2d 72 6f 77 6e 75 6d 20 20 20 20 20 28 69 66 r-rownum (if
a2d0: 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 existing-rowdat
a2e0: 20 72 6f 77 6e 75 6d 20 28 2b 20 72 6f 77 6e 75 rownum (+ rownu
a2f0: 6d 20 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 m 1))).. (
a300: 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 20 20 20 20 curr-colnum
a310: 28 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c (if existing-col
a320: 64 61 74 20 63 6f 6c 6e 75 6d 20 28 2b 20 63 6f dat colnum (+ co
a330: 6c 6e 75 6d 20 31 29 29 29 0a 09 20 20 20 20 20 lnum 1)))..
a340: 20 20 28 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 (new-rownames
a350: 20 20 20 28 69 66 20 65 78 69 73 74 69 6e 67 2d (if existing-
a360: 72 6f 77 64 61 74 20 72 6f 77 6e 61 6d 65 73 20 rowdat rownames
a370: 28 63 6f 6e 73 20 28 6c 69 73 74 20 72 6f 77 6b (cons (list rowk
a380: 65 79 20 63 75 72 72 2d 72 6f 77 6e 75 6d 29 20 ey curr-rownum)
a390: 72 6f 77 6e 61 6d 65 73 29 29 29 0a 09 20 20 20 rownames)))..
a3a0: 20 20 20 20 28 6e 65 77 2d 63 6f 6c 6e 61 6d 65 (new-colname
a3b0: 73 20 20 20 20 28 69 66 20 65 78 69 73 74 69 6e s (if existin
a3c0: 67 2d 63 6f 6c 64 61 74 20 63 6f 6c 6e 61 6d 65 g-coldat colname
a3d0: 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 63 6f s (cons (list co
a3e0: 6c 6b 65 79 20 63 75 72 72 2d 63 6f 6c 6e 75 6d lkey curr-colnum
a3f0: 29 20 63 6f 6c 6e 61 6d 65 73 29 29 29 29 0a 09 ) colnames))))..
a400: 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e ;; (debug:prin
a410: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
a420: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 72 6f t-log-port* "Pro
a430: 63 65 73 73 69 6e 67 20 72 65 63 6f 72 64 3a 20 cessing record:
a440: 22 20 68 65 64 20 29 0a 09 20 20 28 69 66 20 70 " hed ).. (if p
a450: 72 6f 63 20 28 70 72 6f 63 20 63 75 72 72 2d 72 roc (proc curr-r
a460: 6f 77 6e 75 6d 20 63 75 72 72 2d 63 6f 6c 6e 75 ownum curr-colnu
a470: 6d 20 72 6f 77 6b 65 79 20 63 6f 6c 6b 65 79 20 m rowkey colkey
a480: 76 61 6c 75 65 29 29 0a 09 20 20 28 69 66 20 28 value)).. (if (
a490: 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 null? tal)..
a4a0: 20 20 28 6c 69 73 74 20 6e 65 77 2d 72 6f 77 6e (list new-rown
a4b0: 61 6d 65 73 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 ames new-colname
a4c0: 73 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 s).. (loop
a4d0: 28 63 61 72 20 74 61 6c 29 0a 09 09 20 20 20 20 (car tal)...
a4e0: 28 63 64 72 20 74 61 6c 29 0a 09 09 20 20 20 20 (cdr tal)...
a4f0: 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 0a 09 09 20 new-rownames...
a500: 20 20 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 0a new-colnames.
a510: 09 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 .. (if (> cur
a520: 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 r-rownum rownum)
a530: 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 curr-rownum row
a540: 6e 75 6d 29 0a 09 09 20 20 20 20 28 69 66 20 28 num)... (if (
a550: 3e 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f > curr-colnum co
a560: 6c 6e 75 6d 29 20 63 75 72 72 2d 63 6f 6c 6e 75 lnum) curr-colnu
a570: 6d 20 63 6f 6c 6e 75 6d 29 0a 09 09 20 20 20 20 m colnum)...
a580: 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))))))..;;======
a590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a5d0: 0a 3b 3b 20 53 20 59 20 53 20 54 20 45 20 4d 20 .;; S Y S T E M
a5e0: 20 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d S T U F F.;;==
a5f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a630: 3d 3d 3d 3d 0a 0a 3b 3b 20 6c 61 7a 79 2d 73 61 ====..;; lazy-sa
a640: 66 65 20 67 65 74 20 66 69 6c 65 20 6d 6f 64 20 fe get file mod
a650: 74 69 6d 65 2e 20 6f 6e 20 61 6e 79 20 65 72 72 time. on any err
a660: 6f 72 20 28 66 69 6c 65 20 6e 6f 74 20 65 78 69 or (file not exi
a670: 73 74 69 6e 67 20 65 74 63 2e 29 20 72 65 74 75 sting etc.) retu
a680: 72 6e 20 30 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 rn 0.;;.(define
a690: 28 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 (common:lazy-mod
a6a0: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
a6b0: 70 61 74 68 29 0a 20 20 28 68 61 6e 64 6c 65 2d path). (handle-
a6c0: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 exceptions. ex
a6d0: 6e 0a 20 20 20 30 0a 20 20 20 28 66 69 6c 65 2d n. 0. (file-
a6e0: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
a6f0: 65 20 66 70 61 74 68 29 29 29 0a 0a 3b 3b 20 66 e fpath)))..;; f
a700: 69 6e 64 20 74 69 6d 65 73 74 61 6d 70 20 6f 66 ind timestamp of
a710: 20 6e 65 77 65 73 74 20 66 69 6c 65 20 61 73 73 newest file ass
a720: 6f 63 69 61 74 65 64 20 77 69 74 68 20 61 20 73 ociated with a s
a730: 71 6c 69 74 65 20 64 62 20 66 69 6c 65 0a 28 64 qlite db file.(d
a740: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 61 efine (common:la
a750: 7a 79 2d 73 71 6c 69 74 65 2d 64 62 2d 6d 6f 64 zy-sqlite-db-mod
a760: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
a770: 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 path). (let* ((
a780: 67 6c 6f 62 2d 6c 69 73 74 20 28 68 61 6e 64 6c glob-list (handl
a790: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
a7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7b0: 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 20 exn.
a7c0: 20 20 20 20 20 20 20 20 20 27 28 22 2f 6e 6f 2f '("/no/
a7d0: 73 75 63 68 2f 66 69 6c 65 22 29 0a 20 20 20 20 such/file").
a7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a7f0: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 66 70 61 74 (glob (conc fpat
a800: 68 20 22 2a 22 29 29 29 29 0a 20 20 20 20 20 20 h "*")))).
a810: 20 20 20 28 66 69 6c 65 2d 6c 69 73 74 20 28 69 (file-list (i
a820: 66 20 28 65 71 3f 20 30 20 28 6c 65 6e 67 74 68 f (eq? 0 (length
a830: 20 67 6c 6f 62 2d 6c 69 73 74 29 29 0a 20 20 20 glob-list)).
a840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a850: 20 20 20 20 20 27 28 22 2f 6e 6f 2f 73 75 63 68 '("/no/such
a860: 2f 66 69 6c 65 22 29 0a 20 20 20 20 20 20 20 20 /file").
a870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a880: 67 6c 6f 62 2d 6c 69 73 74 29 29 29 0a 20 20 28 glob-list))). (
a890: 61 70 70 6c 79 20 6d 61 78 0a 20 20 20 28 6d 61 apply max. (ma
a8a0: 70 0a 20 20 20 20 63 6f 6d 6d 6f 6e 3a 6c 61 7a p. common:laz
a8b0: 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 y-modification-t
a8c0: 69 6d 65 20 0a 20 20 20 20 66 69 6c 65 2d 6c 69 ime . file-li
a8d0: 73 74 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 st))))..;; retur
a8e0: 6e 20 61 20 6e 69 63 65 20 63 6c 65 61 6e 20 70 n a nice clean p
a8f0: 61 74 68 6e 61 6d 65 20 6d 61 64 65 20 61 62 73 athname made abs
a900: 6f 6c 75 74 65 0a 28 64 65 66 69 6e 65 20 28 63 olute.(define (c
a910: 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 ommon:nice-path
a920: 64 69 72 29 0a 20 20 28 6c 65 74 20 28 28 6d 61 dir). (let ((ma
a930: 74 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 tch (string-matc
a940: 68 20 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c h "^(~[^\\/]*)(\
a950: 5c 2f 2e 2a 7c 29 24 22 20 64 69 72 29 29 29 0a \/.*|)$" dir))).
a960: 20 20 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b (if match ;;
a970: 20 75 73 69 6e 67 20 7e 20 66 6f 72 20 68 6f 6d using ~ for hom
a980: 65 3f 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 e?..(common:nice
a990: 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d -path (conc (com
a9a0: 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 mon:read-link-f
a9b0: 28 63 61 64 72 20 6d 61 74 63 68 29 29 20 22 2f (cadr match)) "/
a9c0: 22 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 " (caddr match))
a9d0: 29 0a 09 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 )..(normalize-pa
a9e0: 74 68 6e 61 6d 65 20 28 69 66 20 28 61 62 73 6f thname (if (abso
a9f0: 6c 75 74 65 2d 70 61 74 68 6e 61 6d 65 3f 20 64 lute-pathname? d
aa00: 69 72 29 0a 09 09 09 09 64 69 72 0a 09 09 09 09 ir).....dir.....
aa10: 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 64 (conc (current-d
aa20: 69 72 65 63 74 6f 72 79 29 20 22 2f 22 20 64 69 irectory) "/" di
aa30: 72 29 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 r))))))..;; make
aa40: 20 22 6e 69 63 65 2d 70 61 74 68 22 20 61 76 61 "nice-path" ava
aa50: 69 6c 61 62 6c 65 20 69 6e 20 63 6f 6e 66 69 67 ilable in config
aa60: 20 66 69 6c 65 73 20 61 6e 64 20 74 68 65 20 72 files and the r
aa70: 65 70 6c 0a 28 64 65 66 69 6e 65 20 6e 69 63 65 epl.(define nice
aa80: 2d 70 61 74 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 -path common:nic
aa90: 65 2d 70 61 74 68 29 0a 0a 28 64 65 66 69 6e 65 e-path)..(define
aaa0: 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 (common:read-li
aab0: 6e 6b 2d 66 20 70 61 74 68 29 0a 20 20 28 68 61 nk-f path). (ha
aac0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
aad0: 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 exn.
aae0: 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 (begin..(debug:p
aaf0: 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 rint-error 0 *de
ab00: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
ab10: 22 63 6f 6d 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f "command \"/bin/
ab20: 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 readlink -f " pa
ab30: 74 68 20 22 5c 22 20 66 61 69 6c 65 64 2e 22 29 th "\" failed.")
ab40: 0a 09 70 61 74 68 29 20 3b 3b 20 6a 75 73 74 20 ..path) ;; just
ab50: 67 69 76 65 20 75 70 0a 20 20 20 20 28 77 69 74 give up. (wit
ab60: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
ab70: 65 0a 09 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 e..(conc "/bin/r
ab80: 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 eadlink -f " pat
ab90: 68 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 h). (lambda
aba0: 20 28 29 0a 09 28 72 65 61 64 2d 6c 69 6e 65 29 ()..(read-line)
abb0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 ))))..(define (g
abc0: 65 74 2d 63 70 75 2d 6c 6f 61 64 20 23 21 6b 65 et-cpu-load #!ke
abd0: 79 20 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 y (remote-host #
abe0: 66 29 29 0a 20 20 28 63 61 72 20 28 63 6f 6d 6d f)). (car (comm
abf0: 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 on:get-cpu-load
ac00: 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 3b remote-host))).;
ac10: 3b 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 ; (let* ((load
ac20: 2d 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d -res (process:cm
ac30: 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 d-run->list "upt
ac40: 69 6d 65 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 ime")).;; . (loa
ac50: 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 6c d-rx (regexp "l
ac60: 6f 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b oad average:\\s+
ac70: 28 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 (\\d+)")).;; . (
ac80: 63 70 75 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b cpu-load #f)).;;
ac90: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
aca0: 6c 61 6d 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 lambda (l).;; ..
acb0: 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 (let ((match (st
acc0: 72 69 6e 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 ring-search load
acd0: 2d 72 78 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 -rx l))).;; ..
ace0: 28 69 66 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 (if match.;; ..
acf0: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 (let ((newv
ad00: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 al (string->numb
ad10: 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 er (cadr match))
ad20: 29 29 0a 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 )).;; ...(if (nu
ad30: 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b mber? newval).;;
ad40: 20 09 09 09 20 20 20 20 28 73 65 74 21 20 63 70 ... (set! cp
ad50: 75 2d 6c 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 u-load newval)))
ad60: 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 ))).;; . (c
ad70: 61 72 20 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b ar load-res)).;;
ad80: 20 20 20 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a cpu-load)).
ad90: 0a 3b 3b 20 67 65 74 20 63 70 75 20 6c 6f 61 64 .;; get cpu load
ada0: 20 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d by reading from
adb0: 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 /proc/loadavg,
adc0: 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 return all three
add0: 20 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 values.;;.(defi
ade0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 ne (common:get-c
adf0: 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 pu-load remote-h
ae00: 6f 73 74 29 0a 20 20 28 69 66 20 72 65 6d 6f 74 ost). (if remot
ae10: 65 2d 68 6f 73 74 0a 20 20 20 20 20 20 28 6d 61 e-host. (ma
ae20: 70 20 28 6c 61 6d 62 64 61 20 28 72 65 73 29 0a p (lambda (res).
ae30: 09 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f . (if (eof-o
ae40: 62 6a 65 63 74 3f 20 72 65 73 29 20 39 65 39 39 bject? res) 9e99
ae50: 20 72 65 73 29 29 0a 09 20 20 20 28 77 69 74 68 res)).. (with
ae60: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
ae70: 20 0a 09 20 20 20 20 28 63 6f 6e 63 20 22 73 73 .. (conc "ss
ae80: 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 h " remote-host
ae90: 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 " cat /proc/load
aea0: 61 76 67 22 29 0a 09 20 20 20 20 28 6c 61 6d 62 avg").. (lamb
aeb0: 64 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 da ()(list (read
aec0: 29 28 72 65 61 64 29 28 72 65 61 64 29 29 29 29 )(read)(read))))
aed0: 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e ). (with-in
aee0: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f put-from-file "/
aef0: 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 0a 09 proc/loadavg" ..
af00: 28 6c 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 (lambda ()(list
af10: 28 72 65 61 64 29 28 72 65 61 64 29 28 72 65 61 (read)(read)(rea
af20: 64 29 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 d))))))..;; get
af30: 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c normalized cpu l
af40: 6f 61 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 oad by reading f
af50: 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 rom /proc/loadav
af60: 67 20 61 6e 64 20 2f 70 72 6f 63 2f 63 70 75 69 g and /proc/cpui
af70: 6e 66 6f 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 nfo return all t
af80: 68 72 65 65 20 76 61 6c 75 65 73 20 61 6e 64 20 hree values and
af90: 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 the number of re
afa0: 61 6c 20 63 70 75 73 20 61 6e 64 20 74 68 65 20 al cpus and the
afb0: 6e 75 6d 62 65 72 20 6f 66 20 74 68 72 65 61 64 number of thread
afc0: 73 0a 3b 3b 20 72 65 74 75 72 6e 73 20 61 6c 69 s.;; returns ali
afd0: 73 74 20 27 28 28 61 64 6a 2d 63 70 75 2d 6c 6f st '((adj-cpu-lo
afe0: 61 64 20 2e 20 6e 6f 72 6d 61 6c 69 7a 65 64 2d ad . normalized-
aff0: 70 72 6f 63 2d 6c 6f 61 64 29 20 2e 2e 2e 20 65 proc-load) ... e
b000: 74 63 2e 0a 3b 3b 20 20 6b 65 79 73 3a 20 61 64 tc..;; keys: ad
b010: 6a 2d 70 72 6f 63 2d 6c 6f 61 64 2c 20 61 64 6a j-proc-load, adj
b020: 2d 63 6f 72 65 2d 6c 6f 61 64 2c 20 31 6d 2d 6c -core-load, 1m-l
b030: 6f 61 64 2c 20 35 6d 2d 6c 6f 61 64 2c 20 31 35 oad, 5m-load, 15
b040: 6d 2d 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e m-load.;;.(defin
b050: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f e (common:get-no
b060: 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 rmalized-cpu-loa
b070: 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 d remote-host).
b080: 20 28 6c 65 74 20 28 28 64 61 74 61 20 28 69 66 (let ((data (if
b090: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 remote-host.
b0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b0b0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
b0c0: 70 69 70 65 20 0a 20 20 20 20 20 20 20 20 20 20 pipe .
b0d0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 (conc "
b0e0: 73 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 ssh " remote-hos
b0f0: 74 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f t " cat /proc/lo
b100: 61 64 61 76 67 3b 63 61 74 20 2f 70 72 6f 63 2f adavg;cat /proc/
b110: 63 70 75 69 6e 66 6f 3b 65 63 68 6f 20 65 6e 64 cpuinfo;echo end
b120: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
b130: 20 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 read-lines
b140: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b150: 20 20 20 20 28 61 70 70 65 6e 64 20 0a 20 20 20 (append .
b160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b170: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
b180: 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 6c 6f 61 -file "/proc/loa
b190: 64 61 76 67 22 20 0a 20 20 20 20 20 20 20 20 20 davg" .
b1a0: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 61 64 read
b1b0: 2d 6c 69 6e 65 73 29 0a 20 20 20 20 20 20 20 20 -lines).
b1c0: 20 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 (with
b1d0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
b1e0: 20 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 "/proc/cpuinfo"
b1f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b200: 20 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 read-lines
b210: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b220: 20 20 20 20 20 28 6c 69 73 74 20 22 65 6e 64 22 (list "end"
b230: 29 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c 6f )))). (lo
b240: 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 ad-rx (regexp "
b250: 5e 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b ^([\\d\\.]+)\\s+
b260: 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 ([\\d\\.]+)\\s+(
b270: 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e 2a [\\d\\.]+)\\s+.*
b280: 24 22 29 29 0a 20 20 20 20 20 20 20 20 28 70 72 $")). (pr
b290: 6f 63 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 oc-rx (regexp "
b2a0: 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c ^processor\\s+:\
b2b0: 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 \s+(\\d+)\\s*$")
b2c0: 29 0a 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d ). (core-
b2d0: 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 63 6f rx (regexp "^co
b2e0: 72 65 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c re id\\s+:\\s+(\
b2f0: 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 \d+)\\s*$")).
b300: 20 20 20 20 20 28 70 68 79 73 2d 72 78 20 20 28 (phys-rx (
b310: 72 65 67 65 78 70 20 22 5e 70 68 79 73 69 63 61 regexp "^physica
b320: 6c 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c l id\\s+:\\s+(\\
b330: 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 d+)\\s*$")).
b340: 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 20 28 6c (max-num (l
b350: 61 6d 62 64 61 20 28 70 20 6e 29 28 6d 61 78 20 ambda (p n)(max
b360: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
b370: 70 29 20 6e 29 29 29 29 0a 20 20 20 20 3b 3b 20 p) n)))). ;;
b380: 28 70 72 69 6e 74 20 22 64 61 74 61 3d 22 20 64 (print "data=" d
b390: 61 74 61 29 0a 20 20 20 20 28 69 66 20 28 6e 75 ata). (if (nu
b3a0: 6c 6c 3f 20 64 61 74 61 29 20 3b 3b 20 73 6f 6d ll? data) ;; som
b3b0: 65 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e ething went wron
b3c0: 67 0a 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 g. #f.
b3d0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
b3e0: 28 68 65 64 20 20 20 20 20 20 28 63 61 72 20 64 (hed (car d
b3f0: 61 74 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 ata)).
b400: 20 20 20 20 20 20 20 20 20 28 74 61 6c 20 20 20 (tal
b410: 20 20 20 28 63 64 72 20 64 61 74 61 29 29 0a 20 (cdr data)).
b420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b430: 20 20 28 6c 6f 61 64 73 20 20 20 20 23 66 29 0a (loads #f).
b440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b450: 20 20 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 20 (proc-num 0)
b460: 20 3b 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 6e ;; processor in
b470: 63 6c 75 64 65 73 20 74 68 72 65 61 64 73 0a 20 cludes threads.
b480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b490: 20 20 28 70 68 79 73 2d 6e 75 6d 20 30 29 20 20 (phys-num 0)
b4a0: 3b 3b 20 70 68 79 73 69 63 61 6c 20 63 68 69 70 ;; physical chip
b4b0: 20 6f 6e 20 6d 6f 74 68 65 72 62 6f 61 72 64 0a on motherboard.
b4c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b4d0: 20 20 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 29 (core-num 0))
b4e0: 20 3b 3b 20 63 6f 72 65 0a 20 20 20 20 20 20 20 ;; core.
b4f0: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 ;; (print hed
b500: 20 22 2c 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 ", " loads ", "
b510: 20 70 72 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 proc-num ", " p
b520: 68 79 73 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 hys-num ", " cor
b530: 65 2d 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 20 e-num).
b540: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
b550: 20 3b 3b 20 68 61 76 65 20 61 6c 6c 20 6f 75 72 ;; have all our
b560: 20 64 61 74 61 2c 20 63 61 6c 63 75 6c 61 74 65 data, calculate
b570: 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 normalized load
b580: 20 61 6e 64 20 72 65 74 75 72 6e 20 72 65 73 75 and return resu
b590: 6c 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 lt.
b5a0: 20 28 6c 65 74 2a 20 28 28 61 63 74 2d 70 72 6f (let* ((act-pro
b5b0: 63 20 28 2b 20 70 72 6f 63 2d 6e 75 6d 20 31 29 c (+ proc-num 1)
b5c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b5d0: 20 20 20 20 20 20 20 28 61 63 74 2d 70 68 79 73 (act-phys
b5e0: 20 28 2b 20 70 68 79 73 2d 6e 75 6d 20 31 29 29 (+ phys-num 1))
b5f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b600: 20 20 20 20 20 20 28 61 63 74 2d 63 6f 72 65 20 (act-core
b610: 28 2b 20 63 6f 72 65 2d 6e 75 6d 20 31 29 29 0a (+ core-num 1)).
b620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b630: 20 20 20 20 20 28 61 64 6a 2d 70 72 6f 63 2d 6c (adj-proc-l
b640: 6f 61 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 oad (/ (car load
b650: 73 29 20 61 63 74 2d 70 72 6f 63 29 29 0a 20 20 s) act-proc)).
b660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b670: 20 20 20 28 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 (adj-core-loa
b680: 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 d (/ (car loads)
b690: 20 61 63 74 2d 63 6f 72 65 29 29 29 0a 20 20 20 act-core))).
b6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 (ap
b6b0: 70 65 6e 64 20 28 6c 69 73 74 20 28 63 6f 6e 73 pend (list (cons
b6c0: 20 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 'adj-proc-load
b6d0: 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a 20 adj-proc-load).
b6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b6f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
b700: 6e 73 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 ns 'adj-core-loa
b710: 64 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 29 d adj-core-load)
b720: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b730: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 (list
b740: 28 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 28 (cons '1m-load (
b750: 63 61 72 20 6c 6f 61 64 73 29 29 0a 20 20 20 20 car loads)).
b760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b770: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
b780: 27 35 6d 2d 6c 6f 61 64 20 28 63 61 64 72 20 6c '5m-load (cadr l
b790: 6f 61 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 oads)).
b7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b7b0: 20 20 20 20 20 28 63 6f 6e 73 20 27 31 35 6d 2d (cons '15m-
b7c0: 6c 6f 61 64 20 28 63 61 64 64 72 20 6c 6f 61 64 load (caddr load
b7d0: 73 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 s))).
b7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
b7f0: 73 74 20 28 63 6f 6e 73 20 27 70 72 6f 63 20 61 st (cons 'proc a
b800: 63 74 2d 70 72 6f 63 29 0a 20 20 20 20 20 20 20 ct-proc).
b810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b820: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 63 6f (cons 'co
b830: 72 65 20 61 63 74 2d 63 6f 72 65 29 0a 20 20 20 re act-core).
b840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b850: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
b860: 20 27 70 68 79 73 20 61 63 74 2d 70 68 79 73 29 'phys act-phys)
b870: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
b880: 20 20 28 72 65 67 65 78 2d 63 61 73 65 0a 20 20 (regex-case.
b890: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 65 64 hed
b8a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b8b0: 28 6c 6f 61 64 2d 72 78 20 20 28 20 78 20 6c 31 (load-rx ( x l1
b8c0: 20 6c 35 20 6c 31 35 20 29 20 28 6c 6f 6f 70 20 l5 l15 ) (loop
b8d0: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
b8e0: 6c 29 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e l)(map string->n
b8f0: 75 6d 62 65 72 20 28 6c 69 73 74 20 6c 31 20 6c umber (list l1 l
b900: 35 20 6c 31 35 29 29 20 70 72 6f 63 2d 6e 75 6d 5 l15)) proc-num
b910: 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e phys-num core-n
b920: 75 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 um)).
b930: 20 20 20 20 28 70 72 6f 63 2d 72 78 20 20 28 20 (proc-rx (
b940: 78 20 70 20 20 20 20 20 20 20 20 20 29 20 28 6c x p ) (l
b950: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
b960: 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 r tal) loads
b970: 20 20 20 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 (max-num
b980: 70 20 70 72 6f 63 2d 6e 75 6d 29 20 70 68 79 73 p proc-num) phys
b990: 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 0a -num core-num)).
b9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b9b0: 70 68 79 73 2d 72 78 20 20 28 20 78 20 70 20 20 phys-rx ( x p
b9c0: 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 ) (loop (
b9d0: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
b9e0: 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 ) loads
b9f0: 20 20 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d proc-num (max-
ba00: 6e 75 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 20 num p phys-num)
ba10: 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 core-num)).
ba20: 20 20 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d (core-
ba30: 72 78 20 20 28 20 78 20 63 20 20 20 20 20 20 20 rx ( x c
ba40: 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 ) (loop (car t
ba50: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 al)(cdr tal) loa
ba60: 64 73 20 20 20 20 20 20 20 20 20 20 20 70 72 6f ds pro
ba70: 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 28 c-num phys-num (
ba80: 6d 61 78 2d 6e 75 6d 20 63 20 63 6f 72 65 2d 6e max-num c core-n
ba90: 75 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 um))).
baa0: 20 20 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 (else .
bab0: 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 (beg
bac0: 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 in.
bad0: 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
bae0: 4e 4f 20 4d 41 54 43 48 3a 20 22 20 68 65 64 29 NO MATCH: " hed)
baf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bb00: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
bb10: 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 l)(cdr tal) load
bb20: 73 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d s proc-num phys-
bb30: 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 29 29 num core-num))))
bb40: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
bb50: 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 common:unix-ping
bb60: 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 hostname). (le
bb70: 74 20 28 28 72 65 73 20 28 73 79 73 74 65 6d 20 t ((res (system
bb80: 28 63 6f 6e 63 20 22 70 69 6e 67 20 2d 63 20 31 (conc "ping -c 1
bb90: 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 20 3e 20 " hostname " >
bba0: 2f 64 65 76 2f 6e 75 6c 6c 22 29 29 29 29 0a 20 /dev/null")))).
bbb0: 20 20 20 28 65 71 3f 20 72 65 73 20 30 29 29 29 (eq? res 0)))
bbc0: 0a 0a 3b 3b 20 69 64 65 61 6c 6c 79 20 70 75 74 ..;; ideally put
bbd0: 20 61 6c 6c 20 74 68 69 73 20 69 6e 66 6f 20 69 all this info i
bbe0: 6e 74 6f 20 74 68 65 20 64 62 2c 20 6e 6f 20 6e nto the db, no n
bbf0: 65 65 64 20 74 6f 20 70 72 65 73 65 72 76 65 20 eed to preserve
bc00: 69 74 20 61 63 72 6f 73 73 20 6d 6f 76 69 6e 67 it across moving
bc10: 20 68 6f 6d 65 68 6f 73 74 0a 3b 3b 0a 3b 3b 20 homehost.;;.;;
bc20: 72 65 74 75 72 6e 20 6c 69 73 74 20 6f 66 0a 3b return list of.;
bc30: 3b 20 20 28 20 72 65 61 63 68 61 62 6c 65 3f 20 ; ( reachable?
bc40: 63 70 75 6c 6f 61 64 20 75 70 64 61 74 65 2d 74 cpuload update-t
bc50: 69 6d 65 20 29 0a 28 64 65 66 69 6e 65 20 28 63 ime ).(define (c
bc60: 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 73 74 2d 69 ommon:get-host-i
bc70: 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 nfo hostname).
bc80: 28 6c 65 74 2a 20 28 28 6c 6f 61 64 69 6e 66 6f (let* ((loadinfo
bc90: 20 28 72 6d 74 3a 67 65 74 2d 6c 61 74 65 73 74 (rmt:get-latest
bca0: 2d 68 6f 73 74 2d 6c 6f 61 64 20 68 6f 73 74 6e -host-load hostn
bcb0: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 ame)). (
bcc0: 6c 6f 61 64 20 28 63 61 72 20 6c 6f 61 64 69 6e load (car loadin
bcd0: 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c fo)). (l
bce0: 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 20 oad-sample-time
bcf0: 28 63 64 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a (cdr loadinfo)).
bd00: 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 (load-s
bd10: 61 6d 70 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 ample-age (- (cu
bd20: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c rrent-seconds) l
bd30: 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 29 oad-sample-time)
bd40: 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 ). (load
bd50: 69 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 info-timeout-sec
bd60: 6f 6e 64 73 20 32 30 29 0a 20 20 20 20 20 20 20 onds 20).
bd70: 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 (host-last-upd
bd80: 61 74 65 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f ate-timeout-seco
bd90: 6e 64 73 20 31 30 29 0a 20 20 20 20 20 20 20 20 nds 10).
bda0: 20 28 68 6f 73 74 2d 72 65 63 20 28 68 61 73 68 (host-rec (hash
bdb0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
bdc0: 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 lt *host-loads*
bdd0: 68 6f 73 74 6e 61 6d 65 20 23 66 29 29 0a 20 20 hostname #f)).
bde0: 20 20 20 20 20 20 20 29 0a 20 20 20 20 28 63 6f ). (co
bdf0: 6e 64 0a 20 20 20 20 20 28 28 3c 20 6c 6f 61 64 nd. ((< load
be00: 2d 73 61 6d 70 6c 65 2d 61 67 65 20 6c 6f 61 64 -sample-age load
be10: 69 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 info-timeout-sec
be20: 6f 6e 64 73 29 0a 20 20 20 20 20 20 28 6c 69 73 onds). (lis
be30: 74 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 t #t.
be40: 20 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d load-sample-tim
be50: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f e. lo
be60: 61 64 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 ad)). ((and
be70: 68 6f 73 74 2d 72 65 63 0a 20 20 20 20 20 20 20 host-rec.
be80: 20 20 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d (< (current-
be90: 73 65 63 6f 6e 64 73 29 20 28 2b 20 28 68 6f 73 seconds) (+ (hos
bea0: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 68 6f t-last-update ho
beb0: 73 74 2d 72 65 63 29 20 68 6f 73 74 2d 6c 61 73 st-rec) host-las
bec0: 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 t-update-timeout
bed0: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 -seconds))).
bee0: 20 20 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 (list #t.
bef0: 20 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 (host-las
bf00: 74 2d 75 70 64 61 74 65 20 68 6f 73 74 2d 72 65 t-update host-re
bf10: 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 c). (
bf20: 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 host-last-cpuloa
bf30: 64 20 68 6f 73 74 2d 72 65 63 20 29 29 29 0a 20 d host-rec ))).
bf40: 20 20 20 20 28 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 ((common:uni
bf50: 78 2d 70 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 x-ping hostname)
bf60: 0a 20 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a . (list #t.
bf70: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 (cur
bf80: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 rent-seconds).
bf90: 20 20 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 (alist
bfa0: 2d 72 65 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c -ref 'adj-core-l
bfb0: 6f 61 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d oad (common:get-
bfc0: 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c normalized-cpu-l
bfd0: 6f 61 64 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 oad hostname))))
bfe0: 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 . (else.
bff0: 20 20 28 6c 69 73 74 20 23 66 20 30 20 2d 31 29 (list #f 0 -1)
c000: 29 29 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e )))). .(defin
c010: 65 20 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 e (common:update
c020: 2d 68 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c -host-loads-tabl
c030: 65 20 68 6f 73 74 73 2d 72 61 77 29 0a 20 20 28 e hosts-raw). (
c040: 6c 65 74 2a 20 28 28 68 6f 73 74 73 20 28 66 69 let* ((hosts (fi
c050: 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 lter (lambda (x)
c060: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c070: 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 (stri
c080: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
c090: 20 22 5e 5c 5c 53 2b 24 22 29 20 78 29 29 0a 20 "^\\S+$") x)).
c0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c0b0: 20 20 20 20 20 20 20 68 6f 73 74 73 2d 72 61 77 hosts-raw
c0c0: 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
c0d0: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
c0e0: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 hostname).
c0f0: 20 28 6c 65 74 2a 20 28 28 72 65 63 20 20 20 20 (let* ((rec
c100: 20 20 20 28 6c 65 74 20 28 28 68 20 28 68 61 73 (let ((h (has
c110: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
c120: 75 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a ult *host-loads*
c130: 20 68 6f 73 74 6e 61 6d 65 20 23 66 29 29 29 0a hostname #f))).
c140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c150: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 68 0a (if h.
c160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 0a h.
c180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c190: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
c1a0: 65 74 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 et ((h (make-hos
c1b0: 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 t))).
c1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c1d0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
c1e0: 2d 73 65 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 -set! *host-load
c1f0: 73 2a 20 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 s* hostname h).
c200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 h
c220: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
c230: 20 20 20 28 68 6f 73 74 2d 69 6e 66 6f 20 20 20 (host-info
c240: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (common:ge
c250: 74 2d 68 6f 73 74 2d 69 6e 66 6f 20 68 6f 73 74 t-host-info host
c260: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
c270: 20 20 20 20 20 28 69 73 2d 72 65 61 63 68 61 62 (is-reachab
c280: 6c 65 20 20 20 20 20 20 28 63 61 72 20 68 6f 73 le (car hos
c290: 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 t-info)).
c2a0: 20 20 20 20 20 20 20 28 6c 61 73 74 2d 72 65 61 (last-rea
c2b0: 63 68 65 64 2d 74 69 6d 65 20 28 63 61 64 72 20 ched-time (cadr
c2c0: 68 6f 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 host-info)).
c2d0: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 (load
c2e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
c2f0: 64 64 72 20 68 6f 73 74 2d 69 6e 66 6f 29 29 29 ddr host-info)))
c300: 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d . (host-
c310: 72 65 61 63 68 61 62 6c 65 2d 73 65 74 21 20 20 reachable-set!
c320: 20 20 72 65 63 20 69 73 2d 72 65 61 63 68 61 62 rec is-reachab
c330: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f le). (ho
c340: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 st-last-update-s
c350: 65 74 21 20 20 72 65 63 20 6c 61 73 74 2d 72 65 et! rec last-re
c360: 61 63 68 65 64 2d 74 69 6d 65 29 0a 20 20 20 20 ached-time).
c370: 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d (host-last-
c380: 63 70 75 6c 6f 61 64 2d 73 65 74 21 20 72 65 63 cpuload-set! rec
c390: 20 6c 6f 61 64 29 29 29 0a 20 20 20 20 20 68 6f load))). ho
c3a0: 73 74 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 sts)))..(define
c3b0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 (common:get-leas
c3c0: 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 20 68 6f t-loaded-host ho
c3d0: 73 74 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a sts-raw). (let*
c3e0: 20 28 28 68 6f 73 74 73 20 28 66 69 6c 74 65 72 ((hosts (filter
c3f0: 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 (lambda (x).
c400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c410: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d (string-m
c420: 61 74 63 68 20 28 72 65 67 65 78 70 20 22 5e 5c atch (regexp "^\
c430: 5c 53 2b 24 22 29 20 78 29 29 0a 20 20 20 20 20 \S+$") x)).
c440: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c450: 20 20 20 68 6f 73 74 73 2d 72 61 77 29 29 0a 20 hosts-raw)).
c460: 20 20 20 20 20 20 20 20 28 62 65 73 74 2d 68 6f (best-ho
c470: 73 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 st #f).
c480: 28 62 65 73 74 2d 6c 6f 61 64 20 39 39 39 39 39 (best-load 99999
c490: 29 0a 20 20 20 20 20 20 20 20 20 28 63 75 72 72 ). (curr
c4a0: 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 -time (current-s
c4b0: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 63 econds))). (c
c4c0: 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 ommon:update-hos
c4d0: 74 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f t-loads-table ho
c4e0: 73 74 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 sts). (for-ea
c4f0: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
c500: 28 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 (hostname).
c510: 20 20 28 6c 65 74 2a 20 28 28 72 65 63 0a 20 20 (let* ((rec.
c520: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
c530: 74 20 28 28 68 20 28 68 61 73 68 2d 74 61 62 6c t ((h (hash-tabl
c540: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 e-ref/default *h
c550: 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e ost-loads* hostn
c560: 61 6d 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 ame #f))).
c570: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 68 (if h
c580: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c590: 20 20 20 20 20 20 68 0a 20 20 20 20 20 20 20 20 h.
c5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
c5b0: 74 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 t ((h (make-host
c5c0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
c5d0: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
c5e0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 -table-set! *hos
c5f0: 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d t-loads* hostnam
c600: 65 20 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 e h).
c610: 20 20 20 20 20 20 20 20 20 20 20 20 68 29 29 29 h)))
c620: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c630: 28 72 65 61 63 68 61 62 6c 65 20 28 68 6f 73 74 (reachable (host
c640: 2d 72 65 61 63 68 61 62 6c 65 20 72 65 63 29 29 -reachable rec))
c650: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
c660: 6c 6f 61 64 20 20 20 20 20 20 28 68 6f 73 74 2d load (host-
c670: 6c 61 73 74 2d 63 70 75 6c 6f 61 64 20 20 20 72 last-cpuload r
c680: 65 63 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 ec))). (
c690: 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 28 cond. (
c6a0: 28 6e 6f 74 20 72 65 61 63 68 61 62 6c 65 29 20 (not reachable)
c6b0: 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 #f). ((
c6c0: 3c 20 28 2b 20 6c 6f 61 64 20 28 2f 20 28 72 61 < (+ load (/ (ra
c6d0: 6e 64 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 ndom 250) 1000))
c6e0: 20 20 20 20 20 20 20 20 20 3b 3b 20 61 64 64 20 ;; add
c6f0: 61 20 72 61 6e 64 6f 6d 20 66 61 63 74 6f 72 20 a random factor
c700: 74 6f 20 6b 65 65 70 20 66 72 6f 6d 20 67 65 74 to keep from get
c710: 74 69 6e 67 20 69 6e 20 61 20 72 75 74 0a 20 20 ting in a rut.
c720: 20 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 62 (+ b
c730: 65 73 74 2d 6c 6f 61 64 20 28 2f 20 28 72 61 6e est-load (/ (ran
c740: 64 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 dom 250) 1000))
c750: 20 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 ). (s
c760: 65 74 21 20 62 65 73 74 2d 6c 6f 61 64 20 6c 6f et! best-load lo
c770: 61 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 ad). (
c780: 73 65 74 21 20 62 65 73 74 2d 68 6f 73 74 20 68 set! best-host h
c790: 6f 73 74 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 ostname))))).
c7a0: 20 20 68 6f 73 74 73 29 0a 20 20 20 20 62 65 73 hosts). bes
c7b0: 74 2d 68 6f 73 74 29 29 0a 0a 0a 0a 0a 28 64 65 t-host)).....(de
c7c0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 fine (common:wai
c7d0: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
c7e0: 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 xload numcpus wa
c7f0: 69 74 64 65 6c 61 79 20 23 21 6b 65 79 20 28 63 itdelay #!key (c
c800: 6f 75 6e 74 20 31 30 30 30 29 20 28 6d 73 67 20 ount 1000) (msg
c810: 23 66 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 #f)(remote-host
c820: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c #f)). (let* ((l
c830: 6f 61 64 61 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 oadavg (common:g
c840: 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f et-cpu-load remo
c850: 74 65 2d 68 6f 73 74 29 29 0a 09 20 28 66 69 72 te-host)).. (fir
c860: 73 74 20 20 20 28 63 61 72 20 6c 6f 61 64 61 76 st (car loadav
c870: 67 29 29 0a 09 20 28 6e 65 78 74 20 20 20 20 28 g)).. (next (
c880: 63 61 64 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 cadr loadavg))..
c890: 20 28 61 64 6a 6c 6f 61 64 20 28 2a 20 6d 61 78 (adjload (* max
c8a0: 6c 6f 61 64 20 6e 75 6d 63 70 75 73 29 29 0a 09 load numcpus))..
c8b0: 20 28 6c 6f 61 64 6a 6d 70 20 28 2d 20 66 69 72 (loadjmp (- fir
c8c0: 73 74 20 6e 65 78 74 29 29 29 0a 20 20 20 20 28 st next))). (
c8d0: 63 6f 6e 64 0a 20 20 20 20 20 28 28 61 6e 64 20 cond. ((and
c8e0: 28 3e 20 66 69 72 73 74 20 61 64 6a 6c 6f 61 64 (> first adjload
c8f0: 29 0a 09 20 20 20 28 3e 20 63 6f 75 6e 74 20 30 ).. (> count 0
c900: 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a )). (debug:
c910: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
c920: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
c930: 22 77 61 69 74 69 6e 67 20 22 20 77 61 69 74 64 "waiting " waitd
c940: 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 20 64 elay " seconds d
c950: 75 65 20 74 6f 20 6c 6f 61 64 20 22 20 66 69 72 ue to load " fir
c960: 73 74 20 22 20 65 78 63 65 65 64 69 6e 67 20 6d st " exceeding m
c970: 61 78 20 6f 66 20 22 20 61 64 6a 6c 6f 61 64 20 ax of " adjload
c980: 28 69 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 (if msg msg ""))
c990: 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 . (thread-s
c9a0: 6c 65 65 70 21 20 77 61 69 74 64 65 6c 61 79 29 leep! waitdelay)
c9b0: 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 . (common:w
c9c0: 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 ait-for-cpuload
c9d0: 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 maxload numcpus
c9e0: 77 61 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 3a waitdelay count:
c9f0: 20 28 2d 20 63 6f 75 6e 74 20 31 29 29 29 0a 20 (- count 1))).
ca00: 20 20 20 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 ((and (> loa
ca10: 64 6a 6d 70 20 6e 75 6d 63 70 75 73 29 0a 09 20 djmp numcpus)..
ca20: 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 (> count 0)).
ca30: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
ca40: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
ca50: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 t-log-port* "wai
ca60: 74 69 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 ting " waitdelay
ca70: 20 22 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 " seconds due t
ca80: 6f 20 6c 6f 61 64 20 6a 75 6d 70 20 22 20 6c 6f o load jump " lo
ca90: 61 64 6a 6d 70 20 22 20 3e 20 6e 75 6d 63 70 75 adjmp " > numcpu
caa0: 73 20 22 20 6e 75 6d 63 70 75 73 20 28 69 66 20 s " numcpus (if
cab0: 6d 73 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 msg msg "")).
cac0: 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 (thread-sleep
cad0: 21 20 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 ! waitdelay).
cae0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d (common:wait-
caf0: 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c for-cpuload maxl
cb00: 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 oad numcpus wait
cb10: 64 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 delay count: (-
cb20: 63 6f 75 6e 74 20 31 29 29 29 29 29 29 0a 0a 28 count 1))))))..(
cb30: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
cb40: 65 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f et-num-cpus remo
cb50: 74 65 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 20 te-host). (let
cb60: 28 28 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 ((proc (lambda (
cb70: 29 0a 09 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 )...(let loop ((
cb80: 6e 75 6d 63 70 75 20 30 29 0a 09 09 09 20 20 20 numcpu 0)....
cb90: 28 69 6e 6c 20 20 20 20 28 72 65 61 64 2d 6c 69 (inl (read-li
cba0: 6e 65 29 29 29 0a 09 09 20 20 28 69 66 20 28 65 ne)))... (if (e
cbb0: 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a of-object? inl).
cbc0: 09 09 20 20 20 20 20 20 6e 75 6d 63 70 75 0a 09 .. numcpu..
cbd0: 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 69 66 . (loop (if
cbe0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 (string-match "
cbf0: 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c ^processor\\s+:\
cc00: 5c 73 2b 5c 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 \s+\\d+$" inl)..
cc10: 09 09 09 28 2b 20 6e 75 6d 63 70 75 20 31 29 0a ...(+ numcpu 1).
cc20: 09 09 09 09 6e 75 6d 63 70 75 29 0a 09 09 09 20 ....numcpu)....
cc30: 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 (read-line)))
cc40: 29 29 29 29 0a 20 20 20 20 28 69 66 20 72 65 6d )))). (if rem
cc50: 6f 74 65 2d 68 6f 73 74 0a 09 28 77 69 74 68 2d ote-host..(with-
cc60: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
cc70: 0a 09 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 .. (conc "ssh "
cc80: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 remote-host " ca
cc90: 74 20 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 t /proc/cpuinfo"
cca0: 29 0a 09 20 70 72 6f 63 29 0a 09 28 77 69 74 68 ).. proc)..(with
ccb0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
ccc0: 20 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 "/proc/cpuinfo"
ccd0: 20 70 72 6f 63 29 29 29 29 0a 0a 3b 3b 20 77 61 proc))))..;; wa
cce0: 69 74 20 66 6f 72 20 6e 6f 72 6d 61 6c 69 7a 65 it for normalize
ccf0: 64 20 63 70 75 20 6c 6f 61 64 20 74 6f 20 64 72 d cpu load to dr
cd00: 6f 70 20 62 65 6c 6f 77 20 6d 61 78 6c 6f 61 64 op below maxload
cd10: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
cd20: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 mon:wait-for-nor
cd30: 6d 61 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 malized-load max
cd40: 6c 6f 61 64 20 23 21 6b 65 79 20 28 6d 73 67 20 load #!key (msg
cd50: 23 66 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 #f)(remote-host
cd60: 23 66 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 #f)). (let ((nu
cd70: 6d 2d 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 m-cpus (common:g
cd80: 65 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f et-num-cpus remo
cd90: 74 65 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 28 te-host))). (
cda0: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
cdb0: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
cdc0: 6e 75 6d 2d 63 70 75 73 20 31 35 20 6d 73 67 3a num-cpus 15 msg:
cdd0: 20 6d 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 msg)))..(define
cde0: 20 28 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 61 (get-uname . pa
cdf0: 72 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 rams). (let* ((
ce00: 75 6e 61 6d 65 2d 72 65 73 20 28 70 72 6f 63 65 uname-res (proce
ce10: 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 ss:cmd-run->list
ce20: 20 28 63 6f 6e 63 20 22 75 6e 61 6d 65 20 22 20 (conc "uname "
ce30: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
ce40: 73 29 20 22 2d 61 22 20 28 63 61 72 20 70 61 72 s) "-a" (car par
ce50: 61 6d 73 29 29 29 29 29 0a 09 20 28 75 6e 61 6d ams))))).. (unam
ce60: 65 20 23 66 29 29 0a 20 20 20 20 28 69 66 20 28 e #f)). (if (
ce70: 6e 75 6c 6c 3f 20 28 63 61 72 20 75 6e 61 6d 65 null? (car uname
ce80: 2d 72 65 73 29 29 0a 09 22 75 6e 6b 6e 6f 77 6e -res)).."unknown
ce90: 22 0a 09 28 63 61 61 72 20 75 6e 61 6d 65 2d 72 "..(caar uname-r
cea0: 65 73 29 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 72 es))))..;; for r
ceb0: 65 61 73 6f 6e 73 20 49 20 64 6f 6e 27 74 20 75 easons I don't u
cec0: 6e 64 65 72 73 74 61 6e 64 20 6d 75 6c 74 69 70 nderstand multip
ced0: 6c 65 20 63 61 6c 6c 73 20 74 6f 20 72 65 61 6c le calls to real
cee0: 2d 70 61 74 68 20 69 6e 20 70 61 72 61 6c 6c 65 -path in paralle
cef0: 6c 20 74 68 72 65 61 64 73 0a 3b 3b 20 6d 75 73 l threads.;; mus
cf00: 74 20 62 65 20 70 72 6f 74 65 63 74 65 64 20 62 t be protected b
cf10: 79 20 6d 75 74 65 78 65 73 0a 3b 3b 0a 28 64 65 y mutexes.;;.(de
cf20: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 fine (common:rea
cf30: 6c 2d 70 61 74 68 20 69 6e 70 61 74 68 29 0a 20 l-path inpath).
cf40: 20 3b 3b 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 ;; (process:cmd
cf50: 2d 72 75 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 -run-with-stderr
cf60: 2d 3e 6c 69 73 74 20 22 72 65 61 64 6c 69 6e 6b ->list "readlink
cf70: 22 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 20 " "-f" inpath))
cf80: 3b 3b 20 63 6d 64 20 2e 20 70 61 72 61 6d 73 29 ;; cmd . params)
cf90: 0a 20 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 65 . ;; (let-value
cfa0: 73 20 0a 20 20 3b 3b 20 20 28 28 28 69 6e 70 20 s . ;; (((inp
cfb0: 6f 75 70 20 70 69 64 29 20 28 70 72 6f 63 65 73 oup pid) (proces
cfc0: 73 20 22 72 65 61 64 6c 69 6e 6b 22 20 28 6c 69 s "readlink" (li
cfd0: 73 74 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 st "-f" inpath))
cfe0: 29 29 0a 20 20 3b 3b 20 20 28 77 69 74 68 2d 69 )). ;; (with-i
cff0: 6e 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 nput-from-port i
d000: 6e 70 0a 20 20 3b 3b 20 20 20 20 28 6c 65 74 20 np. ;; (let
d010: 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 loop ((inl (read
d020: 2d 6c 69 6e 65 29 29 0a 20 20 3b 3b 20 20 20 20 -line)). ;;
d030: 20 20 20 09 28 72 65 73 20 23 66 29 29 0a 20 20 .(res #f)).
d040: 3b 3b 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 ;; (print "
d050: 69 6e 6c 3d 22 20 69 6e 6c 29 0a 20 20 3b 3b 20 inl=" inl). ;;
d060: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
d070: 6a 65 63 74 3f 20 69 6e 6c 29 0a 20 20 3b 3b 20 ject? inl). ;;
d080: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
d090: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
d0a0: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
d0b0: 74 20 69 6e 70 29 0a 20 20 3b 3b 20 20 20 20 20 t inp). ;;
d0c0: 20 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 (close-ou
d0d0: 74 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 tput-port oup).
d0e0: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 3b ;; ;
d0f0: 3b 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 ; (process-wait
d100: 70 69 64 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 pid). ;;
d110: 20 20 20 20 20 72 65 73 29 0a 20 20 3b 3b 20 20 res). ;;
d120: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 (loop (r
d130: 65 61 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 ead-line) inl)))
d140: 29 29 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 ))). (with-inpu
d150: 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e t-from-pipe (con
d160: 63 20 22 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 c "readlink -f "
d170: 20 69 6e 70 61 74 68 29 20 72 65 61 64 2d 6c 69 inpath) read-li
d180: 6e 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ne))..;;========
d190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d1a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d1b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d1c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
d1d0: 3b 20 44 20 49 20 53 20 4b 20 20 20 53 20 50 20 ; D I S K S P
d1e0: 41 20 43 20 45 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d A C E .;;=======
d1f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
d230: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
d240: 3a 67 65 74 2d 64 69 73 6b 2d 73 70 61 63 65 2d :get-disk-space-
d250: 75 73 65 64 20 66 70 61 74 68 29 0a 20 20 28 77 used fpath). (w
d260: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
d270: 69 70 65 20 28 63 6f 6e 63 20 22 2f 75 73 72 2f ipe (conc "/usr/
d280: 62 69 6e 2f 64 75 20 2d 73 20 22 20 66 70 61 74 bin/du -s " fpat
d290: 68 29 20 72 65 61 64 29 29 0a 0a 3b 3b 20 67 69 h) read))..;; gi
d2a0: 76 65 6e 20 70 61 74 68 20 67 65 74 20 66 72 65 ven path get fre
d2b0: 65 20 73 70 61 63 65 2c 20 61 6c 6c 6f 77 73 20 e space, allows
d2c0: 6f 76 65 72 72 69 64 65 20 69 6e 20 5b 73 65 74 override in [set
d2d0: 75 70 5d 0a 3b 3b 20 77 69 74 68 20 66 72 65 65 up].;; with free
d2e0: 2d 73 70 61 63 65 2d 73 63 72 69 70 74 20 2f 70 -space-script /p
d2f0: 61 74 68 2f 74 6f 2f 73 6f 6d 65 2f 73 63 72 69 ath/to/some/scri
d300: 70 74 2e 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 pt.sh.;;.(define
d310: 20 28 67 65 74 2d 64 66 20 70 61 74 68 29 0a 20 (get-df path).
d320: 20 28 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (if (configf:lo
d330: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
d340: 20 22 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 "setup" "free-s
d350: 70 61 63 65 2d 73 63 72 69 70 74 22 29 0a 20 20 pace-script").
d360: 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
d370: 66 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 20 from-pipe .
d380: 20 20 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 66 (conc (configf
d390: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
d3a0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 66 72 65 at* "setup" "fre
d3b0: 65 2d 73 70 61 63 65 2d 73 63 72 69 70 74 22 29 e-space-script")
d3c0: 20 22 20 22 20 70 61 74 68 29 0a 20 20 20 20 20 " " path).
d3d0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 (lambda ().. (
d3e0: 6c 65 74 20 28 28 72 65 73 20 28 72 65 61 64 2d let ((res (read-
d3f0: 6c 69 6e 65 29 29 29 0a 09 20 20 20 28 69 66 20 line))).. (if
d400: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 20 (string? res)..
d410: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e (string->n
d420: 75 6d 62 65 72 20 72 65 73 29 29 29 29 29 0a 20 umber res))))).
d430: 20 20 20 20 20 28 67 65 74 2d 75 6e 69 78 2d 64 (get-unix-d
d440: 66 20 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 f path)))..(defi
d450: 6e 65 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 ne (get-unix-df
d460: 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 path). (let* ((
d470: 64 66 2d 72 65 73 75 6c 74 73 20 28 70 72 6f 63 df-results (proc
d480: 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 ess:cmd-run->lis
d490: 74 20 28 63 6f 6e 63 20 22 64 66 20 22 20 70 61 t (conc "df " pa
d4a0: 74 68 29 29 29 0a 09 20 28 73 70 61 63 65 2d 72 th))).. (space-r
d4b0: 78 20 20 20 28 72 65 67 65 78 70 20 22 28 5b 30 x (regexp "([0
d4c0: 2d 39 5d 2b 29 5c 5c 73 2b 28 5b 30 2d 39 5d 2b -9]+)\\s+([0-9]+
d4d0: 29 25 22 29 29 0a 09 20 28 66 72 65 65 73 70 63 )%")).. (freespc
d4e0: 20 20 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 #f)). ;;
d4f0: 28 77 72 69 74 65 20 64 66 2d 72 65 73 75 6c 74 (write df-result
d500: 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s). (for-each
d510: 20 28 6c 61 6d 62 64 61 20 28 6c 29 0a 09 09 28 (lambda (l)...(
d520: 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 let ((match (str
d530: 69 6e 67 2d 73 65 61 72 63 68 20 73 70 61 63 65 ing-search space
d540: 2d 72 78 20 6c 29 29 29 0a 09 09 20 20 28 69 66 -rx l)))... (if
d550: 20 6d 61 74 63 68 20 0a 09 09 20 20 20 20 20 20 match ...
d560: 28 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 (let ((newval (s
d570: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 tring->number (c
d580: 61 64 72 20 6d 61 74 63 68 29 29 29 29 0a 09 09 adr match))))...
d590: 09 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 65 .(if (number? ne
d5a0: 77 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 wval).... (se
d5b0: 74 21 20 66 72 65 65 73 70 63 20 6e 65 77 76 61 t! freespc newva
d5c0: 6c 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 l)))))).. (
d5d0: 63 61 72 20 64 66 2d 72 65 73 75 6c 74 73 29 29 car df-results))
d5e0: 0a 20 20 20 20 66 72 65 65 73 70 63 29 29 0a 0a . freespc))..
d5f0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
d600: 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 check-space-in-d
d610: 69 72 20 64 69 72 70 61 74 68 20 72 65 71 75 69 ir dirpath requi
d620: 72 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 red). (let* ((d
d630: 62 73 70 61 63 65 20 20 28 69 66 20 28 64 69 72 bspace (if (dir
d640: 65 63 74 6f 72 79 3f 20 64 69 72 70 61 74 68 29 ectory? dirpath)
d650: 0a 09 09 20 20 20 20 20 20 20 28 67 65 74 2d 64 ... (get-d
d660: 66 20 64 69 72 70 61 74 68 29 0a 09 09 20 20 20 f dirpath)...
d670: 20 20 20 20 30 29 29 29 0a 20 20 20 20 28 6c 69 0))). (li
d680: 73 74 20 28 3e 20 64 62 73 70 61 63 65 20 72 65 st (> dbspace re
d690: 71 75 69 72 65 64 29 0a 09 20 20 64 62 73 70 61 quired).. dbspa
d6a0: 63 65 0a 09 20 20 72 65 71 75 69 72 65 64 0a 09 ce.. required..
d6b0: 20 20 64 69 72 70 61 74 68 29 29 29 0a 0a 3b 3b dirpath)))..;;
d6c0: 20 63 68 65 63 6b 20 73 70 61 63 65 20 69 6e 20 check space in
d6d0: 64 62 64 69 72 20 61 6e 64 20 69 6e 20 6d 65 67 dbdir and in meg
d6e0: 61 74 65 73 74 20 64 69 72 0a 3b 3b 20 72 65 74 atest dir.;; ret
d6f0: 75 72 6e 73 3a 20 6f 6b 2f 6e 6f 74 20 64 62 73 urns: ok/not dbs
d700: 70 61 63 65 20 72 65 71 75 69 72 65 64 2d 73 70 pace required-sp
d710: 61 63 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ace.;;.(define (
d720: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d common:check-db-
d730: 64 69 72 2d 73 70 61 63 65 29 0a 20 20 28 6c 65 dir-space). (le
d740: 74 2a 20 28 28 72 65 71 75 69 72 65 64 20 28 73 t* ((required (s
d750: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 09 tring->number ..
d760: 09 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 . (or (config
d770: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
d780: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 64 62 dat* "setup" "db
d790: 64 69 72 2d 73 70 61 63 65 2d 72 65 71 75 69 72 dir-space-requir
d7a0: 65 64 22 29 0a 09 09 09 22 31 30 30 30 30 30 22 ed")...."100000"
d7b0: 29 29 29 0a 09 20 28 64 62 64 69 72 20 20 20 20 ))).. (dbdir
d7c0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 (common:get-db-t
d7d0: 6d 70 2d 61 72 65 61 29 29 20 3b 3b 20 28 64 62 mp-area)) ;; (db
d7e0: 3a 67 65 74 2d 64 62 64 69 72 29 29 0a 09 20 28 :get-dbdir)).. (
d7f0: 74 64 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e tdbspace (common
d800: 3a 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d :check-space-in-
d810: 64 69 72 20 64 62 64 69 72 20 72 65 71 75 69 72 dir dbdir requir
d820: 65 64 29 29 0a 09 20 28 6d 64 62 73 70 61 63 65 ed)).. (mdbspace
d830: 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 (common:check-s
d840: 70 61 63 65 2d 69 6e 2d 64 69 72 20 2a 74 6f 70 pace-in-dir *top
d850: 70 61 74 68 2a 20 72 65 71 75 69 72 65 64 29 29 path* required))
d860: 29 0a 20 20 20 20 28 73 6f 72 74 20 28 6c 69 73 ). (sort (lis
d870: 74 20 74 64 62 73 70 61 63 65 20 6d 64 62 73 70 t tdbspace mdbsp
d880: 61 63 65 29 20 28 6c 61 6d 62 64 61 20 28 61 20 ace) (lambda (a
d890: 62 29 0a 09 09 09 09 20 20 20 20 20 28 3c 20 28 b)..... (< (
d8a0: 63 61 64 72 20 61 29 28 63 61 64 72 20 62 29 29 cadr a)(cadr b))
d8b0: 29 29 29 29 0a 20 20 20 20 0a 3b 3b 20 63 68 65 )))). .;; che
d8c0: 63 6b 20 61 76 61 69 6c 61 62 6c 65 20 73 70 61 ck available spa
d8d0: 63 65 20 69 6e 20 64 62 64 69 72 2c 20 65 78 69 ce in dbdir, exi
d8e0: 74 20 69 66 20 69 6e 73 75 66 66 69 63 69 65 6e t if insufficien
d8f0: 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f t.;;.(define (co
d900: 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 mmon:check-db-di
d910: 72 2d 61 6e 64 2d 65 78 69 74 2d 69 66 2d 69 6e r-and-exit-if-in
d920: 73 75 66 66 69 63 69 65 6e 74 29 0a 20 20 28 6c sufficient). (l
d930: 65 74 2a 20 28 28 73 70 61 63 65 64 61 74 20 28 et* ((spacedat (
d940: 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 car (common:chec
d950: 6b 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 29 29 k-db-dir-space))
d960: 29 20 3b 3b 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 ) ;; look only a
d970: 74 20 77 6f 72 73 74 20 66 6f 72 20 6e 6f 77 0a t worst for now.
d980: 09 20 28 69 73 2d 6f 6b 20 20 20 20 28 63 61 72 . (is-ok (car
d990: 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 spacedat)).. (d
d9a0: 62 73 70 61 63 65 20 20 28 63 61 64 72 20 73 70 bspace (cadr sp
d9b0: 61 63 65 64 61 74 29 29 0a 09 20 28 72 65 71 75 acedat)).. (requ
d9c0: 69 72 65 64 20 28 63 61 64 64 72 20 73 70 61 63 ired (caddr spac
d9d0: 65 64 61 74 29 29 0a 09 20 28 64 62 64 69 72 20 edat)).. (dbdir
d9e0: 20 20 20 28 63 61 64 64 64 72 20 73 70 61 63 65 (cadddr space
d9f0: 64 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 dat))). (if (
da00: 6e 6f 74 20 69 73 2d 6f 6b 29 0a 09 28 62 65 67 not is-ok)..(beg
da10: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
da20: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
da30: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 ult-log-port* "I
da40: 6e 73 75 66 66 69 63 69 65 6e 74 20 73 70 61 63 nsufficient spac
da50: 65 20 69 6e 20 22 20 64 62 64 69 72 20 22 2c 20 e in " dbdir ",
da60: 72 65 71 75 69 72 65 20 22 20 72 65 71 75 69 72 require " requir
da70: 65 64 20 22 2c 20 68 61 76 65 20 22 20 64 62 73 ed ", have " dbs
da80: 70 61 63 65 20 20 22 2c 20 65 78 69 74 69 6e 67 pace ", exiting
da90: 20 6e 6f 77 2e 22 29 0a 09 20 20 28 65 78 69 74 now.").. (exit
daa0: 20 31 29 29 29 29 29 0a 20 20 0a 3b 3b 20 70 61 1))))). .;; pa
dab0: 74 68 73 20 69 73 20 6c 69 73 74 20 6f 66 20 6c ths is list of l
dac0: 69 73 74 73 20 28 28 6e 61 6d 65 20 70 61 74 68 ists ((name path
dad0: 29 20 2e 2e 2e 20 29 0a 3b 3b 0a 28 64 65 66 69 ) ... ).;;.(defi
dae0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 ne (common:get-d
daf0: 69 73 6b 2d 77 69 74 68 2d 6d 6f 73 74 2d 66 72 isk-with-most-fr
db00: 65 65 2d 73 70 61 63 65 20 64 69 73 6b 73 20 6d ee-space disks m
db10: 69 6e 73 69 7a 65 29 0a 20 20 28 6c 65 74 20 28 insize). (let (
db20: 28 62 65 73 74 20 20 20 20 20 23 66 29 0a 09 28 (best #f)..(
db30: 62 65 73 74 73 69 7a 65 20 30 29 29 0a 20 20 20 bestsize 0)).
db40: 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 (for-each .
db50: 20 28 6c 61 6d 62 64 61 20 28 64 69 73 6b 2d 6e (lambda (disk-n
db60: 75 6d 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a um). (let*
db70: 20 28 28 64 69 72 70 61 74 68 20 20 20 20 28 63 ((dirpath (c
db80: 61 64 72 20 28 61 73 73 6f 63 20 64 69 73 6b 2d adr (assoc disk-
db90: 6e 75 6d 20 64 69 73 6b 73 29 29 29 0a 09 20 20 num disks)))..
dba0: 20 20 20 20 28 66 72 65 65 73 70 63 20 20 20 20 (freespc
dbb0: 28 63 6f 6e 64 0a 09 09 09 20 20 20 28 28 6e 6f (cond.... ((no
dbc0: 74 20 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 t (directory? di
dbd0: 72 70 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 rpath)).... (
dbe0: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
dbf0: 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 oise-print 300 "
dc00: 64 69 73 6b 73 20 6e 6f 74 20 61 20 64 69 72 20 disks not a dir
dc10: 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 " disk-num).....
dc20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
dc30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
dc40: 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b * "WARNING: disk
dc50: 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 " disk-num " at
dc60: 20 70 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 path \"" dirpat
dc70: 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 64 h "\" is not a d
dc80: 69 72 65 63 74 6f 72 79 20 2d 20 69 67 6e 6f 72 irectory - ignor
dc90: 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 ing it."))....
dca0: 20 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f -1).... ((no
dcb0: 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 t (file-write-ac
dcc0: 63 65 73 73 3f 20 64 69 72 70 61 74 68 29 29 0a cess? dirpath)).
dcd0: 09 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d ... (if (comm
dce0: 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 on:low-noise-pri
dcf0: 6e 74 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f nt 300 "disks no
dd00: 74 20 77 72 69 74 65 61 62 6c 65 20 22 20 64 69 t writeable " di
dd10: 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 sk-num).....(deb
dd20: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
dd30: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
dd40: 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 ARNING: disk " d
dd50: 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 isk-num " at pat
dd60: 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c h \"" dirpath "\
dd70: 22 20 69 73 20 6e 6f 74 20 77 72 69 74 65 61 62 " is not writeab
dd80: 6c 65 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 le - ignoring it
dd90: 2e 22 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a .")).... -1).
dda0: 09 09 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f ... ((not (eq?
ddb0: 20 28 73 74 72 69 6e 67 2d 72 65 66 20 64 69 72 (string-ref dir
ddc0: 70 61 74 68 20 30 29 20 23 5c 2f 29 29 0a 09 09 path 0) #\/))...
ddd0: 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
dde0: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
ddf0: 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 300 "disks not
de00: 61 20 70 72 6f 70 65 72 20 70 61 74 68 20 22 20 a proper path "
de10: 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 disk-num).....(d
de20: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
de30: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
de40: 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 "WARNING: disk "
de50: 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 disk-num " at p
de60: 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 ath \"" dirpath
de70: 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 66 75 6c "\" is not a ful
de80: 6c 79 20 71 75 61 6c 69 66 69 65 64 20 70 61 74 ly qualified pat
de90: 68 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e h - ignoring it.
dea0: 22 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 ")).... -1)..
deb0: 09 09 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 .. (else....
dec0: 20 20 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 (get-df dirpat
ded0: 68 29 29 29 29 29 0a 09 20 28 69 66 20 28 3e 20 h))))).. (if (>
dee0: 66 72 65 65 73 70 63 20 62 65 73 74 73 69 7a 65 freespc bestsize
def0: 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 ).. (begin..
df00: 20 20 20 20 20 20 20 28 73 65 74 21 20 62 65 73 (set! bes
df10: 74 20 20 20 20 20 28 63 6f 6e 73 20 64 69 73 6b t (cons disk
df20: 2d 6e 75 6d 20 64 69 72 70 61 74 68 29 29 0a 09 -num dirpath))..
df30: 20 20 20 20 20 20 20 28 73 65 74 21 20 62 65 73 (set! bes
df40: 74 73 69 7a 65 20 66 72 65 65 73 70 63 29 29 29 tsize freespc)))
df50: 29 29 0a 20 20 20 20 20 28 6d 61 70 20 63 61 72 )). (map car
df60: 20 64 69 73 6b 73 29 29 0a 20 20 20 20 28 69 66 disks)). (if
df70: 20 28 61 6e 64 20 62 65 73 74 20 28 3e 20 62 65 (and best (> be
df80: 73 74 73 69 7a 65 20 6d 69 6e 73 69 7a 65 29 29 stsize minsize))
df90: 0a 09 62 65 73 74 0a 09 23 66 29 29 29 20 3b 3b ..best..#f))) ;;
dfa0: 20 23 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 73 #f means no dis
dfb0: 6b 20 63 61 6e 64 69 64 61 74 65 20 66 6f 75 6e k candidate foun
dfc0: 64 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d d..;;===========
dfd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dfe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 ===========.;; E
e010: 20 4e 20 56 20 49 20 52 20 4f 20 4e 20 4d 20 45 N V I R O N M E
e020: 20 4e 20 54 20 20 20 56 20 41 20 52 20 53 0a 3b N T V A R S.;
e030: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
e040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e070: 3d 3d 3d 3d 3d 3d 3d 0a 09 20 20 20 20 20 20 0a =======.. .
e080: 28 64 65 66 69 6e 65 20 28 73 61 76 65 2d 65 6e (define (save-en
e090: 76 69 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c vironment-as-fil
e0a0: 65 73 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 es fname #!key (
e0b0: 69 67 6e 6f 72 65 76 61 72 73 20 28 6c 69 73 74 ignorevars (list
e0c0: 20 22 55 53 45 52 22 20 22 48 4f 4d 45 22 20 22 "USER" "HOME" "
e0d0: 44 49 53 50 4c 41 59 22 20 22 4c 53 5f 43 4f 4c DISPLAY" "LS_COL
e0e0: 4f 52 53 22 20 22 58 4b 45 59 53 59 4d 44 42 22 ORS" "XKEYSYMDB"
e0f0: 20 22 45 44 49 54 4f 52 22 20 22 4d 41 4b 45 46 "EDITOR" "MAKEF
e100: 4c 41 47 53 22 20 22 4d 41 4b 45 46 22 20 22 4d LAGS" "MAKEF" "M
e110: 41 4b 45 4f 56 45 52 52 49 44 45 53 22 29 29 29 AKEOVERRIDES")))
e120: 0a 20 20 28 6c 65 74 20 28 28 65 6e 76 76 61 72 . (let ((envvar
e130: 73 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 s (get-environme
e140: 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 nt-variables)).
e150: 20 20 20 20 20 20 20 28 77 68 69 74 65 73 70 20 (whitesp
e160: 28 72 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d (regexp "[^a-zA-
e170: 5a 30 2d 39 5f 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 24 Z0-9_\\-:,.\\/%$
e180: 5d 22 29 29 0a 09 28 6d 75 6e 67 65 76 61 6c 20 ]"))..(mungeval
e190: 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 09 09 (lambda (val)...
e1a0: 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 (cond...
e1b0: 20 28 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 ((eq? val #t) "
e1c0: 22 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 74 ") ;; convert #t
e1d0: 20 74 6f 20 65 6d 70 74 79 20 73 74 72 69 6e 67 to empty string
e1e0: 0a 09 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 ... ((eq? va
e1f0: 6c 20 23 66 29 20 23 66 29 20 3b 3b 20 63 6f 6e l #f) #f) ;; con
e200: 76 65 72 74 20 23 66 20 74 6f 20 69 74 73 65 6c vert #f to itsel
e210: 66 20 28 73 74 69 6c 6c 20 74 68 69 6e 6b 69 6e f (still thinkin
e220: 67 20 61 62 6f 75 74 20 74 68 69 73 20 6f 6e 65 g about this one
e230: 0a 09 09 20 20 20 20 20 28 65 6c 73 65 20 76 61 ... (else va
e240: 6c 29 29 29 29 29 0a 20 20 20 20 20 28 77 69 74 l))))). (wit
e250: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
e260: 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 (conc fname ".c
e270: 73 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d sh"). (lam
e280: 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 bda ().
e290: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
e2a0: 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 da (keyval)...
e2b0: 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 (let* ((key
e2c0: 20 20 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a (car keyval)).
e2d0: 09 09 09 20 20 20 20 20 28 76 61 6c 20 20 20 28 ... (val (
e2e0: 63 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 cdr keyval))....
e2f0: 20 20 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 (delim (if
e300: 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 (string-search w
e310: 68 69 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 hitesp val) ....
e320: 09 09 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 .."\""......""))
e330: 29 0a 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 )....(print (if
e340: 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 6e 6f (member key igno
e350: 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 20 22 revars)..... "
e360: 23 20 73 65 74 65 6e 76 20 22 0a 09 09 09 09 20 # setenv ".....
e370: 20 20 22 73 65 74 65 6e 76 20 22 29 0a 09 09 09 "setenv ")....
e380: 20 20 20 20 20 20 20 6b 65 79 20 22 20 22 20 64 key " " d
e390: 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c 20 76 elim (mungeval v
e3a0: 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a 09 09 20 al) delim)))...
e3b0: 20 20 20 65 6e 76 76 61 72 73 29 29 29 0a 20 20 envvars))).
e3c0: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
e3d0: 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e to-file (conc fn
e3e0: 61 6d 65 20 22 2e 73 68 22 29 0a 20 20 20 20 20 ame ".sh").
e3f0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
e400: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
e410: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c (lambda (keyval
e420: 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 )... (let*
e430: 28 28 6b 65 79 20 28 63 61 72 20 6b 65 79 76 61 ((key (car keyva
e440: 6c 29 29 0a 09 09 09 20 20 20 20 20 28 76 61 6c l)).... (val
e450: 20 28 63 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 (cdr keyval))..
e460: 09 09 20 20 20 20 20 28 64 65 6c 69 6d 20 28 69 .. (delim (i
e470: 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 f (string-search
e480: 20 77 68 69 74 65 73 70 20 76 61 6c 29 20 0a 09 whitesp val) ..
e490: 09 09 09 09 22 5c 22 22 0a 09 09 09 09 09 22 22 ...."\""......""
e4a0: 29 29 29 0a 09 09 09 28 70 72 69 6e 74 20 28 69 )))....(print (i
e4b0: 66 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 f (member key ig
e4c0: 6e 6f 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 norevars).....
e4d0: 20 22 23 20 65 78 70 6f 72 74 20 22 0a 09 09 09 "# export "....
e4e0: 09 20 20 20 22 65 78 70 6f 72 74 20 22 29 0a 09 . "export ")..
e4f0: 09 09 20 20 20 20 20 20 20 6b 65 79 20 22 3d 22 .. key "="
e500: 20 64 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c delim (mungeval
e510: 20 76 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a 20 val) delim))).
e520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e530: 20 20 20 65 6e 76 76 61 72 73 29 29 29 29 29 0a envvars))))).
e540: 0a 3b 3b 20 73 65 74 20 73 6f 6d 65 20 65 6e 76 .;; set some env
e550: 20 76 61 72 73 20 66 72 6f 6d 20 61 6e 20 61 6c vars from an al
e560: 69 73 74 2c 20 72 65 74 75 72 6e 20 61 6e 20 61 ist, return an a
e570: 6c 69 73 74 20 77 69 74 68 20 6f 72 69 67 69 6e list with origin
e580: 61 6c 20 76 61 6c 75 65 73 0a 3b 3b 20 28 28 22 al values.;; (("
e590: 56 41 52 22 20 22 76 61 6c 75 65 22 29 20 2e 2e VAR" "value") ..
e5a0: 2e 29 0a 28 64 65 66 69 6e 65 20 28 61 6c 69 73 .).(define (alis
e5b0: 74 2d 3e 65 6e 76 2d 76 61 72 73 20 6c 73 74 29 t->env-vars lst)
e5c0: 0a 20 20 28 69 66 20 28 6c 69 73 74 3f 20 6c 73 . (if (list? ls
e5d0: 74 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 t). (let ((
e5e0: 72 65 73 20 27 28 29 29 29 0a 09 28 66 6f 72 2d res '()))..(for-
e5f0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 29 each (lambda (p)
e600: 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 76 ... (let* ((v
e610: 61 72 20 28 63 61 72 20 20 70 29 29 0a 09 09 09 ar (car p))....
e620: 20 20 20 28 76 61 6c 20 28 63 61 64 72 20 70 29 (val (cadr p)
e630: 29 0a 09 09 09 20 20 20 28 70 72 76 20 28 67 65 ).... (prv (ge
e640: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
e650: 72 69 61 62 6c 65 20 76 61 72 29 29 29 0a 09 09 riable var)))...
e660: 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 20 (set! res
e670: 28 63 6f 6e 73 20 28 6c 69 73 74 20 76 61 72 20 (cons (list var
e680: 70 72 76 29 20 72 65 73 29 29 0a 09 09 20 20 20 prv) res))...
e690: 20 20 20 28 69 66 20 76 61 6c 20 0a 09 09 09 20 (if val ....
e6a0: 20 28 73 65 74 65 6e 76 20 76 61 72 20 28 2d 3e (setenv var (->
e6b0: 73 74 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 string val))....
e6c0: 20 20 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 (unsetenv var)
e6d0: 29 29 29 0a 09 09 20 20 6c 73 74 29 0a 09 72 65 )))... lst)..re
e6e0: 73 29 0a 20 20 20 20 20 20 27 28 29 29 29 0a 0a s). '()))..
e6f0: 3b 3b 20 63 6c 65 61 72 20 76 61 72 73 20 6d 61 ;; clear vars ma
e700: 74 63 68 69 6e 67 20 70 61 74 74 65 72 6e 2c 20 tching pattern,
e710: 72 75 6e 20 70 72 6f 63 2c 20 73 65 74 20 76 61 run proc, set va
e720: 72 73 20 62 61 63 6b 0a 3b 3b 20 69 66 20 70 72 rs back.;; if pr
e730: 6f 63 20 69 73 20 61 20 73 74 72 69 6e 67 20 72 oc is a string r
e740: 75 6e 20 74 68 61 74 20 73 74 72 69 6e 67 20 61 un that string a
e750: 73 20 61 20 63 6f 6d 6d 61 6e 64 20 77 69 74 68 s a command with
e760: 0a 3b 3b 20 73 79 73 74 65 6d 2e 0a 3b 3b 0a 28 .;; system..;;.(
e770: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 define (common:w
e780: 69 74 68 6f 75 74 2d 76 61 72 73 20 70 72 6f 63 ithout-vars proc
e790: 20 2e 20 76 61 72 2d 70 61 74 74 73 29 0a 20 20 . var-patts).
e7a0: 28 6c 65 74 20 28 28 76 61 72 73 20 28 6d 61 6b (let ((vars (mak
e7b0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
e7c0: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
e7d0: 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 64 (lambda (vard
e7e0: 61 74 29 20 3b 3b 20 65 61 63 68 20 65 6e 76 20 at) ;; each env
e7f0: 76 61 72 0a 20 20 20 20 20 20 20 28 66 6f 72 2d var. (for-
e800: 65 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 76 each..(lambda (v
e810: 61 72 2d 70 61 74 74 29 0a 09 20 20 28 69 66 20 ar-patt).. (if
e820: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 76 61 (string-match va
e830: 72 2d 70 61 74 74 20 28 63 61 72 20 76 61 72 64 r-patt (car vard
e840: 61 74 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 at)).. (let
e850: 20 28 28 76 61 72 20 28 63 61 72 20 76 61 72 64 ((var (car vard
e860: 61 74 29 29 0a 09 09 20 20 20 20 28 76 61 6c 20 at))... (val
e870: 28 63 64 72 20 76 61 72 64 61 74 29 29 29 0a 09 (cdr vardat)))..
e880: 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 .(hash-table-set
e890: 21 20 76 61 72 73 20 76 61 72 20 76 61 6c 29 0a ! vars var val).
e8a0: 09 09 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 ..(unsetenv var)
e8b0: 29 29 29 0a 09 76 61 72 2d 70 61 74 74 73 29 29 )))..var-patts))
e8c0: 0a 20 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 . (get-envir
e8d0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 onment-variables
e8e0: 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 )). (cond.
e8f0: 20 20 28 28 73 74 72 69 6e 67 3f 20 70 72 6f 63 ((string? proc
e900: 29 28 73 79 73 74 65 6d 20 70 72 6f 63 29 29 0a )(system proc)).
e910: 20 20 20 20 20 28 70 72 6f 63 20 20 20 20 20 20 (proc
e920: 20 20 20 20 28 70 72 6f 63 29 29 29 0a 20 20 20 (proc))).
e930: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 (hash-table-for
e940: 2d 65 61 63 68 0a 20 20 20 20 20 76 61 72 73 0a -each. vars.
e950: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 (lambda (va
e960: 72 20 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 r val). (s
e970: 65 74 65 6e 76 20 76 61 72 20 76 61 6c 29 29 29 etenv var val)))
e980: 0a 20 20 20 20 76 61 72 73 29 29 0a 0a 28 64 65 . vars))..(de
e990: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e fine (common:run
e9a0: 2d 61 2d 63 6f 6d 6d 61 6e 64 20 63 6d 64 20 23 -a-command cmd #
e9b0: 21 6b 65 79 20 28 77 69 74 68 2d 76 61 72 73 20 !key (with-vars
e9c0: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 #f)). (let* ((p
e9d0: 72 65 2d 63 6d 64 20 20 28 64 74 65 73 74 73 3a re-cmd (dtests:
e9e0: 67 65 74 2d 70 72 65 2d 63 6f 6d 6d 61 6e 64 29 get-pre-command)
e9f0: 29 0a 20 20 20 20 20 20 20 20 20 28 70 6f 73 74 ). (post
ea00: 2d 63 6d 64 20 28 64 74 65 73 74 73 3a 67 65 74 -cmd (dtests:get
ea10: 2d 70 6f 73 74 2d 63 6f 6d 6d 61 6e 64 29 29 0a -post-command)).
ea20: 20 20 20 20 20 20 20 20 20 28 66 75 6c 6c 63 6d (fullcm
ea30: 64 20 20 28 69 66 20 28 6f 72 20 70 72 65 2d 63 d (if (or pre-c
ea40: 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 md post-cmd).
ea50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ea60: 20 20 20 20 28 63 6f 6e 63 20 70 72 65 2d 63 6d (conc pre-cm
ea70: 64 20 63 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a d cmd post-cmd).
ea80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ea90: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 76 69 (conc "vi
eaa0: 65 77 73 63 72 65 65 6e 20 22 20 63 6d 64 29 29 ewscreen " cmd))
eab0: 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 )). (debug:pr
eac0: 69 6e 74 2d 69 6e 66 6f 20 30 32 20 2a 64 65 66 int-info 02 *def
ead0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
eae0: 52 75 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 3a Running command:
eaf0: 20 22 20 66 75 6c 6c 63 6d 64 29 0a 20 20 20 20 " fullcmd).
eb00: 28 69 66 20 77 69 74 68 2d 76 61 72 73 0a 20 20 (if with-vars.
eb10: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 (common:wi
eb20: 74 68 6f 75 74 2d 76 61 72 73 20 63 6d 64 29 0a thout-vars cmd).
eb30: 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a (common:
eb40: 77 69 74 68 6f 75 74 2d 76 61 72 73 20 66 75 6c without-vars ful
eb50: 6c 63 6d 64 20 22 4d 54 5f 2e 2a 22 29 29 29 29 lcmd "MT_.*"))))
eb60: 0a 09 09 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ... .;;========
eb70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
ebb0: 3b 20 54 20 49 20 4d 20 45 20 20 20 41 20 4e 20 ; T I M E A N
ebc0: 44 20 20 20 44 20 41 20 54 20 45 0a 3b 3b 3d 3d D D A T E.;;==
ebd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ebe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ebf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ec00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ec10: 3d 3d 3d 3d 0a 0a 3b 3b 20 43 6f 6e 76 65 72 74 ====..;; Convert
ec20: 20 73 74 72 69 6e 67 73 20 6c 69 6b 65 20 22 35 strings like "5
ec30: 73 20 32 68 20 33 6d 22 20 3d 3e 20 36 30 78 36 s 2h 3m" => 60x6
ec40: 30 78 32 20 2b 20 33 78 36 30 20 2b 20 35 0a 28 0x2 + 3x60 + 5.(
ec50: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 define (common:h
ec60: 6d 73 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e ms-string->secon
ec70: 64 73 20 74 73 74 72 29 0a 20 20 28 6c 65 74 20 ds tstr). (let
ec80: 28 28 70 61 72 74 73 20 20 20 20 20 28 73 74 72 ((parts (str
ec90: 69 6e 67 2d 73 70 6c 69 74 20 74 73 74 72 29 29 ing-split tstr))
eca0: 0a 09 28 74 69 6d 65 2d 73 65 63 73 20 30 29 0a ..(time-secs 0).
ecb0: 09 3b 3b 20 73 3d 73 65 63 6f 6e 64 73 2c 20 6d .;; s=seconds, m
ecc0: 3d 6d 69 6e 75 74 65 73 2c 20 68 3d 68 6f 75 72 =minutes, h=hour
ecd0: 73 2c 20 64 3d 64 61 79 73 0a 09 28 74 72 78 20 s, d=days..(trx
ece0: 20 20 20 20 20 20 28 72 65 67 65 78 70 20 22 28 (regexp "(
ecf0: 5c 5c 64 2b 29 28 5b 73 6d 68 64 5d 29 22 29 29 \\d+)([smhd])"))
ed00: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
ed10: 28 6c 61 6d 62 64 61 20 28 70 61 72 74 29 0a 09 (lambda (part)..
ed20: 09 28 6c 65 74 20 28 28 6d 61 74 63 68 20 20 28 .(let ((match (
ed30: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 74 72 78 string-match trx
ed40: 20 70 61 72 74 29 29 29 0a 09 09 20 20 28 69 66 part)))... (if
ed50: 20 6d 61 74 63 68 0a 09 09 20 20 20 20 20 20 28 match... (
ed60: 6c 65 74 20 28 28 76 61 6c 20 28 73 74 72 69 6e let ((val (strin
ed70: 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 g->number (cadr
ed80: 6d 61 74 63 68 29 29 29 0a 09 09 09 20 20 20 20 match)))....
ed90: 28 75 6e 74 20 28 63 61 64 64 72 20 6d 61 74 63 (unt (caddr matc
eda0: 68 29 29 29 0a 09 09 09 28 69 66 20 76 61 6c 20 h)))....(if val
edb0: 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 74 69 .... (set! ti
edc0: 6d 65 2d 73 65 63 73 20 28 2b 20 74 69 6d 65 2d me-secs (+ time-
edd0: 73 65 63 73 20 28 2a 20 76 61 6c 0a 09 09 09 09 secs (* val.....
ede0: 09 09 09 20 20 20 20 28 63 61 73 65 20 28 73 74 ... (case (st
edf0: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 75 6e 74 ring->symbol unt
ee00: 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 )........ (
ee10: 28 73 29 20 31 29 0a 09 09 09 09 09 09 09 20 20 (s) 1)........
ee20: 20 20 20 20 28 28 6d 29 20 36 30 29 0a 09 09 09 ((m) 60)....
ee30: 09 09 09 09 20 20 20 20 20 20 28 28 68 29 20 28 .... ((h) (
ee40: 2a 20 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 * 60 60)).......
ee50: 09 20 20 20 20 20 20 28 28 64 29 20 28 2a 20 32 . ((d) (* 2
ee60: 34 20 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 4 60 60)).......
ee70: 09 20 20 20 20 20 20 28 65 6c 73 65 20 30 29 29 . (else 0))
ee80: 29 29 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 ))))))))..
ee90: 70 61 72 74 73 29 0a 20 20 20 20 74 69 6d 65 2d parts). time-
eea0: 73 65 63 73 29 29 0a 09 09 20 20 20 20 20 20 20 secs))...
eeb0: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
eec0: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 s->hr-min-sec se
eed0: 63 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 cs). (let* ((hr
eee0: 73 20 28 71 75 6f 74 69 65 6e 74 20 73 65 63 73 s (quotient secs
eef0: 20 33 36 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 3600)).. (min (
ef00: 71 75 6f 74 69 65 6e 74 20 28 2d 20 73 65 63 73 quotient (- secs
ef10: 20 28 2a 20 68 72 73 20 33 36 30 30 29 29 20 36 (* hrs 3600)) 6
ef20: 30 29 29 0a 09 20 28 73 65 63 20 28 2d 20 73 65 0)).. (sec (- se
ef30: 63 73 20 28 2a 20 68 72 73 20 33 36 30 30 29 28 cs (* hrs 3600)(
ef40: 2a 20 6d 69 6e 20 36 30 29 29 29 29 0a 20 20 20 * min 60)))).
ef50: 20 28 63 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 (conc (if (> hr
ef60: 73 20 30 29 28 63 6f 6e 63 20 68 72 73 20 22 68 s 0)(conc hrs "h
ef70: 72 20 22 29 20 22 22 29 0a 09 20 20 28 69 66 20 r ") "").. (if
ef80: 28 3e 20 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d (> min 0)(conc m
ef90: 69 6e 20 22 6d 20 22 29 20 20 22 22 29 0a 09 20 in "m ") "")..
efa0: 20 73 65 63 20 22 73 22 29 29 29 0a 0a 28 64 65 sec "s")))..(de
efb0: 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 fine (seconds->t
efc0: 69 6d 65 2d 73 74 72 69 6e 67 20 73 65 63 29 0a ime-string sec).
efd0: 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 (time->string
efe0: 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
eff0: 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 cal-time sec) "%
f000: 48 3a 25 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 H:%M:%S"))..(def
f010: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f ine (seconds->wo
f020: 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 rk-week/day-time
f030: 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
f040: 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 tring. (second
f050: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
f060: 63 29 20 22 77 77 25 56 2e 25 75 20 25 48 3a 25 c) "ww%V.%u %H:%
f070: 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 M"))..(define (s
f080: 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 econds->work-wee
f090: 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 k/day sec). (ti
f0a0: 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 me->string. (s
f0b0: 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
f0c0: 6d 65 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 me sec) "ww%V.%u
f0d0: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
f0e0: 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b conds->year-work
f0f0: 2d 77 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 -week/day sec).
f100: 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 (time->string.
f110: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
f120: 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 79 77 l-time sec) "%yw
f130: 77 25 56 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 w%V.%w"))..(defi
f140: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 ne (seconds->yea
f150: 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d r-work-week/day-
f160: 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d time sec). (tim
f170: 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 e->string. (se
f180: 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
f190: 65 20 73 65 63 29 20 22 25 59 77 77 25 56 2e 25 e sec) "%Yww%V.%
f1a0: 77 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 w %H:%M"))..(def
f1b0: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 ine (seconds->ye
f1c0: 61 72 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 ar-week/day-time
f1d0: 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
f1e0: 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 tring. (second
f1f0: 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
f200: 63 29 20 22 25 59 77 25 56 2e 25 77 20 25 48 3a c) "%Yw%V.%w %H:
f210: 25 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 %M"))..(define (
f220: 73 65 63 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 seconds->quarter
f230: 20 73 65 63 29 0a 20 20 28 63 61 73 65 20 28 73 sec). (case (s
f240: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 tring->number..
f250: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 09 (time->string ..
f260: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
f270: 6c 2d 74 69 6d 65 20 73 65 63 29 0a 09 20 20 22 l-time sec).. "
f280: 25 6d 22 29 29 0a 20 20 20 20 28 28 31 20 32 20 %m")). ((1 2
f290: 33 29 20 31 29 0a 20 20 20 20 28 28 34 20 35 20 3) 1). ((4 5
f2a0: 36 29 20 32 29 0a 20 20 20 20 28 28 37 20 38 20 6) 2). ((7 8
f2b0: 39 29 20 33 29 0a 20 20 20 20 28 28 31 30 20 31 9) 3). ((10 1
f2c0: 31 20 31 32 29 20 34 29 0a 20 20 20 20 28 65 6c 1 12) 4). (el
f2d0: 73 65 20 23 66 29 29 29 0a 0a 3b 3b 20 67 69 76 se #f)))..;; giv
f2e0: 65 6e 20 73 70 61 6e 20 6f 66 20 73 65 63 6f 6e en span of secon
f2f0: 64 73 20 74 73 74 61 72 74 20 74 6f 20 74 65 6e ds tstart to ten
f300: 64 0a 3b 3b 20 66 69 6e 64 20 73 74 61 72 74 20 d.;; find start
f310: 74 69 6d 65 20 74 6f 20 6d 61 72 6b 20 61 6e 64 time to mark and
f320: 20 6d 61 72 6b 20 64 65 6c 74 61 0a 3b 3b 0a 28 mark delta.;;.(
f330: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 define (common:f
f340: 69 6e 64 2d 73 74 61 72 74 2d 6d 61 72 6b 2d 61 ind-start-mark-a
f350: 6e 64 2d 6d 61 72 6b 2d 64 65 6c 74 61 20 74 73 nd-mark-delta ts
f360: 74 61 72 74 20 74 65 6e 64 29 0a 20 20 28 6c 65 tart tend). (le
f370: 74 2a 20 28 28 64 65 6c 74 61 74 20 20 20 28 2d t* ((deltat (-
f380: 20 28 6d 61 78 20 74 65 6e 64 20 28 2b 20 74 65 (max tend (+ te
f390: 6e 64 20 31 30 29 29 20 74 73 74 61 72 74 29 29 nd 10)) tstart))
f3a0: 20 3b 3b 20 63 61 6e 27 74 20 68 61 6e 64 6c 65 ;; can't handle
f3b0: 20 72 75 6e 73 20 6f 66 20 6c 65 73 73 20 74 68 runs of less th
f3c0: 61 6e 20 34 20 73 65 63 6f 6e 64 73 2e 20 50 61 an 4 seconds. Pa
f3d0: 64 20 69 74 20 74 6f 20 31 30 20 73 65 63 6f 6e d it to 10 secon
f3e0: 64 73 20 2e 2e 2e 0a 09 20 28 72 65 73 75 6c 74 ds ..... (result
f3f0: 20 20 20 23 66 29 0a 09 20 28 6d 69 6e 20 20 20 #f).. (min
f400: 20 20 20 36 30 29 0a 09 20 28 68 72 20 20 20 20 60).. (hr
f410: 20 20 20 28 2a 20 36 30 20 36 30 29 29 0a 09 20 (* 60 60))..
f420: 28 64 61 79 20 20 20 20 20 20 28 2a 20 32 34 20 (day (* 24
f430: 68 72 29 29 0a 09 20 28 79 72 20 20 20 20 20 20 hr)).. (yr
f440: 20 28 2a 20 33 36 35 20 64 61 79 29 29 20 3b 3b (* 365 day)) ;;
f450: 20 79 65 61 72 0a 09 20 28 6d 6f 20 20 20 20 20 year.. (mo
f460: 20 20 28 2f 20 79 72 20 31 32 29 29 0a 09 20 28 (/ yr 12)).. (
f470: 77 6b 20 20 20 20 20 20 20 28 2a 20 64 61 79 20 wk (* day
f480: 37 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 7))). (for-ea
f490: 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
f4a0: 28 6d 61 78 2d 62 6c 6b 73 29 0a 20 20 20 20 20 (max-blks).
f4b0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 (for-each..(la
f4c0: 6d 62 64 61 20 28 73 70 61 6e 29 20 3b 3b 20 35 mbda (span) ;; 5
f4d0: 20 32 20 31 0a 09 20 20 28 69 66 20 28 6e 6f 74 2 1.. (if (not
f4e0: 20 72 65 73 75 6c 74 29 0a 09 20 20 20 20 20 20 result)..
f4f0: 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 (for-each ..
f500: 20 20 20 28 6c 61 6d 62 64 61 20 28 74 69 6d 65 (lambda (time
f510: 75 6e 69 74 20 74 69 6d 65 73 79 6d 29 20 3b 3b unit timesym) ;;
f520: 20 79 65 61 72 20 6d 6f 6e 74 68 20 64 61 79 20 year month day
f530: 68 72 20 6d 69 6e 20 73 65 63 0a 09 09 20 28 69 hr min sec... (i
f540: 66 20 28 6e 6f 74 20 72 65 73 75 6c 74 29 0a 09 f (not result)..
f550: 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 69 . (let* ((ti
f560: 6d 65 2d 62 6c 6b 20 28 2a 20 73 70 61 6e 20 74 me-blk (* span t
f570: 69 6d 65 75 6e 69 74 29 29 0a 09 09 09 20 20 20 imeunit))....
f580: 20 28 6e 75 6d 2d 62 6c 6b 73 20 28 71 75 6f 74 (num-blks (quot
f590: 69 65 6e 74 20 64 65 6c 74 61 74 20 74 69 6d 65 ient deltat time
f5a0: 2d 62 6c 6b 29 29 29 0a 09 09 20 20 20 20 20 20 -blk)))...
f5b0: 20 28 69 66 20 28 61 6e 64 20 28 3e 20 6e 75 6d (if (and (> num
f5c0: 2d 62 6c 6b 73 20 34 29 28 3c 20 6e 75 6d 2d 62 -blks 4)(< num-b
f5d0: 6c 6b 73 20 6d 61 78 2d 62 6c 6b 73 29 29 0a 09 lks max-blks))..
f5e0: 09 09 20 20 20 28 6c 65 74 20 28 28 66 69 72 73 .. (let ((firs
f5f0: 74 20 28 2a 20 28 71 75 6f 74 69 65 6e 74 20 74 t (* (quotient t
f600: 73 74 61 72 74 20 74 69 6d 65 2d 62 6c 6b 29 20 start time-blk)
f610: 74 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 09 20 time-blk)))....
f620: 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 (set! result
f630: 20 28 6c 69 73 74 20 73 70 61 6e 20 74 69 6d 65 (list span time
f640: 75 6e 69 74 20 74 69 6d 65 2d 62 6c 6b 20 66 69 unit time-blk fi
f650: 72 73 74 20 74 69 6d 65 73 79 6d 29 29 0a 09 09 rst timesym))...
f660: 09 20 20 20 20 20 29 29 29 29 29 0a 09 20 20 20 . )))))..
f670: 20 20 20 20 28 6c 69 73 74 20 79 72 20 6d 6f 20 (list yr mo
f680: 77 6b 20 64 61 79 20 68 72 20 6d 69 6e 20 31 29 wk day hr min 1)
f690: 0a 09 20 20 20 20 20 20 20 27 28 20 20 20 20 20 .. '(
f6a0: 79 20 20 6d 6f 20 77 20 20 64 20 20 20 68 20 20 y mo w d h
f6b0: 6d 20 20 20 73 29 29 29 29 0a 09 28 6c 69 73 74 m s))))..(list
f6c0: 20 38 20 36 20 35 20 32 20 31 29 29 29 0a 20 20 8 6 5 2 1))).
f6d0: 20 20 20 27 28 35 20 31 30 20 31 35 20 32 30 20 '(5 10 15 20
f6e0: 33 30 20 34 30 20 35 30 20 35 30 30 29 29 0a 20 30 40 50 500)).
f6f0: 20 20 20 28 69 66 20 76 61 6c 75 65 73 0a 09 28 (if values..(
f700: 61 70 70 6c 79 20 76 61 6c 75 65 73 20 72 65 73 apply values res
f710: 75 6c 74 29 0a 09 28 76 61 6c 75 65 73 20 30 20 ult)..(values 0
f720: 64 61 79 20 31 20 30 20 27 64 29 29 29 29 0a 09 day 1 0 'd))))..
f730: 20 20 20 20 0a 09 20 20 0a 0a 3b 3b 3d 3d 3d 3d .. ..;;====
f740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f780: 3d 3d 0a 3b 3b 20 43 20 4f 20 4c 20 4f 20 52 20 ==.;; C O L O R
f790: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
f7a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f7b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f7c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f7d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 ==========.
f7e0: 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f .(define (commo
f7f0: 6e 3a 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f n:name->iup-colo
f800: 72 20 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 r name). (case
f810: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
f820: 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 (string-downcase
f830: 20 6e 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 name)). ((re
f840: 64 29 20 20 20 20 22 32 32 33 20 33 33 20 34 39 d) "223 33 49
f850: 22 29 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 "). ((grey)
f860: 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 0a "192 192 192").
f870: 20 20 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 ((orange) "2
f880: 35 35 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 55 172 13").
f890: 28 28 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 ((purple) "This
f8a0: 69 73 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e is unfinished ..
f8b0: 2e 22 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e .")))..;; (defin
f8c0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f e (common:get-co
f8d0: 6c 6f 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 lor-for-state-st
f8e0: 61 74 75 73 20 73 74 61 74 65 20 73 74 61 74 75 atus state statu
f8f0: 73 29 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 73 s).;; (case (s
f900: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 tring->symbol st
f910: 61 74 65 29 0a 3b 3b 20 20 20 20 20 28 28 43 4f ate).;; ((CO
f920: 4d 50 4c 45 54 45 44 29 0a 3b 3b 20 20 20 20 20 MPLETED).;;
f930: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
f940: 73 79 6d 62 6f 6c 20 73 74 61 74 75 73 29 0a 3b symbol status).;
f950: 3b 20 20 20 20 20 20 20 20 28 28 50 41 53 53 29 ; ((PASS)
f960: 20 20 20 20 20 20 20 20 22 37 30 20 20 32 34 39 "70 249
f970: 20 37 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 73").;;
f980: 28 28 57 41 52 4e 20 57 41 49 56 45 44 29 20 22 ((WARN WAIVED) "
f990: 32 35 35 20 31 37 32 20 31 33 22 29 0a 3b 3b 20 255 172 13").;;
f9a0: 20 20 20 20 20 20 20 28 28 53 4b 49 50 29 20 20 ((SKIP)
f9b0: 20 20 20 20 20 20 22 32 33 30 20 32 33 30 20 30 "230 230 0
f9c0: 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 65 6c ").;; (el
f9d0: 73 65 20 22 32 32 33 20 33 33 20 34 39 22 29 29 se "223 33 49"))
f9e0: 29 0a 3b 3b 20 20 20 20 20 28 28 4c 41 55 4e 43 ).;; ((LAUNC
f9f0: 48 45 44 29 20 20 20 20 20 20 20 20 20 22 31 30 HED) "10
fa00: 31 20 31 32 33 20 31 34 32 22 29 0a 3b 3b 20 20 1 123 142").;;
fa10: 20 20 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 ((CHECK)
fa20: 20 20 20 20 20 20 20 22 32 35 35 20 31 30 30 20 "255 100
fa30: 35 30 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 45 50").;; ((RE
fa40: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 MOTEHOSTSTART)
fa50: 22 35 30 20 20 31 33 30 20 31 39 35 22 29 0a 3b "50 130 195").;
fa60: 3b 20 20 20 20 20 28 28 52 55 4e 4e 49 4e 47 29 ; ((RUNNING)
fa70: 20 20 20 20 20 20 20 20 20 20 22 39 20 20 20 31 "9 1
fa80: 33 31 20 32 33 32 22 29 0a 3b 3b 20 20 20 20 20 31 232").;;
fa90: 28 28 4b 49 4c 4c 52 45 51 29 20 20 20 20 20 20 ((KILLREQ)
faa0: 20 20 20 20 22 33 39 20 20 38 32 20 20 32 30 36 "39 82 206
fab0: 22 29 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c ").;; ((KILL
fac0: 45 44 29 20 20 20 20 20 20 20 20 20 20 20 22 32 ED) "2
fad0: 33 34 20 31 30 31 20 31 37 22 29 0a 3b 3b 20 20 34 101 17").;;
fae0: 20 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 ((NOT_STARTED
faf0: 29 20 20 20 20 20 20 22 32 34 30 20 32 34 30 20 ) "240 240
fb00: 32 34 30 22 29 0a 3b 3b 20 20 20 20 20 28 65 6c 240").;; (el
fb10: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
fb20: 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 29 "192 192 192"))
fb30: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
fb40: 6f 6e 3a 69 75 70 2d 63 6f 6c 6f 72 2d 3e 72 67 on:iup-color->rg
fb50: 62 2d 68 65 78 20 69 6e 73 74 72 29 0a 20 20 28 b-hex instr). (
fb60: 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
fb70: 73 65 20 0a 20 20 20 28 6d 61 70 20 28 6c 61 6d se . (map (lam
fb80: 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 bda (x).
fb90: 20 20 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e (number->strin
fba0: 67 20 78 20 31 36 29 29 0a 20 20 20 20 20 20 20 g x 16)).
fbb0: 20 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 (map string->nu
fbc0: 6d 62 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 mber.
fbd0: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
fbe0: 69 6e 73 74 72 29 29 29 0a 20 20 20 22 2f 22 29 instr))). "/")
fbf0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
fc00: 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f on:get-color-fro
fc10: 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 73 29 m-status status)
fc20: 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 65 71 . (cond. ((eq
fc30: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 ual? status "PAS
fc40: 53 22 29 20 20 20 20 22 67 72 65 65 6e 22 29 0a S") "green").
fc50: 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
fc60: 75 73 20 22 46 41 49 4c 22 29 20 20 20 20 22 72 us "FAIL") "r
fc70: 65 64 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ed"). ((equal?
fc80: 20 73 74 61 74 75 73 20 22 57 41 52 4e 22 29 20 status "WARN")
fc90: 20 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 "orange").
fca0: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
fcb0: 22 4b 49 4c 4c 45 44 22 29 20 20 22 6f 72 61 6e "KILLED") "oran
fcc0: 67 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ge"). ((equal?
fcd0: 20 73 74 61 74 75 73 20 22 4b 49 4c 4c 52 45 51 status "KILLREQ
fce0: 22 29 20 22 70 75 72 70 6c 65 22 29 0a 20 20 20 ") "purple").
fcf0: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
fd00: 22 52 55 4e 4e 49 4e 47 22 29 20 22 62 6c 75 65 "RUNNING") "blue
fd10: 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 "). ((equal? s
fd20: 74 61 74 75 73 20 22 41 42 4f 52 54 22 29 20 20 tatus "ABORT")
fd30: 20 22 62 72 6f 77 6e 22 29 0a 20 20 20 28 65 6c "brown"). (el
fd40: 73 65 20 22 62 6c 61 63 6b 22 29 29 29 0a 0a 3b se "black")))..;
fd50: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
fd60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd90: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 20 41 20 4e =======.;; N A N
fda0: 20 4f 20 4d 20 53 20 47 20 20 20 43 20 4c 20 49 O M S G C L I
fdb0: 20 45 20 4e 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d E N T.;;=======
fdc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fdd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fde0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fdf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
fe00: 0a 28 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 .(define (server
fe10: 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d :get-best-guess-
fe20: 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 address hostname
fe30: 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 ). (let ((res #
fe40: 66 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 f)). (for-eac
fe50: 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h . (lambda
fe60: 28 61 64 72 29 0a 20 20 20 20 20 20 20 28 69 66 (adr). (if
fe70: 20 28 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 (not (eq? (u8ve
fe80: 63 74 6f 72 2d 72 65 66 20 61 64 72 20 30 29 20 ctor-ref adr 0)
fe90: 31 32 37 29 29 0a 09 20 20 20 28 73 65 74 21 20 127)).. (set!
fea0: 72 65 73 20 61 64 72 29 29 29 0a 20 20 20 20 20 res adr))).
feb0: 3b 3b 20 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 ;; NOTE: This ca
fec0: 6e 20 66 61 69 6c 20 77 68 65 6e 20 74 68 65 72 n fail when ther
fed0: 65 20 69 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 e is no mention
fee0: 6f 66 20 74 68 65 20 68 6f 73 74 20 69 6e 20 2f of the host in /
fef0: 65 74 63 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 etc/hosts. FIXME
ff00: 0a 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c . (vector->l
ff10: 69 73 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 ist (hostinfo-ad
ff20: 64 72 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d dresses (hostnam
ff30: 65 2d 3e 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 e->hostinfo host
ff40: 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 28 73 74 name)))). (st
ff50: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
ff60: 20 0a 20 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 . (map numb
ff70: 65 72 2d 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 er->string.. (u
ff80: 38 76 65 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 8vector->list..
ff90: 20 20 28 69 66 20 72 65 73 20 72 65 73 20 28 68 (if res res (h
ffa0: 6f 73 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 ostname->ip host
ffb0: 6e 61 6d 65 29 29 29 29 20 22 2e 22 29 29 29 0a name)))) "."))).
ffc0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
ffd0: 6e 3a 73 65 6e 64 2d 64 62 6f 61 72 64 2d 6d 61 n:send-dboard-ma
ffe0: 69 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 6c in-changed). (l
fff0: 65 74 2a 20 28 28 64 61 73 68 62 6f 61 72 64 2d et* ((dashboard-
10000 69 70 73 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 ips (mddb:get-da
10010 73 68 62 6f 61 72 64 73 29 29 29 0a 20 20 20 20 shboards))).
10020 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
10030 6c 61 6d 62 64 61 20 28 69 70 61 64 72 29 0a 20 lambda (ipadr).
10040 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f (let* ((so
10050 63 20 28 63 6f 6d 6d 6f 6e 3a 6f 70 65 6e 2d 6e c (common:open-n
10060 6d 2d 72 65 71 20 28 63 6f 6e 63 20 22 74 63 70 m-req (conc "tcp
10070 3a 2f 2f 22 20 69 70 61 64 72 29 29 29 0a 09 20 ://" ipadr)))..
10080 20 20 20 20 20 28 6d 73 67 20 28 63 6f 6e 63 20 (msg (conc
10090 22 6d 61 69 6e 20 22 20 2a 74 6f 70 70 61 74 68 "main " *toppath
100a0 2a 29 29 0a 09 20 20 20 20 20 20 28 72 65 73 20 *)).. (res
100b0 28 63 6f 6d 6d 6f 6e 3a 6e 6d 2d 73 65 6e 64 2d (common:nm-send-
100c0 72 65 63 65 69 76 65 2d 74 69 6d 65 6f 75 74 20 receive-timeout
100d0 73 6f 63 20 6d 73 67 29 29 29 0a 09 20 28 69 66 soc msg))).. (if
100e0 20 28 6e 6f 74 20 72 65 73 29 20 3b 3b 20 63 6f (not res) ;; co
100f0 75 6c 64 6e 27 74 20 72 65 61 63 68 20 74 68 61 uldn't reach tha
10100 74 20 64 61 73 68 62 6f 61 72 64 20 2d 20 72 65 t dashboard - re
10110 6d 6f 76 65 20 69 74 20 66 72 6f 6d 20 64 62 0a move it from db.
10120 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 . (print "ER
10130 52 4f 52 3a 20 63 6f 75 6c 64 6e 27 74 20 72 65 ROR: couldn't re
10140 61 63 68 20 64 61 73 68 62 6f 61 72 64 20 22 20 ach dashboard "
10150 69 70 61 64 72 29 29 0a 09 20 72 65 73 29 29 0a ipadr)).. res)).
10160 20 20 20 20 20 64 61 73 68 62 6f 61 72 64 2d 69 dashboard-i
10170 70 73 29 29 29 0a 20 20 20 20 0a 20 20 20 20 0a ps))). . .
10180 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
10190 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
101c0 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 ========.;; D A
101d0 53 20 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 S H B O A R D
101e0 44 20 42 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d D B .;;=========
101f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10200 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10210 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10220 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
10230 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 6f 70 65 define (mddb:ope
10240 6e 2d 64 62 29 0a 20 20 28 6c 65 74 2a 20 28 28 n-db). (let* ((
10250 64 62 20 28 6f 70 65 6e 2d 64 61 74 61 62 61 73 db (open-databas
10260 65 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 e (conc (get-env
10270 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
10280 65 20 22 48 4f 4d 45 22 29 20 22 2f 2e 64 61 73 e "HOME") "/.das
10290 68 62 6f 61 72 64 2e 64 62 22 29 29 29 29 0a 20 hboard.db")))).
102a0 20 20 20 28 73 65 74 2d 62 75 73 79 2d 68 61 6e (set-busy-han
102b0 64 6c 65 72 21 20 64 62 20 28 62 75 73 79 2d 74 dler! db (busy-t
102c0 69 6d 65 6f 75 74 20 31 30 30 30 30 29 29 0a 20 imeout 10000)).
102d0 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
102e0 20 20 28 6c 61 6d 62 64 61 20 28 71 72 79 29 0a (lambda (qry).
102f0 20 20 20 20 20 20 20 28 65 78 65 63 20 28 73 71 (exec (sq
10300 6c 20 64 62 20 71 72 79 29 29 29 0a 20 20 20 20 l db qry))).
10310 20 28 6c 69 73 74 20 0a 20 20 20 20 20 20 22 43 (list . "C
10320 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e REATE TABLE IF N
10330 4f 54 20 45 58 49 53 54 53 20 76 61 72 73 20 20 OT EXISTS vars
10340 20 20 20 20 20 28 69 64 20 49 4e 54 45 47 45 52 (id INTEGER
10350 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 PRIMARY KEY,key
10360 20 54 45 58 54 2c 20 76 61 6c 20 54 45 58 54 2c TEXT, val TEXT,
10370 20 43 4f 4e 53 54 52 41 49 4e 54 20 76 61 72 73 CONSTRAINT vars
10380 63 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 constraint UNIQU
10390 45 20 28 6b 65 79 29 29 3b 22 0a 20 20 20 20 20 E (key));".
103a0 20 22 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 "CREATE TABLE I
103b0 46 20 4e 4f 54 20 45 58 49 53 54 53 20 64 61 73 F NOT EXISTS das
103c0 68 62 6f 61 72 64 73 20 28 0a 20 20 20 20 20 20 hboards (.
103d0 20 20 20 20 69 64 20 20 20 20 20 20 20 20 20 49 id I
103e0 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b NTEGER PRIMARY K
103f0 45 59 2c 0a 20 20 20 20 20 20 20 20 20 20 70 69 EY,. pi
10400 64 20 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 d INTEGER
10410 2c 0a 20 20 20 20 20 20 20 20 20 20 75 73 65 72 ,. user
10420 6e 61 6d 65 20 20 20 54 45 58 54 2c 0a 20 20 20 name TEXT,.
10430 20 20 20 20 20 20 20 68 6f 73 74 6e 61 6d 65 20 hostname
10440 20 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 TEXT,.
10450 20 20 69 70 61 64 64 72 20 20 20 20 20 54 45 58 ipaddr TEX
10460 54 2c 0a 20 20 20 20 20 20 20 20 20 20 70 6f 72 T,. por
10470 74 6e 75 6d 20 20 20 20 49 4e 54 45 47 45 52 2c tnum INTEGER,
10480 0a 20 20 20 20 20 20 20 20 20 20 73 74 61 72 74 . start
10490 5f 74 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 _time TIMESTAMP
104a0 44 45 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d DEFAULT (strftim
104b0 65 28 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a e('%s','now')),.
104c0 20 20 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e CON
104d0 53 54 52 41 49 4e 54 20 68 6f 73 74 70 6f 72 74 STRAINT hostport
104e0 20 55 4e 49 51 55 45 20 28 68 6f 73 74 6e 61 6d UNIQUE (hostnam
104f0 65 2c 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 e,portnum).
10500 20 20 20 29 3b 22 0a 20 20 20 20 20 20 29 29 0a );". )).
10510 20 20 20 20 64 62 29 29 0a 0a 3b 3b 20 72 65 67 db))..;; reg
10520 69 73 74 65 72 20 61 20 64 61 73 68 62 6f 61 72 ister a dashboar
10530 64 20 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d d .;;.(define (m
10540 64 64 62 3a 72 65 67 69 73 74 65 72 2d 64 61 73 ddb:register-das
10550 68 62 6f 61 72 64 20 70 6f 72 74 29 0a 20 20 28 hboard port). (
10560 6c 65 74 2a 20 28 28 70 69 64 20 20 20 20 20 20 let* ((pid
10570 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
10580 2d 69 64 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d -id)).. (hostnam
10590 65 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 e (get-host-name
105a0 29 29 0a 09 20 28 69 70 61 64 64 72 20 20 20 28 )).. (ipaddr (
105b0 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d server:get-best-
105c0 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f guess-address ho
105d0 73 74 6e 61 6d 65 29 29 0a 09 20 28 75 73 65 72 stname)).. (user
105e0 6e 61 6d 65 20 28 63 75 72 72 65 6e 74 2d 75 73 name (current-us
105f0 65 72 2d 6e 61 6d 65 29 29 20 3b 3b 20 28 63 61 er-name)) ;; (ca
10600 72 20 75 73 65 72 69 6e 66 6f 29 29 29 0a 09 20 r userinfo)))..
10610 28 64 62 20 20 20 20 20 20 28 6d 64 64 62 3a 6f (db (mddb:o
10620 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 70 pen-db))). (p
10630 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 20 6d rint "Register m
10640 6f 6e 69 74 6f 72 2c 20 70 69 64 3a 20 22 20 70 onitor, pid: " p
10650 69 64 20 22 2c 20 68 6f 73 74 6e 61 6d 65 3a 20 id ", hostname:
10660 22 20 68 6f 73 74 6e 61 6d 65 20 22 2c 20 70 6f " hostname ", po
10670 72 74 3a 20 22 20 70 6f 72 74 20 22 2c 20 75 73 rt: " port ", us
10680 65 72 6e 61 6d 65 3a 20 22 20 75 73 65 72 6e 61 ername: " userna
10690 6d 65 29 0a 20 20 20 20 28 65 78 65 63 20 28 73 me). (exec (s
106a0 71 6c 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 ql db "INSERT OR
106b0 20 52 45 50 4c 41 43 45 20 49 4e 54 4f 20 64 61 REPLACE INTO da
106c0 73 68 62 6f 61 72 64 73 20 28 70 69 64 2c 75 73 shboards (pid,us
106d0 65 72 6e 61 6d 65 2c 68 6f 73 74 6e 61 6d 65 2c ername,hostname,
106e0 69 70 61 64 64 72 2c 70 6f 72 74 6e 75 6d 29 20 ipaddr,portnum)
106f0 56 41 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c VALUES (?,?,?,?,
10700 3f 29 3b 22 29 0a 09 20 20 20 70 69 64 20 75 73 ?);").. pid us
10710 65 72 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 20 ername hostname
10720 69 70 61 64 64 72 20 70 6f 72 74 29 0a 20 20 20 ipaddr port).
10730 20 28 63 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 (close-database
10740 20 64 62 29 29 29 0a 0a 3b 3b 20 75 6e 72 65 67 db)))..;; unreg
10750 69 73 74 65 72 20 61 20 6d 6f 6e 69 74 6f 72 0a ister a monitor.
10760 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 ;;.(define (mddb
10770 3a 75 6e 72 65 67 69 73 74 65 72 2d 64 61 73 68 :unregister-dash
10780 62 6f 61 72 64 20 68 6f 73 74 20 70 6f 72 74 29 board host port)
10790 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 . (let* ((db
107a0 20 20 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 (mddb:open-db
107b0 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 ))). (print "
107c0 52 65 67 69 73 74 65 72 20 75 6e 72 65 67 69 73 Register unregis
107d0 74 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 68 6f 73 ter monitor, hos
107e0 74 3a 70 6f 72 74 3d 22 20 68 6f 73 74 20 22 3a t:port=" host ":
107f0 22 20 70 6f 72 74 29 0a 20 20 20 20 28 65 78 65 " port). (exe
10800 63 20 28 73 71 6c 20 64 62 20 22 44 45 4c 45 54 c (sql db "DELET
10810 45 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 E FROM dashboard
10820 73 20 57 48 45 52 45 20 68 6f 73 74 6e 61 6d 65 s WHERE hostname
10830 3d 3f 20 41 4e 44 20 70 6f 72 74 6e 75 6d 3d 3f =? AND portnum=?
10840 3b 22 29 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 ;") host port).
10850 20 20 20 28 63 6c 6f 73 65 2d 64 61 74 61 62 61 (close-databa
10860 73 65 20 64 62 29 29 29 0a 0a 3b 3b 20 67 65 74 se db)))..;; get
10870 20 72 65 67 69 73 74 65 72 65 64 20 64 61 73 68 registered dash
10880 62 6f 61 72 64 73 0a 3b 3b 0a 28 64 65 66 69 6e boards.;;.(defin
10890 65 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 e (mddb:get-dash
108a0 62 6f 61 72 64 73 29 0a 20 20 28 6c 65 74 20 28 boards). (let (
108b0 28 64 62 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 (db (mddb:open-d
108c0 62 29 29 29 0a 20 20 20 20 28 71 75 65 72 79 20 b))). (query
108d0 66 65 74 63 68 2d 63 6f 6c 75 6d 6e 0a 09 20 20 fetch-column..
108e0 20 28 73 71 6c 20 64 62 20 22 53 45 4c 45 43 54 (sql db "SELECT
108f0 20 69 70 61 64 64 72 20 7c 7c 20 27 3a 27 20 7c ipaddr || ':' |
10900 7c 20 70 6f 72 74 6e 75 6d 20 46 52 4f 4d 20 64 | portnum FROM d
10910 61 73 68 62 6f 61 72 64 73 3b 22 29 29 29 29 0a ashboards;")))).
10920 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=========
10930 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10940 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10950 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10960 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
10970 20 20 54 20 45 20 53 20 54 20 20 20 4c 20 41 20 T E S T L A
10980 55 20 4e 20 43 20 48 20 49 20 4e 20 47 20 20 20 U N C H I N G
10990 50 20 45 20 52 20 20 20 49 20 54 20 45 20 4d 20 P E R I T E M
109a0 20 20 57 20 49 20 54 20 48 20 20 20 48 20 4f 20 W I T H H O
109b0 53 20 54 20 20 20 54 20 59 20 50 20 45 20 53 0a S T T Y P E S.
109c0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
109d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
109e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
109f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10a00 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 ========.;; .;;
10a10 5b 68 6f 73 74 73 5d 0a 3b 3b 20 61 72 6d 20 63 [hosts].;; arm c
10a20 75 62 69 65 30 31 20 63 75 62 69 65 30 32 0a 3b ubie01 cubie02.;
10a30 3b 20 78 38 36 5f 36 34 20 7a 65 75 73 20 78 65 ; x86_64 zeus xe
10a40 6e 61 20 6d 79 74 68 30 31 0a 3b 3b 20 61 6c 6c na myth01.;; all
10a50 68 6f 73 74 73 20 23 7b 67 20 68 6f 73 74 73 20 hosts #{g hosts
10a60 61 72 6d 7d 20 23 7b 67 20 68 6f 73 74 73 20 78 arm} #{g hosts x
10a70 38 36 5f 36 34 7d 0a 3b 3b 20 0a 3b 3b 20 5b 68 86_64}.;; .;; [h
10a80 6f 73 74 2d 74 79 70 65 73 5d 0a 3b 3b 20 67 65 ost-types].;; ge
10a90 6e 65 72 61 6c 20 23 4d 54 4c 4f 57 45 53 54 4c neral #MTLOWESTL
10aa0 4f 41 44 20 23 7b 67 20 68 6f 73 74 73 20 61 6c OAD #{g hosts al
10ab0 6c 68 6f 73 74 73 7d 0a 3b 3b 20 61 72 6d 20 20 lhosts}.;; arm
10ac0 20 20 20 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 #MTLOWESTLOAD
10ad0 20 23 7b 67 20 68 6f 73 74 73 20 61 72 6d 7d 0a #{g hosts arm}.
10ae0 3b 3b 20 6e 62 67 65 6e 65 72 61 6c 20 6e 62 6a ;; nbgeneral nbj
10af0 6f 62 20 72 75 6e 20 4a 4f 42 43 4f 4d 4d 41 4e ob run JOBCOMMAN
10b00 44 20 2d 6c 6f 67 20 24 4d 54 5f 4c 49 4e 4b 54 D -log $MT_LINKT
10b10 52 45 45 2f 24 4d 54 5f 54 41 52 47 45 54 2f 24 REE/$MT_TARGET/$
10b20 4d 54 5f 52 55 4e 4e 41 4d 45 2e 24 4d 54 5f 54 MT_RUNNAME.$MT_T
10b30 45 53 54 4e 41 4d 45 2d 24 4d 54 5f 49 54 45 4d ESTNAME-$MT_ITEM
10b40 5f 50 41 54 48 2e 6c 67 6f 0a 3b 3b 20 0a 3b 3b _PATH.lgo.;; .;;
10b50 20 5b 6c 61 75 6e 63 68 65 72 73 5d 0a 3b 3b 20 [launchers].;;
10b60 65 6e 76 73 65 74 75 70 20 67 65 6e 65 72 61 6c envsetup general
10b70 0a 3b 3b 20 78 6f 72 2f 25 2f 6e 20 34 43 31 36 .;; xor/%/n 4C16
10b80 47 0a 3b 3b 20 25 20 6e 62 67 65 6e 65 72 61 6c G.;; % nbgeneral
10b90 0a 3b 3b 20 0a 3b 3b 20 5b 6a 6f 62 74 6f 6f 6c .;; .;; [jobtool
10ba0 73 5d 0a 3b 3b 20 23 20 69 66 20 64 65 66 69 6e s].;; # if defin
10bb0 65 64 20 61 6e 64 20 6e 6f 74 20 22 6e 6f 22 20 ed and not "no"
10bc0 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 77 flexi-launcher w
10bd0 69 6c 6c 20 62 79 70 61 73 73 20 22 6c 61 75 6e ill bypass "laun
10be0 63 68 65 72 22 20 75 6e 6c 65 73 73 20 6e 6f 20 cher" unless no
10bf0 6d 61 74 63 68 2e 0a 3b 3b 20 66 6c 65 78 69 2d match..;; flexi-
10c00 6c 61 75 6e 63 68 65 72 20 79 65 73 20 20 0a 3b launcher yes .;
10c10 3b 20 6c 61 75 6e 63 68 65 72 20 6e 62 66 61 6b ; launcher nbfak
10c20 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f e.;;.(define (co
10c30 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 75 6e 63 68 65 mmon:get-launche
10c40 72 20 63 6f 6e 66 69 67 64 61 74 20 74 65 73 74 r configdat test
10c50 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 name itempath).
10c60 20 28 6c 65 74 20 28 28 66 61 6c 6c 62 61 63 6b (let ((fallback
10c70 2d 6c 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 -launcher (confi
10c80 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
10c90 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 dat "jobtools" "
10ca0 6c 61 75 6e 63 68 65 72 22 29 29 29 0a 20 20 20 launcher"))).
10cb0 20 28 69 66 20 28 61 6e 64 20 28 63 6f 6e 66 69 (if (and (confi
10cc0 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
10cd0 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 dat "jobtools" "
10ce0 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 flexi-launcher")
10cf0 20 3b 3b 20 6f 76 65 72 72 69 64 65 73 20 6c 61 ;; overrides la
10d00 75 6e 63 68 65 72 0a 09 20 20 20 20 20 28 6e 6f uncher.. (no
10d10 74 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 t (equal? (confi
10d20 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
10d30 64 61 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 dat "jobtools" "
10d40 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 flexi-launcher")
10d50 20 22 6e 6f 22 29 29 29 0a 09 28 6c 65 74 2a 20 "no")))..(let*
10d60 28 28 6c 61 75 6e 63 68 65 72 73 20 20 20 20 20 ((launchers
10d70 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
10d80 72 65 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 ref/default conf
10d90 69 67 64 61 74 20 22 6c 61 75 6e 63 68 65 72 73 igdat "launchers
10da0 22 20 27 28 29 29 29 29 0a 09 20 20 28 69 66 20 " '()))).. (if
10db0 28 6e 75 6c 6c 3f 20 6c 61 75 6e 63 68 65 72 73 (null? launchers
10dc0 29 0a 09 20 20 20 20 20 20 66 61 6c 6c 62 61 63 ).. fallbac
10dd0 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 20 20 20 20 k-launcher..
10de0 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
10df0 64 20 28 63 61 72 20 6c 61 75 6e 63 68 65 72 73 d (car launchers
10e00 29 29 0a 09 09 09 20 28 74 61 6c 20 28 63 64 72 )).... (tal (cdr
10e10 20 6c 61 75 6e 63 68 65 72 73 29 29 29 0a 09 09 launchers)))...
10e20 28 6c 65 74 20 28 28 70 61 74 74 20 20 20 20 20 (let ((patt
10e30 20 28 63 61 72 20 68 65 64 29 29 0a 09 09 20 20 (car hed))...
10e40 20 20 20 20 28 68 6f 73 74 2d 74 79 70 65 20 28 (host-type (
10e50 63 61 64 72 20 68 65 64 29 29 29 0a 09 09 20 20 cadr hed)))...
10e60 28 69 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 (if (tests:match
10e70 20 70 61 74 74 20 74 65 73 74 6e 61 6d 65 20 69 patt testname i
10e80 74 65 6d 70 61 74 68 29 0a 09 09 20 20 20 20 20 tempath)...
10e90 20 28 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 (begin....(debu
10ea0 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
10eb0 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
10ec0 2a 20 22 48 61 76 65 20 66 6c 65 78 69 2d 6c 61 * "Have flexi-la
10ed0 75 6e 63 68 65 72 20 6d 61 74 63 68 20 66 6f 72 uncher match for
10ee0 20 22 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 " testname "/"
10ef0 69 74 65 6d 70 61 74 68 20 22 20 3d 20 22 20 68 itempath " = " h
10f00 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 28 6c 65 ost-type)....(le
10f10 74 20 28 28 6c 61 75 6e 63 68 65 72 20 28 63 6f t ((launcher (co
10f20 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e nfigf:lookup con
10f30 66 69 67 64 61 74 20 22 68 6f 73 74 2d 74 79 70 figdat "host-typ
10f40 65 73 22 20 68 6f 73 74 2d 74 79 70 65 29 29 29 es" host-type)))
10f50 0a 09 09 09 20 20 28 69 66 20 6c 61 75 6e 63 68 .... (if launch
10f60 65 72 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 er.... (let
10f70 2a 20 28 28 6c 61 75 6e 63 68 65 72 2d 70 61 72 * ((launcher-par
10f80 74 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ts (string-split
10f90 20 6c 61 75 6e 63 68 65 72 29 29 0a 09 09 09 09 launcher)).....
10fa0 20 20 20 20 20 28 6c 61 75 6e 63 68 65 72 2d 65 (launcher-e
10fb0 78 65 20 20 20 28 63 61 72 20 6c 61 75 6e 63 68 xe (car launch
10fc0 65 72 2d 70 61 72 74 73 29 29 29 0a 09 09 09 09 er-parts))).....
10fd0 28 69 66 20 28 65 71 75 61 6c 3f 20 6c 61 75 6e (if (equal? laun
10fe0 63 68 65 72 2d 65 78 65 20 22 23 4d 54 4c 4f 57 cher-exe "#MTLOW
10ff0 45 53 54 4c 4f 41 44 22 29 20 3b 3b 20 74 68 69 ESTLOAD") ;; thi
11000 73 20 69 73 20 6f 75 72 20 73 70 65 63 69 61 6c s is our special
11010 20 63 61 73 65 2c 20 77 65 20 77 69 6c 6c 20 66 case, we will f
11020 69 6e 64 20 74 68 65 20 6c 6f 77 65 73 74 20 6c ind the lowest l
11030 6f 61 64 20 61 6e 64 20 63 72 61 66 74 20 61 20 oad and craft a
11040 6e 62 66 61 6b 65 20 63 6f 6d 6d 61 6e 64 6c 69 nbfake commandli
11050 6e 65 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 ne..... (let
11060 28 28 74 61 72 67 2d 68 6f 73 74 20 28 63 6f 6d ((targ-host (com
11070 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 74 2d 6c 6f mon:get-least-lo
11080 61 64 65 64 2d 68 6f 73 74 20 28 63 64 72 20 6c aded-host (cdr l
11090 61 75 6e 63 68 65 72 2d 70 61 72 74 73 29 29 29 auncher-parts)))
110a0 29 0a 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e )..... (con
110b0 63 20 22 72 65 6d 72 75 6e 20 22 20 74 61 72 67 c "remrun " targ
110c0 2d 68 6f 73 74 29 29 0a 09 09 09 09 20 20 20 20 -host)).....
110d0 6c 61 75 6e 63 68 65 72 29 29 0a 09 09 09 20 20 launcher))....
110e0 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 (begin.....(
110f0 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
11100 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
11110 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
11120 6e 6f 20 6c 61 75 6e 63 68 65 72 20 66 6f 75 6e no launcher foun
11130 64 20 66 6f 72 20 68 6f 73 74 2d 74 79 70 65 20 d for host-type
11140 22 20 68 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 " host-type)....
11150 09 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 .(if (null? tal)
11160 0a 09 09 09 09 20 20 20 20 66 61 6c 6c 62 61 63 ..... fallbac
11170 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 09 09 09 20 k-launcher.....
11180 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
11190 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
111a0 29 0a 09 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 )... ;; no
111b0 6d 61 74 63 68 2c 20 74 72 79 20 61 67 61 69 6e match, try again
111c0 0a 09 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 ... (if (nu
111d0 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 66 61 ll? tal).... fa
111e0 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 0a llback-launcher.
111f0 09 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 ... (loop (car
11200 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 tal)(cdr tal))))
11210 29 29 29 29 0a 09 66 61 6c 6c 62 61 63 6b 2d 6c ))))..fallback-l
11220 61 75 6e 63 68 65 72 29 29 29 0a 20 20 0a 3b 3b auncher))). .;;
11230 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11240 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11250 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11260 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11270 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 ======.;; D A S
11280 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 55 20 H B O A R D U
11290 53 20 45 20 52 20 20 20 56 20 49 20 45 20 57 20 S E R V I E W
112a0 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
112b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
112c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
112d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
112e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 ==========..;; f
112f0 69 72 73 74 20 72 65 61 64 20 7e 2f 76 69 65 77 irst read ~/view
11300 73 2e 63 6f 6e 66 69 67 20 69 66 20 69 74 20 65 s.config if it e
11310 78 69 73 74 73 2c 20 74 68 65 6e 20 72 65 61 64 xists, then read
11320 20 24 4d 54 52 41 48 2f 76 69 65 77 73 2e 63 6f $MTRAH/views.co
11330 6e 66 69 67 20 69 66 20 69 74 20 65 78 69 73 74 nfig if it exist
11340 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f s.;;.(define (co
11350 6d 6d 6f 6e 3a 6c 6f 61 64 2d 76 69 65 77 73 2d mmon:load-views-
11360 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 config). (let*
11370 28 28 76 69 65 77 2d 63 66 67 64 61 74 20 20 20 ((view-cfgdat
11380 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
11390 65 29 29 0a 09 20 28 68 6f 6d 65 2d 63 66 67 66 e)).. (home-cfgf
113a0 69 6c 65 20 20 20 28 63 6f 6e 63 20 28 67 65 74 ile (conc (get
113b0 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
113c0 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f iable "HOME") "/
113d0 2e 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 .mtviews.config"
113e0 29 29 0a 09 20 28 6d 74 68 6f 6d 65 2d 63 66 67 )).. (mthome-cfg
113f0 66 69 6c 65 20 28 63 6f 6e 63 20 2a 74 6f 70 70 file (conc *topp
11400 61 74 68 2a 20 22 2f 2e 6d 74 76 69 65 77 73 2e ath* "/.mtviews.
11410 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 config"))). (
11420 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
11430 20 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 mthome-cfgfile)
11440 0a 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 6d ..(read-config m
11450 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 thome-cfgfile vi
11460 65 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 ew-cfgdat #t)).
11470 20 20 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 68 ;; we load th
11480 65 20 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 20 e home dir file
11490 41 46 54 45 52 20 74 68 65 20 4d 54 52 41 48 20 AFTER the MTRAH
114a0 66 69 6c 65 20 73 6f 20 74 68 65 20 75 73 65 72 file so the user
114b0 20 63 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 74 can clobber set
114c0 74 69 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e 69 tings when runni
114d0 6e 67 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 ng the dashboard
114e0 20 69 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 72 in read-only ar
114f0 65 61 73 0a 20 20 20 20 28 69 66 20 28 66 69 6c eas. (if (fil
11500 65 2d 65 78 69 73 74 73 3f 20 68 6f 6d 65 2d 63 e-exists? home-c
11510 66 67 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 fgfile)..(read-c
11520 6f 6e 66 69 67 20 68 6f 6d 65 2d 63 66 67 66 69 onfig home-cfgfi
11530 6c 65 20 76 69 65 77 2d 63 66 67 64 61 74 20 23 le view-cfgdat #
11540 74 29 29 0a 20 20 20 20 76 69 65 77 2d 63 66 67 t)). view-cfg
11550 64 61 74 29 29 0a 0a dat))..