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: 23 66 29 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 #f). (last-serv
1760: 65 72 2d 63 68 65 63 6b 20 30 29 20 20 3b 3b 20 er-check 0) ;;
1770: 6c 61 73 74 20 74 69 6d 65 20 77 65 20 63 68 65 last time we che
1780: 63 6b 65 64 20 74 6f 20 73 65 65 20 69 66 20 74 cked to see if t
1790: 68 65 20 73 65 72 76 65 72 20 77 61 73 20 61 6c he server was al
17a0: 69 76 65 0a 20 20 28 63 6f 6e 6e 64 61 74 20 20 ive. (conndat
17b0: 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 #f). (
17c0: 74 72 61 6e 73 70 6f 72 74 20 20 20 20 20 20 20 transport
17d0: 20 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 *transport-typ
17e0: 65 2a 29 0a 20 20 28 73 65 72 76 65 72 2d 74 69 e*). (server-ti
17f0: 6d 65 6f 75 74 20 20 20 20 28 6f 72 20 28 73 65 meout (or (se
1800: 72 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 rver:get-timeout
1810: 29 20 31 30 30 29 29 29 20 3b 3b 20 64 65 66 61 ) 100))) ;; defa
1820: 75 6c 74 20 74 6f 20 31 30 30 20 73 65 63 6f 6e ult to 100 secon
1830: 64 73 0a 0a 3b 3b 20 6c 61 75 6e 63 68 69 6e 67 ds..;; launching
1840: 20 61 6e 64 20 68 6f 73 74 73 0a 28 64 65 66 73 and hosts.(defs
1850: 74 72 75 63 74 20 68 6f 73 74 0a 20 20 28 72 65 truct host. (re
1860: 61 63 68 61 62 6c 65 20 20 20 20 23 66 29 0a 20 achable #f).
1870: 20 28 6c 61 73 74 2d 75 70 64 61 74 65 20 20 30 (last-update 0
1880: 29 0a 20 20 28 6c 61 73 74 2d 75 73 65 64 20 20 ). (last-used
1890: 20 20 30 29 0a 20 20 28 6c 61 73 74 2d 63 70 75 0). (last-cpu
18a0: 6c 6f 61 64 20 31 29 29 0a 0a 28 64 65 66 69 6e load 1))..(defin
18b0: 65 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 20 e *host-loads*
18c0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
18d0: 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 h-table))..;; ca
18e0: 63 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 che environment
18f0: 76 61 72 73 20 66 6f 72 20 65 61 63 68 20 72 75 vars for each ru
1900: 6e 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a n here.(define *
1910: 65 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d env-vars-by-run-
1920: 69 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 id* (make-hash-t
1930: 61 62 6c 65 29 29 0a 0a 3b 3b 20 54 65 73 74 63 able))..;; Testc
1940: 6f 6e 66 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e onfig and runcon
1950: 66 69 67 20 63 61 63 68 65 73 2e 20 0a 28 64 65 fig caches. .(de
1960: 66 69 6e 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 fine *testconfig
1970: 73 2a 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d s* (make-
1980: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1990: 74 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 test-name => tes
19a0: 74 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 tconfig.(define
19b0: 2a 72 75 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 *runconfigs*
19c0: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
19d0: 74 61 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 table)) ;; targe
19e0: 74 20 20 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 t => runconfi
19f0: 67 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 g..;; This is a
1a00: 63 61 63 68 65 20 6f 66 20 70 72 65 2d 72 65 71 cache of pre-req
1a10: 73 20 6d 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d s met, don't re-
1a20: 63 61 6c 63 20 69 6e 20 63 61 73 65 73 20 77 68 calc in cases wh
1a30: 65 72 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 ere called with
1a40: 73 61 6d 65 20 70 61 72 61 6d 73 20 6c 65 73 73 same params less
1a50: 20 74 68 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 than.;; five se
1a60: 63 6f 6e 64 73 20 61 67 6f 0a 28 64 65 66 69 6e conds ago.(defin
1a70: 65 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d e *pre-reqs-met-
1a80: 63 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 cache* (make-has
1a90: 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 h-table))..;; ca
1aa0: 63 68 65 20 6f 66 20 76 65 72 62 6f 73 69 74 79 che of verbosity
1ab0: 20 67 69 76 65 6e 20 73 74 72 69 6e 67 0a 3b 3b given string.;;
1ac0: 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 .(define *verbos
1ad0: 69 74 79 2d 63 61 63 68 65 2a 20 20 20 20 28 6d ity-cache* (m
1ae0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1af0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
1b00: 6e 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 0a n:clear-caches).
1b10: 20 20 28 73 65 74 21 20 2a 74 61 72 67 65 74 2a (set! *target*
1b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma
1b30: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1b40: 20 20 28 73 65 74 21 20 2a 6b 65 79 73 2a 20 20 (set! *keys*
1b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 (ma
1b60: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1b70: 20 20 28 73 65 74 21 20 2a 6b 65 79 76 61 6c 73 (set! *keyvals
1b80: 2a 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 * (ma
1b90: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1ba0: 20 20 28 73 65 74 21 20 2a 74 6f 70 74 65 73 74 (set! *toptest
1bb0: 2d 70 61 74 68 73 2a 20 20 20 20 20 20 28 6d 61 -paths* (ma
1bc0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1bd0: 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 70 61 (set! *test-pa
1be0: 74 68 73 2a 20 20 20 20 20 20 20 20 20 28 6d 61 ths* (ma
1bf0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1c00: 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 (set! *test-id
1c10: 73 2a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 s* (ma
1c20: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1c30: 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 6e (set! *test-in
1c40: 66 6f 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 fo* (ma
1c50: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1c60: 20 20 28 73 65 74 21 20 2a 72 75 6e 2d 69 6e 66 (set! *run-inf
1c70: 6f 2d 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 o-cache* (ma
1c80: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1c90: 20 20 28 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 (set! *env-var
1ca0: 73 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 s-by-run-id* (ma
1cb0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1cc0: 20 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 (set! *test-id
1cd0: 2d 63 61 63 68 65 2a 20 20 20 20 20 20 28 6d 61 -cache* (ma
1ce0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 ke-hash-table)))
1cf0: 0a 0a 3b 3b 20 47 65 6e 65 72 69 63 20 73 74 72 ..;; Generic str
1d00: 69 6e 67 20 64 61 74 61 62 61 73 65 0a 28 64 65 ing database.(de
1d10: 66 69 6e 65 20 73 64 62 3a 71 72 79 20 23 66 29 fine sdb:qry #f)
1d20: 20 3b 3b 20 28 6d 61 6b 65 2d 73 64 62 3a 71 72 ;; (make-sdb:qr
1d30: 79 29 29 20 3b 3b 20 20 27 69 6e 69 74 20 23 66 y)) ;; 'init #f
1d40: 29 0a 3b 3b 20 47 65 6e 65 72 69 63 20 70 61 74 ).;; Generic pat
1d50: 68 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 h database.(defi
1d60: 6e 65 20 2a 66 64 62 2a 20 23 66 29 0a 0a 28 64 ne *fdb* #f)..(d
1d70: 65 66 69 6e 65 20 2a 6c 61 73 74 2d 6c 61 75 6e efine *last-laun
1d80: 63 68 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ch* (current-sec
1d90: 6f 6e 64 73 29 29 20 3b 3b 20 75 73 65 20 66 6f onds)) ;; use fo
1da0: 72 20 74 68 72 6f 74 74 6c 69 6e 67 20 74 68 65 r throttling the
1db0: 20 6c 61 75 6e 63 68 20 72 61 74 65 2e 20 57 6f launch rate. Wo
1dc0: 75 6c 64 20 62 65 20 62 65 74 74 65 72 20 74 6f uld be better to
1dd0: 20 75 73 65 20 74 68 65 20 64 62 20 61 6e 64 20 use the db and
1de0: 6c 61 73 74 20 74 69 6d 65 20 6f 66 20 61 20 74 last time of a t
1df0: 65 73 74 20 69 6e 20 4c 41 55 4e 43 48 45 44 20 est in LAUNCHED
1e00: 73 74 61 74 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d state...;;======
1e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1e50: 0a 3b 3b 20 56 20 45 20 52 20 53 20 49 20 4f 20 .;; V E R S I O
1e60: 4e 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d N.;;============
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 0a 0a 28 64 65 66 ==========..(def
1eb0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
1ec0: 66 75 6c 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 full-version).
1ed0: 28 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 (conc megatest-v
1ee0: 65 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 ersion "-" megat
1ef0: 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 est-fossil-hash)
1f00: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
1f10: 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 on:version-signa
1f20: 74 75 72 65 29 0a 20 20 28 63 6f 6e 63 20 6d 65 ture). (conc me
1f30: 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 gatest-version "
1f40: 2d 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d 65 -" (substring me
1f50: 67 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 gatest-fossil-ha
1f60: 73 68 20 30 20 34 29 29 29 0a 0a 3b 3b 20 66 72 sh 0 4)))..;; fr
1f70: 6f 6d 20 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 om metadat looku
1f80: 70 20 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 p MEGATEST_VERSI
1f90: 4f 4e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ON.;;.(define (c
1fa0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 ommon:get-last-r
1fb0: 75 6e 2d 76 65 72 73 69 6f 6e 20 61 72 65 61 2d un-version area-
1fc0: 64 61 74 29 20 3b 3b 20 52 41 44 54 20 3d 3e 20 dat) ;; RADT =>
1fd0: 48 6f 77 20 64 6f 65 73 20 74 68 69 73 20 77 6f How does this wo
1fe0: 72 6b 20 69 6e 20 73 65 6e 64 2d 72 65 63 65 69 rk in send-recei
1ff0: 76 65 20 66 75 6e 63 74 69 6f 6e 3f 3f 3b 20 61 ve function??; a
2000: 73 73 75 6d 65 20 69 74 20 69 73 20 74 68 65 20 ssume it is the
2010: 76 61 6c 75 65 20 73 61 76 65 64 20 69 6e 20 73 value saved in s
2020: 6f 6d 65 20 44 42 0a 20 20 28 72 6d 74 3a 67 65 ome DB. (rmt:ge
2030: 74 2d 76 61 72 20 61 72 65 61 2d 64 61 74 20 22 t-var area-dat "
2040: 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e MEGATEST_VERSION
2050: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f "))..(define (co
2060: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
2070: 6e 2d 76 65 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 n-version-number
2080: 29 0a 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ). (string->num
2090: 62 65 72 20 0a 20 20 20 28 73 75 62 73 74 72 69 ber . (substri
20a0: 6e 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c ng (common:get-l
20b0: 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 ast-run-version)
20c0: 20 30 20 36 29 29 29 0a 0a 28 64 65 66 69 6e 65 0 6)))..(define
20d0: 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 (common:set-las
20e0: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 20 61 72 t-run-version ar
20f0: 65 61 2d 64 61 74 29 0a 20 20 28 72 6d 74 3a 73 ea-dat). (rmt:s
2100: 65 74 2d 76 61 72 20 61 72 65 61 2d 64 61 74 20 et-var area-dat
2110: 22 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f "MEGATEST_VERSIO
2120: 4e 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 N" (common:versi
2130: 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 29 0a on-signature))).
2140: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
2150: 3a 76 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 :version-changed
2160: 3f 29 0a 20 20 28 6e 6f 74 20 28 65 71 75 61 6c ?). (not (equal
2170: 3f 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 ? (common:get-la
2180: 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 0a st-run-version).
2190: 09 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a . (common:
21a0: 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 version-signatur
21b0: 65 29 29 29 29 0a 0a 3b 3b 20 4d 6f 76 65 20 6d e))))..;; Move m
21c0: 65 20 65 6c 73 65 77 68 65 72 65 20 2e 2e 2e 0a e elsewhere ....
21d0: 3b 3b 20 52 41 44 54 20 3d 3e 20 57 68 79 20 64 ;; RADT => Why d
21e0: 6f 20 77 65 20 6d 65 65 64 20 74 68 65 20 76 65 o we meed the ve
21f0: 72 73 69 6f 6e 20 63 68 65 63 6b 20 68 65 72 65 rsion check here
2200: 2c 20 74 68 69 73 20 69 73 20 63 61 6c 6c 65 64 , this is called
2210: 20 6f 6e 6c 79 20 69 66 20 76 65 72 73 69 6f 6e only if version
2220: 20 6d 69 73 6d 61 0a 3b 3b 0a 28 64 65 66 69 6e misma.;;.(defin
2230: 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 e (common:cleanu
2240: 70 2d 64 62 20 64 62 73 74 72 75 63 74 29 0a 20 p-db dbstruct).
2250: 20 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 (db:multi-db-sy
2260: 6e 63 20 0a 20 20 20 64 62 73 74 72 75 63 74 0a nc . dbstruct.
2270: 20 20 20 3b 3b 20 27 6e 65 77 32 6f 6c 64 0a 20 ;; 'new2old.
2280: 20 20 27 6b 69 6c 6c 73 65 72 76 65 72 73 0a 20 'killservers.
2290: 20 20 27 64 65 6a 75 6e 6b 0a 20 20 20 3b 3b 20 'dejunk. ;;
22a0: 27 61 64 6a 2d 74 65 73 74 69 64 73 0a 20 20 20 'adj-testids.
22b0: 3b 3b 20 27 6f 6c 64 32 6e 65 77 0a 20 20 20 27 ;; 'old2new. '
22c0: 6e 65 77 32 6f 6c 64 0a 20 20 20 27 73 63 68 65 new2old. 'sche
22d0: 6d 61 29 0a 20 20 28 69 66 20 28 63 6f 6d 6d 6f ma). (if (commo
22e0: 6e 3a 76 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 n:version-change
22f0: 64 3f 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f d?). (commo
2300: 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:set-last-run-v
2310: 65 72 73 69 6f 6e 29 29 29 0a 0a 3b 3b 20 52 6f ersion)))..;; Ro
2320: 74 61 74 65 20 6c 6f 67 73 2c 20 6c 6f 67 69 63 tate logs, logic
2330: 3a 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 : .;;
2340: 20 20 20 20 20 20 69 66 20 3e 20 35 30 30 6b 20 if > 500k
2350: 61 6e 64 20 6f 6c 64 65 72 20 74 68 61 6e 20 31 and older than 1
2360: 20 77 65 65 6b 3a 0a 3b 3b 20 20 20 20 20 20 20 week:.;;
2370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 re
2380: 6d 6f 76 65 20 70 72 65 76 69 6f 75 73 20 63 6f move previous co
2390: 6d 70 72 65 73 73 65 64 20 6c 6f 67 20 61 6e 64 mpressed log and
23a0: 20 63 6f 6d 70 72 65 73 73 20 74 68 69 73 20 6c compress this l
23b0: 6f 67 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 54 og.;; WARNING: T
23c0: 68 69 73 20 70 72 6f 63 20 6f 70 65 72 61 74 65 his proc operate
23d0: 73 20 61 73 73 75 6d 69 6e 67 20 74 68 61 74 20 s assuming that
23e0: 69 74 20 69 73 20 69 6e 20 74 68 65 20 64 69 72 it is in the dir
23f0: 65 63 74 6f 72 79 20 61 62 6f 76 65 20 74 68 65 ectory above the
2400: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 6c 6f 67 .;; log
2410: 73 20 64 69 72 65 63 74 6f 72 79 20 79 6f 75 20 s directory you
2420: 77 69 73 68 20 74 6f 20 6c 6f 67 2d 72 6f 74 61 wish to log-rota
2430: 74 65 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 te..;;.(define (
2440: 63 6f 6d 6d 6f 6e 3a 72 6f 74 61 74 65 2d 6c 6f common:rotate-lo
2450: 67 73 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 gs). (if (not (
2460: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
2470: 3f 20 22 6c 6f 67 73 22 29 29 28 63 72 65 61 74 ? "logs"))(creat
2480: 65 2d 64 69 72 65 63 74 6f 72 79 20 22 6c 6f 67 e-directory "log
2490: 73 22 29 29 0a 20 20 28 64 69 72 65 63 74 6f 72 s")). (director
24a0: 79 2d 66 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 y-fold . (lamb
24b0: 64 61 20 28 66 69 6c 65 20 72 65 6d 29 0a 20 20 da (file rem).
24c0: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
24d0: 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a tions. exn.
24e0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
24f0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
2500: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 lt-log-port* "fa
2510: 69 6c 65 64 20 74 6f 20 72 6f 74 61 74 65 20 6c iled to rotate l
2520: 6f 67 20 22 20 66 69 6c 65 20 22 2c 20 70 72 6f og " file ", pro
2530: 62 61 62 6c 79 20 68 61 6e 64 6c 65 64 20 62 79 bably handled by
2540: 20 61 6e 6f 74 68 65 72 20 70 72 6f 63 65 73 73 another process
2550: 2e 22 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 ."). (let*
2560: 28 28 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 ((fullname (conc
2570: 20 22 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 0a "logs/" file)).
2580: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 69 (fi
2590: 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 72 72 65 le-age (- (curre
25a0: 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 nt-seconds)(file
25b0: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
25c0: 6d 65 20 66 75 6c 6c 6e 61 6d 65 29 29 29 29 0a me fullname)))).
25d0: 20 20 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 (if (or
25e0: 28 61 6e 64 20 28 73 74 72 69 6e 67 2d 6d 61 74 (and (string-mat
25f0: 63 68 20 22 5e 2e 2a 2e 6c 6f 67 22 20 66 69 6c ch "^.*.log" fil
2600: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
2610: 20 20 20 20 20 20 20 20 28 3e 20 28 66 69 6c 65 (> (file
2620: 2d 73 69 7a 65 20 66 75 6c 6c 6e 61 6d 65 29 20 -size fullname)
2630: 32 30 30 30 30 30 29 29 0a 20 20 20 20 20 20 20 200000)).
2640: 20 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 73 (and (s
2650: 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 73 65 tring-match "^se
2660: 72 76 65 72 2d 2e 2a 2e 6c 6f 67 22 20 66 69 6c rver-.*.log" fil
2670: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
2680: 20 20 20 20 20 20 20 20 28 3e 20 28 2d 20 28 63 (> (- (c
2690: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
26a0: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
26b0: 6f 6e 2d 74 69 6d 65 20 66 75 6c 6c 6e 61 6d 65 on-time fullname
26c0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
26d0: 20 20 20 20 20 20 20 20 20 20 20 28 2a 20 38 20 (* 8
26e0: 36 30 20 36 30 29 29 29 29 0a 20 20 20 20 20 20 60 60)))).
26f0: 20 20 20 20 20 20 28 6c 65 74 20 28 28 67 7a 66 (let ((gzf
2700: 69 6c 65 20 28 63 6f 6e 63 20 66 75 6c 6c 6e 61 ile (conc fullna
2710: 6d 65 20 22 2e 67 7a 22 29 29 29 0a 20 20 20 20 me ".gz"))).
2720: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 66 (if (f
2730: 69 6c 65 2d 65 78 69 73 74 73 3f 20 67 7a 66 69 ile-exists? gzfi
2740: 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 le).
2750: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 (begin.
2760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2770: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2780: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
2790: 67 2d 70 6f 72 74 2a 20 22 72 65 6d 6f 76 69 6e g-port* "removin
27a0: 67 20 22 20 67 7a 66 69 6c 65 29 0a 20 20 20 20 g " gzfile).
27b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27c0: 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 67 7a 66 (delete-file gzf
27d0: 69 6c 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 ile))).
27e0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
27f0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
2800: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d t-log-port* "com
2810: 70 72 65 73 73 69 6e 67 20 22 20 66 69 6c 65 29 pressing " file)
2820: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
2830: 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 67 7a system (conc "gz
2840: 69 70 20 22 20 66 75 6c 6c 6e 61 6d 65 29 29 29 ip " fullname)))
2850: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 . (if
2860: 20 28 3e 20 66 69 6c 65 2d 61 67 65 20 28 2a 20 (> file-age (*
2870: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
2880: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
2890: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
28a0: 22 73 65 74 75 70 22 20 22 6c 6f 67 2d 65 78 70 "setup" "log-exp
28b0: 69 72 65 2d 64 61 79 73 22 29 20 22 33 30 22 29 ire-days") "30")
28c0: 29 20 32 34 20 33 36 30 30 29 29 0a 20 20 20 20 ) 24 3600)).
28d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 6e (han
28e0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
28f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2900: 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 exn.
2910: 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 20 #f.
2920: 20 20 20 20 20 20 20 20 20 28 64 65 6c 65 74 65 (delete
2930: 2d 66 69 6c 65 20 66 75 6c 6c 6e 61 6d 65 29 29 -file fullname))
2940: 29 29 29 29 29 0a 20 20 20 27 28 29 0a 20 20 20 ))))). '().
2950: 22 6c 6f 67 73 22 29 29 0a 0a 3b 3b 20 46 6f 72 "logs"))..;; For
2960: 63 65 20 61 20 6d 65 67 61 74 65 73 74 20 63 6c ce a megatest cl
2970: 65 61 6e 75 70 2d 64 62 20 69 66 20 76 65 72 73 eanup-db if vers
2980: 69 6f 6e 20 69 73 20 63 68 61 6e 67 65 64 20 61 ion is changed a
2990: 6e 64 20 73 6b 69 70 2d 76 65 72 73 69 6f 6e 2d nd skip-version-
29a0: 63 68 65 63 6b 20 6e 6f 74 20 73 70 65 63 69 66 check not specif
29b0: 69 65 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ied.;;.(define (
29c0: 63 6f 6d 6d 6f 6e 3a 65 78 69 74 2d 6f 6e 2d 76 common:exit-on-v
29d0: 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 29 0a ersion-changed).
29e0: 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 (if (common:ve
29f0: 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a rsion-changed?).
2a00: 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f (if (commo
2a10: 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a n:on-homehost?).
2a20: 09 20 20 28 6c 65 74 20 28 28 6d 74 63 6f 6e 66 . (let ((mtconf
2a30: 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 (conc (get-envi
2a40: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
2a50: 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f "MT_RUN_AREA_HO
2a60: 4d 45 22 29 20 22 2f 6d 65 67 61 74 65 73 74 2e ME") "/megatest.
2a70: 63 6f 6e 66 69 67 22 29 29 0a 09 09 28 64 62 73 config"))...(dbs
2a80: 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 29 truct (db:setup)
2a90: 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 )).. (debug:p
2aa0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2ab0: 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 20 22 57 log-port*.... "W
2ac0: 41 52 4e 49 4e 47 3a 20 56 65 72 73 69 6f 6e 20 ARNING: Version
2ad0: 6d 69 73 6d 61 74 63 68 21 5c 6e 22 0a 09 09 09 mismatch!\n"....
2ae0: 20 22 20 20 20 65 78 70 65 63 74 65 64 3a 20 22 " expected: "
2af0: 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e (common:version
2b00: 2d 73 69 67 6e 61 74 75 72 65 29 20 22 5c 6e 22 -signature) "\n"
2b10: 0a 09 09 09 20 22 20 20 20 67 6f 74 3a 20 20 20 .... " got:
2b20: 20 20 20 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 " (common:get
2b30: 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f -last-run-versio
2b40: 6e 29 29 0a 09 20 20 20 20 28 69 66 20 28 61 6e n)).. (if (an
2b50: 64 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 d (file-exists?
2b60: 6d 74 63 6f 6e 66 29 0a 09 09 20 20 20 20 20 28 mtconf)... (
2b70: 65 71 3f 20 28 63 75 72 72 65 6e 74 2d 75 73 65 eq? (current-use
2b80: 72 2d 69 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 r-id)(file-owner
2b90: 20 6d 74 63 6f 6e 66 29 29 29 20 3b 3b 20 73 61 mtconf))) ;; sa
2ba0: 66 65 20 74 6f 20 72 75 6e 20 2d 63 6c 65 61 6e fe to run -clean
2bb0: 75 70 2d 64 62 0a 09 09 28 62 65 67 69 6e 0a 09 up-db...(begin..
2bc0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
2bd0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2be0: 6f 72 74 2a 20 22 20 20 20 49 20 73 65 65 20 79 ort* " I see y
2bf0: 6f 75 20 61 72 65 20 74 68 65 20 6f 77 6e 65 72 ou are the owner
2c00: 20 6f 66 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e of megatest.con
2c10: 66 69 67 2c 20 61 74 74 65 6d 70 74 69 6e 67 20 fig, attempting
2c20: 74 6f 20 63 6c 65 61 6e 75 70 20 61 6e 64 20 72 to cleanup and r
2c30: 65 73 65 74 20 74 6f 20 6e 65 77 20 76 65 72 73 eset to new vers
2c40: 69 6f 6e 22 29 0a 09 09 20 20 28 68 61 6e 64 6c ion")... (handl
2c50: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 20 e-exceptions...
2c60: 20 20 65 78 6e 0a 09 09 20 20 20 28 62 65 67 69 exn... (begi
2c70: 6e 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 3a n... (debug:
2c80: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
2c90: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 6c -log-port* "Fail
2ca0: 65 64 20 74 6f 20 73 77 69 74 63 68 20 76 65 72 ed to switch ver
2cb0: 73 69 6f 6e 73 2e 22 29 0a 09 09 20 20 20 20 20 sions.")...
2cc0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
2cd0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
2ce0: 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 * " message: " (
2cf0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
2d00: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
2d10: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
2d20: 29 0a 09 09 20 20 20 20 20 28 70 72 69 6e 74 2d )... (print-
2d30: 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 call-chain (curr
2d40: 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 ent-error-port))
2d50: 0a 09 09 20 20 20 20 20 28 65 78 69 74 20 31 29 ... (exit 1)
2d60: 29 0a 09 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 )... (common:c
2d70: 6c 65 61 6e 75 70 2d 64 62 20 64 62 73 74 72 75 leanup-db dbstru
2d80: 63 74 29 29 29 0a 09 09 28 62 65 67 69 6e 0a 09 ct)))...(begin..
2d90: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 . (debug:print
2da0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2db0: 6f 72 74 2a 20 22 20 74 6f 20 73 77 69 74 63 68 ort* " to switch
2dc0: 20 76 65 72 73 69 6f 6e 73 20 79 6f 75 20 63 61 versions you ca
2dd0: 6e 20 72 75 6e 3a 20 5c 22 6d 65 67 61 74 65 73 n run: \"megates
2de0: 74 20 2d 63 6c 65 61 6e 75 70 2d 64 62 5c 22 22 t -cleanup-db\""
2df0: 29 0a 09 09 20 20 28 65 78 69 74 20 31 29 29 29 )... (exit 1)))
2e00: 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
2e10: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
2e20: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2e30: 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f t* "ERROR: canno
2e40: 74 20 6d 69 67 72 61 74 65 20 76 65 72 73 69 6f t migrate versio
2e50: 6e 20 75 6e 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 n unless on home
2e60: 68 6f 73 74 2e 20 45 78 69 74 69 6e 67 2e 22 29 host. Exiting.")
2e70: 0a 09 20 20 20 20 28 65 78 69 74 20 31 29 29 29 .. (exit 1)))
2e80: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
2e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
2ed0: 53 20 50 20 41 20 52 20 53 20 45 20 20 20 41 20 S P A R S E A
2ee0: 52 20 52 20 41 20 59 20 53 0a 3b 3b 3d 3d 3d 3d R R A Y S.;;====
2ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2f30: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b ==..(define (mak
2f40: 65 2d 73 70 61 72 73 65 2d 61 72 72 61 79 29 0a e-sparse-array).
2f50: 20 20 28 6c 65 74 20 28 28 61 20 28 6d 61 6b 65 (let ((a (make
2f60: 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 -sparse-vector))
2f70: 29 0a 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 ). (sparse-ve
2f80: 63 74 6f 72 2d 73 65 74 21 20 61 20 30 20 28 6d ctor-set! a 0 (m
2f90: 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f ake-sparse-vecto
2fa0: 72 29 29 0a 20 20 20 20 61 29 29 0a 0a 28 64 65 r)). a))..(de
2fb0: 66 69 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 fine (sparse-arr
2fc0: 61 79 3f 20 61 29 0a 20 20 28 61 6e 64 20 28 73 ay? a). (and (s
2fd0: 70 61 72 73 65 2d 76 65 63 74 6f 72 3f 20 61 29 parse-vector? a)
2fe0: 0a 20 20 20 20 20 20 20 28 73 70 61 72 73 65 2d . (sparse-
2ff0: 76 65 63 74 6f 72 3f 20 28 73 70 61 72 73 65 2d vector? (sparse-
3000: 76 65 63 74 6f 72 2d 72 65 66 20 61 20 30 29 29 vector-ref a 0))
3010: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 61 ))..(define (spa
3020: 72 73 65 2d 61 72 72 61 79 2d 72 65 66 20 61 20 rse-array-ref a
3030: 78 20 79 29 0a 20 20 28 6c 65 74 20 28 28 72 6f x y). (let ((ro
3040: 77 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 w (sparse-vector
3050: 2d 72 65 66 20 61 20 78 29 29 29 0a 20 20 20 20 -ref a x))).
3060: 28 69 66 20 72 6f 77 0a 09 28 73 70 61 72 73 65 (if row..(sparse
3070: 2d 76 65 63 74 6f 72 2d 72 65 66 20 72 6f 77 20 -vector-ref row
3080: 79 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 y)..#f)))..(defi
3090: 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 ne (sparse-array
30a0: 2d 73 65 74 21 20 61 20 78 20 79 20 76 61 6c 29 -set! a x y val)
30b0: 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 . (let ((row (s
30c0: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 parse-vector-ref
30d0: 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 a x))). (if
30e0: 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 row..(sparse-vec
30f0: 74 6f 72 2d 73 65 74 21 20 72 6f 77 20 79 20 76 tor-set! row y v
3100: 61 6c 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 2d al)..(let ((new-
3110: 72 6f 77 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 row (make-sparse
3120: 2d 76 65 63 74 6f 72 29 29 29 0a 09 20 20 28 73 -vector))).. (s
3130: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 parse-vector-set
3140: 21 20 61 20 78 20 6e 65 77 2d 72 6f 77 29 0a 09 ! a x new-row)..
3150: 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 (sparse-vector
3160: 2d 73 65 74 21 20 6e 65 77 2d 72 6f 77 20 79 20 -set! new-row y
3170: 76 61 6c 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d val)))))..;;====
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
31c0: 3d 3d 0a 3b 3b 20 4c 20 4f 20 43 20 4b 20 45 20 ==.;; L O C K E
31d0: 52 20 53 20 20 20 41 20 4e 20 44 20 20 20 42 20 R S A N D B
31e0: 4c 20 4f 20 43 20 4b 20 45 20 52 20 53 20 0a 3b L O C K E R S .;
31f0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3230: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 =======..;; bloc
3240: 6b 20 66 75 72 74 68 65 72 20 61 63 63 65 73 73 k further access
3250: 65 73 20 74 6f 20 64 61 74 61 62 61 73 65 73 2e es to databases.
3260: 20 43 61 6c 6c 20 74 68 69 73 20 62 65 66 6f 72 Call this befor
3270: 65 20 73 68 75 74 74 69 6e 67 20 64 62 20 64 6f e shutting db do
3280: 77 6e 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d wn.(define (comm
3290: 6f 6e 3a 64 62 2d 62 6c 6f 63 6b 2d 66 75 72 74 on:db-block-furt
32a0: 68 65 72 2d 71 75 65 72 69 65 73 29 0a 20 20 28 her-queries). (
32b0: 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d mutex-lock! *db-
32c0: 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a 20 access-mutex*).
32d0: 20 28 73 65 74 21 20 2a 64 62 2d 61 63 63 65 73 (set! *db-acces
32e0: 73 2d 61 6c 6c 6f 77 65 64 2a 20 23 66 29 0a 20 s-allowed* #f).
32f0: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
3300: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
3310: 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f *))..(define (co
3320: 6d 6d 6f 6e 3a 64 62 2d 61 63 63 65 73 73 2d 61 mmon:db-access-a
3330: 6c 6c 6f 77 65 64 3f 29 0a 20 20 28 6c 65 74 20 llowed?). (let
3340: 28 28 76 61 6c 20 28 62 65 67 69 6e 0a 09 20 20 ((val (begin..
3350: 20 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b (mutex-lock
3360: 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 ! *db-access-mut
3370: 65 78 2a 29 0a 09 20 20 20 20 20 20 20 2a 64 62 ex*).. *db
3380: 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 2a -access-allowed*
3390: 0a 09 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d .. (mutex-
33a0: 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 unlock! *db-acce
33b0: 73 73 2d 6d 75 74 65 78 2a 29 29 29 29 0a 20 20 ss-mutex*)))).
33c0: 20 20 76 61 6c 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d val))..;;=====
33d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
33f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3410: 3d 0a 3b 3b 20 55 20 53 20 45 20 46 20 55 20 4c =.;; U S E F U L
3420: 20 20 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d S T U F F.;;=
3430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3470: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 =====..;; conver
3480: 74 20 74 68 69 6e 67 73 20 74 6f 20 61 6e 20 61 t things to an a
3490: 6c 69 73 74 20 6f 72 20 61 73 73 6f 63 20 6c 69 list or assoc li
34a0: 73 74 2c 20 23 66 20 67 65 74 73 20 63 6f 6e 76 st, #f gets conv
34b0: 65 72 74 65 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 erted to "".;;.(
34c0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 define (common:t
34d0: 6f 2d 61 6c 69 73 74 20 64 61 74 29 0a 20 20 28 o-alist dat). (
34e0: 63 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 cond. ((list?
34f0: 64 61 74 29 20 20 20 28 6d 61 70 20 63 6f 6d 6d dat) (map comm
3500: 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 64 61 74 29 on:to-alist dat)
3510: 29 0a 20 20 20 28 28 76 65 63 74 6f 72 3f 20 64 ). ((vector? d
3520: 61 74 29 0a 20 20 20 20 28 6d 61 70 20 63 6f 6d at). (map com
3530: 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 76 65 mon:to-alist (ve
3540: 63 74 6f 72 2d 3e 6c 69 73 74 20 64 61 74 29 29 ctor->list dat))
3550: 29 0a 20 20 20 28 28 70 61 69 72 3f 20 64 61 74 ). ((pair? dat
3560: 29 0a 20 20 20 20 28 63 6f 6e 73 20 28 63 6f 6d ). (cons (com
3570: 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 61 mon:to-alist (ca
3580: 72 20 64 61 74 29 29 0a 09 20 20 28 63 6f 6d 6d r dat)).. (comm
3590: 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 64 72 on:to-alist (cdr
35a0: 20 64 61 74 29 29 29 29 0a 20 20 20 28 28 68 61 dat)))). ((ha
35b0: 73 68 2d 74 61 62 6c 65 3f 20 64 61 74 29 0a 20 sh-table? dat).
35c0: 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 (map common:t
35d0: 6f 2d 61 6c 69 73 74 20 28 68 61 73 68 2d 74 61 o-alist (hash-ta
35e0: 62 6c 65 2d 3e 61 6c 69 73 74 20 64 61 74 29 29 ble->alist dat))
35f0: 29 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 ). (else. (
3600: 69 66 20 64 61 74 0a 09 64 61 74 0a 09 22 22 29 if dat..dat.."")
3610: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
3620: 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 mmon:low-noise-p
3630: 72 69 6e 74 20 77 61 69 74 76 61 6c 20 2e 20 6b rint waitval . k
3640: 65 79 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b eys). (let* ((k
3650: 65 79 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d ey (string-
3660: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
3670: 20 63 6f 6e 63 20 6b 65 79 73 29 20 22 2d 22 20 conc keys) "-"
3680: 29 29 0a 09 20 28 6c 61 73 74 74 69 6d 65 20 28 )).. (lasttime (
3690: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
36a0: 65 66 61 75 6c 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 efault *common:d
36b0: 65 6e 6f 69 73 65 2a 20 6b 65 79 20 30 29 29 0a enoise* key 0)).
36c0: 09 20 28 63 75 72 72 74 69 6d 65 20 28 63 75 72 . (currtime (cur
36d0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
36e0: 20 20 20 20 28 69 66 20 28 3e 20 28 2d 20 63 75 (if (> (- cu
36f0: 72 72 74 69 6d 65 20 6c 61 73 74 74 69 6d 65 29 rrtime lasttime)
3700: 20 77 61 69 74 76 61 6c 29 0a 09 28 62 65 67 69 waitval)..(begi
3710: 6e 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 n.. (hash-table
3720: 2d 73 65 74 21 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 -set! *common:de
3730: 6e 6f 69 73 65 2a 20 6b 65 79 20 63 75 72 72 74 noise* key currt
3740: 69 6d 65 29 0a 09 20 20 23 74 29 0a 09 23 66 29 ime).. #t)..#f)
3750: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
3760: 6d 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 mon:get-megatest
3770: 2d 65 78 65 29 0a 20 20 28 6f 72 20 28 67 65 74 -exe). (or (get
3780: 65 6e 76 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 env "MT_MEGATEST
3790: 22 29 20 22 6d 65 67 61 74 65 73 74 22 29 29 0a ") "megatest")).
37a0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
37b0: 3a 72 65 61 64 2d 65 6e 63 6f 64 65 64 2d 73 74 :read-encoded-st
37c0: 72 69 6e 67 20 69 6e 73 74 72 29 0a 20 20 28 68 ring instr). (h
37d0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
37e0: 0a 20 20 20 65 78 6e 0a 20 20 20 28 68 61 6e 64 . exn. (hand
37f0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
3800: 20 20 65 78 6e 0a 20 20 20 20 28 62 65 67 69 6e exn. (begin
3810: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
3820: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
3830: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3840: 72 65 63 65 69 76 65 64 20 62 61 64 20 65 6e 63 received bad enc
3850: 6f 64 65 64 20 73 74 72 69 6e 67 20 5c 22 22 20 oded string \""
3860: 69 6e 73 74 72 20 22 5c 22 2c 20 6d 65 73 73 61 instr "\", messa
3870: 67 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f ge: " ((conditio
3880: 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 n-property-acces
3890: 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 sor 'exn 'messag
38a0: 65 29 20 65 78 6e 29 29 0a 20 20 20 20 20 20 28 e) exn)). (
38b0: 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e print-call-chain
38c0: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
38d0: 70 6f 72 74 29 29 0a 20 20 20 20 20 20 23 66 29 port)). #f)
38e0: 0a 20 20 20 20 28 72 65 61 64 20 28 6f 70 65 6e . (read (open
38f0: 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 28 62 -input-string (b
3900: 61 73 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 ase64:base64-dec
3910: 6f 64 65 20 69 6e 73 74 72 29 29 29 29 0a 20 20 ode instr)))).
3920: 20 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 (read (open-inp
3930: 75 74 2d 73 74 72 69 6e 67 20 28 7a 33 3a 64 65 ut-string (z3:de
3940: 63 6f 64 65 2d 62 75 66 66 65 72 20 28 62 61 73 code-buffer (bas
3950: 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 e64:base64-decod
3960: 65 20 69 6e 73 74 72 29 29 29 29 29 29 0a 0a 3b e instr))))))..;
3970: 3b 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 ; dot-locking eg
3980: 67 20 73 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 g seems not to w
3990: 6f 72 6b 2c 20 75 73 69 6e 67 20 74 68 69 73 20 ork, using this
39a0: 66 6f 72 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f for now.;; if lo
39b0: 63 6b 20 69 73 20 6f 6c 64 65 72 20 74 68 61 6e ck is older than
39c0: 20 65 78 70 69 72 65 2d 74 69 6d 65 20 74 68 65 expire-time the
39d0: 6e 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 n remove it and
39e0: 74 72 79 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 try again.;; to
39f0: 67 65 74 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a get the lock.;;.
3a00: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
3a10: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
3a20: 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 65 78 fname #!key (ex
3a30: 70 69 72 65 2d 74 69 6d 65 20 33 30 30 29 29 0a pire-time 300)).
3a40: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
3a50: 74 73 3f 20 66 6e 61 6d 65 29 0a 20 20 20 20 20 ts? fname).
3a60: 20 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 (if (> (- (curr
3a70: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c ent-seconds)(fil
3a80: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
3a90: 69 6d 65 20 66 6e 61 6d 65 29 29 20 65 78 70 69 ime fname)) expi
3aa0: 72 65 2d 74 69 6d 65 29 0a 09 20 20 28 62 65 67 re-time).. (beg
3ab0: 69 6e 0a 09 20 20 20 20 28 64 65 6c 65 74 65 2d in.. (delete-
3ac0: 66 69 6c 65 2a 20 66 6e 61 6d 65 29 0a 09 20 20 file* fname)..
3ad0: 20 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 (common:simple
3ae0: 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 -file-lock fname
3af0: 20 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 expire-time: ex
3b00: 70 69 72 65 2d 74 69 6d 65 29 29 0a 09 20 20 23 pire-time)).. #
3b10: 66 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 f). (let ((
3b20: 6b 65 79 2d 73 74 72 69 6e 67 20 28 63 6f 6e 63 key-string (conc
3b30: 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 (get-host-name)
3b40: 20 22 2d 22 20 28 63 75 72 72 65 6e 74 2d 70 72 "-" (current-pr
3b50: 6f 63 65 73 73 2d 69 64 29 29 29 29 0a 09 28 77 ocess-id))))..(w
3b60: 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 ith-output-to-fi
3b70: 6c 65 20 66 6e 61 6d 65 0a 09 20 20 28 6c 61 6d le fname.. (lam
3b80: 62 64 61 20 28 29 0a 09 20 20 20 20 28 70 72 69 bda ().. (pri
3b90: 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 nt key-string)))
3ba0: 0a 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
3bb0: 20 30 2e 32 35 29 0a 09 28 69 66 20 28 66 69 6c 0.25)..(if (fil
3bc0: 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 e-exists? fname)
3bd0: 0a 09 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 .. (with-inpu
3be0: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d t-from-file fnam
3bf0: 65 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 64 61 e.. (lambda
3c00: 20 28 29 0a 09 09 28 65 71 75 61 6c 3f 20 6b 65 ()...(equal? ke
3c10: 79 2d 73 74 72 69 6e 67 20 28 72 65 61 64 2d 6c y-string (read-l
3c20: 69 6e 65 29 29 29 29 0a 09 20 20 20 20 23 66 29 ine)))).. #f)
3c30: 29 29 29 0a 09 0a 28 64 65 66 69 6e 65 20 28 63 )))...(define (c
3c40: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
3c50: 65 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 e-release-lock f
3c60: 6e 61 6d 65 29 0a 20 20 28 64 65 6c 65 74 65 2d name). (delete-
3c70: 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 0a 0a 3b file* fname))..;
3c80: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
3c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cc0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 54 20 41 =======.;; S T A
3cd0: 20 54 20 45 20 53 20 20 20 41 20 4e 20 44 20 20 T E S A N D
3ce0: 20 53 20 54 20 41 20 54 20 55 20 53 20 45 20 53 S T A T U S E S
3cf0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
3d40: 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 ne *common:std-s
3d50: 74 61 74 65 73 2a 20 20 20 0a 20 20 27 28 28 30 tates* . '((0
3d60: 20 22 41 52 43 48 49 56 45 44 22 29 0a 20 20 20 "ARCHIVED").
3d70: 20 28 31 20 22 53 54 55 43 4b 22 29 0a 20 20 20 (1 "STUCK").
3d80: 20 28 32 20 22 4b 49 4c 4c 52 45 51 22 29 0a 20 (2 "KILLREQ").
3d90: 20 20 20 28 33 20 22 4b 49 4c 4c 45 44 22 29 0a (3 "KILLED").
3da0: 20 20 20 20 28 34 20 22 4e 4f 54 5f 53 54 41 52 (4 "NOT_STAR
3db0: 54 45 44 22 29 0a 20 20 20 20 28 35 20 22 43 4f TED"). (5 "CO
3dc0: 4d 50 4c 45 54 45 44 22 29 0a 20 20 20 20 28 36 MPLETED"). (6
3dd0: 20 22 4c 41 55 4e 43 48 45 44 22 29 0a 20 20 20 "LAUNCHED").
3de0: 20 28 37 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 (7 "REMOTEHOSTS
3df0: 54 41 52 54 22 29 0a 20 20 20 20 28 38 20 22 52 TART"). (8 "R
3e00: 55 4e 4e 49 4e 47 22 29 0a 20 20 20 20 29 29 0a UNNING"). )).
3e10: 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e .(define *common
3e20: 3a 73 74 64 2d 73 74 61 74 75 73 65 73 2a 0a 20 :std-statuses*.
3e30: 20 27 28 3b 3b 20 28 30 20 22 44 45 4c 45 54 45 '(;; (0 "DELETE
3e40: 44 22 29 0a 20 20 20 20 28 31 20 22 6e 2f 61 22 D"). (1 "n/a"
3e50: 29 0a 20 20 20 20 28 32 20 22 50 41 53 53 22 29 ). (2 "PASS")
3e60: 0a 20 20 20 20 28 33 20 22 43 48 45 43 4b 22 29 . (3 "CHECK")
3e70: 0a 20 20 20 20 28 34 20 22 53 4b 49 50 22 29 0a . (4 "SKIP").
3e80: 20 20 20 20 28 35 20 22 57 41 52 4e 22 29 0a 20 (5 "WARN").
3e90: 20 20 20 28 36 20 22 57 41 49 56 45 44 22 29 0a (6 "WAIVED").
3ea0: 20 20 20 20 28 37 20 22 53 54 55 43 4b 2f 44 45 (7 "STUCK/DE
3eb0: 41 44 22 29 0a 20 20 20 20 28 38 20 22 46 41 49 AD"). (8 "FAI
3ec0: 4c 22 29 0a 20 20 20 20 28 39 20 22 41 42 4f 52 L"). (9 "ABOR
3ed0: 54 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a T")))..(define *
3ee0: 63 6f 6d 6d 6f 6e 3a 65 6e 64 65 64 2d 73 74 61 common:ended-sta
3ef0: 74 65 73 2a 20 20 20 20 20 20 20 3b 3b 20 73 74 tes* ;; st
3f00: 61 74 65 73 20 77 68 69 63 68 20 69 6e 64 69 63 ates which indic
3f10: 61 74 65 20 74 68 65 20 74 65 73 74 20 69 73 20 ate the test is
3f20: 73 74 6f 70 70 65 64 20 61 6e 64 20 77 69 6c 6c stopped and will
3f30: 20 6e 6f 74 20 70 72 6f 63 65 65 64 0a 20 20 27 not proceed. '
3f40: 28 22 43 4f 4d 50 4c 45 54 45 44 22 20 22 41 52 ("COMPLETED" "AR
3f50: 43 48 49 56 45 44 22 20 22 4b 49 4c 4c 45 44 22 CHIVED" "KILLED"
3f60: 20 22 4b 49 4c 4c 52 45 51 22 20 22 53 54 55 43 "KILLREQ" "STUC
3f70: 4b 22 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 29 K" "INCOMPLETE")
3f80: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d )..(define *comm
3f90: 6f 6e 3a 62 61 64 6c 79 2d 65 6e 64 65 64 2d 73 on:badly-ended-s
3fa0: 74 61 74 65 73 2a 20 3b 3b 20 74 68 65 73 65 20 tates* ;; these
3fb0: 72 6f 6c 6c 20 75 70 20 61 73 20 43 48 45 43 4b roll up as CHECK
3fc0: 2c 20 69 2e 65 2e 20 72 65 73 75 6c 74 73 20 6e , i.e. results n
3fd0: 65 65 64 20 74 6f 20 62 65 20 63 68 65 63 6b 65 eed to be checke
3fe0: 64 0a 20 20 27 28 22 4b 49 4c 4c 45 44 22 20 22 d. '("KILLED" "
3ff0: 4b 49 4c 4c 52 45 51 22 20 22 53 54 55 43 4b 22 KILLREQ" "STUCK"
4000: 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 44 "INCOMPLETE" "D
4010: 45 41 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 EAD"))..(define
4020: 2a 63 6f 6d 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d *common:running-
4030: 73 74 61 74 65 73 2a 20 20 20 20 20 3b 3b 20 74 states* ;; t
4040: 65 73 74 20 69 73 20 65 69 74 68 65 72 20 72 75 est is either ru
4050: 6e 6e 69 6e 67 20 6f 72 20 63 61 6e 20 62 65 20 nning or can be
4060: 72 75 6e 0a 20 20 27 28 22 52 55 4e 4e 49 4e 47 run. '("RUNNING
4070: 22 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 " "REMOTEHOSTSTA
4080: 52 54 22 20 22 4c 41 55 4e 43 48 45 44 22 29 29 RT" "LAUNCHED"))
4090: 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f ..(define *commo
40a0: 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 n:cant-run-state
40b0: 73 2a 20 20 20 20 3b 3b 20 54 68 65 73 65 20 61 s* ;; These a
40c0: 72 65 20 73 74 6f 70 70 69 6e 67 20 63 6f 6e 64 re stopping cond
40d0: 69 74 69 6f 6e 73 20 74 68 61 74 20 70 72 65 76 itions that prev
40e0: 65 6e 74 20 61 20 74 65 73 74 20 66 72 6f 6d 20 ent a test from
40f0: 62 65 69 6e 67 20 72 75 6e 0a 20 20 27 28 22 43 being run. '("C
4100: 4f 4d 50 4c 45 54 45 44 22 20 22 4b 49 4c 4c 45 OMPLETED" "KILLE
4110: 44 22 20 22 55 4e 4b 4e 4f 57 4e 22 20 22 49 4e D" "UNKNOWN" "IN
4120: 43 4f 4d 50 4c 45 54 45 22 20 22 41 52 43 48 49 COMPLETE" "ARCHI
4130: 56 45 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 VED"))..(define
4140: 2a 63 6f 6d 6d 6f 6e 3a 6e 6f 74 2d 73 74 61 72 *common:not-star
4150: 74 65 64 2d 6f 6b 2d 73 74 61 74 75 73 65 73 2a ted-ok-statuses*
4160: 20 3b 3b 20 69 66 20 6e 6f 74 20 6f 6e 65 20 6f ;; if not one o
4170: 66 20 74 68 65 73 65 20 73 74 61 74 75 73 65 73 f these statuses
4180: 20 77 68 65 6e 20 69 6e 20 6e 6f 74 5f 73 74 61 when in not_sta
4190: 72 74 65 64 20 73 74 61 74 65 20 74 72 65 61 74 rted state treat
41a0: 20 61 73 20 64 65 61 64 0a 20 20 27 28 22 6e 2f as dead. '("n/
41b0: 61 22 20 22 6e 61 22 20 22 50 41 53 53 22 20 22 a" "na" "PASS" "
41c0: 46 41 49 4c 22 20 22 57 41 52 4e 22 20 22 43 48 FAIL" "WARN" "CH
41d0: 45 43 4b 22 20 22 57 41 49 56 45 44 22 20 22 44 ECK" "WAIVED" "D
41e0: 45 41 44 22 20 22 53 4b 49 50 22 29 29 0a 0a 28 EAD" "SKIP"))..(
41f0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
4200: 70 65 63 69 61 6c 2d 73 6f 72 74 20 69 74 65 6d pecial-sort item
4210: 73 20 6f 72 64 65 72 20 63 6f 6d 70 29 0a 20 20 s order comp).
4220: 28 6c 65 74 20 28 28 69 74 65 6d 73 2d 6f 72 64 (let ((items-ord
4230: 65 72 20 28 6d 61 70 20 72 65 76 65 72 73 65 20 er (map reverse
4240: 6f 72 64 65 72 29 29 0a 20 20 20 20 20 20 20 20 order)).
4250: 28 61 63 6f 6d 70 20 20 20 20 20 20 20 28 6f 72 (acomp (or
4260: 20 63 6f 6d 70 20 3e 29 29 29 0a 20 20 20 20 28 comp >))). (
4270: 73 6f 72 74 20 69 74 65 6d 73 0a 20 20 20 20 20 sort items.
4280: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 (lambda (a b)
4290: 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 . (let
42a0: 28 28 61 2d 6e 75 6d 20 28 63 61 64 72 20 28 6f ((a-num (cadr (o
42b0: 72 20 28 61 73 73 6f 63 20 61 20 69 74 65 6d 73 r (assoc a items
42c0: 2d 6f 72 64 65 72 29 20 27 28 30 20 30 29 29 29 -order) '(0 0)))
42d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
42e0: 20 20 28 62 2d 6e 75 6d 20 28 63 61 64 72 20 28 (b-num (cadr (
42f0: 6f 72 20 28 61 73 73 6f 63 20 62 20 69 74 65 6d or (assoc b item
4300: 73 2d 6f 72 64 65 72 29 20 27 28 30 20 30 29 29 s-order) '(0 0))
4310: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
4320: 28 61 63 6f 6d 70 20 61 2d 6e 75 6d 20 62 2d 6e (acomp a-num b-n
4330: 75 6d 29 29 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 um))))))..;; ;;
4340: 67 69 76 65 6e 20 61 20 74 6f 70 6c 65 76 65 6c given a toplevel
4350: 20 77 69 74 68 20 63 75 72 72 73 74 61 74 65 2c with currstate,
4360: 20 63 75 72 72 73 74 61 74 75 73 20 61 70 70 6c currstatus appl
4370: 79 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 74 y state and stat
4380: 75 73 0a 3b 3b 20 3b 3b 20 20 3d 3e 20 28 6e 65 us.;; ;; => (ne
4390: 77 73 74 61 74 65 20 2e 20 6e 65 77 73 74 61 74 wstate . newstat
43a0: 75 73 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 us).;; (define (
43b0: 63 6f 6d 6d 6f 6e 3a 61 70 70 6c 79 2d 73 74 61 common:apply-sta
43c0: 74 65 2d 73 74 61 74 75 73 20 63 75 72 72 73 74 te-status currst
43d0: 61 74 65 20 63 75 72 72 73 74 61 74 75 73 20 73 ate currstatus s
43e0: 74 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 tate status).;;
43f0: 20 20 28 6c 65 74 2a 20 28 28 63 73 74 61 74 65 (let* ((cstate
4400: 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f (string->symbo
4410: 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 l (string-downca
4420: 73 65 20 63 75 72 72 73 74 61 74 65 29 29 29 0a se currstate))).
4430: 3b 3b 20 20 20 20 20 20 20 20 20 20 28 63 73 74 ;; (cst
4440: 61 74 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 79 atus (string->sy
4450: 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 mbol (string-dow
4460: 6e 63 61 73 65 20 63 75 72 72 73 74 61 74 75 73 ncase currstatus
4470: 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ))).;;
4480: 28 73 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 (sstate (string
4490: 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 ->symbol (string
44a0: 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 65 29 -downcase state)
44b0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 )).;; (
44c0: 73 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d sstatus (string-
44d0: 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d >symbol (string-
44e0: 64 6f 77 6e 63 61 73 65 20 73 74 61 74 75 73 29 downcase status)
44f0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 )).;; (
4500: 6e 73 74 61 74 65 20 20 23 66 29 0a 3b 3b 20 20 nstate #f).;;
4510: 20 20 20 20 20 20 20 20 28 6e 73 74 61 74 75 73 (nstatus
4520: 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 28 73 65 #f)).;; (se
4530: 74 21 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 t! nstate.;;
4540: 20 20 20 20 20 20 20 28 63 61 73 65 20 63 73 74 (case cst
4550: 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ate.;;
4560: 20 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6e ((completed n
4570: 6f 74 5f 73 74 61 72 74 65 64 20 6b 69 6c 6c 65 ot_started kille
4580: 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 d killreq stuck
4590: 61 72 63 68 69 76 65 64 29 20 0a 3b 3b 20 20 20 archived) .;;
45a0: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 65 (case
45b0: 20 73 73 74 61 74 65 20 3b 3b 20 63 6f 6d 70 6c sstate ;; compl
45c0: 65 74 65 64 20 2d 3e 20 73 73 74 61 74 65 0a 3b eted -> sstate.;
45d0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
45e0: 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 6c ((completed kil
45f0: 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 led killreq stuc
4600: 6b 20 61 72 63 68 69 76 65 64 29 20 63 6f 6d 70 k archived) comp
4610: 6c 65 74 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 leted).;;
4620: 20 20 20 20 20 20 20 20 20 28 28 72 75 6e 6e 69 ((runni
4630: 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 ng remotehoststa
4640: 72 74 20 6c 61 75 6e 63 68 65 64 29 20 20 20 20 rt launched)
4650: 20 20 20 20 72 75 6e 6e 69 6e 67 29 0a 3b 3b 20 running).;;
4660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4670: 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 else
4680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4690: 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 unknow
46a0: 6e 2d 65 72 72 6f 72 2d 31 29 29 29 0a 3b 3b 20 n-error-1))).;;
46b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 72 75 ((ru
46c0: 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 nning remotehost
46d0: 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 0a start launched).
46e0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
46f0: 28 63 61 73 65 20 73 73 74 61 74 65 0a 3b 3b 20 (case sstate.;;
4700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4710: 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 6c 6c 65 (completed kille
4720: 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 d killreq stuck
4730: 61 72 63 68 69 76 65 64 29 20 23 66 29 20 3b 3b archived) #f) ;;
4740: 20 6e 65 65 64 20 74 6f 20 6c 6f 6f 6b 20 61 74 need to look at
4750: 20 61 6c 6c 20 69 74 65 6d 73 0a 3b 3b 20 20 20 all items.;;
4760: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 72 ((r
4770: 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 unning remotehos
4780: 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 tstart launched)
4790: 20 20 20 20 20 20 20 20 72 75 6e 6e 69 6e 67 29 running)
47a0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
47b0: 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 (else
47c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
47d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 75 6e un
47e0: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 32 29 29 29 known-error-2)))
47f0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4800: 28 65 6c 73 65 20 75 6e 6b 6e 6f 77 6e 2d 65 72 (else unknown-er
4810: 72 6f 72 2d 33 29 29 29 0a 3b 3b 20 20 20 20 20 ror-3))).;;
4820: 28 73 65 74 21 20 6e 73 74 61 74 75 73 0a 3b 3b (set! nstatus.;;
4830: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 65 (case
4840: 20 73 73 74 61 74 75 73 0a 3b 3b 20 20 20 20 20 sstatus.;;
4850: 20 20 20 20 20 20 20 20 28 28 70 61 73 73 29 0a ((pass).
4860: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
4870: 28 63 61 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 (case nstate.;;
4880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4890: 28 70 61 73 73 20 6e 2f 61 20 64 65 6c 65 74 65 (pass n/a delete
48a0: 64 29 20 20 20 20 20 70 61 73 73 29 0a 3b 3b 20 d) pass).;;
48b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
48c0: 28 77 61 72 6e 29 20 20 20 20 20 20 20 20 20 20 (warn)
48d0: 20 20 20 20 20 20 20 77 61 72 6e 29 0a 3b 3b 20 warn).;;
48e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
48f0: 28 66 61 69 6c 29 20 20 20 20 20 20 20 20 20 20 (fail)
4900: 20 20 20 20 20 20 20 66 61 69 6c 29 0a 3b 3b 20 fail).;;
4910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4920: 28 63 68 65 63 6b 29 20 20 20 20 20 20 20 20 20 (check)
4930: 20 20 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b 20 check).;;
4940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4950: 28 77 61 69 76 65 64 29 20 20 20 20 20 20 20 20 (waived)
4960: 20 20 20 20 20 77 61 69 76 65 64 29 0a 3b 3b 20 waived).;;
4970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4980: 28 73 6b 69 70 29 20 20 20 20 20 20 20 20 20 20 (skip)
4990: 20 20 20 20 20 20 20 73 6b 69 70 29 0a 3b 3b 20 skip).;;
49a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
49b0: 28 73 74 75 63 6b 2f 64 65 61 64 29 20 20 20 20 (stuck/dead)
49c0: 20 20 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b 20 stuck).;;
49d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
49e0: 28 61 62 6f 72 74 29 20 20 20 20 20 20 20 20 20 (abort)
49f0: 20 20 20 20 20 20 61 62 6f 72 74 29 0a 3b 3b 20 abort).;;
4a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4a10: 65 6c 73 65 20 20 20 20 20 20 20 20 75 6e 6b 6e else unkn
4a20: 6f 77 6e 2d 65 72 72 6f 72 2d 34 29 29 29 0a 3b own-error-4))).;
4a30: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ; ((
4a40: 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 warn).;;
4a50: 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 74 61 (case nsta
4a60: 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 te.;;
4a70: 20 20 20 20 20 28 28 70 61 73 73 20 77 61 72 6e ((pass warn
4a80: 20 6e 2f 61 20 73 6b 69 70 20 64 65 6c 65 74 65 n/a skip delete
4a90: 64 29 20 20 20 77 61 72 6e 29 0a 3b 3b 20 20 20 d) warn).;;
4aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 66 ((f
4ab0: 61 69 6c 29 20 20 20 20 20 20 20 20 20 20 20 20 ail)
4ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 66 61 69 fai
4ad0: 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 l).;;
4ae0: 20 20 20 20 20 28 28 63 68 65 63 6b 29 20 20 20 ((check)
4af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4b00: 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b 20 20 20 check).;;
4b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 77 ((w
4b20: 61 69 76 65 64 29 20 20 20 20 20 20 20 20 20 20 aived)
4b30: 20 20 20 20 20 20 20 20 20 20 20 77 61 69 76 65 waive
4b40: 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 d).;;
4b50: 20 20 20 20 20 28 28 73 74 75 63 6b 2f 64 65 61 ((stuck/dea
4b60: 64 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 d)
4b70: 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b 20 20 20 stuck).;;
4b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
4b90: 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 se
4ba0: 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d unknown-error-
4bb0: 35 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 5))).;;
4bc0: 20 20 20 20 28 28 66 61 69 6c 29 0a 3b 3b 20 20 ((fail).;;
4bd0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 (cas
4be0: 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 e nstate.;;
4bf0: 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 73 ((pas
4c00: 73 20 77 61 72 6e 20 66 61 69 6c 20 63 68 65 63 s warn fail chec
4c10: 6b 20 6e 2f 61 20 77 61 69 76 65 64 20 73 6b 69 k n/a waived ski
4c20: 70 20 64 65 6c 65 74 65 64 20 73 74 75 63 6b 2f p deleted stuck/
4c30: 64 65 61 64 20 73 74 75 63 6b 29 20 20 66 61 69 dead stuck) fai
4c40: 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 l).;;
4c50: 20 20 20 20 20 28 28 61 62 6f 72 74 29 20 20 20 ((abort)
4c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4c90: 20 20 20 20 20 20 61 62 6f 72 74 29 0a 3b 3b 20 abort).;;
4ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4cb0: 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 else
4cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4cd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4ce0: 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 unknown-er
4cf0: 72 6f 72 2d 36 29 29 29 0a 3b 3b 20 20 20 20 20 ror-6))).;;
4d00: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 (else
4d10: 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 37 unknown-error-7
4d20: 29 29 29 0a 3b 3b 20 20 20 20 20 28 63 6f 6e 73 ))).;; (cons
4d30: 20 0a 3b 3b 20 20 20 20 20 20 28 69 66 20 6e 73 .;; (if ns
4d40: 74 61 74 65 20 20 28 73 79 6d 62 6f 6c 2d 3e 73 tate (symbol->s
4d50: 74 72 69 6e 67 20 6e 73 74 61 74 65 29 20 20 6e tring nstate) n
4d60: 73 74 61 74 65 29 0a 3b 3b 20 20 20 20 20 20 28 state).;; (
4d70: 69 66 20 6e 73 74 61 74 75 73 20 28 73 79 6d 62 if nstatus (symb
4d80: 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 73 74 61 74 ol->string nstat
4d90: 75 73 29 20 6e 73 74 61 74 75 73 29 29 29 29 0a us) nstatus)))).
4da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
4db0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
4dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4df0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 45 20 ========.;; D E
4e00: 42 20 55 20 47 20 47 20 49 20 4e 20 47 20 20 20 B U G G I N G
4e10: 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d S T U F F .;;===
4e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e60: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 76 65 ===..(define *ve
4e70: 72 62 6f 73 69 74 79 2a 20 20 20 20 20 20 20 20 rbosity*
4e80: 20 31 29 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 67 1).(define *log
4e90: 67 69 6e 67 2a 20 20 20 20 20 20 20 20 20 20 20 ging*
4ea0: 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 #f)..(define (ge
4eb0: 74 2d 77 69 74 68 2d 64 65 66 61 75 6c 74 20 76 t-with-default v
4ec0: 61 6c 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c al default). (l
4ed0: 65 74 20 28 28 76 61 6c 20 28 61 72 67 73 3a 67 et ((val (args:g
4ee0: 65 74 2d 61 72 67 20 76 61 6c 29 29 29 0a 20 20 et-arg val))).
4ef0: 20 20 28 69 66 20 76 61 6c 20 76 61 6c 20 64 65 (if val val de
4f00: 66 61 75 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e fault)))..(defin
4f10: 65 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 e (assoc/default
4f20: 20 6b 65 79 20 6c 73 74 20 2e 20 64 65 66 61 75 key lst . defau
4f30: 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 lt). (let ((res
4f40: 20 28 61 73 73 6f 63 20 6b 65 79 20 6c 73 74 29 (assoc key lst)
4f50: 29 29 0a 20 20 20 20 28 69 66 20 72 65 73 20 28 )). (if res (
4f60: 63 61 64 72 20 72 65 73 29 28 69 66 20 28 6e 75 cadr res)(if (nu
4f70: 6c 6c 3f 20 64 65 66 61 75 6c 74 29 20 23 66 20 ll? default) #f
4f80: 28 63 61 72 20 64 65 66 61 75 6c 74 29 29 29 29 (car default))))
4f90: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
4fa0: 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 on:get-testsuite
4fb0: 2d 6e 61 6d 65 29 0a 20 20 28 6f 72 20 28 63 6f -name). (or (co
4fc0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
4fd0: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
4fe0: 20 22 74 65 73 74 73 75 69 74 65 22 20 29 0a 20 "testsuite" ).
4ff0: 20 20 20 20 20 28 69 66 20 2a 74 6f 70 70 61 74 (if *toppat
5000: 68 2a 20 0a 20 20 20 20 20 20 20 20 20 20 28 70 h* . (p
5010: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 2a 74 6f athname-file *to
5020: 70 70 61 74 68 2a 29 0a 20 20 20 20 20 20 20 20 ppath*).
5030: 20 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 (pathname-file
5040: 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 74 (current-direct
5050: 6f 72 79 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ory)))))..(defin
5060: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 e (common:get-db
5070: 2d 74 6d 70 2d 61 72 65 61 29 0a 20 20 28 69 66 -tmp-area). (if
5080: 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 68 2a *db-cache-path*
5090: 0a 20 20 20 20 20 20 2a 64 62 2d 63 61 63 68 65 . *db-cache
50a0: 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 28 6c 65 -path*. (le
50b0: 74 20 28 28 64 62 70 61 74 68 20 28 63 72 65 61 t ((dbpath (crea
50c0: 74 65 2d 64 69 72 65 63 74 6f 72 79 20 28 63 6f te-directory (co
50d0: 6e 63 20 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 nc "/tmp/" (curr
50e0: 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 0a 09 ent-user-name)..
50f0: 09 09 09 09 20 20 20 20 22 2f 6d 65 67 61 74 65 .... "/megate
5100: 73 74 5f 6c 6f 63 61 6c 64 62 2f 22 0a 09 09 09 st_localdb/"....
5110: 09 09 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 .. (common:ge
5120: 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 t-testsuite-name
5130: 29 20 22 2f 22 0a 09 09 09 09 09 20 20 20 20 28 ) "/"...... (
5140: 73 74 72 69 6e 67 2d 74 72 61 6e 73 6c 61 74 65 string-translate
5150: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 22 20 22 *toppath* "/" "
5160: 2e 22 29 29 20 23 74 29 29 29 0a 09 28 73 65 74 .")) #t)))..(set
5170: 21 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 68 ! *db-cache-path
5180: 2a 20 64 62 70 61 74 68 29 0a 09 64 62 70 61 74 * dbpath)..dbpat
5190: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 h)))..(define (c
51a0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 70 ommon:get-area-p
51b0: 61 74 68 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 ath-signature).
51c0: 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 (message-digest
51d0: 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 -string (md5-pri
51e0: 6d 69 74 69 76 65 29 20 2a 74 6f 70 70 61 74 68 mitive) *toppath
51f0: 2a 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d *))..;;=========
5200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5220: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
5240: 20 45 20 58 20 49 20 54 20 20 20 48 20 41 20 4e E X I T H A N
5250: 20 44 20 4c 20 49 20 4e 20 47 0a 3b 3b 3d 3d 3d D L I N G.;;===
5260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5290: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
52a0: 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f ===..(define (co
52b0: 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 6e 63 3f 29 0a mmon:run-sync?).
52c0: 20 20 20 20 28 61 6e 64 20 28 63 6f 6d 6d 6f 6e (and (common
52d0: 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 :on-homehost?)..
52e0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
52f0: 2d 73 65 72 76 65 72 22 29 29 29 0a 0a 3b 3b 20 -server")))..;;
5300: 20 20 28 6c 65 74 20 28 28 6f 68 68 20 28 63 6f (let ((ohh (co
5310: 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 mmon:on-homehost
5320: 3f 29 29 0a 3b 3b 20 09 28 73 72 76 20 28 61 72 ?)).;; .(srv (ar
5330: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 gs:get-arg "-ser
5340: 76 65 72 22 29 29 29 0a 3b 3b 20 20 20 20 20 28 ver"))).;; (
5350: 61 6e 64 20 6f 68 68 20 73 72 76 29 29 29 0a 20 and ohh srv))).
5360: 20 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 ;; (debug:pri
5370: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
5380: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f lt-log-port* "co
5390: 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 6e 63 3f 20 6f mmon:run-sync? o
53a0: 68 68 3d 22 20 6f 68 68 20 22 2c 20 73 72 76 3d hh=" ohh ", srv=
53b0: 22 20 73 72 76 29 0a 0a 3b 3b 3b 3b 20 72 75 6e " srv)..;;;; run
53c0: 2d 69 64 73 0a 3b 3b 20 20 20 20 69 66 20 23 66 -ids.;; if #f
53d0: 20 75 73 65 20 2a 64 62 2d 6c 6f 63 61 6c 2d 73 use *db-local-s
53e0: 79 6e 63 2a 20 3a 20 6f 72 20 27 6c 6f 63 61 6c ync* : or 'local
53f0: 2d 73 79 6e 63 2d 66 6c 61 67 73 0a 3b 3b 20 20 -sync-flags.;;
5400: 20 20 69 66 20 23 74 20 75 73 65 20 74 69 6d 65 if #t use time
5410: 73 74 61 6d 70 73 20 20 20 20 20 20 3a 20 6f 72 stamps : or
5420: 20 27 74 69 6d 65 73 74 61 6d 70 73 0a 28 64 65 'timestamps.(de
5430: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 79 6e fine (common:syn
5440: 63 2d 74 6f 2d 6d 65 67 61 74 65 73 74 2e 64 62 c-to-megatest.db
5450: 20 64 62 73 74 72 75 63 74 29 20 0a 20 20 28 6c dbstruct) . (l
5460: 65 74 20 28 28 73 74 61 72 74 2d 74 69 6d 65 20 et ((start-time
5470: 20 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 (current
5480: 2d 73 65 63 6f 6e 64 73 29 29 0a 09 28 72 65 73 -seconds))..(res
5490: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
54a0: 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e (db:multi-db-syn
54b0: 63 20 64 62 73 74 72 75 63 74 20 27 6e 65 77 32 c dbstruct 'new2
54c0: 6f 6c 64 29 29 29 0a 20 20 20 20 28 6c 65 74 20 old))). (let
54d0: 28 28 73 79 6e 63 2d 74 69 6d 65 20 28 2d 20 28 ((sync-time (- (
54e0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
54f0: 20 73 74 61 72 74 2d 74 69 6d 65 29 29 29 0a 20 start-time))).
5500: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
5510: 74 2d 69 6e 66 6f 20 33 20 2a 64 65 66 61 75 6c t-info 3 *defaul
5520: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 79 6e t-log-port* "Syn
5530: 63 20 6f 66 20 6e 65 77 64 62 20 74 6f 20 6f 6c c of newdb to ol
5540: 64 64 62 20 63 6f 6d 70 6c 65 74 65 64 20 69 6e ddb completed in
5550: 20 22 20 73 79 6e 63 2d 74 69 6d 65 20 22 20 73 " sync-time " s
5560: 65 63 6f 6e 64 73 20 70 69 64 3d 22 28 63 75 72 econds pid="(cur
5570: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
5580: 29 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d ). (if (com
5590: 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 mon:low-noise-pr
55a0: 69 6e 74 20 33 30 20 22 73 79 6e 63 20 6e 65 77 int 30 "sync new
55b0: 20 74 6f 20 6f 6c 64 22 29 0a 09 20 20 28 64 65 to old").. (de
55c0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
55d0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
55e0: 72 74 2a 20 22 53 79 6e 63 20 6f 66 20 6e 65 77 rt* "Sync of new
55f0: 64 62 20 74 6f 20 6f 6c 64 64 62 20 63 6f 6d 70 db to olddb comp
5600: 6c 65 74 65 64 20 69 6e 20 22 20 73 79 6e 63 2d leted in " sync-
5610: 74 69 6d 65 20 22 20 73 65 63 6f 6e 64 73 20 70 time " seconds p
5620: 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f id="(current-pro
5630: 63 65 73 73 2d 69 64 29 29 29 29 0a 20 20 20 20 cess-id)))).
5640: 72 65 73 29 29 0a 0a 0a 0a 0a 28 64 65 66 69 6e res)).....(defin
5650: 65 20 2a 77 64 6e 75 6d 2a 20 30 29 0a 28 64 65 e *wdnum* 0).(de
5660: 66 69 6e 65 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 fine *wdnum*mute
5670: 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a x (make-mutex)).
5680: 3b 3b 20 63 75 72 72 65 6e 74 6c 79 20 74 68 65 ;; currently the
5690: 20 70 72 69 6d 61 72 79 20 6a 6f 62 20 6f 66 20 primary job of
56a0: 74 68 65 20 77 61 74 63 68 64 6f 67 20 69 73 20 the watchdog is
56b0: 74 6f 20 72 75 6e 20 74 68 65 20 73 79 6e 63 20 to run the sync
56c0: 62 61 63 6b 20 74 6f 20 6d 65 67 61 74 65 73 74 back to megatest
56d0: 2e 64 62 20 66 72 6f 6d 20 74 68 65 20 64 62 20 .db from the db
56e0: 69 6e 20 2f 74 6d 70 0a 3b 3b 20 69 66 20 77 65 in /tmp.;; if we
56f0: 20 61 72 65 20 6f 6e 20 74 68 65 20 68 6f 6d 65 are on the home
5700: 68 6f 73 74 20 61 6e 64 20 77 65 20 61 72 65 20 host and we are
5710: 61 20 73 65 72 76 65 72 20 28 62 79 20 64 65 66 a server (by def
5720: 69 6e 69 74 69 6f 6e 20 77 65 20 61 72 65 20 6f inition we are o
5730: 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 69 n the homehost i
5740: 66 20 77 65 20 61 72 65 20 61 20 73 65 72 76 65 f we are a serve
5750: 72 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 r).;;.(define (c
5760: 6f 6d 6d 6f 6e 3a 77 61 74 63 68 64 6f 67 29 0a ommon:watchdog).
5770: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
5780: 20 30 2e 30 35 29 20 3b 3b 20 64 65 6c 61 79 20 0.05) ;; delay
5790: 66 6f 72 20 73 74 61 72 74 75 70 0a 20 20 28 6c for startup. (l
57a0: 65 74 20 28 28 6c 65 67 61 63 79 2d 73 79 6e 63 et ((legacy-sync
57b0: 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 6e (common:run-syn
57c0: 63 3f 29 29 0a 09 28 64 65 62 75 67 2d 6d 6f 64 c?))..(debug-mod
57d0: 65 20 20 28 64 65 62 75 67 3a 64 65 62 75 67 2d e (debug:debug-
57e0: 6d 6f 64 65 20 31 29 29 0a 09 28 6c 61 73 74 2d mode 1))..(last-
57f0: 74 69 6d 65 20 20 20 28 63 75 72 72 65 6e 74 2d time (current-
5800: 73 65 63 6f 6e 64 73 29 29 0a 20 20 20 20 20 20 seconds)).
5810: 20 20 28 74 68 69 73 2d 77 64 2d 6e 75 6d 20 20 (this-wd-num
5820: 20 20 20 28 62 65 67 69 6e 20 28 6d 75 74 65 78 (begin (mutex
5830: 2d 6c 6f 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 -lock! *wdnum*mu
5840: 74 65 78 29 20 28 6c 65 74 20 28 28 78 20 2a 77 tex) (let ((x *w
5850: 64 6e 75 6d 2a 29 29 20 28 73 65 74 21 20 2a 77 dnum*)) (set! *w
5860: 64 6e 75 6d 2a 20 28 61 64 64 31 20 2a 77 64 6e dnum* (add1 *wdn
5870: 75 6d 2a 29 29 20 28 6d 75 74 65 78 2d 75 6e 6c um*)) (mutex-unl
5880: 6f 63 6b 21 20 2a 77 64 6e 75 6d 2a 6d 75 74 65 ock! *wdnum*mute
5890: 78 29 20 78 29 29 29 29 0a 20 20 20 20 28 64 65 x) x)))). (de
58a0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
58b0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
58c0: 72 74 2a 20 22 77 61 74 63 68 64 6f 67 20 73 74 rt* "watchdog st
58d0: 61 72 74 69 6e 67 2e 20 6c 65 67 61 63 79 2d 73 arting. legacy-s
58e0: 79 6e 63 20 69 73 20 22 20 6c 65 67 61 63 79 2d ync is " legacy-
58f0: 73 79 6e 63 22 20 70 69 64 3d 22 28 63 75 72 72 sync" pid="(curr
5900: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 ent-process-id)"
5910: 20 74 68 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 this-wd-num="th
5920: 69 73 2d 77 64 2d 6e 75 6d 29 0a 20 20 20 20 28 is-wd-num). (
5930: 69 66 20 28 61 6e 64 20 6c 65 67 61 63 79 2d 73 if (and legacy-s
5940: 79 6e 63 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 ync (not *time-t
5950: 6f 2d 65 78 69 74 2a 29 29 0a 09 28 6c 65 74 2a o-exit*))..(let*
5960: 20 28 28 64 62 73 74 72 75 63 74 20 28 64 62 3a ((dbstruct (db:
5970: 73 65 74 75 70 29 29 0a 09 20 20 20 20 20 20 20 setup))..
5980: 28 6d 74 64 62 20 20 20 20 20 28 64 62 72 3a 64 (mtdb (dbr:d
5990: 62 73 74 72 75 63 74 2d 6d 74 64 62 20 64 62 73 bstruct-mtdb dbs
59a0: 74 72 75 63 74 29 29 0a 09 20 20 20 20 20 20 20 truct))..
59b0: 28 6d 74 70 61 74 68 20 20 20 28 64 62 3a 64 62 (mtpath (db:db
59c0: 64 61 74 2d 67 65 74 2d 70 61 74 68 20 6d 74 64 dat-get-path mtd
59d0: 62 29 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 b))).. (debug:p
59e0: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
59f0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
5a00: 53 65 72 76 65 72 20 72 75 6e 6e 69 6e 67 2c 20 Server running,
5a10: 70 65 72 69 6f 64 69 63 20 73 79 6e 63 20 73 74 periodic sync st
5a20: 61 72 74 65 64 2e 22 29 0a 09 20 20 28 6c 65 74 arted.").. (let
5a30: 20 6c 6f 6f 70 20 28 29 0a 09 20 20 20 20 3b 3b loop ().. ;;
5a40: 20 73 79 6e 63 20 66 6f 72 20 66 69 6c 65 73 79 sync for filesy
5a50: 73 74 65 6d 20 6c 6f 63 61 6c 20 64 62 20 77 72 stem local db wr
5a60: 69 74 65 73 0a 09 20 20 20 20 3b 3b 0a 09 20 20 ites.. ;;..
5a70: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
5a80: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
5a90: 74 65 78 2a 29 0a 09 20 20 20 20 28 6c 65 74 2a tex*).. (let*
5aa0: 20 28 28 6e 65 65 64 2d 73 79 6e 63 20 20 20 20 ((need-sync
5ab0: 20 20 20 20 28 3e 3d 20 2a 64 62 2d 6c 61 73 74 (>= *db-last
5ac0: 2d 61 63 63 65 73 73 2a 20 2a 64 62 2d 6c 61 73 -access* *db-las
5ad0: 74 2d 73 79 6e 63 2a 29 29 20 3b 3b 20 6e 6f 20 t-sync*)) ;; no
5ae0: 73 79 6e 63 20 73 69 6e 63 65 20 6c 61 73 74 20 sync since last
5af0: 77 72 69 74 65 0a 09 09 20 20 20 28 73 79 6e 63 write... (sync
5b00: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 20 2a 64 62 -in-progress *db
5b10: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
5b20: 73 2a 29 0a 09 09 20 20 20 28 73 68 6f 75 6c 64 s*)... (should
5b30: 2d 73 79 6e 63 20 20 20 20 20 20 28 61 6e 64 20 -sync (and
5b40: 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 (not *time-to-ex
5b50: 69 74 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 it*).
5b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
5b80: 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 > (- (current-se
5b90: 63 6f 6e 64 73 29 20 2a 64 62 2d 6c 61 73 74 2d conds) *db-last-
5ba0: 73 79 6e 63 2a 29 20 35 29 29 29 20 3b 3b 20 73 sync*) 5))) ;; s
5bb0: 79 6e 63 20 65 76 65 72 79 20 66 69 76 65 20 73 ync every five s
5bc0: 65 63 6f 6e 64 73 20 6d 69 6e 69 6d 75 6d 0a 09 econds minimum..
5bd0: 09 20 20 20 28 73 74 61 72 74 2d 74 69 6d 65 20 . (start-time
5be0: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 (current-s
5bf0: 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 28 6d econds))... (m
5c00: 74 2d 6d 6f 64 2d 74 69 6d 65 20 20 20 20 20 20 t-mod-time
5c10: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
5c20: 6f 6e 2d 74 69 6d 65 20 6d 74 70 61 74 68 29 29 on-time mtpath))
5c30: 0a 09 09 20 20 20 28 72 65 63 65 6e 74 6c 79 2d ... (recently-
5c40: 73 79 6e 63 65 64 20 20 28 3e 20 28 2d 20 73 74 synced (> (- st
5c50: 61 72 74 2d 74 69 6d 65 20 6d 74 2d 6d 6f 64 2d art-time mt-mod-
5c60: 74 69 6d 65 29 20 34 29 29 0a 09 09 20 20 20 28 time) 4))... (
5c70: 77 69 6c 6c 2d 73 79 6e 63 20 20 20 20 20 20 20 will-sync
5c80: 20 28 61 6e 64 20 28 6f 72 20 6e 65 65 64 2d 73 (and (or need-s
5c90: 79 6e 63 20 73 68 6f 75 6c 64 2d 73 79 6e 63 29 ync should-sync)
5ca0: 0a 09 09 09 09 09 20 20 28 6e 6f 74 20 73 79 6e ...... (not syn
5cb0: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 29 0a 09 c-in-progress)..
5cc0: 09 09 09 09 20 20 28 6e 6f 74 20 72 65 63 65 6e .... (not recen
5cd0: 74 6c 79 2d 73 79 6e 63 65 64 29 29 29 29 0a 09 tly-synced))))..
5ce0: 20 20 20 20 20 20 3b 3b 20 28 69 66 20 72 65 63 ;; (if rec
5cf0: 65 6e 74 6c 79 2d 73 79 6e 63 65 64 20 28 64 65 ently-synced (de
5d00: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
5d10: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5d20: 72 74 2a 20 22 53 6b 69 70 70 69 6e 67 20 73 79 rt* "Skipping sy
5d30: 6e 63 20 64 75 65 20 74 6f 20 72 65 63 65 6e 74 nc due to recent
5d40: 6c 79 2d 73 79 6e 63 65 64 20 66 6c 61 67 3d 22 ly-synced flag="
5d50: 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 recently-synced
5d60: 29 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 64 65 )).. ;; (de
5d70: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
5d80: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
5d90: 72 74 2a 20 22 6e 65 65 64 2d 73 79 6e 63 3a 20 rt* "need-sync:
5da0: 22 20 6e 65 65 64 2d 73 79 6e 63 20 22 20 73 79 " need-sync " sy
5db0: 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 3a 20 nc-in-progress:
5dc0: 22 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 " sync-in-progre
5dd0: 73 73 20 22 20 73 68 6f 75 6c 64 2d 73 79 6e 63 ss " should-sync
5de0: 3a 20 22 20 73 68 6f 75 6c 64 2d 73 79 6e 63 20 : " should-sync
5df0: 22 20 77 69 6c 6c 2d 73 79 6e 63 3a 20 22 20 77 " will-sync: " w
5e00: 69 6c 6c 2d 73 79 6e 63 29 0a 09 20 20 20 20 20 ill-sync)..
5e10: 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 20 28 (if will-sync (
5e20: 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e set! *db-sync-in
5e30: 2d 70 72 6f 67 72 65 73 73 2a 20 23 74 29 29 0a -progress* #t)).
5e40: 09 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e . (mutex-un
5e50: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
5e60: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 sync-mutex*)..
5e70: 20 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e (if will-syn
5e80: 63 0a 09 09 20 20 28 6c 65 74 20 28 28 72 65 73 c... (let ((res
5e90: 20 28 63 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d 74 6f (common:sync-to
5ea0: 2d 6d 65 67 61 74 65 73 74 2e 64 62 20 64 62 73 -megatest.db dbs
5eb0: 74 72 75 63 74 29 29 29 20 3b 3b 20 64 69 64 20 truct))) ;; did
5ec0: 77 65 20 73 79 6e 63 20 61 6e 79 20 64 61 74 61 we sync any data
5ed0: 3f 20 49 66 20 73 6f 20 6e 65 65 64 20 74 6f 20 ? If so need to
5ee0: 73 65 74 20 74 68 65 20 64 62 20 74 6f 75 63 68 set the db touch
5ef0: 65 64 20 66 6c 61 67 20 74 6f 20 6b 65 65 70 20 ed flag to keep
5f00: 74 68 65 20 73 65 72 76 65 72 20 61 6c 69 76 65 the server alive
5f10: 0a 09 09 20 20 20 20 28 69 66 20 28 3e 20 72 65 ... (if (> re
5f20: 73 20 30 29 20 3b 3b 20 73 6f 6d 65 20 72 65 63 s 0) ;; some rec
5f30: 6f 72 64 73 20 77 65 72 65 20 74 72 61 6e 73 66 ords were transf
5f40: 65 72 72 65 64 2c 20 6b 65 65 70 20 74 68 65 20 erred, keep the
5f50: 64 62 20 61 6c 69 76 65 0a 09 09 09 28 62 65 67 db alive....(beg
5f60: 69 6e 0a 09 09 09 20 20 28 6d 75 74 65 78 2d 6c in.... (mutex-l
5f70: 6f 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d ock! *heartbeat-
5f80: 6d 75 74 65 78 2a 29 0a 09 09 09 20 20 28 73 65 mutex*).... (se
5f90: 74 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 t! *db-last-acce
5fa0: 73 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ss* (current-sec
5fb0: 6f 6e 64 73 29 29 0a 09 09 09 20 20 28 6d 75 74 onds)).... (mut
5fc0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 ex-unlock! *hear
5fd0: 74 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 tbeat-mutex*)...
5fe0: 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
5ff0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
6000: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 79 6e 63 20 log-port* "sync
6010: 63 61 6c 6c 65 64 2c 20 22 20 72 65 73 20 22 20 called, " res "
6020: 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 65 72 records transfer
6030: 72 65 64 2e 22 29 29 0a 09 09 09 28 64 65 62 75 red."))....(debu
6040: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a g:print-info 2 *
6050: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6060: 2a 20 22 73 79 6e 63 20 63 61 6c 6c 65 64 20 62 * "sync called b
6070: 75 74 20 7a 65 72 6f 20 72 65 63 6f 72 64 73 20 ut zero records
6080: 74 72 61 6e 73 66 65 72 72 65 64 22 29 29 29 29 transferred"))))
6090: 0a 09 20 20 20 20 20 20 28 69 66 20 77 69 6c 6c .. (if will
60a0: 2d 73 79 6e 63 0a 09 09 20 20 28 62 65 67 69 6e -sync... (begin
60b0: 0a 09 09 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f ... (mutex-lo
60c0: 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 ck! *db-multi-sy
60d0: 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 09 20 20 20 nc-mutex*)...
60e0: 20 28 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d (set! *db-sync-
60f0: 69 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 29 in-progress* #f)
6100: 0a 09 09 20 20 20 20 28 73 65 74 21 20 2a 64 62 ... (set! *db
6110: 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 73 74 61 72 -last-sync* star
6120: 74 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 28 6d t-time)... (m
6130: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 utex-unlock! *db
6140: 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 -multi-sync-mute
6150: 78 2a 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 x*))).. (if
6160: 20 28 61 6e 64 20 64 65 62 75 67 2d 6d 6f 64 65 (and debug-mode
6170: 0a 09 09 20 20 20 20 20 20 20 28 3e 20 28 2d 20 ... (> (-
6180: 73 74 61 72 74 2d 74 69 6d 65 20 6c 61 73 74 2d start-time last-
6190: 74 69 6d 65 29 20 36 30 29 29 0a 09 09 20 20 28 time) 60))... (
61a0: 62 65 67 69 6e 0a 09 09 20 20 20 20 28 73 65 74 begin... (set
61b0: 21 20 6c 61 73 74 2d 74 69 6d 65 20 73 74 61 72 ! last-time star
61c0: 74 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 28 64 t-time)... (d
61d0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
61e0: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
61f0: 6f 72 74 2a 20 22 74 69 6d 65 73 74 61 6d 70 20 ort* "timestamp
6200: 2d 3e 20 22 20 28 73 65 63 6f 6e 64 73 2d 3e 74 -> " (seconds->t
6210: 69 6d 65 2d 73 74 72 69 6e 67 20 28 63 75 72 72 ime-string (curr
6220: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 22 2c ent-seconds)) ",
6230: 20 74 69 6d 65 20 73 69 6e 63 65 20 73 74 61 72 time since star
6240: 74 20 2d 3e 20 22 20 28 73 65 63 6f 6e 64 73 2d t -> " (seconds-
6250: 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 28 >hr-min-sec (- (
6260: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
6270: 20 2a 74 69 6d 65 2d 7a 65 72 6f 2a 29 29 29 29 *time-zero*))))
6280: 29 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b 3b )).. .. ;;
6290: 20 6b 65 65 70 20 67 6f 69 6e 67 20 75 6e 6c 65 keep going unle
62a0: 73 73 20 74 69 6d 65 20 74 6f 20 65 78 69 74 0a ss time to exit.
62b0: 09 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 69 66 . ;;.. (if
62c0: 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 (not *time-to-e
62d0: 78 69 74 2a 29 0a 09 09 28 6c 65 74 20 64 65 6c xit*)...(let del
62e0: 61 79 2d 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 ay-loop ((count
62f0: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
6300: 20 20 20 20 20 20 3b 3b 28 42 42 3e 20 22 64 65 ;;(BB> "de
6310: 6c 61 79 2d 6c 6f 6f 70 20 74 6f 70 3b 20 63 6f lay-loop top; co
6320: 75 6e 74 3d 22 63 6f 75 6e 74 22 20 70 69 64 3d unt="count" pid=
6330: 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 "(current-proces
6340: 73 2d 69 64 29 22 20 74 68 69 73 2d 77 64 2d 6e s-id)" this-wd-n
6350: 75 6d 3d 22 74 68 69 73 2d 77 64 2d 6e 75 6d 22 um="this-wd-num"
6360: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 3d *time-to-exit*=
6370: 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 "*time-to-exit*)
6380: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
63b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 09 09 ...
63c0: 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 (if (and (not
63d0: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a *time-to-exit*).
63e0: 09 09 09 20 20 20 28 3c 20 63 6f 75 6e 74 20 34 ... (< count 4
63f0: 29 29 20 3b 3b 20 77 61 73 20 31 31 2c 20 63 68 )) ;; was 11, ch
6400: 61 6e 67 69 6e 67 20 74 6f 20 34 2e 20 0a 09 09 anging to 4. ...
6410: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
6420: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
6430: 29 0a 09 09 09 28 64 65 6c 61 79 2d 6c 6f 6f 70 )....(delay-loop
6440: 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 29 0a (+ count 1)))).
6450: 09 09 20 20 28 69 66 20 28 6e 6f 74 20 2a 74 69 .. (if (not *ti
6460: 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 20 28 6c 6f me-to-exit*) (lo
6470: 6f 70 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 op)))).. (if
6480: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
6490: 65 2d 70 72 69 6e 74 20 33 30 29 0a 09 09 28 64 e-print 30)...(d
64a0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
64b0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
64c0: 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 77 61 ort* "Exiting wa
64d0: 74 63 68 64 6f 67 20 74 69 6d 65 72 2c 20 2a 74 tchdog timer, *t
64e0: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3d 20 22 ime-to-exit* = "
64f0: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 22 *time-to-exit*"
6500: 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 pid="(current-p
6510: 72 6f 63 65 73 73 2d 69 64 29 22 20 74 68 69 73 rocess-id)" this
6520: 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 64 -wd-num="this-wd
6530: 2d 6e 75 6d 29 29 29 29 29 29 29 0a 0a 28 64 65 -num)))))))..(de
6540: 66 69 6e 65 20 28 73 74 64 2d 65 78 69 74 2d 70 fine (std-exit-p
6550: 72 6f 63 65 64 75 72 65 20 61 72 65 61 2d 64 61 rocedure area-da
6560: 74 29 0a 20 20 28 6f 6e 2d 65 78 69 74 20 28 6c t). (on-exit (l
6570: 61 6d 62 64 61 20 28 29 20 30 29 29 0a 20 20 3b ambda () 0)). ;
6580: 3b 28 42 42 3e 20 22 73 74 64 2d 65 78 69 74 2d ;(BB> "std-exit-
6590: 70 72 6f 63 65 64 75 72 65 20 63 61 6c 6c 65 64 procedure called
65a0: 3b 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a ; *time-to-exit*
65b0: 3d 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a ="*time-to-exit*
65c0: 29 0a 20 20 28 6c 65 74 20 28 28 6e 6f 2d 68 75 ). (let ((no-hu
65d0: 72 72 79 20 20 28 69 66 20 2a 74 69 6d 65 2d 74 rry (if *time-t
65e0: 6f 2d 65 78 69 74 2a 20 3b 3b 20 68 75 72 72 79 o-exit* ;; hurry
65f0: 20 75 70 0a 09 09 20 20 20 20 20 20 20 23 66 0a up... #f.
6600: 09 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a .. (begin.
6610: 09 09 09 20 28 73 65 74 21 20 2a 74 69 6d 65 2d ... (set! *time-
6620: 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 09 09 to-exit* #t)....
6630: 20 23 74 29 29 29 29 0a 20 20 20 20 28 64 65 62 #t)))). (deb
6640: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 ug:print-info 4
6650: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6660: 74 2a 20 22 73 74 61 72 74 69 6e 67 20 65 78 69 t* "starting exi
6670: 74 20 70 72 6f 63 65 73 73 2c 20 66 69 6e 61 6c t process, final
6680: 69 7a 69 6e 67 20 64 61 74 61 62 61 73 65 73 2e izing databases.
6690: 22 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 "). (if (and
66a0: 6e 6f 2d 68 75 72 72 79 20 28 64 65 62 75 67 3a no-hurry (debug:
66b0: 64 65 62 75 67 2d 6d 6f 64 65 20 31 38 29 29 0a debug-mode 18)).
66c0: 09 28 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 .(rmt:print-db-s
66d0: 74 61 74 73 20 61 72 65 61 2d 64 61 74 29 29 0a tats area-dat)).
66e0: 20 20 20 20 28 6c 65 74 20 28 28 74 68 31 20 28 (let ((th1 (
66f0: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
6700: 62 64 61 20 28 29 20 3b 3b 20 74 68 72 65 61 64 bda () ;; thread
6710: 20 66 6f 72 20 63 6c 65 61 6e 69 6e 67 20 75 70 for cleaning up
6720: 2c 20 67 69 76 65 20 69 74 20 66 69 76 65 20 73 , give it five s
6730: 65 63 6f 6e 64 73 0a 20 20 20 20 20 20 20 20 20 econds.
6740: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6750: 20 20 20 20 20 28 69 66 20 2a 64 62 73 74 72 75 (if *dbstru
6760: 63 74 2d 64 62 2a 20 28 64 62 3a 63 6c 6f 73 65 ct-db* (db:close
6770: 2d 61 6c 6c 20 2a 64 62 73 74 72 75 63 74 2d 64 -all *dbstruct-d
6780: 62 2a 29 29 20 3b 3b 20 6f 6e 65 20 73 65 63 6f b*)) ;; one seco
6790: 6e 64 20 61 6c 6c 6f 63 61 74 65 64 0a 09 09 09 nd allocated....
67a0: 20 20 20 20 20 20 28 69 66 20 2a 74 61 73 6b 2d (if *task-
67b0: 64 62 2a 20 20 20 20 0a 09 09 09 09 20 20 28 6c db* ..... (l
67c0: 65 74 20 28 28 64 62 20 28 63 64 72 20 2a 74 61 et ((db (cdr *ta
67d0: 73 6b 2d 64 62 2a 29 29 29 0a 09 09 09 09 20 20 sk-db*))).....
67e0: 20 20 28 69 66 20 28 73 71 6c 69 74 65 33 3a 64 (if (sqlite3:d
67f0: 61 74 61 62 61 73 65 3f 20 64 62 29 0a 09 09 09 atabase? db)....
6800: 09 09 28 62 65 67 69 6e 0a 09 09 09 09 09 20 20 ..(begin......
6810: 28 73 71 6c 69 74 65 33 3a 69 6e 74 65 72 72 75 (sqlite3:interru
6820: 70 74 21 20 64 62 29 0a 09 09 09 09 09 20 20 28 pt! db)...... (
6830: 73 71 6c 69 74 65 33 3a 66 69 6e 61 6c 69 7a 65 sqlite3:finalize
6840: 21 20 64 62 20 23 74 29 0a 09 09 09 09 09 20 20 ! db #t)......
6850: 3b 3b 20 28 76 65 63 74 6f 72 2d 73 65 74 21 20 ;; (vector-set!
6860: 2a 74 61 73 6b 2d 64 62 2a 20 30 20 23 66 29 0a *task-db* 0 #f).
6870: 09 09 09 09 09 20 20 28 73 65 74 21 20 2a 74 61 ..... (set! *ta
6880: 73 6b 2d 64 62 2a 20 23 66 29 29 29 29 29 0a 20 sk-db* #f))))).
6890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
68a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
68b0: 20 28 61 6e 64 20 2a 72 75 6e 72 65 6d 6f 74 65 (and *runremote
68c0: 2a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 *.
68d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
68e0: 20 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 (remote
68f0: 2d 63 6f 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d -conndat *runrem
6900: 6f 74 65 2a 29 29 0a 20 20 20 20 20 20 20 20 20 ote*)).
6910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6920: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
6930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6950: 20 20 20 20 28 68 74 74 70 2d 63 6c 69 65 6e 74 (http-client
6960: 23 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 #close-all-conne
6970: 63 74 69 6f 6e 73 21 29 29 29 20 3b 3b 20 66 6f ctions!))) ;; fo
6980: 72 20 68 74 74 70 2d 63 6c 69 65 6e 74 0a 20 20 r http-client.
6990: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
69b0: 28 6e 6f 74 20 28 65 71 3f 20 2a 64 65 66 61 75 (not (eq? *defau
69c0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 lt-log-port* (cu
69d0: 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 rrent-error-port
69e0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
69f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6a00: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 (close-out
6a10: 70 75 74 2d 70 6f 72 74 20 2a 64 65 66 61 75 6c put-port *defaul
6a20: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 29 0a 09 09 t-log-port*))...
6a30: 09 20 20 20 20 20 20 28 73 65 74 21 20 2a 64 65 . (set! *de
6a40: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
6a50: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
6a60: 6f 72 74 29 29 29 20 22 43 6c 65 61 6e 75 70 20 ort))) "Cleanup
6a70: 64 62 20 65 78 69 74 20 74 68 72 65 61 64 22 29 db exit thread")
6a80: 29 0a 09 20 20 28 74 68 32 20 28 6d 61 6b 65 2d ).. (th2 (make-
6a90: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
6aa0: 29 0a 09 09 09 20 20 20 20 20 20 28 64 65 62 75 ).... (debu
6ab0: 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 g:print 4 *defau
6ac0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 41 74 lt-log-port* "At
6ad0: 74 65 6d 70 74 69 6e 67 20 63 6c 65 61 6e 20 65 tempting clean e
6ae0: 78 69 74 2e 20 50 6c 65 61 73 65 20 62 65 20 70 xit. Please be p
6af0: 61 74 69 65 6e 74 20 61 6e 64 20 77 61 69 74 20 atient and wait
6b00: 61 20 66 65 77 20 73 65 63 6f 6e 64 73 2e 2e 2e a few seconds...
6b10: 22 29 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ").... (if
6b20: 6e 6f 2d 68 75 72 72 79 0a 20 20 20 20 20 20 20 no-hurry.
6b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b40: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
6b50: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
6b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6b70: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
6b80: 65 65 70 21 20 35 29 29 20 3b 3b 20 67 69 76 65 eep! 5)) ;; give
6b90: 20 74 68 65 20 63 6c 65 61 6e 20 75 70 20 66 65 the clean up fe
6ba0: 77 20 73 65 63 6f 6e 64 73 20 74 6f 20 64 6f 20 w seconds to do
6bb0: 69 74 27 73 20 73 74 75 66 66 0a 20 20 20 20 20 it's stuff.
6bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
6bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
6be0: 67 69 6e 0a 20 20 20 20 20 20 09 09 09 09 20 20 gin. ....
6bf0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
6c00: 29 29 29 0a 20 20 20 20 20 20 09 09 09 20 20 20 ))). ...
6c10: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
6c20: 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
6c30: 6f 72 74 2a 20 22 20 2e 2e 2e 20 64 6f 6e 65 22 ort* " ... done"
6c40: 29 0a 20 20 20 20 20 20 09 09 09 20 20 20 20 20 ). ...
6c50: 20 29 0a 09 09 09 20 20 20 20 22 63 6c 65 61 6e ).... "clean
6c60: 20 65 78 69 74 22 29 29 29 0a 20 20 20 20 20 20 exit"))).
6c70: 28 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 (thread-start! t
6c80: 68 31 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 h1). (threa
6c90: 64 2d 73 74 61 72 74 21 20 74 68 32 29 0a 20 20 d-start! th2).
6ca0: 20 20 20 20 28 74 68 72 65 61 64 2d 6a 6f 69 6e (thread-join
6cb0: 21 20 74 68 31 29 0a 20 20 20 20 20 20 29 0a 20 ! th1). ).
6cc0: 20 20 20 29 0a 0a 20 20 30 29 0a 0a 28 64 65 66 ).. 0)..(def
6cd0: 69 6e 65 20 28 73 74 64 2d 73 69 67 6e 61 6c 2d ine (std-signal-
6ce0: 68 61 6e 64 6c 65 72 20 73 69 67 6e 75 6d 29 0a handler signum).
6cf0: 20 20 3b 3b 20 28 73 69 67 6e 61 6c 2d 6d 61 73 ;; (signal-mas
6d00: 6b 21 20 73 69 67 6e 75 6d 29 0a 20 20 28 73 65 k! signum). (se
6d10: 74 21 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 t! *time-to-exit
6d20: 2a 20 23 74 29 0a 20 20 3b 3b 28 42 42 3e 20 22 * #t). ;;(BB> "
6d30: 67 6f 74 20 73 69 67 6e 61 6c 20 22 73 69 67 6e got signal "sign
6d40: 75 6d 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 um). (debug:pri
6d50: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
6d60: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 ult-log-port* "R
6d70: 65 63 65 69 76 65 64 20 73 69 67 6e 61 6c 20 22 eceived signal "
6d80: 20 73 69 67 6e 75 6d 20 22 20 65 78 69 74 69 6e signum " exitin
6d90: 67 20 70 72 6f 6d 70 74 6c 79 22 29 0a 20 20 3b g promptly"). ;
6da0: 3b 20 28 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 ; (std-exit-proc
6db0: 65 64 75 72 65 29 20 3b 3b 20 73 68 6f 75 6c 64 edure) ;; should
6dc0: 6e 27 74 20 6e 65 65 64 20 74 68 69 73 20 73 69 n't need this si
6dd0: 6e 63 65 20 77 65 20 61 72 65 20 65 78 69 74 69 nce we are exiti
6de0: 6e 67 20 61 6e 64 20 69 74 20 77 69 6c 6c 20 62 ng and it will b
6df0: 65 20 63 61 6c 6c 65 64 20 61 6e 79 77 61 79 0a e called anyway.
6e00: 20 20 28 65 78 69 74 29 29 0a 0a 28 73 65 74 2d (exit))..(set-
6e10: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 signal-handler!
6e20: 73 69 67 6e 61 6c 2f 69 6e 74 20 20 73 74 64 2d signal/int std-
6e30: 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 signal-handler)
6e40: 20 3b 3b 20 5e 43 0a 28 73 65 74 2d 73 69 67 6e ;; ^C.(set-sign
6e50: 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e al-handler! sign
6e60: 61 6c 2f 74 65 72 6d 20 73 74 64 2d 73 69 67 6e al/term std-sign
6e70: 61 6c 2d 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 28 al-handler).;; (
6e80: 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c set-signal-handl
6e90: 65 72 21 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 er! signal/stop
6ea0: 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c std-signal-handl
6eb0: 65 72 29 20 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 er) ;; ^Z NO, d
6ec0: 6f 20 4e 4f 54 20 68 61 6e 64 6c 65 20 5e 5a 21 o NOT handle ^Z!
6ed0: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
6ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 ==========.;; M
6f20: 49 20 53 20 43 20 20 20 55 20 54 20 49 20 4c 20 I S C U T I L
6f30: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
6f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6f70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6f ==========..;; o
6f80: 6e 65 2d 6f 66 20 61 72 67 73 20 64 65 66 69 6e ne-of args defin
6f90: 65 64 0a 28 64 65 66 69 6e 65 20 28 61 72 67 73 ed.(define (args
6fa0: 2d 64 65 66 69 6e 65 64 3f 20 2e 20 70 61 72 61 -defined? . para
6fb0: 6d 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 m). (let ((res
6fc0: 23 66 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 #f)). (for-ea
6fd0: 63 68 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ch . (lambda
6fe0: 20 28 61 72 67 29 0a 20 20 20 20 20 20 20 28 69 (arg). (i
6ff0: 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 f (args:get-arg
7000: 61 72 67 29 28 73 65 74 21 20 72 65 73 20 23 74 arg)(set! res #t
7010: 29 29 29 0a 20 20 20 20 20 70 61 72 61 6d 29 0a ))). param).
7020: 20 20 20 20 72 65 73 29 29 0a 0a 3b 3b 20 63 6f res))..;; co
7030: 6e 76 65 72 74 20 73 74 75 66 66 20 74 6f 20 61 nvert stuff to a
7040: 20 6e 75 6d 62 65 72 20 69 66 20 70 6f 73 73 69 number if possi
7050: 62 6c 65 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 ble.(define (any
7060: 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 ->number val).
7070: 28 63 6f 6e 64 20 0a 20 20 20 28 28 6e 75 6d 62 (cond . ((numb
7080: 65 72 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 er? val) val).
7090: 20 28 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 ((string? val)
70a0: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
70b0: 76 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f val)). ((symbo
70c0: 6c 3f 20 76 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 l? val) (any->nu
70d0: 6d 62 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 mber (symbol->st
70e0: 72 69 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 28 ring val))). (
70f0: 65 6c 73 65 20 23 66 29 29 29 0a 0a 28 64 65 66 else #f)))..(def
7100: 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 ine (any->number
7110: 2d 69 66 2d 70 6f 73 73 69 62 6c 65 20 76 61 6c -if-possible val
7120: 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 20 28 ). (let ((num (
7130: 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 any->number val)
7140: 29 29 0a 20 20 20 20 28 69 66 20 6e 75 6d 20 6e )). (if num n
7150: 75 6d 20 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 um val)))..(defi
7160: 6e 65 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 ne (patt-list-ma
7170: 74 63 68 20 69 74 65 6d 20 70 61 74 74 73 29 0a tch item patts).
7180: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7190: 6e 66 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 8 *default-l
71a0: 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 2d 6c og-port* "patt-l
71b0: 69 73 74 2d 6d 61 74 63 68 20 69 74 65 6d 3d 22 ist-match item="
71c0: 20 69 74 65 6d 20 22 20 70 61 74 74 73 3d 22 20 item " patts="
71d0: 70 61 74 74 73 29 0a 20 20 28 69 66 20 28 61 6e patts). (if (an
71e0: 64 20 69 74 65 6d 20 70 61 74 74 73 29 20 20 3b d item patts) ;
71f0: 3b 20 68 65 72 65 20 77 65 20 61 72 65 20 66 69 ; here we are fi
7200: 6c 74 65 72 69 6e 67 20 66 6f 72 20 6d 61 74 63 ltering for matc
7210: 68 65 73 20 77 69 74 68 20 69 74 65 6d 20 70 61 hes with item pa
7220: 74 74 65 72 6e 73 0a 20 20 20 20 20 20 28 6c 65 tterns. (le
7230: 74 20 28 28 72 65 73 20 23 66 29 29 20 20 20 3b t ((res #f)) ;
7240: 3b 20 6c 6f 6f 6b 20 74 68 72 6f 75 67 68 20 61 ; look through a
7250: 6c 6c 20 74 68 65 20 69 74 65 6d 2d 70 61 74 74 ll the item-patt
7260: 73 20 69 66 20 64 65 66 69 6e 65 64 2c 20 66 6f s if defined, fo
7270: 72 6d 61 74 20 69 73 20 70 61 74 74 31 2c 70 61 rmat is patt1,pa
7280: 74 74 32 2c 70 61 74 74 33 20 2e 2e 2e 20 77 69 tt2,patt3 ... wi
7290: 6c 64 63 61 72 64 20 69 73 20 25 0a 09 28 66 6f ldcard is %..(fo
72a0: 72 2d 65 61 63 68 20 0a 09 20 28 6c 61 6d 62 64 r-each .. (lambd
72b0: 61 20 28 70 61 74 74 29 0a 09 20 20 20 28 6c 65 a (patt).. (le
72c0: 74 20 28 28 6d 6f 64 70 61 74 74 20 28 73 74 72 t ((modpatt (str
72d0: 69 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 ing-substitute "
72e0: 25 22 20 22 2e 2a 22 20 70 61 74 74 20 23 74 29 %" ".*" patt #t)
72f0: 29 29 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a )).. (debug:
7300: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 30 20 2a 64 print-info 10 *d
7310: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
7320: 20 22 70 61 74 74 20 22 20 70 61 74 74 20 22 20 "patt " patt "
7330: 6d 6f 64 70 61 74 74 20 22 20 6d 6f 64 70 61 74 modpatt " modpat
7340: 74 29 0a 09 20 20 20 20 20 28 69 66 20 28 73 74 t).. (if (st
7350: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
7360: 78 70 20 6d 6f 64 70 61 74 74 29 20 69 74 65 6d xp modpatt) item
7370: 29 0a 09 09 20 28 73 65 74 21 20 72 65 73 20 23 )... (set! res #
7380: 74 29 29 29 29 0a 09 20 28 73 74 72 69 6e 67 2d t)))).. (string-
7390: 73 70 6c 69 74 20 70 61 74 74 73 20 22 2c 22 29 split patts ",")
73a0: 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 23 74 )..res). #t
73b0: 29 29 0a 0a 3b 3b 20 28 6d 61 70 20 70 72 69 6e ))..;; (map prin
73c0: 74 20 28 6d 61 70 20 63 61 72 20 28 68 61 73 68 t (map car (hash
73d0: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 28 72 -table->alist (r
73e0: 65 61 64 2d 63 6f 6e 66 69 67 20 22 72 75 6e 63 ead-config "runc
73f0: 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 20 23 onfigs.config" #
7400: 66 20 23 74 29 29 29 29 0a 28 64 65 66 69 6e 65 f #t)))).(define
7410: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 75 6e (common:get-run
7420: 63 6f 6e 66 69 67 2d 74 61 72 67 65 74 73 20 23 config-targets #
7430: 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 !key (configf #f
7440: 29 29 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 )). (let ((targ
7450: 73 20 20 20 20 20 20 20 28 73 6f 72 74 20 28 6d s (sort (m
7460: 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 ap car (hash-tab
7470: 6c 65 2d 3e 61 6c 69 73 74 0a 09 09 09 09 20 20 le->alist.....
7480: 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 0a 09 (or configf..
7490: 09 09 09 09 20 28 72 65 61 64 2d 63 6f 6e 66 69 .... (read-confi
74a0: 67 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 g (conc *toppath
74b0: 2a 20 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 * "/runconfigs.c
74c0: 6f 6e 66 69 67 22 29 0a 09 09 09 09 09 09 20 20 onfig").......
74d0: 20 20 20 20 23 66 20 23 74 29 0a 09 09 09 09 09 #f #t)......
74e0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
74f0: 65 29 29 29 29 0a 09 09 09 20 20 20 73 74 72 69 e)))).... stri
7500: 6e 67 3c 3f 29 29 0a 09 28 74 61 72 67 65 74 2d ng<?))..(target-
7510: 70 61 74 74 20 28 61 72 67 73 3a 67 65 74 2d 61 patt (args:get-a
7520: 72 67 20 22 2d 74 61 72 67 65 74 22 29 29 29 0a rg "-target"))).
7530: 20 20 20 20 28 69 66 20 74 61 72 67 65 74 2d 70 (if target-p
7540: 61 74 74 0a 09 28 66 69 6c 74 65 72 20 28 6c 61 att..(filter (la
7550: 6d 62 64 61 20 28 78 29 0a 09 09 20 20 28 70 61 mbda (x)... (pa
7560: 74 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 78 20 tt-list-match x
7570: 74 61 72 67 65 74 2d 70 61 74 74 29 29 0a 09 09 target-patt))...
7580: 74 61 72 67 73 29 0a 09 74 61 72 67 73 29 29 29 targs)..targs)))
7590: 0a 0a 3b 3b 20 27 28 70 72 69 6e 74 20 28 73 74 ..;; '(print (st
75a0: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
75b0: 20 28 6d 61 70 20 63 61 64 72 20 28 68 61 73 68 (map cadr (hash
75c0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
75d0: 6c 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 lt (read-config
75e0: 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 "megatest.config
75f0: 22 20 5c 23 66 20 5c 23 74 29 20 22 64 69 73 6b " \#f \#t) "disk
7600: 73 22 20 27 22 27 22 27 28 22 6e 6f 6e 65 22 20 s" '"'"'("none"
7610: 22 22 29 29 29 20 22 5c 6e 22 29 29 27 0a 28 64 ""))) "\n"))'.(d
7620: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
7630: 74 2d 64 69 73 6b 73 20 23 21 6b 65 79 20 28 63 t-disks #!key (c
7640: 6f 6e 66 69 67 66 20 23 66 29 29 0a 20 20 28 68 onfigf #f)). (h
7650: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7660: 66 61 75 6c 74 20 0a 20 20 20 28 6f 72 20 63 6f fault . (or co
7670: 6e 66 69 67 66 20 28 72 65 61 64 2d 63 6f 6e 66 nfigf (read-conf
7680: 69 67 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e ig "megatest.con
7690: 66 69 67 22 20 23 66 20 23 74 29 29 0a 20 20 20 fig" #f #t)).
76a0: 22 64 69 73 6b 73 22 20 27 28 22 6e 6f 6e 65 22 "disks" '("none"
76b0: 20 22 22 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 "")))..;; retur
76c0: 6e 20 66 69 72 73 74 20 63 6f 6d 6d 61 6e 64 20 n first command
76d0: 74 68 61 74 20 65 78 69 73 74 73 2c 20 65 6c 73 that exists, els
76e0: 65 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 e #f.;;.(define
76f0: 28 63 6f 6d 6d 6f 6e 3a 77 68 69 63 68 20 63 6d (common:which cm
7700: 64 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f ds). (if (null?
7710: 20 63 6d 64 73 29 0a 20 20 20 20 20 20 23 66 0a cmds). #f.
7720: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
7730: 28 28 68 65 64 20 28 63 61 72 20 63 6d 64 73 29 ((hed (car cmds)
7740: 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 63 )... (tal (cdr c
7750: 6d 64 73 29 29 29 0a 09 28 6c 65 74 20 28 28 72 mds)))..(let ((r
7760: 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 es (with-input-f
7770: 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 rom-pipe (conc "
7780: 77 68 69 63 68 20 22 20 68 65 64 29 20 72 65 61 which " hed) rea
7790: 64 2d 6c 69 6e 65 29 29 29 0a 09 20 20 28 69 66 d-line))).. (if
77a0: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 72 (and (string? r
77b0: 65 73 29 0a 09 09 20 20 20 28 66 69 6c 65 2d 65 es)... (file-e
77c0: 78 69 73 74 73 3f 20 72 65 73 29 29 0a 09 20 20 xists? res))..
77d0: 20 20 20 20 72 65 73 0a 09 20 20 20 20 20 20 28 res.. (
77e0: 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
77f0: 09 20 20 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 . #f... (loop
7800: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
7810: 6c 29 29 29 29 29 29 29 29 0a 20 20 0a 28 64 65 l)))))))). .(de
7820: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
7830: 2d 69 6e 73 74 61 6c 6c 2d 61 72 65 61 29 0a 20 -install-area).
7840: 20 28 6c 65 74 20 28 28 65 78 65 2d 70 61 74 68 (let ((exe-path
7850: 20 28 63 61 72 20 28 61 72 67 76 29 29 29 29 0a (car (argv)))).
7860: 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 (if (file-ex
7870: 69 73 74 73 3f 20 65 78 65 2d 70 61 74 68 29 0a ists? exe-path).
7880: 09 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 .(handle-excepti
7890: 6f 6e 73 0a 09 20 65 78 6e 0a 09 20 23 66 0a 09 ons.. exn.. #f..
78a0: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
78b0: 74 6f 72 79 0a 09 20 20 28 70 61 74 68 6e 61 6d tory.. (pathnam
78c0: 65 2d 64 69 72 65 63 74 6f 72 79 20 0a 09 20 20 e-directory ..
78d0: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
78e0: 74 6f 72 79 20 65 78 65 2d 70 61 74 68 29 29 29 tory exe-path)))
78f0: 29 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 72 65 74 )..#f)))..;; ret
7900: 75 72 6e 20 66 69 72 73 74 20 70 61 74 68 20 74 urn first path t
7910: 68 61 74 20 63 61 6e 20 62 65 20 63 72 65 61 74 hat can be creat
7920: 65 64 20 6f 72 20 61 6c 72 65 61 64 79 20 65 78 ed or already ex
7930: 69 73 74 73 20 61 6e 64 20 69 73 20 77 72 69 74 ists and is writ
7940: 61 62 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 able.;;.(define
7950: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 (common:get-crea
7960: 74 65 2d 77 72 69 74 65 61 62 6c 65 2d 64 69 72 te-writeable-dir
7970: 20 64 69 72 73 29 0a 20 20 28 69 66 20 28 6e 75 dirs). (if (nu
7980: 6c 6c 3f 20 64 69 72 73 29 0a 20 20 20 20 20 20 ll? dirs).
7990: 23 66 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f #f. (let lo
79a0: 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 64 69 op ((hed (car di
79b0: 72 73 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 rs))... (tal (cd
79c0: 72 20 64 69 72 73 29 29 29 0a 09 28 6c 65 74 20 r dirs)))..(let
79d0: 28 28 72 65 73 20 28 6f 72 20 28 61 6e 64 20 28 ((res (or (and (
79e0: 64 69 72 65 63 74 6f 72 79 3f 20 68 65 64 29 0a directory? hed).
79f0: 09 09 09 20 20 20 20 28 66 69 6c 65 2d 77 72 69 ... (file-wri
7a00: 74 65 2d 61 63 63 65 73 73 3f 20 68 65 64 29 0a te-access? hed).
7a10: 09 09 09 20 20 20 20 68 65 64 29 0a 09 09 20 20 ... hed)...
7a20: 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 (handle-exc
7a30: 65 70 74 69 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 eptions....exn..
7a40: 09 09 23 66 0a 09 09 09 28 63 72 65 61 74 65 2d ..#f....(create-
7a50: 64 69 72 65 63 74 6f 72 79 20 68 65 64 20 23 74 directory hed #t
7a60: 29 29 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e ))))).. (if (an
7a70: 64 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a d (string? res).
7a80: 09 09 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f .. (directory?
7a90: 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 res)).. re
7aa0: 73 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 s.. (if (nu
7ab0: 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a ll? tal)... #f.
7ac0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 .. (loop (car t
7ad0: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
7ae0: 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ))). .;;=======
7af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7b20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
7b30: 3b 3b 20 54 20 41 20 52 20 47 20 45 20 54 20 53 ;; T A R G E T S
7b40: 20 20 2c 20 20 20 53 20 54 20 41 20 54 20 45 20 , S T A T E
7b50: 2c 20 20 20 53 20 54 20 41 20 54 20 55 20 53 20 , S T A T U S
7b60: 2c 20 20 20 0a 3b 3b 20 20 20 20 20 20 20 20 20 , .;;
7b70: 20 20 20 20 20 20 20 20 20 20 20 52 20 55 20 4e R U N
7b80: 20 4e 20 41 20 4d 20 45 20 20 20 20 41 20 4e 20 N A M E A N
7b90: 44 20 20 20 54 20 45 20 53 20 54 20 50 20 41 20 D T E S T P A
7ba0: 54 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d T T.;;==========
7bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7bc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7bd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7be0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
7bf0: 20 4c 6f 6f 6b 75 70 20 61 20 76 61 6c 75 65 20 Lookup a value
7c00: 69 6e 20 72 75 6e 63 6f 6e 66 69 67 73 20 62 61 in runconfigs ba
7c10: 73 65 64 20 6f 6e 20 2d 72 65 71 74 61 72 67 20 sed on -reqtarg
7c20: 6f 72 20 2d 74 61 72 67 65 74 0a 28 64 65 66 69 or -target.(defi
7c30: 6e 65 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 ne (runconfigs-g
7c40: 65 74 20 63 6f 6e 66 69 67 20 76 61 72 29 0a 20 et config var).
7c50: 20 28 6c 65 74 20 28 28 74 61 72 67 20 28 63 6f (let ((targ (co
7c60: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 mmon:args-get-ta
7c70: 72 67 65 74 29 29 29 20 3b 3b 20 28 6f 72 20 28 rget))) ;; (or (
7c80: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 args:get-arg "-r
7c90: 65 71 74 61 72 67 22 29 28 61 72 67 73 3a 67 65 eqtarg")(args:ge
7ca0: 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 t-arg "-target")
7cb0: 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 47 (getenv "MT_TARG
7cc0: 45 54 22 29 29 29 29 0a 20 20 20 20 28 69 66 20 ET")))). (if
7cd0: 74 61 72 67 0a 09 28 6f 72 20 28 63 6f 6e 66 69 targ..(or (confi
7ce0: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
7cf0: 20 74 61 72 67 20 76 61 72 29 0a 09 20 20 20 20 targ var)..
7d00: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
7d10: 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 config "default"
7d20: 20 76 61 72 29 29 0a 09 28 63 6f 6e 66 69 67 66 var))..(configf
7d30: 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 :lookup config "
7d40: 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 29 29 default" var))))
7d50: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
7d60: 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 65 n:args-get-state
7d70: 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 ). (or (args:ge
7d80: 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 29 28 t-arg "-state")(
7d90: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
7da0: 74 61 74 65 22 29 29 29 0a 0a 28 64 65 66 69 6e tate")))..(defin
7db0: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 e (common:args-g
7dc0: 65 74 2d 73 74 61 74 75 73 29 0a 20 20 28 6f 72 et-status). (or
7dd0: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
7de0: 2d 73 74 61 74 75 73 22 29 28 61 72 67 73 3a 67 -status")(args:g
7df0: 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 22 et-arg ":status"
7e00: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
7e10: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 65 mmon:args-get-te
7e20: 73 74 70 61 74 74 20 61 72 65 61 2d 64 61 74 20 stpatt area-dat
7e30: 72 63 6f 6e 66 29 0a 20 20 28 6c 65 74 2a 20 28 rconf). (let* (
7e40: 28 74 61 67 65 78 70 72 20 28 61 72 67 73 3a 67 (tagexpr (args:g
7e50: 65 74 2d 61 72 67 20 22 2d 74 61 67 65 78 70 72 et-arg "-tagexpr
7e60: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 74 61 ")). (ta
7e70: 67 73 2d 74 65 73 74 70 61 74 74 20 28 69 66 20 gs-testpatt (if
7e80: 74 61 67 65 78 70 72 20 28 73 74 72 69 6e 67 2d tagexpr (string-
7e90: 6a 6f 69 6e 20 28 72 75 6e 73 3a 67 65 74 2d 74 join (runs:get-t
7ea0: 65 73 74 73 2d 6d 61 74 63 68 69 6e 67 2d 74 61 ests-matching-ta
7eb0: 67 73 20 61 72 65 61 2d 64 61 74 20 74 61 67 65 gs area-dat tage
7ec0: 78 70 72 29 20 22 2c 22 29 20 23 66 29 29 0a 20 xpr) ",") #f)).
7ed0: 20 20 20 20 20 20 20 20 28 74 65 73 74 70 61 74 (testpat
7ee0: 74 2d 6b 65 79 20 20 28 69 66 20 28 61 72 67 73 t-key (if (args
7ef0: 3a 67 65 74 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 :get-arg "--mode
7f00: 70 61 74 74 22 29 20 28 61 72 67 73 3a 67 65 74 patt") (args:get
7f10: 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 70 61 74 74 -arg "--modepatt
7f20: 22 29 20 22 54 45 53 54 50 41 54 54 22 29 29 0a ") "TESTPATT")).
7f30: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 2d 74 (args-t
7f40: 65 73 74 70 61 74 74 20 28 6f 72 20 28 61 72 67 estpatt (or (arg
7f50: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 s:get-arg "-test
7f60: 70 61 74 74 22 29 20 28 61 72 67 73 3a 67 65 74 patt") (args:get
7f70: 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 -arg "-runtests"
7f80: 29 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 ) "%")).
7f90: 20 28 72 74 65 73 74 70 61 74 74 20 20 20 20 20 (rtestpatt
7fa0: 28 69 66 20 72 63 6f 6e 66 20 28 72 75 6e 63 6f (if rconf (runco
7fb0: 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 20 nfigs-get rconf
7fc0: 74 65 73 74 70 61 74 74 2d 6b 65 79 29 20 23 66 testpatt-key) #f
7fd0: 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 ))). (cond.
7fe0: 20 20 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 (tags-testpat
7ff0: 74 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 t. (debug:p
8000: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
8010: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
8020: 2d 74 61 67 65 78 70 72 20 22 74 61 67 65 78 70 -tagexpr "tagexp
8030: 72 22 20 73 65 6c 65 63 74 73 20 74 65 73 74 70 r" selects testp
8040: 61 74 74 20 22 74 61 67 73 2d 74 65 73 74 70 61 att "tags-testpa
8050: 74 74 29 0a 20 20 20 20 20 20 74 61 67 73 2d 74 tt). tags-t
8060: 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 28 28 estpatt). ((
8070: 61 6e 64 20 28 65 71 75 61 6c 3f 20 61 72 67 73 and (equal? args
8080: 2d 74 65 73 74 70 61 74 74 20 22 25 22 29 20 72 -testpatt "%") r
8090: 74 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 20 testpatt).
80a0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
80b0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
80c0: 2d 70 6f 72 74 2a 20 22 74 65 73 74 70 61 74 74 -port* "testpatt
80d0: 20 64 65 66 69 6e 65 64 20 69 6e 20 22 74 65 73 defined in "tes
80e0: 74 70 61 74 74 2d 6b 65 79 22 20 66 72 6f 6d 20 tpatt-key" from
80f0: 72 75 6e 63 6f 6e 66 69 67 73 3a 20 22 20 72 74 runconfigs: " rt
8100: 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 20 72 estpatt). r
8110: 74 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 28 testpatt). (
8120: 65 6c 73 65 20 61 72 67 73 2d 74 65 73 74 70 61 else args-testpa
8130: 74 74 29 29 29 29 0a 20 20 20 20 20 0a 28 64 65 tt)))). .(de
8140: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
8150: 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 20 28 6f 72 -linktree). (or
8160: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e (getenv "MT_LIN
8170: 4b 54 52 45 45 22 29 0a 20 20 20 20 20 20 28 69 KTREE"). (i
8180: 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 20 f *configdat*..
8190: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
81a0: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
81b0: 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 tup" "linktree")
81c0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
81d0: 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 72 75 mmon:args-get-ru
81e0: 6e 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 nname). (let ((
81f0: 72 65 73 20 28 6f 72 20 28 61 72 67 73 3a 67 65 res (or (args:ge
8200: 74 2d 61 72 67 20 22 2d 72 75 6e 6e 61 6d 65 22 t-arg "-runname"
8210: 29 0a 09 09 20 28 61 72 67 73 3a 67 65 74 2d 61 )... (args:get-a
8220: 72 67 20 22 3a 72 75 6e 6e 61 6d 65 22 29 0a 09 rg ":runname")..
8230: 09 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 52 55 . (getenv "MT_RU
8240: 4e 4e 41 4d 45 22 29 29 29 29 0a 20 20 20 20 3b NNAME")))). ;
8250: 3b 20 28 69 66 20 72 65 73 20 28 73 65 74 2d 65 ; (if res (set-e
8260: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
8270: 62 6c 65 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 ble "MT_RUNNAME"
8280: 20 72 65 73 29 29 20 3b 3b 20 6e 6f 74 20 73 75 res)) ;; not su
8290: 72 65 20 69 66 20 74 68 69 73 20 69 73 20 61 20 re if this is a
82a0: 67 6f 6f 64 20 69 64 65 61 2e 20 73 69 64 65 20 good idea. side
82b0: 65 66 66 65 63 74 20 61 6e 64 20 61 6c 6c 20 2e effect and all .
82c0: 2e 2e 0a 20 20 20 20 72 65 73 29 29 0a 0a 28 64 ... res))..(d
82d0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 efine (common:ar
82e0: 67 73 2d 67 65 74 2d 74 61 72 67 65 74 20 23 21 gs-get-target #!
82f0: 6b 65 79 20 28 73 70 6c 69 74 20 23 66 29 29 0a key (split #f)).
8300: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 73 20 20 (let* ((keys
8310: 20 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c (if (hash-tabl
8320: 65 3f 20 2a 63 6f 6e 66 69 67 64 61 74 2a 29 20 e? *configdat*)
8330: 28 6b 65 79 73 3a 63 6f 6e 66 69 67 2d 67 65 74 (keys:config-get
8340: 2d 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 -fields *configd
8350: 61 74 2a 29 20 27 28 29 29 29 0a 09 20 28 6e 75 at*) '())).. (nu
8360: 6d 6b 65 79 73 20 28 6c 65 6e 67 74 68 20 6b 65 mkeys (length ke
8370: 79 73 29 29 0a 09 20 28 74 61 72 67 65 74 20 20 ys)).. (target
8380: 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 (or (args:get-ar
8390: 67 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 g "-reqtarg")...
83a0: 20 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d (args:get-
83b0: 61 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 arg "-target")..
83c0: 09 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 . (getenv "
83d0: 4d 54 5f 54 41 52 47 45 54 22 29 29 29 0a 09 20 MT_TARGET")))..
83e0: 28 74 6c 69 73 74 20 20 20 28 69 66 20 74 61 72 (tlist (if tar
83f0: 67 65 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 get (string-spli
8400: 74 20 74 61 72 67 65 74 20 22 2f 22 20 23 74 29 t target "/" #t)
8410: 20 27 28 29 29 29 0a 09 20 28 76 61 6c 69 64 20 '())).. (valid
8420: 20 20 28 69 66 20 74 61 72 67 65 74 0a 09 09 20 (if target...
8430: 20 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 (or (null?
8440: 6b 65 79 73 29 20 3b 3b 20 70 72 6f 62 61 62 6c keys) ;; probabl
8450: 79 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 6f 75 72 y don't know our
8460: 20 6b 65 79 73 20 79 65 74 0a 09 09 09 20 20 28 keys yet.... (
8470: 61 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 and (not (null?
8480: 74 6c 69 73 74 29 29 0a 09 09 09 20 20 20 20 20 tlist))....
8490: 20 20 28 65 71 3f 20 6e 75 6d 6b 65 79 73 20 28 (eq? numkeys (
84a0: 6c 65 6e 67 74 68 20 74 6c 69 73 74 29 29 0a 09 length tlist))..
84b0: 09 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 .. (null?
84c0: 28 66 69 6c 74 65 72 20 73 74 72 69 6e 67 2d 6e (filter string-n
84d0: 75 6c 6c 3f 20 74 6c 69 73 74 29 29 29 29 0a 09 ull? tlist))))..
84e0: 09 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 . #f))).
84f0: 20 28 69 66 20 76 61 6c 69 64 0a 09 28 69 66 20 (if valid..(if
8500: 73 70 6c 69 74 0a 09 20 20 20 20 74 6c 69 73 74 split.. tlist
8510: 0a 09 20 20 20 20 74 61 72 67 65 74 29 0a 09 28 .. target)..(
8520: 69 66 20 74 61 72 67 65 74 0a 09 20 20 20 20 28 if target.. (
8530: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 begin.. (de
8540: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
8550: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
8560: 6f 72 74 2a 20 22 49 6e 76 61 6c 69 64 20 74 61 ort* "Invalid ta
8570: 72 67 65 74 2c 20 73 70 61 63 65 73 20 6f 72 20 rget, spaces or
8580: 62 6c 61 6e 6b 73 20 6e 6f 74 20 61 6c 6c 6f 77 blanks not allow
8590: 65 64 20 5c 22 22 20 74 61 72 67 65 74 20 22 5c ed \"" target "\
85a0: 22 2c 20 74 61 72 67 65 74 20 73 68 6f 75 6c 64 ", target should
85b0: 20 62 65 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 be: " (string-i
85c0: 6e 74 65 72 73 70 65 72 73 65 20 6b 65 79 73 20 ntersperse keys
85d0: 22 2f 22 29 20 22 2c 20 68 61 76 65 20 22 20 74 "/") ", have " t
85e0: 6c 69 73 74 20 22 20 66 6f 72 20 65 6c 65 6d 65 list " for eleme
85f0: 6e 74 73 22 29 0a 09 20 20 20 20 20 20 23 66 29 nts").. #f)
8600: 0a 09 20 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b .. #f))))..;;
8610: 20 6c 6f 67 69 63 20 66 6f 72 20 67 65 74 74 69 logic for getti
8620: 6e 67 20 68 6f 6d 65 68 6f 73 74 2e 20 52 65 74 ng homehost. Ret
8630: 75 72 6e 73 20 28 68 6f 73 74 20 2e 20 61 74 2d urns (host . at-
8640: 68 6f 6d 65 29 0a 3b 3b 20 49 46 20 2a 74 6f 70 home).;; IF *top
8650: 70 61 74 68 2a 20 69 73 20 6e 6f 74 20 73 65 74 path* is not set
8660: 2c 20 77 61 69 74 20 75 70 20 74 6f 20 66 69 76 , wait up to fiv
8670: 65 20 73 65 63 6f 6e 64 73 20 74 72 79 69 6e 67 e seconds trying
8680: 20 65 76 65 72 79 20 74 77 6f 20 73 65 63 6f 6e every two secon
8690: 64 73 0a 3b 3b 20 28 74 68 69 73 20 69 73 20 74 ds.;; (this is t
86a0: 6f 20 61 63 63 6f 6d 6f 64 61 74 65 20 74 68 65 o accomodate the
86b0: 20 77 61 74 63 68 64 6f 67 29 0a 3b 3b 0a 28 64 watchdog).;;.(d
86c0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
86d0: 74 2d 68 6f 6d 65 68 6f 73 74 20 23 21 6b 65 79 t-homehost #!key
86e0: 20 28 74 72 79 6e 75 6d 20 35 29 29 0a 20 20 3b (trynum 5)). ;
86f0: 3b 20 63 61 6c 6c 65 64 20 6f 66 74 65 6e 20 65 ; called often e
8700: 73 70 65 63 69 61 6c 6c 79 20 61 74 20 73 74 61 specially at sta
8710: 72 74 20 75 70 2e 20 75 73 65 20 6d 75 74 65 78 rt up. use mutex
8720: 20 74 6f 20 65 6c 69 6d 69 6e 61 74 65 20 63 6f to eliminate co
8730: 6c 6c 69 73 69 6f 6e 73 0a 20 20 28 6d 75 74 65 llisions. (mute
8740: 78 2d 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 x-lock! *homehos
8750: 74 2d 6d 75 74 65 78 2a 29 0a 20 20 28 63 6f 6e t-mutex*). (con
8760: 64 0a 20 20 20 28 2a 68 6f 6d 65 2d 68 6f 73 74 d. (*home-host
8770: 2a 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c *. (mutex-unl
8780: 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d ock! *homehost-m
8790: 75 74 65 78 2a 29 0a 20 20 20 20 2a 68 6f 6d 65 utex*). *home
87a0: 2d 68 6f 73 74 2a 29 0a 20 20 20 28 28 6e 6f 74 -host*). ((not
87b0: 20 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 *toppath*).
87c0: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
87d0: 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 homehost-mutex*)
87e0: 0a 20 20 20 20 28 6c 61 75 6e 63 68 3a 73 65 74 . (launch:set
87f0: 75 70 29 20 3b 3b 20 73 61 66 65 6c 79 20 6d 75 up) ;; safely mu
8800: 74 65 78 65 64 20 6e 6f 77 0a 20 20 20 20 28 69 texed now. (i
8810: 66 20 28 3e 20 74 72 79 6e 75 6d 20 30 29 0a 09 f (> trynum 0)..
8820: 28 62 65 67 69 6e 0a 09 20 20 28 74 68 72 65 61 (begin.. (threa
8830: 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 20 20 28 d-sleep! 2).. (
8840: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 common:get-homeh
8850: 6f 73 74 20 74 72 79 6e 75 6d 3a 20 28 2d 20 74 ost trynum: (- t
8860: 72 79 6e 75 6d 20 31 29 29 29 0a 09 23 66 29 29 rynum 1)))..#f))
8870: 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 6c . (else. (l
8880: 65 74 2a 20 28 28 63 75 72 72 68 6f 73 74 20 28 et* ((currhost (
8890: 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a get-host-name)).
88a0: 09 20 20 20 28 62 65 73 74 61 64 72 73 20 28 73 . (bestadrs (s
88b0: 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 erver:get-best-g
88c0: 75 65 73 73 2d 61 64 64 72 65 73 73 20 63 75 72 uess-address cur
88d0: 72 68 6f 73 74 29 29 0a 09 20 20 20 3b 3b 20 66 rhost)).. ;; f
88e0: 69 72 73 74 20 6c 6f 6f 6b 20 69 6e 20 63 6f 6e irst look in con
88f0: 66 69 67 2c 20 74 68 65 6e 20 6c 6f 6f 6b 20 69 fig, then look i
8900: 6e 20 66 69 6c 65 20 2e 68 6f 6d 65 68 6f 73 74 n file .homehost
8910: 2c 20 63 72 65 61 74 65 20 69 74 20 69 66 20 6e , create it if n
8920: 6f 74 20 66 6f 75 6e 64 0a 09 20 20 20 28 68 6f ot found.. (ho
8930: 6d 65 68 6f 73 74 20 28 6f 72 20 28 63 6f 6e 66 mehost (or (conf
8940: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
8950: 69 67 64 61 74 2a 20 22 73 65 72 76 65 72 22 20 igdat* "server"
8960: 22 68 6f 6d 65 68 6f 73 74 22 20 29 0a 09 09 09 "homehost" )....
8970: 20 28 6c 65 74 20 28 28 68 68 66 20 28 63 6f 6e (let ((hhf (con
8980: 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e 68 c *toppath* "/.h
8990: 6f 6d 65 68 6f 73 74 22 29 29 29 0a 09 09 09 20 omehost")))....
89a0: 20 20 28 69 66 20 28 66 69 6c 65 2d 65 78 69 73 (if (file-exis
89b0: 74 73 3f 20 68 68 66 29 0a 09 09 09 20 20 20 20 ts? hhf)....
89c0: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
89d0: 72 6f 6d 2d 66 69 6c 65 20 68 68 66 20 72 65 61 rom-file hhf rea
89e0: 64 2d 6c 69 6e 65 29 0a 09 09 09 20 20 20 20 20 d-line)....
89f0: 20 20 28 69 66 20 28 66 69 6c 65 2d 77 72 69 74 (if (file-writ
8a00: 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 70 61 e-access? *toppa
8a10: 74 68 2a 29 0a 09 09 09 09 20 20 20 28 62 65 67 th*)..... (beg
8a20: 69 6e 0a 09 09 09 09 20 20 20 20 20 28 77 69 74 in..... (wit
8a30: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
8a40: 20 68 68 66 0a 09 09 09 09 20 20 20 20 20 20 20 hhf.....
8a50: 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 09 (lambda ()......
8a60: 20 28 70 72 69 6e 74 20 62 65 73 74 61 64 72 73 (print bestadrs
8a70: 29 29 29 0a 09 09 09 09 20 20 20 20 20 28 62 65 )))..... (be
8a80: 67 69 6e 0a 09 09 09 09 20 20 20 20 20 20 20 28 gin..... (
8a90: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
8aa0: 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a omehost-mutex*).
8ab0: 09 09 09 09 20 20 20 20 20 20 20 28 63 61 72 20 .... (car
8ac0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 (common:get-home
8ad0: 68 6f 73 74 29 29 29 29 0a 09 09 09 09 20 20 20 host)))).....
8ae0: 23 66 29 29 29 29 29 0a 09 20 20 20 28 61 74 2d #f))))).. (at-
8af0: 68 6f 6d 65 20 20 28 6f 72 20 28 65 71 75 61 6c home (or (equal
8b00: 3f 20 68 6f 6d 65 68 6f 73 74 20 63 75 72 72 68 ? homehost currh
8b10: 6f 73 74 29 0a 09 09 09 20 28 65 71 75 61 6c 3f ost).... (equal?
8b20: 20 68 6f 6d 65 68 6f 73 74 20 62 65 73 74 61 64 homehost bestad
8b30: 72 73 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 rs)))). (se
8b40: 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 28 t! *home-host* (
8b50: 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 74 20 61 74 cons homehost at
8b60: 2d 68 6f 6d 65 29 29 0a 20 20 20 20 20 20 28 6d -home)). (m
8b70: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f utex-unlock! *ho
8b80: 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 mehost-mutex*).
8b90: 20 20 20 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a *home-host*
8ba0: 29 29 29 29 0a 0a 3b 3b 20 61 6d 20 49 20 6f 6e ))))..;; am I on
8bb0: 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 3f 0a 3b the homehost?.;
8bc0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
8bd0: 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a n:on-homehost?).
8be0: 20 20 28 6c 65 74 20 28 28 68 68 20 28 63 6f 6d (let ((hh (com
8bf0: 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mon:get-homehost
8c00: 29 29 29 0a 20 20 20 20 28 69 66 20 68 68 0a 09 ))). (if hh..
8c10: 28 63 64 72 20 68 68 29 0a 09 23 66 29 29 29 0a (cdr hh)..#f))).
8c20: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
8c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 =========.;; M I
8c70: 20 53 20 43 20 20 20 4c 20 49 20 53 20 54 20 53 S C L I S T S
8c80: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
8c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8cc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 74 =========..;; it
8cd0: 65 6d 73 20 69 6e 20 6c 69 73 74 61 20 61 72 65 ems in lista are
8ce0: 20 6d 61 74 63 68 65 64 20 76 61 6c 75 65 20 61 matched value a
8cf0: 6e 64 20 70 6f 73 69 74 69 6f 6e 20 69 6e 20 6c nd position in l
8d00: 69 73 74 62 0a 3b 3b 20 72 65 74 75 72 6e 20 74 istb.;; return t
8d10: 68 65 20 72 65 6d 61 69 6e 69 6e 67 20 69 74 65 he remaining ite
8d20: 6d 73 20 69 6e 20 6c 69 73 74 62 20 6f 72 20 23 ms in listb or #
8d30: 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f f.;;.(define (co
8d40: 6d 6d 6f 6e 3a 6c 69 73 74 2d 69 73 2d 73 75 62 mmon:list-is-sub
8d50: 6c 69 73 74 20 6c 69 73 74 61 20 6c 69 73 74 62 list lista listb
8d60: 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c ). (if (null? l
8d70: 69 73 74 61 29 0a 20 20 20 20 20 20 6c 69 73 74 ista). list
8d80: 62 20 3b 3b 20 61 6c 6c 20 69 74 65 6d 73 20 69 b ;; all items i
8d90: 6e 20 6c 69 73 74 62 20 61 72 65 20 22 72 65 6d n listb are "rem
8da0: 61 69 6e 69 6e 67 22 0a 20 20 20 20 20 20 28 69 aining". (i
8db0: 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 6c 69 73 f (> (length lis
8dc0: 74 61 29 28 6c 65 6e 67 74 68 20 6c 69 73 74 62 ta)(length listb
8dd0: 29 29 20 0a 09 20 20 23 66 0a 09 20 20 28 6c 65 )) .. #f.. (le
8de0: 74 20 6c 6f 6f 70 20 28 28 68 65 64 61 20 28 63 t loop ((heda (c
8df0: 61 72 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 ar lista))...
8e00: 20 20 28 74 61 6c 61 20 28 63 64 72 20 6c 69 73 (tala (cdr lis
8e10: 74 61 29 29 0a 09 09 20 20 20 20 20 28 68 65 64 ta))... (hed
8e20: 62 20 28 63 61 72 20 6c 69 73 74 62 29 29 0a 09 b (car listb))..
8e30: 09 20 20 20 20 20 28 74 61 6c 62 20 28 63 64 72 . (talb (cdr
8e40: 20 6c 69 73 74 62 29 29 29 0a 09 20 20 20 20 28 listb))).. (
8e50: 69 66 20 28 65 71 75 61 6c 3f 20 68 65 64 61 20 if (equal? heda
8e60: 68 65 64 62 29 0a 09 09 28 69 66 20 28 6e 75 6c hedb)...(if (nul
8e70: 6c 3f 20 74 61 6c 61 29 20 3b 3b 20 77 65 20 61 l? tala) ;; we a
8e80: 72 65 20 64 6f 6e 65 0a 09 09 20 20 20 20 74 61 re done... ta
8e90: 6c 62 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 lb... (loop (
8ea0: 63 61 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 car tala).... (
8eb0: 63 64 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 cdr tala).... (
8ec0: 63 61 72 20 74 61 6c 62 29 0a 09 09 09 20 20 0a car talb).... .
8ed0: 09 09 09 20 20 28 63 64 72 20 74 61 6c 62 29 29 ... (cdr talb))
8ee0: 29 0a 09 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 )...#f)))))..;;
8ef0: 4e 65 65 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 Needed for long
8f00: 6c 69 73 74 73 20 74 6f 20 62 65 20 73 6f 72 74 lists to be sort
8f10: 65 64 20 77 68 65 72 65 20 28 61 70 70 6c 79 20 ed where (apply
8f20: 6d 61 78 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b max ... ) dies.;
8f30: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
8f40: 6e 3a 6d 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 n:max inlst). (
8f50: 6c 65 74 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 let loop ((max-v
8f60: 61 6c 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a al (car inlst)).
8f70: 09 20 20 20 20 20 28 68 65 64 20 20 20 20 20 28 . (hed (
8f80: 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 car inlst))..
8f90: 20 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 (tal (cdr
8fa0: 69 6e 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 inlst))). (if
8fb0: 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c (not (null? tal
8fc0: 29 29 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 ))..(loop (max h
8fd0: 65 64 20 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 ed max-val)..
8fe0: 20 20 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 (car tal)..
8ff0: 20 20 20 20 28 63 64 72 20 74 61 6c 29 29 0a 09 (cdr tal))..
9000: 28 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c (max hed max-val
9010: 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e ))))..;; get min
9020: 20 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 or max, use > f
9030: 6f 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 or max and < for
9040: 20 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 min, this works
9050: 20 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 around the limi
9060: 74 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 ts on apply.;;.(
9070: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d define (common:m
9080: 69 6e 2d 6d 61 78 20 63 6f 6d 70 20 6c 73 74 29 in-max comp lst)
9090: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 . (if (null? ls
90a0: 74 29 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 62 t). #f ;; b
90b0: 65 74 74 65 72 20 74 68 61 6e 20 61 6e 20 65 78 etter than an ex
90c0: 63 65 70 74 69 6f 6e 20 66 6f 72 20 6d 79 20 6e ception for my n
90d0: 65 65 64 73 0a 20 20 20 20 20 20 28 66 6f 6c 64 eeds. (fold
90e0: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 (lambda (a b)..
90f0: 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d 70 20 (if (comp
9100: 61 20 62 29 20 61 20 62 29 29 0a 09 20 20 20 20 a b) a b))..
9110: 28 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 6c (car lst).. l
9120: 73 74 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 st)))..;; get mi
9130: 6e 20 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 n or max, use >
9140: 66 6f 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f for max and < fo
9150: 72 20 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b r min, this work
9160: 73 20 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d s around the lim
9170: 69 74 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a its on apply.;;.
9180: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
9190: 73 75 6d 20 6c 73 74 29 0a 20 20 28 69 66 20 28 sum lst). (if (
91a0: 6e 75 6c 6c 3f 20 6c 73 74 29 0a 20 20 20 20 20 null? lst).
91b0: 20 30 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 28 0. (fold (
91c0: 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 20 lambda (a b)..
91d0: 20 20 20 20 28 2b 20 61 20 62 29 29 0a 09 20 20 (+ a b))..
91e0: 20 20 28 63 61 72 20 6c 73 74 29 0a 09 20 20 20 (car lst)..
91f0: 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 70 61 74 68 lst)))..;; path
9200: 20 6c 69 73 74 20 74 6f 20 68 61 73 68 2d 74 61 list to hash-ta
9210: 62 6c 65 20 74 72 65 65 0a 3b 3b 20 20 20 28 28 ble tree.;; ((
9220: 61 20 62 20 63 29 28 61 20 62 20 64 29 28 65 20 a b c)(a b d)(e
9230: 62 20 63 29 29 20 3d 3e 20 28 28 61 20 28 62 20 b c)) => ((a (b
9240: 28 64 29 20 28 63 29 29 29 20 28 65 20 28 62 20 (d) (c))) (e (b
9250: 28 63 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e (c)))).;;.(defin
9260: 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e e (common:list->
9270: 68 74 72 65 65 20 6c 73 74 29 0a 20 20 28 6c 65 htree lst). (le
9280: 74 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 t ((resh (make-h
9290: 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
92a0: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
92b0: 28 6c 61 6d 62 64 61 20 28 69 6e 6c 73 74 29 0a (lambda (inlst).
92c0: 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 (let loop
92d0: 20 28 28 68 74 20 20 72 65 73 68 29 0a 09 09 20 ((ht resh)...
92e0: 20 28 68 65 64 20 28 63 61 72 20 69 6e 6c 73 74 (hed (car inlst
92f0: 29 29 0a 09 09 20 20 28 74 61 6c 20 28 63 64 72 ))... (tal (cdr
9300: 20 69 6e 6c 73 74 29 29 29 0a 09 20 28 69 66 20 inlst))).. (if
9310: 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f (hash-table-ref/
9320: 64 65 66 61 75 6c 74 20 68 74 20 68 65 64 20 23 default ht hed #
9330: 66 29 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f f).. (if (no
9340: 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 t (null? tal))..
9350: 09 20 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 . (loop (hash-ta
9360: 62 6c 65 2d 72 65 66 20 68 74 20 68 65 64 29 0a ble-ref ht hed).
9370: 09 09 20 20 20 20 20 20 20 28 63 61 72 20 74 61 .. (car ta
9380: 6c 29 0a 09 09 20 20 20 20 20 20 20 28 63 64 72 l)... (cdr
9390: 20 74 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 tal))).. (b
93a0: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 68 61 egin.. (ha
93b0: 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 sh-table-set! ht
93c0: 20 68 65 64 20 28 6d 61 6b 65 2d 68 61 73 68 2d hed (make-hash-
93d0: 74 61 62 6c 65 29 29 0a 09 20 20 20 20 20 20 20 table))..
93e0: 28 6c 6f 6f 70 20 68 74 20 68 65 64 20 74 61 6c (loop ht hed tal
93f0: 29 29 29 29 29 0a 20 20 20 20 20 6c 73 74 29 0a ))))). lst).
9400: 20 20 20 20 72 65 73 68 29 29 0a 0a 3b 3b 20 68 resh))..;; h
9410: 61 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 ash-table tree t
9420: 6f 20 68 74 6d 6c 20 6c 69 73 74 20 74 72 65 65 o html list tree
9430: 0a 3b 3b 0a 3b 3b 20 20 20 74 69 70 66 75 6e 63 .;;.;; tipfunc
9440: 20 74 61 6b 65 73 20 74 77 6f 20 70 61 72 61 6d takes two param
9450: 65 74 65 72 73 3a 20 79 20 74 68 65 20 74 69 70 eters: y the tip
9460: 20 76 61 6c 75 65 20 61 6e 64 20 70 61 74 68 20 value and path
9470: 74 68 65 20 70 61 74 68 20 74 6f 20 74 68 61 74 the path to that
9480: 20 70 6f 69 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e point.;;.(defin
9490: 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d e (common:htree-
94a0: 3e 68 74 6d 6c 20 68 74 20 70 61 74 68 20 74 69 >html ht path ti
94b0: 70 66 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 pfunc). (let ((
94c0: 64 61 74 6c 69 73 74 20 09 28 73 6f 72 74 20 28 datlist .(sort (
94d0: 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 hash-table->alis
94e0: 74 20 68 74 29 0a 20 20 20 20 20 20 20 20 20 20 t ht).
94f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9500: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
9510: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
9520: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9530: 20 20 28 73 74 72 69 6e 67 3c 20 28 63 61 72 20 (string< (car
9540: 61 29 28 63 61 72 20 62 29 29 29 29 29 29 0a 20 a)(car b)))))).
9550: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 (if (null? da
9560: 74 6c 69 73 74 29 0a 20 20 20 20 09 28 74 69 70 tlist). .(tip
9570: 66 75 6e 63 20 23 66 20 70 61 74 68 29 20 3b 3b func #f path) ;;
9580: 20 72 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 really shouldn'
9590: 74 20 67 65 74 20 68 65 72 65 0a 09 28 73 3a 75 t get here..(s:u
95a0: 6c 0a 09 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 l.. (map (lambda
95b0: 20 28 78 29 0a 09 09 28 6c 65 74 2a 20 28 28 6c (x)...(let* ((l
95c0: 65 76 65 6c 6e 61 6d 65 20 28 63 61 72 20 78 29 evelname (car x)
95d0: 29 0a 09 09 20 20 20 20 20 20 20 28 79 20 20 20 )... (y
95e0: 20 20 20 20 20 20 28 63 64 72 20 78 29 29 0a 09 (cdr x))..
95f0: 09 20 20 20 20 20 20 20 28 6e 65 77 70 61 74 68 . (newpath
9600: 20 20 20 28 61 70 70 65 6e 64 20 70 61 74 68 20 (append path
9610: 28 6c 69 73 74 20 6c 65 76 65 6c 6e 61 6d 65 29 (list levelname)
9620: 29 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 61 ))... (lea
9630: 66 20 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 f (or (not
9640: 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 29 (hash-table? y))
9650: 0a 09 09 09 09 20 20 20 20 20 20 28 6e 75 6c 6c ..... (null
9660: 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 ? (hash-table-ke
9670: 79 73 20 79 29 29 29 29 29 0a 09 09 20 20 28 69 ys y)))))... (i
9680: 66 20 6c 65 61 66 0a 09 09 20 20 20 20 20 20 28 f leaf... (
9690: 73 3a 6c 69 20 28 74 69 70 66 75 6e 63 20 79 20 s:li (tipfunc y
96a0: 6e 65 77 70 61 74 68 29 29 0a 09 09 20 20 20 20 newpath))...
96b0: 20 20 28 73 3a 6c 69 0a 09 09 20 20 20 20 20 20 (s:li...
96c0: 20 28 6c 69 73 74 20 0a 09 09 09 6c 65 76 65 6c (list ....level
96d0: 6e 61 6d 65 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a name....(common:
96e0: 68 74 72 65 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 htree->html y ne
96f0: 77 70 61 74 68 20 74 69 70 66 75 6e 63 29 29 29 wpath tipfunc)))
9700: 29 29 29 0a 09 20 20 20 20 20 20 64 61 74 6c 69 ))).. datli
9710: 73 74 29 29 29 29 29 0a 0a 3b 3b 20 68 61 73 68 st)))))..;; hash
9720: 2d 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 61 -table tree to a
9730: 6c 69 73 74 20 74 72 65 65 0a 3b 3b 0a 28 64 65 list tree.;;.(de
9740: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 fine (common:htr
9750: 65 65 2d 3e 61 74 72 65 65 20 68 74 29 0a 20 20 ee->atree ht).
9760: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 (map (lambda (x)
9770: 0a 09 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 .. (cons (car x)
9780: 0a 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 .. (let ((
9790: 79 20 28 63 64 72 20 78 29 29 29 0a 09 09 20 28 y (cdr x)))... (
97a0: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 if (hash-table?
97b0: 79 29 0a 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f y)... (commo
97c0: 6e 3a 68 74 72 65 65 2d 3e 61 74 72 65 65 20 79 n:htree->atree y
97d0: 29 0a 09 09 20 20 20 20 20 79 29 29 29 29 0a 20 )... y)))).
97e0: 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c (hash-tabl
97f0: 65 2d 3e 61 6c 69 73 74 20 68 74 29 29 29 0a 0a e->alist ht)))..
9800: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
9810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9840: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 ========.;; M U
9850: 4e 20 47 20 45 20 20 20 44 20 41 20 54 20 41 20 N G E D A T A
9860: 20 20 49 20 4e 20 54 20 4f 20 20 20 4e 20 49 20 I N T O N I
9870: 43 20 45 20 20 20 46 20 4f 20 52 20 4d 20 53 0a C E F O R M S.
9880: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
9890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
98c0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e ========..;; Gen
98d0: 65 72 61 74 65 20 61 6e 20 69 6e 64 65 78 20 66 erate an index f
98e0: 6f 72 20 61 20 73 70 61 72 73 65 20 6c 69 73 74 or a sparse list
98f0: 20 6f 66 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b of key values.;
9900: 3b 20 20 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 ; ( (rowname1
9910: 63 6f 6c 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 colname1 val1)(r
9920: 6f 77 6e 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 owname2 colname2
9930: 20 76 61 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d val2) ).;;.;; =
9940: 3e 20 0a 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f > .;;.;; ( (ro
9950: 77 6e 61 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d wname1 0)(rownam
9960: 65 32 20 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 e2 1)) ;; row
9970: 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 names -> num.;;
9980: 20 20 20 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 (colname1 0)
9990: 28 63 6f 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 (colname2 1)) )
99a0: 20 3b 3b 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 ;; colnames ->
99b0: 6e 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f num.;; .;; optio
99c0: 6e 61 6c 20 61 70 70 6c 79 20 70 72 6f 63 20 74 nal apply proc t
99d0: 6f 20 72 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 o rownum colnum
99e0: 76 61 6c 75 65 0a 28 64 65 66 69 6e 65 20 28 63 value.(define (c
99f0: 6f 6d 6d 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 ommon:sparse-lis
9a00: 74 2d 67 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 t-generate-index
9a10: 20 64 61 74 61 20 23 21 6b 65 79 20 28 70 72 6f data #!key (pro
9a20: 63 20 23 66 29 29 0a 20 20 28 69 66 20 28 6e 75 c #f)). (if (nu
9a30: 6c 6c 3f 20 64 61 74 61 29 0a 20 20 20 20 20 20 ll? data).
9a40: 28 6c 69 73 74 20 27 28 29 20 27 28 29 29 0a 20 (list '() '()).
9a50: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
9a60: 28 68 65 64 20 28 63 61 72 20 64 61 74 61 29 29 (hed (car data))
9a70: 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 64 61 ... (tal (cdr da
9a80: 74 61 29 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 ta))... (rowname
9a90: 73 20 27 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 s '())... (colna
9aa0: 6d 65 73 20 27 28 29 29 0a 09 09 20 28 72 6f 77 mes '())... (row
9ab0: 6e 75 6d 20 20 20 30 29 0a 09 09 20 28 63 6f 6c num 0)... (col
9ac0: 6e 75 6d 20 20 20 30 29 29 0a 09 28 6c 65 74 2a num 0))..(let*
9ad0: 20 28 28 72 6f 77 6b 65 79 20 20 20 20 20 20 20 ((rowkey
9ae0: 20 20 20 28 63 61 72 20 20 20 68 65 64 29 29 0a (car hed)).
9af0: 09 20 20 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 . (colkey
9b00: 20 20 20 20 20 20 20 20 20 28 63 61 64 72 20 20 (cadr
9b10: 68 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 76 hed)).. (v
9b20: 61 6c 75 65 20 20 20 20 20 20 20 20 20 20 20 28 alue (
9b30: 63 61 64 64 72 20 68 65 64 29 29 0a 09 20 20 20 caddr hed))..
9b40: 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d 72 6f (existing-ro
9b50: 77 64 61 74 20 28 61 73 73 6f 63 20 72 6f 77 6b wdat (assoc rowk
9b60: 65 79 20 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 ey rownames))..
9b70: 20 20 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d (existing-
9b80: 63 6f 6c 64 61 74 20 28 61 73 73 6f 63 20 63 6f coldat (assoc co
9b90: 6c 6b 65 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a lkey colnames)).
9ba0: 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 72 6f . (curr-ro
9bb0: 77 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 wnum (if exi
9bc0: 73 74 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 sting-rowdat row
9bd0: 6e 75 6d 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 num (+ rownum 1)
9be0: 29 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 )).. (curr
9bf0: 2d 63 6f 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 -colnum (if
9c00: 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 existing-coldat
9c10: 63 6f 6c 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d colnum (+ colnum
9c20: 20 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 1))).. (n
9c30: 65 77 2d 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 ew-rownames (
9c40: 69 66 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 if existing-rowd
9c50: 61 74 20 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e at rownames (con
9c60: 73 20 28 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 s (list rowkey c
9c70: 75 72 72 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e urr-rownum) rown
9c80: 61 6d 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 ames)))..
9c90: 28 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 (new-colnames
9ca0: 20 28 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f (if existing-co
9cb0: 6c 64 61 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 ldat colnames (c
9cc0: 6f 6e 73 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 ons (list colkey
9cd0: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f curr-colnum) co
9ce0: 6c 6e 61 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b lnames)))).. ;;
9cf0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
9d00: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
9d10: 67 2d 70 6f 72 74 2a 20 22 50 72 6f 63 65 73 73 g-port* "Process
9d20: 69 6e 67 20 72 65 63 6f 72 64 3a 20 22 20 68 65 ing record: " he
9d30: 64 20 29 0a 09 20 20 28 69 66 20 70 72 6f 63 20 d ).. (if proc
9d40: 28 70 72 6f 63 20 63 75 72 72 2d 72 6f 77 6e 75 (proc curr-rownu
9d50: 6d 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f m curr-colnum ro
9d60: 77 6b 65 79 20 63 6f 6c 6b 65 79 20 76 61 6c 75 wkey colkey valu
9d70: 65 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c e)).. (if (null
9d80: 3f 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 6c ? tal).. (l
9d90: 69 73 74 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 ist new-rownames
9da0: 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 new-colnames)..
9db0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
9dc0: 20 74 61 6c 29 0a 09 09 20 20 20 20 28 63 64 72 tal)... (cdr
9dd0: 20 74 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 2d tal)... new-
9de0: 72 6f 77 6e 61 6d 65 73 0a 09 09 20 20 20 20 6e rownames... n
9df0: 65 77 2d 63 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 ew-colnames...
9e00: 20 20 28 69 66 20 28 3e 20 63 75 72 72 2d 72 6f (if (> curr-ro
9e10: 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 20 63 75 72 wnum rownum) cur
9e20: 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 r-rownum rownum)
9e30: 0a 09 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 ... (if (> cu
9e40: 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d rr-colnum colnum
9e50: 29 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f ) curr-colnum co
9e60: 6c 6e 75 6d 29 0a 09 09 20 20 20 20 29 29 29 29 lnum)... ))))
9e70: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
9e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
9ec0: 53 20 59 20 53 20 54 20 45 20 4d 20 20 20 53 20 S Y S T E M S
9ed0: 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d T U F F.;;======
9ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
9f20: 0a 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 ..;; lazy-safe g
9f30: 65 74 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 et file mod time
9f40: 2e 20 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 . on any error (
9f50: 66 69 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e file not existin
9f60: 67 20 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 g etc.) return 0
9f70: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
9f80: 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 mon:lazy-modific
9f90: 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 ation-time fpath
9fa0: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
9fb0: 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 ptions. exn.
9fc0: 20 30 0a 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 0. (file-modi
9fd0: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 fication-time fp
9fe0: 61 74 68 29 29 29 0a 0a 3b 3b 20 66 69 6e 64 20 ath)))..;; find
9ff0: 74 69 6d 65 73 74 61 6d 70 20 6f 66 20 6e 65 77 timestamp of new
a000: 65 73 74 20 66 69 6c 65 20 61 73 73 6f 63 69 61 est file associa
a010: 74 65 64 20 77 69 74 68 20 61 20 73 71 6c 69 74 ted with a sqlit
a020: 65 20 64 62 20 66 69 6c 65 0a 28 64 65 66 69 6e e db file.(defin
a030: 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 73 e (common:lazy-s
a040: 71 6c 69 74 65 2d 64 62 2d 6d 6f 64 69 66 69 63 qlite-db-modific
a050: 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 ation-time fpath
a060: 29 0a 20 20 28 6c 65 74 2a 20 28 28 67 6c 6f 62 ). (let* ((glob
a070: 2d 6c 69 73 74 20 28 68 61 6e 64 6c 65 2d 65 78 -list (handle-ex
a080: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 ceptions.
a090: 20 20 20 20 20 20 20 20 20 20 20 20 20 65 78 6e exn
a0a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a0b0: 20 20 20 20 20 27 28 22 2f 6e 6f 2f 73 75 63 68 '("/no/such
a0c0: 2f 66 69 6c 65 22 29 0a 20 20 20 20 20 20 20 20 /file").
a0d0: 20 20 20 20 20 20 20 20 20 20 20 20 28 67 6c 6f (glo
a0e0: 62 20 28 63 6f 6e 63 20 66 70 61 74 68 20 22 2a b (conc fpath "*
a0f0: 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 ")))). (
a100: 66 69 6c 65 2d 6c 69 73 74 20 28 69 66 20 28 65 file-list (if (e
a110: 71 3f 20 30 20 28 6c 65 6e 67 74 68 20 67 6c 6f q? 0 (length glo
a120: 62 2d 6c 69 73 74 29 29 0a 20 20 20 20 20 20 20 b-list)).
a130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
a140: 20 27 28 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c '("/no/such/fil
a150: 65 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e").
a160: 20 20 20 20 20 20 20 20 20 20 20 20 67 6c 6f 62 glob
a170: 2d 6c 69 73 74 29 29 29 0a 20 20 28 61 70 70 6c -list))). (appl
a180: 79 20 6d 61 78 0a 20 20 20 28 6d 61 70 0a 20 20 y max. (map.
a190: 20 20 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f common:lazy-mo
a1a0: 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 dification-time
a1b0: 0a 20 20 20 20 66 69 6c 65 2d 6c 69 73 74 29 29 . file-list))
a1c0: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 61 20 ))..;; return a
a1d0: 6e 69 63 65 20 63 6c 65 61 6e 20 70 61 74 68 6e nice clean pathn
a1e0: 61 6d 65 20 6d 61 64 65 20 61 62 73 6f 6c 75 74 ame made absolut
a1f0: 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f e.(define (commo
a200: 6e 3a 6e 69 63 65 2d 70 61 74 68 20 64 69 72 29 n:nice-path dir)
a210: 0a 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 20 . (let ((match
a220: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e (string-match "^
a230: 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 2e 2a (~[^\\/]*)(\\/.*
a240: 7c 29 24 22 20 64 69 72 29 29 29 0a 20 20 20 20 |)$" dir))).
a250: 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 75 73 69 (if match ;; usi
a260: 6e 67 20 7e 20 66 6f 72 20 68 6f 6d 65 3f 0a 09 ng ~ for home?..
a270: 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 (common:nice-pat
a280: 68 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a h (conc (common:
a290: 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 28 63 61 64 read-link-f (cad
a2a0: 72 20 6d 61 74 63 68 29 29 20 22 2f 22 20 28 63 r match)) "/" (c
a2b0: 61 64 64 72 20 6d 61 74 63 68 29 29 29 0a 09 28 addr match)))..(
a2c0: 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 68 6e 61 normalize-pathna
a2d0: 6d 65 20 28 69 66 20 28 61 62 73 6f 6c 75 74 65 me (if (absolute
a2e0: 2d 70 61 74 68 6e 61 6d 65 3f 20 64 69 72 29 0a -pathname? dir).
a2f0: 09 09 09 09 64 69 72 0a 09 09 09 09 28 63 6f 6e ....dir.....(con
a300: 63 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 63 c (current-direc
a310: 74 6f 72 79 29 20 22 2f 22 20 64 69 72 29 29 29 tory) "/" dir)))
a320: 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 22 6e 69 )))..;; make "ni
a330: 63 65 2d 70 61 74 68 22 20 61 76 61 69 6c 61 62 ce-path" availab
a340: 6c 65 20 69 6e 20 63 6f 6e 66 69 67 20 66 69 6c le in config fil
a350: 65 73 20 61 6e 64 20 74 68 65 20 72 65 70 6c 0a es and the repl.
a360: 28 64 65 66 69 6e 65 20 6e 69 63 65 2d 70 61 74 (define nice-pat
a370: 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 h common:nice-pa
a380: 74 68 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f th)..(define (co
a390: 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 mmon:read-link-f
a3a0: 20 70 61 74 68 29 0a 20 20 28 68 61 6e 64 6c 65 path). (handle
a3b0: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 -exceptions.
a3c0: 20 20 65 78 6e 0a 20 20 20 20 20 20 28 62 65 67 exn. (beg
a3d0: 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e 74 in..(debug:print
a3e0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
a3f0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d t-log-port* "com
a400: 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f 72 65 61 64 mand \"/bin/read
a410: 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 20 22 link -f " path "
a420: 5c 22 20 66 61 69 6c 65 64 2e 22 29 0a 09 70 61 \" failed.")..pa
a430: 74 68 29 20 3b 3b 20 6a 75 73 74 20 67 69 76 65 th) ;; just give
a440: 20 75 70 0a 20 20 20 20 28 77 69 74 68 2d 69 6e up. (with-in
a450: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 28 put-from-pipe..(
a460: 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 65 61 64 6c conc "/bin/readl
a470: 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 29 0a 20 ink -f " path).
a480: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
a490: 09 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 .(read-line)))))
a4a0: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 63 ..(define (get-c
a4b0: 70 75 2d 6c 6f 61 64 20 23 21 6b 65 79 20 28 72 pu-load #!key (r
a4c0: 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a emote-host #f)).
a4d0: 20 20 28 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 67 (car (common:g
a4e0: 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f et-cpu-load remo
a4f0: 74 65 2d 68 6f 73 74 29 29 29 0a 3b 3b 20 20 20 te-host))).;;
a500: 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d 72 65 73 (let* ((load-res
a510: 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 (process:cmd-ru
a520: 6e 2d 3e 6c 69 73 74 20 22 75 70 74 69 6d 65 22 n->list "uptime"
a530: 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 2d 72 78 )).;; . (load-rx
a540: 20 20 28 72 65 67 65 78 70 20 22 6c 6f 61 64 20 (regexp "load
a550: 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 5c 5c 64 average:\\s+(\\d
a560: 2b 29 22 29 29 0a 3b 3b 20 09 20 28 63 70 75 2d +)")).;; . (cpu-
a570: 6c 6f 61 64 20 23 66 29 29 0a 3b 3b 20 20 20 20 load #f)).;;
a580: 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
a590: 64 61 20 28 6c 29 0a 3b 3b 20 09 09 28 6c 65 74 da (l).;; ..(let
a5a0: 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 ((match (string
a5b0: 2d 73 65 61 72 63 68 20 6c 6f 61 64 2d 72 78 20 -search load-rx
a5c0: 6c 29 29 29 0a 3b 3b 20 09 09 20 20 28 69 66 20 l))).;; .. (if
a5d0: 6d 61 74 63 68 0a 3b 3b 20 09 09 20 20 20 20 20 match.;; ..
a5e0: 20 28 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 (let ((newval (
a5f0: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
a600: 63 61 64 72 20 6d 61 74 63 68 29 29 29 29 0a 3b cadr match)))).;
a610: 3b 20 09 09 09 28 69 66 20 28 6e 75 6d 62 65 72 ; ...(if (number
a620: 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 09 09 09 ? newval).;; ...
a630: 20 20 20 20 28 73 65 74 21 20 63 70 75 2d 6c 6f (set! cpu-lo
a640: 61 64 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a ad newval)))))).
a650: 3b 3b 20 09 20 20 20 20 20 20 28 63 61 72 20 6c ;; . (car l
a660: 6f 61 64 2d 72 65 73 29 29 0a 3b 3b 20 20 20 20 oad-res)).;;
a670: 20 63 70 75 2d 6c 6f 61 64 29 29 0a 0a 3b 3b 20 cpu-load))..;;
a680: 67 65 74 20 63 70 75 20 6c 6f 61 64 20 62 79 20 get cpu load by
a690: 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 2f 70 72 reading from /pr
a6a0: 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 72 65 74 75 oc/loadavg, retu
a6b0: 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 61 6c rn all three val
a6c0: 75 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ues.;;.(define (
a6d0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c common:get-cpu-l
a6e0: 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 oad remote-host)
a6f0: 0a 20 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f . (if remote-ho
a700: 73 74 0a 20 20 20 20 20 20 28 6d 61 70 20 28 6c st. (map (l
a710: 61 6d 62 64 61 20 28 72 65 73 29 0a 09 20 20 20 ambda (res)..
a720: 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 (if (eof-objec
a730: 74 3f 20 72 65 73 29 20 39 65 39 39 20 72 65 73 t? res) 9e99 res
a740: 29 29 0a 09 20 20 20 28 77 69 74 68 2d 69 6e 70 )).. (with-inp
a750: 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 20 ut-from-pipe ..
a760: 20 20 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 (conc "ssh "
a770: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 remote-host " ca
a780: 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 t /proc/loadavg"
a790: 29 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 ).. (lambda (
a7a0: 29 28 6c 69 73 74 20 28 72 65 61 64 29 28 72 65 )(list (read)(re
a7b0: 61 64 29 28 72 65 61 64 29 29 29 29 29 0a 20 20 ad)(read))))).
a7c0: 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d (with-input-
a7d0: 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 from-file "/proc
a7e0: 2f 6c 6f 61 64 61 76 67 22 20 0a 09 28 6c 61 6d /loadavg" ..(lam
a7f0: 62 64 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 bda ()(list (rea
a800: 64 29 28 72 65 61 64 29 28 72 65 61 64 29 29 29 d)(read)(read)))
a810: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6e 6f 72 6d )))..;; get norm
a820: 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f 61 64 20 alized cpu load
a830: 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 by reading from
a840: 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 20 61 6e /proc/loadavg an
a850: 64 20 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 20 d /proc/cpuinfo
a860: 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 return all three
a870: 20 76 61 6c 75 65 73 20 61 6e 64 20 74 68 65 20 values and the
a880: 6e 75 6d 62 65 72 20 6f 66 20 72 65 61 6c 20 63 number of real c
a890: 70 75 73 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 pus and the numb
a8a0: 65 72 20 6f 66 20 74 68 72 65 61 64 73 0a 3b 3b er of threads.;;
a8b0: 20 72 65 74 75 72 6e 73 20 61 6c 69 73 74 20 27 returns alist '
a8c0: 28 28 61 64 6a 2d 63 70 75 2d 6c 6f 61 64 20 2e ((adj-cpu-load .
a8d0: 20 6e 6f 72 6d 61 6c 69 7a 65 64 2d 70 72 6f 63 normalized-proc
a8e0: 2d 6c 6f 61 64 29 20 2e 2e 2e 20 65 74 63 2e 0a -load) ... etc..
a8f0: 3b 3b 20 20 6b 65 79 73 3a 20 61 64 6a 2d 70 72 ;; keys: adj-pr
a900: 6f 63 2d 6c 6f 61 64 2c 20 61 64 6a 2d 63 6f 72 oc-load, adj-cor
a910: 65 2d 6c 6f 61 64 2c 20 31 6d 2d 6c 6f 61 64 2c e-load, 1m-load,
a920: 20 35 6d 2d 6c 6f 61 64 2c 20 31 35 6d 2d 6c 6f 5m-load, 15m-lo
a930: 61 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ad.;;.(define (c
a940: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d 61 6c ommon:get-normal
a950: 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 72 65 ized-cpu-load re
a960: 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 20 28 6c 65 mote-host). (le
a970: 74 20 28 28 64 61 74 61 20 28 69 66 20 72 65 6d t ((data (if rem
a980: 6f 74 65 2d 68 6f 73 74 0a 20 20 20 20 20 20 20 ote-host.
a990: 20 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 (with
a9a0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
a9b0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
a9c0: 20 20 20 20 20 28 63 6f 6e 63 20 22 73 73 68 20 (conc "ssh
a9d0: 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 " remote-host "
a9e0: 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 cat /proc/loadav
a9f0: 67 3b 63 61 74 20 2f 70 72 6f 63 2f 63 70 75 69 g;cat /proc/cpui
aa00: 6e 66 6f 3b 65 63 68 6f 20 65 6e 64 22 29 0a 20 nfo;echo end").
aa10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa20: 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 20 20 read-lines).
aa30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa40: 28 61 70 70 65 6e 64 20 0a 20 20 20 20 20 20 20 (append .
aa50: 20 20 20 20 20 20 20 20 20 20 20 20 28 77 69 74 (wit
aa60: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c h-input-from-fil
aa70: 65 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 e "/proc/loadavg
aa80: 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 " .
aa90: 20 20 20 20 20 20 20 20 72 65 61 64 2d 6c 69 6e read-lin
aaa0: 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 es).
aab0: 20 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 (with-inp
aac0: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 ut-from-file "/p
aad0: 72 6f 63 2f 63 70 75 69 6e 66 6f 22 0a 20 20 20 roc/cpuinfo".
aae0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aaf0: 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 20 20 read-lines).
ab00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ab10: 20 28 6c 69 73 74 20 22 65 6e 64 22 29 29 29 29 (list "end"))))
ab20: 0a 20 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 72 . (load-r
ab30: 78 20 20 28 72 65 67 65 78 70 20 22 5e 28 5b 5c x (regexp "^([\
ab40: 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b 5c 5c \d\\.]+)\\s+([\\
ab50: 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b 5c 5c 64 d\\.]+)\\s+([\\d
ab60: 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e 2a 24 22 29 29 \\.]+)\\s+.*$"))
ab70: 0a 20 20 20 20 20 20 20 20 28 70 72 6f 63 2d 72 . (proc-r
ab80: 78 20 20 28 72 65 67 65 78 70 20 22 5e 70 72 6f x (regexp "^pro
ab90: 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b 28 cessor\\s+:\\s+(
aba0: 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 \\d+)\\s*$")).
abb0: 20 20 20 20 20 20 28 63 6f 72 65 2d 72 78 20 20 (core-rx
abc0: 28 72 65 67 65 78 70 20 22 5e 63 6f 72 65 20 69 (regexp "^core i
abd0: 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 d\\s+:\\s+(\\d+)
abe0: 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 20 20 \\s*$")).
abf0: 20 28 70 68 79 73 2d 72 78 20 20 28 72 65 67 65 (phys-rx (rege
ac00: 78 70 20 22 5e 70 68 79 73 69 63 61 6c 20 69 64 xp "^physical id
ac10: 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 5c \\s+:\\s+(\\d+)\
ac20: 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 20 20 20 \s*$")).
ac30: 28 6d 61 78 2d 6e 75 6d 20 20 28 6c 61 6d 62 64 (max-num (lambd
ac40: 61 20 28 70 20 6e 29 28 6d 61 78 20 28 73 74 72 a (p n)(max (str
ac50: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 29 20 6e ing->number p) n
ac60: 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 )))). ;; (pri
ac70: 6e 74 20 22 64 61 74 61 3d 22 20 64 61 74 61 29 nt "data=" data)
ac80: 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 . (if (null?
ac90: 64 61 74 61 29 20 3b 3b 20 73 6f 6d 65 74 68 69 data) ;; somethi
aca0: 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 0a 20 20 ng went wrong.
acb0: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 #f.
acc0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
acd0: 20 20 20 20 20 20 28 63 61 72 20 64 61 74 61 29 (car data)
ace0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
acf0: 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 20 28 (tal (
ad00: 63 64 72 20 64 61 74 61 29 29 0a 20 20 20 20 20 cdr data)).
ad10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
ad20: 6f 61 64 73 20 20 20 20 23 66 29 0a 20 20 20 20 oads #f).
ad30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
ad40: 70 72 6f 63 2d 6e 75 6d 20 30 29 20 20 3b 3b 20 proc-num 0) ;;
ad50: 70 72 6f 63 65 73 73 6f 72 20 69 6e 63 6c 75 64 processor includ
ad60: 65 73 20 74 68 72 65 61 64 73 0a 20 20 20 20 20 es threads.
ad70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
ad80: 68 79 73 2d 6e 75 6d 20 30 29 20 20 3b 3b 20 70 hys-num 0) ;; p
ad90: 68 79 73 69 63 61 6c 20 63 68 69 70 20 6f 6e 20 hysical chip on
ada0: 6d 6f 74 68 65 72 62 6f 61 72 64 0a 20 20 20 20 motherboard.
adb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
adc0: 63 6f 72 65 2d 6e 75 6d 20 30 29 29 20 3b 3b 20 core-num 0)) ;;
add0: 63 6f 72 65 0a 20 20 20 20 20 20 20 20 20 20 3b core. ;
ade0: 3b 20 28 70 72 69 6e 74 20 68 65 64 20 22 2c 20 ; (print hed ",
adf0: 22 20 6c 6f 61 64 73 20 22 2c 20 22 20 70 72 6f " loads ", " pro
ae00: 63 2d 6e 75 6d 20 22 2c 20 22 20 70 68 79 73 2d c-num ", " phys-
ae10: 6e 75 6d 20 22 2c 20 22 20 63 6f 72 65 2d 6e 75 num ", " core-nu
ae20: 6d 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 66 m). (if
ae30: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b 20 (null? tal) ;;
ae40: 68 61 76 65 20 61 6c 6c 20 6f 75 72 20 64 61 74 have all our dat
ae50: 61 2c 20 63 61 6c 63 75 6c 61 74 65 20 6e 6f 72 a, calculate nor
ae60: 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 61 6e 64 malized load and
ae70: 20 72 65 74 75 72 6e 20 72 65 73 75 6c 74 0a 20 return result.
ae80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
ae90: 74 2a 20 28 28 61 63 74 2d 70 72 6f 63 20 28 2b t* ((act-proc (+
aea0: 20 70 72 6f 63 2d 6e 75 6d 20 31 29 29 0a 20 20 proc-num 1)).
aeb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aec0: 20 20 20 28 61 63 74 2d 70 68 79 73 20 28 2b 20 (act-phys (+
aed0: 70 68 79 73 2d 6e 75 6d 20 31 29 29 0a 20 20 20 phys-num 1)).
aee0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aef0: 20 20 28 61 63 74 2d 63 6f 72 65 20 28 2b 20 63 (act-core (+ c
af00: 6f 72 65 2d 6e 75 6d 20 31 29 29 0a 20 20 20 20 ore-num 1)).
af10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
af20: 20 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 (adj-proc-load
af30: 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 20 61 (/ (car loads) a
af40: 63 74 2d 70 72 6f 63 29 29 0a 20 20 20 20 20 20 ct-proc)).
af50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
af60: 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 28 2f adj-core-load (/
af70: 20 28 63 61 72 20 6c 6f 61 64 73 29 20 61 63 74 (car loads) act
af80: 2d 63 6f 72 65 29 29 29 0a 20 20 20 20 20 20 20 -core))).
af90: 20 20 20 20 20 20 20 20 20 28 61 70 70 65 6e 64 (append
afa0: 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 61 64 (list (cons 'ad
afb0: 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 61 64 6a 2d j-proc-load adj-
afc0: 70 72 6f 63 2d 6c 6f 61 64 29 0a 20 20 20 20 20 proc-load).
afd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
afe0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 (cons '
aff0: 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 61 64 adj-core-load ad
b000: 6a 2d 63 6f 72 65 2d 6c 6f 61 64 29 29 0a 20 20 j-core-load)).
b010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b020: 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f 6e (list (con
b030: 73 20 27 31 6d 2d 6c 6f 61 64 20 28 63 61 72 20 s '1m-load (car
b040: 6c 6f 61 64 73 29 29 0a 20 20 20 20 20 20 20 20 loads)).
b050: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b060: 20 20 20 20 20 20 28 63 6f 6e 73 20 27 35 6d 2d (cons '5m-
b070: 6c 6f 61 64 20 28 63 61 64 72 20 6c 6f 61 64 73 load (cadr loads
b080: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
b090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b0a0: 20 28 63 6f 6e 73 20 27 31 35 6d 2d 6c 6f 61 64 (cons '15m-load
b0b0: 20 28 63 61 64 64 72 20 6c 6f 61 64 73 29 29 29 (caddr loads)))
b0c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b0d0: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 (list (
b0e0: 63 6f 6e 73 20 27 70 72 6f 63 20 61 63 74 2d 70 cons 'proc act-p
b0f0: 72 6f 63 29 0a 20 20 20 20 20 20 20 20 20 20 20 roc).
b100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b110: 20 20 20 28 63 6f 6e 73 20 27 63 6f 72 65 20 61 (cons 'core a
b120: 63 74 2d 63 6f 72 65 29 0a 20 20 20 20 20 20 20 ct-core).
b130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b140: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 70 68 (cons 'ph
b150: 79 73 20 61 63 74 2d 70 68 79 73 29 29 29 29 0a ys act-phys)))).
b160: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
b170: 65 67 65 78 2d 63 61 73 65 0a 20 20 20 20 20 20 egex-case.
b180: 20 20 20 20 20 20 20 20 20 68 65 64 0a 20 20 20 hed.
b190: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 61 (loa
b1a0: 64 2d 72 78 20 20 28 20 78 20 6c 31 20 6c 35 20 d-rx ( x l1 l5
b1b0: 6c 31 35 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 l15 ) (loop (car
b1c0: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 6d tal)(cdr tal)(m
b1d0: 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ap string->numbe
b1e0: 72 20 28 6c 69 73 74 20 6c 31 20 6c 35 20 6c 31 r (list l1 l5 l1
b1f0: 35 29 29 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 5)) proc-num phy
b200: 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 s-num core-num))
b210: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
b220: 28 70 72 6f 63 2d 72 78 20 20 28 20 78 20 70 20 (proc-rx ( x p
b230: 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 ) (loop
b240: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
b250: 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 l) loads
b260: 20 20 20 28 6d 61 78 2d 6e 75 6d 20 70 20 70 72 (max-num p pr
b270: 6f 63 2d 6e 75 6d 29 20 70 68 79 73 2d 6e 75 6d oc-num) phys-num
b280: 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 core-num)).
b290: 20 20 20 20 20 20 20 20 20 20 20 28 70 68 79 73 (phys
b2a0: 2d 72 78 20 20 28 20 78 20 70 20 20 20 20 20 20 -rx ( x p
b2b0: 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 ) (loop (car
b2c0: 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f tal)(cdr tal) lo
b2d0: 61 64 73 20 20 20 20 20 20 20 20 20 20 20 70 72 ads pr
b2e0: 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 6d 20 oc-num (max-num
b2f0: 70 20 70 68 79 73 2d 6e 75 6d 29 20 63 6f 72 65 p phys-num) core
b300: 2d 6e 75 6d 29 29 0a 20 20 20 20 20 20 20 20 20 -num)).
b310: 20 20 20 20 20 20 28 63 6f 72 65 2d 72 78 20 20 (core-rx
b320: 28 20 78 20 63 20 20 20 20 20 20 20 20 20 29 20 ( x c )
b330: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
b340: 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 cdr tal) loads
b350: 20 20 20 20 20 20 20 20 20 70 72 6f 63 2d 6e 75 proc-nu
b360: 6d 20 70 68 79 73 2d 6e 75 6d 20 28 6d 61 78 2d m phys-num (max-
b370: 6e 75 6d 20 63 20 63 6f 72 65 2d 6e 75 6d 29 29 num c core-num))
b380: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
b390: 20 28 65 6c 73 65 20 0a 20 20 20 20 20 20 20 20 (else .
b3a0: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
b3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3c0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 4e 4f 20 4d ;; (print "NO M
b3d0: 41 54 43 48 3a 20 22 20 68 65 64 29 0a 20 20 20 ATCH: " hed).
b3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b3f0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
b400: 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 70 72 dr tal) loads pr
b410: 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 oc-num phys-num
b420: 63 6f 72 65 2d 6e 75 6d 29 29 29 29 29 29 29 29 core-num))))))))
b430: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
b440: 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 20 68 6f 73 on:unix-ping hos
b450: 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 28 tname). (let ((
b460: 72 65 73 20 28 73 79 73 74 65 6d 20 28 63 6f 6e res (system (con
b470: 63 20 22 70 69 6e 67 20 2d 63 20 31 20 22 20 68 c "ping -c 1 " h
b480: 6f 73 74 6e 61 6d 65 20 22 20 3e 20 2f 64 65 76 ostname " > /dev
b490: 2f 6e 75 6c 6c 22 29 29 29 29 0a 20 20 20 20 28 /null")))). (
b4a0: 65 71 3f 20 72 65 73 20 30 29 29 29 0a 0a 3b 3b eq? res 0)))..;;
b4b0: 20 69 64 65 61 6c 6c 79 20 70 75 74 20 61 6c 6c ideally put all
b4c0: 20 74 68 69 73 20 69 6e 66 6f 20 69 6e 74 6f 20 this info into
b4d0: 74 68 65 20 64 62 2c 20 6e 6f 20 6e 65 65 64 20 the db, no need
b4e0: 74 6f 20 70 72 65 73 65 72 76 65 20 69 74 20 61 to preserve it a
b4f0: 63 72 6f 73 73 20 6d 6f 76 69 6e 67 20 68 6f 6d cross moving hom
b500: 65 68 6f 73 74 0a 3b 3b 0a 3b 3b 20 72 65 74 75 ehost.;;.;; retu
b510: 72 6e 20 6c 69 73 74 20 6f 66 0a 3b 3b 20 20 28 rn list of.;; (
b520: 20 72 65 61 63 68 61 62 6c 65 3f 20 63 70 75 6c reachable? cpul
b530: 6f 61 64 20 75 70 64 61 74 65 2d 74 69 6d 65 20 oad update-time
b540: 29 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ).(define (commo
b550: 6e 3a 67 65 74 2d 68 6f 73 74 2d 69 6e 66 6f 20 n:get-host-info
b560: 68 6f 73 74 6e 61 6d 65 20 61 72 65 61 2d 64 61 hostname area-da
b570: 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 t). (let* ((loa
b580: 64 69 6e 66 6f 20 28 72 6d 74 3a 67 65 74 2d 6c dinfo (rmt:get-l
b590: 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 20 atest-host-load
b5a0: 61 72 65 61 2d 64 61 74 20 68 6f 73 74 6e 61 6d area-dat hostnam
b5b0: 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f e)). (lo
b5c0: 61 64 20 28 63 61 72 20 6c 6f 61 64 69 6e 66 6f ad (car loadinfo
b5d0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 )). (loa
b5e0: 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 20 28 63 d-sample-time (c
b5f0: 64 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a 20 20 dr loadinfo)).
b600: 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 61 6d (load-sam
b610: 70 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 72 72 ple-age (- (curr
b620: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 6f 61 ent-seconds) loa
b630: 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 29 29 0a d-sample-time)).
b640: 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 69 6e (loadin
b650: 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e fo-timeout-secon
b660: 64 73 20 32 30 29 0a 20 20 20 20 20 20 20 20 20 ds 20).
b670: 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 (host-last-updat
b680: 65 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 e-timeout-second
b690: 73 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 28 s 10). (
b6a0: 68 6f 73 74 2d 72 65 63 20 28 68 61 73 68 2d 74 host-rec (hash-t
b6b0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
b6c0: 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f *host-loads* ho
b6d0: 73 74 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 20 stname #f)).
b6e0: 20 20 20 20 20 29 0a 20 20 20 20 28 63 6f 6e 64 ). (cond
b6f0: 0a 20 20 20 20 20 28 28 3c 20 6c 6f 61 64 2d 73 . ((< load-s
b700: 61 6d 70 6c 65 2d 61 67 65 20 6c 6f 61 64 69 6e ample-age loadin
b710: 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e fo-timeout-secon
b720: 64 73 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 ds). (list
b730: 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 6c #t. l
b740: 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 0a oad-sample-time.
b750: 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f 61 64 load
b760: 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 68 6f )). ((and ho
b770: 73 74 2d 72 65 63 0a 20 20 20 20 20 20 20 20 20 st-rec.
b780: 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 65 (< (current-se
b790: 63 6f 6e 64 73 29 20 28 2b 20 28 68 6f 73 74 2d conds) (+ (host-
b7a0: 6c 61 73 74 2d 75 70 64 61 74 65 20 68 6f 73 74 last-update host
b7b0: 2d 72 65 63 29 20 68 6f 73 74 2d 6c 61 73 74 2d -rec) host-last-
b7c0: 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 2d 73 update-timeout-s
b7d0: 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 econds))).
b7e0: 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 20 20 (list #t.
b7f0: 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d (host-last-
b800: 75 70 64 61 74 65 20 68 6f 73 74 2d 72 65 63 29 update host-rec)
b810: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 6f . (ho
b820: 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 64 20 st-last-cpuload
b830: 68 6f 73 74 2d 72 65 63 20 29 29 29 0a 20 20 20 host-rec ))).
b840: 20 20 28 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d ((common:unix-
b850: 70 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 0a 20 ping hostname).
b860: 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a 20 20 (list #t.
b870: 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 (curre
b880: 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 20 nt-seconds).
b890: 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 (alist-r
b8a0: 65 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 ef 'adj-core-loa
b8b0: 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f d (common:get-no
b8c0: 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 rmalized-cpu-loa
b8d0: 64 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 d hostname)))).
b8e0: 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 (else.
b8f0: 28 6c 69 73 74 20 23 66 20 30 20 2d 31 29 29 29 (list #f 0 -1)))
b900: 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 )). .(define
b910: 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 (common:update-h
b920: 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 20 ost-loads-table
b930: 68 6f 73 74 73 2d 72 61 77 29 0a 20 20 28 6c 65 hosts-raw). (le
b940: 74 2a 20 28 28 68 6f 73 74 73 20 28 66 69 6c 74 t* ((hosts (filt
b950: 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 er (lambda (x).
b960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b970: 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
b980: 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 -match (regexp "
b990: 5e 5c 5c 53 2b 24 22 29 20 78 29 29 0a 20 20 20 ^\\S+$") x)).
b9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b9b0: 20 20 20 20 20 68 6f 73 74 73 2d 72 61 77 29 29 hosts-raw))
b9c0: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
b9d0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 6f (lambda (ho
b9e0: 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 stname). (
b9f0: 6c 65 74 2a 20 28 28 72 65 63 20 20 20 20 20 20 let* ((rec
ba00: 20 28 6c 65 74 20 28 28 68 20 28 68 61 73 68 2d (let ((h (hash-
ba10: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
ba20: 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 t *host-loads* h
ba30: 6f 73 74 6e 61 6d 65 20 23 66 29 29 29 0a 20 20 ostname #f))).
ba40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba50: 20 20 20 20 20 20 20 20 28 69 66 20 68 0a 20 20 (if h.
ba60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba70: 20 20 20 20 20 20 20 20 20 20 20 20 68 0a 20 20 h.
ba80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ba90: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
baa0: 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 29 ((h (make-host)
bab0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
bac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bad0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
bae0: 65 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a et! *host-loads*
baf0: 20 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 20 20 hostname h).
bb00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bb10: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 29 29 h))
bb20: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
bb30: 20 28 68 6f 73 74 2d 69 6e 66 6f 20 20 20 20 20 (host-info
bb40: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d (common:get-
bb50: 68 6f 73 74 2d 69 6e 66 6f 20 68 6f 73 74 6e 61 host-info hostna
bb60: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 me)).
bb70: 20 20 20 28 69 73 2d 72 65 61 63 68 61 62 6c 65 (is-reachable
bb80: 20 20 20 20 20 20 28 63 61 72 20 68 6f 73 74 2d (car host-
bb90: 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 info)).
bba0: 20 20 20 20 20 28 6c 61 73 74 2d 72 65 61 63 68 (last-reach
bbb0: 65 64 2d 74 69 6d 65 20 28 63 61 64 72 20 68 6f ed-time (cadr ho
bbc0: 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 st-info)).
bbd0: 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 20 20 (load
bbe0: 20 20 20 20 20 20 20 20 20 20 20 28 63 61 64 64 (cadd
bbf0: 72 20 68 6f 73 74 2d 69 6e 66 6f 29 29 29 0a 20 r host-info))).
bc00: 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d 72 65 (host-re
bc10: 61 63 68 61 62 6c 65 2d 73 65 74 21 20 20 20 20 achable-set!
bc20: 72 65 63 20 69 73 2d 72 65 61 63 68 61 62 6c 65 rec is-reachable
bc30: 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 ). (host
bc40: 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 65 74 -last-update-set
bc50: 21 20 20 72 65 63 20 6c 61 73 74 2d 72 65 61 63 ! rec last-reac
bc60: 68 65 64 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 hed-time).
bc70: 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 63 70 (host-last-cp
bc80: 75 6c 6f 61 64 2d 73 65 74 21 20 72 65 63 20 6c uload-set! rec l
bc90: 6f 61 64 29 29 29 0a 20 20 20 20 20 68 6f 73 74 oad))). host
bca0: 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 s)))..(define (c
bcb0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 74 2d ommon:get-least-
bcc0: 6c 6f 61 64 65 64 2d 68 6f 73 74 20 68 6f 73 74 loaded-host host
bcd0: 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a 20 28 s-raw). (let* (
bce0: 28 68 6f 73 74 73 20 28 66 69 6c 74 65 72 20 28 (hosts (filter (
bcf0: 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 lambda (x).
bd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd10: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 (string-mat
bd20: 63 68 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 53 ch (regexp "^\\S
bd30: 2b 24 22 29 20 78 29 29 0a 20 20 20 20 20 20 20 +$") x)).
bd40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bd50: 20 68 6f 73 74 73 2d 72 61 77 29 29 0a 20 20 20 hosts-raw)).
bd60: 20 20 20 20 20 20 28 62 65 73 74 2d 68 6f 73 74 (best-host
bd70: 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 28 62 #f). (b
bd80: 65 73 74 2d 6c 6f 61 64 20 39 39 39 39 39 29 0a est-load 99999).
bd90: 20 20 20 20 20 20 20 20 20 28 63 75 72 72 2d 74 (curr-t
bda0: 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 ime (current-sec
bdb0: 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 63 6f 6d onds))). (com
bdc0: 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 74 2d mon:update-host-
bdd0: 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f 73 74 loads-table host
bde0: 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 s). (for-each
bdf0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 . (lambda (h
be00: 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 ostname).
be10: 28 6c 65 74 2a 20 28 28 72 65 63 0a 20 20 20 20 (let* ((rec.
be20: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
be30: 28 28 68 20 28 68 61 73 68 2d 74 61 62 6c 65 2d ((h (hash-table-
be40: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 6f 73 ref/default *hos
be50: 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d t-loads* hostnam
be60: 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 e #f))).
be70: 20 20 20 20 20 20 20 20 20 28 69 66 20 68 0a 20 (if h.
be80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
be90: 20 20 20 20 68 0a 20 20 20 20 20 20 20 20 20 20 h.
bea0: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
beb0: 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 29 29 ((h (make-host))
bec0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
bed0: 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 (hash-t
bee0: 61 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 74 2d able-set! *host-
bef0: 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 loads* hostname
bf00: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
bf10: 20 20 20 20 20 20 20 20 20 20 68 29 29 29 29 0a h)))).
bf20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
bf30: 65 61 63 68 61 62 6c 65 20 28 68 6f 73 74 2d 72 eachable (host-r
bf40: 65 61 63 68 61 62 6c 65 20 72 65 63 29 29 0a 20 eachable rec)).
bf50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f (lo
bf60: 61 64 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 ad (host-la
bf70: 73 74 2d 63 70 75 6c 6f 61 64 20 20 20 72 65 63 st-cpuload rec
bf80: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 6f ))). (co
bf90: 6e 64 0a 20 20 20 20 20 20 20 20 20 20 28 28 6e nd. ((n
bfa0: 6f 74 20 72 65 61 63 68 61 62 6c 65 29 20 23 66 ot reachable) #f
bfb0: 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 3c 20 ). ((<
bfc0: 28 2b 20 6c 6f 61 64 20 28 2f 20 28 72 61 6e 64 (+ load (/ (rand
bfd0: 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 20 om 250) 1000))
bfe0: 20 20 20 20 20 20 20 3b 3b 20 61 64 64 20 61 20 ;; add a
bff0: 72 61 6e 64 6f 6d 20 66 61 63 74 6f 72 20 74 6f random factor to
c000: 20 6b 65 65 70 20 66 72 6f 6d 20 67 65 74 74 69 keep from getti
c010: 6e 67 20 69 6e 20 61 20 72 75 74 0a 20 20 20 20 ng in a rut.
c020: 20 20 20 20 20 20 20 20 20 20 28 2b 20 62 65 73 (+ bes
c030: 74 2d 6c 6f 61 64 20 28 2f 20 28 72 61 6e 64 6f t-load (/ (rando
c040: 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 20 29 m 250) 1000)) )
c050: 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 . (set
c060: 21 20 62 65 73 74 2d 6c 6f 61 64 20 6c 6f 61 64 ! best-load load
c070: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 ). (se
c080: 74 21 20 62 65 73 74 2d 68 6f 73 74 20 68 6f 73 t! best-host hos
c090: 74 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 20 tname))))).
c0a0: 68 6f 73 74 73 29 0a 20 20 20 20 62 65 73 74 2d hosts). best-
c0b0: 68 6f 73 74 29 29 0a 0a 0a 0a 0a 28 64 65 66 69 host)).....(defi
c0c0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d ne (common:wait-
c0d0: 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c for-cpuload maxl
c0e0: 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 oad numcpus wait
c0f0: 64 65 6c 61 79 20 23 21 6b 65 79 20 28 63 6f 75 delay #!key (cou
c100: 6e 74 20 31 30 30 30 29 20 28 6d 73 67 20 23 66 nt 1000) (msg #f
c110: 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 )(remote-host #f
c120: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 )). (let* ((loa
c130: 64 61 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 davg (common:get
c140: 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 -cpu-load remote
c150: 2d 68 6f 73 74 29 29 0a 09 20 28 66 69 72 73 74 -host)).. (first
c160: 20 20 20 28 63 61 72 20 6c 6f 61 64 61 76 67 29 (car loadavg)
c170: 29 0a 09 20 28 6e 65 78 74 20 20 20 20 28 63 61 ).. (next (ca
c180: 64 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 dr loadavg)).. (
c190: 61 64 6a 6c 6f 61 64 20 28 2a 20 6d 61 78 6c 6f adjload (* maxlo
c1a0: 61 64 20 6e 75 6d 63 70 75 73 29 29 0a 09 20 28 ad numcpus)).. (
c1b0: 6c 6f 61 64 6a 6d 70 20 28 2d 20 66 69 72 73 74 loadjmp (- first
c1c0: 20 6e 65 78 74 29 29 29 0a 20 20 20 20 28 63 6f next))). (co
c1d0: 6e 64 0a 20 20 20 20 20 28 28 61 6e 64 20 28 3e nd. ((and (>
c1e0: 20 66 69 72 73 74 20 61 64 6a 6c 6f 61 64 29 0a first adjload).
c1f0: 09 20 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 . (> count 0))
c200: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
c210: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
c220: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 ult-log-port* "w
c230: 61 69 74 69 6e 67 20 22 20 77 61 69 74 64 65 6c aiting " waitdel
c240: 61 79 20 22 20 73 65 63 6f 6e 64 73 20 64 75 65 ay " seconds due
c250: 20 74 6f 20 6c 6f 61 64 20 22 20 66 69 72 73 74 to load " first
c260: 20 22 20 65 78 63 65 65 64 69 6e 67 20 6d 61 78 " exceeding max
c270: 20 6f 66 20 22 20 61 64 6a 6c 6f 61 64 20 28 69 of " adjload (i
c280: 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 0a 20 f msg msg "")).
c290: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
c2a0: 65 70 21 20 77 61 69 74 64 65 6c 61 79 29 0a 20 ep! waitdelay).
c2b0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 (common:wai
c2c0: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
c2d0: 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 xload numcpus wa
c2e0: 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 itdelay count: (
c2f0: 2d 20 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 - count 1))).
c300: 20 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 64 6a ((and (> loadj
c310: 6d 70 20 6e 75 6d 63 70 75 73 29 0a 09 20 20 20 mp numcpus)..
c320: 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 (> count 0)).
c330: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
c340: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
c350: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 log-port* "waiti
c360: 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 20 22 ng " waitdelay "
c370: 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 seconds due to
c380: 6c 6f 61 64 20 6a 75 6d 70 20 22 20 6c 6f 61 64 load jump " load
c390: 6a 6d 70 20 22 20 3e 20 6e 75 6d 63 70 75 73 20 jmp " > numcpus
c3a0: 22 20 6e 75 6d 63 70 75 73 20 28 69 66 20 6d 73 " numcpus (if ms
c3b0: 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 20 20 g msg "")).
c3c0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
c3d0: 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 20 20 waitdelay).
c3e0: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
c3f0: 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 r-cpuload maxloa
c400: 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 d numcpus waitde
c410: 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f lay count: (- co
c420: 75 6e 74 20 31 29 29 29 29 29 29 0a 0a 28 64 65 unt 1))))))..(de
c430: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
c440: 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 -num-cpus remote
c450: 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 20 28 28 -host). (let ((
c460: 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 28 29 0a proc (lambda ().
c470: 09 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 ..(let loop ((nu
c480: 6d 63 70 75 20 30 29 0a 09 09 09 20 20 20 28 69 mcpu 0).... (i
c490: 6e 6c 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 nl (read-line
c4a0: 29 29 29 0a 09 09 20 20 28 69 66 20 28 65 6f 66 )))... (if (eof
c4b0: 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 09 -object? inl)...
c4c0: 20 20 20 20 20 20 6e 75 6d 63 70 75 0a 09 09 20 numcpu...
c4d0: 20 20 20 20 20 28 6c 6f 6f 70 20 28 69 66 20 28 (loop (if (
c4e0: 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 70 string-match "^p
c4f0: 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 rocessor\\s+:\\s
c500: 2b 5c 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 09 09 +\\d+$" inl)....
c510: 09 28 2b 20 6e 75 6d 63 70 75 20 31 29 0a 09 09 .(+ numcpu 1)...
c520: 09 09 6e 75 6d 63 70 75 29 0a 09 09 09 20 20 20 ..numcpu)....
c530: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 (read-line)))))
c540: 29 29 0a 20 20 20 20 28 69 66 20 72 65 6d 6f 74 )). (if remot
c550: 65 2d 68 6f 73 74 0a 09 28 77 69 74 68 2d 69 6e e-host..(with-in
c560: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 put-from-pipe ..
c570: 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 72 65 (conc "ssh " re
c580: 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 61 74 20 mote-host " cat
c590: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 29 0a /proc/cpuinfo").
c5a0: 09 20 70 72 6f 63 29 0a 09 28 77 69 74 68 2d 69 . proc)..(with-i
c5b0: 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 nput-from-file "
c5c0: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 20 70 /proc/cpuinfo" p
c5d0: 72 6f 63 29 29 29 29 0a 0a 3b 3b 20 77 61 69 74 roc))))..;; wait
c5e0: 20 66 6f 72 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 for normalized
c5f0: 63 70 75 20 6c 6f 61 64 20 74 6f 20 64 72 6f 70 cpu load to drop
c600: 20 62 65 6c 6f 77 20 6d 61 78 6c 6f 61 64 0a 3b below maxload.;
c610: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
c620: 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 n:wait-for-norma
c630: 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 6c 6f lized-load maxlo
c640: 61 64 20 23 21 6b 65 79 20 28 6d 73 67 20 23 66 ad #!key (msg #f
c650: 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 )(remote-host #f
c660: 29 29 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d )). (let ((num-
c670: 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 cpus (common:get
c680: 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 -num-cpus remote
c690: 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 28 63 6f -host))). (co
c6a0: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 mmon:wait-for-cp
c6b0: 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 uload maxload nu
c6c0: 6d 2d 63 70 75 73 20 31 35 20 6d 73 67 3a 20 6d m-cpus 15 msg: m
c6d0: 73 67 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 sg)))..(define (
c6e0: 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 61 72 61 get-uname . para
c6f0: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 6e ms). (let* ((un
c700: 61 6d 65 2d 72 65 73 20 28 70 72 6f 63 65 73 73 ame-res (process
c710: 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 :cmd-run->list (
c720: 63 6f 6e 63 20 22 75 6e 61 6d 65 20 22 20 28 69 conc "uname " (i
c730: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
c740: 20 22 2d 61 22 20 28 63 61 72 20 70 61 72 61 6d "-a" (car param
c750: 73 29 29 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 s))))).. (uname
c760: 23 66 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 #f)). (if (nu
c770: 6c 6c 3f 20 28 63 61 72 20 75 6e 61 6d 65 2d 72 ll? (car uname-r
c780: 65 73 29 29 0a 09 22 75 6e 6b 6e 6f 77 6e 22 0a es)).."unknown".
c790: 09 28 63 61 61 72 20 75 6e 61 6d 65 2d 72 65 73 .(caar uname-res
c7a0: 29 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 72 65 61 ))))..;; for rea
c7b0: 73 6f 6e 73 20 49 20 64 6f 6e 27 74 20 75 6e 64 sons I don't und
c7c0: 65 72 73 74 61 6e 64 20 6d 75 6c 74 69 70 6c 65 erstand multiple
c7d0: 20 63 61 6c 6c 73 20 74 6f 20 72 65 61 6c 2d 70 calls to real-p
c7e0: 61 74 68 20 69 6e 20 70 61 72 61 6c 6c 65 6c 20 ath in parallel
c7f0: 74 68 72 65 61 64 73 0a 3b 3b 20 6d 75 73 74 20 threads.;; must
c800: 62 65 20 70 72 6f 74 65 63 74 65 64 20 62 79 20 be protected by
c810: 6d 75 74 65 78 65 73 0a 3b 3b 0a 28 64 65 66 69 mutexes.;;.(defi
c820: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d ne (common:real-
c830: 70 61 74 68 20 69 6e 70 61 74 68 29 0a 20 20 3b path inpath). ;
c840: 3b 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 ; (process:cmd-r
c850: 75 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 2d 3e un-with-stderr->
c860: 6c 69 73 74 20 22 72 65 61 64 6c 69 6e 6b 22 20 list "readlink"
c870: 22 2d 66 22 20 69 6e 70 61 74 68 29 29 20 3b 3b "-f" inpath)) ;;
c880: 20 63 6d 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 cmd . params).
c890: 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 ;; (let-values
c8a0: 0a 20 20 3b 3b 20 20 28 28 28 69 6e 70 20 6f 75 . ;; (((inp ou
c8b0: 70 20 70 69 64 29 20 28 70 72 6f 63 65 73 73 20 p pid) (process
c8c0: 22 72 65 61 64 6c 69 6e 6b 22 20 28 6c 69 73 74 "readlink" (list
c8d0: 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 29 29 "-f" inpath))))
c8e0: 0a 20 20 3b 3b 20 20 28 77 69 74 68 2d 69 6e 70 . ;; (with-inp
c8f0: 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 ut-from-port inp
c900: 0a 20 20 3b 3b 20 20 20 20 28 6c 65 74 20 6c 6f . ;; (let lo
c910: 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c op ((inl (read-l
c920: 69 6e 65 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 ine)). ;;
c930: 20 09 28 72 65 73 20 23 66 29 29 0a 20 20 3b 3b .(res #f)). ;;
c940: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 69 6e (print "in
c950: 6c 3d 22 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 l=" inl). ;;
c960: 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje
c970: 63 74 3f 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 ct? inl). ;;
c980: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
c990: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 63 ;; (c
c9a0: 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 lose-input-port
c9b0: 69 6e 70 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 inp). ;;
c9c0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 (close-outp
c9d0: 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 20 3b ut-port oup). ;
c9e0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ; ;;
c9f0: 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 69 (process-wait pi
ca00: 64 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 d). ;;
ca10: 20 20 20 72 65 73 29 0a 20 20 3b 3b 20 20 20 20 res). ;;
ca20: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 (loop (rea
ca30: 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 d-line) inl)))))
ca40: 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ). (with-input-
ca50: 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 from-pipe (conc
ca60: 22 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 69 "readlink -f " i
ca70: 6e 70 61 74 68 29 20 72 65 61 64 2d 6c 69 6e 65 npath) read-line
ca80: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
ca90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
caa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
cad0: 44 20 49 20 53 20 4b 20 20 20 53 20 50 20 41 20 D I S K S P A
cae0: 43 20 45 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d C E .;;=========
caf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
cb20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
cb30: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
cb40: 65 74 2d 64 69 73 6b 2d 73 70 61 63 65 2d 75 73 et-disk-space-us
cb50: 65 64 20 66 70 61 74 68 29 0a 20 20 28 77 69 74 ed fpath). (wit
cb60: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
cb70: 65 20 28 63 6f 6e 63 20 22 2f 75 73 72 2f 62 69 e (conc "/usr/bi
cb80: 6e 2f 64 75 20 2d 73 20 22 20 66 70 61 74 68 29 n/du -s " fpath)
cb90: 20 72 65 61 64 29 29 0a 0a 3b 3b 20 67 69 76 65 read))..;; give
cba0: 6e 20 70 61 74 68 20 67 65 74 20 66 72 65 65 20 n path get free
cbb0: 73 70 61 63 65 2c 20 61 6c 6c 6f 77 73 20 6f 76 space, allows ov
cbc0: 65 72 72 69 64 65 20 69 6e 20 5b 73 65 74 75 70 erride in [setup
cbd0: 5d 0a 3b 3b 20 77 69 74 68 20 66 72 65 65 2d 73 ].;; with free-s
cbe0: 70 61 63 65 2d 73 63 72 69 70 74 20 2f 70 61 74 pace-script /pat
cbf0: 68 2f 74 6f 2f 73 6f 6d 65 2f 73 63 72 69 70 74 h/to/some/script
cc00: 2e 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 .sh.;;.(define (
cc10: 67 65 74 2d 64 66 20 70 61 74 68 29 0a 20 20 28 get-df path). (
cc20: 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b if (configf:look
cc30: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
cc40: 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 70 61 setup" "free-spa
cc50: 63 65 2d 73 63 72 69 70 74 22 29 0a 20 20 20 20 ce-script").
cc60: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
cc70: 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 20 20 20 om-pipe .
cc80: 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 66 3a 6c (conc (configf:l
cc90: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
cca0: 2a 20 22 73 65 74 75 70 22 20 22 66 72 65 65 2d * "setup" "free-
ccb0: 73 70 61 63 65 2d 73 63 72 69 70 74 22 29 20 22 space-script") "
ccc0: 20 22 20 70 61 74 68 29 0a 20 20 20 20 20 20 20 " path).
ccd0: 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 (lambda ().. (le
cce0: 74 20 28 28 72 65 73 20 28 72 65 61 64 2d 6c 69 t ((res (read-li
ccf0: 6e 65 29 29 29 0a 09 20 20 20 28 69 66 20 28 73 ne))).. (if (s
cd00: 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 20 20 20 tring? res)..
cd10: 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d (string->num
cd20: 62 65 72 20 72 65 73 29 29 29 29 29 0a 20 20 20 ber res))))).
cd30: 20 20 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 (get-unix-df
cd40: 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 path)))..(define
cd50: 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 (get-unix-df pa
cd60: 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 66 th). (let* ((df
cd70: 2d 72 65 73 75 6c 74 73 20 28 70 72 6f 63 65 73 -results (proces
cd80: 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 s:cmd-run->list
cd90: 28 63 6f 6e 63 20 22 64 66 20 22 20 70 61 74 68 (conc "df " path
cda0: 29 29 29 0a 09 20 28 73 70 61 63 65 2d 72 78 20 ))).. (space-rx
cdb0: 20 20 28 72 65 67 65 78 70 20 22 28 5b 30 2d 39 (regexp "([0-9
cdc0: 5d 2b 29 5c 5c 73 2b 28 5b 30 2d 39 5d 2b 29 25 ]+)\\s+([0-9]+)%
cdd0: 22 29 29 0a 09 20 28 66 72 65 65 73 70 63 20 20 ")).. (freespc
cde0: 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 28 77 #f)). ;; (w
cdf0: 72 69 74 65 20 64 66 2d 72 65 73 75 6c 74 73 29 rite df-results)
ce00: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 . (for-each (
ce10: 6c 61 6d 62 64 61 20 28 6c 29 0a 09 09 28 6c 65 lambda (l)...(le
ce20: 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
ce30: 67 2d 73 65 61 72 63 68 20 73 70 61 63 65 2d 72 g-search space-r
ce40: 78 20 6c 29 29 29 0a 09 09 20 20 28 69 66 20 6d x l)))... (if m
ce50: 61 74 63 68 20 0a 09 09 20 20 20 20 20 20 28 6c atch ... (l
ce60: 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 74 72 et ((newval (str
ce70: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 ing->number (cad
ce80: 72 20 6d 61 74 63 68 29 29 29 29 0a 09 09 09 28 r match))))....(
ce90: 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 if (number? newv
cea0: 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 74 21 al).... (set!
ceb0: 20 66 72 65 65 73 70 63 20 6e 65 77 76 61 6c 29 freespc newval)
cec0: 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 63 61 ))))).. (ca
ced0: 72 20 64 66 2d 72 65 73 75 6c 74 73 29 29 0a 20 r df-results)).
cee0: 20 20 20 66 72 65 65 73 70 63 29 29 0a 0a 28 64 freespc))..(d
cef0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 efine (common:ch
cf00: 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 72 eck-space-in-dir
cf10: 20 64 69 72 70 61 74 68 20 72 65 71 75 69 72 65 dirpath require
cf20: 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 73 d). (let* ((dbs
cf30: 70 61 63 65 20 20 28 69 66 20 28 64 69 72 65 63 pace (if (direc
cf40: 74 6f 72 79 3f 20 64 69 72 70 61 74 68 29 0a 09 tory? dirpath)..
cf50: 09 20 20 20 20 20 20 20 28 67 65 74 2d 64 66 20 . (get-df
cf60: 64 69 72 70 61 74 68 29 0a 09 09 20 20 20 20 20 dirpath)...
cf70: 20 20 30 29 29 29 0a 20 20 20 20 28 6c 69 73 74 0))). (list
cf80: 20 28 3e 20 64 62 73 70 61 63 65 20 72 65 71 75 (> dbspace requ
cf90: 69 72 65 64 29 0a 09 20 20 64 62 73 70 61 63 65 ired).. dbspace
cfa0: 0a 09 20 20 72 65 71 75 69 72 65 64 0a 09 20 20 .. required..
cfb0: 64 69 72 70 61 74 68 29 29 29 0a 0a 3b 3b 20 63 dirpath)))..;; c
cfc0: 68 65 63 6b 20 73 70 61 63 65 20 69 6e 20 64 62 heck space in db
cfd0: 64 69 72 20 61 6e 64 20 69 6e 20 6d 65 67 61 74 dir and in megat
cfe0: 65 73 74 20 64 69 72 0a 3b 3b 20 72 65 74 75 72 est dir.;; retur
cff0: 6e 73 3a 20 6f 6b 2f 6e 6f 74 20 64 62 73 70 61 ns: ok/not dbspa
d000: 63 65 20 72 65 71 75 69 72 65 64 2d 73 70 61 63 ce required-spac
d010: 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f e.;;.(define (co
d020: 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 mmon:check-db-di
d030: 72 2d 73 70 61 63 65 29 0a 20 20 28 6c 65 74 2a r-space). (let*
d040: 20 28 28 72 65 71 75 69 72 65 64 20 28 73 74 72 ((required (str
d050: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 09 09 20 ing->number ...
d060: 20 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a (or (configf:
d070: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
d080: 74 2a 20 22 73 65 74 75 70 22 20 22 64 62 64 69 t* "setup" "dbdi
d090: 72 2d 73 70 61 63 65 2d 72 65 71 75 69 72 65 64 r-space-required
d0a0: 22 29 0a 09 09 09 22 31 30 30 30 30 30 22 29 29 ")...."100000"))
d0b0: 29 0a 09 20 28 64 62 64 69 72 20 20 20 20 28 63 ).. (dbdir (c
d0c0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 ommon:get-db-tmp
d0d0: 2d 61 72 65 61 29 29 20 3b 3b 20 28 64 62 3a 67 -area)) ;; (db:g
d0e0: 65 74 2d 64 62 64 69 72 29 29 0a 09 20 28 74 64 et-dbdir)).. (td
d0f0: 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a 63 bspace (common:c
d100: 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 heck-space-in-di
d110: 72 20 64 62 64 69 72 20 72 65 71 75 69 72 65 64 r dbdir required
d120: 29 29 0a 09 20 28 6d 64 62 73 70 61 63 65 20 28 )).. (mdbspace (
d130: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 common:check-spa
d140: 63 65 2d 69 6e 2d 64 69 72 20 2a 74 6f 70 70 61 ce-in-dir *toppa
d150: 74 68 2a 20 72 65 71 75 69 72 65 64 29 29 29 0a th* required))).
d160: 20 20 20 20 28 73 6f 72 74 20 28 6c 69 73 74 20 (sort (list
d170: 74 64 62 73 70 61 63 65 20 6d 64 62 73 70 61 63 tdbspace mdbspac
d180: 65 29 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 e) (lambda (a b)
d190: 0a 09 09 09 09 20 20 20 20 20 28 3c 20 28 63 61 ..... (< (ca
d1a0: 64 72 20 61 29 28 63 61 64 72 20 62 29 29 29 29 dr a)(cadr b))))
d1b0: 29 29 0a 20 20 20 20 0a 3b 3b 20 63 68 65 63 6b )). .;; check
d1c0: 20 61 76 61 69 6c 61 62 6c 65 20 73 70 61 63 65 available space
d1d0: 20 69 6e 20 64 62 64 69 72 2c 20 65 78 69 74 20 in dbdir, exit
d1e0: 69 66 20 69 6e 73 75 66 66 69 63 69 65 6e 74 0a if insufficient.
d1f0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
d200: 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d on:check-db-dir-
d210: 61 6e 64 2d 65 78 69 74 2d 69 66 2d 69 6e 73 75 and-exit-if-insu
d220: 66 66 69 63 69 65 6e 74 29 0a 20 20 28 6c 65 74 fficient). (let
d230: 2a 20 28 28 73 70 61 63 65 64 61 74 20 28 63 61 * ((spacedat (ca
d240: 72 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d r (common:check-
d250: 64 62 2d 64 69 72 2d 73 70 61 63 65 29 29 29 20 db-dir-space)))
d260: 3b 3b 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 ;; look only at
d270: 77 6f 72 73 74 20 66 6f 72 20 6e 6f 77 0a 09 20 worst for now..
d280: 28 69 73 2d 6f 6b 20 20 20 20 28 63 61 72 20 73 (is-ok (car s
d290: 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 62 73 pacedat)).. (dbs
d2a0: 70 61 63 65 20 20 28 63 61 64 72 20 73 70 61 63 pace (cadr spac
d2b0: 65 64 61 74 29 29 0a 09 20 28 72 65 71 75 69 72 edat)).. (requir
d2c0: 65 64 20 28 63 61 64 64 72 20 73 70 61 63 65 64 ed (caddr spaced
d2d0: 61 74 29 29 0a 09 20 28 64 62 64 69 72 20 20 20 at)).. (dbdir
d2e0: 20 28 63 61 64 64 64 72 20 73 70 61 63 65 64 61 (cadddr spaceda
d2f0: 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f t))). (if (no
d300: 74 20 69 73 2d 6f 6b 29 0a 09 28 62 65 67 69 6e t is-ok)..(begin
d310: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
d320: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
d330: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 73 t-log-port* "Ins
d340: 75 66 66 69 63 69 65 6e 74 20 73 70 61 63 65 20 ufficient space
d350: 69 6e 20 22 20 64 62 64 69 72 20 22 2c 20 72 65 in " dbdir ", re
d360: 71 75 69 72 65 20 22 20 72 65 71 75 69 72 65 64 quire " required
d370: 20 22 2c 20 68 61 76 65 20 22 20 64 62 73 70 61 ", have " dbspa
d380: 63 65 20 20 22 2c 20 65 78 69 74 69 6e 67 20 6e ce ", exiting n
d390: 6f 77 2e 22 29 0a 09 20 20 28 65 78 69 74 20 31 ow.").. (exit 1
d3a0: 29 29 29 29 29 0a 20 20 0a 3b 3b 20 70 61 74 68 ))))). .;; path
d3b0: 73 20 69 73 20 6c 69 73 74 20 6f 66 20 6c 69 73 s is list of lis
d3c0: 74 73 20 28 28 6e 61 6d 65 20 70 61 74 68 29 20 ts ((name path)
d3d0: 2e 2e 2e 20 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 ... ).;;.(define
d3e0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 (common:get-dis
d3f0: 6b 2d 77 69 74 68 2d 6d 6f 73 74 2d 66 72 65 65 k-with-most-free
d400: 2d 73 70 61 63 65 20 64 69 73 6b 73 20 6d 69 6e -space disks min
d410: 73 69 7a 65 29 0a 20 20 28 6c 65 74 20 28 28 62 size). (let ((b
d420: 65 73 74 20 20 20 20 20 23 66 29 0a 09 28 62 65 est #f)..(be
d430: 73 74 73 69 7a 65 20 30 29 29 0a 20 20 20 20 28 stsize 0)). (
d440: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
d450: 6c 61 6d 62 64 61 20 28 64 69 73 6b 2d 6e 75 6d lambda (disk-num
d460: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
d470: 28 64 69 72 70 61 74 68 20 20 20 20 28 63 61 64 (dirpath (cad
d480: 72 20 28 61 73 73 6f 63 20 64 69 73 6b 2d 6e 75 r (assoc disk-nu
d490: 6d 20 64 69 73 6b 73 29 29 29 0a 09 20 20 20 20 m disks)))..
d4a0: 20 20 28 66 72 65 65 73 70 63 20 20 20 20 28 63 (freespc (c
d4b0: 6f 6e 64 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 ond.... ((not
d4c0: 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 72 70 (directory? dirp
d4d0: 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 66 ath)).... (if
d4e0: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
d4f0: 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 se-print 300 "di
d500: 73 6b 73 20 6e 6f 74 20 61 20 64 69 72 20 22 20 sks not a dir "
d510: 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 disk-num).....(d
d520: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
d530: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
d540: 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 "WARNING: disk "
d550: 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 disk-num " at p
d560: 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 ath \"" dirpath
d570: 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 64 69 72 "\" is not a dir
d580: 65 63 74 6f 72 79 20 2d 20 69 67 6e 6f 72 69 6e ectory - ignorin
d590: 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 20 g it."))....
d5a0: 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 -1).... ((not
d5b0: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
d5c0: 73 73 3f 20 64 69 72 70 61 74 68 29 29 0a 09 09 ss? dirpath))...
d5d0: 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
d5e0: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
d5f0: 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 300 "disks not
d600: 77 72 69 74 65 61 62 6c 65 20 22 20 64 69 73 6b writeable " disk
d610: 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 75 67 -num).....(debug
d620: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
d630: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
d640: 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 73 NING: disk " dis
d650: 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 68 20 k-num " at path
d660: 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c 22 20 \"" dirpath "\"
d670: 69 73 20 6e 6f 74 20 77 72 69 74 65 61 62 6c 65 is not writeable
d680: 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 - ignoring it."
d690: 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 )).... -1)...
d6a0: 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 28 . ((not (eq? (
d6b0: 73 74 72 69 6e 67 2d 72 65 66 20 64 69 72 70 61 string-ref dirpa
d6c0: 74 68 20 30 29 20 23 5c 2f 29 29 0a 09 09 09 20 th 0) #\/))....
d6d0: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c (if (common:l
d6e0: 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 ow-noise-print 3
d6f0: 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 61 20 00 "disks not a
d700: 70 72 6f 70 65 72 20 70 61 74 68 20 22 20 64 69 proper path " di
d710: 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 sk-num).....(deb
d720: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
d730: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
d740: 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 ARNING: disk " d
d750: 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 isk-num " at pat
d760: 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c h \"" dirpath "\
d770: 22 20 69 73 20 6e 6f 74 20 61 20 66 75 6c 6c 79 " is not a fully
d780: 20 71 75 61 6c 69 66 69 65 64 20 70 61 74 68 20 qualified path
d790: 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 - ignoring it.")
d7a0: 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 ).... -1)....
d7b0: 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 20 (else....
d7c0: 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 29 (get-df dirpath)
d7d0: 29 29 29 29 0a 09 20 28 69 66 20 28 3e 20 66 72 )))).. (if (> fr
d7e0: 65 65 73 70 63 20 62 65 73 74 73 69 7a 65 29 0a eespc bestsize).
d7f0: 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 . (begin..
d800: 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 20 (set! best
d810: 20 20 20 20 28 63 6f 6e 73 20 64 69 73 6b 2d 6e (cons disk-n
d820: 75 6d 20 64 69 72 70 61 74 68 29 29 0a 09 20 20 um dirpath))..
d830: 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 73 (set! bests
d840: 69 7a 65 20 66 72 65 65 73 70 63 29 29 29 29 29 ize freespc)))))
d850: 0a 20 20 20 20 20 28 6d 61 70 20 63 61 72 20 64 . (map car d
d860: 69 73 6b 73 29 29 0a 20 20 20 20 28 69 66 20 28 isks)). (if (
d870: 61 6e 64 20 62 65 73 74 20 28 3e 20 62 65 73 74 and best (> best
d880: 73 69 7a 65 20 6d 69 6e 73 69 7a 65 29 29 0a 09 size minsize))..
d890: 62 65 73 74 0a 09 23 66 29 29 29 20 3b 3b 20 23 best..#f))) ;; #
d8a0: 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 73 6b 20 f means no disk
d8b0: 63 61 6e 64 69 64 61 74 65 20 66 6f 75 6e 64 0a candidate found.
d8c0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
d8d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d8e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d8f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 4e =========.;; E N
d910: 20 56 20 49 20 52 20 4f 20 4e 20 4d 20 45 20 4e V I R O N M E N
d920: 20 54 20 20 20 56 20 41 20 52 20 53 0a 3b 3b 3d T V A R S.;;=
d930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d960: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
d970: 3d 3d 3d 3d 3d 0a 09 20 20 20 20 20 20 0a 28 64 =====.. .(d
d980: 65 66 69 6e 65 20 28 73 61 76 65 2d 65 6e 76 69 efine (save-envi
d990: 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 73 ronment-as-files
d9a0: 20 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 69 67 fname #!key (ig
d9b0: 6e 6f 72 65 76 61 72 73 20 28 6c 69 73 74 20 22 norevars (list "
d9c0: 55 53 45 52 22 20 22 48 4f 4d 45 22 20 22 44 49 USER" "HOME" "DI
d9d0: 53 50 4c 41 59 22 20 22 4c 53 5f 43 4f 4c 4f 52 SPLAY" "LS_COLOR
d9e0: 53 22 20 22 58 4b 45 59 53 59 4d 44 42 22 20 22 S" "XKEYSYMDB" "
d9f0: 45 44 49 54 4f 52 22 20 22 4d 41 4b 45 46 4c 41 EDITOR" "MAKEFLA
da00: 47 53 22 20 22 4d 41 4b 45 46 22 20 22 4d 41 4b GS" "MAKEF" "MAK
da10: 45 4f 56 45 52 52 49 44 45 53 22 29 29 29 0a 20 EOVERRIDES"))).
da20: 20 28 6c 65 74 20 28 28 65 6e 76 76 61 72 73 20 (let ((envvars
da30: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
da40: 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 20 -variables)).
da50: 20 20 20 20 20 28 77 68 69 74 65 73 70 20 28 72 (whitesp (r
da60: 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 egexp "[^a-zA-Z0
da70: 2d 39 5f 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 24 5d 22 -9_\\-:,.\\/%$]"
da80: 29 29 0a 09 28 6d 75 6e 67 65 76 61 6c 20 28 6c ))..(mungeval (l
da90: 61 6d 62 64 61 20 28 76 61 6c 29 0a 09 09 20 20 ambda (val)...
daa0: 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 20 28 (cond... (
dab0: 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 22 29 (eq? val #t) "")
dac0: 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 74 20 74 ;; convert #t t
dad0: 6f 20 65 6d 70 74 79 20 73 74 72 69 6e 67 0a 09 o empty string..
dae0: 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 6c 20 . ((eq? val
daf0: 23 66 29 20 23 66 29 20 3b 3b 20 63 6f 6e 76 65 #f) #f) ;; conve
db00: 72 74 20 23 66 20 74 6f 20 69 74 73 65 6c 66 20 rt #f to itself
db10: 28 73 74 69 6c 6c 20 74 68 69 6e 6b 69 6e 67 20 (still thinking
db20: 61 62 6f 75 74 20 74 68 69 73 20 6f 6e 65 0a 09 about this one..
db30: 09 20 20 20 20 20 28 65 6c 73 65 20 76 61 6c 29 . (else val)
db40: 29 29 29 29 0a 20 20 20 20 20 28 77 69 74 68 2d )))). (with-
db50: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 output-to-file (
db60: 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 73 68 conc fname ".csh
db70: 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 "). (lambd
db80: 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 28 a (). (
db90: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
dba0: 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 20 20 (keyval)...
dbb0: 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 (let* ((key
dbc0: 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 (car keyval))...
dbd0: 09 20 20 20 20 20 28 76 61 6c 20 20 20 28 63 64 . (val (cd
dbe0: 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 r keyval))....
dbf0: 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 28 73 (delim (if (s
dc00: 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 tring-search whi
dc10: 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 09 09 tesp val) ......
dc20: 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 29 0a "\""......""))).
dc30: 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 28 6d ...(print (if (m
dc40: 65 6d 62 65 72 20 6b 65 79 20 69 67 6e 6f 72 65 ember key ignore
dc50: 76 61 72 73 29 0a 09 09 09 09 20 20 20 22 23 20 vars)..... "#
dc60: 73 65 74 65 6e 76 20 22 0a 09 09 09 09 20 20 20 setenv ".....
dc70: 22 73 65 74 65 6e 76 20 22 29 0a 09 09 09 20 20 "setenv ")....
dc80: 20 20 20 20 20 6b 65 79 20 22 20 22 20 64 65 6c key " " del
dc90: 69 6d 20 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c im (mungeval val
dca0: 29 20 64 65 6c 69 6d 29 29 29 0a 09 09 20 20 20 ) delim)))...
dcb0: 20 65 6e 76 76 61 72 73 29 29 29 0a 20 20 20 20 envvars))).
dcc0: 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f (with-output-to
dcd0: 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e 61 6d -file (conc fnam
dce0: 65 20 22 2e 73 68 22 29 0a 20 20 20 20 20 20 20 e ".sh").
dcf0: 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 (lambda ().
dd00: 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 (for-each (
dd10: 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 0a lambda (keyval).
dd20: 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 .. (let* ((
dd30: 6b 65 79 20 28 63 61 72 20 6b 65 79 76 61 6c 29 key (car keyval)
dd40: 29 0a 09 09 09 20 20 20 20 20 28 76 61 6c 20 28 ).... (val (
dd50: 63 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 cdr keyval))....
dd60: 20 20 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 (delim (if
dd70: 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 (string-search w
dd80: 68 69 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 hitesp val) ....
dd90: 09 09 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 .."\""......""))
dda0: 29 0a 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 )....(print (if
ddb0: 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 6e 6f (member key igno
ddc0: 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 20 22 revars)..... "
ddd0: 23 20 65 78 70 6f 72 74 20 22 0a 09 09 09 09 20 # export ".....
dde0: 20 20 22 65 78 70 6f 72 74 20 22 29 0a 09 09 09 "export ")....
ddf0: 20 20 20 20 20 20 20 6b 65 79 20 22 3d 22 20 64 key "=" d
de00: 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c 20 76 elim (mungeval v
de10: 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a 20 20 20 al) delim))).
de20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
de30: 20 65 6e 76 76 61 72 73 29 29 29 29 29 0a 0a 3b envvars)))))..;
de40: 3b 20 73 65 74 20 73 6f 6d 65 20 65 6e 76 20 76 ; set some env v
de50: 61 72 73 20 66 72 6f 6d 20 61 6e 20 61 6c 69 73 ars from an alis
de60: 74 2c 20 72 65 74 75 72 6e 20 61 6e 20 61 6c 69 t, return an ali
de70: 73 74 20 77 69 74 68 20 6f 72 69 67 69 6e 61 6c st with original
de80: 20 76 61 6c 75 65 73 0a 3b 3b 20 28 28 22 56 41 values.;; (("VA
de90: 52 22 20 22 76 61 6c 75 65 22 29 20 2e 2e 2e 29 R" "value") ...)
dea0: 0a 28 64 65 66 69 6e 65 20 28 61 6c 69 73 74 2d .(define (alist-
deb0: 3e 65 6e 76 2d 76 61 72 73 20 6c 73 74 29 0a 20 >env-vars lst).
dec0: 20 28 69 66 20 28 6c 69 73 74 3f 20 6c 73 74 29 (if (list? lst)
ded0: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
dee0: 73 20 27 28 29 29 29 0a 09 28 66 6f 72 2d 65 61 s '()))..(for-ea
def0: 63 68 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 ch (lambda (p)..
df00: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 76 61 72 . (let* ((var
df10: 20 28 63 61 72 20 20 70 29 29 0a 09 09 09 20 20 (car p))....
df20: 20 28 76 61 6c 20 28 63 61 64 72 20 70 29 29 0a (val (cadr p)).
df30: 09 09 09 20 20 20 28 70 72 76 20 28 67 65 74 2d ... (prv (get-
df40: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
df50: 61 62 6c 65 20 76 61 72 29 29 29 0a 09 09 20 20 able var)))...
df60: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 63 (set! res (c
df70: 6f 6e 73 20 28 6c 69 73 74 20 76 61 72 20 70 72 ons (list var pr
df80: 76 29 20 72 65 73 29 29 0a 09 09 20 20 20 20 20 v) res))...
df90: 20 28 69 66 20 76 61 6c 20 0a 09 09 09 20 20 28 (if val .... (
dfa0: 73 65 74 65 6e 76 20 76 61 72 20 28 2d 3e 73 74 setenv var (->st
dfb0: 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 ring val))....
dfc0: 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 29 (unsetenv var)))
dfd0: 29 0a 09 09 20 20 6c 73 74 29 0a 09 72 65 73 29 )... lst)..res)
dfe0: 0a 20 20 20 20 20 20 27 28 29 29 29 0a 0a 3b 3b . '()))..;;
dff0: 20 63 6c 65 61 72 20 76 61 72 73 20 6d 61 74 63 clear vars matc
e000: 68 69 6e 67 20 70 61 74 74 65 72 6e 2c 20 72 75 hing pattern, ru
e010: 6e 20 70 72 6f 63 2c 20 73 65 74 20 76 61 72 73 n proc, set vars
e020: 20 62 61 63 6b 0a 3b 3b 20 69 66 20 70 72 6f 63 back.;; if proc
e030: 20 69 73 20 61 20 73 74 72 69 6e 67 20 72 75 6e is a string run
e040: 20 74 68 61 74 20 73 74 72 69 6e 67 20 61 73 20 that string as
e050: 61 20 63 6f 6d 6d 61 6e 64 20 77 69 74 68 0a 3b a command with.;
e060: 3b 20 73 79 73 74 65 6d 2e 0a 3b 3b 0a 28 64 65 ; system..;;.(de
e070: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 fine (common:wit
e080: 68 6f 75 74 2d 76 61 72 73 20 70 72 6f 63 20 2e hout-vars proc .
e090: 20 76 61 72 2d 70 61 74 74 73 29 0a 20 20 28 6c var-patts). (l
e0a0: 65 74 20 28 28 76 61 72 73 20 28 6d 61 6b 65 2d et ((vars (make-
e0b0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 hash-table))).
e0c0: 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
e0d0: 20 28 6c 61 6d 62 64 61 20 28 76 61 72 64 61 74 (lambda (vardat
e0e0: 29 20 3b 3b 20 65 61 63 68 20 65 6e 76 20 76 61 ) ;; each env va
e0f0: 72 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 r. (for-ea
e100: 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 76 61 72 ch..(lambda (var
e110: 2d 70 61 74 74 29 0a 09 20 20 28 69 66 20 28 73 -patt).. (if (s
e120: 74 72 69 6e 67 2d 6d 61 74 63 68 20 76 61 72 2d tring-match var-
e130: 70 61 74 74 20 28 63 61 72 20 76 61 72 64 61 74 patt (car vardat
e140: 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 )).. (let (
e150: 28 76 61 72 20 28 63 61 72 20 76 61 72 64 61 74 (var (car vardat
e160: 29 29 0a 09 09 20 20 20 20 28 76 61 6c 20 28 63 ))... (val (c
e170: 64 72 20 76 61 72 64 61 74 29 29 29 0a 09 09 28 dr vardat)))...(
e180: 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 hash-table-set!
e190: 76 61 72 73 20 76 61 72 20 76 61 6c 29 0a 09 09 vars var val)...
e1a0: 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 29 (unsetenv var)))
e1b0: 29 0a 09 76 61 72 2d 70 61 74 74 73 29 29 0a 20 )..var-patts)).
e1c0: 20 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e (get-environ
e1d0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 ment-variables))
e1e0: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
e1f0: 28 28 73 74 72 69 6e 67 3f 20 70 72 6f 63 29 28 ((string? proc)(
e200: 73 79 73 74 65 6d 20 70 72 6f 63 29 29 0a 20 20 system proc)).
e210: 20 20 20 28 70 72 6f 63 20 20 20 20 20 20 20 20 (proc
e220: 20 20 28 70 72 6f 63 29 29 29 0a 20 20 20 20 28 (proc))). (
e230: 68 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 hash-table-for-e
e240: 61 63 68 0a 20 20 20 20 20 76 61 72 73 0a 20 20 ach. vars.
e250: 20 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 20 (lambda (var
e260: 76 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 val). (set
e270: 65 6e 76 20 76 61 72 20 76 61 6c 29 29 29 0a 20 env var val))).
e280: 20 20 20 76 61 72 73 29 29 0a 0a 28 64 65 66 69 vars))..(defi
e290: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 61 ne (common:run-a
e2a0: 2d 63 6f 6d 6d 61 6e 64 20 63 6d 64 20 23 21 6b -command cmd #!k
e2b0: 65 79 20 28 77 69 74 68 2d 76 61 72 73 20 23 66 ey (with-vars #f
e2c0: 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 72 65 )). (let* ((pre
e2d0: 2d 63 6d 64 20 20 28 64 74 65 73 74 73 3a 67 65 -cmd (dtests:ge
e2e0: 74 2d 70 72 65 2d 63 6f 6d 6d 61 6e 64 29 29 0a t-pre-command)).
e2f0: 20 20 20 20 20 20 20 20 20 28 70 6f 73 74 2d 63 (post-c
e300: 6d 64 20 28 64 74 65 73 74 73 3a 67 65 74 2d 70 md (dtests:get-p
e310: 6f 73 74 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 ost-command)).
e320: 20 20 20 20 20 20 20 28 66 75 6c 6c 63 6d 64 20 (fullcmd
e330: 20 28 69 66 20 28 6f 72 20 70 72 65 2d 63 6d 64 (if (or pre-cmd
e340: 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 20 20 post-cmd).
e350: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e360: 20 20 28 63 6f 6e 63 20 70 72 65 2d 63 6d 64 20 (conc pre-cmd
e370: 63 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 cmd post-cmd).
e380: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e390: 20 20 20 20 20 28 63 6f 6e 63 20 22 76 69 65 77 (conc "view
e3a0: 73 63 72 65 65 6e 20 22 20 63 6d 64 29 29 29 29 screen " cmd))))
e3b0: 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
e3c0: 74 2d 69 6e 66 6f 20 30 32 20 2a 64 65 66 61 75 t-info 02 *defau
e3d0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 75 lt-log-port* "Ru
e3e0: 6e 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 3a 20 22 nning command: "
e3f0: 20 66 75 6c 6c 63 6d 64 29 0a 20 20 20 20 28 69 fullcmd). (i
e400: 66 20 77 69 74 68 2d 76 61 72 73 0a 20 20 20 20 f with-vars.
e410: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 (common:with
e420: 6f 75 74 2d 76 61 72 73 20 63 6d 64 29 0a 20 20 out-vars cmd).
e430: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 (common:wi
e440: 74 68 6f 75 74 2d 76 61 72 73 20 66 75 6c 6c 63 thout-vars fullc
e450: 6d 64 20 22 4d 54 5f 2e 2a 22 29 29 29 29 0a 09 md "MT_.*"))))..
e460: 09 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d . .;;==========
e470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e480: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
e4b0: 54 20 49 20 4d 20 45 20 20 20 41 20 4e 20 44 20 T I M E A N D
e4c0: 20 20 44 20 41 20 54 20 45 0a 3b 3b 3d 3d 3d 3d D A T E.;;====
e4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e4f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e510: 3d 3d 0a 0a 3b 3b 20 43 6f 6e 76 65 72 74 20 73 ==..;; Convert s
e520: 74 72 69 6e 67 73 20 6c 69 6b 65 20 22 35 73 20 trings like "5s
e530: 32 68 20 33 6d 22 20 3d 3e 20 36 30 78 36 30 78 2h 3m" => 60x60x
e540: 32 20 2b 20 33 78 36 30 20 2b 20 35 0a 28 64 65 2 + 3x60 + 5.(de
e550: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 fine (common:hms
e560: 2d 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 -string->seconds
e570: 20 74 73 74 72 29 0a 20 20 28 6c 65 74 20 28 28 tstr). (let ((
e580: 70 61 72 74 73 20 20 20 20 20 28 73 74 72 69 6e parts (strin
e590: 67 2d 73 70 6c 69 74 20 74 73 74 72 29 29 0a 09 g-split tstr))..
e5a0: 28 74 69 6d 65 2d 73 65 63 73 20 30 29 0a 09 3b (time-secs 0)..;
e5b0: 3b 20 73 3d 73 65 63 6f 6e 64 73 2c 20 6d 3d 6d ; s=seconds, m=m
e5c0: 69 6e 75 74 65 73 2c 20 68 3d 68 6f 75 72 73 2c inutes, h=hours,
e5d0: 20 64 3d 64 61 79 73 0a 09 28 74 72 78 20 20 20 d=days..(trx
e5e0: 20 20 20 20 28 72 65 67 65 78 70 20 22 28 5c 5c (regexp "(\\
e5f0: 64 2b 29 28 5b 73 6d 68 64 5d 29 22 29 29 29 0a d+)([smhd])"))).
e600: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
e610: 61 6d 62 64 61 20 28 70 61 72 74 29 0a 09 09 28 ambda (part)...(
e620: 6c 65 74 20 28 28 6d 61 74 63 68 20 20 28 73 74 let ((match (st
e630: 72 69 6e 67 2d 6d 61 74 63 68 20 74 72 78 20 70 ring-match trx p
e640: 61 72 74 29 29 29 0a 09 09 20 20 28 69 66 20 6d art)))... (if m
e650: 61 74 63 68 0a 09 09 20 20 20 20 20 20 28 6c 65 atch... (le
e660: 74 20 28 28 76 61 6c 20 28 73 74 72 69 6e 67 2d t ((val (string-
e670: 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d 61 >number (cadr ma
e680: 74 63 68 29 29 29 0a 09 09 09 20 20 20 20 28 75 tch))).... (u
e690: 6e 74 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 nt (caddr match)
e6a0: 29 29 0a 09 09 09 28 69 66 20 76 61 6c 20 0a 09 ))....(if val ..
e6b0: 09 09 20 20 20 20 28 73 65 74 21 20 74 69 6d 65 .. (set! time
e6c0: 2d 73 65 63 73 20 28 2b 20 74 69 6d 65 2d 73 65 -secs (+ time-se
e6d0: 63 73 20 28 2a 20 76 61 6c 0a 09 09 09 09 09 09 cs (* val.......
e6e0: 09 20 20 20 20 28 63 61 73 65 20 28 73 74 72 69 . (case (stri
e6f0: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 75 6e 74 29 0a ng->symbol unt).
e700: 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 73 ....... ((s
e710: 29 20 31 29 0a 09 09 09 09 09 09 09 20 20 20 20 ) 1)........
e720: 20 20 28 28 6d 29 20 36 30 29 0a 09 09 09 09 09 ((m) 60)......
e730: 09 09 20 20 20 20 20 20 28 28 68 29 20 28 2a 20 .. ((h) (*
e740: 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 20 60 60))........
e750: 20 20 20 20 20 28 28 64 29 20 28 2a 20 32 34 20 ((d) (* 24
e760: 36 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 20 60 60))........
e770: 20 20 20 20 20 28 65 6c 73 65 20 30 29 29 29 29 (else 0))))
e780: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 70 61 )))))).. pa
e790: 72 74 73 29 0a 20 20 20 20 74 69 6d 65 2d 73 65 rts). time-se
e7a0: 63 73 29 29 0a 09 09 20 20 20 20 20 20 20 0a 28 cs))... .(
e7b0: 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d define (seconds-
e7c0: 3e 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 63 73 >hr-min-sec secs
e7d0: 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 73 20 ). (let* ((hrs
e7e0: 28 71 75 6f 74 69 65 6e 74 20 73 65 63 73 20 33 (quotient secs 3
e7f0: 36 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 71 75 600)).. (min (qu
e800: 6f 74 69 65 6e 74 20 28 2d 20 73 65 63 73 20 28 otient (- secs (
e810: 2a 20 68 72 73 20 33 36 30 30 29 29 20 36 30 29 * hrs 3600)) 60)
e820: 29 0a 09 20 28 73 65 63 20 28 2d 20 73 65 63 73 ).. (sec (- secs
e830: 20 28 2a 20 68 72 73 20 33 36 30 30 29 28 2a 20 (* hrs 3600)(*
e840: 6d 69 6e 20 36 30 29 29 29 29 0a 20 20 20 20 28 min 60)))). (
e850: 63 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 73 20 conc (if (> hrs
e860: 30 29 28 63 6f 6e 63 20 68 72 73 20 22 68 72 20 0)(conc hrs "hr
e870: 22 29 20 22 22 29 0a 09 20 20 28 69 66 20 28 3e ") "").. (if (>
e880: 20 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d 69 6e min 0)(conc min
e890: 20 22 6d 20 22 29 20 20 22 22 29 0a 09 20 20 73 "m ") "").. s
e8a0: 65 63 20 22 73 22 29 29 29 0a 0a 28 64 65 66 69 ec "s")))..(defi
e8b0: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d ne (seconds->tim
e8c0: 65 2d 73 74 72 69 6e 67 20 73 65 63 29 0a 20 20 e-string sec).
e8d0: 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 20 (time->string .
e8e0: 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 (seconds->loca
e8f0: 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 48 3a l-time sec) "%H:
e900: 25 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 69 6e %M:%S"))..(defin
e910: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b e (seconds->work
e920: 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 -week/day-time s
e930: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
e940: 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ing. (seconds-
e950: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
e960: 20 22 77 77 25 56 2e 25 75 20 25 48 3a 25 4d 22 "ww%V.%u %H:%M"
e970: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ))..(define (sec
e980: 6f 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f onds->work-week/
e990: 64 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d 65 day sec). (time
e9a0: 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 ->string. (sec
e9b0: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
e9c0: 20 73 65 63 29 20 22 77 77 25 56 2e 25 75 22 29 sec) "ww%V.%u")
e9d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
e9e0: 6e 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 nds->year-work-w
e9f0: 65 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 28 eek/day sec). (
ea00: 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 time->string.
ea10: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
ea20: 74 69 6d 65 20 73 65 63 29 20 22 25 79 77 77 25 time sec) "%yww%
ea30: 56 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 6e 65 V.%w"))..(define
ea40: 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d (seconds->year-
ea50: 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 work-week/day-ti
ea60: 6d 65 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d me sec). (time-
ea70: 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f >string. (seco
ea80: 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 nds->local-time
ea90: 73 65 63 29 20 22 25 59 77 77 25 56 2e 25 77 20 sec) "%Yww%V.%w
eaa0: 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 69 6e %H:%M"))..(defin
eab0: 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 e (seconds->year
eac0: 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 -week/day-time s
ead0: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
eae0: 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ing. (seconds-
eaf0: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
eb00: 20 22 25 59 77 25 56 2e 25 77 20 25 48 3a 25 4d "%Yw%V.%w %H:%M
eb10: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 "))..(define (se
eb20: 63 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 20 73 conds->quarter s
eb30: 65 63 29 0a 20 20 28 63 61 73 65 20 28 73 74 72 ec). (case (str
eb40: 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 28 74 ing->number.. (t
eb50: 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 09 20 20 ime->string ..
eb60: 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
eb70: 74 69 6d 65 20 73 65 63 29 0a 09 20 20 22 25 6d time sec).. "%m
eb80: 22 29 29 0a 20 20 20 20 28 28 31 20 32 20 33 29 ")). ((1 2 3)
eb90: 20 31 29 0a 20 20 20 20 28 28 34 20 35 20 36 29 1). ((4 5 6)
eba0: 20 32 29 0a 20 20 20 20 28 28 37 20 38 20 39 29 2). ((7 8 9)
ebb0: 20 33 29 0a 20 20 20 20 28 28 31 30 20 31 31 20 3). ((10 11
ebc0: 31 32 29 20 34 29 0a 20 20 20 20 28 65 6c 73 65 12) 4). (else
ebd0: 20 23 66 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e #f)))..;; given
ebe0: 20 73 70 61 6e 20 6f 66 20 73 65 63 6f 6e 64 73 span of seconds
ebf0: 20 74 73 74 61 72 74 20 74 6f 20 74 65 6e 64 0a tstart to tend.
ec00: 3b 3b 20 66 69 6e 64 20 73 74 61 72 74 20 74 69 ;; find start ti
ec10: 6d 65 20 74 6f 20 6d 61 72 6b 20 61 6e 64 20 6d me to mark and m
ec20: 61 72 6b 20 64 65 6c 74 61 0a 3b 3b 0a 28 64 65 ark delta.;;.(de
ec30: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6e fine (common:fin
ec40: 64 2d 73 74 61 72 74 2d 6d 61 72 6b 2d 61 6e 64 d-start-mark-and
ec50: 2d 6d 61 72 6b 2d 64 65 6c 74 61 20 74 73 74 61 -mark-delta tsta
ec60: 72 74 20 74 65 6e 64 29 0a 20 20 28 6c 65 74 2a rt tend). (let*
ec70: 20 28 28 64 65 6c 74 61 74 20 20 20 28 2d 20 28 ((deltat (- (
ec80: 6d 61 78 20 74 65 6e 64 20 28 2b 20 74 65 6e 64 max tend (+ tend
ec90: 20 31 30 29 29 20 74 73 74 61 72 74 29 29 20 3b 10)) tstart)) ;
eca0: 3b 20 63 61 6e 27 74 20 68 61 6e 64 6c 65 20 72 ; can't handle r
ecb0: 75 6e 73 20 6f 66 20 6c 65 73 73 20 74 68 61 6e uns of less than
ecc0: 20 34 20 73 65 63 6f 6e 64 73 2e 20 50 61 64 20 4 seconds. Pad
ecd0: 69 74 20 74 6f 20 31 30 20 73 65 63 6f 6e 64 73 it to 10 seconds
ece0: 20 2e 2e 2e 0a 09 20 28 72 65 73 75 6c 74 20 20 ..... (result
ecf0: 20 23 66 29 0a 09 20 28 6d 69 6e 20 20 20 20 20 #f).. (min
ed00: 20 36 30 29 0a 09 20 28 68 72 20 20 20 20 20 20 60).. (hr
ed10: 20 28 2a 20 36 30 20 36 30 29 29 0a 09 20 28 64 (* 60 60)).. (d
ed20: 61 79 20 20 20 20 20 20 28 2a 20 32 34 20 68 72 ay (* 24 hr
ed30: 29 29 0a 09 20 28 79 72 20 20 20 20 20 20 20 28 )).. (yr (
ed40: 2a 20 33 36 35 20 64 61 79 29 29 20 3b 3b 20 79 * 365 day)) ;; y
ed50: 65 61 72 0a 09 20 28 6d 6f 20 20 20 20 20 20 20 ear.. (mo
ed60: 28 2f 20 79 72 20 31 32 29 29 0a 09 20 28 77 6b (/ yr 12)).. (wk
ed70: 20 20 20 20 20 20 20 28 2a 20 64 61 79 20 37 29 (* day 7)
ed80: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
ed90: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 6d . (lambda (m
eda0: 61 78 2d 62 6c 6b 73 29 0a 20 20 20 20 20 20 20 ax-blks).
edb0: 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 6d 62 (for-each..(lamb
edc0: 64 61 20 28 73 70 61 6e 29 20 3b 3b 20 35 20 32 da (span) ;; 5 2
edd0: 20 31 0a 09 20 20 28 69 66 20 28 6e 6f 74 20 72 1.. (if (not r
ede0: 65 73 75 6c 74 29 0a 09 20 20 20 20 20 20 28 66 esult).. (f
edf0: 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 20 20 or-each ..
ee00: 20 28 6c 61 6d 62 64 61 20 28 74 69 6d 65 75 6e (lambda (timeun
ee10: 69 74 20 74 69 6d 65 73 79 6d 29 20 3b 3b 20 79 it timesym) ;; y
ee20: 65 61 72 20 6d 6f 6e 74 68 20 64 61 79 20 68 72 ear month day hr
ee30: 20 6d 69 6e 20 73 65 63 0a 09 09 20 28 69 66 20 min sec... (if
ee40: 28 6e 6f 74 20 72 65 73 75 6c 74 29 0a 09 09 20 (not result)...
ee50: 20 20 20 20 28 6c 65 74 2a 20 28 28 74 69 6d 65 (let* ((time
ee60: 2d 62 6c 6b 20 28 2a 20 73 70 61 6e 20 74 69 6d -blk (* span tim
ee70: 65 75 6e 69 74 29 29 0a 09 09 09 20 20 20 20 28 eunit)).... (
ee80: 6e 75 6d 2d 62 6c 6b 73 20 28 71 75 6f 74 69 65 num-blks (quotie
ee90: 6e 74 20 64 65 6c 74 61 74 20 74 69 6d 65 2d 62 nt deltat time-b
eea0: 6c 6b 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 lk)))... (
eeb0: 69 66 20 28 61 6e 64 20 28 3e 20 6e 75 6d 2d 62 if (and (> num-b
eec0: 6c 6b 73 20 34 29 28 3c 20 6e 75 6d 2d 62 6c 6b lks 4)(< num-blk
eed0: 73 20 6d 61 78 2d 62 6c 6b 73 29 29 0a 09 09 09 s max-blks))....
eee0: 20 20 20 28 6c 65 74 20 28 28 66 69 72 73 74 20 (let ((first
eef0: 28 2a 20 28 71 75 6f 74 69 65 6e 74 20 74 73 74 (* (quotient tst
ef00: 61 72 74 20 74 69 6d 65 2d 62 6c 6b 29 20 74 69 art time-blk) ti
ef10: 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 09 20 20 20 me-blk)))....
ef20: 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 20 28 (set! result (
ef30: 6c 69 73 74 20 73 70 61 6e 20 74 69 6d 65 75 6e list span timeun
ef40: 69 74 20 74 69 6d 65 2d 62 6c 6b 20 66 69 72 73 it time-blk firs
ef50: 74 20 74 69 6d 65 73 79 6d 29 29 0a 09 09 09 20 t timesym))....
ef60: 20 20 20 20 29 29 29 29 29 0a 09 20 20 20 20 20 )))))..
ef70: 20 20 28 6c 69 73 74 20 79 72 20 6d 6f 20 77 6b (list yr mo wk
ef80: 20 64 61 79 20 68 72 20 6d 69 6e 20 31 29 0a 09 day hr min 1)..
ef90: 20 20 20 20 20 20 20 27 28 20 20 20 20 20 79 20 '( y
efa0: 20 6d 6f 20 77 20 20 64 20 20 20 68 20 20 6d 20 mo w d h m
efb0: 20 20 73 29 29 29 29 0a 09 28 6c 69 73 74 20 38 s))))..(list 8
efc0: 20 36 20 35 20 32 20 31 29 29 29 0a 20 20 20 20 6 5 2 1))).
efd0: 20 27 28 35 20 31 30 20 31 35 20 32 30 20 33 30 '(5 10 15 20 30
efe0: 20 34 30 20 35 30 20 35 30 30 29 29 0a 20 20 20 40 50 500)).
eff0: 20 28 69 66 20 76 61 6c 75 65 73 0a 09 28 61 70 (if values..(ap
f000: 70 6c 79 20 76 61 6c 75 65 73 20 72 65 73 75 6c ply values resul
f010: 74 29 0a 09 28 76 61 6c 75 65 73 20 30 20 64 61 t)..(values 0 da
f020: 79 20 31 20 30 20 27 64 29 29 29 29 0a 09 20 20 y 1 0 'd))))..
f030: 20 20 0a 09 20 20 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d .. ..;;======
f040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f080: 0a 3b 3b 20 43 20 4f 20 4c 20 4f 20 52 20 53 0a .;; C O L O R S.
f090: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
f0a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f0d0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 20 0a ========. .
f0e0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
f0f0: 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f 72 20 name->iup-color
f100: 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 28 73 name). (case (s
f110: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 tring->symbol (s
f120: 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 6e tring-downcase n
f130: 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 64 29 ame)). ((red)
f140: 20 20 20 20 22 32 32 33 20 33 33 20 34 39 22 29 "223 33 49")
f150: 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 20 22 . ((grey) "
f160: 31 39 32 20 31 39 32 20 31 39 32 22 29 0a 20 20 192 192 192").
f170: 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 35 35 ((orange) "255
f180: 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 28 28 172 13"). ((
f190: 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 69 73 purple) "This is
f1a0: 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e 2e 22 unfinished ..."
f1b0: 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 )))..;; (define
f1c0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
f1d0: 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 61 74 r-for-state-stat
f1e0: 75 73 20 73 74 61 74 65 20 73 74 61 74 75 73 29 us state status)
f1f0: 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 73 74 72 .;; (case (str
f200: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 74 ing->symbol stat
f210: 65 29 0a 3b 3b 20 20 20 20 20 28 28 43 4f 4d 50 e).;; ((COMP
f220: 4c 45 54 45 44 29 0a 3b 3b 20 20 20 20 20 20 28 LETED).;; (
f230: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
f240: 6d 62 6f 6c 20 73 74 61 74 75 73 29 0a 3b 3b 20 mbol status).;;
f250: 20 20 20 20 20 20 20 28 28 50 41 53 53 29 20 20 ((PASS)
f260: 20 20 20 20 20 20 22 37 30 20 20 32 34 39 20 37 "70 249 7
f270: 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 3").;; ((
f280: 57 41 52 4e 20 57 41 49 56 45 44 29 20 22 32 35 WARN WAIVED) "25
f290: 35 20 31 37 32 20 31 33 22 29 0a 3b 3b 20 20 20 5 172 13").;;
f2a0: 20 20 20 20 20 28 28 53 4b 49 50 29 20 20 20 20 ((SKIP)
f2b0: 20 20 20 20 22 32 33 30 20 32 33 30 20 30 22 29 "230 230 0")
f2c0: 0a 3b 3b 20 20 20 20 20 20 20 20 28 65 6c 73 65 .;; (else
f2d0: 20 22 32 32 33 20 33 33 20 34 39 22 29 29 29 0a "223 33 49"))).
f2e0: 3b 3b 20 20 20 20 20 28 28 4c 41 55 4e 43 48 45 ;; ((LAUNCHE
f2f0: 44 29 20 20 20 20 20 20 20 20 20 22 31 30 31 20 D) "101
f300: 31 32 33 20 31 34 32 22 29 0a 3b 3b 20 20 20 20 123 142").;;
f310: 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 20 20 ((CHECK)
f320: 20 20 20 20 20 22 32 35 35 20 31 30 30 20 35 30 "255 100 50
f330: 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 45 4d 4f ").;; ((REMO
f340: 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 22 35 TEHOSTSTART) "5
f350: 30 20 20 31 33 30 20 31 39 35 22 29 0a 3b 3b 20 0 130 195").;;
f360: 20 20 20 20 28 28 52 55 4e 4e 49 4e 47 29 20 20 ((RUNNING)
f370: 20 20 20 20 20 20 20 20 22 39 20 20 20 31 33 31 "9 131
f380: 20 32 33 32 22 29 0a 3b 3b 20 20 20 20 20 28 28 232").;; ((
f390: 4b 49 4c 4c 52 45 51 29 20 20 20 20 20 20 20 20 KILLREQ)
f3a0: 20 20 22 33 39 20 20 38 32 20 20 32 30 36 22 29 "39 82 206")
f3b0: 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c 45 44 .;; ((KILLED
f3c0: 29 20 20 20 20 20 20 20 20 20 20 20 22 32 33 34 ) "234
f3d0: 20 31 30 31 20 31 37 22 29 0a 3b 3b 20 20 20 20 101 17").;;
f3e0: 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 29 20 ((NOT_STARTED)
f3f0: 20 20 20 20 20 22 32 34 30 20 32 34 30 20 32 34 "240 240 24
f400: 30 22 29 0a 3b 3b 20 20 20 20 20 28 65 6c 73 65 0").;; (else
f410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
f420: 31 39 32 20 31 39 32 20 31 39 32 22 29 29 29 0a 192 192 192"))).
f430: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
f440: 3a 69 75 70 2d 63 6f 6c 6f 72 2d 3e 72 67 62 2d :iup-color->rgb-
f450: 68 65 78 20 69 6e 73 74 72 29 0a 20 20 28 73 74 hex instr). (st
f460: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
f470: 20 0a 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 . (map (lambd
f480: 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 20 a (x).
f490: 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 (number->string
f4a0: 78 20 31 36 29 29 0a 20 20 20 20 20 20 20 20 28 x 16)). (
f4b0: 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 map string->numb
f4c0: 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 er.
f4d0: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 6e (string-split in
f4e0: 73 74 72 29 29 29 0a 20 20 20 22 2f 22 29 29 0a str))). "/")).
f4f0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
f500: 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d :get-color-from-
f510: 73 74 61 74 75 73 20 73 74 61 74 75 73 29 0a 20 status status).
f520: 20 28 63 6f 6e 64 0a 20 20 20 28 28 65 71 75 61 (cond. ((equa
f530: 6c 3f 20 73 74 61 74 75 73 20 22 50 41 53 53 22 l? status "PASS"
f540: 29 20 20 20 20 22 67 72 65 65 6e 22 29 0a 20 20 ) "green").
f550: 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 ((equal? status
f560: 20 22 46 41 49 4c 22 29 20 20 20 20 22 72 65 64 "FAIL") "red
f570: 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 "). ((equal? s
f580: 74 61 74 75 73 20 22 57 41 52 4e 22 29 20 20 20 tatus "WARN")
f590: 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 28 "orange"). ((
f5a0: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 4b equal? status "K
f5b0: 49 4c 4c 45 44 22 29 20 20 22 6f 72 61 6e 67 65 ILLED") "orange
f5c0: 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 "). ((equal? s
f5d0: 74 61 74 75 73 20 22 4b 49 4c 4c 52 45 51 22 29 tatus "KILLREQ")
f5e0: 20 22 70 75 72 70 6c 65 22 29 0a 20 20 20 28 28 "purple"). ((
f5f0: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 52 equal? status "R
f600: 55 4e 4e 49 4e 47 22 29 20 22 62 6c 75 65 22 29 UNNING") "blue")
f610: 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
f620: 74 75 73 20 22 41 42 4f 52 54 22 29 20 20 20 22 tus "ABORT") "
f630: 62 72 6f 77 6e 22 29 0a 20 20 20 28 65 6c 73 65 brown"). (else
f640: 20 22 62 6c 61 63 6b 22 29 29 29 0a 0a 3b 3b 3d "black")))..;;=
f650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f690: 3d 3d 3d 3d 3d 0a 3b 3b 20 4e 20 41 20 4e 20 4f =====.;; N A N O
f6a0: 20 4d 20 53 20 47 20 20 20 43 20 4c 20 49 20 45 M S G C L I E
f6b0: 20 4e 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d N T.;;=========
f6c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f6f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
f700: 64 65 66 69 6e 65 20 28 73 65 72 76 65 72 3a 67 define (server:g
f710: 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
f720: 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 0a dress hostname).
f730: 20 20 28 6c 65 74 20 28 28 72 65 73 20 23 66 29 (let ((res #f)
f740: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
f750: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 . (lambda (a
f760: 64 72 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 dr). (if (
f770: 6e 6f 74 20 28 65 71 3f 20 28 75 38 76 65 63 74 not (eq? (u8vect
f780: 6f 72 2d 72 65 66 20 61 64 72 20 30 29 20 31 32 or-ref adr 0) 12
f790: 37 29 29 0a 09 20 20 20 28 73 65 74 21 20 72 65 7)).. (set! re
f7a0: 73 20 61 64 72 29 29 29 0a 20 20 20 20 20 3b 3b s adr))). ;;
f7b0: 20 4e 4f 54 45 3a 20 54 68 69 73 20 63 61 6e 20 NOTE: This can
f7c0: 66 61 69 6c 20 77 68 65 6e 20 74 68 65 72 65 20 fail when there
f7d0: 69 73 20 6e 6f 20 6d 65 6e 74 69 6f 6e 20 6f 66 is no mention of
f7e0: 20 74 68 65 20 68 6f 73 74 20 69 6e 20 2f 65 74 the host in /et
f7f0: 63 2f 68 6f 73 74 73 2e 20 46 49 58 4d 45 0a 20 c/hosts. FIXME.
f800: 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 (vector->lis
f810: 74 20 28 68 6f 73 74 69 6e 66 6f 2d 61 64 64 72 t (hostinfo-addr
f820: 65 73 73 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d esses (hostname-
f830: 3e 68 6f 73 74 69 6e 66 6f 20 68 6f 73 74 6e 61 >hostinfo hostna
f840: 6d 65 29 29 29 29 0a 20 20 20 20 28 73 74 72 69 me)))). (stri
f850: 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 0a ng-intersperse .
f860: 20 20 20 20 20 28 6d 61 70 20 6e 75 6d 62 65 72 (map number
f870: 2d 3e 73 74 72 69 6e 67 0a 09 20 20 28 75 38 76 ->string.. (u8v
f880: 65 63 74 6f 72 2d 3e 6c 69 73 74 0a 09 20 20 20 ector->list..
f890: 28 69 66 20 72 65 73 20 72 65 73 20 28 68 6f 73 (if res res (hos
f8a0: 74 6e 61 6d 65 2d 3e 69 70 20 68 6f 73 74 6e 61 tname->ip hostna
f8b0: 6d 65 29 29 29 29 20 22 2e 22 29 29 29 0a 0a 0a me)))) ".")))...
f8c0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
f8d0: 73 65 6e 64 2d 64 62 6f 61 72 64 2d 6d 61 69 6e send-dboard-main
f8e0: 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 6c 65 74 -changed). (let
f8f0: 2a 20 28 28 64 61 73 68 62 6f 61 72 64 2d 69 70 * ((dashboard-ip
f900: 73 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 s (mddb:get-dash
f910: 62 6f 61 72 64 73 29 29 29 0a 20 20 20 20 28 66 boards))). (f
f920: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
f930: 6d 62 64 61 20 28 69 70 61 64 72 29 0a 20 20 20 mbda (ipadr).
f940: 20 20 20 20 28 6c 65 74 2a 20 28 28 73 6f 63 20 (let* ((soc
f950: 28 63 6f 6d 6d 6f 6e 3a 6f 70 65 6e 2d 6e 6d 2d (common:open-nm-
f960: 72 65 71 20 28 63 6f 6e 63 20 22 74 63 70 3a 2f req (conc "tcp:/
f970: 2f 22 20 69 70 61 64 72 29 29 29 0a 09 20 20 20 /" ipadr)))..
f980: 20 20 20 28 6d 73 67 20 28 63 6f 6e 63 20 22 6d (msg (conc "m
f990: 61 69 6e 20 22 20 2a 74 6f 70 70 61 74 68 2a 29 ain " *toppath*)
f9a0: 29 0a 09 20 20 20 20 20 20 28 72 65 73 20 28 63 ).. (res (c
f9b0: 6f 6d 6d 6f 6e 3a 6e 6d 2d 73 65 6e 64 2d 72 65 ommon:nm-send-re
f9c0: 63 65 69 76 65 2d 74 69 6d 65 6f 75 74 20 73 6f ceive-timeout so
f9d0: 63 20 6d 73 67 29 29 29 0a 09 20 28 69 66 20 28 c msg))).. (if (
f9e0: 6e 6f 74 20 72 65 73 29 20 3b 3b 20 63 6f 75 6c not res) ;; coul
f9f0: 64 6e 27 74 20 72 65 61 63 68 20 74 68 61 74 20 dn't reach that
fa00: 64 61 73 68 62 6f 61 72 64 20 2d 20 72 65 6d 6f dashboard - remo
fa10: 76 65 20 69 74 20 66 72 6f 6d 20 64 62 0a 09 20 ve it from db..
fa20: 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f (print "ERRO
fa30: 52 3a 20 63 6f 75 6c 64 6e 27 74 20 72 65 61 63 R: couldn't reac
fa40: 68 20 64 61 73 68 62 6f 61 72 64 20 22 20 69 70 h dashboard " ip
fa50: 61 64 72 29 29 0a 09 20 72 65 73 29 29 0a 20 20 adr)).. res)).
fa60: 20 20 20 64 61 73 68 62 6f 61 72 64 2d 69 70 73 dashboard-ips
fa70: 29 29 29 0a 20 20 20 20 0a 20 20 20 20 0a 3b 3b ))). . .;;
fa80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fa90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
faa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fac0: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 ======.;; D A S
fad0: 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 44 20 H B O A R D D
fae0: 42 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d B .;;===========
faf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fb20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
fb30: 66 69 6e 65 20 28 6d 64 64 62 3a 6f 70 65 6e 2d fine (mddb:open-
fb40: 64 62 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 db). (let* ((db
fb50: 20 28 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 (open-database
fb60: 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 (conc (get-envir
fb70: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
fb80: 22 48 4f 4d 45 22 29 20 22 2f 2e 64 61 73 68 62 "HOME") "/.dashb
fb90: 6f 61 72 64 2e 64 62 22 29 29 29 29 0a 20 20 20 oard.db")))).
fba0: 20 28 73 65 74 2d 62 75 73 79 2d 68 61 6e 64 6c (set-busy-handl
fbb0: 65 72 21 20 64 62 20 28 62 75 73 79 2d 74 69 6d er! db (busy-tim
fbc0: 65 6f 75 74 20 31 30 30 30 30 29 29 0a 20 20 20 eout 10000)).
fbd0: 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
fbe0: 28 6c 61 6d 62 64 61 20 28 71 72 79 29 0a 20 20 (lambda (qry).
fbf0: 20 20 20 20 20 28 65 78 65 63 20 28 73 71 6c 20 (exec (sql
fc00: 64 62 20 71 72 79 29 29 29 0a 20 20 20 20 20 28 db qry))). (
fc10: 6c 69 73 74 20 0a 20 20 20 20 20 20 22 43 52 45 list . "CRE
fc20: 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 ATE TABLE IF NOT
fc30: 20 45 58 49 53 54 53 20 76 61 72 73 20 20 20 20 EXISTS vars
fc40: 20 20 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 (id INTEGER P
fc50: 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 20 54 RIMARY KEY,key T
fc60: 45 58 54 2c 20 76 61 6c 20 54 45 58 54 2c 20 43 EXT, val TEXT, C
fc70: 4f 4e 53 54 52 41 49 4e 54 20 76 61 72 73 63 6f ONSTRAINT varsco
fc80: 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 45 20 nstraint UNIQUE
fc90: 28 6b 65 79 29 29 3b 22 0a 20 20 20 20 20 20 22 (key));". "
fca0: 43 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 CREATE TABLE IF
fcb0: 4e 4f 54 20 45 58 49 53 54 53 20 64 61 73 68 62 NOT EXISTS dashb
fcc0: 6f 61 72 64 73 20 28 0a 20 20 20 20 20 20 20 20 oards (.
fcd0: 20 20 69 64 20 20 20 20 20 20 20 20 20 49 4e 54 id INT
fce0: 45 47 45 52 20 50 52 49 4d 41 52 59 20 4b 45 59 EGER PRIMARY KEY
fcf0: 2c 0a 20 20 20 20 20 20 20 20 20 20 70 69 64 20 ,. pid
fd00: 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 2c 0a INTEGER,.
fd10: 20 20 20 20 20 20 20 20 20 20 75 73 65 72 6e 61 userna
fd20: 6d 65 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 me TEXT,.
fd30: 20 20 20 20 20 68 6f 73 74 6e 61 6d 65 20 20 20 hostname
fd40: 54 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 TEXT,.
fd50: 69 70 61 64 64 72 20 20 20 20 20 54 45 58 54 2c ipaddr TEXT,
fd60: 0a 20 20 20 20 20 20 20 20 20 20 70 6f 72 74 6e . portn
fd70: 75 6d 20 20 20 20 49 4e 54 45 47 45 52 2c 0a 20 um INTEGER,.
fd80: 20 20 20 20 20 20 20 20 20 73 74 61 72 74 5f 74 start_t
fd90: 69 6d 65 20 54 49 4d 45 53 54 41 4d 50 20 44 45 ime TIMESTAMP DE
fda0: 46 41 55 4c 54 20 28 73 74 72 66 74 69 6d 65 28 FAULT (strftime(
fdb0: 27 25 73 27 2c 27 6e 6f 77 27 29 29 2c 0a 20 20 '%s','now')),.
fdc0: 20 20 20 20 20 20 20 20 20 20 20 43 4f 4e 53 54 CONST
fdd0: 52 41 49 4e 54 20 68 6f 73 74 70 6f 72 74 20 55 RAINT hostport U
fde0: 4e 49 51 55 45 20 28 68 6f 73 74 6e 61 6d 65 2c NIQUE (hostname,
fdf0: 70 6f 72 74 6e 75 6d 29 0a 20 20 20 20 20 20 20 portnum).
fe00: 20 29 3b 22 0a 20 20 20 20 20 20 29 29 0a 20 20 );". )).
fe10: 20 20 64 62 29 29 0a 0a 3b 3b 20 72 65 67 69 73 db))..;; regis
fe20: 74 65 72 20 61 20 64 61 73 68 62 6f 61 72 64 20 ter a dashboard
fe30: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 .;;.(define (mdd
fe40: 62 3a 72 65 67 69 73 74 65 72 2d 64 61 73 68 62 b:register-dashb
fe50: 6f 61 72 64 20 70 6f 72 74 29 0a 20 20 28 6c 65 oard port). (le
fe60: 74 2a 20 28 28 70 69 64 20 20 20 20 20 20 28 63 t* ((pid (c
fe70: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
fe80: 64 29 29 0a 09 20 28 68 6f 73 74 6e 61 6d 65 20 d)).. (hostname
fe90: 28 67 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 (get-host-name))
fea0: 0a 09 20 28 69 70 61 64 64 72 20 20 20 28 73 65 .. (ipaddr (se
feb0: 72 76 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 rver:get-best-gu
fec0: 65 73 73 2d 61 64 64 72 65 73 73 20 68 6f 73 74 ess-address host
fed0: 6e 61 6d 65 29 29 0a 09 20 28 75 73 65 72 6e 61 name)).. (userna
fee0: 6d 65 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 me (current-user
fef0: 2d 6e 61 6d 65 29 29 20 3b 3b 20 28 63 61 72 20 -name)) ;; (car
ff00: 75 73 65 72 69 6e 66 6f 29 29 29 0a 09 20 28 64 userinfo))).. (d
ff10: 62 20 20 20 20 20 20 28 6d 64 64 62 3a 6f 70 65 b (mddb:ope
ff20: 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 70 72 69 n-db))). (pri
ff30: 6e 74 20 22 52 65 67 69 73 74 65 72 20 6d 6f 6e nt "Register mon
ff40: 69 74 6f 72 2c 20 70 69 64 3a 20 22 20 70 69 64 itor, pid: " pid
ff50: 20 22 2c 20 68 6f 73 74 6e 61 6d 65 3a 20 22 20 ", hostname: "
ff60: 68 6f 73 74 6e 61 6d 65 20 22 2c 20 70 6f 72 74 hostname ", port
ff70: 3a 20 22 20 70 6f 72 74 20 22 2c 20 75 73 65 72 : " port ", user
ff80: 6e 61 6d 65 3a 20 22 20 75 73 65 72 6e 61 6d 65 name: " username
ff90: 29 0a 20 20 20 20 28 65 78 65 63 20 28 73 71 6c ). (exec (sql
ffa0: 20 64 62 20 22 49 4e 53 45 52 54 20 4f 52 20 52 db "INSERT OR R
ffb0: 45 50 4c 41 43 45 20 49 4e 54 4f 20 64 61 73 68 EPLACE INTO dash
ffc0: 62 6f 61 72 64 73 20 28 70 69 64 2c 75 73 65 72 boards (pid,user
ffd0: 6e 61 6d 65 2c 68 6f 73 74 6e 61 6d 65 2c 69 70 name,hostname,ip
ffe0: 61 64 64 72 2c 70 6f 72 74 6e 75 6d 29 20 56 41 addr,portnum) VA
fff0: 4c 55 45 53 20 28 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 LUES (?,?,?,?,?)
10000 3b 22 29 0a 09 20 20 20 70 69 64 20 75 73 65 72 ;").. pid user
10010 6e 61 6d 65 20 68 6f 73 74 6e 61 6d 65 20 69 70 name hostname ip
10020 61 64 64 72 20 70 6f 72 74 29 0a 20 20 20 20 28 addr port). (
10030 63 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 20 64 close-database d
10040 62 29 29 29 0a 0a 3b 3b 20 75 6e 72 65 67 69 73 b)))..;; unregis
10050 74 65 72 20 61 20 6d 6f 6e 69 74 6f 72 0a 3b 3b ter a monitor.;;
10060 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 75 .(define (mddb:u
10070 6e 72 65 67 69 73 74 65 72 2d 64 61 73 68 62 6f nregister-dashbo
10080 61 72 64 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 ard host port).
10090 20 28 6c 65 74 2a 20 28 28 64 62 20 20 20 20 20 (let* ((db
100a0 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 (mddb:open-db))
100b0 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 ). (print "Re
100c0 67 69 73 74 65 72 20 75 6e 72 65 67 69 73 74 65 gister unregiste
100d0 72 20 6d 6f 6e 69 74 6f 72 2c 20 68 6f 73 74 3a r monitor, host:
100e0 70 6f 72 74 3d 22 20 68 6f 73 74 20 22 3a 22 20 port=" host ":"
100f0 70 6f 72 74 29 0a 20 20 20 20 28 65 78 65 63 20 port). (exec
10100 28 73 71 6c 20 64 62 20 22 44 45 4c 45 54 45 20 (sql db "DELETE
10110 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 73 20 FROM dashboards
10120 57 48 45 52 45 20 68 6f 73 74 6e 61 6d 65 3d 3f WHERE hostname=?
10130 20 41 4e 44 20 70 6f 72 74 6e 75 6d 3d 3f 3b 22 AND portnum=?;"
10140 29 20 68 6f 73 74 20 70 6f 72 74 29 0a 20 20 20 ) host port).
10150 20 28 63 6c 6f 73 65 2d 64 61 74 61 62 61 73 65 (close-database
10160 20 64 62 29 29 29 0a 0a 3b 3b 20 67 65 74 20 72 db)))..;; get r
10170 65 67 69 73 74 65 72 65 64 20 64 61 73 68 62 6f egistered dashbo
10180 61 72 64 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ards.;;.(define
10190 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 62 6f (mddb:get-dashbo
101a0 61 72 64 73 29 0a 20 20 28 6c 65 74 20 28 28 64 ards). (let ((d
101b0 62 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 b (mddb:open-db)
101c0 29 29 0a 20 20 20 20 28 71 75 65 72 79 20 66 65 )). (query fe
101d0 74 63 68 2d 63 6f 6c 75 6d 6e 0a 09 20 20 20 28 tch-column.. (
101e0 73 71 6c 20 64 62 20 22 53 45 4c 45 43 54 20 69 sql db "SELECT i
101f0 70 61 64 64 72 20 7c 7c 20 27 3a 27 20 7c 7c 20 paddr || ':' ||
10200 70 6f 72 74 6e 75 6d 20 46 52 4f 4d 20 64 61 73 portnum FROM das
10210 68 62 6f 61 72 64 73 3b 22 29 29 29 29 0a 20 20 hboards;")))).
10220 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;===========
10230 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10240 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10250 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10260 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 20 ===========.;;
10270 54 20 45 20 53 20 54 20 20 20 4c 20 41 20 55 20 T E S T L A U
10280 4e 20 43 20 48 20 49 20 4e 20 47 20 20 20 50 20 N C H I N G P
10290 45 20 52 20 20 20 49 20 54 20 45 20 4d 20 20 20 E R I T E M
102a0 57 20 49 20 54 20 48 20 20 20 48 20 4f 20 53 20 W I T H H O S
102b0 54 20 20 20 54 20 59 20 50 20 45 20 53 0a 3b 3b T T Y P E S.;;
102c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10300 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 0a 3b 3b 20 5b 68 ======.;; .;; [h
10310 6f 73 74 73 5d 0a 3b 3b 20 61 72 6d 20 63 75 62 osts].;; arm cub
10320 69 65 30 31 20 63 75 62 69 65 30 32 0a 3b 3b 20 ie01 cubie02.;;
10330 78 38 36 5f 36 34 20 7a 65 75 73 20 78 65 6e 61 x86_64 zeus xena
10340 20 6d 79 74 68 30 31 0a 3b 3b 20 61 6c 6c 68 6f myth01.;; allho
10350 73 74 73 20 23 7b 67 20 68 6f 73 74 73 20 61 72 sts #{g hosts ar
10360 6d 7d 20 23 7b 67 20 68 6f 73 74 73 20 78 38 36 m} #{g hosts x86
10370 5f 36 34 7d 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 _64}.;; .;; [hos
10380 74 2d 74 79 70 65 73 5d 0a 3b 3b 20 67 65 6e 65 t-types].;; gene
10390 72 61 6c 20 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 ral #MTLOWESTLOA
103a0 44 20 23 7b 67 20 68 6f 73 74 73 20 61 6c 6c 68 D #{g hosts allh
103b0 6f 73 74 73 7d 0a 3b 3b 20 61 72 6d 20 20 20 20 osts}.;; arm
103c0 20 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 20 23 #MTLOWESTLOAD #
103d0 7b 67 20 68 6f 73 74 73 20 61 72 6d 7d 0a 3b 3b {g hosts arm}.;;
103e0 20 6e 62 67 65 6e 65 72 61 6c 20 6e 62 6a 6f 62 nbgeneral nbjob
103f0 20 72 75 6e 20 4a 4f 42 43 4f 4d 4d 41 4e 44 20 run JOBCOMMAND
10400 2d 6c 6f 67 20 24 4d 54 5f 4c 49 4e 4b 54 52 45 -log $MT_LINKTRE
10410 45 2f 24 4d 54 5f 54 41 52 47 45 54 2f 24 4d 54 E/$MT_TARGET/$MT
10420 5f 52 55 4e 4e 41 4d 45 2e 24 4d 54 5f 54 45 53 _RUNNAME.$MT_TES
10430 54 4e 41 4d 45 2d 24 4d 54 5f 49 54 45 4d 5f 50 TNAME-$MT_ITEM_P
10440 41 54 48 2e 6c 67 6f 0a 3b 3b 20 0a 3b 3b 20 5b ATH.lgo.;; .;; [
10450 6c 61 75 6e 63 68 65 72 73 5d 0a 3b 3b 20 65 6e launchers].;; en
10460 76 73 65 74 75 70 20 67 65 6e 65 72 61 6c 0a 3b vsetup general.;
10470 3b 20 78 6f 72 2f 25 2f 6e 20 34 43 31 36 47 0a ; xor/%/n 4C16G.
10480 3b 3b 20 25 20 6e 62 67 65 6e 65 72 61 6c 0a 3b ;; % nbgeneral.;
10490 3b 20 0a 3b 3b 20 5b 6a 6f 62 74 6f 6f 6c 73 5d ; .;; [jobtools]
104a0 0a 3b 3b 20 23 20 69 66 20 64 65 66 69 6e 65 64 .;; # if defined
104b0 20 61 6e 64 20 6e 6f 74 20 22 6e 6f 22 20 66 6c and not "no" fl
104c0 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 77 69 6c exi-launcher wil
104d0 6c 20 62 79 70 61 73 73 20 22 6c 61 75 6e 63 68 l bypass "launch
104e0 65 72 22 20 75 6e 6c 65 73 73 20 6e 6f 20 6d 61 er" unless no ma
104f0 74 63 68 2e 0a 3b 3b 20 66 6c 65 78 69 2d 6c 61 tch..;; flexi-la
10500 75 6e 63 68 65 72 20 79 65 73 20 20 0a 3b 3b 20 uncher yes .;;
10510 6c 61 75 6e 63 68 65 72 20 6e 62 66 61 6b 65 0a launcher nbfake.
10520 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
10530 6f 6e 3a 67 65 74 2d 6c 61 75 6e 63 68 65 72 20 on:get-launcher
10540 63 6f 6e 66 69 67 64 61 74 20 74 65 73 74 6e 61 configdat testna
10550 6d 65 20 69 74 65 6d 70 61 74 68 29 0a 20 20 28 me itempath). (
10560 6c 65 74 20 28 28 66 61 6c 6c 62 61 63 6b 2d 6c let ((fallback-l
10570 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 69 67 66 auncher (configf
10580 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
10590 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 6c 61 t "jobtools" "la
105a0 75 6e 63 68 65 72 22 29 29 29 0a 20 20 20 20 28 uncher"))). (
105b0 69 66 20 28 61 6e 64 20 28 63 6f 6e 66 69 67 66 if (and (configf
105c0 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
105d0 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 6c t "jobtools" "fl
105e0 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 20 3b exi-launcher") ;
105f0 3b 20 6f 76 65 72 72 69 64 65 73 20 6c 61 75 6e ; overrides laun
10600 63 68 65 72 0a 09 20 20 20 20 20 28 6e 6f 74 20 cher.. (not
10610 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 (equal? (configf
10620 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 :lookup configda
10630 74 20 22 6a 6f 62 74 6f 6f 6c 73 22 20 22 66 6c t "jobtools" "fl
10640 65 78 69 2d 6c 61 75 6e 63 68 65 72 22 29 20 22 exi-launcher") "
10650 6e 6f 22 29 29 29 0a 09 28 6c 65 74 2a 20 28 28 no")))..(let* ((
10660 6c 61 75 6e 63 68 65 72 73 20 20 20 20 20 20 20 launchers
10670 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 (hash-table-re
10680 66 2f 64 65 66 61 75 6c 74 20 63 6f 6e 66 69 67 f/default config
10690 64 61 74 20 22 6c 61 75 6e 63 68 65 72 73 22 20 dat "launchers"
106a0 27 28 29 29 29 29 0a 09 20 20 28 69 66 20 28 6e '()))).. (if (n
106b0 75 6c 6c 3f 20 6c 61 75 6e 63 68 65 72 73 29 0a ull? launchers).
106c0 09 20 20 20 20 20 20 66 61 6c 6c 62 61 63 6b 2d . fallback-
106d0 6c 61 75 6e 63 68 65 72 0a 09 20 20 20 20 20 20 launcher..
106e0 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
106f0 28 63 61 72 20 6c 61 75 6e 63 68 65 72 73 29 29 (car launchers))
10700 0a 09 09 09 20 28 74 61 6c 20 28 63 64 72 20 6c .... (tal (cdr l
10710 61 75 6e 63 68 65 72 73 29 29 29 0a 09 09 28 6c aunchers)))...(l
10720 65 74 20 28 28 70 61 74 74 20 20 20 20 20 20 28 et ((patt (
10730 63 61 72 20 68 65 64 29 29 0a 09 09 20 20 20 20 car hed))...
10740 20 20 28 68 6f 73 74 2d 74 79 70 65 20 28 63 61 (host-type (ca
10750 64 72 20 68 65 64 29 29 29 0a 09 09 20 20 28 69 dr hed)))... (i
10760 66 20 28 74 65 73 74 73 3a 6d 61 74 63 68 20 70 f (tests:match p
10770 61 74 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 att testname ite
10780 6d 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 28 mpath)... (
10790 62 65 67 69 6e 0a 09 09 09 28 64 65 62 75 67 3a begin....(debug:
107a0 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 print-info 2 *de
107b0 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
107c0 22 48 61 76 65 20 66 6c 65 78 69 2d 6c 61 75 6e "Have flexi-laun
107d0 63 68 65 72 20 6d 61 74 63 68 20 66 6f 72 20 22 cher match for "
107e0 20 74 65 73 74 6e 61 6d 65 20 22 2f 22 20 69 74 testname "/" it
107f0 65 6d 70 61 74 68 20 22 20 3d 20 22 20 68 6f 73 empath " = " hos
10800 74 2d 74 79 70 65 29 0a 09 09 09 28 6c 65 74 20 t-type)....(let
10810 28 28 6c 61 75 6e 63 68 65 72 20 28 63 6f 6e 66 ((launcher (conf
10820 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
10830 67 64 61 74 20 22 68 6f 73 74 2d 74 79 70 65 73 gdat "host-types
10840 22 20 68 6f 73 74 2d 74 79 70 65 29 29 29 0a 09 " host-type)))..
10850 09 09 20 20 28 69 66 20 6c 61 75 6e 63 68 65 72 .. (if launcher
10860 0a 09 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 .... (let*
10870 28 28 6c 61 75 6e 63 68 65 72 2d 70 61 72 74 73 ((launcher-parts
10880 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 6c (string-split l
10890 61 75 6e 63 68 65 72 29 29 0a 09 09 09 09 20 20 auncher)).....
108a0 20 20 20 28 6c 61 75 6e 63 68 65 72 2d 65 78 65 (launcher-exe
108b0 20 20 20 28 63 61 72 20 6c 61 75 6e 63 68 65 72 (car launcher
108c0 2d 70 61 72 74 73 29 29 29 0a 09 09 09 09 28 69 -parts))).....(i
108d0 66 20 28 65 71 75 61 6c 3f 20 6c 61 75 6e 63 68 f (equal? launch
108e0 65 72 2d 65 78 65 20 22 23 4d 54 4c 4f 57 45 53 er-exe "#MTLOWES
108f0 54 4c 4f 41 44 22 29 20 3b 3b 20 74 68 69 73 20 TLOAD") ;; this
10900 69 73 20 6f 75 72 20 73 70 65 63 69 61 6c 20 63 is our special c
10910 61 73 65 2c 20 77 65 20 77 69 6c 6c 20 66 69 6e ase, we will fin
10920 64 20 74 68 65 20 6c 6f 77 65 73 74 20 6c 6f 61 d the lowest loa
10930 64 20 61 6e 64 20 63 72 61 66 74 20 61 20 6e 62 d and craft a nb
10940 66 61 6b 65 20 63 6f 6d 6d 61 6e 64 6c 69 6e 65 fake commandline
10950 0a 09 09 09 09 20 20 20 20 28 6c 65 74 20 28 28 ..... (let ((
10960 74 61 72 67 2d 68 6f 73 74 20 28 63 6f 6d 6d 6f targ-host (commo
10970 6e 3a 67 65 74 2d 6c 65 61 73 74 2d 6c 6f 61 64 n:get-least-load
10980 65 64 2d 68 6f 73 74 20 28 63 64 72 20 6c 61 75 ed-host (cdr lau
10990 6e 63 68 65 72 2d 70 61 72 74 73 29 29 29 29 0a ncher-parts)))).
109a0 09 09 09 09 20 20 20 20 20 20 28 63 6f 6e 63 20 .... (conc
109b0 22 72 65 6d 72 75 6e 20 22 20 74 61 72 67 2d 68 "remrun " targ-h
109c0 6f 73 74 29 29 0a 09 09 09 09 20 20 20 20 6c 61 ost))..... la
109d0 75 6e 63 68 65 72 29 29 0a 09 09 09 20 20 20 20 uncher))....
109e0 20 20 28 62 65 67 69 6e 0a 09 09 09 09 28 64 65 (begin.....(de
109f0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
10a00 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
10a10 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 6e 6f rt* "WARNING: no
10a20 20 6c 61 75 6e 63 68 65 72 20 66 6f 75 6e 64 20 launcher found
10a30 66 6f 72 20 68 6f 73 74 2d 74 79 70 65 20 22 20 for host-type "
10a40 68 6f 73 74 2d 74 79 70 65 29 0a 09 09 09 09 28 host-type).....(
10a50 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 if (null? tal)..
10a60 09 09 09 20 20 20 20 66 61 6c 6c 62 61 63 6b 2d ... fallback-
10a70 6c 61 75 6e 63 68 65 72 0a 09 09 09 09 20 20 20 launcher.....
10a80 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
10a90 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 0a (cdr tal))))))).
10aa0 09 09 20 20 20 20 20 20 3b 3b 20 6e 6f 20 6d 61 .. ;; no ma
10ab0 74 63 68 2c 20 74 72 79 20 61 67 61 69 6e 0a 09 tch, try again..
10ac0 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
10ad0 3f 20 74 61 6c 29 0a 09 09 09 20 20 66 61 6c 6c ? tal).... fall
10ae0 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 0a 09 09 back-launcher...
10af0 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
10b00 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 l)(cdr tal))))))
10b10 29 29 0a 09 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 ))..fallback-lau
10b20 6e 63 68 65 72 29 29 29 0a 20 20 0a 3b 3b 3d 3d ncher))). .;;==
10b30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b70 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 48 20 ====.;; D A S H
10b80 42 20 4f 20 41 20 52 20 44 20 20 20 55 20 53 20 B O A R D U S
10b90 45 20 52 20 20 20 56 20 49 20 45 20 57 20 53 0a E R V I E W S.
10ba0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
10bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10bc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10bd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10be0 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 69 72 ========..;; fir
10bf0 73 74 20 72 65 61 64 20 7e 2f 76 69 65 77 73 2e st read ~/views.
10c00 63 6f 6e 66 69 67 20 69 66 20 69 74 20 65 78 69 config if it exi
10c10 73 74 73 2c 20 74 68 65 6e 20 72 65 61 64 20 24 sts, then read $
10c20 4d 54 52 41 48 2f 76 69 65 77 73 2e 63 6f 6e 66 MTRAH/views.conf
10c30 69 67 20 69 66 20 69 74 20 65 78 69 73 74 73 0a ig if it exists.
10c40 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
10c50 6f 6e 3a 6c 6f 61 64 2d 76 69 65 77 73 2d 63 6f on:load-views-co
10c60 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 28 28 nfig). (let* ((
10c70 76 69 65 77 2d 63 66 67 64 61 74 20 20 20 20 28 view-cfgdat (
10c80 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
10c90 29 0a 09 20 28 68 6f 6d 65 2d 63 66 67 66 69 6c ).. (home-cfgfil
10ca0 65 20 20 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 e (conc (get-e
10cb0 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
10cc0 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f 2e 6d ble "HOME") "/.m
10cd0 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 29 29 tviews.config"))
10ce0 0a 09 20 28 6d 74 68 6f 6d 65 2d 63 66 67 66 69 .. (mthome-cfgfi
10cf0 6c 65 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 le (conc *toppat
10d00 68 2a 20 22 2f 2e 6d 74 76 69 65 77 73 2e 63 6f h* "/.mtviews.co
10d10 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 69 66 nfig"))). (if
10d20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d (file-exists? m
10d30 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a 09 thome-cfgfile)..
10d40 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 6d 74 68 (read-config mth
10d50 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 65 77 ome-cfgfile view
10d60 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 20 20 -cfgdat #t)).
10d70 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 68 65 20 ;; we load the
10d80 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 20 41 46 home dir file AF
10d90 54 45 52 20 74 68 65 20 4d 54 52 41 48 20 66 69 TER the MTRAH fi
10da0 6c 65 20 73 6f 20 74 68 65 20 75 73 65 72 20 63 le so the user c
10db0 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 74 74 69 an clobber setti
10dc0 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 ngs when running
10dd0 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 20 69 the dashboard i
10de0 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 72 65 61 n read-only area
10df0 73 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d s. (if (file-
10e00 65 78 69 73 74 73 3f 20 68 6f 6d 65 2d 63 66 67 exists? home-cfg
10e10 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 6f 6e file)..(read-con
10e20 66 69 67 20 68 6f 6d 65 2d 63 66 67 66 69 6c 65 fig home-cfgfile
10e30 20 76 69 65 77 2d 63 66 67 64 61 74 20 23 74 29 view-cfgdat #t)
10e40 29 0a 20 20 20 20 76 69 65 77 2d 63 66 67 64 61 ). view-cfgda
10e50 74 29 29 0a 0a t))..