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 72 65 61 64 2d 64 6f 74 73 65 erver:read-dotse
1770: 72 76 65 72 2d 3e 75 72 6c 20 2a 74 6f 70 70 61 rver->url *toppa
1780: 74 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 65 th*))) ;; (serve
1790: 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 r:check-if-runni
17a0: 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 20 23 66 ng *toppath*) #f
17b0: 29 29 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 65 )). (last-serve
17c0: 72 2d 63 68 65 63 6b 20 30 29 20 20 3b 3b 20 6c r-check 0) ;; l
17d0: 61 73 74 20 74 69 6d 65 20 77 65 20 63 68 65 63 ast time we chec
17e0: 6b 65 64 20 74 6f 20 73 65 65 20 69 66 20 74 68 ked to see if th
17f0: 65 20 73 65 72 76 65 72 20 77 61 73 20 61 6c 69 e server was ali
1800: 76 65 0a 20 20 28 63 6f 6e 6e 64 61 74 20 20 20 ve. (conndat
1810: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 74 #f). (t
1820: 72 61 6e 73 70 6f 72 74 20 20 20 20 20 20 20 20 ransport
1830: 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 *transport-type
1840: 2a 29 0a 20 20 28 73 65 72 76 65 72 2d 74 69 6d *). (server-tim
1850: 65 6f 75 74 20 20 20 20 28 6f 72 20 28 73 65 72 eout (or (ser
1860: 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 ver:get-timeout)
1870: 20 31 30 30 29 29 29 20 3b 3b 20 64 65 66 61 75 100))) ;; defau
1880: 6c 74 20 74 6f 20 31 30 30 20 73 65 63 6f 6e 64 lt to 100 second
1890: 73 0a 0a 3b 3b 20 6c 61 75 6e 63 68 69 6e 67 20 s..;; launching
18a0: 61 6e 64 20 68 6f 73 74 73 0a 28 64 65 66 73 74 and hosts.(defst
18b0: 72 75 63 74 20 68 6f 73 74 0a 20 20 28 72 65 61 ruct host. (rea
18c0: 63 68 61 62 6c 65 20 20 20 20 23 66 29 0a 20 20 chable #f).
18d0: 28 6c 61 73 74 2d 75 70 64 61 74 65 20 20 30 29 (last-update 0)
18e0: 0a 20 20 28 6c 61 73 74 2d 75 73 65 64 20 20 20 . (last-used
18f0: 20 30 29 0a 20 20 28 6c 61 73 74 2d 63 70 75 6c 0). (last-cpul
1900: 6f 61 64 20 31 29 29 0a 0a 28 64 65 66 69 6e 65 oad 1))..(define
1910: 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 20 20 *host-loads*
1920: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
1930: 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 -table))..;; cac
1940: 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 he environment v
1950: 61 72 73 20 66 6f 72 20 65 61 63 68 20 72 75 6e ars for each run
1960: 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 65 here.(define *e
1970: 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 nv-vars-by-run-i
1980: 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 d* (make-hash-ta
1990: 62 6c 65 29 29 0a 0a 3b 3b 20 54 65 73 74 63 6f ble))..;; Testco
19a0: 6e 66 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e 66 nfig and runconf
19b0: 69 67 20 63 61 63 68 65 73 2e 20 0a 28 64 65 66 ig caches. .(def
19c0: 69 6e 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 ine *testconfigs
19d0: 2a 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 * (make-h
19e0: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 ash-table)) ;; t
19f0: 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 est-name => test
1a00: 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 2a config.(define *
1a10: 72 75 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 runconfigs*
1a20: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1a30: 61 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 74 able)) ;; target
1a40: 20 20 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 => runconfig
1a50: 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 63 ..;; This is a c
1a60: 61 63 68 65 20 6f 66 20 70 72 65 2d 72 65 71 73 ache of pre-reqs
1a70: 20 6d 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d 63 met, don't re-c
1a80: 61 6c 63 20 69 6e 20 63 61 73 65 73 20 77 68 65 alc in cases whe
1a90: 72 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 73 re called with s
1aa0: 61 6d 65 20 70 61 72 61 6d 73 20 6c 65 73 73 20 ame params less
1ab0: 74 68 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 63 than.;; five sec
1ac0: 6f 6e 64 73 20 61 67 6f 0a 28 64 65 66 69 6e 65 onds ago.(define
1ad0: 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 *pre-reqs-met-c
1ae0: 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 ache* (make-hash
1af0: 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 -table))..;; cac
1b00: 68 65 20 6f 66 20 76 65 72 62 6f 73 69 74 79 20 he of verbosity
1b10: 67 69 76 65 6e 20 73 74 72 69 6e 67 0a 3b 3b 0a given string.;;.
1b20: 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 (define *verbosi
1b30: 74 79 2d 63 61 63 68 65 2a 20 20 20 20 28 6d 61 ty-cache* (ma
1b40: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1b50: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
1b60: 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 0a 20 :clear-caches).
1b70: 20 28 73 65 74 21 20 2a 74 61 72 67 65 74 2a 20 (set! *target*
1b80: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1b90: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1ba0: 20 28 73 65 74 21 20 2a 6b 65 79 73 2a 20 20 20 (set! *keys*
1bb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1bc0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1bd0: 20 28 73 65 74 21 20 2a 6b 65 79 76 61 6c 73 2a (set! *keyvals*
1be0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1bf0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1c00: 20 28 73 65 74 21 20 2a 74 6f 70 74 65 73 74 2d (set! *toptest-
1c10: 70 61 74 68 73 2a 20 20 20 20 20 20 28 6d 61 6b paths* (mak
1c20: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1c30: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 70 61 74 (set! *test-pat
1c40: 68 73 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b hs* (mak
1c50: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1c60: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 73 (set! *test-ids
1c70: 2a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b * (mak
1c80: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1c90: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 6e 66 (set! *test-inf
1ca0: 6f 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b o* (mak
1cb0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1cc0: 20 28 73 65 74 21 20 2a 72 75 6e 2d 69 6e 66 6f (set! *run-info
1cd0: 2d 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 6b -cache* (mak
1ce0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1cf0: 20 28 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 (set! *env-vars
1d00: 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 6b -by-run-id* (mak
1d10: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1d20: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 2d (set! *test-id-
1d30: 63 61 63 68 65 2a 20 20 20 20 20 20 28 6d 61 6b cache* (mak
1d40: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
1d50: 0a 3b 3b 20 47 65 6e 65 72 69 63 20 73 74 72 69 .;; Generic stri
1d60: 6e 67 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 ng database.(def
1d70: 69 6e 65 20 73 64 62 3a 71 72 79 20 23 66 29 20 ine sdb:qry #f)
1d80: 3b 3b 20 28 6d 61 6b 65 2d 73 64 62 3a 71 72 79 ;; (make-sdb:qry
1d90: 29 29 20 3b 3b 20 20 27 69 6e 69 74 20 23 66 29 )) ;; 'init #f)
1da0: 0a 3b 3b 20 47 65 6e 65 72 69 63 20 70 61 74 68 .;; Generic path
1db0: 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e database.(defin
1dc0: 65 20 2a 66 64 62 2a 20 23 66 29 0a 0a 28 64 65 e *fdb* #f)..(de
1dd0: 66 69 6e 65 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 fine *last-launc
1de0: 68 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f h* (current-seco
1df0: 6e 64 73 29 29 20 3b 3b 20 75 73 65 20 66 6f 72 nds)) ;; use for
1e00: 20 74 68 72 6f 74 74 6c 69 6e 67 20 74 68 65 20 throttling the
1e10: 6c 61 75 6e 63 68 20 72 61 74 65 2e 20 57 6f 75 launch rate. Wou
1e20: 6c 64 20 62 65 20 62 65 74 74 65 72 20 74 6f 20 ld be better to
1e30: 75 73 65 20 74 68 65 20 64 62 20 61 6e 64 20 6c use the db and l
1e40: 61 73 74 20 74 69 6d 65 20 6f 66 20 61 20 74 65 ast time of a te
1e50: 73 74 20 69 6e 20 4c 41 55 4e 43 48 45 44 20 73 st in LAUNCHED s
1e60: 74 61 74 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d tate...;;=======
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 3d 3d 3d 0a ===============.
1eb0: 3b 3b 20 56 20 45 20 52 20 53 20 49 20 4f 20 4e ;; V E R S I O N
1ec0: 0a 3b 3b 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 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
1f10: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 ne (common:get-f
1f20: 75 6c 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 ull-version). (
1f30: 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 conc megatest-ve
1f40: 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 rsion "-" megate
1f50: 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 st-fossil-hash))
1f60: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
1f70: 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 n:version-signat
1f80: 75 72 65 29 0a 20 20 28 63 6f 6e 63 20 6d 65 67 ure). (conc meg
1f90: 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d atest-version "-
1fa0: 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d 65 67 " (substring meg
1fb0: 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 atest-fossil-has
1fc0: 68 20 30 20 34 29 29 29 0a 0a 3b 3b 20 66 72 6f h 0 4)))..;; fro
1fd0: 6d 20 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 70 m metadat lookup
1fe0: 20 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f MEGATEST_VERSIO
1ff0: 4e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f N.;;.(define (co
2000: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
2010: 6e 2d 76 65 72 73 69 6f 6e 29 20 3b 3b 20 52 41 n-version) ;; RA
2020: 44 54 20 3d 3e 20 48 6f 77 20 64 6f 65 73 20 74 DT => How does t
2030: 68 69 73 20 77 6f 72 6b 20 69 6e 20 73 65 6e 64 his work in send
2040: 2d 72 65 63 65 69 76 65 20 66 75 6e 63 74 69 6f -receive functio
2050: 6e 3f 3f 3b 20 61 73 73 75 6d 65 20 69 74 20 69 n??; assume it i
2060: 73 20 74 68 65 20 76 61 6c 75 65 20 73 61 76 65 s the value save
2070: 64 20 69 6e 20 73 6f 6d 65 20 44 42 0a 20 20 28 d in some DB. (
2080: 72 6d 74 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 rmt:get-var "MEG
2090: 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 29 29 ATEST_VERSION"))
20a0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
20b0: 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:get-last-run-v
20c0: 65 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 ersion-number).
20d0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
20e0: 20 0a 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 . (substring
20f0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 (common:get-last
2100: 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 30 20 -run-version) 0
2110: 36 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6)))..(define (c
2120: 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 ommon:set-last-r
2130: 75 6e 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 72 un-version). (r
2140: 6d 74 3a 73 65 74 2d 76 61 72 20 22 4d 45 47 41 mt:set-var "MEGA
2150: 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 20 28 63 TEST_VERSION" (c
2160: 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 ommon:version-si
2170: 67 6e 61 74 75 72 65 29 29 29 0a 0a 28 64 65 66 gnature)))..(def
2180: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 ine (common:vers
2190: 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 ion-changed?).
21a0: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 63 6f (not (equal? (co
21b0: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
21c0: 6e 2d 76 65 72 73 69 6f 6e 29 0a 09 20 20 20 20 n-version)..
21d0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 (common:versi
21e0: 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 29 29 on-signature))))
21f0: 0a 0a 3b 3b 20 4d 6f 76 65 20 6d 65 20 65 6c 73 ..;; Move me els
2200: 65 77 68 65 72 65 20 2e 2e 2e 0a 3b 3b 20 52 41 ewhere ....;; RA
2210: 44 54 20 3d 3e 20 57 68 79 20 64 6f 20 77 65 20 DT => Why do we
2220: 6d 65 65 64 20 74 68 65 20 76 65 72 73 69 6f 6e meed the version
2230: 20 63 68 65 63 6b 20 68 65 72 65 2c 20 74 68 69 check here, thi
2240: 73 20 69 73 20 63 61 6c 6c 65 64 20 6f 6e 6c 79 s is called only
2250: 20 69 66 20 76 65 72 73 69 6f 6e 20 6d 69 73 6d if version mism
2260: 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f a.;;.(define (co
2270: 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 70 2d 64 62 20 mmon:cleanup-db
2280: 64 62 73 74 72 75 63 74 29 0a 20 20 28 64 62 3a dbstruct). (db:
2290: 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 0a 20 multi-db-sync .
22a0: 20 20 64 62 73 74 72 75 63 74 0a 20 20 20 3b 3b dbstruct. ;;
22b0: 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 27 6b 69 'new2old. 'ki
22c0: 6c 6c 73 65 72 76 65 72 73 0a 20 20 20 27 64 65 llservers. 'de
22d0: 6a 75 6e 6b 0a 20 20 20 3b 3b 20 27 61 64 6a 2d junk. ;; 'adj-
22e0: 74 65 73 74 69 64 73 0a 20 20 20 3b 3b 20 27 6f testids. ;; 'o
22f0: 6c 64 32 6e 65 77 0a 20 20 20 27 6e 65 77 32 6f ld2new. 'new2o
2300: 6c 64 0a 20 20 20 27 73 63 68 65 6d 61 29 0a 20 ld. 'schema).
2310: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 (if (common:ver
2320: 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 sion-changed?).
2330: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 (common:set
2340: 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f -last-run-versio
2350: 6e 29 29 29 0a 0a 3b 3b 20 52 6f 74 61 74 65 20 n)))..;; Rotate
2360: 6c 6f 67 73 2c 20 6c 6f 67 69 63 3a 20 0a 3b 3b logs, logic: .;;
2370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2380: 20 69 66 20 3e 20 35 30 30 6b 20 61 6e 64 20 6f if > 500k and o
2390: 6c 64 65 72 20 74 68 61 6e 20 31 20 77 65 65 6b lder than 1 week
23a0: 3a 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 :.;;
23b0: 20 20 20 20 20 20 20 20 20 72 65 6d 6f 76 65 20 remove
23c0: 70 72 65 76 69 6f 75 73 20 63 6f 6d 70 72 65 73 previous compres
23d0: 73 65 64 20 6c 6f 67 20 61 6e 64 20 63 6f 6d 70 sed log and comp
23e0: 72 65 73 73 20 74 68 69 73 20 6c 6f 67 0a 3b 3b ress this log.;;
23f0: 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 73 20 70 WARNING: This p
2400: 72 6f 63 20 6f 70 65 72 61 74 65 73 20 61 73 73 roc operates ass
2410: 75 6d 69 6e 67 20 74 68 61 74 20 69 74 20 69 73 uming that it is
2420: 20 69 6e 20 74 68 65 20 64 69 72 65 63 74 6f 72 in the director
2430: 79 20 61 62 6f 76 65 20 74 68 65 0a 3b 3b 20 20 y above the.;;
2440: 20 20 20 20 20 20 20 20 6c 6f 67 73 20 64 69 72 logs dir
2450: 65 63 74 6f 72 79 20 79 6f 75 20 77 69 73 68 20 ectory you wish
2460: 74 6f 20 6c 6f 67 2d 72 6f 74 61 74 65 2e 0a 3b to log-rotate..;
2470: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2480: 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 29 0a 20 n:rotate-logs).
2490: 20 28 69 66 20 28 6e 6f 74 20 28 64 69 72 65 63 (if (not (direc
24a0: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 22 6c 6f tory-exists? "lo
24b0: 67 73 22 29 29 28 63 72 65 61 74 65 2d 64 69 72 gs"))(create-dir
24c0: 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 29 29 0a ectory "logs")).
24d0: 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c (directory-fol
24e0: 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 66 d . (lambda (f
24f0: 69 6c 65 20 72 65 6d 29 0a 20 20 20 20 20 28 69 ile rem). (i
2500: 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 2d 6d f (and (string-m
2510: 61 74 63 68 20 22 5e 2e 2a 2e 6c 6f 67 22 20 66 atch "^.*.log" f
2520: 69 6c 65 29 0a 09 20 20 20 20 20 20 28 3e 20 28 ile).. (> (
2530: 66 69 6c 65 2d 73 69 7a 65 20 28 63 6f 6e 63 20 file-size (conc
2540: 22 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 20 32 "logs/" file)) 2
2550: 30 30 30 30 30 29 29 0a 09 20 28 6c 65 74 20 28 00000)).. (let (
2560: 28 67 7a 66 69 6c 65 20 28 63 6f 6e 63 20 22 6c (gzfile (conc "l
2570: 6f 67 73 2f 22 20 66 69 6c 65 20 22 2e 67 7a 22 ogs/" file ".gz"
2580: 29 29 29 0a 09 20 20 20 28 69 66 20 28 66 69 6c ))).. (if (fil
2590: 65 2d 65 78 69 73 74 73 3f 20 67 7a 66 69 6c 65 e-exists? gzfile
25a0: 29 0a 09 20 20 20 20 20 20 20 28 62 65 67 69 6e ).. (begin
25b0: 0a 09 09 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ... (debug:print
25c0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
25d0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 6d 6f -log-port* "remo
25e0: 76 69 6e 67 20 22 20 67 7a 66 69 6c 65 29 0a 09 ving " gzfile)..
25f0: 09 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 67 . (delete-file g
2600: 7a 66 69 6c 65 29 29 29 0a 09 20 20 20 28 64 65 zfile))).. (de
2610: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
2620: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2630: 72 74 2a 20 22 63 6f 6d 70 72 65 73 73 69 6e 67 rt* "compressing
2640: 20 22 20 66 69 6c 65 29 0a 09 20 20 20 28 73 79 " file).. (sy
2650: 73 74 65 6d 20 28 63 6f 6e 63 20 22 67 7a 69 70 stem (conc "gzip
2660: 20 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 29 29 logs/" file))))
2670: 29 0a 20 20 20 27 28 29 0a 20 20 20 22 6c 6f 67 ). '(). "log
2680: 73 22 29 29 0a 0a 3b 3b 20 46 6f 72 63 65 20 61 s"))..;; Force a
2690: 20 6d 65 67 61 74 65 73 74 20 63 6c 65 61 6e 75 megatest cleanu
26a0: 70 2d 64 62 20 69 66 20 76 65 72 73 69 6f 6e 20 p-db if version
26b0: 69 73 20 63 68 61 6e 67 65 64 20 61 6e 64 20 73 is changed and s
26c0: 6b 69 70 2d 76 65 72 73 69 6f 6e 2d 63 68 65 63 kip-version-chec
26d0: 6b 20 6e 6f 74 20 73 70 65 63 69 66 69 65 64 0a k not specified.
26e0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
26f0: 6f 6e 3a 65 78 69 74 2d 6f 6e 2d 76 65 72 73 69 on:exit-on-versi
2700: 6f 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 69 on-changed). (i
2710: 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f f (common:versio
2720: 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 20 20 n-changed?).
2730: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e (if (common:on
2740: 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 20 28 -homehost?).. (
2750: 6c 65 74 20 28 28 6d 74 63 6f 6e 66 20 28 63 6f let ((mtconf (co
2760: 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d nc (get-environm
2770: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 ent-variable "MT
2780: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 _RUN_AREA_HOME")
2790: 20 22 2f 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 "/megatest.conf
27a0: 69 67 22 29 29 0a 09 09 28 64 62 73 74 72 75 63 ig"))...(dbstruc
27b0: 74 20 28 64 62 3a 73 65 74 75 70 29 29 29 0a 09 t (db:setup)))..
27c0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
27d0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
27e0: 70 6f 72 74 2a 0a 09 09 09 20 22 57 41 52 4e 49 port*.... "WARNI
27f0: 4e 47 3a 20 56 65 72 73 69 6f 6e 20 6d 69 73 6d NG: Version mism
2800: 61 74 63 68 21 5c 6e 22 0a 09 09 09 20 22 20 20 atch!\n".... "
2810: 20 65 78 70 65 63 74 65 64 3a 20 22 20 28 63 6f expected: " (co
2820: 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 mmon:version-sig
2830: 6e 61 74 75 72 65 29 20 22 5c 6e 22 0a 09 09 09 nature) "\n"....
2840: 20 22 20 20 20 67 6f 74 3a 20 20 20 20 20 20 22 " got: "
2850: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
2860: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 29 0a t-run-version)).
2870: 09 20 20 20 20 28 69 66 20 28 61 6e 64 20 28 66 . (if (and (f
2880: 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 63 6f ile-exists? mtco
2890: 6e 66 29 0a 09 09 20 20 20 20 20 28 65 71 3f 20 nf)... (eq?
28a0: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 (current-user-id
28b0: 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 )(file-owner mtc
28c0: 6f 6e 66 29 29 29 20 3b 3b 20 73 61 66 65 20 74 onf))) ;; safe t
28d0: 6f 20 72 75 6e 20 2d 63 6c 65 61 6e 75 70 2d 64 o run -cleanup-d
28e0: 62 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 b...(begin... (
28f0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2900: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2910: 20 22 20 20 20 49 20 73 65 65 20 79 6f 75 20 61 " I see you a
2920: 72 65 20 74 68 65 20 6f 77 6e 65 72 20 6f 66 20 re the owner of
2930: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 2c megatest.config,
2940: 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 attempting to c
2950: 6c 65 61 6e 75 70 20 61 6e 64 20 72 65 73 65 74 leanup and reset
2960: 20 74 6f 20 6e 65 77 20 76 65 72 73 69 6f 6e 22 to new version"
2970: 29 0a 09 09 20 20 28 68 61 6e 64 6c 65 2d 65 78 )... (handle-ex
2980: 63 65 70 74 69 6f 6e 73 0a 09 09 20 20 20 65 78 ceptions... ex
2990: 6e 0a 09 09 20 20 20 28 62 65 67 69 6e 0a 09 09 n... (begin...
29a0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
29b0: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
29c0: 2d 70 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 74 -port* "Failed t
29d0: 6f 20 73 77 69 74 63 68 20 76 65 72 73 69 6f 6e o switch version
29e0: 73 2e 22 29 0a 09 09 20 20 20 20 20 28 64 65 62 s.")... (deb
29f0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
2a00: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
2a10: 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
2a20: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
2a30: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
2a40: 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 essage) exn))...
2a50: 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c (print-call
2a60: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
2a70: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 09 09 20 error-port))...
2a80: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 09 09 (exit 1))...
2a90: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e (common:clean
2aa0: 75 70 2d 64 62 20 64 62 73 74 72 75 63 74 29 29 up-db dbstruct))
2ab0: 29 0a 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 )...(begin... (
2ac0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2ad0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2ae0: 20 22 20 74 6f 20 73 77 69 74 63 68 20 76 65 72 " to switch ver
2af0: 73 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 72 75 sions you can ru
2b00: 6e 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 2d 63 n: \"megatest -c
2b10: 6c 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a 09 09 leanup-db\"")...
2b20: 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 20 (exit 1))))..
2b30: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 65 (begin.. (de
2b40: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
2b50: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
2b60: 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 6d 69 ERROR: cannot mi
2b70: 67 72 61 74 65 20 76 65 72 73 69 6f 6e 20 75 6e grate version un
2b80: 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 less on homehost
2b90: 2e 20 45 78 69 74 69 6e 67 2e 22 29 0a 09 20 20 . Exiting.")..
2ba0: 20 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 0a (exit 1)))))..
2bb0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
2bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2bf0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 50 20 ========.;; S P
2c00: 41 20 52 20 53 20 45 20 20 20 41 20 52 20 52 20 A R S E A R R
2c10: 41 20 59 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d A Y S.;;========
2c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
2c60: 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 70 (define (make-sp
2c70: 61 72 73 65 2d 61 72 72 61 79 29 0a 20 20 28 6c arse-array). (l
2c80: 65 74 20 28 28 61 20 28 6d 61 6b 65 2d 73 70 61 et ((a (make-spa
2c90: 72 73 65 2d 76 65 63 74 6f 72 29 29 29 0a 20 20 rse-vector))).
2ca0: 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 (sparse-vector
2cb0: 2d 73 65 74 21 20 61 20 30 20 28 6d 61 6b 65 2d -set! a 0 (make-
2cc0: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 0a sparse-vector)).
2cd0: 20 20 20 20 61 29 29 0a 0a 28 64 65 66 69 6e 65 a))..(define
2ce0: 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 3f 20 (sparse-array?
2cf0: 61 29 0a 20 20 28 61 6e 64 20 28 73 70 61 72 73 a). (and (spars
2d00: 65 2d 76 65 63 74 6f 72 3f 20 61 29 0a 20 20 20 e-vector? a).
2d10: 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 (sparse-vect
2d20: 6f 72 3f 20 28 73 70 61 72 73 65 2d 76 65 63 74 or? (sparse-vect
2d30: 6f 72 2d 72 65 66 20 61 20 30 29 29 29 29 0a 0a or-ref a 0))))..
2d40: 28 64 65 66 69 6e 65 20 28 73 70 61 72 73 65 2d (define (sparse-
2d50: 61 72 72 61 79 2d 72 65 66 20 61 20 78 20 79 29 array-ref a x y)
2d60: 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 . (let ((row (s
2d70: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 parse-vector-ref
2d80: 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 a x))). (if
2d90: 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 row..(sparse-vec
2da0: 74 6f 72 2d 72 65 66 20 72 6f 77 20 79 29 0a 09 tor-ref row y)..
2db0: 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)))..(define (
2dc0: 73 70 61 72 73 65 2d 61 72 72 61 79 2d 73 65 74 sparse-array-set
2dd0: 21 20 61 20 78 20 79 20 76 61 6c 29 0a 20 20 28 ! a x y val). (
2de0: 6c 65 74 20 28 28 72 6f 77 20 28 73 70 61 72 73 let ((row (spars
2df0: 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 78 e-vector-ref a x
2e00: 29 29 29 0a 20 20 20 20 28 69 66 20 72 6f 77 0a ))). (if row.
2e10: 09 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d .(sparse-vector-
2e20: 73 65 74 21 20 72 6f 77 20 79 20 76 61 6c 29 0a set! row y val).
2e30: 09 28 6c 65 74 20 28 28 6e 65 77 2d 72 6f 77 20 .(let ((new-row
2e40: 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 (make-sparse-vec
2e50: 74 6f 72 29 29 29 0a 09 20 20 28 73 70 61 72 73 tor))).. (spars
2e60: 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 61 20 e-vector-set! a
2e70: 78 20 6e 65 77 2d 72 6f 77 29 0a 09 20 20 28 73 x new-row).. (s
2e80: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 parse-vector-set
2e90: 21 20 6e 65 77 2d 72 6f 77 20 79 20 76 61 6c 29 ! new-row y val)
2ea0: 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ))))..;;========
2eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
2ef0: 3b 20 4c 20 4f 20 43 20 4b 20 45 20 52 20 53 20 ; L O C K E R S
2f00: 20 20 41 20 4e 20 44 20 20 20 42 20 4c 20 4f 20 A N D B L O
2f10: 43 20 4b 20 45 20 52 20 53 20 0a 3b 3b 3d 3d 3d C K E R S .;;===
2f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 20 62 6c 6f 63 6b 20 66 75 ===..;; block fu
2f70: 72 74 68 65 72 20 61 63 63 65 73 73 65 73 20 74 rther accesses t
2f80: 6f 20 64 61 74 61 62 61 73 65 73 2e 20 43 61 6c o databases. Cal
2f90: 6c 20 74 68 69 73 20 62 65 66 6f 72 65 20 73 68 l this before sh
2fa0: 75 74 74 69 6e 67 20 64 62 20 64 6f 77 6e 0a 28 utting db down.(
2fb0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 define (common:d
2fc0: 62 2d 62 6c 6f 63 6b 2d 66 75 72 74 68 65 72 2d b-block-further-
2fd0: 71 75 65 72 69 65 73 29 0a 20 20 28 6d 75 74 65 queries). (mute
2fe0: 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 x-lock! *db-acce
2ff0: 73 73 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 65 ss-mutex*). (se
3000: 74 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c t! *db-access-al
3010: 6c 6f 77 65 64 2a 20 23 66 29 0a 20 20 28 6d 75 lowed* #f). (mu
3020: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d tex-unlock! *db-
3030: 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 29 0a access-mutex*)).
3040: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
3050: 3a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 :db-access-allow
3060: 65 64 3f 29 0a 20 20 28 6c 65 74 20 28 28 76 61 ed?). (let ((va
3070: 6c 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 l (begin..
3080: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 (mutex-lock! *d
3090: 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 b-access-mutex*)
30a0: 0a 09 20 20 20 20 20 20 20 2a 64 62 2d 61 63 63 .. *db-acc
30b0: 65 73 73 2d 61 6c 6c 6f 77 65 64 2a 0a 09 20 20 ess-allowed*..
30c0: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
30d0: 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d ck! *db-access-m
30e0: 75 74 65 78 2a 29 29 29 29 0a 20 20 20 20 76 61 utex*)))). va
30f0: 6c 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d l))..;;=========
3100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
3140: 20 55 20 53 20 45 20 46 20 55 20 4c 20 20 20 53 U S E F U L S
3150: 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d T U F F.;;=====
3160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31a0: 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 74 68 =..;; convert th
31b0: 69 6e 67 73 20 74 6f 20 61 6e 20 61 6c 69 73 74 ings to an alist
31c0: 20 6f 72 20 61 73 73 6f 63 20 6c 69 73 74 2c 20 or assoc list,
31d0: 23 66 20 67 65 74 73 20 63 6f 6e 76 65 72 74 65 #f gets converte
31e0: 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 65 66 69 d to "".;;.(defi
31f0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c ne (common:to-al
3200: 69 73 74 20 64 61 74 29 0a 20 20 28 63 6f 6e 64 ist dat). (cond
3210: 0a 20 20 20 28 28 6c 69 73 74 3f 20 64 61 74 29 . ((list? dat)
3220: 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 (map common:t
3230: 6f 2d 61 6c 69 73 74 20 64 61 74 29 29 0a 20 20 o-alist dat)).
3240: 20 28 28 76 65 63 74 6f 72 3f 20 64 61 74 29 0a ((vector? dat).
3250: 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a (map common:
3260: 74 6f 2d 61 6c 69 73 74 20 28 76 65 63 74 6f 72 to-alist (vector
3270: 2d 3e 6c 69 73 74 20 64 61 74 29 29 29 0a 20 20 ->list dat))).
3280: 20 28 28 70 61 69 72 3f 20 64 61 74 29 0a 20 20 ((pair? dat).
3290: 20 20 28 63 6f 6e 73 20 28 63 6f 6d 6d 6f 6e 3a (cons (common:
32a0: 74 6f 2d 61 6c 69 73 74 20 28 63 61 72 20 64 61 to-alist (car da
32b0: 74 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 74 t)).. (common:t
32c0: 6f 2d 61 6c 69 73 74 20 28 63 64 72 20 64 61 74 o-alist (cdr dat
32d0: 29 29 29 29 0a 20 20 20 28 28 68 61 73 68 2d 74 )))). ((hash-t
32e0: 61 62 6c 65 3f 20 64 61 74 29 0a 20 20 20 20 28 able? dat). (
32f0: 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c map common:to-al
3300: 69 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ist (hash-table-
3310: 3e 61 6c 69 73 74 20 64 61 74 29 29 29 0a 20 20 >alist dat))).
3320: 20 28 65 6c 73 65 0a 20 20 20 20 28 69 66 20 64 (else. (if d
3330: 61 74 0a 09 64 61 74 0a 09 22 22 29 29 29 29 0a at..dat.."")))).
3340: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
3350: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
3360: 20 77 61 69 74 76 61 6c 20 2e 20 6b 65 79 73 29 waitval . keys)
3370: 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 . (let* ((key
3380: 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
3390: 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 6f 6e rsperse (map con
33a0: 63 20 6b 65 79 73 29 20 22 2d 22 20 29 29 0a 09 c keys) "-" ))..
33b0: 20 28 6c 61 73 74 74 69 6d 65 20 28 68 61 73 68 (lasttime (hash
33c0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
33d0: 6c 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 lt *common:denoi
33e0: 73 65 2a 20 6b 65 79 20 30 29 29 0a 09 20 28 63 se* key 0)).. (c
33f0: 75 72 72 74 69 6d 65 20 28 63 75 72 72 65 6e 74 urrtime (current
3400: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 -seconds))).
3410: 28 69 66 20 28 3e 20 28 2d 20 63 75 72 72 74 69 (if (> (- currti
3420: 6d 65 20 6c 61 73 74 74 69 6d 65 29 20 77 61 69 me lasttime) wai
3430: 74 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 tval)..(begin..
3440: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
3450: 21 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 ! *common:denois
3460: 65 2a 20 6b 65 79 20 63 75 72 72 74 69 6d 65 29 e* key currtime)
3470: 0a 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a .. #t)..#f)))..
3480: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
3490: 67 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 get-megatest-exe
34a0: 29 0a 20 20 28 6f 72 20 28 67 65 74 65 6e 76 20 ). (or (getenv
34b0: 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 29 20 22 "MT_MEGATEST") "
34c0: 6d 65 67 61 74 65 73 74 22 29 29 0a 0a 28 64 65 megatest"))..(de
34d0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 fine (common:rea
34e0: 64 2d 65 6e 63 6f 64 65 64 2d 73 74 72 69 6e 67 d-encoded-string
34f0: 20 69 6e 73 74 72 29 0a 20 20 28 68 61 6e 64 6c instr). (handl
3500: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
3510: 65 78 6e 0a 20 20 20 28 68 61 6e 64 6c 65 2d 65 exn. (handle-e
3520: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 65 78 xceptions. ex
3530: 6e 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 n. (begin.
3540: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
3550: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
3560: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 65 -log-port* "rece
3570: 69 76 65 64 20 62 61 64 20 65 6e 63 6f 64 65 64 ived bad encoded
3580: 20 73 74 72 69 6e 67 20 5c 22 22 20 69 6e 73 74 string \"" inst
3590: 72 20 22 5c 22 2c 20 6d 65 73 73 61 67 65 3a 20 r "\", message:
35a0: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
35b0: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
35c0: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
35d0: 78 6e 29 29 0a 20 20 20 20 20 20 28 70 72 69 6e xn)). (prin
35e0: 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 t-call-chain (cu
35f0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
3600: 29 29 0a 20 20 20 20 20 20 23 66 29 0a 20 20 20 )). #f).
3610: 20 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 (read (open-inp
3620: 75 74 2d 73 74 72 69 6e 67 20 28 62 61 73 65 36 ut-string (base6
3630: 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 4:base64-decode
3640: 69 6e 73 74 72 29 29 29 29 0a 20 20 20 28 72 65 instr)))). (re
3650: 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 ad (open-input-s
3660: 74 72 69 6e 67 20 28 7a 33 3a 64 65 63 6f 64 65 tring (z3:decode
3670: 2d 62 75 66 66 65 72 20 28 62 61 73 65 36 34 3a -buffer (base64:
3680: 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 6e base64-decode in
3690: 73 74 72 29 29 29 29 29 29 0a 0a 3b 3b 20 64 6f str))))))..;; do
36a0: 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 20 73 65 t-locking egg se
36b0: 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c ems not to work,
36c0: 20 75 73 69 6e 67 20 74 68 69 73 20 66 6f 72 20 using this for
36d0: 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 now.;; if lock i
36e0: 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 65 78 70 s older than exp
36f0: 69 72 65 2d 74 69 6d 65 20 74 68 65 6e 20 72 65 ire-time then re
3700: 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 72 79 20 move it and try
3710: 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 again.;; to get
3720: 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 the lock.;;.(def
3730: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 ine (common:simp
3740: 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 le-file-lock fna
3750: 6d 65 20 23 21 6b 65 79 20 28 65 78 70 69 72 65 me #!key (expire
3760: 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 69 -time 300)). (i
3770: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
3780: 66 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 69 66 fname). (if
3790: 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d (> (- (current-
37a0: 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f seconds)(file-mo
37b0: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
37c0: 66 6e 61 6d 65 29 29 20 65 78 70 69 72 65 2d 74 fname)) expire-t
37d0: 69 6d 65 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 ime).. (begin..
37e0: 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 (delete-file
37f0: 2a 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 28 63 * fname).. (c
3800: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
3810: 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 e-lock fname exp
3820: 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 ire-time: expire
3830: 2d 74 69 6d 65 29 29 0a 09 20 20 23 66 29 0a 20 -time)).. #f).
3840: 20 20 20 20 20 28 6c 65 74 20 28 28 6b 65 79 2d (let ((key-
3850: 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 67 65 string (conc (ge
3860: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d 22 t-host-name) "-"
3870: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
3880: 73 2d 69 64 29 29 29 29 0a 09 28 77 69 74 68 2d s-id))))..(with-
3890: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 66 output-to-file f
38a0: 6e 61 6d 65 0a 09 20 20 28 6c 61 6d 62 64 61 20 name.. (lambda
38b0: 28 29 0a 09 20 20 20 20 28 70 72 69 6e 74 20 6b ().. (print k
38c0: 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 28 74 ey-string)))..(t
38d0: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 hread-sleep! 0.2
38e0: 35 29 0a 09 28 69 66 20 28 66 69 6c 65 2d 65 78 5)..(if (file-ex
38f0: 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 20 20 ists? fname)..
3900: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
3910: 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 om-file fname..
3920: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
3930: 09 09 28 65 71 75 61 6c 3f 20 6b 65 79 2d 73 74 ..(equal? key-st
3940: 72 69 6e 67 20 28 72 65 61 64 2d 6c 69 6e 65 29 ring (read-line)
3950: 29 29 29 0a 09 20 20 20 20 23 66 29 29 29 29 0a ))).. #f)))).
3960: 09 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
3970: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 n:simple-file-re
3980: 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 lease-lock fname
3990: 29 0a 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 ). (delete-file
39a0: 2a 20 66 6e 61 6d 65 29 29 0a 0a 3b 3b 3d 3d 3d * fname))..;;===
39b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39f0: 3d 3d 3d 0a 3b 3b 20 53 20 54 20 41 20 54 20 45 ===.;; S T A T E
3a00: 20 53 20 20 20 41 20 4e 20 44 20 20 20 53 20 54 S A N D S T
3a10: 20 41 20 54 20 55 20 53 20 45 20 53 0a 3b 3b 3d A T U S E S.;;=
3a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a60: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a =====..(define *
3a70: 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 65 common:std-state
3a80: 73 2a 20 20 20 0a 20 20 27 28 28 30 20 22 41 52 s* . '((0 "AR
3a90: 43 48 49 56 45 44 22 29 0a 20 20 20 20 28 31 20 CHIVED"). (1
3aa0: 22 53 54 55 43 4b 22 29 0a 20 20 20 20 28 32 20 "STUCK"). (2
3ab0: 22 4b 49 4c 4c 52 45 51 22 29 0a 20 20 20 20 28 "KILLREQ"). (
3ac0: 33 20 22 4b 49 4c 4c 45 44 22 29 0a 20 20 20 20 3 "KILLED").
3ad0: 28 34 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 (4 "NOT_STARTED"
3ae0: 29 0a 20 20 20 20 28 35 20 22 43 4f 4d 50 4c 45 ). (5 "COMPLE
3af0: 54 45 44 22 29 0a 20 20 20 20 28 36 20 22 4c 41 TED"). (6 "LA
3b00: 55 4e 43 48 45 44 22 29 0a 20 20 20 20 28 37 20 UNCHED"). (7
3b10: 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 "REMOTEHOSTSTART
3b20: 22 29 0a 20 20 20 20 28 38 20 22 52 55 4e 4e 49 "). (8 "RUNNI
3b30: 4e 47 22 29 0a 20 20 20 20 29 29 0a 0a 28 64 65 NG"). ))..(de
3b40: 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 fine *common:std
3b50: 2d 73 74 61 74 75 73 65 73 2a 0a 20 20 27 28 3b -statuses*. '(;
3b60: 3b 20 28 30 20 22 44 45 4c 45 54 45 44 22 29 0a ; (0 "DELETED").
3b70: 20 20 20 20 28 31 20 22 6e 2f 61 22 29 0a 20 20 (1 "n/a").
3b80: 20 20 28 32 20 22 50 41 53 53 22 29 0a 20 20 20 (2 "PASS").
3b90: 20 28 33 20 22 43 48 45 43 4b 22 29 0a 20 20 20 (3 "CHECK").
3ba0: 20 28 34 20 22 53 4b 49 50 22 29 0a 20 20 20 20 (4 "SKIP").
3bb0: 28 35 20 22 57 41 52 4e 22 29 0a 20 20 20 20 28 (5 "WARN"). (
3bc0: 36 20 22 57 41 49 56 45 44 22 29 0a 20 20 20 20 6 "WAIVED").
3bd0: 28 37 20 22 53 54 55 43 4b 2f 44 45 41 44 22 29 (7 "STUCK/DEAD")
3be0: 0a 20 20 20 20 28 38 20 22 46 41 49 4c 22 29 0a . (8 "FAIL").
3bf0: 20 20 20 20 28 39 20 22 41 42 4f 52 54 22 29 29 (9 "ABORT"))
3c00: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d )..(define *comm
3c10: 6f 6e 3a 65 6e 64 65 64 2d 73 74 61 74 65 73 2a on:ended-states*
3c20: 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 65 73 ;; states
3c30: 20 77 68 69 63 68 20 69 6e 64 69 63 61 74 65 20 which indicate
3c40: 74 68 65 20 74 65 73 74 20 69 73 20 73 74 6f 70 the test is stop
3c50: 70 65 64 20 61 6e 64 20 77 69 6c 6c 20 6e 6f 74 ped and will not
3c60: 20 70 72 6f 63 65 65 64 0a 20 20 27 28 22 43 4f proceed. '("CO
3c70: 4d 50 4c 45 54 45 44 22 20 22 41 52 43 48 49 56 MPLETED" "ARCHIV
3c80: 45 44 22 20 22 4b 49 4c 4c 45 44 22 20 22 4b 49 ED" "KILLED" "KI
3c90: 4c 4c 52 45 51 22 20 22 53 54 55 43 4b 22 20 22 LLREQ" "STUCK" "
3ca0: 49 4e 43 4f 4d 50 4c 45 54 45 22 29 29 0a 0a 28 INCOMPLETE"))..(
3cb0: 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 62 define *common:b
3cc0: 61 64 6c 79 2d 65 6e 64 65 64 2d 73 74 61 74 65 adly-ended-state
3cd0: 73 2a 20 3b 3b 20 74 68 65 73 65 20 72 6f 6c 6c s* ;; these roll
3ce0: 20 75 70 20 61 73 20 43 48 45 43 4b 2c 20 69 2e up as CHECK, i.
3cf0: 65 2e 20 72 65 73 75 6c 74 73 20 6e 65 65 64 20 e. results need
3d00: 74 6f 20 62 65 20 63 68 65 63 6b 65 64 0a 20 20 to be checked.
3d10: 27 28 22 4b 49 4c 4c 45 44 22 20 22 4b 49 4c 4c '("KILLED" "KILL
3d20: 52 45 51 22 20 22 53 54 55 43 4b 22 20 22 49 4e REQ" "STUCK" "IN
3d30: 43 4f 4d 50 4c 45 54 45 22 20 22 44 45 41 44 22 COMPLETE" "DEAD"
3d40: 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d ))..(define *com
3d50: 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 61 74 mon:running-stat
3d60: 65 73 2a 20 20 20 20 20 3b 3b 20 74 65 73 74 20 es* ;; test
3d70: 69 73 20 65 69 74 68 65 72 20 72 75 6e 6e 69 6e is either runnin
3d80: 67 20 6f 72 20 63 61 6e 20 62 65 20 72 75 6e 0a g or can be run.
3d90: 20 20 27 28 22 52 55 4e 4e 49 4e 47 22 20 22 52 '("RUNNING" "R
3da0: 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 EMOTEHOSTSTART"
3db0: 22 4c 41 55 4e 43 48 45 44 22 29 29 0a 0a 28 64 "LAUNCHED"))..(d
3dc0: 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 63 61 efine *common:ca
3dd0: 6e 74 2d 72 75 6e 2d 73 74 61 74 65 73 2a 20 20 nt-run-states*
3de0: 20 20 3b 3b 20 54 68 65 73 65 20 61 72 65 20 73 ;; These are s
3df0: 74 6f 70 70 69 6e 67 20 63 6f 6e 64 69 74 69 6f topping conditio
3e00: 6e 73 20 74 68 61 74 20 70 72 65 76 65 6e 74 20 ns that prevent
3e10: 61 20 74 65 73 74 20 66 72 6f 6d 20 62 65 69 6e a test from bein
3e20: 67 20 72 75 6e 0a 20 20 27 28 22 43 4f 4d 50 4c g run. '("COMPL
3e30: 45 54 45 44 22 20 22 4b 49 4c 4c 45 44 22 20 22 ETED" "KILLED" "
3e40: 55 4e 4b 4e 4f 57 4e 22 20 22 49 4e 43 4f 4d 50 UNKNOWN" "INCOMP
3e50: 4c 45 54 45 22 20 22 41 52 43 48 49 56 45 44 22 LETE" "ARCHIVED"
3e60: 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d ))..(define *com
3e70: 6d 6f 6e 3a 6e 6f 74 2d 73 74 61 72 74 65 64 2d mon:not-started-
3e80: 6f 6b 2d 73 74 61 74 75 73 65 73 2a 20 3b 3b 20 ok-statuses* ;;
3e90: 69 66 20 6e 6f 74 20 6f 6e 65 20 6f 66 20 74 68 if not one of th
3ea0: 65 73 65 20 73 74 61 74 75 73 65 73 20 77 68 65 ese statuses whe
3eb0: 6e 20 69 6e 20 6e 6f 74 5f 73 74 61 72 74 65 64 n in not_started
3ec0: 20 73 74 61 74 65 20 74 72 65 61 74 20 61 73 20 state treat as
3ed0: 64 65 61 64 0a 20 20 27 28 22 6e 2f 61 22 20 22 dead. '("n/a" "
3ee0: 6e 61 22 20 22 50 41 53 53 22 20 22 46 41 49 4c na" "PASS" "FAIL
3ef0: 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b 22 " "WARN" "CHECK"
3f00: 20 22 57 41 49 56 45 44 22 20 22 44 45 41 44 22 "WAIVED" "DEAD"
3f10: 20 22 53 4b 49 50 22 29 29 0a 0a 28 64 65 66 69 "SKIP"))..(defi
3f20: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 70 65 63 69 ne (common:speci
3f30: 61 6c 2d 73 6f 72 74 20 69 74 65 6d 73 20 6f 72 al-sort items or
3f40: 64 65 72 20 63 6f 6d 70 29 0a 20 20 28 6c 65 74 der comp). (let
3f50: 20 28 28 69 74 65 6d 73 2d 6f 72 64 65 72 20 28 ((items-order (
3f60: 6d 61 70 20 72 65 76 65 72 73 65 20 6f 72 64 65 map reverse orde
3f70: 72 29 29 0a 20 20 20 20 20 20 20 20 28 61 63 6f r)). (aco
3f80: 6d 70 20 20 20 20 20 20 20 28 6f 72 20 63 6f 6d mp (or com
3f90: 70 20 3e 29 29 29 0a 20 20 20 20 28 73 6f 72 74 p >))). (sort
3fa0: 20 69 74 65 6d 73 0a 20 20 20 20 20 20 20 20 28 items. (
3fb0: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 20 20 lambda (a b).
3fc0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 61 2d (let ((a-
3fd0: 6e 75 6d 20 28 63 61 64 72 20 28 6f 72 20 28 61 num (cadr (or (a
3fe0: 73 73 6f 63 20 61 20 69 74 65 6d 73 2d 6f 72 64 ssoc a items-ord
3ff0: 65 72 29 20 27 28 30 20 30 29 29 29 29 0a 20 20 er) '(0 0)))).
4000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
4010: 2d 6e 75 6d 20 28 63 61 64 72 20 28 6f 72 20 28 -num (cadr (or (
4020: 61 73 73 6f 63 20 62 20 69 74 65 6d 73 2d 6f 72 assoc b items-or
4030: 64 65 72 29 20 27 28 30 20 30 29 29 29 29 29 0a der) '(0 0))))).
4040: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 63 6f (aco
4050: 6d 70 20 61 2d 6e 75 6d 20 62 2d 6e 75 6d 29 29 mp a-num b-num))
4060: 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 67 69 76 65 ))))..;; ;; give
4070: 6e 20 61 20 74 6f 70 6c 65 76 65 6c 20 77 69 74 n a toplevel wit
4080: 68 20 63 75 72 72 73 74 61 74 65 2c 20 63 75 72 h currstate, cur
4090: 72 73 74 61 74 75 73 20 61 70 70 6c 79 20 73 74 rstatus apply st
40a0: 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 0a 3b ate and status.;
40b0: 3b 20 3b 3b 20 20 3d 3e 20 28 6e 65 77 73 74 61 ; ;; => (newsta
40c0: 74 65 20 2e 20 6e 65 77 73 74 61 74 75 73 29 0a te . newstatus).
40d0: 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;; (define (comm
40e0: 6f 6e 3a 61 70 70 6c 79 2d 73 74 61 74 65 2d 73 on:apply-state-s
40f0: 74 61 74 75 73 20 63 75 72 72 73 74 61 74 65 20 tatus currstate
4100: 63 75 72 72 73 74 61 74 75 73 20 73 74 61 74 65 currstatus state
4110: 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 28 6c status).;; (l
4120: 65 74 2a 20 28 28 63 73 74 61 74 65 20 20 28 73 et* ((cstate (s
4130: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 tring->symbol (s
4140: 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 63 tring-downcase c
4150: 75 72 72 73 74 61 74 65 29 29 29 0a 3b 3b 20 20 urrstate))).;;
4160: 20 20 20 20 20 20 20 20 28 63 73 74 61 74 75 73 (cstatus
4170: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
4180: 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 (string-downcas
4190: 65 20 63 75 72 72 73 74 61 74 75 73 29 29 29 0a e currstatus))).
41a0: 3b 3b 20 20 20 20 20 20 20 20 20 20 28 73 73 74 ;; (sst
41b0: 61 74 65 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 ate (string->sy
41c0: 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 mbol (string-dow
41d0: 6e 63 61 73 65 20 73 74 61 74 65 29 29 29 0a 3b ncase state))).;
41e0: 3b 20 20 20 20 20 20 20 20 20 20 28 73 73 74 61 ; (ssta
41f0: 74 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d tus (string->sym
4200: 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e bol (string-down
4210: 63 61 73 65 20 73 74 61 74 75 73 29 29 29 0a 3b case status))).;
4220: 3b 20 20 20 20 20 20 20 20 20 20 28 6e 73 74 61 ; (nsta
4230: 74 65 20 20 23 66 29 0a 3b 3b 20 20 20 20 20 20 te #f).;;
4240: 20 20 20 20 28 6e 73 74 61 74 75 73 20 23 66 29 (nstatus #f)
4250: 29 0a 3b 3b 20 20 20 20 20 28 73 65 74 21 20 6e ).;; (set! n
4260: 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 state.;;
4270: 20 20 20 28 63 61 73 65 20 63 73 74 61 74 65 0a (case cstate.
4280: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ;; (
4290: 28 63 6f 6d 70 6c 65 74 65 64 20 6e 6f 74 5f 73 (completed not_s
42a0: 74 61 72 74 65 64 20 6b 69 6c 6c 65 64 20 6b 69 tarted killed ki
42b0: 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 72 63 68 llreq stuck arch
42c0: 69 76 65 64 29 20 0a 3b 3b 20 20 20 20 20 20 20 ived) .;;
42d0: 20 20 20 20 20 20 20 28 63 61 73 65 20 73 73 74 (case sst
42e0: 61 74 65 20 3b 3b 20 63 6f 6d 70 6c 65 74 65 64 ate ;; completed
42f0: 20 2d 3e 20 73 73 74 61 74 65 0a 3b 3b 20 20 20 -> sstate.;;
4300: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 ((c
4310: 6f 6d 70 6c 65 74 65 64 20 6b 69 6c 6c 65 64 20 ompleted killed
4320: 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 72 killreq stuck ar
4330: 63 68 69 76 65 64 29 20 63 6f 6d 70 6c 65 74 65 chived) complete
4340: 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 d).;;
4350: 20 20 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 ((running r
4360: 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 20 6c emotehoststart l
4370: 61 75 6e 63 68 65 64 29 20 20 20 20 20 20 20 20 aunched)
4380: 72 75 6e 6e 69 6e 67 29 0a 3b 3b 20 20 20 20 20 running).;;
4390: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
43a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
43c0: 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 unknown-er
43d0: 72 6f 72 2d 31 29 29 29 0a 3b 3b 20 20 20 20 20 ror-1))).;;
43e0: 20 20 20 20 20 20 20 20 28 28 72 75 6e 6e 69 6e ((runnin
43f0: 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 g remotehoststar
4400: 74 20 6c 61 75 6e 63 68 65 64 29 0a 3b 3b 20 20 t launched).;;
4410: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 (cas
4420: 65 20 73 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 e sstate.;;
4430: 20 20 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d ((com
4440: 70 6c 65 74 65 64 20 6b 69 6c 6c 65 64 20 6b 69 pleted killed ki
4450: 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 72 63 68 llreq stuck arch
4460: 69 76 65 64 29 20 23 66 29 20 3b 3b 20 6e 65 65 ived) #f) ;; nee
4470: 64 20 74 6f 20 6c 6f 6f 6b 20 61 74 20 61 6c 6c d to look at all
4480: 20 69 74 65 6d 73 0a 3b 3b 20 20 20 20 20 20 20 items.;;
4490: 20 20 20 20 20 20 20 20 20 28 28 72 75 6e 6e 69 ((runni
44a0: 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 ng remotehoststa
44b0: 72 74 20 6c 61 75 6e 63 68 65 64 29 20 20 20 20 rt launched)
44c0: 20 20 20 20 72 75 6e 6e 69 6e 67 29 0a 3b 3b 20 running).;;
44d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
44e0: 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 else
44f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4500: 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 unknow
4510: 6e 2d 65 72 72 6f 72 2d 32 29 29 29 0a 3b 3b 20 n-error-2))).;;
4520: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
4530: 65 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d e unknown-error-
4540: 33 29 29 29 0a 3b 3b 20 20 20 20 20 28 73 65 74 3))).;; (set
4550: 21 20 6e 73 74 61 74 75 73 0a 3b 3b 20 20 20 20 ! nstatus.;;
4560: 20 20 20 20 20 20 20 28 63 61 73 65 20 73 73 74 (case sst
4570: 61 74 75 73 0a 3b 3b 20 20 20 20 20 20 20 20 20 atus.;;
4580: 20 20 20 20 28 28 70 61 73 73 29 0a 3b 3b 20 20 ((pass).;;
4590: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 (cas
45a0: 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 e nstate.;;
45b0: 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 73 ((pas
45c0: 73 20 6e 2f 61 20 64 65 6c 65 74 65 64 29 20 20 s n/a deleted)
45d0: 20 20 20 70 61 73 73 29 0a 3b 3b 20 20 20 20 20 pass).;;
45e0: 20 20 20 20 20 20 20 20 20 20 20 28 28 77 61 72 ((war
45f0: 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n)
4600: 20 20 20 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 warn).;;
4610: 20 20 20 20 20 20 20 20 20 20 20 28 28 66 61 69 ((fai
4620: 6c 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 l)
4630: 20 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 20 20 fail).;;
4640: 20 20 20 20 20 20 20 20 20 20 20 28 28 63 68 65 ((che
4650: 63 6b 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ck)
4660: 20 20 63 68 65 63 6b 29 0a 3b 3b 20 20 20 20 20 check).;;
4670: 20 20 20 20 20 20 20 20 20 20 20 28 28 77 61 69 ((wai
4680: 76 65 64 29 20 20 20 20 20 20 20 20 20 20 20 20 ved)
4690: 20 77 61 69 76 65 64 29 0a 3b 3b 20 20 20 20 20 waived).;;
46a0: 20 20 20 20 20 20 20 20 20 20 20 28 28 73 6b 69 ((ski
46b0: 70 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 p)
46c0: 20 20 20 73 6b 69 70 29 0a 3b 3b 20 20 20 20 20 skip).;;
46d0: 20 20 20 20 20 20 20 20 20 20 20 28 28 73 74 75 ((stu
46e0: 63 6b 2f 64 65 61 64 29 20 20 20 20 20 20 20 20 ck/dead)
46f0: 20 20 73 74 75 63 6b 29 0a 3b 3b 20 20 20 20 20 stuck).;;
4700: 20 20 20 20 20 20 20 20 20 20 20 28 28 61 62 6f ((abo
4710: 72 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 rt)
4720: 20 20 61 62 6f 72 74 29 0a 3b 3b 20 20 20 20 20 abort).;;
4730: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
4740: 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d unknown-
4750: 65 72 72 6f 72 2d 34 29 29 29 0a 3b 3b 20 20 20 error-4))).;;
4760: 20 20 20 20 20 20 20 20 20 20 28 28 77 61 72 6e ((warn
4770: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
4780: 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 0a 3b (case nstate.;
4790: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
47a0: 20 28 28 70 61 73 73 20 77 61 72 6e 20 6e 2f 61 ((pass warn n/a
47b0: 20 73 6b 69 70 20 64 65 6c 65 74 65 64 29 20 20 skip deleted)
47c0: 20 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 20 20 warn).;;
47d0: 20 20 20 20 20 20 20 20 20 28 28 66 61 69 6c 29 ((fail)
47e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
47f0: 20 20 20 20 20 20 20 20 20 66 61 69 6c 29 0a 3b fail).;
4800: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4810: 20 28 28 63 68 65 63 6b 29 20 20 20 20 20 20 20 ((check)
4820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4830: 63 68 65 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 check).;;
4840: 20 20 20 20 20 20 20 20 20 28 28 77 61 69 76 65 ((waive
4850: 64 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d)
4860: 20 20 20 20 20 20 20 77 61 69 76 65 64 29 0a 3b waived).;
4870: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4880: 20 28 28 73 74 75 63 6b 2f 64 65 61 64 29 20 20 ((stuck/dead)
4890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
48a0: 73 74 75 63 6b 29 0a 3b 3b 20 20 20 20 20 20 20 stuck).;;
48b0: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 (else
48c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 75 6e un
48d0: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 35 29 29 29 known-error-5)))
48e0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
48f0: 28 28 66 61 69 6c 29 0a 3b 3b 20 20 20 20 20 20 ((fail).;;
4900: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 (case ns
4910: 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 tate.;;
4920: 20 20 20 20 20 20 20 28 28 70 61 73 73 20 77 61 ((pass wa
4930: 72 6e 20 66 61 69 6c 20 63 68 65 63 6b 20 6e 2f rn fail check n/
4940: 61 20 77 61 69 76 65 64 20 73 6b 69 70 20 64 65 a waived skip de
4950: 6c 65 74 65 64 20 73 74 75 63 6b 2f 64 65 61 64 leted stuck/dead
4960: 20 73 74 75 63 6b 29 20 20 66 61 69 6c 29 0a 3b stuck) fail).;
4970: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
4980: 20 28 28 61 62 6f 72 74 29 20 20 20 20 20 20 20 ((abort)
4990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49c0: 20 20 61 62 6f 72 74 29 0a 3b 3b 20 20 20 20 20 abort).;;
49d0: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
49e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
49f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4a10: 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d unknown-error-
4a20: 36 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 6))).;;
4a30: 20 20 20 20 28 65 6c 73 65 20 20 20 20 75 6e 6b (else unk
4a40: 6e 6f 77 6e 2d 65 72 72 6f 72 2d 37 29 29 29 0a nown-error-7))).
4a50: 3b 3b 20 20 20 20 20 28 63 6f 6e 73 20 0a 3b 3b ;; (cons .;;
4a60: 20 20 20 20 20 20 28 69 66 20 6e 73 74 61 74 65 (if nstate
4a70: 20 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e (symbol->strin
4a80: 67 20 6e 73 74 61 74 65 29 20 20 6e 73 74 61 74 g nstate) nstat
4a90: 65 29 0a 3b 3b 20 20 20 20 20 20 28 69 66 20 6e e).;; (if n
4aa0: 73 74 61 74 75 73 20 28 73 79 6d 62 6f 6c 2d 3e status (symbol->
4ab0: 73 74 72 69 6e 67 20 6e 73 74 61 74 75 73 29 20 string nstatus)
4ac0: 6e 73 74 61 74 75 73 29 29 29 29 0a 20 20 20 20 nstatus)))).
4ad0: 20 20 20 20 20 20 20 20 20 20 20 0a 3b 3b 3d 3d .;;==
4ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b20: 3d 3d 3d 3d 0a 3b 3b 20 44 20 45 20 42 20 55 20 ====.;; D E B U
4b30: 47 20 47 20 49 20 4e 20 47 20 20 20 53 20 54 20 G G I N G S T
4b40: 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d U F F .;;=======
4b50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
4b90: 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 .(define *verbos
4ba0: 69 74 79 2a 20 20 20 20 20 20 20 20 20 31 29 0a ity* 1).
4bb0: 28 64 65 66 69 6e 65 20 2a 6c 6f 67 67 69 6e 67 (define *logging
4bc0: 2a 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a * #f).
4bd0: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 77 69 .(define (get-wi
4be0: 74 68 2d 64 65 66 61 75 6c 74 20 76 61 6c 20 64 th-default val d
4bf0: 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 efault). (let (
4c00: 28 76 61 6c 20 28 61 72 67 73 3a 67 65 74 2d 61 (val (args:get-a
4c10: 72 67 20 76 61 6c 29 29 29 0a 20 20 20 20 28 69 rg val))). (i
4c20: 66 20 76 61 6c 20 76 61 6c 20 64 65 66 61 75 6c f val val defaul
4c30: 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 t)))..(define (a
4c40: 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 6b 65 79 ssoc/default key
4c50: 20 6c 73 74 20 2e 20 64 65 66 61 75 6c 74 29 0a lst . default).
4c60: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 61 73 (let ((res (as
4c70: 73 6f 63 20 6b 65 79 20 6c 73 74 29 29 29 0a 20 soc key lst))).
4c80: 20 20 20 28 69 66 20 72 65 73 20 28 63 61 64 72 (if res (cadr
4c90: 20 72 65 73 29 28 69 66 20 28 6e 75 6c 6c 3f 20 res)(if (null?
4ca0: 64 65 66 61 75 6c 74 29 20 23 66 20 28 63 61 72 default) #f (car
4cb0: 20 64 65 66 61 75 6c 74 29 29 29 29 29 0a 0a 28 default)))))..(
4cc0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
4cd0: 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d et-testsuite-nam
4ce0: 65 29 0a 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 e). (or (config
4cf0: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
4d00: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 74 65 dat* "setup" "te
4d10: 73 74 73 75 69 74 65 22 20 29 0a 20 20 20 20 20 stsuite" ).
4d20: 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 0a (if *toppath* .
4d30: 20 20 20 20 20 20 20 20 20 20 28 70 61 74 68 6e (pathn
4d40: 61 6d 65 2d 66 69 6c 65 20 2a 74 6f 70 70 61 74 ame-file *toppat
4d50: 68 2a 29 0a 20 20 20 20 20 20 20 20 20 20 28 70 h*). (p
4d60: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 75 athname-file (cu
4d70: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
4d80: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
4d90: 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 ommon:get-db-tmp
4da0: 2d 61 72 65 61 29 0a 20 20 28 69 66 20 2a 64 62 -area). (if *db
4db0: 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 20 20 -cache-path*.
4dc0: 20 20 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 *db-cache-pat
4dd0: 68 2a 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 h*. (let ((
4de0: 64 62 70 61 74 68 20 28 63 72 65 61 74 65 2d 64 dbpath (create-d
4df0: 69 72 65 63 74 6f 72 79 20 28 63 6f 6e 63 20 22 irectory (conc "
4e00: 2f 74 6d 70 2f 22 20 28 63 75 72 72 65 6e 74 2d /tmp/" (current-
4e10: 75 73 65 72 2d 6e 61 6d 65 29 0a 09 09 09 09 09 user-name)......
4e20: 20 20 20 20 22 2f 6d 65 67 61 74 65 73 74 5f 6c "/megatest_l
4e30: 6f 63 61 6c 64 62 2f 22 0a 09 09 09 09 09 20 20 ocaldb/"......
4e40: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 (common:get-te
4e50: 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 20 22 2f stsuite-name) "/
4e60: 22 0a 09 09 09 09 09 20 20 20 20 28 73 74 72 69 "...... (stri
4e70: 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 2a 74 6f ng-translate *to
4e80: 70 70 61 74 68 2a 20 22 2f 22 20 22 2e 22 29 29 ppath* "/" "."))
4e90: 20 23 74 29 29 29 0a 09 28 73 65 74 21 20 2a 64 #t)))..(set! *d
4ea0: 62 2d 63 61 63 68 65 2d 70 61 74 68 2a 20 64 62 b-cache-path* db
4eb0: 70 61 74 68 29 0a 09 64 62 70 61 74 68 29 29 29 path)..dbpath)))
4ec0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
4ed0: 6e 3a 67 65 74 2d 61 72 65 61 2d 70 61 74 68 2d n:get-area-path-
4ee0: 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 6d 65 signature). (me
4ef0: 73 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 72 ssage-digest-str
4f00: 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 69 ing (md5-primiti
4f10: 76 65 29 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a ve) *toppath*)).
4f20: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
4f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 58 =========.;; E X
4f70: 20 49 20 54 20 20 20 48 20 41 20 4e 20 44 20 4c I T H A N D L
4f80: 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d I N G.;;=======
4f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4fc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
4fd0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
4fe0: 3a 72 75 6e 2d 73 79 6e 63 3f 29 0a 20 20 20 20 :run-sync?).
4ff0: 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d (and (common:on-
5000: 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 28 61 72 homehost?).. (ar
5010: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 gs:get-arg "-ser
5020: 76 65 72 22 29 29 29 0a 0a 3b 3b 20 20 20 28 6c ver")))..;; (l
5030: 65 74 20 28 28 6f 68 68 20 28 63 6f 6d 6d 6f 6e et ((ohh (common
5040: 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 29 0a :on-homehost?)).
5050: 3b 3b 20 09 28 73 72 76 20 28 61 72 67 73 3a 67 ;; .(srv (args:g
5060: 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 et-arg "-server"
5070: 29 29 29 0a 3b 3b 20 20 20 20 20 28 61 6e 64 20 ))).;; (and
5080: 6f 68 68 20 73 72 76 29 29 29 0a 20 20 20 20 3b ohh srv))). ;
5090: 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ; (debug:print-i
50a0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
50b0: 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d 6d 6f 6e og-port* "common
50c0: 3a 72 75 6e 2d 73 79 6e 63 3f 20 6f 68 68 3d 22 :run-sync? ohh="
50d0: 20 6f 68 68 20 22 2c 20 73 72 76 3d 22 20 73 72 ohh ", srv=" sr
50e0: 76 29 0a 0a 3b 3b 3b 3b 20 72 75 6e 2d 69 64 73 v)..;;;; run-ids
50f0: 0a 3b 3b 20 20 20 20 69 66 20 23 66 20 75 73 65 .;; if #f use
5100: 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 79 6e 63 2a *db-local-sync*
5110: 20 3a 20 6f 72 20 27 6c 6f 63 61 6c 2d 73 79 6e : or 'local-syn
5120: 63 2d 66 6c 61 67 73 0a 3b 3b 20 20 20 20 69 66 c-flags.;; if
5130: 20 23 74 20 75 73 65 20 74 69 6d 65 73 74 61 6d #t use timestam
5140: 70 73 20 20 20 20 20 20 3a 20 6f 72 20 27 74 69 ps : or 'ti
5150: 6d 65 73 74 61 6d 70 73 0a 28 64 65 66 69 6e 65 mestamps.(define
5160: 20 28 63 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d 74 6f (common:sync-to
5170: 2d 6d 65 67 61 74 65 73 74 2e 64 62 20 64 62 73 -megatest.db dbs
5180: 74 72 75 63 74 29 20 0a 20 20 28 6c 65 74 20 28 truct) . (let (
5190: 28 73 74 61 72 74 2d 74 69 6d 65 20 20 20 20 20 (start-time
51a0: 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (current-sec
51b0: 6f 6e 64 73 29 29 0a 09 28 72 65 73 20 20 20 20 onds))..(res
51c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 3a (db:
51d0: 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 64 62 multi-db-sync db
51e0: 73 74 72 75 63 74 20 27 6e 65 77 32 6f 6c 64 29 struct 'new2old)
51f0: 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 73 79 )). (let ((sy
5200: 6e 63 2d 74 69 6d 65 20 28 2d 20 28 63 75 72 72 nc-time (- (curr
5210: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 ent-seconds) sta
5220: 72 74 2d 74 69 6d 65 29 29 29 0a 20 20 20 20 20 rt-time))).
5230: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
5240: 66 6f 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 3 *default-lo
5250: 67 2d 70 6f 72 74 2a 20 22 53 79 6e 63 20 6f 66 g-port* "Sync of
5260: 20 6e 65 77 64 62 20 74 6f 20 6f 6c 64 64 62 20 newdb to olddb
5270: 63 6f 6d 70 6c 65 74 65 64 20 69 6e 20 22 20 73 completed in " s
5280: 79 6e 63 2d 74 69 6d 65 20 22 20 73 65 63 6f 6e ync-time " secon
5290: 64 73 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 ds pid="(current
52a0: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 -process-id)).
52b0: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
52c0: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
52d0: 33 30 20 22 73 79 6e 63 20 6e 65 77 20 74 6f 20 30 "sync new to
52e0: 6f 6c 64 22 29 0a 09 20 20 28 64 65 62 75 67 3a old").. (debug:
52f0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
5300: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
5310: 22 53 79 6e 63 20 6f 66 20 6e 65 77 64 62 20 74 "Sync of newdb t
5320: 6f 20 6f 6c 64 64 62 20 63 6f 6d 70 6c 65 74 65 o olddb complete
5330: 64 20 69 6e 20 22 20 73 79 6e 63 2d 74 69 6d 65 d in " sync-time
5340: 20 22 20 73 65 63 6f 6e 64 73 20 70 69 64 3d 22 " seconds pid="
5350: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
5360: 2d 69 64 29 29 29 29 0a 20 20 20 20 72 65 73 29 -id)))). res)
5370: 29 0a 0a 0a 0a 0a 28 64 65 66 69 6e 65 20 2a 77 ).....(define *w
5380: 64 6e 75 6d 2a 20 30 29 0a 28 64 65 66 69 6e 65 dnum* 0).(define
5390: 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 78 20 28 6d *wdnum*mutex (m
53a0: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 63 ake-mutex)).;; c
53b0: 75 72 72 65 6e 74 6c 79 20 74 68 65 20 70 72 69 urrently the pri
53c0: 6d 61 72 79 20 6a 6f 62 20 6f 66 20 74 68 65 20 mary job of the
53d0: 77 61 74 63 68 64 6f 67 20 69 73 20 74 6f 20 72 watchdog is to r
53e0: 75 6e 20 74 68 65 20 73 79 6e 63 20 62 61 63 6b un the sync back
53f0: 20 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 to megatest.db
5400: 66 72 6f 6d 20 74 68 65 20 64 62 20 69 6e 20 2f from the db in /
5410: 74 6d 70 0a 3b 3b 20 69 66 20 77 65 20 61 72 65 tmp.;; if we are
5420: 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 on the homehost
5430: 20 61 6e 64 20 77 65 20 61 72 65 20 61 20 73 65 and we are a se
5440: 72 76 65 72 20 28 62 79 20 64 65 66 69 6e 69 74 rver (by definit
5450: 69 6f 6e 20 77 65 20 61 72 65 20 6f 6e 20 74 68 ion we are on th
5460: 65 20 68 6f 6d 65 68 6f 73 74 20 69 66 20 77 65 e homehost if we
5470: 20 61 72 65 20 61 20 73 65 72 76 65 72 29 0a 3b are a server).;
5480: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
5490: 6e 3a 77 61 74 63 68 64 6f 67 29 0a 20 20 0a 20 n:watchdog). .
54a0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
54b0: 30 2e 30 35 29 20 3b 3b 20 64 65 6c 61 79 20 66 0.05) ;; delay f
54c0: 6f 72 20 73 74 61 72 74 75 70 0a 20 20 28 6c 65 or startup. (le
54d0: 74 20 28 28 6c 65 67 61 63 79 2d 73 79 6e 63 20 t ((legacy-sync
54e0: 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 6e 63 (common:run-sync
54f0: 3f 29 29 0a 09 28 64 65 62 75 67 2d 6d 6f 64 65 ?))..(debug-mode
5500: 20 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d (debug:debug-m
5510: 6f 64 65 20 31 29 29 0a 09 28 6c 61 73 74 2d 74 ode 1))..(last-t
5520: 69 6d 65 20 20 20 28 63 75 72 72 65 6e 74 2d 73 ime (current-s
5530: 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 20 econds)).
5540: 20 28 74 68 69 73 2d 77 64 2d 6e 75 6d 20 20 20 (this-wd-num
5550: 20 20 28 62 65 67 69 6e 20 28 6d 75 74 65 78 2d (begin (mutex-
5560: 6c 6f 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 74 lock! *wdnum*mut
5570: 65 78 29 20 28 6c 65 74 20 28 28 78 20 2a 77 64 ex) (let ((x *wd
5580: 6e 75 6d 2a 29 29 20 28 73 65 74 21 20 2a 77 64 num*)) (set! *wd
5590: 6e 75 6d 2a 20 28 61 64 64 31 20 2a 77 64 6e 75 num* (add1 *wdnu
55a0: 6d 2a 29 29 20 28 6d 75 74 65 78 2d 75 6e 6c 6f m*)) (mutex-unlo
55b0: 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 78 ck! *wdnum*mutex
55c0: 29 20 78 29 29 29 0a 20 20 20 20 20 20 20 20 29 ) x))). )
55d0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
55e0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
55f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 74 t-log-port* "wat
5600: 63 68 64 6f 67 20 73 74 61 72 74 69 6e 67 2e 20 chdog starting.
5610: 6c 65 67 61 63 79 2d 73 79 6e 63 20 69 73 20 22 legacy-sync is "
5620: 20 6c 65 67 61 63 79 2d 73 79 6e 63 22 20 70 69 legacy-sync" pi
5630: 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 d="(current-proc
5640: 65 73 73 2d 69 64 29 22 20 74 68 69 73 2d 77 64 ess-id)" this-wd
5650: 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 64 2d 6e 75 -num="this-wd-nu
5660: 6d 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 m). (if (and
5670: 6c 65 67 61 63 79 2d 73 79 6e 63 20 28 6e 6f 74 legacy-sync (not
5680: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 *time-to-exit*)
5690: 29 0a 09 28 6c 65 74 20 28 28 64 62 73 74 72 75 )..(let ((dbstru
56a0: 63 74 20 28 64 62 3a 73 65 74 75 70 29 29 29 0a ct (db:setup))).
56b0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
56c0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
56d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 65 72 76 65 log-port* "Serve
56e0: 72 20 72 75 6e 6e 69 6e 67 2c 20 70 65 72 69 6f r running, perio
56f0: 64 69 63 20 73 79 6e 63 20 73 74 61 72 74 65 64 dic sync started
5700: 2e 22 29 0a 09 20 20 28 6c 65 74 20 6c 6f 6f 70 .").. (let loop
5710: 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ().
5720: 3b 3b 28 42 42 3e 20 22 77 61 74 63 68 64 6f 67 ;;(BB> "watchdog
5730: 20 6c 6f 6f 70 2e 20 20 70 69 64 3d 22 28 63 75 loop. pid="(cu
5740: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
5750: 29 22 20 74 68 69 73 2d 77 64 2d 6e 75 6d 3d 22 )" this-wd-num="
5760: 74 68 69 73 2d 77 64 2d 6e 75 6d 22 20 2a 74 69 this-wd-num" *ti
5770: 6d 65 2d 74 6f 2d 65 78 69 74 2a 3d 22 2a 74 69 me-to-exit*="*ti
5780: 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 09 20 20 me-to-exit*)..
5790: 20 20 3b 3b 20 73 79 6e 63 20 66 6f 72 20 66 69 ;; sync for fi
57a0: 6c 65 73 79 73 74 65 6d 20 6c 6f 63 61 6c 20 64 lesystem local d
57b0: 62 20 77 72 69 74 65 73 0a 09 20 20 20 20 3b 3b b writes.. ;;
57c0: 0a 09 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 .. (mutex-loc
57d0: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
57e0: 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 28 c-mutex*).. (
57f0: 6c 65 74 2a 20 28 28 6e 65 65 64 2d 73 79 6e 63 let* ((need-sync
5800: 20 20 20 20 20 20 20 20 28 3e 3d 20 2a 64 62 2d (>= *db-
5810: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 2a 64 62 last-access* *db
5820: 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 29 20 3b 3b -last-sync*)) ;;
5830: 20 6e 6f 20 73 79 6e 63 20 73 69 6e 63 65 20 6c no sync since l
5840: 61 73 74 20 77 72 69 74 65 0a 09 09 20 20 20 28 ast write... (
5850: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
5860: 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f *db-sync-in-pro
5870: 67 72 65 73 73 2a 29 0a 09 09 20 20 20 28 73 68 gress*)... (sh
5880: 6f 75 6c 64 2d 73 79 6e 63 20 20 20 20 20 20 28 ould-sync (
5890: 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 and (not *time-t
58a0: 6f 2d 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 o-exit*).
58b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
58d0: 20 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e (> (- (curren
58e0: 74 2d 73 65 63 6f 6e 64 73 29 20 2a 64 62 2d 6c t-seconds) *db-l
58f0: 61 73 74 2d 73 79 6e 63 2a 29 20 35 29 29 29 20 ast-sync*) 5)))
5900: 3b 3b 20 73 79 6e 63 20 65 76 65 72 79 20 66 69 ;; sync every fi
5910: 76 65 20 73 65 63 6f 6e 64 73 20 6d 69 6e 69 6d ve seconds minim
5920: 75 6d 0a 09 09 20 20 20 28 77 69 6c 6c 2d 73 79 um... (will-sy
5930: 6e 63 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 nc (and (
5940: 6f 72 20 6e 65 65 64 2d 73 79 6e 63 20 73 68 6f or need-sync sho
5950: 75 6c 64 2d 73 79 6e 63 29 0a 09 09 09 09 09 20 uld-sync)......
5960: 20 28 6e 6f 74 20 73 79 6e 63 2d 69 6e 2d 70 72 (not sync-in-pr
5970: 6f 67 72 65 73 73 29 29 29 0a 09 09 20 20 20 28 ogress)))... (
5980: 73 74 61 72 74 2d 74 69 6d 65 20 20 20 20 20 20 start-time
5990: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
59a0: 73 29 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 s))).. ;; (
59b0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
59c0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
59d0: 70 6f 72 74 2a 20 22 6e 65 65 64 2d 73 79 6e 63 port* "need-sync
59e0: 3a 20 22 20 6e 65 65 64 2d 73 79 6e 63 20 22 20 : " need-sync "
59f0: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
5a00: 3a 20 22 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 : " sync-in-prog
5a10: 72 65 73 73 20 22 20 73 68 6f 75 6c 64 2d 73 79 ress " should-sy
5a20: 6e 63 3a 20 22 20 73 68 6f 75 6c 64 2d 73 79 6e nc: " should-syn
5a30: 63 20 22 20 77 69 6c 6c 2d 73 79 6e 63 3a 20 22 c " will-sync: "
5a40: 20 77 69 6c 6c 2d 73 79 6e 63 29 0a 09 20 20 20 will-sync)..
5a50: 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 (if will-sync
5a60: 20 28 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d (set! *db-sync-
5a70: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 74 29 in-progress* #t)
5a80: 29 0a 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d ).. (mutex-
5a90: 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 unlock! *db-mult
5aa0: 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 i-sync-mutex*)..
5ab0: 20 20 20 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 (if will-s
5ac0: 79 6e 63 0a 09 09 20 20 28 6c 65 74 20 28 28 72 ync... (let ((r
5ad0: 65 73 20 28 63 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d es (common:sync-
5ae0: 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 62 20 64 to-megatest.db d
5af0: 62 73 74 72 75 63 74 29 29 29 20 3b 3b 20 64 69 bstruct))) ;; di
5b00: 64 20 77 65 20 73 79 6e 63 20 61 6e 79 20 64 61 d we sync any da
5b10: 74 61 3f 20 49 66 20 73 6f 20 6e 65 65 64 20 74 ta? If so need t
5b20: 6f 20 73 65 74 20 74 68 65 20 64 62 20 74 6f 75 o set the db tou
5b30: 63 68 65 64 20 66 6c 61 67 20 74 6f 20 6b 65 65 ched flag to kee
5b40: 70 20 74 68 65 20 73 65 72 76 65 72 20 61 6c 69 p the server ali
5b50: 76 65 0a 09 09 20 20 20 20 28 69 66 20 28 3e 20 ve... (if (>
5b60: 72 65 73 20 30 29 20 3b 3b 20 73 6f 6d 65 20 72 res 0) ;; some r
5b70: 65 63 6f 72 64 73 20 77 65 72 65 20 74 72 61 6e ecords were tran
5b80: 73 66 65 72 72 65 64 2c 20 6b 65 65 70 20 74 68 sferred, keep th
5b90: 65 20 64 62 20 61 6c 69 76 65 0a 09 09 09 28 62 e db alive....(b
5ba0: 65 67 69 6e 0a 09 09 09 20 20 28 6d 75 74 65 78 egin.... (mutex
5bb0: 2d 6c 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 -lock! *heartbea
5bc0: 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 28 t-mutex*).... (
5bd0: 73 65 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 set! *db-last-ac
5be0: 63 65 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 cess* (current-s
5bf0: 65 63 6f 6e 64 73 29 29 0a 09 09 09 20 20 28 6d econds)).... (m
5c00: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 utex-unlock! *he
5c10: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a artbeat-mutex*).
5c20: 09 09 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e ... (debug:prin
5c30: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
5c40: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 79 6e t-log-port* "syn
5c50: 63 20 63 61 6c 6c 65 64 2c 20 22 20 72 65 73 20 c called, " res
5c60: 22 20 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 " records transf
5c70: 65 72 72 65 64 2e 22 29 29 0a 09 09 09 28 64 65 erred."))....(de
5c80: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 bug:print-info 2
5c90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5ca0: 72 74 2a 20 22 73 79 6e 63 20 63 61 6c 6c 65 64 rt* "sync called
5cb0: 20 62 75 74 20 7a 65 72 6f 20 72 65 63 6f 72 64 but zero record
5cc0: 73 20 74 72 61 6e 73 66 65 72 72 65 64 22 29 29 s transferred"))
5cd0: 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 77 69 )).. (if wi
5ce0: 6c 6c 2d 73 79 6e 63 0a 09 09 20 20 28 62 65 67 ll-sync... (beg
5cf0: 69 6e 0a 09 09 20 20 20 20 28 6d 75 74 65 78 2d in... (mutex-
5d00: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
5d10: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 09 20 sync-mutex*)...
5d20: 20 20 20 28 73 65 74 21 20 2a 64 62 2d 73 79 6e (set! *db-syn
5d30: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 c-in-progress* #
5d40: 66 29 0a 09 09 20 20 20 20 28 73 65 74 21 20 2a f)... (set! *
5d50: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 73 74 db-last-sync* st
5d60: 61 72 74 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 art-time)...
5d70: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
5d80: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
5d90: 74 65 78 2a 29 29 29 0a 09 20 20 20 20 20 20 28 tex*))).. (
5da0: 69 66 20 28 61 6e 64 20 64 65 62 75 67 2d 6d 6f if (and debug-mo
5db0: 64 65 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 de... (> (
5dc0: 2d 20 73 74 61 72 74 2d 74 69 6d 65 20 6c 61 73 - start-time las
5dd0: 74 2d 74 69 6d 65 29 20 36 30 29 29 0a 09 09 20 t-time) 60))...
5de0: 20 28 62 65 67 69 6e 0a 09 09 20 20 20 20 28 73 (begin... (s
5df0: 65 74 21 20 6c 61 73 74 2d 74 69 6d 65 20 73 74 et! last-time st
5e00: 61 72 74 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 art-time)...
5e10: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
5e20: 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
5e30: 2d 70 6f 72 74 2a 20 22 74 69 6d 65 73 74 61 6d -port* "timestam
5e40: 70 20 2d 3e 20 22 20 28 73 65 63 6f 6e 64 73 2d p -> " (seconds-
5e50: 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 28 63 75 >time-string (cu
5e60: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 rrent-seconds))
5e70: 22 2c 20 74 69 6d 65 20 73 69 6e 63 65 20 73 74 ", time since st
5e80: 61 72 74 20 2d 3e 20 22 20 28 73 65 63 6f 6e 64 art -> " (second
5e90: 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d s->hr-min-sec (-
5ea0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
5eb0: 73 29 20 2a 74 69 6d 65 2d 7a 65 72 6f 2a 29 29 s) *time-zero*))
5ec0: 29 29 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 )))).. ..
5ed0: 3b 3b 20 6b 65 65 70 20 67 6f 69 6e 67 20 75 6e ;; keep going un
5ee0: 6c 65 73 73 20 74 69 6d 65 20 74 6f 20 65 78 69 less time to exi
5ef0: 74 0a 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 t.. ;;.. (
5f00: 69 66 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f if (not *time-to
5f10: 2d 65 78 69 74 2a 29 0a 09 09 28 6c 65 74 20 64 -exit*)...(let d
5f20: 65 6c 61 79 2d 6c 6f 6f 70 20 28 28 63 6f 75 6e elay-loop ((coun
5f30: 74 20 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 0)).
5f40: 20 20 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 ;;(BB> "
5f50: 64 65 6c 61 79 2d 6c 6f 6f 70 20 74 6f 70 3b 20 delay-loop top;
5f60: 63 6f 75 6e 74 3d 22 63 6f 75 6e 74 22 20 70 69 count="count" pi
5f70: 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 d="(current-proc
5f80: 65 73 73 2d 69 64 29 22 20 74 68 69 73 2d 77 64 ess-id)" this-wd
5f90: 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 64 2d 6e 75 -num="this-wd-nu
5fa0: 6d 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 m" *time-to-exit
5fb0: 2a 3d 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 *="*time-to-exit
5fc0: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
5fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
6000: 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f .. (if (and (no
6010: 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a t *time-to-exit*
6020: 29 0a 09 09 09 20 20 20 28 3c 20 63 6f 75 6e 74 ).... (< count
6030: 20 34 29 29 20 3b 3b 20 77 61 73 20 31 31 2c 20 4)) ;; was 11,
6040: 63 68 61 6e 67 69 6e 67 20 74 6f 20 34 2e 20 0a changing to 4. .
6050: 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
6060: 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
6070: 20 31 29 0a 09 09 09 28 64 65 6c 61 79 2d 6c 6f 1)....(delay-lo
6080: 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 op (+ count 1)))
6090: 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 2a )... (if (not *
60a0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 20 28 time-to-exit*) (
60b0: 6c 6f 6f 70 29 29 29 29 0a 09 20 20 20 20 28 69 loop)))).. (i
60c0: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
60d0: 69 73 65 2d 70 72 69 6e 74 20 33 30 29 0a 09 09 ise-print 30)...
60e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
60f0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
6100: 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 -port* "Exiting
6110: 77 61 74 63 68 64 6f 67 20 74 69 6d 65 72 2c 20 watchdog timer,
6120: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3d *time-to-exit* =
6130: 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 " *time-to-exit
6140: 2a 22 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 *" pid="(current
6150: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 74 68 -process-id)" th
6160: 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 2d is-wd-num="this-
6170: 77 64 2d 6e 75 6d 29 29 29 29 29 29 29 0a 0a 28 wd-num)))))))..(
6180: 64 65 66 69 6e 65 20 28 73 74 64 2d 65 78 69 74 define (std-exit
6190: 2d 70 72 6f 63 65 64 75 72 65 29 0a 20 20 28 6f -procedure). (o
61a0: 6e 2d 65 78 69 74 20 28 6c 61 6d 62 64 61 20 28 n-exit (lambda (
61b0: 29 20 30 29 29 0a 20 20 3b 3b 28 42 42 3e 20 22 ) 0)). ;;(BB> "
61c0: 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 std-exit-procedu
61d0: 72 65 20 63 61 6c 6c 65 64 3b 20 2a 74 69 6d 65 re called; *time
61e0: 2d 74 6f 2d 65 78 69 74 2a 3d 22 2a 74 69 6d 65 -to-exit*="*time
61f0: 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 20 28 6c 65 -to-exit*). (le
6200: 74 20 28 28 6e 6f 2d 68 75 72 72 79 20 20 28 69 t ((no-hurry (i
6210: 66 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a f *time-to-exit*
6220: 20 3b 3b 20 68 75 72 72 79 20 75 70 0a 09 09 20 ;; hurry up...
6230: 20 20 20 20 20 20 23 66 0a 09 09 20 20 20 20 20 #f...
6240: 20 20 28 62 65 67 69 6e 0a 09 09 09 20 28 73 65 (begin.... (se
6250: 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 t! *time-to-exit
6260: 2a 20 23 74 29 0a 09 09 09 20 23 74 29 29 29 29 * #t).... #t))))
6270: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
6280: 74 2d 69 6e 66 6f 20 34 20 2a 64 65 66 61 75 6c t-info 4 *defaul
6290: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 61 t-log-port* "sta
62a0: 72 74 69 6e 67 20 65 78 69 74 20 70 72 6f 63 65 rting exit proce
62b0: 73 73 2c 20 66 69 6e 61 6c 69 7a 69 6e 67 20 64 ss, finalizing d
62c0: 61 74 61 62 61 73 65 73 2e 22 29 0a 20 20 20 20 atabases.").
62d0: 28 69 66 20 28 61 6e 64 20 6e 6f 2d 68 75 72 72 (if (and no-hurr
62e0: 79 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d 6d y (debug:debug-m
62f0: 6f 64 65 20 31 38 29 29 0a 09 28 72 6d 74 3a 70 ode 18))..(rmt:p
6300: 72 69 6e 74 2d 64 62 2d 73 74 61 74 73 29 29 0a rint-db-stats)).
6310: 20 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 (let ((th1 (
6320: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
6330: 62 64 61 20 28 29 20 3b 3b 20 74 68 72 65 61 64 bda () ;; thread
6340: 20 66 6f 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 for cleaning up
6350: 2c 20 67 69 76 65 20 69 74 20 66 69 76 65 20 73 , give it five s
6360: 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 20 20 20 econds.
6370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6380: 20 20 20 20 20 28 69 66 20 2a 64 62 73 74 72 75 (if *dbstru
6390: 63 74 2d 64 62 2a 20 28 64 62 3a 63 6c 6f 73 65 ct-db* (db:close
63a0: 2d 61 6c 6c 20 2a 64 62 73 74 72 75 63 74 2d 64 -all *dbstruct-d
63b0: 62 2a 29 29 20 3b 3b 20 6f 6e 65 20 73 65 63 6f b*)) ;; one seco
63c0: 6e 64 20 61 6c 6c 6f 63 61 74 65 64 0a 09 09 09 nd allocated....
63d0: 20 20 20 20 20 20 28 69 66 20 2a 74 61 73 6b 2d (if *task-
63e0: 64 62 2a 20 20 20 20 0a 09 09 09 09 20 20 28 6c db* ..... (l
63f0: 65 74 20 28 28 64 62 20 28 63 64 72 20 2a 74 61 et ((db (cdr *ta
6400: 73 6b 2d 64 62 2a 29 29 29 0a 09 09 09 09 20 20 sk-db*))).....
6410: 20 20 28 69 66 20 28 73 71 6c 69 74 65 33 3a 64 (if (sqlite3:d
6420: 61 74 61 62 61 73 65 3f 20 64 62 29 0a 09 09 09 atabase? db)....
6430: 09 09 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 ..(begin......
6440: 28 73 71 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 (sqlite3:interru
6450: 70 74 21 20 64 62 29 0a 09 09 09 09 09 20 20 28 pt! db)...... (
6460: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
6470: 21 20 64 62 20 23 74 29 0a 09 09 09 09 09 20 20 ! db #t)......
6480: 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 ;; (vector-set!
6490: 2a 74 61 73 6b 2d 64 62 2a 20 30 20 23 66 29 0a *task-db* 0 #f).
64a0: 09 09 09 09 09 20 20 28 73 65 74 21 20 2a 74 61 ..... (set! *ta
64b0: 73 6b 2d 64 62 2a 20 23 66 29 29 29 29 29 0a 20 sk-db* #f))))).
64c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
64d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
64e0: 20 28 61 6e 64 20 2a 72 75 6e 72 65 6d 6f 74 65 (and *runremote
64f0: 2a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 *.
6500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6510: 20 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 (remote
6520: 2d 63 6f 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d -conndat *runrem
6530: 6f 74 65 2a 29 29 0a 20 20 20 20 20 20 20 20 20 ote*)).
6540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6550: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
6560: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6580: 20 20 20 20 28 68 74 74 70 2d 63 6c 69 65 6e 74 (http-client
6590: 23 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 #close-all-conne
65a0: 63 74 69 6f 6e 73 21 29 29 29 20 3b 3b 20 66 6f ctions!))) ;; fo
65b0: 72 20 68 74 74 70 2d 63 6c 69 65 6e 74 0a 20 20 r http-client.
65c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
65d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
65e0: 28 6e 6f 74 20 28 65 71 3f 20 2a 64 65 66 61 75 (not (eq? *defau
65f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 lt-log-port* (cu
6600: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
6610: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
6620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6630: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 (close-out
6640: 70 75 74 2d 70 6f 72 74 20 2a 64 65 66 61 75 6c put-port *defaul
6650: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 29 0a 09 09 t-log-port*))...
6660: 09 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 65 . (set! *de
6670: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
6680: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
6690: 6f 72 74 29 29 29 20 22 43 6c 65 61 6e 75 70 20 ort))) "Cleanup
66a0: 64 62 20 65 78 69 74 20 74 68 72 65 61 64 22 29 db exit thread")
66b0: 29 0a 09 20 20 28 74 68 32 20 28 6d 61 6b 65 2d ).. (th2 (make-
66c0: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
66d0: 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ).... (debu
66e0: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
66f0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 lt-log-port* "At
6700: 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 65 tempting clean e
6710: 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 70 xit. Please be p
6720: 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 20 atient and wait
6730: 61 20 66 65 77 20 73 65 63 6f 6e 64 73 2e 2e 2e a few seconds...
6740: 22 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ").... (if
6750: 6e 6f 2d 68 75 72 72 79 0a 20 20 20 20 20 20 20 no-hurry.
6760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6770: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
6780: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
6790: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
67a0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
67b0: 65 65 70 21 20 35 29 29 20 3b 3b 20 67 69 76 65 eep! 5)) ;; give
67c0: 20 74 68 65 20 63 6c 65 61 6e 20 75 70 20 66 65 the clean up fe
67d0: 77 20 73 65 63 6f 6e 64 73 20 74 6f 20 64 6f 20 w seconds to do
67e0: 69 74 27 73 20 73 74 75 66 66 0a 20 20 20 20 20 it's stuff.
67f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6800: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
6810: 67 69 6e 0a 20 20 20 20 20 20 09 09 09 09 20 20 gin. ....
6820: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
6830: 29 29 29 0a 20 20 20 20 20 20 09 09 09 20 20 20 ))). ...
6840: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6850: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
6860: 6f 72 74 2a 20 22 20 2e 2e 2e 20 64 6f 6e 65 22 ort* " ... done"
6870: 29 0a 20 20 20 20 20 20 09 09 09 20 20 20 20 20 ). ...
6880: 20 29 0a 09 09 09 20 20 20 20 22 63 6c 65 61 6e ).... "clean
6890: 20 65 78 69 74 22 29 29 29 0a 20 20 20 20 20 20 exit"))).
68a0: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
68b0: 68 31 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 h1). (threa
68c0: 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 20 20 d-start! th2).
68d0: 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e (thread-join
68e0: 21 20 74 68 31 29 0a 20 20 20 20 20 20 29 0a 20 ! th1). ).
68f0: 20 20 20 29 0a 0a 20 20 30 29 0a 0a 28 64 65 66 ).. 0)..(def
6900: 69 6e 65 20 28 73 74 64 2d 73 69 67 6e 61 6c 2d ine (std-signal-
6910: 68 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a handler signum).
6920: 20 20 3b 3b 20 28 73 69 67 6e 61 6c 2d 6d 61 73 ;; (signal-mas
6930: 6b 21 20 73 69 67 6e 75 6d 29 0a 20 20 28 73 65 k! signum). (se
6940: 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 t! *time-to-exit
6950: 2a 20 23 74 29 0a 20 20 3b 3b 28 42 42 3e 20 22 * #t). ;;(BB> "
6960: 67 6f 74 20 73 69 67 6e 61 6c 20 22 73 69 67 6e got signal "sign
6970: 75 6d 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 um). (debug:pri
6980: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
6990: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 ult-log-port* "R
69a0: 65 63 65 69 76 65 64 20 73 69 67 6e 61 6c 20 22 eceived signal "
69b0: 20 73 69 67 6e 75 6d 20 22 20 65 78 69 74 69 6e signum " exitin
69c0: 67 20 70 72 6f 6d 70 74 6c 79 22 29 0a 20 20 3b g promptly"). ;
69d0: 3b 20 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 ; (std-exit-proc
69e0: 65 64 75 72 65 29 20 3b 3b 20 73 68 6f 75 6c 64 edure) ;; should
69f0: 6e 27 74 20 6e 65 65 64 20 74 68 69 73 20 73 69 n't need this si
6a00: 6e 63 65 20 77 65 20 61 72 65 20 65 78 69 74 69 nce we are exiti
6a10: 6e 67 20 61 6e 64 20 69 74 20 77 69 6c 6c 20 62 ng and it will b
6a20: 65 20 63 61 6c 6c 65 64 20 61 6e 79 77 61 79 0a e called anyway.
6a30: 20 20 28 65 78 69 74 29 29 0a 0a 28 73 65 74 2d (exit))..(set-
6a40: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 signal-handler!
6a50: 73 69 67 6e 61 6c 2f 69 6e 74 20 20 73 74 64 2d signal/int std-
6a60: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 signal-handler)
6a70: 20 3b 3b 20 5e 43 0a 28 73 65 74 2d 73 69 67 6e ;; ^C.(set-sign
6a80: 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e al-handler! sign
6a90: 61 6c 2f 74 65 72 6d 20 73 74 64 2d 73 69 67 6e al/term std-sign
6aa0: 61 6c 2d 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 28 al-handler).;; (
6ab0: 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c set-signal-handl
6ac0: 65 72 21 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 er! signal/stop
6ad0: 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c std-signal-handl
6ae0: 65 72 29 20 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 er) ;; ^Z NO, d
6af0: 6f 20 4e 4f 54 20 68 61 6e 64 6c 65 20 5e 5a 21 o NOT handle ^Z!
6b00: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
6b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 ==========.;; M
6b50: 49 20 53 20 43 20 20 20 55 20 54 20 49 20 4c 20 I S C U T I L
6b60: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
6b70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6f ==========..;; o
6bb0: 6e 65 2d 6f 66 20 61 72 67 73 20 64 65 66 69 6e ne-of args defin
6bc0: 65 64 0a 28 64 65 66 69 6e 65 20 28 61 72 67 73 ed.(define (args
6bd0: 2d 64 65 66 69 6e 65 64 3f 20 2e 20 70 61 72 61 -defined? . para
6be0: 6d 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 m). (let ((res
6bf0: 23 66 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 #f)). (for-ea
6c00: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
6c10: 20 28 61 72 67 29 0a 20 20 20 20 20 20 20 28 69 (arg). (i
6c20: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
6c30: 61 72 67 29 28 73 65 74 21 20 72 65 73 20 23 74 arg)(set! res #t
6c40: 29 29 29 0a 20 20 20 20 20 70 61 72 61 6d 29 0a ))). param).
6c50: 20 20 20 20 72 65 73 29 29 0a 0a 3b 3b 20 63 6f res))..;; co
6c60: 6e 76 65 72 74 20 73 74 75 66 66 20 74 6f 20 61 nvert stuff to a
6c70: 20 6e 75 6d 62 65 72 20 69 66 20 70 6f 73 73 69 number if possi
6c80: 62 6c 65 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 ble.(define (any
6c90: 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 ->number val).
6ca0: 28 63 6f 6e 64 20 0a 20 20 20 28 28 6e 75 6d 62 (cond . ((numb
6cb0: 65 72 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 er? val) val).
6cc0: 20 28 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 ((string? val)
6cd0: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
6ce0: 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f val)). ((symbo
6cf0: 6c 3f 20 76 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 l? val) (any->nu
6d00: 6d 62 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 mber (symbol->st
6d10: 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 28 ring val))). (
6d20: 65 6c 73 65 20 23 66 29 29 29 0a 0a 28 64 65 66 else #f)))..(def
6d30: 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 ine (any->number
6d40: 2d 69 66 2d 70 6f 73 73 69 62 6c 65 20 76 61 6c -if-possible val
6d50: 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 20 28 ). (let ((num (
6d60: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 any->number val)
6d70: 29 29 0a 20 20 20 20 28 69 66 20 6e 75 6d 20 6e )). (if num n
6d80: 75 6d 20 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 um val)))..(defi
6d90: 6e 65 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 ne (patt-list-ma
6da0: 74 63 68 20 69 74 65 6d 20 70 61 74 74 73 29 0a tch item patts).
6db0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6dc0: 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 8 *default-l
6dd0: 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 2d 6c og-port* "patt-l
6de0: 69 73 74 2d 6d 61 74 63 68 20 69 74 65 6d 3d 22 ist-match item="
6df0: 20 69 74 65 6d 20 22 20 70 61 74 74 73 3d 22 20 item " patts="
6e00: 70 61 74 74 73 29 0a 20 20 28 69 66 20 28 61 6e patts). (if (an
6e10: 64 20 69 74 65 6d 20 70 61 74 74 73 29 20 20 3b d item patts) ;
6e20: 3b 20 68 65 72 65 20 77 65 20 61 72 65 20 66 69 ; here we are fi
6e30: 6c 74 65 72 69 6e 67 20 66 6f 72 20 6d 61 74 63 ltering for matc
6e40: 68 65 73 20 77 69 74 68 20 69 74 65 6d 20 70 61 hes with item pa
6e50: 74 74 65 72 6e 73 0a 20 20 20 20 20 20 28 6c 65 tterns. (le
6e60: 74 20 28 28 72 65 73 20 23 66 29 29 20 20 20 3b t ((res #f)) ;
6e70: 3b 20 6c 6f 6f 6b 20 74 68 72 6f 75 67 68 20 61 ; look through a
6e80: 6c 6c 20 74 68 65 20 69 74 65 6d 2d 70 61 74 74 ll the item-patt
6e90: 73 20 69 66 20 64 65 66 69 6e 65 64 2c 20 66 6f s if defined, fo
6ea0: 72 6d 61 74 20 69 73 20 70 61 74 74 31 2c 70 61 rmat is patt1,pa
6eb0: 74 74 32 2c 70 61 74 74 33 20 2e 2e 2e 20 77 69 tt2,patt3 ... wi
6ec0: 6c 64 63 61 72 64 20 69 73 20 25 0a 09 28 66 6f ldcard is %..(fo
6ed0: 72 2d 65 61 63 68 20 0a 09 20 28 6c 61 6d 62 64 r-each .. (lambd
6ee0: 61 20 28 70 61 74 74 29 0a 09 20 20 20 28 6c 65 a (patt).. (le
6ef0: 74 20 28 28 6d 6f 64 70 61 74 74 20 28 73 74 72 t ((modpatt (str
6f00: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 ing-substitute "
6f10: 25 22 20 22 2e 2a 22 20 70 61 74 74 20 23 74 29 %" ".*" patt #t)
6f20: 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a )).. (debug:
6f30: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 30 20 2a 64 print-info 10 *d
6f40: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6f50: 20 22 70 61 74 74 20 22 20 70 61 74 74 20 22 20 "patt " patt "
6f60: 6d 6f 64 70 61 74 74 20 22 20 6d 6f 64 70 61 74 modpatt " modpat
6f70: 74 29 0a 09 20 20 20 20 20 28 69 66 20 28 73 74 t).. (if (st
6f80: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
6f90: 78 70 20 6d 6f 64 70 61 74 74 29 20 69 74 65 6d xp modpatt) item
6fa0: 29 0a 09 09 20 28 73 65 74 21 20 72 65 73 20 23 )... (set! res #
6fb0: 74 29 29 29 29 0a 09 20 28 73 74 72 69 6e 67 2d t)))).. (string-
6fc0: 73 70 6c 69 74 20 70 61 74 74 73 20 22 2c 22 29 split patts ",")
6fd0: 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 23 74 )..res). #t
6fe0: 29 29 0a 0a 3b 3b 20 28 6d 61 70 20 70 72 69 6e ))..;; (map prin
6ff0: 74 20 28 6d 61 70 20 63 61 72 20 28 68 61 73 68 t (map car (hash
7000: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 28 72 -table->alist (r
7010: 65 61 64 2d 63 6f 6e 66 69 67 20 22 72 75 6e 63 ead-config "runc
7020: 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 20 23 onfigs.config" #
7030: 66 20 23 74 29 29 29 29 0a 28 64 65 66 69 6e 65 f #t)))).(define
7040: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 75 6e (common:get-run
7050: 63 6f 6e 66 69 67 2d 74 61 72 67 65 74 73 20 23 config-targets #
7060: 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 !key (configf #f
7070: 29 29 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 )). (let ((targ
7080: 73 20 20 20 20 20 20 20 28 73 6f 72 74 20 28 6d s (sort (m
7090: 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 ap car (hash-tab
70a0: 6c 65 2d 3e 61 6c 69 73 74 0a 09 09 09 09 20 20 le->alist.....
70b0: 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 0a 09 (or configf..
70c0: 09 09 09 09 20 28 72 65 61 64 2d 63 6f 6e 66 69 .... (read-confi
70d0: 67 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 g (conc *toppath
70e0: 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 * "/runconfigs.c
70f0: 6f 6e 66 69 67 22 29 0a 09 09 09 09 09 09 20 20 onfig").......
7100: 20 20 20 20 23 66 20 23 74 29 0a 09 09 09 09 09 #f #t)......
7110: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
7120: 65 29 29 29 29 0a 09 09 09 20 20 20 73 74 72 69 e)))).... stri
7130: 6e 67 3c 3f 29 29 0a 09 28 74 61 72 67 65 74 2d ng<?))..(target-
7140: 70 61 74 74 20 28 61 72 67 73 3a 67 65 74 2d 61 patt (args:get-a
7150: 72 67 20 22 2d 74 61 72 67 65 74 22 29 29 29 0a rg "-target"))).
7160: 20 20 20 20 28 69 66 20 74 61 72 67 65 74 2d 70 (if target-p
7170: 61 74 74 0a 09 28 66 69 6c 74 65 72 20 28 6c 61 att..(filter (la
7180: 6d 62 64 61 20 28 78 29 0a 09 09 20 20 28 70 61 mbda (x)... (pa
7190: 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 78 20 tt-list-match x
71a0: 74 61 72 67 65 74 2d 70 61 74 74 29 29 0a 09 09 target-patt))...
71b0: 74 61 72 67 73 29 0a 09 74 61 72 67 73 29 29 29 targs)..targs)))
71c0: 0a 0a 3b 3b 20 27 28 70 72 69 6e 74 20 28 73 74 ..;; '(print (st
71d0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
71e0: 20 28 6d 61 70 20 63 61 64 72 20 28 68 61 73 68 (map cadr (hash
71f0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
7200: 6c 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 lt (read-config
7210: 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 "megatest.config
7220: 22 20 5c 23 66 20 5c 23 74 29 20 22 64 69 73 6b " \#f \#t) "disk
7230: 73 22 20 27 22 27 22 27 28 22 6e 6f 6e 65 22 20 s" '"'"'("none"
7240: 22 22 29 29 29 20 22 5c 6e 22 29 29 27 0a 28 64 ""))) "\n"))'.(d
7250: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
7260: 74 2d 64 69 73 6b 73 20 23 21 6b 65 79 20 28 63 t-disks #!key (c
7270: 6f 6e 66 69 67 66 20 23 66 29 29 0a 20 20 28 68 onfigf #f)). (h
7280: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7290: 66 61 75 6c 74 20 0a 20 20 20 28 6f 72 20 63 6f fault . (or co
72a0: 6e 66 69 67 66 20 28 72 65 61 64 2d 63 6f 6e 66 nfigf (read-conf
72b0: 69 67 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e ig "megatest.con
72c0: 66 69 67 22 20 23 66 20 23 74 29 29 0a 20 20 20 fig" #f #t)).
72d0: 22 64 69 73 6b 73 22 20 27 28 22 6e 6f 6e 65 22 "disks" '("none"
72e0: 20 22 22 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 "")))..;; retur
72f0: 6e 20 66 69 72 73 74 20 63 6f 6d 6d 61 6e 64 20 n first command
7300: 74 68 61 74 20 65 78 69 73 74 73 2c 20 65 6c 73 that exists, els
7310: 65 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 e #f.;;.(define
7320: 28 63 6f 6d 6d 6f 6e 3a 77 68 69 63 68 20 63 6d (common:which cm
7330: 64 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f ds). (if (null?
7340: 20 63 6d 64 73 29 0a 20 20 20 20 20 20 23 66 0a cmds). #f.
7350: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
7360: 28 28 68 65 64 20 28 63 61 72 20 63 6d 64 73 29 ((hed (car cmds)
7370: 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 63 )... (tal (cdr c
7380: 6d 64 73 29 29 29 0a 09 28 6c 65 74 20 28 28 72 mds)))..(let ((r
7390: 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 es (with-input-f
73a0: 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 rom-pipe (conc "
73b0: 77 68 69 63 68 20 22 20 68 65 64 29 20 72 65 61 which " hed) rea
73c0: 64 2d 6c 69 6e 65 29 29 29 0a 09 20 20 28 69 66 d-line))).. (if
73d0: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 72 (and (string? r
73e0: 65 73 29 0a 09 09 20 20 20 28 66 69 6c 65 2d 65 es)... (file-e
73f0: 78 69 73 74 73 3f 20 72 65 73 29 29 0a 09 20 20 xists? res))..
7400: 20 20 20 20 72 65 73 0a 09 20 20 20 20 20 20 28 res.. (
7410: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
7420: 09 20 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 . #f... (loop
7430: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
7440: 6c 29 29 29 29 29 29 29 29 0a 20 20 0a 28 64 65 l)))))))). .(de
7450: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
7460: 2d 69 6e 73 74 61 6c 6c 2d 61 72 65 61 29 0a 20 -install-area).
7470: 20 28 6c 65 74 20 28 28 65 78 65 2d 70 61 74 68 (let ((exe-path
7480: 20 28 63 61 72 20 28 61 72 67 76 29 29 29 29 0a (car (argv)))).
7490: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
74a0: 69 73 74 73 3f 20 65 78 65 2d 70 61 74 68 29 0a ists? exe-path).
74b0: 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 .(handle-excepti
74c0: 6f 6e 73 0a 09 20 65 78 6e 0a 09 20 23 66 0a 09 ons.. exn.. #f..
74d0: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
74e0: 74 6f 72 79 0a 09 20 20 28 70 61 74 68 6e 61 6d tory.. (pathnam
74f0: 65 2d 64 69 72 65 63 74 6f 72 79 20 0a 09 20 20 e-directory ..
7500: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
7510: 74 6f 72 79 20 65 78 65 2d 70 61 74 68 29 29 29 tory exe-path)))
7520: 29 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 72 65 74 )..#f)))..;; ret
7530: 75 72 6e 20 66 69 72 73 74 20 70 61 74 68 20 74 urn first path t
7540: 68 61 74 20 63 61 6e 20 62 65 20 63 72 65 61 74 hat can be creat
7550: 65 64 20 6f 72 20 61 6c 72 65 61 64 79 20 65 78 ed or already ex
7560: 69 73 74 73 20 61 6e 64 20 69 73 20 77 72 69 74 ists and is writ
7570: 61 62 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 able.;;.(define
7580: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 (common:get-crea
7590: 74 65 2d 77 72 69 74 65 61 62 6c 65 2d 64 69 72 te-writeable-dir
75a0: 20 64 69 72 73 29 0a 20 20 28 69 66 20 28 6e 75 dirs). (if (nu
75b0: 6c 6c 3f 20 64 69 72 73 29 0a 20 20 20 20 20 20 ll? dirs).
75c0: 23 66 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f #f. (let lo
75d0: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 64 69 op ((hed (car di
75e0: 72 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 rs))... (tal (cd
75f0: 72 20 64 69 72 73 29 29 29 0a 09 28 6c 65 74 20 r dirs)))..(let
7600: 28 28 72 65 73 20 28 6f 72 20 28 61 6e 64 20 28 ((res (or (and (
7610: 64 69 72 65 63 74 6f 72 79 3f 20 68 65 64 29 0a directory? hed).
7620: 09 09 09 20 20 20 20 28 66 69 6c 65 2d 77 72 69 ... (file-wri
7630: 74 65 2d 61 63 63 65 73 73 3f 20 68 65 64 29 0a te-access? hed).
7640: 09 09 09 20 20 20 20 68 65 64 29 0a 09 09 20 20 ... hed)...
7650: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
7660: 65 70 74 69 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 eptions....exn..
7670: 09 09 23 66 0a 09 09 09 28 63 72 65 61 74 65 2d ..#f....(create-
7680: 64 69 72 65 63 74 6f 72 79 20 68 65 64 20 23 74 directory hed #t
7690: 29 29 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e ))))).. (if (an
76a0: 64 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a d (string? res).
76b0: 09 09 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f .. (directory?
76c0: 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 res)).. re
76d0: 73 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 s.. (if (nu
76e0: 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a ll? tal)... #f.
76f0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 .. (loop (car t
7700: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
7710: 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ))). .;;=======
7720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
7760: 3b 3b 20 54 20 41 20 52 20 47 20 45 20 54 20 53 ;; T A R G E T S
7770: 20 20 2c 20 20 20 53 20 54 20 41 20 54 20 45 20 , S T A T E
7780: 2c 20 20 20 53 20 54 20 41 20 54 20 55 20 53 20 , S T A T U S
7790: 2c 20 20 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 , .;;
77a0: 20 20 20 20 20 20 20 20 20 20 20 52 20 55 20 4e R U N
77b0: 20 4e 20 41 20 4d 20 45 20 20 20 20 41 20 4e 20 N A M E A N
77c0: 44 20 20 20 54 20 45 20 53 20 54 20 50 20 41 20 D T E S T P A
77d0: 54 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d T T.;;==========
77e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
77f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
7820: 20 4c 6f 6f 6b 75 70 20 61 20 76 61 6c 75 65 20 Lookup a value
7830: 69 6e 20 72 75 6e 63 6f 6e 66 69 67 73 20 62 61 in runconfigs ba
7840: 73 65 64 20 6f 6e 20 2d 72 65 71 74 61 72 67 20 sed on -reqtarg
7850: 6f 72 20 2d 74 61 72 67 65 74 0a 28 64 65 66 69 or -target.(defi
7860: 6e 65 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 ne (runconfigs-g
7870: 65 74 20 63 6f 6e 66 69 67 20 76 61 72 29 0a 20 et config var).
7880: 20 28 6c 65 74 20 28 28 74 61 72 67 20 28 63 6f (let ((targ (co
7890: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 mmon:args-get-ta
78a0: 72 67 65 74 29 29 29 20 3b 3b 20 28 6f 72 20 28 rget))) ;; (or (
78b0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
78c0: 65 71 74 61 72 67 22 29 28 61 72 67 73 3a 67 65 eqtarg")(args:ge
78d0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
78e0: 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 (getenv "MT_TARG
78f0: 45 54 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 ET")))). (if
7900: 74 61 72 67 0a 09 28 6f 72 20 28 63 6f 6e 66 69 targ..(or (confi
7910: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
7920: 20 74 61 72 67 20 76 61 72 29 0a 09 20 20 20 20 targ var)..
7930: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
7940: 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 config "default"
7950: 20 76 61 72 29 29 0a 09 28 63 6f 6e 66 69 67 66 var))..(configf
7960: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 :lookup config "
7970: 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 29 29 default" var))))
7980: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
7990: 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 65 n:args-get-state
79a0: 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 ). (or (args:ge
79b0: 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 29 28 t-arg "-state")(
79c0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
79d0: 74 61 74 65 22 29 29 29 0a 0a 28 64 65 66 69 6e tate")))..(defin
79e0: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 e (common:args-g
79f0: 65 74 2d 73 74 61 74 75 73 29 0a 20 20 28 6f 72 et-status). (or
7a00: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7a10: 2d 73 74 61 74 75 73 22 29 28 61 72 67 73 3a 67 -status")(args:g
7a20: 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 22 et-arg ":status"
7a30: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
7a40: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 65 mmon:args-get-te
7a50: 73 74 70 61 74 74 20 72 63 6f 6e 66 29 0a 20 20 stpatt rconf).
7a60: 28 6c 65 74 2a 20 28 28 74 61 67 65 78 70 72 20 (let* ((tagexpr
7a70: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
7a80: 74 61 67 65 78 70 72 22 29 29 0a 20 20 20 20 20 tagexpr")).
7a90: 20 20 20 20 28 74 61 67 73 2d 74 65 73 74 70 61 (tags-testpa
7aa0: 74 74 20 28 69 66 20 74 61 67 65 78 70 72 20 28 tt (if tagexpr (
7ab0: 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 72 75 6e string-join (run
7ac0: 73 3a 67 65 74 2d 74 65 73 74 73 2d 6d 61 74 63 s:get-tests-matc
7ad0: 68 69 6e 67 2d 74 61 67 73 20 74 61 67 65 78 70 hing-tags tagexp
7ae0: 72 29 20 22 2c 22 29 20 23 66 29 29 0a 20 20 20 r) ",") #f)).
7af0: 20 20 20 20 20 20 28 74 65 73 74 70 61 74 74 2d (testpatt-
7b00: 6b 65 79 20 20 28 69 66 20 28 61 72 67 73 3a 67 key (if (args:g
7b10: 65 74 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 70 61 et-arg "--modepa
7b20: 74 74 22 29 20 28 61 72 67 73 3a 67 65 74 2d 61 tt") (args:get-a
7b30: 72 67 20 22 2d 2d 6d 6f 64 65 70 61 74 74 22 29 rg "--modepatt")
7b40: 20 22 54 45 53 54 50 41 54 54 22 29 29 0a 20 20 "TESTPATT")).
7b50: 20 20 20 20 20 20 20 28 61 72 67 73 2d 74 65 73 (args-tes
7b60: 74 70 61 74 74 20 28 6f 72 20 28 61 72 67 73 3a tpatt (or (args:
7b70: 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 get-arg "-testpa
7b80: 74 74 22 29 20 28 61 72 67 73 3a 67 65 74 2d 61 tt") (args:get-a
7b90: 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 29 20 rg "-runtests")
7ba0: 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 "%")). (
7bb0: 72 74 65 73 74 70 61 74 74 20 20 20 20 20 28 69 rtestpatt (i
7bc0: 66 20 72 63 6f 6e 66 20 28 72 75 6e 63 6f 6e 66 f rconf (runconf
7bd0: 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 20 74 65 igs-get rconf te
7be0: 73 74 70 61 74 74 2d 6b 65 79 29 20 23 66 29 29 stpatt-key) #f))
7bf0: 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 ). (cond.
7c00: 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 0a (tags-testpatt.
7c10: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
7c20: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
7c30: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 2d 74 lt-log-port* "-t
7c40: 61 67 65 78 70 72 20 22 74 61 67 65 78 70 72 22 agexpr "tagexpr"
7c50: 20 73 65 6c 65 63 74 73 20 74 65 73 74 70 61 74 selects testpat
7c60: 74 20 22 74 61 67 73 2d 74 65 73 74 70 61 74 74 t "tags-testpatt
7c70: 29 0a 20 20 20 20 20 20 74 61 67 73 2d 74 65 73 ). tags-tes
7c80: 74 70 61 74 74 29 0a 20 20 20 20 20 28 28 61 6e tpatt). ((an
7c90: 64 20 28 65 71 75 61 6c 3f 20 61 72 67 73 2d 74 d (equal? args-t
7ca0: 65 73 74 70 61 74 74 20 22 25 22 29 20 72 74 65 estpatt "%") rte
7cb0: 73 74 70 61 74 74 29 0a 20 20 20 20 20 20 28 64 stpatt). (d
7cc0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
7cd0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
7ce0: 6f 72 74 2a 20 22 74 65 73 74 70 61 74 74 20 64 ort* "testpatt d
7cf0: 65 66 69 6e 65 64 20 69 6e 20 22 74 65 73 74 70 efined in "testp
7d00: 61 74 74 2d 6b 65 79 22 20 66 72 6f 6d 20 72 75 att-key" from ru
7d10: 6e 63 6f 6e 66 69 67 73 3a 20 22 20 72 74 65 73 nconfigs: " rtes
7d20: 74 70 61 74 74 29 0a 20 20 20 20 20 20 72 74 65 tpatt). rte
7d30: 73 74 70 61 74 74 29 0a 20 20 20 20 20 28 65 6c stpatt). (el
7d40: 73 65 20 61 72 67 73 2d 74 65 73 74 70 61 74 74 se args-testpatt
7d50: 29 29 29 29 0a 20 20 20 20 20 0a 28 64 65 66 69 )))). .(defi
7d60: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c ne (common:get-l
7d70: 69 6e 6b 74 72 65 65 29 0a 20 20 28 6f 72 20 28 inktree). (or (
7d80: 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 getenv "MT_LINKT
7d90: 52 45 45 22 29 0a 20 20 20 20 20 20 28 69 66 20 REE"). (if
7da0: 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 20 20 28 *configdat*.. (
7db0: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
7dc0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
7dd0: 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 29 29 p" "linktree")))
7de0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
7df0: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 72 75 6e 6e on:args-get-runn
7e00: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 65 ame). (let ((re
7e10: 73 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d s (or (args:get-
7e20: 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 29 0a arg "-runname").
7e30: 09 09 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 .. (args:get-arg
7e40: 20 22 3a 72 75 6e 6e 61 6d 65 22 29 0a 09 09 20 ":runname")...
7e50: 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 4e 4e (getenv "MT_RUNN
7e60: 41 4d 45 22 29 29 29 29 0a 20 20 20 20 3b 3b 20 AME")))). ;;
7e70: 28 69 66 20 72 65 73 20 28 73 65 74 2d 65 6e 76 (if res (set-env
7e80: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
7e90: 65 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 20 72 e "MT_RUNNAME" r
7ea0: 65 73 29 29 20 3b 3b 20 6e 6f 74 20 73 75 72 65 es)) ;; not sure
7eb0: 20 69 66 20 74 68 69 73 20 69 73 20 61 20 67 6f if this is a go
7ec0: 6f 64 20 69 64 65 61 2e 20 73 69 64 65 20 65 66 od idea. side ef
7ed0: 66 65 63 74 20 61 6e 64 20 61 6c 6c 20 2e 2e 2e fect and all ...
7ee0: 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 65 66 . res))..(def
7ef0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 ine (common:args
7f00: 2d 67 65 74 2d 74 61 72 67 65 74 20 23 21 6b 65 -get-target #!ke
7f10: 79 20 28 73 70 6c 69 74 20 23 66 29 29 0a 20 20 y (split #f)).
7f20: 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 20 20 (let* ((keys
7f30: 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 3f (if (hash-table?
7f40: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 20 28 6b *configdat*) (k
7f50: 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 2d 66 eys:config-get-f
7f60: 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 74 ields *configdat
7f70: 2a 29 20 27 28 29 29 29 0a 09 20 28 6e 75 6d 6b *) '())).. (numk
7f80: 65 79 73 20 28 6c 65 6e 67 74 68 20 6b 65 79 73 eys (length keys
7f90: 29 29 0a 09 20 28 74 61 72 67 65 74 20 20 28 6f )).. (target (o
7fa0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
7fb0: 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 20 20 "-reqtarg")...
7fc0: 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (args:get-ar
7fd0: 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 20 g "-target")...
7fe0: 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d 54 (getenv "MT
7ff0: 5f 54 41 52 47 45 54 22 29 29 29 0a 09 20 28 74 _TARGET"))).. (t
8000: 6c 69 73 74 20 20 20 28 69 66 20 74 61 72 67 65 list (if targe
8010: 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 t (string-split
8020: 74 61 72 67 65 74 20 22 2f 22 20 23 74 29 20 27 target "/" #t) '
8030: 28 29 29 29 0a 09 20 28 76 61 6c 69 64 20 20 20 ())).. (valid
8040: 28 69 66 20 74 61 72 67 65 74 0a 09 09 20 20 20 (if target...
8050: 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 6b 65 (or (null? ke
8060: 79 73 29 20 3b 3b 20 70 72 6f 62 61 62 6c 79 20 ys) ;; probably
8070: 64 6f 6e 27 74 20 6b 6e 6f 77 20 6f 75 72 20 6b don't know our k
8080: 65 79 73 20 79 65 74 0a 09 09 09 20 20 28 61 6e eys yet.... (an
8090: 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 6c d (not (null? tl
80a0: 69 73 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 ist))....
80b0: 28 65 71 3f 20 6e 75 6d 6b 65 79 73 20 28 6c 65 (eq? numkeys (le
80c0: 6e 67 74 68 20 74 6c 69 73 74 29 29 0a 09 09 09 ngth tlist))....
80d0: 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 28 66 (null? (f
80e0: 69 6c 74 65 72 20 73 74 72 69 6e 67 2d 6e 75 6c ilter string-nul
80f0: 6c 3f 20 74 6c 69 73 74 29 29 29 29 0a 09 09 20 l? tlist))))...
8100: 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 28 #f))). (
8110: 69 66 20 76 61 6c 69 64 0a 09 28 69 66 20 73 70 if valid..(if sp
8120: 6c 69 74 0a 09 20 20 20 20 74 6c 69 73 74 0a 09 lit.. tlist..
8130: 20 20 20 20 74 61 72 67 65 74 29 0a 09 28 69 66 target)..(if
8140: 20 74 61 72 67 65 74 0a 09 20 20 20 20 28 62 65 target.. (be
8150: 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 75 gin.. (debu
8160: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
8170: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
8180: 74 2a 20 22 49 6e 76 61 6c 69 64 20 74 61 72 67 t* "Invalid targ
8190: 65 74 2c 20 73 70 61 63 65 73 20 6f 72 20 62 6c et, spaces or bl
81a0: 61 6e 6b 73 20 6e 6f 74 20 61 6c 6c 6f 77 65 64 anks not allowed
81b0: 20 5c 22 22 20 74 61 72 67 65 74 20 22 5c 22 2c \"" target "\",
81c0: 20 74 61 72 67 65 74 20 73 68 6f 75 6c 64 20 62 target should b
81d0: 65 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 e: " (string-int
81e0: 65 72 73 70 65 72 73 65 20 6b 65 79 73 20 22 2f ersperse keys "/
81f0: 22 29 20 22 2c 20 68 61 76 65 20 22 20 74 6c 69 ") ", have " tli
8200: 73 74 20 22 20 66 6f 72 20 65 6c 65 6d 65 6e 74 st " for element
8210: 73 22 29 0a 09 20 20 20 20 20 20 23 66 29 0a 09 s").. #f)..
8220: 20 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b 20 6c #f))))..;; l
8230: 6f 67 69 63 20 66 6f 72 20 67 65 74 74 69 6e 67 ogic for getting
8240: 20 68 6f 6d 65 68 6f 73 74 2e 20 52 65 74 75 72 homehost. Retur
8250: 6e 73 20 28 68 6f 73 74 20 2e 20 61 74 2d 68 6f ns (host . at-ho
8260: 6d 65 29 0a 3b 3b 20 49 46 20 2a 74 6f 70 70 61 me).;; IF *toppa
8270: 74 68 2a 20 69 73 20 6e 6f 74 20 73 65 74 2c 20 th* is not set,
8280: 77 61 69 74 20 75 70 20 74 6f 20 66 69 76 65 20 wait up to five
8290: 73 65 63 6f 6e 64 73 20 74 72 79 69 6e 67 20 65 seconds trying e
82a0: 76 65 72 79 20 74 77 6f 20 73 65 63 6f 6e 64 73 very two seconds
82b0: 0a 3b 3b 20 28 74 68 69 73 20 69 73 20 74 6f 20 .;; (this is to
82c0: 61 63 63 6f 6d 6f 64 61 74 65 20 74 68 65 20 77 accomodate the w
82d0: 61 74 63 68 64 6f 67 29 0a 3b 3b 0a 28 64 65 66 atchdog).;;.(def
82e0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
82f0: 68 6f 6d 65 68 6f 73 74 20 23 21 6b 65 79 20 28 homehost #!key (
8300: 74 72 79 6e 75 6d 20 35 29 29 0a 20 20 3b 3b 20 trynum 5)). ;;
8310: 63 61 6c 6c 65 64 20 6f 66 74 65 6e 20 65 73 70 called often esp
8320: 65 63 69 61 6c 6c 79 20 61 74 20 73 74 61 72 74 ecially at start
8330: 20 75 70 2e 20 75 73 65 20 6d 75 74 65 78 20 74 up. use mutex t
8340: 6f 20 65 6c 69 6d 69 6e 61 74 65 20 63 6f 6c 6c o eliminate coll
8350: 69 73 69 6f 6e 73 0a 20 20 28 6d 75 74 65 78 2d isions. (mutex-
8360: 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d lock! *homehost-
8370: 6d 75 74 65 78 2a 29 0a 20 20 28 63 6f 6e 64 0a mutex*). (cond.
8380: 20 20 20 28 2a 68 6f 6d 65 2d 68 6f 73 74 2a 0a (*home-host*.
8390: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
83a0: 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 k! *homehost-mut
83b0: 65 78 2a 29 0a 20 20 20 20 2a 68 6f 6d 65 2d 68 ex*). *home-h
83c0: 6f 73 74 2a 29 0a 20 20 20 28 28 6e 6f 74 20 2a ost*). ((not *
83d0: 74 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 28 6d toppath*). (m
83e0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f utex-unlock! *ho
83f0: 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 mehost-mutex*).
8400: 20 20 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 (launch:setup
8410: 29 20 3b 3b 20 73 61 66 65 6c 79 20 6d 75 74 65 ) ;; safely mute
8420: 78 65 64 20 6e 6f 77 0a 20 20 20 20 28 69 66 20 xed now. (if
8430: 28 3e 20 74 72 79 6e 75 6d 20 30 29 0a 09 28 62 (> trynum 0)..(b
8440: 65 67 69 6e 0a 09 20 20 28 74 68 72 65 61 64 2d egin.. (thread-
8450: 73 6c 65 65 70 21 20 32 29 0a 09 20 20 28 63 6f sleep! 2).. (co
8460: 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 mmon:get-homehos
8470: 74 20 74 72 79 6e 75 6d 3a 20 28 2d 20 74 72 79 t trynum: (- try
8480: 6e 75 6d 20 31 29 29 29 0a 09 23 66 29 29 0a 20 num 1)))..#f)).
8490: 20 20 28 65 6c 73 65 0a 20 20 20 20 28 6c 65 74 (else. (let
84a0: 2a 20 28 28 63 75 72 72 68 6f 73 74 20 28 67 65 * ((currhost (ge
84b0: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 t-host-name))..
84c0: 20 20 28 62 65 73 74 61 64 72 73 20 28 73 65 72 (bestadrs (ser
84d0: 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 ver:get-best-gue
84e0: 73 73 2d 61 64 64 72 65 73 73 20 63 75 72 72 68 ss-address currh
84f0: 6f 73 74 29 29 0a 09 20 20 20 3b 3b 20 66 69 72 ost)).. ;; fir
8500: 73 74 20 6c 6f 6f 6b 20 69 6e 20 63 6f 6e 66 69 st look in confi
8510: 67 2c 20 74 68 65 6e 20 6c 6f 6f 6b 20 69 6e 20 g, then look in
8520: 66 69 6c 65 20 2e 68 6f 6d 65 68 6f 73 74 2c 20 file .homehost,
8530: 63 72 65 61 74 65 20 69 74 20 69 66 20 6e 6f 74 create it if not
8540: 20 66 6f 75 6e 64 0a 09 20 20 20 28 68 6f 6d 65 found.. (home
8550: 68 6f 73 74 20 28 6f 72 20 28 63 6f 6e 66 69 67 host (or (config
8560: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
8570: 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 68 dat* "server" "h
8580: 6f 6d 65 68 6f 73 74 22 20 29 0a 09 09 09 20 28 omehost" ).... (
8590: 6c 65 74 20 28 28 68 68 66 20 28 63 6f 6e 63 20 let ((hhf (conc
85a0: 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e 68 6f 6d *toppath* "/.hom
85b0: 65 68 6f 73 74 22 29 29 29 0a 09 09 09 20 20 20 ehost")))....
85c0: 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 (if (file-exists
85d0: 3f 20 68 68 66 29 0a 09 09 09 20 20 20 20 20 20 ? hhf)....
85e0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
85f0: 6d 2d 66 69 6c 65 20 68 68 66 20 72 65 61 64 2d m-file hhf read-
8600: 6c 69 6e 65 29 0a 09 09 09 20 20 20 20 20 20 20 line)....
8610: 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 65 2d (if (file-write-
8620: 61 63 63 65 73 73 3f 20 2a 74 6f 70 70 61 74 68 access? *toppath
8630: 2a 29 0a 09 09 09 09 20 20 20 28 62 65 67 69 6e *)..... (begin
8640: 0a 09 09 09 09 20 20 20 20 20 28 77 69 74 68 2d ..... (with-
8650: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 68 output-to-file h
8660: 68 66 0a 09 09 09 09 20 20 20 20 20 20 20 28 6c hf..... (l
8670: 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 20 28 ambda ()...... (
8680: 70 72 69 6e 74 20 62 65 73 74 61 64 72 73 29 29 print bestadrs))
8690: 29 0a 09 09 09 09 20 20 20 20 20 28 62 65 67 69 )..... (begi
86a0: 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 6d 75 n..... (mu
86b0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d tex-unlock! *hom
86c0: 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 09 09 ehost-mutex*)...
86d0: 09 09 20 20 20 20 20 20 20 28 63 61 72 20 28 63 .. (car (c
86e0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f ommon:get-homeho
86f0: 73 74 29 29 29 29 0a 09 09 09 09 20 20 20 23 66 st))))..... #f
8700: 29 29 29 29 29 0a 09 20 20 20 28 61 74 2d 68 6f ))))).. (at-ho
8710: 6d 65 20 20 28 6f 72 20 28 65 71 75 61 6c 3f 20 me (or (equal?
8720: 68 6f 6d 65 68 6f 73 74 20 63 75 72 72 68 6f 73 homehost currhos
8730: 74 29 0a 09 09 09 20 28 65 71 75 61 6c 3f 20 68 t).... (equal? h
8740: 6f 6d 65 68 6f 73 74 20 62 65 73 74 61 64 72 73 omehost bestadrs
8750: 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 )))). (set!
8760: 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 28 63 6f *home-host* (co
8770: 6e 73 20 68 6f 6d 65 68 6f 73 74 20 61 74 2d 68 ns homehost at-h
8780: 6f 6d 65 29 29 0a 20 20 20 20 20 20 28 6d 75 74 ome)). (mut
8790: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 ex-unlock! *home
87a0: 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 host-mutex*).
87b0: 20 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 29 29 *home-host*))
87c0: 29 29 0a 0a 3b 3b 20 61 6d 20 49 20 6f 6e 20 74 ))..;; am I on t
87d0: 68 65 20 68 6f 6d 65 68 6f 73 74 3f 0a 3b 3b 0a he homehost?.;;.
87e0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
87f0: 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 20 20 on-homehost?).
8800: 28 6c 65 74 20 28 28 68 68 20 28 63 6f 6d 6d 6f (let ((hh (commo
8810: 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 n:get-homehost))
8820: 29 0a 20 20 20 20 28 69 66 20 68 68 0a 09 28 63 ). (if hh..(c
8830: 64 72 20 68 68 29 0a 09 23 66 29 29 29 0a 0a 3b dr hh)..#f)))..;
8840: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
8850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8860: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8870: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8880: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 =======.;; M I S
8890: 20 43 20 20 20 4c 20 49 20 53 20 54 20 53 0a 3b C L I S T S.;
88a0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
88b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
88c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
88d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
88e0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 74 65 6d =======..;; item
88f0: 73 20 69 6e 20 6c 69 73 74 61 20 61 72 65 20 6d s in lista are m
8900: 61 74 63 68 65 64 20 76 61 6c 75 65 20 61 6e 64 atched value and
8910: 20 70 6f 73 69 74 69 6f 6e 20 69 6e 20 6c 69 73 position in lis
8920: 74 62 0a 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 tb.;; return the
8930: 20 72 65 6d 61 69 6e 69 6e 67 20 69 74 65 6d 73 remaining items
8940: 20 69 6e 20 6c 69 73 74 62 20 6f 72 20 23 66 0a in listb or #f.
8950: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
8960: 6f 6e 3a 6c 69 73 74 2d 69 73 2d 73 75 62 6c 69 on:list-is-subli
8970: 73 74 20 6c 69 73 74 61 20 6c 69 73 74 62 29 0a st lista listb).
8980: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 69 73 (if (null? lis
8990: 74 61 29 0a 20 20 20 20 20 20 6c 69 73 74 62 20 ta). listb
89a0: 3b 3b 20 61 6c 6c 20 69 74 65 6d 73 20 69 6e 20 ;; all items in
89b0: 6c 69 73 74 62 20 61 72 65 20 22 72 65 6d 61 69 listb are "remai
89c0: 6e 69 6e 67 22 0a 20 20 20 20 20 20 28 69 66 20 ning". (if
89d0: 28 3e 20 28 6c 65 6e 67 74 68 20 6c 69 73 74 61 (> (length lista
89e0: 29 28 6c 65 6e 67 74 68 20 6c 69 73 74 62 29 29 )(length listb))
89f0: 20 0a 09 20 20 23 66 0a 09 20 20 28 6c 65 74 20 .. #f.. (let
8a00: 6c 6f 6f 70 20 28 28 68 65 64 61 20 28 63 61 72 loop ((heda (car
8a10: 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 20 lista))...
8a20: 28 74 61 6c 61 20 28 63 64 72 20 6c 69 73 74 61 (tala (cdr lista
8a30: 29 29 0a 09 09 20 20 20 20 20 28 68 65 64 62 20 ))... (hedb
8a40: 28 63 61 72 20 6c 69 73 74 62 29 29 0a 09 09 20 (car listb))...
8a50: 20 20 20 20 28 74 61 6c 62 20 28 63 64 72 20 6c (talb (cdr l
8a60: 69 73 74 62 29 29 29 0a 09 20 20 20 20 28 69 66 istb))).. (if
8a70: 20 28 65 71 75 61 6c 3f 20 68 65 64 61 20 68 65 (equal? heda he
8a80: 64 62 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f db)...(if (null?
8a90: 20 74 61 6c 61 29 20 3b 3b 20 77 65 20 61 72 65 tala) ;; we are
8aa0: 20 64 6f 6e 65 0a 09 09 20 20 20 20 74 61 6c 62 done... talb
8ab0: 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 ... (loop (ca
8ac0: 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 64 r tala).... (cd
8ad0: 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 61 r tala).... (ca
8ae0: 72 20 74 61 6c 62 29 0a 09 09 09 20 20 0a 09 09 r talb).... ...
8af0: 09 20 20 28 63 64 72 20 74 61 6c 62 29 29 29 0a . (cdr talb))).
8b00: 09 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 4e 65 ..#f)))))..;; Ne
8b10: 65 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 6c 69 eded for long li
8b20: 73 74 73 20 74 6f 20 62 65 20 73 6f 72 74 65 64 sts to be sorted
8b30: 20 77 68 65 72 65 20 28 61 70 70 6c 79 20 6d 61 where (apply ma
8b40: 78 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b 3b 0a x ... ) dies.;;.
8b50: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
8b60: 6d 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 6c 65 max inlst). (le
8b70: 74 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 61 6c t loop ((max-val
8b80: 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 (car inlst))..
8b90: 20 20 20 20 28 68 65 64 20 20 20 20 20 28 63 61 (hed (ca
8ba0: 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 20 20 r inlst))..
8bb0: 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 69 6e (tal (cdr in
8bc0: 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 lst))). (if (
8bd0: 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 not (null? tal))
8be0: 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 65 64 ..(loop (max hed
8bf0: 20 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 20 20 max-val)..
8c00: 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 20 20 (car tal)..
8c10: 20 20 28 63 64 72 20 74 61 6c 29 29 0a 09 28 6d (cdr tal))..(m
8c20: 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 29 ax hed max-val))
8c30: 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e 20 6f ))..;; get min o
8c40: 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 6f 72 r max, use > for
8c50: 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 20 6d max and < for m
8c60: 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 20 61 in, this works a
8c70: 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 74 73 round the limits
8c80: 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 64 65 on apply.;;.(de
8c90: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d 69 6e fine (common:min
8ca0: 2d 6d 61 78 20 63 6f 6d 70 20 6c 73 74 29 0a 20 -max comp lst).
8cb0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 29 (if (null? lst)
8cc0: 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 62 65 74 . #f ;; bet
8cd0: 74 65 72 20 74 68 61 6e 20 61 6e 20 65 78 63 65 ter than an exce
8ce0: 70 74 69 6f 6e 20 66 6f 72 20 6d 79 20 6e 65 65 ption for my nee
8cf0: 64 73 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 28 ds. (fold (
8d00: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 20 lambda (a b)..
8d10: 20 20 20 20 28 69 66 20 28 63 6f 6d 70 20 61 20 (if (comp a
8d20: 62 29 20 61 20 62 29 29 0a 09 20 20 20 20 28 63 b) a b)).. (c
8d30: 61 72 20 6c 73 74 29 0a 09 20 20 20 20 6c 73 74 ar lst).. lst
8d40: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e 20 )))..;; get min
8d50: 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 6f or max, use > fo
8d60: 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 20 r max and < for
8d70: 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 20 min, this works
8d80: 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 74 around the limit
8d90: 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 64 s on apply.;;.(d
8da0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 75 efine (common:su
8db0: 6d 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6e 75 m lst). (if (nu
8dc0: 6c 6c 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 30 ll? lst). 0
8dd0: 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c 61 . (fold (la
8de0: 6d 62 64 61 20 28 61 20 62 29 0a 09 20 20 20 20 mbda (a b)..
8df0: 20 20 28 2b 20 61 20 62 29 29 0a 09 20 20 20 20 (+ a b))..
8e00: 28 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 6c (car lst).. l
8e10: 73 74 29 29 29 0a 0a 3b 3b 20 70 61 74 68 20 6c st)))..;; path l
8e20: 69 73 74 20 74 6f 20 68 61 73 68 2d 74 61 62 6c ist to hash-tabl
8e30: 65 20 74 72 65 65 0a 3b 3b 20 20 20 28 28 61 20 e tree.;; ((a
8e40: 62 20 63 29 28 61 20 62 20 64 29 28 65 20 62 20 b c)(a b d)(e b
8e50: 63 29 29 20 3d 3e 20 28 28 61 20 28 62 20 28 64 c)) => ((a (b (d
8e60: 29 20 28 63 29 29 29 20 28 65 20 28 62 20 28 63 ) (c))) (e (b (c
8e70: 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 )))).;;.(define
8e80: 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 (common:list->ht
8e90: 72 65 65 20 6c 73 74 29 0a 20 20 28 6c 65 74 20 ree lst). (let
8ea0: 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 ((resh (make-has
8eb0: 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 h-table))). (
8ec0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
8ed0: 61 6d 62 64 61 20 28 69 6e 6c 73 74 29 0a 20 20 ambda (inlst).
8ee0: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
8ef0: 28 68 74 20 20 72 65 73 68 29 0a 09 09 20 20 28 (ht resh)... (
8f00: 68 65 64 20 28 63 61 72 20 69 6e 6c 73 74 29 29 hed (car inlst))
8f10: 0a 09 09 20 20 28 74 61 6c 20 28 63 64 72 20 69 ... (tal (cdr i
8f20: 6e 6c 73 74 29 29 29 0a 09 20 28 69 66 20 28 68 nlst))).. (if (h
8f30: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
8f40: 66 61 75 6c 74 20 68 74 20 68 65 64 20 23 66 29 fault ht hed #f)
8f50: 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 .. (if (not
8f60: 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 (null? tal))...
8f70: 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 6c (loop (hash-tabl
8f80: 65 2d 72 65 66 20 68 74 20 68 65 64 29 0a 09 09 e-ref ht hed)...
8f90: 20 20 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 (car tal)
8fa0: 0a 09 09 20 20 20 20 20 20 20 28 63 64 72 20 74 ... (cdr t
8fb0: 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 al))).. (beg
8fc0: 69 6e 0a 09 20 20 20 20 20 20 20 28 68 61 73 68 in.. (hash
8fd0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 68 -table-set! ht h
8fe0: 65 64 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 ed (make-hash-ta
8ff0: 62 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c ble)).. (l
9000: 6f 6f 70 20 68 74 20 68 65 64 20 74 61 6c 29 29 oop ht hed tal))
9010: 29 29 29 0a 20 20 20 20 20 6c 73 74 29 0a 20 20 ))). lst).
9020: 20 20 72 65 73 68 29 29 0a 0a 3b 3b 20 68 61 73 resh))..;; has
9030: 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 h-table tree to
9040: 68 74 6d 6c 20 6c 69 73 74 20 74 72 65 65 0a 3b html list tree.;
9050: 3b 0a 3b 3b 20 20 20 74 69 70 66 75 6e 63 20 74 ;.;; tipfunc t
9060: 61 6b 65 73 20 74 77 6f 20 70 61 72 61 6d 65 74 akes two paramet
9070: 65 72 73 3a 20 79 20 74 68 65 20 74 69 70 20 76 ers: y the tip v
9080: 61 6c 75 65 20 61 6e 64 20 70 61 74 68 20 74 68 alue and path th
9090: 65 20 70 61 74 68 20 74 6f 20 74 68 61 74 20 70 e path to that p
90a0: 6f 69 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 oint.;;.(define
90b0: 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 (common:htree->h
90c0: 74 6d 6c 20 68 74 20 70 61 74 68 20 74 69 70 66 tml ht path tipf
90d0: 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 64 61 unc). (let ((da
90e0: 74 6c 69 73 74 20 09 28 73 6f 72 74 20 28 68 61 tlist .(sort (ha
90f0: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
9100: 68 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ht).
9110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9120: 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a (lambda (a b).
9130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9150: 28 73 74 72 69 6e 67 3c 20 28 63 61 72 20 61 29 (string< (car a)
9160: 28 63 61 72 20 62 29 29 29 29 29 29 0a 20 20 20 (car b)))))).
9170: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 6c (if (null? datl
9180: 69 73 74 29 0a 20 20 20 20 09 28 74 69 70 66 75 ist). .(tipfu
9190: 6e 63 20 23 66 20 70 61 74 68 29 20 3b 3b 20 72 nc #f path) ;; r
91a0: 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 eally shouldn't
91b0: 67 65 74 20 68 65 72 65 0a 09 28 73 3a 75 6c 0a get here..(s:ul.
91c0: 09 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 . (map (lambda (
91d0: 78 29 0a 09 09 28 6c 65 74 2a 20 28 28 6c 65 76 x)...(let* ((lev
91e0: 65 6c 6e 61 6d 65 20 28 63 61 72 20 78 29 29 0a elname (car x)).
91f0: 09 09 20 20 20 20 20 20 20 28 79 20 20 20 20 20 .. (y
9200: 20 20 20 20 28 63 64 72 20 78 29 29 0a 09 09 20 (cdr x))...
9210: 20 20 20 20 20 20 28 6e 65 77 70 61 74 68 20 20 (newpath
9220: 20 28 61 70 70 65 6e 64 20 70 61 74 68 20 28 6c (append path (l
9230: 69 73 74 20 6c 65 76 65 6c 6e 61 6d 65 29 29 29 ist levelname)))
9240: 0a 09 09 20 20 20 20 20 20 20 28 6c 65 61 66 20 ... (leaf
9250: 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 68 (or (not (h
9260: 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 29 0a 09 ash-table? y))..
9270: 09 09 09 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 ... (null?
9280: 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
9290: 20 79 29 29 29 29 29 0a 09 09 20 20 28 69 66 20 y)))))... (if
92a0: 6c 65 61 66 0a 09 09 20 20 20 20 20 20 28 73 3a leaf... (s:
92b0: 6c 69 20 28 74 69 70 66 75 6e 63 20 79 20 6e 65 li (tipfunc y ne
92c0: 77 70 61 74 68 29 29 0a 09 09 20 20 20 20 20 20 wpath))...
92d0: 28 73 3a 6c 69 0a 09 09 20 20 20 20 20 20 20 28 (s:li... (
92e0: 6c 69 73 74 20 0a 09 09 09 6c 65 76 65 6c 6e 61 list ....levelna
92f0: 6d 65 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a 68 74 me....(common:ht
9300: 72 65 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 77 70 ree->html y newp
9310: 61 74 68 20 74 69 70 66 75 6e 63 29 29 29 29 29 ath tipfunc)))))
9320: 29 0a 09 20 20 20 20 20 20 64 61 74 6c 69 73 74 ).. datlist
9330: 29 29 29 29 29 0a 0a 3b 3b 20 68 61 73 68 2d 74 )))))..;; hash-t
9340: 61 62 6c 65 20 74 72 65 65 20 74 6f 20 61 6c 69 able tree to ali
9350: 73 74 20 74 72 65 65 0a 3b 3b 0a 28 64 65 66 69 st tree.;;.(defi
9360: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 ne (common:htree
9370: 2d 3e 61 74 72 65 65 20 68 74 29 0a 20 20 28 6d ->atree ht). (m
9380: 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 ap (lambda (x)..
9390: 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 0a 09 (cons (car x)..
93a0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 79 20 (let ((y
93b0: 28 63 64 72 20 78 29 29 29 0a 09 09 20 28 69 66 (cdr x)))... (if
93c0: 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 (hash-table? y)
93d0: 0a 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ... (common:
93e0: 68 74 72 65 65 2d 3e 61 74 72 65 65 20 79 29 0a htree->atree y).
93f0: 09 09 20 20 20 20 20 79 29 29 29 29 0a 20 20 20 .. y)))).
9400: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
9410: 3e 61 6c 69 73 74 20 68 74 29 29 29 0a 0a 3b 3b >alist ht)))..;;
9420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9460: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4e 20 ======.;; M U N
9470: 47 20 45 20 20 20 44 20 41 20 54 20 41 20 20 20 G E D A T A
9480: 49 20 4e 20 54 20 4f 20 20 20 4e 20 49 20 43 20 I N T O N I C
9490: 45 20 20 20 46 20 4f 20 52 20 4d 20 53 0a 3b 3b E F O R M S.;;
94a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
94e0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 72 ======..;; Gener
94f0: 61 74 65 20 61 6e 20 69 6e 64 65 78 20 66 6f 72 ate an index for
9500: 20 61 20 73 70 61 72 73 65 20 6c 69 73 74 20 6f a sparse list o
9510: 66 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b 3b 20 f key values.;;
9520: 20 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 63 6f ( (rowname1 co
9530: 6c 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 6f 77 lname1 val1)(row
9540: 6e 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 20 76 name2 colname2 v
9550: 61 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e 20 al2) ).;;.;; =>
9560: 0a 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e .;;.;; ( (rown
9570: 61 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d 65 32 ame1 0)(rowname2
9580: 20 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 6e 61 1)) ;; rowna
9590: 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 20 mes -> num.;;
95a0: 20 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 28 63 (colname1 0)(c
95b0: 6f 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 20 3b olname2 1)) ) ;
95c0: 3b 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e 75 ; colnames -> nu
95d0: 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e 61 m.;; .;; optiona
95e0: 6c 20 61 70 70 6c 79 20 70 72 6f 63 20 74 6f 20 l apply proc to
95f0: 72 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 61 rownum colnum va
9600: 6c 75 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d lue.(define (com
9610: 6d 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 74 2d mon:sparse-list-
9620: 67 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 20 64 generate-index d
9630: 61 74 61 20 23 21 6b 65 79 20 28 70 72 6f 63 20 ata #!key (proc
9640: 23 66 29 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c #f)). (if (null
9650: 3f 20 64 61 74 61 29 0a 20 20 20 20 20 20 28 6c ? data). (l
9660: 69 73 74 20 27 28 29 20 27 28 29 29 0a 20 20 20 ist '() '()).
9670: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
9680: 65 64 20 28 63 61 72 20 64 61 74 61 29 29 0a 09 ed (car data))..
9690: 09 20 28 74 61 6c 20 28 63 64 72 20 64 61 74 61 . (tal (cdr data
96a0: 29 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 73 20 ))... (rownames
96b0: 27 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 6d 65 '())... (colname
96c0: 73 20 27 28 29 29 0a 09 09 20 28 72 6f 77 6e 75 s '())... (rownu
96d0: 6d 20 20 20 30 29 0a 09 09 20 28 63 6f 6c 6e 75 m 0)... (colnu
96e0: 6d 20 20 20 30 29 29 0a 09 28 6c 65 74 2a 20 28 m 0))..(let* (
96f0: 28 72 6f 77 6b 65 79 20 20 20 20 20 20 20 20 20 (rowkey
9700: 20 28 63 61 72 20 20 20 68 65 64 29 29 0a 09 20 (car hed))..
9710: 20 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 20 20 (colkey
9720: 20 20 20 20 20 20 20 28 63 61 64 72 20 20 68 65 (cadr he
9730: 64 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 6c d)).. (val
9740: 75 65 20 20 20 20 20 20 20 20 20 20 20 28 63 61 ue (ca
9750: 64 64 72 20 68 65 64 29 29 0a 09 20 20 20 20 20 ddr hed))..
9760: 20 20 28 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 (existing-rowd
9770: 61 74 20 28 61 73 73 6f 63 20 72 6f 77 6b 65 79 at (assoc rowkey
9780: 20 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 20 20 rownames))..
9790: 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d 63 6f (existing-co
97a0: 6c 64 61 74 20 28 61 73 73 6f 63 20 63 6f 6c 6b ldat (assoc colk
97b0: 65 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 20 ey colnames))..
97c0: 20 20 20 20 20 20 28 63 75 72 72 2d 72 6f 77 6e (curr-rown
97d0: 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 74 um (if exist
97e0: 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e 75 ing-rowdat rownu
97f0: 6d 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 29 29 m (+ rownum 1)))
9800: 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 63 .. (curr-c
9810: 6f 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 olnum (if ex
9820: 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 63 6f isting-coldat co
9830: 6c 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 31 lnum (+ colnum 1
9840: 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 77 ))).. (new
9850: 2d 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 69 66 -rownames (if
9860: 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 existing-rowdat
9870: 20 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e 73 20 rownames (cons
9880: 28 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 75 72 (list rowkey cur
9890: 72 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 6d r-rownum) rownam
98a0: 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e es))).. (n
98b0: 65 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 20 28 ew-colnames (
98c0: 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 if existing-cold
98d0: 61 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 6f 6e at colnames (con
98e0: 73 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 20 63 s (list colkey c
98f0: 75 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c 6e urr-colnum) coln
9900: 61 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b 20 28 ames)))).. ;; (
9910: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
9920: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
9930: 70 6f 72 74 2a 20 22 50 72 6f 63 65 73 73 69 6e port* "Processin
9940: 67 20 72 65 63 6f 72 64 3a 20 22 20 68 65 64 20 g record: " hed
9950: 29 0a 09 20 20 28 69 66 20 70 72 6f 63 20 28 70 ).. (if proc (p
9960: 72 6f 63 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 roc curr-rownum
9970: 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 6b curr-colnum rowk
9980: 65 79 20 63 6f 6c 6b 65 79 20 76 61 6c 75 65 29 ey colkey value)
9990: 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 ).. (if (null?
99a0: 74 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 69 73 tal).. (lis
99b0: 74 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 6e t new-rownames n
99c0: 65 77 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 20 ew-colnames)..
99d0: 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 (loop (car t
99e0: 61 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 al)... (cdr t
99f0: 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 2d 72 6f al)... new-ro
9a00: 77 6e 61 6d 65 73 0a 09 09 20 20 20 20 6e 65 77 wnames... new
9a10: 2d 63 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 20 20 -colnames...
9a20: 28 69 66 20 28 3e 20 63 75 72 72 2d 72 6f 77 6e (if (> curr-rown
9a30: 75 6d 20 72 6f 77 6e 75 6d 29 20 63 75 72 72 2d um rownum) curr-
9a40: 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a 09 rownum rownum)..
9a50: 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 72 . (if (> curr
9a60: 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 20 -colnum colnum)
9a70: 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e curr-colnum coln
9a80: 75 6d 29 0a 09 09 20 20 20 20 29 29 29 29 29 29 um)... ))))))
9a90: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
9aa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 ==========.;; S
9ae0: 59 20 53 20 54 20 45 20 4d 20 20 20 53 20 54 20 Y S T E M S T
9af0: 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d U F F.;;========
9b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9b30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
9b40: 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 74 ;; lazy-safe get
9b50: 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e 20 file mod time.
9b60: 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 66 69 on any error (fi
9b70: 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 20 le not existing
9b80: 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 0a 3b etc.) return 0.;
9b90: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
9ba0: 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 n:lazy-modificat
9bb0: 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a ion-time fpath).
9bc0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
9bd0: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 30 ions. exn. 0
9be0: 0a 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 . (file-modifi
9bf0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 cation-time fpat
9c00: 68 29 29 29 0a 0a 3b 3b 20 66 69 6e 64 20 74 69 h)))..;; find ti
9c10: 6d 65 73 74 61 6d 70 20 6f 66 20 6e 65 77 65 73 mestamp of newes
9c20: 74 20 66 69 6c 65 20 61 73 73 6f 63 69 61 74 65 t file associate
9c30: 64 20 77 69 74 68 20 61 20 73 71 6c 69 74 65 20 d with a sqlite
9c40: 64 62 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 20 db file.(define
9c50: 28 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 73 71 6c (common:lazy-sql
9c60: 69 74 65 2d 64 62 2d 6d 6f 64 69 66 69 63 61 74 ite-db-modificat
9c70: 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a ion-time fpath).
9c80: 20 20 28 6c 65 74 2a 20 28 28 67 6c 6f 62 2d 6c (let* ((glob-l
9c90: 69 73 74 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ist (handle-exce
9ca0: 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 ptions.
9cb0: 20 20 20 20 20 20 20 20 20 20 20 65 78 6e 0a 20 exn.
9cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9cd0: 20 20 20 27 28 22 2f 6e 6f 2f 73 75 63 68 2f 66 '("/no/such/f
9ce0: 69 6c 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 ile").
9cf0: 20 20 20 20 20 20 20 20 20 20 28 67 6c 6f 62 20 (glob
9d00: 28 63 6f 6e 63 20 66 70 61 74 68 20 22 2a 22 29 (conc fpath "*")
9d10: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 66 69 ))). (fi
9d20: 6c 65 2d 6c 69 73 74 20 28 69 66 20 28 65 71 3f le-list (if (eq?
9d30: 20 30 20 28 6c 65 6e 67 74 68 20 67 6c 6f 62 2d 0 (length glob-
9d40: 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 20 20 list)).
9d50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 27 '
9d60: 28 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 22 ("/no/such/file"
9d70: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9d80: 20 20 20 20 20 20 20 20 20 20 67 6c 6f 62 2d 6c glob-l
9d90: 69 73 74 29 29 29 0a 20 20 28 61 70 70 6c 79 20 ist))). (apply
9da0: 6d 61 78 0a 20 20 20 28 6d 61 70 0a 20 20 20 20 max. (map.
9db0: 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 common:lazy-modi
9dc0: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 0a 20 fication-time .
9dd0: 20 20 20 66 69 6c 65 2d 6c 69 73 74 29 29 29 29 file-list))))
9de0: 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 61 20 6e 69 ..;; return a ni
9df0: 63 65 20 63 6c 65 61 6e 20 70 61 74 68 6e 61 6d ce clean pathnam
9e00: 65 20 6d 61 64 65 20 61 62 73 6f 6c 75 74 65 0a e made absolute.
9e10: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
9e20: 6e 69 63 65 2d 70 61 74 68 20 64 69 72 29 0a 20 nice-path dir).
9e30: 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 (let ((match (s
9e40: 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 28 7e tring-match "^(~
9e50: 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 2e 2a 7c 29 [^\\/]*)(\\/.*|)
9e60: 24 22 20 64 69 72 29 29 29 0a 20 20 20 20 28 69 $" dir))). (i
9e70: 66 20 6d 61 74 63 68 20 3b 3b 20 75 73 69 6e 67 f match ;; using
9e80: 20 7e 20 66 6f 72 20 68 6f 6d 65 3f 0a 09 28 63 ~ for home?..(c
9e90: 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 ommon:nice-path
9ea0: 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 72 65 (conc (common:re
9eb0: 61 64 2d 6c 69 6e 6b 2d 66 20 28 63 61 64 72 20 ad-link-f (cadr
9ec0: 6d 61 74 63 68 29 29 20 22 2f 22 20 28 63 61 64 match)) "/" (cad
9ed0: 64 72 20 6d 61 74 63 68 29 29 29 0a 09 28 6e 6f dr match)))..(no
9ee0: 72 6d 61 6c 69 7a 65 2d 70 61 74 68 6e 61 6d 65 rmalize-pathname
9ef0: 20 28 69 66 20 28 61 62 73 6f 6c 75 74 65 2d 70 (if (absolute-p
9f00: 61 74 68 6e 61 6d 65 3f 20 64 69 72 29 0a 09 09 athname? dir)...
9f10: 09 09 64 69 72 0a 09 09 09 09 28 63 6f 6e 63 20 ..dir.....(conc
9f20: 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f (current-directo
9f30: 72 79 29 20 22 2f 22 20 64 69 72 29 29 29 29 29 ry) "/" dir)))))
9f40: 29 0a 0a 3b 3b 20 6d 61 6b 65 20 22 6e 69 63 65 )..;; make "nice
9f50: 2d 70 61 74 68 22 20 61 76 61 69 6c 61 62 6c 65 -path" available
9f60: 20 69 6e 20 63 6f 6e 66 69 67 20 66 69 6c 65 73 in config files
9f70: 20 61 6e 64 20 74 68 65 20 72 65 70 6c 0a 28 64 and the repl.(d
9f80: 65 66 69 6e 65 20 6e 69 63 65 2d 70 61 74 68 20 efine nice-path
9f90: 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 common:nice-path
9fa0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
9fb0: 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 70 on:read-link-f p
9fc0: 61 74 68 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 ath). (handle-e
9fd0: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 xceptions.
9fe0: 65 78 6e 0a 20 20 20 20 20 20 28 62 65 67 69 6e exn. (begin
9ff0: 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 ..(debug:print-e
a000: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
a010: 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d 6d 61 log-port* "comma
a020: 6e 64 20 5c 22 2f 62 69 6e 2f 72 65 61 64 6c 69 nd \"/bin/readli
a030: 6e 6b 20 2d 66 20 22 20 70 61 74 68 20 22 5c 22 nk -f " path "\"
a040: 20 66 61 69 6c 65 64 2e 22 29 0a 09 70 61 74 68 failed.")..path
a050: 29 20 3b 3b 20 6a 75 73 74 20 67 69 76 65 20 75 ) ;; just give u
a060: 70 0a 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 p. (with-inpu
a070: 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 28 63 6f t-from-pipe..(co
a080: 6e 63 20 22 2f 62 69 6e 2f 72 65 61 64 6c 69 6e nc "/bin/readlin
a090: 6b 20 2d 66 20 22 20 70 61 74 68 29 0a 20 20 20 k -f " path).
a0a0: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 (lambda ()..(
a0b0: 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 0a 0a read-line)))))..
a0c0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 63 70 75 (define (get-cpu
a0d0: 2d 6c 6f 61 64 20 23 21 6b 65 79 20 28 72 65 6d -load #!key (rem
a0e0: 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 20 ote-host #f)).
a0f0: 28 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (car (common:get
a100: 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 -cpu-load remote
a110: 2d 68 6f 73 74 29 29 29 0a 3b 3b 20 20 20 28 6c -host))).;; (l
a120: 65 74 2a 20 28 28 6c 6f 61 64 2d 72 65 73 20 28 et* ((load-res (
a130: 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d process:cmd-run-
a140: 3e 6c 69 73 74 20 22 75 70 74 69 6d 65 22 29 29 >list "uptime"))
a150: 0a 3b 3b 20 09 20 28 6c 6f 61 64 2d 72 78 20 20 .;; . (load-rx
a160: 28 72 65 67 65 78 70 20 22 6c 6f 61 64 20 61 76 (regexp "load av
a170: 65 72 61 67 65 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 erage:\\s+(\\d+)
a180: 22 29 29 0a 3b 3b 20 09 20 28 63 70 75 2d 6c 6f ")).;; . (cpu-lo
a190: 61 64 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 28 ad #f)).;; (
a1a0: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
a1b0: 20 28 6c 29 0a 3b 3b 20 09 09 28 6c 65 74 20 28 (l).;; ..(let (
a1c0: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 73 (match (string-s
a1d0: 65 61 72 63 68 20 6c 6f 61 64 2d 72 78 20 6c 29 earch load-rx l)
a1e0: 29 29 0a 3b 3b 20 09 09 20 20 28 69 66 20 6d 61 )).;; .. (if ma
a1f0: 74 63 68 0a 3b 3b 20 09 09 20 20 20 20 20 20 28 tch.;; .. (
a200: 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 74 let ((newval (st
a210: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 ring->number (ca
a220: 64 72 20 6d 61 74 63 68 29 29 29 29 0a 3b 3b 20 dr match)))).;;
a230: 09 09 09 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 ...(if (number?
a240: 6e 65 77 76 61 6c 29 0a 3b 3b 20 09 09 09 20 20 newval).;; ...
a250: 20 20 28 73 65 74 21 20 63 70 75 2d 6c 6f 61 64 (set! cpu-load
a260: 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a 3b 3b newval)))))).;;
a270: 20 09 20 20 20 20 20 20 28 63 61 72 20 6c 6f 61 . (car loa
a280: 64 2d 72 65 73 29 29 0a 3b 3b 20 20 20 20 20 63 d-res)).;; c
a290: 70 75 2d 6c 6f 61 64 29 29 0a 0a 3b 3b 20 67 65 pu-load))..;; ge
a2a0: 74 20 63 70 75 20 6c 6f 61 64 20 62 79 20 72 65 t cpu load by re
a2b0: 61 64 69 6e 67 20 66 72 6f 6d 20 2f 70 72 6f 63 ading from /proc
a2c0: 2f 6c 6f 61 64 61 76 67 2c 20 72 65 74 75 72 6e /loadavg, return
a2d0: 20 61 6c 6c 20 74 68 72 65 65 20 76 61 6c 75 65 all three value
a2e0: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f s.;;.(define (co
a2f0: 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 mmon:get-cpu-loa
a300: 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 d remote-host).
a310: 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f 73 74 (if remote-host
a320: 0a 20 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d . (map (lam
a330: 62 64 61 20 28 72 65 73 29 0a 09 20 20 20 20 20 bda (res)..
a340: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
a350: 20 72 65 73 29 20 39 65 39 39 20 72 65 73 29 29 res) 9e99 res))
a360: 0a 09 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 .. (with-input
a370: 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 20 20 20 -from-pipe ..
a380: 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 72 65 (conc "ssh " re
a390: 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 74 20 mote-host " cat
a3a0: 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 29 0a /proc/loadavg").
a3b0: 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 28 . (lambda ()(
a3c0: 6c 69 73 74 20 28 72 65 61 64 29 28 72 65 61 64 list (read)(read
a3d0: 29 28 72 65 61 64 29 29 29 29 29 0a 20 20 20 20 )(read))))).
a3e0: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
a3f0: 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 6c om-file "/proc/l
a400: 6f 61 64 61 76 67 22 20 0a 09 28 6c 61 6d 62 64 oadavg" ..(lambd
a410: 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 29 a ()(list (read)
a420: 28 72 65 61 64 29 28 72 65 61 64 29 29 29 29 29 (read)(read)))))
a430: 29 0a 0a 3b 3b 20 67 65 74 20 6e 6f 72 6d 61 6c )..;; get normal
a440: 69 7a 65 64 20 63 70 75 20 6c 6f 61 64 20 62 79 ized cpu load by
a450: 20 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 2f 70 reading from /p
a460: 72 6f 63 2f 6c 6f 61 64 61 76 67 20 61 6e 64 20 roc/loadavg and
a470: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 20 72 65 /proc/cpuinfo re
a480: 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 turn all three v
a490: 61 6c 75 65 73 20 61 6e 64 20 74 68 65 20 6e 75 alues and the nu
a4a0: 6d 62 65 72 20 6f 66 20 72 65 61 6c 20 63 70 75 mber of real cpu
a4b0: 73 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 s and the number
a4c0: 20 6f 66 20 74 68 72 65 61 64 73 0a 3b 3b 20 72 of threads.;; r
a4d0: 65 74 75 72 6e 73 20 61 6c 69 73 74 20 27 28 28 eturns alist '((
a4e0: 61 64 6a 2d 63 70 75 2d 6c 6f 61 64 20 2e 20 6e adj-cpu-load . n
a4f0: 6f 72 6d 61 6c 69 7a 65 64 2d 70 72 6f 63 2d 6c ormalized-proc-l
a500: 6f 61 64 29 20 2e 2e 2e 20 65 74 63 2e 0a 3b 3b oad) ... etc..;;
a510: 20 20 6b 65 79 73 3a 20 61 64 6a 2d 70 72 6f 63 keys: adj-proc
a520: 2d 6c 6f 61 64 2c 20 61 64 6a 2d 63 6f 72 65 2d -load, adj-core-
a530: 6c 6f 61 64 2c 20 31 6d 2d 6c 6f 61 64 2c 20 35 load, 1m-load, 5
a540: 6d 2d 6c 6f 61 64 2c 20 31 35 6d 2d 6c 6f 61 64 m-load, 15m-load
a550: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
a560: 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a mon:get-normaliz
a570: 65 64 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f ed-cpu-load remo
a580: 74 65 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 20 te-host). (let
a590: 28 28 64 61 74 61 20 28 69 66 20 72 65 6d 6f 74 ((data (if remot
a5a0: 65 2d 68 6f 73 74 0a 20 20 20 20 20 20 20 20 20 e-host.
a5b0: 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d 69 (with-i
a5c0: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a nput-from-pipe .
a5d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a5e0: 20 20 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 (conc "ssh "
a5f0: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 remote-host " ca
a600: 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 3b t /proc/loadavg;
a610: 63 61 74 20 2f 70 72 6f 63 2f 63 70 75 69 6e 66 cat /proc/cpuinf
a620: 6f 3b 65 63 68 6f 20 65 6e 64 22 29 0a 20 20 20 o;echo end").
a630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a640: 72 65 61 64 2d 6c 69 6e 65 73 29 0a 20 20 20 20 read-lines).
a650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
a660: 70 70 65 6e 64 20 0a 20 20 20 20 20 20 20 20 20 ppend .
a670: 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d (with-
a680: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
a690: 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 "/proc/loadavg"
a6a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a6b0: 20 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 read-lines
a6c0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
a6d0: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
a6e0: 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f -from-file "/pro
a6f0: 63 2f 63 70 75 69 6e 66 6f 22 0a 20 20 20 20 20 c/cpuinfo".
a700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a710: 72 65 61 64 2d 6c 69 6e 65 73 29 0a 20 20 20 20 read-lines).
a720: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
a730: 6c 69 73 74 20 22 65 6e 64 22 29 29 29 29 0a 20 list "end")))).
a740: 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 72 78 20 (load-rx
a750: 20 28 72 65 67 65 78 70 20 22 5e 28 5b 5c 5c 64 (regexp "^([\\d
a760: 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b 5c 5c 64 5c \\.]+)\\s+([\\d\
a770: 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b 5c 5c 64 5c 5c \.]+)\\s+([\\d\\
a780: 2e 5d 2b 29 5c 5c 73 2b 2e 2a 24 22 29 29 0a 20 .]+)\\s+.*$")).
a790: 20 20 20 20 20 20 20 28 70 72 6f 63 2d 72 78 20 (proc-rx
a7a0: 20 28 72 65 67 65 78 70 20 22 5e 70 72 6f 63 65 (regexp "^proce
a7b0: 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c ssor\\s+:\\s+(\\
a7c0: 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 d+)\\s*$")).
a7d0: 20 20 20 20 28 63 6f 72 65 2d 72 78 20 20 28 72 (core-rx (r
a7e0: 65 67 65 78 70 20 22 5e 63 6f 72 65 20 69 64 5c egexp "^core id\
a7f0: 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 5c 5c \s+:\\s+(\\d+)\\
a800: 73 2a 24 22 29 29 0a 20 20 20 20 20 20 20 20 28 s*$")). (
a810: 70 68 79 73 2d 72 78 20 20 28 72 65 67 65 78 70 phys-rx (regexp
a820: 20 22 5e 70 68 79 73 69 63 61 6c 20 69 64 5c 5c "^physical id\\
a830: 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 s+:\\s+(\\d+)\\s
a840: 2a 24 22 29 29 0a 20 20 20 20 20 20 20 20 28 6d *$")). (m
a850: 61 78 2d 6e 75 6d 20 20 28 6c 61 6d 62 64 61 20 ax-num (lambda
a860: 28 70 20 6e 29 28 6d 61 78 20 28 73 74 72 69 6e (p n)(max (strin
a870: 67 2d 3e 6e 75 6d 62 65 72 20 70 29 20 6e 29 29 g->number p) n))
a880: 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 )). ;; (print
a890: 20 22 64 61 74 61 3d 22 20 64 61 74 61 29 0a 20 "data=" data).
a8a0: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 (if (null? da
a8b0: 74 61 29 20 3b 3b 20 73 6f 6d 65 74 68 69 6e 67 ta) ;; something
a8c0: 20 77 65 6e 74 20 77 72 6f 6e 67 0a 20 20 20 20 went wrong.
a8d0: 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 28 #f. (
a8e0: 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 let loop ((hed
a8f0: 20 20 20 20 28 63 61 72 20 64 61 74 61 29 29 0a (car data)).
a900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a910: 20 20 20 28 74 61 6c 20 20 20 20 20 20 28 63 64 (tal (cd
a920: 72 20 64 61 74 61 29 29 0a 20 20 20 20 20 20 20 r data)).
a930: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 61 (loa
a940: 64 73 20 20 20 20 23 66 29 0a 20 20 20 20 20 20 ds #f).
a950: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 72 (pr
a960: 6f 63 2d 6e 75 6d 20 30 29 20 20 3b 3b 20 70 72 oc-num 0) ;; pr
a970: 6f 63 65 73 73 6f 72 20 69 6e 63 6c 75 64 65 73 ocessor includes
a980: 20 74 68 72 65 61 64 73 0a 20 20 20 20 20 20 20 threads.
a990: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 68 79 (phy
a9a0: 73 2d 6e 75 6d 20 30 29 20 20 3b 3b 20 70 68 79 s-num 0) ;; phy
a9b0: 73 69 63 61 6c 20 63 68 69 70 20 6f 6e 20 6d 6f sical chip on mo
a9c0: 74 68 65 72 62 6f 61 72 64 0a 20 20 20 20 20 20 therboard.
a9d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
a9e0: 72 65 2d 6e 75 6d 20 30 29 29 20 3b 3b 20 63 6f re-num 0)) ;; co
a9f0: 72 65 0a 20 20 20 20 20 20 20 20 20 20 3b 3b 20 re. ;;
aa00: 28 70 72 69 6e 74 20 68 65 64 20 22 2c 20 22 20 (print hed ", "
aa10: 6c 6f 61 64 73 20 22 2c 20 22 20 70 72 6f 63 2d loads ", " proc-
aa20: 6e 75 6d 20 22 2c 20 22 20 70 68 79 73 2d 6e 75 num ", " phys-nu
aa30: 6d 20 22 2c 20 22 20 63 6f 72 65 2d 6e 75 6d 29 m ", " core-num)
aa40: 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 . (if (
aa50: 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 68 61 null? tal) ;; ha
aa60: 76 65 20 61 6c 6c 20 6f 75 72 20 64 61 74 61 2c ve all our data,
aa70: 20 63 61 6c 63 75 6c 61 74 65 20 6e 6f 72 6d 61 calculate norma
aa80: 6c 69 7a 65 64 20 6c 6f 61 64 20 61 6e 64 20 72 lized load and r
aa90: 65 74 75 72 6e 20 72 65 73 75 6c 74 0a 20 20 20 eturn result.
aaa0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a (let*
aab0: 20 28 28 61 63 74 2d 70 72 6f 63 20 28 2b 20 70 ((act-proc (+ p
aac0: 72 6f 63 2d 6e 75 6d 20 31 29 29 0a 20 20 20 20 roc-num 1)).
aad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aae0: 20 28 61 63 74 2d 70 68 79 73 20 28 2b 20 70 68 (act-phys (+ ph
aaf0: 79 73 2d 6e 75 6d 20 31 29 29 0a 20 20 20 20 20 ys-num 1)).
ab00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ab10: 28 61 63 74 2d 63 6f 72 65 20 28 2b 20 63 6f 72 (act-core (+ cor
ab20: 65 2d 6e 75 6d 20 31 29 29 0a 20 20 20 20 20 20 e-num 1)).
ab30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ab40: 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 28 2f adj-proc-load (/
ab50: 20 28 63 61 72 20 6c 6f 61 64 73 29 20 61 63 74 (car loads) act
ab60: 2d 70 72 6f 63 29 29 0a 20 20 20 20 20 20 20 20 -proc)).
ab70: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 64 (ad
ab80: 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 28 2f 20 28 j-core-load (/ (
ab90: 63 61 72 20 6c 6f 61 64 73 29 20 61 63 74 2d 63 car loads) act-c
aba0: 6f 72 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 ore))).
abb0: 20 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 28 (append (
abc0: 6c 69 73 74 20 28 63 6f 6e 73 20 27 61 64 6a 2d list (cons 'adj-
abd0: 70 72 6f 63 2d 6c 6f 61 64 20 61 64 6a 2d 70 72 proc-load adj-pr
abe0: 6f 63 2d 6c 6f 61 64 29 0a 20 20 20 20 20 20 20 oc-load).
abf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ac00: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 61 64 (cons 'ad
ac10: 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 61 64 6a 2d j-core-load adj-
ac20: 63 6f 72 65 2d 6c 6f 61 64 29 29 0a 20 20 20 20 core-load)).
ac30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ac40: 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 (list (cons
ac50: 27 31 6d 2d 6c 6f 61 64 20 28 63 61 72 20 6c 6f '1m-load (car lo
ac60: 61 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ads)).
ac70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ac80: 20 20 20 20 28 63 6f 6e 73 20 27 35 6d 2d 6c 6f (cons '5m-lo
ac90: 61 64 20 28 63 61 64 72 20 6c 6f 61 64 73 29 29 ad (cadr loads))
aca0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
acb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
acc0: 63 6f 6e 73 20 27 31 35 6d 2d 6c 6f 61 64 20 28 cons '15m-load (
acd0: 63 61 64 64 72 20 6c 6f 61 64 73 29 29 29 0a 20 caddr loads))).
ace0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
acf0: 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f (list (co
ad00: 6e 73 20 27 70 72 6f 63 20 61 63 74 2d 70 72 6f ns 'proc act-pro
ad10: 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 c).
ad20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad30: 20 28 63 6f 6e 73 20 27 63 6f 72 65 20 61 63 74 (cons 'core act
ad40: 2d 63 6f 72 65 29 0a 20 20 20 20 20 20 20 20 20 -core).
ad50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ad60: 20 20 20 20 20 28 63 6f 6e 73 20 27 70 68 79 73 (cons 'phys
ad70: 20 61 63 74 2d 70 68 79 73 29 29 29 29 0a 20 20 act-phys)))).
ad80: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 67 (reg
ad90: 65 78 2d 63 61 73 65 0a 20 20 20 20 20 20 20 20 ex-case.
ada0: 20 20 20 20 20 20 20 68 65 64 0a 20 20 20 20 20 hed.
adb0: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 2d (load-
adc0: 72 78 20 20 28 20 78 20 6c 31 20 6c 35 20 6c 31 rx ( x l1 l5 l1
add0: 35 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 5 ) (loop (car t
ade0: 61 6c 29 28 63 64 72 20 74 61 6c 29 28 6d 61 70 al)(cdr tal)(map
adf0: 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 string->number
ae00: 28 6c 69 73 74 20 6c 31 20 6c 35 20 6c 31 35 29 (list l1 l5 l15)
ae10: 29 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d ) proc-num phys-
ae20: 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 num core-num)).
ae30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
ae40: 72 6f 63 2d 72 78 20 20 28 20 78 20 70 20 20 20 roc-rx ( x p
ae50: 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 ) (loop (c
ae60: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
ae70: 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 20 loads
ae80: 20 28 6d 61 78 2d 6e 75 6d 20 70 20 70 72 6f 63 (max-num p proc
ae90: 2d 6e 75 6d 29 20 70 68 79 73 2d 6e 75 6d 20 63 -num) phys-num c
aea0: 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 20 ore-num)).
aeb0: 20 20 20 20 20 20 20 20 20 28 70 68 79 73 2d 72 (phys-r
aec0: 78 20 20 28 20 78 20 70 20 20 20 20 20 20 20 20 x ( x p
aed0: 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 ) (loop (car ta
aee0: 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 l)(cdr tal) load
aef0: 73 20 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 s proc
af00: 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 6d 20 70 20 -num (max-num p
af10: 70 68 79 73 2d 6e 75 6d 29 20 63 6f 72 65 2d 6e phys-num) core-n
af20: 75 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 um)).
af30: 20 20 20 20 28 63 6f 72 65 2d 72 78 20 20 28 20 (core-rx (
af40: 78 20 63 20 20 20 20 20 20 20 20 20 29 20 28 6c x c ) (l
af50: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
af60: 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 r tal) loads
af70: 20 20 20 20 20 20 20 70 72 6f 63 2d 6e 75 6d 20 proc-num
af80: 70 68 79 73 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 phys-num (max-nu
af90: 6d 20 63 20 63 6f 72 65 2d 6e 75 6d 29 29 29 0a m c core-num))).
afa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
afb0: 65 6c 73 65 20 0a 20 20 20 20 20 20 20 20 20 20 else .
afc0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
afd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
afe0: 3b 20 28 70 72 69 6e 74 20 22 4e 4f 20 4d 41 54 ; (print "NO MAT
aff0: 43 48 3a 20 22 20 68 65 64 29 0a 20 20 20 20 20 CH: " hed).
b000: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f (lo
b010: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
b020: 20 74 61 6c 29 20 6c 6f 61 64 73 20 70 72 6f 63 tal) loads proc
b030: 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 63 6f -num phys-num co
b040: 72 65 2d 6e 75 6d 29 29 29 29 29 29 29 29 29 0a re-num))))))))).
b050: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
b060: 3a 75 6e 69 78 2d 70 69 6e 67 20 68 6f 73 74 6e :unix-ping hostn
b070: 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 72 65 ame). (let ((re
b080: 73 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 s (system (conc
b090: 22 70 69 6e 67 20 2d 63 20 31 20 22 20 68 6f 73 "ping -c 1 " hos
b0a0: 74 6e 61 6d 65 20 22 20 3e 20 2f 64 65 76 2f 6e tname " > /dev/n
b0b0: 75 6c 6c 22 29 29 29 29 0a 20 20 20 20 28 65 71 ull")))). (eq
b0c0: 3f 20 72 65 73 20 30 29 29 29 0a 0a 3b 3b 20 69 ? res 0)))..;; i
b0d0: 64 65 61 6c 6c 79 20 70 75 74 20 61 6c 6c 20 74 deally put all t
b0e0: 68 69 73 20 69 6e 66 6f 20 69 6e 74 6f 20 74 68 his info into th
b0f0: 65 20 64 62 2c 20 6e 6f 20 6e 65 65 64 20 74 6f e db, no need to
b100: 20 70 72 65 73 65 72 76 65 20 69 74 20 61 63 72 preserve it acr
b110: 6f 73 73 20 6d 6f 76 69 6e 67 20 68 6f 6d 65 68 oss moving homeh
b120: 6f 73 74 0a 3b 3b 0a 3b 3b 20 72 65 74 75 72 6e ost.;;.;; return
b130: 20 6c 69 73 74 20 6f 66 0a 3b 3b 20 20 28 20 72 list of.;; ( r
b140: 65 61 63 68 61 62 6c 65 3f 20 63 70 75 6c 6f 61 eachable? cpuloa
b150: 64 20 75 70 64 61 74 65 2d 74 69 6d 65 20 29 0a d update-time ).
b160: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
b170: 67 65 74 2d 68 6f 73 74 2d 69 6e 66 6f 20 68 6f get-host-info ho
b180: 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 2a 20 stname). (let*
b190: 28 28 6c 6f 61 64 69 6e 66 6f 20 28 72 6d 74 3a ((loadinfo (rmt:
b1a0: 67 65 74 2d 6c 61 74 65 73 74 2d 68 6f 73 74 2d get-latest-host-
b1b0: 6c 6f 61 64 20 68 6f 73 74 6e 61 6d 65 29 29 0a load hostname)).
b1c0: 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 28 (load (
b1d0: 63 61 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a 20 car loadinfo)).
b1e0: 20 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 61 (load-sa
b1f0: 6d 70 6c 65 2d 74 69 6d 65 20 28 63 64 72 20 6c mple-time (cdr l
b200: 6f 61 64 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 oadinfo)).
b210: 20 20 20 28 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d (load-sample-
b220: 61 67 65 20 28 2d 20 28 63 75 72 72 65 6e 74 2d age (- (current-
b230: 73 65 63 6f 6e 64 73 29 20 6c 6f 61 64 2d 73 61 seconds) load-sa
b240: 6d 70 6c 65 2d 74 69 6d 65 29 29 0a 20 20 20 20 mple-time)).
b250: 20 20 20 20 20 28 6c 6f 61 64 69 6e 66 6f 2d 74 (loadinfo-t
b260: 69 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 73 20 32 imeout-seconds 2
b270: 30 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 0). (hos
b280: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 t-last-update-ti
b290: 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 73 20 31 30 meout-seconds 10
b2a0: 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 ). (host
b2b0: 2d 72 65 63 20 28 68 61 73 68 2d 74 61 62 6c 65 -rec (hash-table
b2c0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 6f -ref/default *ho
b2d0: 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 st-loads* hostna
b2e0: 6d 65 20 23 66 29 29 0a 20 20 20 20 20 20 20 20 me #f)).
b2f0: 20 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 ). (cond.
b300: 20 20 28 28 3c 20 6c 6f 61 64 2d 73 61 6d 70 6c ((< load-sampl
b310: 65 2d 61 67 65 20 6c 6f 61 64 69 6e 66 6f 2d 74 e-age loadinfo-t
b320: 69 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 73 29 0a imeout-seconds).
b330: 20 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a 20 (list #t.
b340: 20 20 20 20 20 20 20 20 20 20 20 6c 6f 61 64 2d load-
b350: 73 61 6d 70 6c 65 2d 74 69 6d 65 0a 20 20 20 20 sample-time.
b360: 20 20 20 20 20 20 20 20 6c 6f 61 64 29 29 0a 20 load)).
b370: 20 20 20 20 28 28 61 6e 64 20 68 6f 73 74 2d 72 ((and host-r
b380: 65 63 0a 20 20 20 20 20 20 20 20 20 20 20 28 3c ec. (<
b390: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
b3a0: 73 29 20 28 2b 20 28 68 6f 73 74 2d 6c 61 73 74 s) (+ (host-last
b3b0: 2d 75 70 64 61 74 65 20 68 6f 73 74 2d 72 65 63 -update host-rec
b3c0: 29 20 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 ) host-last-upda
b3d0: 74 65 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e te-timeout-secon
b3e0: 64 73 29 29 29 0a 20 20 20 20 20 20 28 6c 69 73 ds))). (lis
b3f0: 74 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 t #t.
b400: 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 (host-last-upda
b410: 74 65 20 68 6f 73 74 2d 72 65 63 29 0a 20 20 20 te host-rec).
b420: 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d 6c (host-l
b430: 61 73 74 2d 63 70 75 6c 6f 61 64 20 68 6f 73 74 ast-cpuload host
b440: 2d 72 65 63 20 29 29 29 0a 20 20 20 20 20 28 28 -rec ))). ((
b450: 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 common:unix-ping
b460: 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 hostname).
b470: 20 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 20 (list #t.
b480: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 (current-s
b490: 65 63 6f 6e 64 73 29 0a 20 20 20 20 20 20 20 20 econds).
b4a0: 20 20 20 20 28 61 6c 69 73 74 2d 72 65 66 20 27 (alist-ref '
b4b0: 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 28 63 adj-core-load (c
b4c0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d 61 6c ommon:get-normal
b4d0: 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 68 6f ized-cpu-load ho
b4e0: 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 20 stname)))).
b4f0: 28 65 6c 73 65 0a 20 20 20 20 20 20 28 6c 69 73 (else. (lis
b500: 74 20 23 66 20 30 20 2d 31 29 29 29 29 29 0a 20 t #f 0 -1))))).
b510: 20 20 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .(define (com
b520: 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 74 2d mon:update-host-
b530: 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f 73 74 loads-table host
b540: 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a 20 28 s-raw). (let* (
b550: 28 68 6f 73 74 73 20 28 66 69 6c 74 65 72 20 28 (hosts (filter (
b560: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x).
b570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b580: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 (string-mat
b590: 63 68 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 53 ch (regexp "^\\S
b5a0: 2b 24 22 29 20 78 29 29 0a 20 20 20 20 20 20 20 +$") x)).
b5b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b5c0: 20 68 6f 73 74 73 2d 72 61 77 29 29 29 0a 20 20 hosts-raw))).
b5d0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
b5e0: 20 28 6c 61 6d 62 64 61 20 28 68 6f 73 74 6e 61 (lambda (hostna
b5f0: 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a me). (let*
b600: 20 28 28 72 65 63 20 20 20 20 20 20 20 28 6c 65 ((rec (le
b610: 74 20 28 28 68 20 28 68 61 73 68 2d 74 61 62 6c t ((h (hash-tabl
b620: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 e-ref/default *h
b630: 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e ost-loads* hostn
b640: 61 6d 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 ame #f))).
b650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b660: 20 20 20 20 28 69 66 20 68 0a 20 20 20 20 20 20 (if h.
b670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b680: 20 20 20 20 20 20 20 20 68 0a 20 20 20 20 20 20 h.
b690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b6a0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 (let ((h
b6b0: 20 28 6d 61 6b 65 2d 68 6f 73 74 29 29 29 0a 20 (make-host))).
b6c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b6e0: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
b6f0: 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 *host-loads* hos
b700: 74 6e 61 6d 65 20 68 29 0a 20 20 20 20 20 20 20 tname h).
b710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b720: 20 20 20 20 20 20 20 20 20 68 29 29 29 29 0a 20 h)))).
b730: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 6f (ho
b740: 73 74 2d 69 6e 66 6f 20 20 20 20 20 20 20 20 20 st-info
b750: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 73 74 (common:get-host
b760: 2d 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 -info hostname))
b770: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
b780: 69 73 2d 72 65 61 63 68 61 62 6c 65 20 20 20 20 is-reachable
b790: 20 20 28 63 61 72 20 68 6f 73 74 2d 69 6e 66 6f (car host-info
b7a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b7b0: 20 28 6c 61 73 74 2d 72 65 61 63 68 65 64 2d 74 (last-reached-t
b7c0: 69 6d 65 20 28 63 61 64 72 20 68 6f 73 74 2d 69 ime (cadr host-i
b7d0: 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 nfo)).
b7e0: 20 20 20 20 28 6c 6f 61 64 20 20 20 20 20 20 20 (load
b7f0: 20 20 20 20 20 20 20 28 63 61 64 64 72 20 68 6f (caddr ho
b800: 73 74 2d 69 6e 66 6f 29 29 29 0a 20 20 20 20 20 st-info))).
b810: 20 20 20 20 28 68 6f 73 74 2d 72 65 61 63 68 61 (host-reacha
b820: 62 6c 65 2d 73 65 74 21 20 20 20 20 72 65 63 20 ble-set! rec
b830: 69 73 2d 72 65 61 63 68 61 62 6c 65 29 0a 20 20 is-reachable).
b840: 20 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 (host-las
b850: 74 2d 75 70 64 61 74 65 2d 73 65 74 21 20 20 72 t-update-set! r
b860: 65 63 20 6c 61 73 74 2d 72 65 61 63 68 65 64 2d ec last-reached-
b870: 74 69 6d 65 29 0a 20 20 20 20 20 20 20 20 20 28 time). (
b880: 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 host-last-cpuloa
b890: 64 2d 73 65 74 21 20 72 65 63 20 6c 6f 61 64 29 d-set! rec load)
b8a0: 29 29 0a 20 20 20 20 20 68 6f 73 74 73 29 29 29 )). hosts)))
b8b0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
b8c0: 6e 3a 67 65 74 2d 6c 65 61 73 74 2d 6c 6f 61 64 n:get-least-load
b8d0: 65 64 2d 68 6f 73 74 20 68 6f 73 74 73 2d 72 61 ed-host hosts-ra
b8e0: 77 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 6f 73 w). (let* ((hos
b8f0: 74 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ts (filter (lamb
b900: 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 da (x).
b910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b920: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 (string-match (
b930: 72 65 67 65 78 70 20 22 5e 5c 5c 53 2b 24 22 29 regexp "^\\S+$")
b940: 20 78 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 x)).
b950: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 hos
b960: 74 73 2d 72 61 77 29 29 0a 20 20 20 20 20 20 20 ts-raw)).
b970: 20 20 28 62 65 73 74 2d 68 6f 73 74 20 23 66 29 (best-host #f)
b980: 0a 20 20 20 20 20 20 20 20 20 28 62 65 73 74 2d . (best-
b990: 6c 6f 61 64 20 39 39 39 39 39 29 0a 20 20 20 20 load 99999).
b9a0: 20 20 20 20 20 28 63 75 72 72 2d 74 69 6d 65 20 (curr-time
b9b0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
b9c0: 29 29 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ))). (common:
b9d0: 75 70 64 61 74 65 2d 68 6f 73 74 2d 6c 6f 61 64 update-host-load
b9e0: 73 2d 74 61 62 6c 65 20 68 6f 73 74 73 29 0a 20 s-table hosts).
b9f0: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
ba00: 20 20 28 6c 61 6d 62 64 61 20 28 68 6f 73 74 6e (lambda (hostn
ba10: 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c 65 74 ame). (let
ba20: 2a 20 28 28 72 65 63 0a 20 20 20 20 20 20 20 20 * ((rec.
ba30: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 20 (let ((h
ba40: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
ba50: 64 65 66 61 75 6c 74 20 2a 68 6f 73 74 2d 6c 6f default *host-lo
ba60: 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 23 66 ads* hostname #f
ba70: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
ba80: 20 20 20 20 20 28 69 66 20 68 0a 20 20 20 20 20 (if h.
ba90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
baa0: 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 h.
bab0: 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 20 (let ((h
bac0: 28 6d 61 6b 65 2d 68 6f 73 74 29 29 29 0a 20 20 (make-host))).
bad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bae0: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
baf0: 2d 73 65 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 -set! *host-load
bb00: 73 2a 20 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 s* hostname h).
bb10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bb20: 20 20 20 20 20 20 68 29 29 29 29 0a 20 20 20 20 h)))).
bb30: 20 20 20 20 20 20 20 20 20 20 28 72 65 61 63 68 (reach
bb40: 61 62 6c 65 20 28 68 6f 73 74 2d 72 65 61 63 68 able (host-reach
bb50: 61 62 6c 65 20 72 65 63 29 29 0a 20 20 20 20 20 able rec)).
bb60: 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 20 (load
bb70: 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 63 (host-last-c
bb80: 70 75 6c 6f 61 64 20 20 20 72 65 63 29 29 29 0a puload rec))).
bb90: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 (cond.
bba0: 20 20 20 20 20 20 20 20 20 28 28 6e 6f 74 20 72 ((not r
bbb0: 65 61 63 68 61 62 6c 65 29 20 23 66 29 0a 20 20 eachable) #f).
bbc0: 20 20 20 20 20 20 20 20 28 28 3c 20 28 2b 20 6c ((< (+ l
bbd0: 6f 61 64 20 28 2f 20 28 72 61 6e 64 6f 6d 20 32 oad (/ (random 2
bbe0: 35 30 29 20 31 30 30 30 29 29 20 20 20 20 20 20 50) 1000))
bbf0: 20 20 20 3b 3b 20 61 64 64 20 61 20 72 61 6e 64 ;; add a rand
bc00: 6f 6d 20 66 61 63 74 6f 72 20 74 6f 20 6b 65 65 om factor to kee
bc10: 70 20 66 72 6f 6d 20 67 65 74 74 69 6e 67 20 69 p from getting i
bc20: 6e 20 61 20 72 75 74 0a 20 20 20 20 20 20 20 20 n a rut.
bc30: 20 20 20 20 20 20 28 2b 20 62 65 73 74 2d 6c 6f (+ best-lo
bc40: 61 64 20 28 2f 20 28 72 61 6e 64 6f 6d 20 32 35 ad (/ (random 25
bc50: 30 29 20 31 30 30 30 29 29 20 20 29 0a 20 20 20 0) 1000)) ).
bc60: 20 20 20 20 20 20 20 20 28 73 65 74 21 20 62 65 (set! be
bc70: 73 74 2d 6c 6f 61 64 20 6c 6f 61 64 29 0a 20 20 st-load load).
bc80: 20 20 20 20 20 20 20 20 20 28 73 65 74 21 20 62 (set! b
bc90: 65 73 74 2d 68 6f 73 74 20 68 6f 73 74 6e 61 6d est-host hostnam
bca0: 65 29 29 29 29 29 0a 20 20 20 20 20 68 6f 73 74 e))))). host
bcb0: 73 29 0a 20 20 20 20 62 65 73 74 2d 68 6f 73 74 s). best-host
bcc0: 29 29 0a 0a 0a 0a 0a 28 64 65 66 69 6e 65 20 28 )).....(define (
bcd0: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
bce0: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
bcf0: 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 numcpus waitdela
bd00: 79 20 23 21 6b 65 79 20 28 63 6f 75 6e 74 20 31 y #!key (count 1
bd10: 30 30 30 29 20 28 6d 73 67 20 23 66 29 28 72 65 000) (msg #f)(re
bd20: 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 mote-host #f)).
bd30: 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 61 76 67 (let* ((loadavg
bd40: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 (common:get-cpu
bd50: 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 -load remote-hos
bd60: 74 29 29 0a 09 20 28 66 69 72 73 74 20 20 20 28 t)).. (first (
bd70: 63 61 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 car loadavg))..
bd80: 28 6e 65 78 74 20 20 20 20 28 63 61 64 72 20 6c (next (cadr l
bd90: 6f 61 64 61 76 67 29 29 0a 09 20 28 61 64 6a 6c oadavg)).. (adjl
bda0: 6f 61 64 20 28 2a 20 6d 61 78 6c 6f 61 64 20 6e oad (* maxload n
bdb0: 75 6d 63 70 75 73 29 29 0a 09 20 28 6c 6f 61 64 umcpus)).. (load
bdc0: 6a 6d 70 20 28 2d 20 66 69 72 73 74 20 6e 65 78 jmp (- first nex
bdd0: 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 t))). (cond.
bde0: 20 20 20 20 28 28 61 6e 64 20 28 3e 20 66 69 72 ((and (> fir
bdf0: 73 74 20 61 64 6a 6c 6f 61 64 29 0a 09 20 20 20 st adjload)..
be00: 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 (> count 0)).
be10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
be20: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
be30: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 log-port* "waiti
be40: 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 20 22 ng " waitdelay "
be50: 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 seconds due to
be60: 6c 6f 61 64 20 22 20 66 69 72 73 74 20 22 20 65 load " first " e
be70: 78 63 65 65 64 69 6e 67 20 6d 61 78 20 6f 66 20 xceeding max of
be80: 22 20 61 64 6a 6c 6f 61 64 20 28 69 66 20 6d 73 " adjload (if ms
be90: 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 20 20 g msg "")).
bea0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
beb0: 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 20 20 waitdelay).
bec0: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
bed0: 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 r-cpuload maxloa
bee0: 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 d numcpus waitde
bef0: 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f lay count: (- co
bf00: 75 6e 74 20 31 29 29 29 0a 20 20 20 20 20 28 28 unt 1))). ((
bf10: 61 6e 64 20 28 3e 20 6c 6f 61 64 6a 6d 70 20 6e and (> loadjmp n
bf20: 75 6d 63 70 75 73 29 0a 09 20 20 20 28 3e 20 63 umcpus).. (> c
bf30: 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 20 28 ount 0)). (
bf40: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
bf50: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
bf60: 70 6f 72 74 2a 20 22 77 61 69 74 69 6e 67 20 22 port* "waiting "
bf70: 20 77 61 69 74 64 65 6c 61 79 20 22 20 73 65 63 waitdelay " sec
bf80: 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f 61 64 onds due to load
bf90: 20 6a 75 6d 70 20 22 20 6c 6f 61 64 6a 6d 70 20 jump " loadjmp
bfa0: 22 20 3e 20 6e 75 6d 63 70 75 73 20 22 20 6e 75 " > numcpus " nu
bfb0: 6d 63 70 75 73 20 28 69 66 20 6d 73 67 20 6d 73 mcpus (if msg ms
bfc0: 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 68 g "")). (th
bfd0: 72 65 61 64 2d 73 6c 65 65 70 21 20 77 61 69 74 read-sleep! wait
bfe0: 64 65 6c 61 79 29 0a 20 20 20 20 20 20 28 63 6f delay). (co
bff0: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 mmon:wait-for-cp
c000: 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 uload maxload nu
c010: 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 20 mcpus waitdelay
c020: 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 20 count: (- count
c030: 31 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 1))))))..(define
c040: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d (common:get-num
c050: 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f 73 -cpus remote-hos
c060: 74 29 0a 20 20 28 6c 65 74 20 28 28 70 72 6f 63 t). (let ((proc
c070: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 28 6c (lambda ()...(l
c080: 65 74 20 6c 6f 6f 70 20 28 28 6e 75 6d 63 70 75 et loop ((numcpu
c090: 20 30 29 0a 09 09 09 20 20 20 28 69 6e 6c 20 20 0).... (inl
c0a0: 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a (read-line))).
c0b0: 09 09 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a .. (if (eof-obj
c0c0: 65 63 74 3f 20 69 6e 6c 29 0a 09 09 20 20 20 20 ect? inl)...
c0d0: 20 20 6e 75 6d 63 70 75 0a 09 09 20 20 20 20 20 numcpu...
c0e0: 20 28 6c 6f 6f 70 20 28 69 66 20 28 73 74 72 69 (loop (if (stri
c0f0: 6e 67 2d 6d 61 74 63 68 20 22 5e 70 72 6f 63 65 ng-match "^proce
c100: 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b 5c 5c 64 ssor\\s+:\\s+\\d
c110: 2b 24 22 20 69 6e 6c 29 0a 09 09 09 09 28 2b 20 +$" inl).....(+
c120: 6e 75 6d 63 70 75 20 31 29 0a 09 09 09 09 6e 75 numcpu 1).....nu
c130: 6d 63 70 75 29 0a 09 09 09 20 20 20 20 28 72 65 mcpu).... (re
c140: 61 64 2d 6c 69 6e 65 29 29 29 29 29 29 29 0a 20 ad-line))))))).
c150: 20 20 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f (if remote-ho
c160: 73 74 0a 09 28 77 69 74 68 2d 69 6e 70 75 74 2d st..(with-input-
c170: 66 72 6f 6d 2d 70 69 70 65 20 0a 09 20 28 63 6f from-pipe .. (co
c180: 6e 63 20 22 73 73 68 20 22 20 72 65 6d 6f 74 65 nc "ssh " remote
c190: 2d 68 6f 73 74 20 22 20 63 61 74 20 2f 70 72 6f -host " cat /pro
c1a0: 63 2f 63 70 75 69 6e 66 6f 22 29 0a 09 20 70 72 c/cpuinfo").. pr
c1b0: 6f 63 29 0a 09 28 77 69 74 68 2d 69 6e 70 75 74 oc)..(with-input
c1c0: 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f -from-file "/pro
c1d0: 63 2f 63 70 75 69 6e 66 6f 22 20 70 72 6f 63 29 c/cpuinfo" proc)
c1e0: 29 29 29 0a 0a 3b 3b 20 77 61 69 74 20 66 6f 72 )))..;; wait for
c1f0: 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 normalized cpu
c200: 6c 6f 61 64 20 74 6f 20 64 72 6f 70 20 62 65 6c load to drop bel
c210: 6f 77 20 6d 61 78 6c 6f 61 64 0a 3b 3b 0a 28 64 ow maxload.;;.(d
c220: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 efine (common:wa
c230: 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 it-for-normalize
c240: 64 2d 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 23 d-load maxload #
c250: 21 6b 65 79 20 28 6d 73 67 20 23 66 29 28 72 65 !key (msg #f)(re
c260: 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 mote-host #f)).
c270: 20 28 6c 65 74 20 28 28 6e 75 6d 2d 63 70 75 73 (let ((num-cpus
c280: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d (common:get-num
c290: 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 6f 73 -cpus remote-hos
c2a0: 74 29 29 29 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e t))). (common
c2b0: 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 :wait-for-cpuloa
c2c0: 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 2d 63 70 d maxload num-cp
c2d0: 75 73 20 31 35 20 6d 73 67 3a 20 6d 73 67 29 29 us 15 msg: msg))
c2e0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get-
c2f0: 75 6e 61 6d 65 20 2e 20 70 61 72 61 6d 73 29 0a uname . params).
c300: 20 20 28 6c 65 74 2a 20 28 28 75 6e 61 6d 65 2d (let* ((uname-
c310: 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 res (process:cmd
c320: 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 -run->list (conc
c330: 20 22 75 6e 61 6d 65 20 22 20 28 69 66 20 28 6e "uname " (if (n
c340: 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 2d 61 ull? params) "-a
c350: 22 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 29 " (car params)))
c360: 29 29 0a 09 20 28 75 6e 61 6d 65 20 23 66 29 29 )).. (uname #f))
c370: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
c380: 28 63 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 (car uname-res))
c390: 0a 09 22 75 6e 6b 6e 6f 77 6e 22 0a 09 28 63 61 .."unknown"..(ca
c3a0: 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 29 29 ar uname-res))))
c3b0: 0a 0a 3b 3b 20 66 6f 72 20 72 65 61 73 6f 6e 73 ..;; for reasons
c3c0: 20 49 20 64 6f 6e 27 74 20 75 6e 64 65 72 73 74 I don't underst
c3d0: 61 6e 64 20 6d 75 6c 74 69 70 6c 65 20 63 61 6c and multiple cal
c3e0: 6c 73 20 74 6f 20 72 65 61 6c 2d 70 61 74 68 20 ls to real-path
c3f0: 69 6e 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 65 in parallel thre
c400: 61 64 73 0a 3b 3b 20 6d 75 73 74 20 62 65 20 70 ads.;; must be p
c410: 72 6f 74 65 63 74 65 64 20 62 79 20 6d 75 74 65 rotected by mute
c420: 78 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 xes.;;.(define (
c430: 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 68 common:real-path
c440: 20 69 6e 70 61 74 68 29 0a 20 20 3b 3b 20 28 70 inpath). ;; (p
c450: 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 rocess:cmd-run-w
c460: 69 74 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 74 ith-stderr->list
c470: 20 22 72 65 61 64 6c 69 6e 6b 22 20 22 2d 66 22 "readlink" "-f"
c480: 20 69 6e 70 61 74 68 29 29 20 3b 3b 20 63 6d 64 inpath)) ;; cmd
c490: 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 . params). ;;
c4a0: 28 6c 65 74 2d 76 61 6c 75 65 73 20 0a 20 20 3b (let-values . ;
c4b0: 3b 20 20 28 28 28 69 6e 70 20 6f 75 70 20 70 69 ; (((inp oup pi
c4c0: 64 29 20 28 70 72 6f 63 65 73 73 20 22 72 65 61 d) (process "rea
c4d0: 64 6c 69 6e 6b 22 20 28 6c 69 73 74 20 22 2d 66 dlink" (list "-f
c4e0: 22 20 69 6e 70 61 74 68 29 29 29 29 0a 20 20 3b " inpath)))). ;
c4f0: 3b 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 ; (with-input-f
c500: 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 0a 20 20 3b rom-port inp. ;
c510: 3b 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 ; (let loop (
c520: 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 29 (inl (read-line)
c530: 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 09 28 72 ). ;; .(r
c540: 65 73 20 23 66 29 29 0a 20 20 3b 3b 20 20 20 20 es #f)). ;;
c550: 20 20 28 70 72 69 6e 74 20 22 69 6e 6c 3d 22 20 (print "inl="
c560: 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 28 inl). ;; (
c570: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
c580: 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 inl). ;;
c590: 20 20 20 28 62 65 67 69 6e 0a 20 20 3b 3b 20 20 (begin. ;;
c5a0: 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 (close
c5b0: 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 29 -input-port inp)
c5c0: 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 . ;;
c5d0: 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 (close-output-p
c5e0: 6f 72 74 20 6f 75 70 29 0a 20 20 3b 3b 20 20 20 ort oup). ;;
c5f0: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 6f ;; (pro
c600: 63 65 73 73 2d 77 61 69 74 20 70 69 64 29 0a 20 cess-wait pid).
c610: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 72 ;; r
c620: 65 73 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 es). ;;
c630: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
c640: 6e 65 29 20 69 6e 6c 29 29 29 29 29 29 0a 20 20 ne) inl)))))).
c650: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
c660: 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 72 65 61 -pipe (conc "rea
c670: 64 6c 69 6e 6b 20 2d 66 20 22 20 69 6e 70 61 74 dlink -f " inpat
c680: 68 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 0a 0a h) read-line))..
c690: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
c6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c6b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c6c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c6d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 20 ========.;; D I
c6e0: 53 20 4b 20 20 20 53 20 50 20 41 20 43 20 45 20 S K S P A C E
c6f0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
c700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
c740: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 ne (common:get-d
c750: 69 73 6b 2d 73 70 61 63 65 2d 75 73 65 64 20 66 isk-space-used f
c760: 70 61 74 68 29 0a 20 20 28 77 69 74 68 2d 69 6e path). (with-in
c770: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 put-from-pipe (c
c780: 6f 6e 63 20 22 2f 75 73 72 2f 62 69 6e 2f 64 75 onc "/usr/bin/du
c790: 20 2d 73 20 22 20 66 70 61 74 68 29 20 72 65 61 -s " fpath) rea
c7a0: 64 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 70 61 d))..;; given pa
c7b0: 74 68 20 67 65 74 20 66 72 65 65 20 73 70 61 63 th get free spac
c7c0: 65 2c 20 61 6c 6c 6f 77 73 20 6f 76 65 72 72 69 e, allows overri
c7d0: 64 65 20 69 6e 20 5b 73 65 74 75 70 5d 0a 3b 3b de in [setup].;;
c7e0: 20 77 69 74 68 20 66 72 65 65 2d 73 70 61 63 65 with free-space
c7f0: 2d 73 63 72 69 70 74 20 2f 70 61 74 68 2f 74 6f -script /path/to
c800: 2f 73 6f 6d 65 2f 73 63 72 69 70 74 2e 73 68 0a /some/script.sh.
c810: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d ;;.(define (get-
c820: 64 66 20 70 61 74 68 29 0a 20 20 28 69 66 20 28 df path). (if (
c830: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
c840: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
c850: 70 22 20 22 66 72 65 65 2d 73 70 61 63 65 2d 73 p" "free-space-s
c860: 63 72 69 70 74 22 29 0a 20 20 20 20 20 20 28 77 cript"). (w
c870: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
c880: 69 70 65 20 0a 20 20 20 20 20 20 20 28 63 6f 6e ipe . (con
c890: 63 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 c (configf:looku
c8a0: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
c8b0: 65 74 75 70 22 20 22 66 72 65 65 2d 73 70 61 63 etup" "free-spac
c8c0: 65 2d 73 63 72 69 70 74 22 29 20 22 20 22 20 70 e-script") " " p
c8d0: 61 74 68 29 0a 20 20 20 20 20 20 20 28 6c 61 6d ath). (lam
c8e0: 62 64 61 20 28 29 0a 09 20 28 6c 65 74 20 28 28 bda ().. (let ((
c8f0: 72 65 73 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 res (read-line))
c900: 29 0a 09 20 20 20 28 69 66 20 28 73 74 72 69 6e ).. (if (strin
c910: 67 3f 20 72 65 73 29 0a 09 20 20 20 20 20 20 20 g? res)..
c920: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
c930: 72 65 73 29 29 29 29 29 0a 20 20 20 20 20 20 28 res))))). (
c940: 67 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 68 get-unix-df path
c950: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 )))..(define (ge
c960: 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 68 29 0a t-unix-df path).
c970: 20 20 28 6c 65 74 2a 20 28 28 64 66 2d 72 65 73 (let* ((df-res
c980: 75 6c 74 73 20 28 70 72 6f 63 65 73 73 3a 63 6d ults (process:cm
c990: 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e d-run->list (con
c9a0: 63 20 22 64 66 20 22 20 70 61 74 68 29 29 29 0a c "df " path))).
c9b0: 09 20 28 73 70 61 63 65 2d 72 78 20 20 20 28 72 . (space-rx (r
c9c0: 65 67 65 78 70 20 22 28 5b 30 2d 39 5d 2b 29 5c egexp "([0-9]+)\
c9d0: 5c 73 2b 28 5b 30 2d 39 5d 2b 29 25 22 29 29 0a \s+([0-9]+)%")).
c9e0: 09 20 28 66 72 65 65 73 70 63 20 20 20 20 23 66 . (freespc #f
c9f0: 29 29 0a 20 20 20 20 3b 3b 20 28 77 72 69 74 65 )). ;; (write
ca00: 20 64 66 2d 72 65 73 75 6c 74 73 29 0a 20 20 20 df-results).
ca10: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
ca20: 64 61 20 28 6c 29 0a 09 09 28 6c 65 74 20 28 28 da (l)...(let ((
ca30: 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 73 65 match (string-se
ca40: 61 72 63 68 20 73 70 61 63 65 2d 72 78 20 6c 29 arch space-rx l)
ca50: 29 29 0a 09 09 20 20 28 69 66 20 6d 61 74 63 68 ))... (if match
ca60: 20 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 ... (let (
ca70: 28 6e 65 77 76 61 6c 20 28 73 74 72 69 6e 67 2d (newval (string-
ca80: 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d 61 >number (cadr ma
ca90: 74 63 68 29 29 29 29 0a 09 09 09 28 69 66 20 28 tch))))....(if (
caa0: 6e 75 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a number? newval).
cab0: 09 09 09 20 20 20 20 28 73 65 74 21 20 66 72 65 ... (set! fre
cac0: 65 73 70 63 20 6e 65 77 76 61 6c 29 29 29 29 29 espc newval)))))
cad0: 29 0a 09 20 20 20 20 20 20 28 63 61 72 20 64 66 ).. (car df
cae0: 2d 72 65 73 75 6c 74 73 29 29 0a 20 20 20 20 66 -results)). f
caf0: 72 65 65 73 70 63 29 29 0a 0a 28 64 65 66 69 6e reespc))..(defin
cb00: 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d e (common:check-
cb10: 73 70 61 63 65 2d 69 6e 2d 64 69 72 20 64 69 72 space-in-dir dir
cb20: 70 61 74 68 20 72 65 71 75 69 72 65 64 29 0a 20 path required).
cb30: 20 28 6c 65 74 2a 20 28 28 64 62 73 70 61 63 65 (let* ((dbspace
cb40: 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 79 (if (directory
cb50: 3f 20 64 69 72 70 61 74 68 29 0a 09 09 20 20 20 ? dirpath)...
cb60: 20 20 20 20 28 67 65 74 2d 64 66 20 64 69 72 70 (get-df dirp
cb70: 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 30 29 ath)... 0)
cb80: 29 29 0a 20 20 20 20 28 6c 69 73 74 20 28 3e 20 )). (list (>
cb90: 64 62 73 70 61 63 65 20 72 65 71 75 69 72 65 64 dbspace required
cba0: 29 0a 09 20 20 64 62 73 70 61 63 65 0a 09 20 20 ).. dbspace..
cbb0: 72 65 71 75 69 72 65 64 0a 09 20 20 64 69 72 70 required.. dirp
cbc0: 61 74 68 29 29 29 0a 0a 3b 3b 20 63 68 65 63 6b ath)))..;; check
cbd0: 20 73 70 61 63 65 20 69 6e 20 64 62 64 69 72 20 space in dbdir
cbe0: 61 6e 64 20 69 6e 20 6d 65 67 61 74 65 73 74 20 and in megatest
cbf0: 64 69 72 0a 3b 3b 20 72 65 74 75 72 6e 73 3a 20 dir.;; returns:
cc00: 6f 6b 2f 6e 6f 74 20 64 62 73 70 61 63 65 20 72 ok/not dbspace r
cc10: 65 71 75 69 72 65 64 2d 73 70 61 63 65 0a 3b 3b equired-space.;;
cc20: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
cc30: 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 73 70 :check-db-dir-sp
cc40: 61 63 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 72 ace). (let* ((r
cc50: 65 71 75 69 72 65 64 20 28 73 74 72 69 6e 67 2d equired (string-
cc60: 3e 6e 75 6d 62 65 72 20 0a 09 09 20 20 20 20 28 >number ... (
cc70: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
cc80: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
cc90: 73 65 74 75 70 22 20 22 64 62 64 69 72 2d 73 70 setup" "dbdir-sp
cca0: 61 63 65 2d 72 65 71 75 69 72 65 64 22 29 0a 09 ace-required")..
ccb0: 09 09 22 31 30 30 30 30 30 22 29 29 29 0a 09 20 .."100000")))..
ccc0: 28 64 62 64 69 72 20 20 20 20 28 63 6f 6d 6d 6f (dbdir (commo
ccd0: 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 n:get-db-tmp-are
cce0: 61 29 29 20 3b 3b 20 28 64 62 3a 67 65 74 2d 64 a)) ;; (db:get-d
ccf0: 62 64 69 72 29 29 0a 09 20 28 74 64 62 73 70 61 bdir)).. (tdbspa
cd00: 63 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b ce (common:check
cd10: 2d 73 70 61 63 65 2d 69 6e 2d 64 69 72 20 64 62 -space-in-dir db
cd20: 64 69 72 20 72 65 71 75 69 72 65 64 29 29 0a 09 dir required))..
cd30: 20 28 6d 64 62 73 70 61 63 65 20 28 63 6f 6d 6d (mdbspace (comm
cd40: 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 on:check-space-i
cd50: 6e 2d 64 69 72 20 2a 74 6f 70 70 61 74 68 2a 20 n-dir *toppath*
cd60: 72 65 71 75 69 72 65 64 29 29 29 0a 20 20 20 20 required))).
cd70: 28 73 6f 72 74 20 28 6c 69 73 74 20 74 64 62 73 (sort (list tdbs
cd80: 70 61 63 65 20 6d 64 62 73 70 61 63 65 29 20 28 pace mdbspace) (
cd90: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 09 09 lambda (a b)....
cda0: 09 20 20 20 20 20 28 3c 20 28 63 61 64 72 20 61 . (< (cadr a
cdb0: 29 28 63 61 64 72 20 62 29 29 29 29 29 29 0a 20 )(cadr b)))))).
cdc0: 20 20 20 0a 3b 3b 20 63 68 65 63 6b 20 61 76 61 .;; check ava
cdd0: 69 6c 61 62 6c 65 20 73 70 61 63 65 20 69 6e 20 ilable space in
cde0: 64 62 64 69 72 2c 20 65 78 69 74 20 69 66 20 69 dbdir, exit if i
cdf0: 6e 73 75 66 66 69 63 69 65 6e 74 0a 3b 3b 0a 28 nsufficient.;;.(
ce00: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 define (common:c
ce10: 68 65 63 6b 2d 64 62 2d 64 69 72 2d 61 6e 64 2d heck-db-dir-and-
ce20: 65 78 69 74 2d 69 66 2d 69 6e 73 75 66 66 69 63 exit-if-insuffic
ce30: 69 65 6e 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 ient). (let* ((
ce40: 73 70 61 63 65 64 61 74 20 28 63 61 72 20 28 63 spacedat (car (c
ce50: 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 ommon:check-db-d
ce60: 69 72 2d 73 70 61 63 65 29 29 29 20 3b 3b 20 6c ir-space))) ;; l
ce70: 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 77 6f 72 73 ook only at wors
ce80: 74 20 66 6f 72 20 6e 6f 77 0a 09 20 28 69 73 2d t for now.. (is-
ce90: 6f 6b 20 20 20 20 28 63 61 72 20 73 70 61 63 65 ok (car space
cea0: 64 61 74 29 29 0a 09 20 28 64 62 73 70 61 63 65 dat)).. (dbspace
ceb0: 20 20 28 63 61 64 72 20 73 70 61 63 65 64 61 74 (cadr spacedat
cec0: 29 29 0a 09 20 28 72 65 71 75 69 72 65 64 20 28 )).. (required (
ced0: 63 61 64 64 72 20 73 70 61 63 65 64 61 74 29 29 caddr spacedat))
cee0: 0a 09 20 28 64 62 64 69 72 20 20 20 20 28 63 61 .. (dbdir (ca
cef0: 64 64 64 72 20 73 70 61 63 65 64 61 74 29 29 29 dddr spacedat)))
cf00: 0a 20 20 20 20 28 69 66 20 28 6e 6f 74 20 69 73 . (if (not is
cf10: 2d 6f 6b 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 -ok)..(begin..
cf20: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
cf30: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
cf40: 67 2d 70 6f 72 74 2a 20 22 49 6e 73 75 66 66 69 g-port* "Insuffi
cf50: 63 69 65 6e 74 20 73 70 61 63 65 20 69 6e 20 22 cient space in "
cf60: 20 64 62 64 69 72 20 22 2c 20 72 65 71 75 69 72 dbdir ", requir
cf70: 65 20 22 20 72 65 71 75 69 72 65 64 20 22 2c 20 e " required ",
cf80: 68 61 76 65 20 22 20 64 62 73 70 61 63 65 20 20 have " dbspace
cf90: 22 2c 20 65 78 69 74 69 6e 67 20 6e 6f 77 2e 22 ", exiting now."
cfa0: 29 0a 09 20 20 28 65 78 69 74 20 31 29 29 29 29 ).. (exit 1))))
cfb0: 29 0a 20 20 0a 3b 3b 20 70 61 74 68 73 20 69 73 ). .;; paths is
cfc0: 20 6c 69 73 74 20 6f 66 20 6c 69 73 74 73 20 28 list of lists (
cfd0: 28 6e 61 6d 65 20 70 61 74 68 29 20 2e 2e 2e 20 (name path) ...
cfe0: 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ).;;.(define (co
cff0: 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d 77 69 mmon:get-disk-wi
d000: 74 68 2d 6d 6f 73 74 2d 66 72 65 65 2d 73 70 61 th-most-free-spa
d010: 63 65 20 64 69 73 6b 73 20 6d 69 6e 73 69 7a 65 ce disks minsize
d020: 29 0a 20 20 28 6c 65 74 20 28 28 62 65 73 74 20 ). (let ((best
d030: 20 20 20 20 23 66 29 0a 09 28 62 65 73 74 73 69 #f)..(bestsi
d040: 7a 65 20 30 29 29 0a 20 20 20 20 28 66 6f 72 2d ze 0)). (for-
d050: 65 61 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 each . (lamb
d060: 64 61 20 28 64 69 73 6b 2d 6e 75 6d 29 0a 20 20 da (disk-num).
d070: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 69 72 (let* ((dir
d080: 70 61 74 68 20 20 20 20 28 63 61 64 72 20 28 61 path (cadr (a
d090: 73 73 6f 63 20 64 69 73 6b 2d 6e 75 6d 20 64 69 ssoc disk-num di
d0a0: 73 6b 73 29 29 29 0a 09 20 20 20 20 20 20 28 66 sks))).. (f
d0b0: 72 65 65 73 70 63 20 20 20 20 28 63 6f 6e 64 0a reespc (cond.
d0c0: 09 09 09 20 20 20 28 28 6e 6f 74 20 28 64 69 72 ... ((not (dir
d0d0: 65 63 74 6f 72 79 3f 20 64 69 72 70 61 74 68 29 ectory? dirpath)
d0e0: 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 63 6f ).... (if (co
d0f0: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
d100: 72 69 6e 74 20 33 30 30 20 22 64 69 73 6b 73 20 rint 300 "disks
d110: 6e 6f 74 20 61 20 64 69 72 20 22 20 64 69 73 6b not a dir " disk
d120: 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 75 67 -num).....(debug
d130: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
d140: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
d150: 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 73 NING: disk " dis
d160: 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 68 20 k-num " at path
d170: 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c 22 20 \"" dirpath "\"
d180: 69 73 20 6e 6f 74 20 61 20 64 69 72 65 63 74 6f is not a directo
d190: 72 79 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 ry - ignoring it
d1a0: 2e 22 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a .")).... -1).
d1b0: 09 09 09 20 20 20 28 28 6e 6f 74 20 28 66 69 6c ... ((not (fil
d1c0: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
d1d0: 64 69 72 70 61 74 68 29 29 0a 09 09 09 20 20 20 dirpath))....
d1e0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (if (common:low
d1f0: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 30 -noise-print 300
d200: 20 22 64 69 73 6b 73 20 6e 6f 74 20 77 72 69 74 "disks not writ
d210: 65 61 62 6c 65 20 22 20 64 69 73 6b 2d 6e 75 6d eable " disk-num
d220: 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ).....(debug:pri
d230: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
d240: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
d250: 3a 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 : disk " disk-nu
d260: 6d 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 20 m " at path \""
d270: 64 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 6e dirpath "\" is n
d280: 6f 74 20 77 72 69 74 65 61 62 6c 65 20 2d 20 69 ot writeable - i
d290: 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 29 0a 09 gnoring it."))..
d2a0: 09 09 20 20 20 20 2d 31 29 0a 09 09 09 20 20 20 .. -1)....
d2b0: 28 28 6e 6f 74 20 28 65 71 3f 20 28 73 74 72 69 ((not (eq? (stri
d2c0: 6e 67 2d 72 65 66 20 64 69 72 70 61 74 68 20 30 ng-ref dirpath 0
d2d0: 29 20 23 5c 2f 29 29 0a 09 09 09 20 20 20 20 28 ) #\/)).... (
d2e0: 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e if (common:low-n
d2f0: 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 oise-print 300 "
d300: 64 69 73 6b 73 20 6e 6f 74 20 61 20 70 72 6f 70 disks not a prop
d310: 65 72 20 70 61 74 68 20 22 20 64 69 73 6b 2d 6e er path " disk-n
d320: 75 6d 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 um).....(debug:p
d330: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
d340: 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 log-port* "WARNI
d350: 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 73 6b 2d NG: disk " disk-
d360: 6e 75 6d 20 22 20 61 74 20 70 61 74 68 20 5c 22 num " at path \"
d370: 22 20 64 69 72 70 61 74 68 20 22 5c 22 20 69 73 " dirpath "\" is
d380: 20 6e 6f 74 20 61 20 66 75 6c 6c 79 20 71 75 61 not a fully qua
d390: 6c 69 66 69 65 64 20 70 61 74 68 20 2d 20 69 67 lified path - ig
d3a0: 6e 6f 72 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 noring it."))...
d3b0: 09 20 20 20 20 2d 31 29 0a 09 09 09 20 20 20 28 . -1).... (
d3c0: 65 6c 73 65 0a 09 09 09 20 20 20 20 28 67 65 74 else.... (get
d3d0: 2d 64 66 20 64 69 72 70 61 74 68 29 29 29 29 29 -df dirpath)))))
d3e0: 0a 09 20 28 69 66 20 28 3e 20 66 72 65 65 73 70 .. (if (> freesp
d3f0: 63 20 62 65 73 74 73 69 7a 65 29 0a 09 20 20 20 c bestsize)..
d400: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 (begin..
d410: 20 28 73 65 74 21 20 62 65 73 74 20 20 20 20 20 (set! best
d420: 28 63 6f 6e 73 20 64 69 73 6b 2d 6e 75 6d 20 64 (cons disk-num d
d430: 69 72 70 61 74 68 29 29 0a 09 20 20 20 20 20 20 irpath))..
d440: 20 28 73 65 74 21 20 62 65 73 74 73 69 7a 65 20 (set! bestsize
d450: 66 72 65 65 73 70 63 29 29 29 29 29 0a 20 20 20 freespc))))).
d460: 20 20 28 6d 61 70 20 63 61 72 20 64 69 73 6b 73 (map car disks
d470: 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 )). (if (and
d480: 62 65 73 74 20 28 3e 20 62 65 73 74 73 69 7a 65 best (> bestsize
d490: 20 6d 69 6e 73 69 7a 65 29 29 0a 09 62 65 73 74 minsize))..best
d4a0: 0a 09 23 66 29 29 29 20 3b 3b 20 23 66 20 6d 65 ..#f))) ;; #f me
d4b0: 61 6e 73 20 6e 6f 20 64 69 73 6b 20 63 61 6e 64 ans no disk cand
d4c0: 69 64 61 74 65 20 66 6f 75 6e 64 0a 0a 3b 3b 3d idate found..;;=
d4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d510: 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 4e 20 56 20 49 =====.;; E N V I
d520: 20 52 20 4f 20 4e 20 4d 20 45 20 4e 20 54 20 20 R O N M E N T
d530: 20 56 20 41 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d V A R S.;;=====
d540: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d550: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d560: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d570: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d580: 3d 0a 09 20 20 20 20 20 20 0a 28 64 65 66 69 6e =.. .(defin
d590: 65 20 28 73 61 76 65 2d 65 6e 76 69 72 6f 6e 6d e (save-environm
d5a0: 65 6e 74 2d 61 73 2d 66 69 6c 65 73 20 66 6e 61 ent-as-files fna
d5b0: 6d 65 20 23 21 6b 65 79 20 28 69 67 6e 6f 72 65 me #!key (ignore
d5c0: 76 61 72 73 20 28 6c 69 73 74 20 22 55 53 45 52 vars (list "USER
d5d0: 22 20 22 48 4f 4d 45 22 20 22 44 49 53 50 4c 41 " "HOME" "DISPLA
d5e0: 59 22 20 22 4c 53 5f 43 4f 4c 4f 52 53 22 20 22 Y" "LS_COLORS" "
d5f0: 58 4b 45 59 53 59 4d 44 42 22 20 22 45 44 49 54 XKEYSYMDB" "EDIT
d600: 4f 52 22 20 22 4d 41 4b 45 46 4c 41 47 53 22 20 OR" "MAKEFLAGS"
d610: 22 4d 41 4b 45 46 22 20 22 4d 41 4b 45 4f 56 45 "MAKEF" "MAKEOVE
d620: 52 52 49 44 45 53 22 29 29 29 0a 20 20 28 6c 65 RRIDES"))). (le
d630: 74 20 28 28 65 6e 76 76 61 72 73 20 28 67 65 74 t ((envvars (get
d640: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
d650: 69 61 62 6c 65 73 29 29 0a 20 20 20 20 20 20 20 iables)).
d660: 20 28 77 68 69 74 65 73 70 20 28 72 65 67 65 78 (whitesp (regex
d670: 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 2d 39 5f 5c p "[^a-zA-Z0-9_\
d680: 5c 2d 3a 2c 2e 5c 5c 2f 25 24 5d 22 29 29 0a 09 \-:,.\\/%$]"))..
d690: 28 6d 75 6e 67 65 76 61 6c 20 28 6c 61 6d 62 64 (mungeval (lambd
d6a0: 61 20 28 76 61 6c 29 0a 09 09 20 20 20 20 28 63 a (val)... (c
d6b0: 6f 6e 64 0a 09 09 20 20 20 20 20 28 28 65 71 3f ond... ((eq?
d6c0: 20 76 61 6c 20 23 74 29 20 22 22 29 20 3b 3b 20 val #t) "") ;;
d6d0: 63 6f 6e 76 65 72 74 20 23 74 20 74 6f 20 65 6d convert #t to em
d6e0: 70 74 79 20 73 74 72 69 6e 67 0a 09 09 20 20 20 pty string...
d6f0: 20 20 28 28 65 71 3f 20 76 61 6c 20 23 66 29 20 ((eq? val #f)
d700: 23 66 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 #f) ;; convert #
d710: 66 20 74 6f 20 69 74 73 65 6c 66 20 28 73 74 69 f to itself (sti
d720: 6c 6c 20 74 68 69 6e 6b 69 6e 67 20 61 62 6f 75 ll thinking abou
d730: 74 20 74 68 69 73 20 6f 6e 65 0a 09 09 20 20 20 t this one...
d740: 20 20 28 65 6c 73 65 20 76 61 6c 29 29 29 29 29 (else val)))))
d750: 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 . (with-outp
d760: 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 ut-to-file (conc
d770: 20 66 6e 61 6d 65 20 22 2e 63 73 68 22 29 0a 20 fname ".csh").
d780: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
d790: 0a 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d . (for-
d7a0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
d7b0: 79 76 61 6c 29 0a 09 09 20 20 20 20 20 20 28 6c yval)... (l
d7c0: 65 74 2a 20 28 28 6b 65 79 20 20 20 28 63 61 72 et* ((key (car
d7d0: 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 keyval))....
d7e0: 20 20 28 76 61 6c 20 20 20 28 63 64 72 20 6b 65 (val (cdr ke
d7f0: 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 yval)).... (
d800: 64 65 6c 69 6d 20 28 69 66 20 28 73 74 72 69 6e delim (if (strin
d810: 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 73 70 g-search whitesp
d820: 20 76 61 6c 29 20 0a 09 09 09 09 09 22 5c 22 22 val) ......"\""
d830: 0a 09 09 09 09 09 22 22 29 29 29 0a 09 09 09 28 ......"")))....(
d840: 70 72 69 6e 74 20 28 69 66 20 28 6d 65 6d 62 65 print (if (membe
d850: 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 72 73 r key ignorevars
d860: 29 0a 09 09 09 09 20 20 20 22 23 20 73 65 74 65 )..... "# sete
d870: 6e 76 20 22 0a 09 09 09 09 20 20 20 22 73 65 74 nv "..... "set
d880: 65 6e 76 20 22 29 0a 09 09 09 20 20 20 20 20 20 env ")....
d890: 20 6b 65 79 20 22 20 22 20 64 65 6c 69 6d 20 28 key " " delim (
d8a0: 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 64 65 mungeval val) de
d8b0: 6c 69 6d 29 29 29 0a 09 09 20 20 20 20 65 6e 76 lim)))... env
d8c0: 76 61 72 73 29 29 29 0a 20 20 20 20 20 28 77 69 vars))). (wi
d8d0: 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c th-output-to-fil
d8e0: 65 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e e (conc fname ".
d8f0: 73 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d sh"). (lam
d900: 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 bda ().
d910: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
d920: 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 da (keyval)...
d930: 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 (let* ((key
d940: 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 (car keyval))...
d950: 09 20 20 20 20 20 28 76 61 6c 20 28 63 64 72 20 . (val (cdr
d960: 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 20 keyval))....
d970: 20 28 64 65 6c 69 6d 20 28 69 66 20 28 73 74 72 (delim (if (str
d980: 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 ing-search white
d990: 73 70 20 76 61 6c 29 20 0a 09 09 09 09 09 22 5c sp val) ......"\
d9a0: 22 22 0a 09 09 09 09 09 22 22 29 29 29 0a 09 09 ""......"")))...
d9b0: 09 28 70 72 69 6e 74 20 28 69 66 20 28 6d 65 6d .(print (if (mem
d9c0: 62 65 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 ber key ignoreva
d9d0: 72 73 29 0a 09 09 09 09 20 20 20 22 23 20 65 78 rs)..... "# ex
d9e0: 70 6f 72 74 20 22 0a 09 09 09 09 20 20 20 22 65 port "..... "e
d9f0: 78 70 6f 72 74 20 22 29 0a 09 09 09 20 20 20 20 xport ")....
da00: 20 20 20 6b 65 79 20 22 3d 22 20 64 65 6c 69 6d key "=" delim
da10: 20 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 (mungeval val)
da20: 64 65 6c 69 6d 29 29 29 0a 20 20 20 20 20 20 20 delim))).
da30: 20 20 20 20 20 20 20 20 20 20 20 20 20 65 6e 76 env
da40: 76 61 72 73 29 29 29 29 29 0a 0a 3b 3b 20 73 65 vars)))))..;; se
da50: 74 20 73 6f 6d 65 20 65 6e 76 20 76 61 72 73 20 t some env vars
da60: 66 72 6f 6d 20 61 6e 20 61 6c 69 73 74 2c 20 72 from an alist, r
da70: 65 74 75 72 6e 20 61 6e 20 61 6c 69 73 74 20 77 eturn an alist w
da80: 69 74 68 20 6f 72 69 67 69 6e 61 6c 20 76 61 6c ith original val
da90: 75 65 73 0a 3b 3b 20 28 28 22 56 41 52 22 20 22 ues.;; (("VAR" "
daa0: 76 61 6c 75 65 22 29 20 2e 2e 2e 29 0a 28 64 65 value") ...).(de
dab0: 66 69 6e 65 20 28 61 6c 69 73 74 2d 3e 65 6e 76 fine (alist->env
dac0: 2d 76 61 72 73 20 6c 73 74 29 0a 20 20 28 69 66 -vars lst). (if
dad0: 20 28 6c 69 73 74 3f 20 6c 73 74 29 0a 20 20 20 (list? lst).
dae0: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 (let ((res '(
daf0: 29 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 )))..(for-each (
db00: 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 lambda (p)...
db10: 20 28 6c 65 74 2a 20 28 28 76 61 72 20 28 63 61 (let* ((var (ca
db20: 72 20 20 70 29 29 0a 09 09 09 20 20 20 28 76 61 r p)).... (va
db30: 6c 20 28 63 61 64 72 20 70 29 29 0a 09 09 09 20 l (cadr p))....
db40: 20 20 28 70 72 76 20 28 67 65 74 2d 65 6e 76 69 (prv (get-envi
db50: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
db60: 20 76 61 72 29 29 29 0a 09 09 20 20 20 20 20 20 var)))...
db70: 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 (set! res (cons
db80: 28 6c 69 73 74 20 76 61 72 20 70 72 76 29 20 72 (list var prv) r
db90: 65 73 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 es))... (if
dba0: 20 76 61 6c 20 0a 09 09 09 20 20 28 73 65 74 65 val .... (sete
dbb0: 6e 76 20 76 61 72 20 28 2d 3e 73 74 72 69 6e 67 nv var (->string
dbc0: 20 76 61 6c 29 29 0a 09 09 09 20 20 28 75 6e 73 val)).... (uns
dbd0: 65 74 65 6e 76 20 76 61 72 29 29 29 29 0a 09 09 etenv var))))...
dbe0: 20 20 6c 73 74 29 0a 09 72 65 73 29 0a 20 20 20 lst)..res).
dbf0: 20 20 20 27 28 29 29 29 0a 0a 3b 3b 20 63 6c 65 '()))..;; cle
dc00: 61 72 20 76 61 72 73 20 6d 61 74 63 68 69 6e 67 ar vars matching
dc10: 20 70 61 74 74 65 72 6e 2c 20 72 75 6e 20 70 72 pattern, run pr
dc20: 6f 63 2c 20 73 65 74 20 76 61 72 73 20 62 61 63 oc, set vars bac
dc30: 6b 0a 3b 3b 20 69 66 20 70 72 6f 63 20 69 73 20 k.;; if proc is
dc40: 61 20 73 74 72 69 6e 67 20 72 75 6e 20 74 68 61 a string run tha
dc50: 74 20 73 74 72 69 6e 67 20 61 73 20 61 20 63 6f t string as a co
dc60: 6d 6d 61 6e 64 20 77 69 74 68 0a 3b 3b 20 73 79 mmand with.;; sy
dc70: 73 74 65 6d 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 stem..;;.(define
dc80: 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 (common:without
dc90: 2d 76 61 72 73 20 70 72 6f 63 20 2e 20 76 61 72 -vars proc . var
dca0: 2d 70 61 74 74 73 29 0a 20 20 28 6c 65 74 20 28 -patts). (let (
dcb0: 28 76 61 72 73 20 28 6d 61 6b 65 2d 68 61 73 68 (vars (make-hash
dcc0: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 66 -table))). (f
dcd0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
dce0: 6d 62 64 61 20 28 76 61 72 64 61 74 29 20 3b 3b mbda (vardat) ;;
dcf0: 20 65 61 63 68 20 65 6e 76 20 76 61 72 0a 20 20 each env var.
dd00: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 (for-each..
dd10: 28 6c 61 6d 62 64 61 20 28 76 61 72 2d 70 61 74 (lambda (var-pat
dd20: 74 29 0a 09 20 20 28 69 66 20 28 73 74 72 69 6e t).. (if (strin
dd30: 67 2d 6d 61 74 63 68 20 76 61 72 2d 70 61 74 74 g-match var-patt
dd40: 20 28 63 61 72 20 76 61 72 64 61 74 29 29 0a 09 (car vardat))..
dd50: 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 72 (let ((var
dd60: 20 28 63 61 72 20 76 61 72 64 61 74 29 29 0a 09 (car vardat))..
dd70: 09 20 20 20 20 28 76 61 6c 20 28 63 64 72 20 76 . (val (cdr v
dd80: 61 72 64 61 74 29 29 29 0a 09 09 28 68 61 73 68 ardat)))...(hash
dd90: 2d 74 61 62 6c 65 2d 73 65 74 21 20 76 61 72 73 -table-set! vars
dda0: 20 76 61 72 20 76 61 6c 29 0a 09 09 28 75 6e 73 var val)...(uns
ddb0: 65 74 65 6e 76 20 76 61 72 29 29 29 29 0a 09 76 etenv var))))..v
ddc0: 61 72 2d 70 61 74 74 73 29 29 0a 20 20 20 20 20 ar-patts)).
ddd0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
dde0: 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 20 -variables)).
ddf0: 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 73 74 (cond. ((st
de00: 72 69 6e 67 3f 20 70 72 6f 63 29 28 73 79 73 74 ring? proc)(syst
de10: 65 6d 20 70 72 6f 63 29 29 0a 20 20 20 20 20 28 em proc)). (
de20: 70 72 6f 63 20 20 20 20 20 20 20 20 20 20 28 70 proc (p
de30: 72 6f 63 29 29 29 0a 20 20 20 20 28 68 61 73 68 roc))). (hash
de40: 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a -table-for-each.
de50: 20 20 20 20 20 76 61 72 73 0a 20 20 20 20 20 28 vars. (
de60: 6c 61 6d 62 64 61 20 28 76 61 72 20 76 61 6c 29 lambda (var val)
de70: 0a 20 20 20 20 20 20 20 28 73 65 74 65 6e 76 20 . (setenv
de80: 76 61 72 20 76 61 6c 29 29 29 0a 20 20 20 20 76 var val))). v
de90: 61 72 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ars))..(define (
dea0: 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 61 2d 63 6f 6d common:run-a-com
deb0: 6d 61 6e 64 20 63 6d 64 20 23 21 6b 65 79 20 28 mand cmd #!key (
dec0: 77 69 74 68 2d 76 61 72 73 20 23 66 29 29 0a 20 with-vars #f)).
ded0: 20 28 6c 65 74 2a 20 28 28 70 72 65 2d 63 6d 64 (let* ((pre-cmd
dee0: 20 20 28 64 74 65 73 74 73 3a 67 65 74 2d 70 72 (dtests:get-pr
def0: 65 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 20 e-command)).
df00: 20 20 20 20 20 28 70 6f 73 74 2d 63 6d 64 20 28 (post-cmd (
df10: 64 74 65 73 74 73 3a 67 65 74 2d 70 6f 73 74 2d dtests:get-post-
df20: 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 20 20 20 command)).
df30: 20 20 20 28 66 75 6c 6c 63 6d 64 20 20 28 69 66 (fullcmd (if
df40: 20 28 6f 72 20 70 72 65 2d 63 6d 64 20 70 6f 73 (or pre-cmd pos
df50: 74 2d 63 6d 64 29 0a 20 20 20 20 20 20 20 20 20 t-cmd).
df60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
df70: 6f 6e 63 20 70 72 65 2d 63 6d 64 20 63 6d 64 20 onc pre-cmd cmd
df80: 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 20 20 20 post-cmd).
df90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfa0: 20 28 63 6f 6e 63 20 22 76 69 65 77 73 63 72 65 (conc "viewscre
dfb0: 65 6e 20 22 20 63 6d 64 29 29 29 29 0a 20 20 20 en " cmd)))).
dfc0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
dfd0: 66 6f 20 30 32 20 2a 64 65 66 61 75 6c 74 2d 6c fo 02 *default-l
dfe0: 6f 67 2d 70 6f 72 74 2a 20 22 52 75 6e 6e 69 6e og-port* "Runnin
dff0: 67 20 63 6f 6d 6d 61 6e 64 3a 20 22 20 66 75 6c g command: " ful
e000: 6c 63 6d 64 29 0a 20 20 20 20 28 69 66 20 77 69 lcmd). (if wi
e010: 74 68 2d 76 61 72 73 0a 20 20 20 20 20 20 20 20 th-vars.
e020: 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d (common:without-
e030: 76 61 72 73 20 63 6d 64 29 0a 20 20 20 20 20 20 vars cmd).
e040: 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 (common:withou
e050: 74 2d 76 61 72 73 20 66 75 6c 6c 63 6d 64 20 22 t-vars fullcmd "
e060: 4d 54 5f 2e 2a 22 29 29 29 29 0a 09 09 20 20 0a MT_.*"))))... .
e070: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
e080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e0b0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 49 20 ========.;; T I
e0c0: 4d 20 45 20 20 20 41 20 4e 20 44 20 20 20 44 20 M E A N D D
e0d0: 41 20 54 20 45 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d A T E.;;========
e0e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e0f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
e120: 3b 3b 20 43 6f 6e 76 65 72 74 20 73 74 72 69 6e ;; Convert strin
e130: 67 73 20 6c 69 6b 65 20 22 35 73 20 32 68 20 33 gs like "5s 2h 3
e140: 6d 22 20 3d 3e 20 36 30 78 36 30 78 32 20 2b 20 m" => 60x60x2 +
e150: 33 78 36 30 20 2b 20 35 0a 28 64 65 66 69 6e 65 3x60 + 5.(define
e160: 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 72 (common:hms-str
e170: 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 74 73 74 ing->seconds tst
e180: 72 29 0a 20 20 28 6c 65 74 20 28 28 70 61 72 74 r). (let ((part
e190: 73 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 s (string-sp
e1a0: 6c 69 74 20 74 73 74 72 29 29 0a 09 28 74 69 6d lit tstr))..(tim
e1b0: 65 2d 73 65 63 73 20 30 29 0a 09 3b 3b 20 73 3d e-secs 0)..;; s=
e1c0: 73 65 63 6f 6e 64 73 2c 20 6d 3d 6d 69 6e 75 74 seconds, m=minut
e1d0: 65 73 2c 20 68 3d 68 6f 75 72 73 2c 20 64 3d 64 es, h=hours, d=d
e1e0: 61 79 73 0a 09 28 74 72 78 20 20 20 20 20 20 20 ays..(trx
e1f0: 28 72 65 67 65 78 70 20 22 28 5c 5c 64 2b 29 28 (regexp "(\\d+)(
e200: 5b 73 6d 68 64 5d 29 22 29 29 29 0a 20 20 20 20 [smhd])"))).
e210: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
e220: 61 20 28 70 61 72 74 29 0a 09 09 28 6c 65 74 20 a (part)...(let
e230: 28 28 6d 61 74 63 68 20 20 28 73 74 72 69 6e 67 ((match (string
e240: 2d 6d 61 74 63 68 20 74 72 78 20 70 61 72 74 29 -match trx part)
e250: 29 29 0a 09 09 20 20 28 69 66 20 6d 61 74 63 68 ))... (if match
e260: 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ... (let ((
e270: 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d val (string->num
e280: 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 ber (cadr match)
e290: 29 29 0a 09 09 09 20 20 20 20 28 75 6e 74 20 28 )).... (unt (
e2a0: 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 0a 09 caddr match)))..
e2b0: 09 09 28 69 66 20 76 61 6c 20 0a 09 09 09 20 20 ..(if val ....
e2c0: 20 20 28 73 65 74 21 20 74 69 6d 65 2d 73 65 63 (set! time-sec
e2d0: 73 20 28 2b 20 74 69 6d 65 2d 73 65 63 73 20 28 s (+ time-secs (
e2e0: 2a 20 76 61 6c 0a 09 09 09 09 09 09 09 20 20 20 * val........
e2f0: 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
e300: 73 79 6d 62 6f 6c 20 75 6e 74 29 0a 09 09 09 09 symbol unt).....
e310: 09 09 09 20 20 20 20 20 20 28 28 73 29 20 31 29 ... ((s) 1)
e320: 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 ........ ((
e330: 6d 29 20 36 30 29 0a 09 09 09 09 09 09 09 20 20 m) 60)........
e340: 20 20 20 20 28 28 68 29 20 28 2a 20 36 30 20 36 ((h) (* 60 6
e350: 30 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 0))........
e360: 20 28 28 64 29 20 28 2a 20 32 34 20 36 30 20 36 ((d) (* 24 60 6
e370: 30 29 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 0))........
e380: 20 28 65 6c 73 65 20 30 29 29 29 29 29 29 29 29 (else 0))))))))
e390: 29 29 0a 09 20 20 20 20 20 20 70 61 72 74 73 29 )).. parts)
e3a0: 0a 20 20 20 20 74 69 6d 65 2d 73 65 63 73 29 29 . time-secs))
e3b0: 0a 09 09 20 20 20 20 20 20 20 0a 28 64 65 66 69 ... .(defi
e3c0: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d ne (seconds->hr-
e3d0: 6d 69 6e 2d 73 65 63 20 73 65 63 73 29 0a 20 20 min-sec secs).
e3e0: 28 6c 65 74 2a 20 28 28 68 72 73 20 28 71 75 6f (let* ((hrs (quo
e3f0: 74 69 65 6e 74 20 73 65 63 73 20 33 36 30 30 29 tient secs 3600)
e400: 29 0a 09 20 28 6d 69 6e 20 28 71 75 6f 74 69 65 ).. (min (quotie
e410: 6e 74 20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 nt (- secs (* hr
e420: 73 20 33 36 30 30 29 29 20 36 30 29 29 0a 09 20 s 3600)) 60))..
e430: 28 73 65 63 20 28 2d 20 73 65 63 73 20 28 2a 20 (sec (- secs (*
e440: 68 72 73 20 33 36 30 30 29 28 2a 20 6d 69 6e 20 hrs 3600)(* min
e450: 36 30 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 60)))). (conc
e460: 20 28 69 66 20 28 3e 20 68 72 73 20 30 29 28 63 (if (> hrs 0)(c
e470: 6f 6e 63 20 68 72 73 20 22 68 72 20 22 29 20 22 onc hrs "hr ") "
e480: 22 29 0a 09 20 20 28 69 66 20 28 3e 20 6d 69 6e ").. (if (> min
e490: 20 30 29 28 63 6f 6e 63 20 6d 69 6e 20 22 6d 20 0)(conc min "m
e4a0: 22 29 20 20 22 22 29 0a 09 20 20 73 65 63 20 22 ") "").. sec "
e4b0: 73 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s")))..(define (
e4c0: 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 seconds->time-st
e4d0: 72 69 6e 67 20 73 65 63 29 0a 20 20 28 74 69 6d ring sec). (tim
e4e0: 65 2d 3e 73 74 72 69 6e 67 20 0a 20 20 20 28 73 e->string . (s
e4f0: 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
e500: 6d 65 20 73 65 63 29 20 22 25 48 3a 25 4d 3a 25 me sec) "%H:%M:%
e510: 53 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 S"))..(define (s
e520: 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 econds->work-wee
e530: 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 0a k/day-time sec).
e540: 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a (time->string.
e550: 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
e560: 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 77 77 al-time sec) "ww
e570: 25 56 2e 25 75 20 25 48 3a 25 4d 22 29 29 0a 0a %V.%u %H:%M"))..
e580: 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 (define (seconds
e590: 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 20 ->work-week/day
e5a0: 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
e5b0: 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
e5c0: 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
e5d0: 29 20 22 77 77 25 56 2e 25 75 22 29 29 0a 0a 28 ) "ww%V.%u"))..(
e5e0: 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d define (seconds-
e5f0: 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f >year-work-week/
e600: 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d 65 day sec). (time
e610: 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 ->string. (sec
e620: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
e630: 20 73 65 63 29 20 22 25 79 77 77 25 56 2e 25 77 sec) "%yww%V.%w
e640: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
e650: 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b conds->year-work
e660: 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 -week/day-time s
e670: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
e680: 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ing. (seconds-
e690: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
e6a0: 20 22 25 59 77 77 25 56 2e 25 77 20 25 48 3a 25 "%Yww%V.%w %H:%
e6b0: 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 M"))..(define (s
e6c0: 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 65 65 econds->year-wee
e6d0: 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 0a k/day-time sec).
e6e0: 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a (time->string.
e6f0: 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
e700: 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 59 al-time sec) "%Y
e710: 77 25 56 2e 25 77 20 25 48 3a 25 4d 22 29 29 0a w%V.%w %H:%M")).
e720: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
e730: 73 2d 3e 71 75 61 72 74 65 72 20 73 65 63 29 0a s->quarter sec).
e740: 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
e750: 3e 6e 75 6d 62 65 72 0a 09 20 28 74 69 6d 65 2d >number.. (time-
e760: 3e 73 74 72 69 6e 67 20 0a 09 20 20 28 73 65 63 >string .. (sec
e770: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
e780: 20 73 65 63 29 0a 09 20 20 22 25 6d 22 29 29 0a sec).. "%m")).
e790: 20 20 20 20 28 28 31 20 32 20 33 29 20 31 29 0a ((1 2 3) 1).
e7a0: 20 20 20 20 28 28 34 20 35 20 36 29 20 32 29 0a ((4 5 6) 2).
e7b0: 20 20 20 20 28 28 37 20 38 20 39 29 20 33 29 0a ((7 8 9) 3).
e7c0: 20 20 20 20 28 28 31 30 20 31 31 20 31 32 29 20 ((10 11 12)
e7d0: 34 29 0a 20 20 20 20 28 65 6c 73 65 20 23 66 29 4). (else #f)
e7e0: 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 73 70 61 ))..;; given spa
e7f0: 6e 20 6f 66 20 73 65 63 6f 6e 64 73 20 74 73 74 n of seconds tst
e800: 61 72 74 20 74 6f 20 74 65 6e 64 0a 3b 3b 20 66 art to tend.;; f
e810: 69 6e 64 20 73 74 61 72 74 20 74 69 6d 65 20 74 ind start time t
e820: 6f 20 6d 61 72 6b 20 61 6e 64 20 6d 61 72 6b 20 o mark and mark
e830: 64 65 6c 74 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 delta.;;.(define
e840: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 73 74 (common:find-st
e850: 61 72 74 2d 6d 61 72 6b 2d 61 6e 64 2d 6d 61 72 art-mark-and-mar
e860: 6b 2d 64 65 6c 74 61 20 74 73 74 61 72 74 20 74 k-delta tstart t
e870: 65 6e 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 end). (let* ((d
e880: 65 6c 74 61 74 20 20 20 28 2d 20 28 6d 61 78 20 eltat (- (max
e890: 74 65 6e 64 20 28 2b 20 74 65 6e 64 20 31 30 29 tend (+ tend 10)
e8a0: 29 20 74 73 74 61 72 74 29 29 20 3b 3b 20 63 61 ) tstart)) ;; ca
e8b0: 6e 27 74 20 68 61 6e 64 6c 65 20 72 75 6e 73 20 n't handle runs
e8c0: 6f 66 20 6c 65 73 73 20 74 68 61 6e 20 34 20 73 of less than 4 s
e8d0: 65 63 6f 6e 64 73 2e 20 50 61 64 20 69 74 20 74 econds. Pad it t
e8e0: 6f 20 31 30 20 73 65 63 6f 6e 64 73 20 2e 2e 2e o 10 seconds ...
e8f0: 0a 09 20 28 72 65 73 75 6c 74 20 20 20 23 66 29 .. (result #f)
e900: 0a 09 20 28 6d 69 6e 20 20 20 20 20 20 36 30 29 .. (min 60)
e910: 0a 09 20 28 68 72 20 20 20 20 20 20 20 28 2a 20 .. (hr (*
e920: 36 30 20 36 30 29 29 0a 09 20 28 64 61 79 20 20 60 60)).. (day
e930: 20 20 20 20 28 2a 20 32 34 20 68 72 29 29 0a 09 (* 24 hr))..
e940: 20 28 79 72 20 20 20 20 20 20 20 28 2a 20 33 36 (yr (* 36
e950: 35 20 64 61 79 29 29 20 3b 3b 20 79 65 61 72 0a 5 day)) ;; year.
e960: 09 20 28 6d 6f 20 20 20 20 20 20 20 28 2f 20 79 . (mo (/ y
e970: 72 20 31 32 29 29 0a 09 20 28 77 6b 20 20 20 20 r 12)).. (wk
e980: 20 20 20 28 2a 20 64 61 79 20 37 29 29 29 0a 20 (* day 7))).
e990: 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
e9a0: 20 20 28 6c 61 6d 62 64 61 20 28 6d 61 78 2d 62 (lambda (max-b
e9b0: 6c 6b 73 29 0a 20 20 20 20 20 20 20 28 66 6f 72 lks). (for
e9c0: 2d 65 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 -each..(lambda (
e9d0: 73 70 61 6e 29 20 3b 3b 20 35 20 32 20 31 0a 09 span) ;; 5 2 1..
e9e0: 20 20 28 69 66 20 28 6e 6f 74 20 72 65 73 75 6c (if (not resul
e9f0: 74 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d 65 t).. (for-e
ea00: 61 63 68 20 0a 09 20 20 20 20 20 20 20 28 6c 61 ach .. (la
ea10: 6d 62 64 61 20 28 74 69 6d 65 75 6e 69 74 20 74 mbda (timeunit t
ea20: 69 6d 65 73 79 6d 29 20 3b 3b 20 79 65 61 72 20 imesym) ;; year
ea30: 6d 6f 6e 74 68 20 64 61 79 20 68 72 20 6d 69 6e month day hr min
ea40: 20 73 65 63 0a 09 09 20 28 69 66 20 28 6e 6f 74 sec... (if (not
ea50: 20 72 65 73 75 6c 74 29 0a 09 09 20 20 20 20 20 result)...
ea60: 28 6c 65 74 2a 20 28 28 74 69 6d 65 2d 62 6c 6b (let* ((time-blk
ea70: 20 28 2a 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 (* span timeuni
ea80: 74 29 29 0a 09 09 09 20 20 20 20 28 6e 75 6d 2d t)).... (num-
ea90: 62 6c 6b 73 20 28 71 75 6f 74 69 65 6e 74 20 64 blks (quotient d
eaa0: 65 6c 74 61 74 20 74 69 6d 65 2d 62 6c 6b 29 29 eltat time-blk))
eab0: 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 28 )... (if (
eac0: 61 6e 64 20 28 3e 20 6e 75 6d 2d 62 6c 6b 73 20 and (> num-blks
ead0: 34 29 28 3c 20 6e 75 6d 2d 62 6c 6b 73 20 6d 61 4)(< num-blks ma
eae0: 78 2d 62 6c 6b 73 29 29 0a 09 09 09 20 20 20 28 x-blks)).... (
eaf0: 6c 65 74 20 28 28 66 69 72 73 74 20 28 2a 20 28 let ((first (* (
eb00: 71 75 6f 74 69 65 6e 74 20 74 73 74 61 72 74 20 quotient tstart
eb10: 74 69 6d 65 2d 62 6c 6b 29 20 74 69 6d 65 2d 62 time-blk) time-b
eb20: 6c 6b 29 29 29 0a 09 09 09 20 20 20 20 20 28 73 lk))).... (s
eb30: 65 74 21 20 72 65 73 75 6c 74 20 28 6c 69 73 74 et! result (list
eb40: 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 20 74 span timeunit t
eb50: 69 6d 65 2d 62 6c 6b 20 66 69 72 73 74 20 74 69 ime-blk first ti
eb60: 6d 65 73 79 6d 29 29 0a 09 09 09 20 20 20 20 20 mesym))....
eb70: 29 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 6c ))))).. (l
eb80: 69 73 74 20 79 72 20 6d 6f 20 77 6b 20 64 61 79 ist yr mo wk day
eb90: 20 68 72 20 6d 69 6e 20 31 29 0a 09 20 20 20 20 hr min 1)..
eba0: 20 20 20 27 28 20 20 20 20 20 79 20 20 6d 6f 20 '( y mo
ebb0: 77 20 20 64 20 20 20 68 20 20 6d 20 20 20 73 29 w d h m s)
ebc0: 29 29 29 0a 09 28 6c 69 73 74 20 38 20 36 20 35 )))..(list 8 6 5
ebd0: 20 32 20 31 29 29 29 0a 20 20 20 20 20 27 28 35 2 1))). '(5
ebe0: 20 31 30 20 31 35 20 32 30 20 33 30 20 34 30 20 10 15 20 30 40
ebf0: 35 30 20 35 30 30 29 29 0a 20 20 20 20 28 69 66 50 500)). (if
ec00: 20 76 61 6c 75 65 73 0a 09 28 61 70 70 6c 79 20 values..(apply
ec10: 76 61 6c 75 65 73 20 72 65 73 75 6c 74 29 0a 09 values result)..
ec20: 28 76 61 6c 75 65 73 20 30 20 64 61 79 20 31 20 (values 0 day 1
ec30: 30 20 27 64 29 29 29 29 0a 09 20 20 20 20 0a 09 0 'd)))).. ..
ec40: 20 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;==========
ec50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ec60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ec70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ec80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
ec90: 43 20 4f 20 4c 20 4f 20 52 20 53 0a 3b 3b 3d 3d C O L O R S.;;==
eca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ecb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ecc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ecd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ece0: 3d 3d 3d 3d 0a 20 20 20 20 20 20 0a 28 64 65 66 ====. .(def
ecf0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6e 61 6d 65 ine (common:name
ed00: 2d 3e 69 75 70 2d 63 6f 6c 6f 72 20 6e 61 6d 65 ->iup-color name
ed10: 29 0a 20 20 28 63 61 73 65 20 28 73 74 72 69 6e ). (case (strin
ed20: 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e g->symbol (strin
ed30: 67 2d 64 6f 77 6e 63 61 73 65 20 6e 61 6d 65 29 g-downcase name)
ed40: 29 0a 20 20 20 20 28 28 72 65 64 29 20 20 20 20 ). ((red)
ed50: 22 32 32 33 20 33 33 20 34 39 22 29 0a 20 20 20 "223 33 49").
ed60: 20 28 28 67 72 65 79 29 20 20 20 22 31 39 32 20 ((grey) "192
ed70: 31 39 32 20 31 39 32 22 29 0a 20 20 20 20 28 28 192 192"). ((
ed80: 6f 72 61 6e 67 65 29 20 22 32 35 35 20 31 37 32 orange) "255 172
ed90: 20 31 33 22 29 0a 20 20 20 20 28 28 70 75 72 70 13"). ((purp
eda0: 6c 65 29 20 22 54 68 69 73 20 69 73 20 75 6e 66 le) "This is unf
edb0: 69 6e 69 73 68 65 64 20 2e 2e 2e 22 29 29 29 0a inished ..."))).
edc0: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6f 6d .;; (define (com
edd0: 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 6f mon:get-color-fo
ede0: 72 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 73 r-state-status s
edf0: 74 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 tate status).;;
ee00: 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
ee10: 3e 73 79 6d 62 6f 6c 20 73 74 61 74 65 29 0a 3b >symbol state).;
ee20: 3b 20 20 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 ; ((COMPLETE
ee30: 44 29 0a 3b 3b 20 20 20 20 20 20 28 63 61 73 65 D).;; (case
ee40: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
ee50: 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 20 20 status).;;
ee60: 20 20 20 28 28 50 41 53 53 29 20 20 20 20 20 20 ((PASS)
ee70: 20 20 22 37 30 20 20 32 34 39 20 37 33 22 29 0a "70 249 73").
ee80: 3b 3b 20 20 20 20 20 20 20 20 28 28 57 41 52 4e ;; ((WARN
ee90: 20 57 41 49 56 45 44 29 20 22 32 35 35 20 31 37 WAIVED) "255 17
eea0: 32 20 31 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 2 13").;;
eeb0: 20 28 28 53 4b 49 50 29 20 20 20 20 20 20 20 20 ((SKIP)
eec0: 22 32 33 30 20 32 33 30 20 30 22 29 0a 3b 3b 20 "230 230 0").;;
eed0: 20 20 20 20 20 20 20 28 65 6c 73 65 20 22 32 32 (else "22
eee0: 33 20 33 33 20 34 39 22 29 29 29 0a 3b 3b 20 20 3 33 49"))).;;
eef0: 20 20 20 28 28 4c 41 55 4e 43 48 45 44 29 20 20 ((LAUNCHED)
ef00: 20 20 20 20 20 20 20 22 31 30 31 20 31 32 33 20 "101 123
ef10: 31 34 32 22 29 0a 3b 3b 20 20 20 20 20 28 28 43 142").;; ((C
ef20: 48 45 43 4b 29 20 20 20 20 20 20 20 20 20 20 20 HECK)
ef30: 20 22 32 35 35 20 31 30 30 20 35 30 22 29 0a 3b "255 100 50").;
ef40: 3b 20 20 20 20 20 28 28 52 45 4d 4f 54 45 48 4f ; ((REMOTEHO
ef50: 53 54 53 54 41 52 54 29 20 20 22 35 30 20 20 31 STSTART) "50 1
ef60: 33 30 20 31 39 35 22 29 0a 3b 3b 20 20 20 20 20 30 195").;;
ef70: 28 28 52 55 4e 4e 49 4e 47 29 20 20 20 20 20 20 ((RUNNING)
ef80: 20 20 20 20 22 39 20 20 20 31 33 31 20 32 33 32 "9 131 232
ef90: 22 29 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c ").;; ((KILL
efa0: 52 45 51 29 20 20 20 20 20 20 20 20 20 20 22 33 REQ) "3
efb0: 39 20 20 38 32 20 20 32 30 36 22 29 0a 3b 3b 20 9 82 206").;;
efc0: 20 20 20 20 28 28 4b 49 4c 4c 45 44 29 20 20 20 ((KILLED)
efd0: 20 20 20 20 20 20 20 20 22 32 33 34 20 31 30 31 "234 101
efe0: 20 31 37 22 29 0a 3b 3b 20 20 20 20 20 28 28 4e 17").;; ((N
eff0: 4f 54 5f 53 54 41 52 54 45 44 29 20 20 20 20 20 OT_STARTED)
f000: 20 22 32 34 30 20 32 34 30 20 32 34 30 22 29 0a "240 240 240").
f010: 3b 3b 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 ;; (else
f020: 20 20 20 20 20 20 20 20 20 20 20 22 31 39 32 20 "192
f030: 31 39 32 20 31 39 32 22 29 29 29 0a 0a 28 64 65 192 192")))..(de
f040: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 69 75 70 fine (common:iup
f050: 2d 63 6f 6c 6f 72 2d 3e 72 67 62 2d 68 65 78 20 -color->rgb-hex
f060: 69 6e 73 74 72 29 0a 20 20 28 73 74 72 69 6e 67 instr). (string
f070: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 -intersperse .
f080: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
f090: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6e 75 6d ). (num
f0a0: 62 65 72 2d 3e 73 74 72 69 6e 67 20 78 20 31 36 ber->string x 16
f0b0: 29 29 0a 20 20 20 20 20 20 20 20 28 6d 61 70 20 )). (map
f0c0: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 20 string->number.
f0d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 72 (str
f0e0: 69 6e 67 2d 73 70 6c 69 74 20 69 6e 73 74 72 29 ing-split instr)
f0f0: 29 29 0a 20 20 20 22 2f 22 29 29 0a 0a 28 64 65 )). "/"))..(de
f100: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
f110: 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 -color-from-stat
f120: 75 73 20 73 74 61 74 75 73 29 0a 20 20 28 63 6f us status). (co
f130: 6e 64 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 nd. ((equal? s
f140: 74 61 74 75 73 20 22 50 41 53 53 22 29 20 20 20 tatus "PASS")
f150: 20 22 67 72 65 65 6e 22 29 0a 20 20 20 28 28 65 "green"). ((e
f160: 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 qual? status "FA
f170: 49 4c 22 29 20 20 20 20 22 72 65 64 22 29 0a 20 IL") "red").
f180: 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 ((equal? statu
f190: 73 20 22 57 41 52 4e 22 29 20 20 20 20 22 6f 72 s "WARN") "or
f1a0: 61 6e 67 65 22 29 0a 20 20 20 28 28 65 71 75 61 ange"). ((equa
f1b0: 6c 3f 20 73 74 61 74 75 73 20 22 4b 49 4c 4c 45 l? status "KILLE
f1c0: 44 22 29 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 D") "orange").
f1d0: 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 ((equal? statu
f1e0: 73 20 22 4b 49 4c 4c 52 45 51 22 29 20 22 70 75 s "KILLREQ") "pu
f1f0: 72 70 6c 65 22 29 0a 20 20 20 28 28 65 71 75 61 rple"). ((equa
f200: 6c 3f 20 73 74 61 74 75 73 20 22 52 55 4e 4e 49 l? status "RUNNI
f210: 4e 47 22 29 20 22 62 6c 75 65 22 29 0a 20 20 20 NG") "blue").
f220: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
f230: 22 41 42 4f 52 54 22 29 20 20 20 22 62 72 6f 77 "ABORT") "brow
f240: 6e 22 29 0a 20 20 20 28 65 6c 73 65 20 22 62 6c n"). (else "bl
f250: 61 63 6b 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d ack")))..;;=====
f260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f2a0: 3d 0a 3b 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 53 =.;; N A N O M S
f2b0: 20 47 20 20 20 43 20 4c 20 49 20 45 20 4e 20 54 G C L I E N T
f2c0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
f2d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f2e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f2f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
f310: 6e 65 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 ne (server:get-b
f320: 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 est-guess-addres
f330: 73 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c s hostname). (l
f340: 65 74 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 et ((res #f)).
f350: 20 20 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 (for-each .
f360: 20 20 28 6c 61 6d 62 64 61 20 28 61 64 72 29 0a (lambda (adr).
f370: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
f380: 28 65 71 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 (eq? (u8vector-r
f390: 65 66 20 61 64 72 20 30 29 20 31 32 37 29 29 0a ef adr 0) 127)).
f3a0: 09 20 20 20 28 73 65 74 21 20 72 65 73 20 61 64 . (set! res ad
f3b0: 72 29 29 29 0a 20 20 20 20 20 3b 3b 20 4e 4f 54 r))). ;; NOT
f3c0: 45 3a 20 54 68 69 73 20 63 61 6e 20 66 61 69 6c E: This can fail
f3d0: 20 77 68 65 6e 20 74 68 65 72 65 20 69 73 20 6e when there is n
f3e0: 6f 20 6d 65 6e 74 69 6f 6e 20 6f 66 20 74 68 65 o mention of the
f3f0: 20 68 6f 73 74 20 69 6e 20 2f 65 74 63 2f 68 6f host in /etc/ho
f400: 73 74 73 2e 20 46 49 58 4d 45 0a 20 20 20 20 20 sts. FIXME.
f410: 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 (vector->list (h
f420: 6f 73 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 ostinfo-addresse
f430: 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 s (hostname->hos
f440: 74 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 tinfo hostname))
f450: 29 29 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 )). (string-i
f460: 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 20 ntersperse .
f470: 20 28 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 (map number->st
f480: 72 69 6e 67 0a 09 20 20 28 75 38 76 65 63 74 6f ring.. (u8vecto
f490: 72 2d 3e 6c 69 73 74 0a 09 20 20 20 28 69 66 20 r->list.. (if
f4a0: 72 65 73 20 72 65 73 20 28 68 6f 73 74 6e 61 6d res res (hostnam
f4b0: 65 2d 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 e->ip hostname))
f4c0: 29 29 20 22 2e 22 29 29 29 0a 0a 0a 28 64 65 66 )) ".")))...(def
f4d0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e 64 ine (common:send
f4e0: 2d 64 62 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 61 -dboard-main-cha
f4f0: 6e 67 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 nged). (let* ((
f500: 64 61 73 68 62 6f 61 72 64 2d 69 70 73 20 28 6d dashboard-ips (m
f510: 64 64 62 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 ddb:get-dashboar
f520: 64 73 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 ds))). (for-e
f530: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
f540: 20 28 69 70 61 64 72 29 0a 20 20 20 20 20 20 20 (ipadr).
f550: 28 6c 65 74 2a 20 28 28 73 6f 63 20 28 63 6f 6d (let* ((soc (com
f560: 6d 6f 6e 3a 6f 70 65 6e 2d 6e 6d 2d 72 65 71 20 mon:open-nm-req
f570: 28 63 6f 6e 63 20 22 74 63 70 3a 2f 2f 22 20 69 (conc "tcp://" i
f580: 70 61 64 72 29 29 29 0a 09 20 20 20 20 20 20 28 padr))).. (
f590: 6d 73 67 20 28 63 6f 6e 63 20 22 6d 61 69 6e 20 msg (conc "main
f5a0: 22 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 " *toppath*))..
f5b0: 20 20 20 20 20 28 72 65 73 20 28 63 6f 6d 6d 6f (res (commo
f5c0: 6e 3a 6e 6d 2d 73 65 6e 64 2d 72 65 63 65 69 76 n:nm-send-receiv
f5d0: 65 2d 74 69 6d 65 6f 75 74 20 73 6f 63 20 6d 73 e-timeout soc ms
f5e0: 67 29 29 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 g))).. (if (not
f5f0: 72 65 73 29 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 res) ;; couldn't
f600: 20 72 65 61 63 68 20 74 68 61 74 20 64 61 73 68 reach that dash
f610: 62 6f 61 72 64 20 2d 20 72 65 6d 6f 76 65 20 69 board - remove i
f620: 74 20 66 72 6f 6d 20 64 62 0a 09 20 20 20 20 20 t from db..
f630: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 63 (print "ERROR: c
f640: 6f 75 6c 64 6e 27 74 20 72 65 61 63 68 20 64 61 ouldn't reach da
f650: 73 68 62 6f 61 72 64 20 22 20 69 70 61 64 72 29 shboard " ipadr)
f660: 29 0a 09 20 72 65 73 29 29 0a 20 20 20 20 20 64 ).. res)). d
f670: 61 73 68 62 6f 61 72 64 2d 69 70 73 29 29 29 0a ashboard-ips))).
f680: 20 20 20 20 0a 20 20 20 20 0a 3b 3b 3d 3d 3d 3d . .;;====
f690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6d0: 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 48 20 42 20 ==.;; D A S H B
f6e0: 4f 20 41 20 52 20 44 20 20 20 44 20 42 20 0a 3b O A R D D B .;
f6f0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
f700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f730: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
f740: 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 0a (mddb:open-db).
f750: 20 20 28 6c 65 74 2a 20 28 28 64 62 20 28 6f 70 (let* ((db (op
f760: 65 6e 2d 64 61 74 61 62 61 73 65 20 28 63 6f 6e en-database (con
f770: 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 c (get-environme
f780: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d nt-variable "HOM
f790: 45 22 29 20 22 2f 2e 64 61 73 68 62 6f 61 72 64 E") "/.dashboard
f7a0: 2e 64 62 22 29 29 29 29 0a 20 20 20 20 28 73 65 .db")))). (se
f7b0: 74 2d 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 t-busy-handler!
f7c0: 64 62 20 28 62 75 73 79 2d 74 69 6d 65 6f 75 74 db (busy-timeout
f7d0: 20 31 30 30 30 30 29 29 0a 20 20 20 20 28 66 6f 10000)). (fo
f7e0: 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d r-each. (lam
f7f0: 62 64 61 20 28 71 72 79 29 0a 20 20 20 20 20 20 bda (qry).
f800: 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 71 (exec (sql db q
f810: 72 79 29 29 29 0a 20 20 20 20 20 28 6c 69 73 74 ry))). (list
f820: 20 0a 20 20 20 20 20 20 22 43 52 45 41 54 45 20 . "CREATE
f830: 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 TABLE IF NOT EXI
f840: 53 54 53 20 76 61 72 73 20 20 20 20 20 20 20 28 STS vars (
f850: 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 id INTEGER PRIMA
f860: 52 59 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c RY KEY,key TEXT,
f870: 20 76 61 6c 20 54 45 58 54 2c 20 43 4f 4e 53 54 val TEXT, CONST
f880: 52 41 49 4e 54 20 76 61 72 73 63 6f 6e 73 74 72 RAINT varsconstr
f890: 61 69 6e 74 20 55 4e 49 51 55 45 20 28 6b 65 79 aint UNIQUE (key
f8a0: 29 29 3b 22 0a 20 20 20 20 20 20 22 43 52 45 41 ));". "CREA
f8b0: 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 TE TABLE IF NOT
f8c0: 45 58 49 53 54 53 20 64 61 73 68 62 6f 61 72 64 EXISTS dashboard
f8d0: 73 20 28 0a 20 20 20 20 20 20 20 20 20 20 69 64 s (. id
f8e0: 20 20 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 INTEGER
f8f0: 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 PRIMARY KEY,.
f900: 20 20 20 20 20 20 20 20 70 69 64 20 20 20 20 20 pid
f910: 20 20 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 INTEGER,.
f920: 20 20 20 20 20 20 75 73 65 72 6e 61 6d 65 20 20 username
f930: 20 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 TEXT,.
f940: 20 68 6f 73 74 6e 61 6d 65 20 20 20 54 45 58 54 hostname TEXT
f950: 2c 0a 20 20 20 20 20 20 20 20 20 20 69 70 61 64 ,. ipad
f960: 64 72 20 20 20 20 20 54 45 58 54 2c 0a 20 20 20 dr TEXT,.
f970: 20 20 20 20 20 20 20 70 6f 72 74 6e 75 6d 20 20 portnum
f980: 20 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 INTEGER,.
f990: 20 20 20 20 20 73 74 61 72 74 5f 74 69 6d 65 20 start_time
f9a0: 54 49 4d 45 53 54 41 4d 50 20 44 45 46 41 55 4c TIMESTAMP DEFAUL
f9b0: 54 20 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 T (strftime('%s'
f9c0: 2c 27 6e 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 ,'now')),.
f9d0: 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 49 4e CONSTRAIN
f9e0: 54 20 68 6f 73 74 70 6f 72 74 20 55 4e 49 51 55 T hostport UNIQU
f9f0: 45 20 28 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 E (hostname,port
fa00: 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 29 3b 22 num). );"
fa10: 0a 20 20 20 20 20 20 29 29 0a 20 20 20 20 64 62 . )). db
fa20: 29 29 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 ))..;; register
fa30: 61 20 64 61 73 68 62 6f 61 72 64 20 0a 3b 3b 0a a dashboard .;;.
fa40: 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 72 65 (define (mddb:re
fa50: 67 69 73 74 65 72 2d 64 61 73 68 62 6f 61 72 64 gister-dashboard
fa60: 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 port). (let* (
fa70: 28 70 69 64 20 20 20 20 20 20 28 63 75 72 72 65 (pid (curre
fa80: 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a nt-process-id)).
fa90: 09 20 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 . (hostname (get
faa0: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 -host-name)).. (
fab0: 69 70 61 64 64 72 20 20 20 28 73 65 72 76 65 72 ipaddr (server
fac0: 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d :get-best-guess-
fad0: 61 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 address hostname
fae0: 29 29 0a 09 20 28 75 73 65 72 6e 61 6d 65 20 28 )).. (username (
faf0: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d current-user-nam
fb00: 65 29 29 20 3b 3b 20 28 63 61 72 20 75 73 65 72 e)) ;; (car user
fb10: 69 6e 66 6f 29 29 29 0a 09 20 28 64 62 20 20 20 info))).. (db
fb20: 20 20 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 (mddb:open-db
fb30: 29 29 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 ))). (print "
fb40: 52 65 67 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 Register monitor
fb50: 2c 20 70 69 64 3a 20 22 20 70 69 64 20 22 2c 20 , pid: " pid ",
fb60: 68 6f 73 74 6e 61 6d 65 3a 20 22 20 68 6f 73 74 hostname: " host
fb70: 6e 61 6d 65 20 22 2c 20 70 6f 72 74 3a 20 22 20 name ", port: "
fb80: 70 6f 72 74 20 22 2c 20 75 73 65 72 6e 61 6d 65 port ", username
fb90: 3a 20 22 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 : " username).
fba0: 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 (exec (sql db
fbb0: 22 49 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 "INSERT OR REPLA
fbc0: 43 45 20 49 4e 54 4f 20 64 61 73 68 62 6f 61 72 CE INTO dashboar
fbd0: 64 73 20 28 70 69 64 2c 75 73 65 72 6e 61 6d 65 ds (pid,username
fbe0: 2c 68 6f 73 74 6e 61 6d 65 2c 69 70 61 64 64 72 ,hostname,ipaddr
fbf0: 2c 70 6f 72 74 6e 75 6d 29 20 56 41 4c 55 45 53 ,portnum) VALUES
fc00: 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a (?,?,?,?,?);").
fc10: 09 20 20 20 70 69 64 20 75 73 65 72 6e 61 6d 65 . pid username
fc20: 20 68 6f 73 74 6e 61 6d 65 20 69 70 61 64 64 72 hostname ipaddr
fc30: 20 70 6f 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 port). (clos
fc40: 65 2d 64 61 74 61 62 61 73 65 20 64 62 29 29 29 e-database db)))
fc50: 0a 0a 3b 3b 20 75 6e 72 65 67 69 73 74 65 72 20 ..;; unregister
fc60: 61 20 6d 6f 6e 69 74 6f 72 0a 3b 3b 0a 28 64 65 a monitor.;;.(de
fc70: 66 69 6e 65 20 28 6d 64 64 62 3a 75 6e 72 65 67 fine (mddb:unreg
fc80: 69 73 74 65 72 2d 64 61 73 68 62 6f 61 72 64 20 ister-dashboard
fc90: 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 host port). (le
fca0: 74 2a 20 28 28 64 62 20 20 20 20 20 20 28 6d 64 t* ((db (md
fcb0: 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 db:open-db))).
fcc0: 20 20 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 (print "Regist
fcd0: 65 72 20 75 6e 72 65 67 69 73 74 65 72 20 6d 6f er unregister mo
fce0: 6e 69 74 6f 72 2c 20 68 6f 73 74 3a 70 6f 72 74 nitor, host:port
fcf0: 3d 22 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 =" host ":" port
fd00: 29 0a 20 20 20 20 28 65 78 65 63 20 28 73 71 6c ). (exec (sql
fd10: 20 64 62 20 22 44 45 4c 45 54 45 20 46 52 4f 4d db "DELETE FROM
fd20: 20 64 61 73 68 62 6f 61 72 64 73 20 57 48 45 52 dashboards WHER
fd30: 45 20 68 6f 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 E hostname=? AND
fd40: 20 70 6f 72 74 6e 75 6d 3d 3f 3b 22 29 20 68 6f portnum=?;") ho
fd50: 73 74 20 70 6f 72 74 29 0a 20 20 20 20 28 63 6c st port). (cl
fd60: 6f 73 65 2d 64 61 74 61 62 61 73 65 20 64 62 29 ose-database db)
fd70: 29 29 0a 0a 3b 3b 20 67 65 74 20 72 65 67 69 73 ))..;; get regis
fd80: 74 65 72 65 64 20 64 61 73 68 62 6f 61 72 64 73 tered dashboards
fd90: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 .;;.(define (mdd
fda0: 62 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 64 73 b:get-dashboards
fdb0: 29 0a 20 20 28 6c 65 74 20 28 28 64 62 20 28 6d ). (let ((db (m
fdc0: 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 ddb:open-db))).
fdd0: 20 20 20 28 71 75 65 72 79 20 66 65 74 63 68 2d (query fetch-
fde0: 63 6f 6c 75 6d 6e 0a 09 20 20 20 28 73 71 6c 20 column.. (sql
fdf0: 64 62 20 22 53 45 4c 45 43 54 20 69 70 61 64 64 db "SELECT ipadd
fe00: 72 20 7c 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 74 r || ':' || port
fe10: 6e 75 6d 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 num FROM dashboa
fe20: 72 64 73 3b 22 29 29 29 29 0a 20 20 20 20 0a 3b rds;")))). .;
fe30: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
fe40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe70: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 =======.;; T E
fe80: 53 20 54 20 20 20 4c 20 41 20 55 20 4e 20 43 20 S T L A U N C
fe90: 48 20 49 20 4e 20 47 20 20 20 50 20 45 20 52 20 H I N G P E R
fea0: 20 20 49 20 54 20 45 20 4d 20 20 20 57 20 49 20 I T E M W I
feb0: 54 20 48 20 20 20 48 20 4f 20 53 20 54 20 20 20 T H H O S T
fec0: 54 20 59 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d 3d T Y P E S.;;====
fed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ff10: 3d 3d 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 73 ==.;; .;; [hosts
ff20: 5d 0a 3b 3b 20 61 72 6d 20 63 75 62 69 65 30 31 ].;; arm cubie01
ff30: 20 63 75 62 69 65 30 32 0a 3b 3b 20 78 38 36 5f cubie02.;; x86_
ff40: 36 34 20 7a 65 75 73 20 78 65 6e 61 20 6d 79 74 64 zeus xena myt
ff50: 68 30 31 0a 3b 3b 20 61 6c 6c 68 6f 73 74 73 20 h01.;; allhosts
ff60: 23 7b 67 20 68 6f 73 74 73 20 61 72 6d 7d 20 23 #{g hosts arm} #
ff70: 7b 67 20 68 6f 73 74 73 20 78 38 36 5f 36 34 7d {g hosts x86_64}
ff80: 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 2d 74 79 .;; .;; [host-ty
ff90: 70 65 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 pes].;; general
ffa0: 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b #MTLOWESTLOAD #{
ffb0: 67 20 68 6f 73 74 73 20 61 6c 6c 68 6f 73 74 73 g hosts allhosts
ffc0: 7d 0a 3b 3b 20 61 72 6d 20 20 20 20 20 23 4d 54 }.;; arm #MT
ffd0: 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 68 LOWESTLOAD #{g h
ffe0: 6f 73 74 73 20 61 72 6d 7d 0a 3b 3b 20 6e 62 67 osts arm}.;; nbg
fff0: 65 6e 65 72 61 6c 20 6e 62 6a 6f 62 20 72 75 6e eneral nbjob run
10000 20 4a 4f 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f 67 JOBCOMMAND -log
10010 20 24 4d 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 4d $MT_LINKTREE/$M
10020 54 5f 54 41 52 47 45 54 2f 24 4d 54 5f 52 55 4e T_TARGET/$MT_RUN
10030 4e 41 4d 45 2e 24 4d 54 5f 54 45 53 54 4e 41 4d NAME.$MT_TESTNAM
10040 45 2d 24 4d 54 5f 49 54 45 4d 5f 50 41 54 48 2e E-$MT_ITEM_PATH.
10050 6c 67 6f 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 6e lgo.;; .;; [laun
10060 63 68 65 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 74 chers].;; envset
10070 75 70 20 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 6f up general.;; xo
10080 72 2f 25 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 25 r/%/n 4C16G.;; %
10090 20 6e 62 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a 3b nbgeneral.;; .;
100a0 3b 20 5b 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b 20 ; [jobtools].;;
100b0 23 20 69 66 20 64 65 66 69 6e 65 64 20 61 6e 64 # if defined and
100c0 20 6e 6f 74 20 22 6e 6f 22 20 66 6c 65 78 69 2d not "no" flexi-
100d0 6c 61 75 6e 63 68 65 72 20 77 69 6c 6c 20 62 79 launcher will by
100e0 70 61 73 73 20 22 6c 61 75 6e 63 68 65 72 22 20 pass "launcher"
100f0 75 6e 6c 65 73 73 20 6e 6f 20 6d 61 74 63 68 2e unless no match.
10100 0a 3b 3b 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 .;; flexi-launch
10110 65 72 20 79 65 73 20 20 0a 3b 3b 20 6c 61 75 6e er yes .;; laun
10120 63 68 65 72 20 6e 62 66 61 6b 65 0a 3b 3b 0a 28 cher nbfake.;;.(
10130 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
10140 65 74 2d 6c 61 75 6e 63 68 65 72 20 63 6f 6e 66 et-launcher conf
10150 69 67 64 61 74 20 74 65 73 74 6e 61 6d 65 20 69 igdat testname i
10160 74 65 6d 70 61 74 68 29 0a 20 20 28 6c 65 74 20 tempath). (let
10170 28 28 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 ((fallback-launc
10180 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f her (configf:loo
10190 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a kup configdat "j
101a0 6f 62 74 6f 6f 6c 73 22 20 22 6c 61 75 6e 63 68 obtools" "launch
101b0 65 72 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 er"))). (if (
101c0 61 6e 64 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f and (configf:loo
101d0 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a kup configdat "j
101e0 6f 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d obtools" "flexi-
101f0 6c 61 75 6e 63 68 65 72 22 29 20 3b 3b 20 6f 76 launcher") ;; ov
10200 65 72 72 69 64 65 73 20 6c 61 75 6e 63 68 65 72 errides launcher
10210 0a 09 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 .. (not (equ
10220 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f al? (configf:loo
10230 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a kup configdat "j
10240 6f 62 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d obtools" "flexi-
10250 6c 61 75 6e 63 68 65 72 22 29 20 22 6e 6f 22 29 launcher") "no")
10260 29 29 0a 09 28 6c 65 74 2a 20 28 28 6c 61 75 6e ))..(let* ((laun
10270 63 68 65 72 73 20 20 20 20 20 20 20 20 20 28 68 chers (h
10280 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
10290 66 61 75 6c 74 20 63 6f 6e 66 69 67 64 61 74 20 fault configdat
102a0 22 6c 61 75 6e 63 68 65 72 73 22 20 27 28 29 29 "launchers" '())
102b0 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f )).. (if (null?
102c0 20 6c 61 75 6e 63 68 65 72 73 29 0a 09 20 20 20 launchers)..
102d0 20 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e fallback-laun
102e0 63 68 65 72 0a 09 20 20 20 20 20 20 28 6c 65 74 cher.. (let
102f0 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 loop ((hed (car
10300 20 6c 61 75 6e 63 68 65 72 73 29 29 0a 09 09 09 launchers))....
10310 20 28 74 61 6c 20 28 63 64 72 20 6c 61 75 6e 63 (tal (cdr launc
10320 68 65 72 73 29 29 29 0a 09 09 28 6c 65 74 20 28 hers)))...(let (
10330 28 70 61 74 74 20 20 20 20 20 20 28 63 61 72 20 (patt (car
10340 68 65 64 29 29 0a 09 09 20 20 20 20 20 20 28 68 hed))... (h
10350 6f 73 74 2d 74 79 70 65 20 28 63 61 64 72 20 68 ost-type (cadr h
10360 65 64 29 29 29 0a 09 09 20 20 28 69 66 20 28 74 ed)))... (if (t
10370 65 73 74 73 3a 6d 61 74 63 68 20 70 61 74 74 20 ests:match patt
10380 74 65 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 testname itempat
10390 68 29 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 h)... (begi
103a0 6e 0a 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e n....(debug:prin
103b0 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c t-info 2 *defaul
103c0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 48 61 76 t-log-port* "Hav
103d0 65 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 e flexi-launcher
103e0 20 6d 61 74 63 68 20 66 6f 72 20 22 20 74 65 73 match for " tes
103f0 74 6e 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 tname "/" itempa
10400 74 68 20 22 20 3d 20 22 20 68 6f 73 74 2d 74 79 th " = " host-ty
10410 70 65 29 0a 09 09 09 28 6c 65 74 20 28 28 6c 61 pe)....(let ((la
10420 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 66 3a uncher (configf:
10430 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 lookup configdat
10440 20 22 68 6f 73 74 2d 74 79 70 65 73 22 20 68 6f "host-types" ho
10450 73 74 2d 74 79 70 65 29 29 29 0a 09 09 09 20 20 st-type)))....
10460 28 69 66 20 6c 61 75 6e 63 68 65 72 0a 09 09 09 (if launcher....
10470 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 61 (let* ((la
10480 75 6e 63 68 65 72 2d 70 61 72 74 73 20 28 73 74 uncher-parts (st
10490 72 69 6e 67 2d 73 70 6c 69 74 20 6c 61 75 6e 63 ring-split launc
104a0 68 65 72 29 29 0a 09 09 09 09 20 20 20 20 20 28 her))..... (
104b0 6c 61 75 6e 63 68 65 72 2d 65 78 65 20 20 20 28 launcher-exe (
104c0 63 61 72 20 6c 61 75 6e 63 68 65 72 2d 70 61 72 car launcher-par
104d0 74 73 29 29 29 0a 09 09 09 09 28 69 66 20 28 65 ts))).....(if (e
104e0 71 75 61 6c 3f 20 6c 61 75 6e 63 68 65 72 2d 65 qual? launcher-e
104f0 78 65 20 22 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 xe "#MTLOWESTLOA
10500 44 22 29 20 3b 3b 20 74 68 69 73 20 69 73 20 6f D") ;; this is o
10510 75 72 20 73 70 65 63 69 61 6c 20 63 61 73 65 2c ur special case,
10520 20 77 65 20 77 69 6c 6c 20 66 69 6e 64 20 74 68 we will find th
10530 65 20 6c 6f 77 65 73 74 20 6c 6f 61 64 20 61 6e e lowest load an
10540 64 20 63 72 61 66 74 20 61 20 6e 62 66 61 6b 65 d craft a nbfake
10550 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 0a 09 09 09 commandline....
10560 09 20 20 20 20 28 6c 65 74 20 28 28 74 61 72 67 . (let ((targ
10570 2d 68 6f 73 74 20 28 63 6f 6d 6d 6f 6e 3a 67 65 -host (common:ge
10580 74 2d 6c 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 t-least-loaded-h
10590 6f 73 74 20 28 63 64 72 20 6c 61 75 6e 63 68 65 ost (cdr launche
105a0 72 2d 70 61 72 74 73 29 29 29 29 0a 09 09 09 09 r-parts)))).....
105b0 20 20 20 20 20 20 28 63 6f 6e 63 20 22 72 65 6d (conc "rem
105c0 72 75 6e 20 22 20 74 61 72 67 2d 68 6f 73 74 29 run " targ-host)
105d0 29 0a 09 09 09 09 20 20 20 20 6c 61 75 6e 63 68 )..... launch
105e0 65 72 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 er)).... (b
105f0 65 67 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a egin.....(debug:
10600 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
10610 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
10620 22 57 41 52 4e 49 4e 47 3a 20 6e 6f 20 6c 61 75 "WARNING: no lau
10630 6e 63 68 65 72 20 66 6f 75 6e 64 20 66 6f 72 20 ncher found for
10640 68 6f 73 74 2d 74 79 70 65 20 22 20 68 6f 73 74 host-type " host
10650 2d 74 79 70 65 29 0a 09 09 09 09 28 69 66 20 28 -type).....(if (
10660 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 null? tal).....
10670 20 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e fallback-laun
10680 63 68 65 72 0a 09 09 09 09 20 20 20 20 28 6c 6f cher..... (lo
10690 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
106a0 20 74 61 6c 29 29 29 29 29 29 29 0a 09 09 20 20 tal)))))))...
106b0 20 20 20 20 3b 3b 20 6e 6f 20 6d 61 74 63 68 2c ;; no match,
106c0 20 74 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 try again...
106d0 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
106e0 6c 29 0a 09 09 09 20 20 66 61 6c 6c 62 61 63 6b l).... fallback
106f0 2d 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 28 -launcher.... (
10700 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
10710 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a 09 dr tal))))))))..
10720 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 fallback-launche
10730 72 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d r))). .;;======
10740 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10750 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10760 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10770 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10780 0a 3b 3b 20 44 20 41 20 53 20 48 20 42 20 4f 20 .;; D A S H B O
10790 41 20 52 20 44 20 20 20 55 20 53 20 45 20 52 20 A R D U S E R
107a0 20 20 56 20 49 20 45 20 57 20 53 0a 3b 3b 3d 3d V I E W S.;;==
107b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107f0 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 72 73 74 20 72 ====..;; first r
10800 65 61 64 20 7e 2f 76 69 65 77 73 2e 63 6f 6e 66 ead ~/views.conf
10810 69 67 20 69 66 20 69 74 20 65 78 69 73 74 73 2c ig if it exists,
10820 20 74 68 65 6e 20 72 65 61 64 20 24 4d 54 52 41 then read $MTRA
10830 48 2f 76 69 65 77 73 2e 63 6f 6e 66 69 67 20 69 H/views.config i
10840 66 20 69 74 20 65 78 69 73 74 73 0a 3b 3b 0a 28 f it exists.;;.(
10850 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c define (common:l
10860 6f 61 64 2d 76 69 65 77 73 2d 63 6f 6e 66 69 67 oad-views-config
10870 29 0a 20 20 28 6c 65 74 2a 20 28 28 76 69 65 77 ). (let* ((view
10880 2d 63 66 67 64 61 74 20 20 20 20 28 6d 61 6b 65 -cfgdat (make
10890 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 -hash-table))..
108a0 28 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 20 20 (home-cfgfile
108b0 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 (conc (get-envir
108c0 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
108d0 22 48 4f 4d 45 22 29 20 22 2f 2e 6d 74 76 69 65 "HOME") "/.mtvie
108e0 77 73 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 ws.config")).. (
108f0 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 28 mthome-cfgfile (
10900 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
10910 2f 2e 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 /.mtviews.config
10920 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 66 69 "))). (if (fi
10930 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 68 6f 6d le-exists? mthom
10940 65 2d 63 66 67 66 69 6c 65 29 0a 09 28 72 65 61 e-cfgfile)..(rea
10950 64 2d 63 6f 6e 66 69 67 20 6d 74 68 6f 6d 65 2d d-config mthome-
10960 63 66 67 66 69 6c 65 20 76 69 65 77 2d 63 66 67 cfgfile view-cfg
10970 64 61 74 20 23 74 29 29 0a 20 20 20 20 3b 3b 20 dat #t)). ;;
10980 77 65 20 6c 6f 61 64 20 74 68 65 20 68 6f 6d 65 we load the home
10990 20 64 69 72 20 66 69 6c 65 20 41 46 54 45 52 20 dir file AFTER
109a0 74 68 65 20 4d 54 52 41 48 20 66 69 6c 65 20 73 the MTRAH file s
109b0 6f 20 74 68 65 20 75 73 65 72 20 63 61 6e 20 63 o the user can c
109c0 6c 6f 62 62 65 72 20 73 65 74 74 69 6e 67 73 20 lobber settings
109d0 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 74 68 65 when running the
109e0 20 64 61 73 68 62 6f 61 72 64 20 69 6e 20 72 65 dashboard in re
109f0 61 64 2d 6f 6e 6c 79 20 61 72 65 61 73 0a 20 20 ad-only areas.
10a00 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
10a10 74 73 3f 20 68 6f 6d 65 2d 63 66 67 66 69 6c 65 ts? home-cfgfile
10a20 29 0a 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 )..(read-config
10a30 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 65 home-cfgfile vie
10a40 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 20 w-cfgdat #t)).
10a50 20 20 76 69 65 77 2d 63 66 67 64 61 74 29 29 0a view-cfgdat)).
10a60 0a .