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 0a 20 20 20 20 20 6d ils stack. m
0270: 61 74 63 68 61 62 6c 65 29 0a 28 72 65 71 75 69 atchable).(requi
0280: 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 72 65 67 re-extension reg
0290: 65 78 20 70 6f 73 69 78 29 0a 0a 28 72 65 71 75 ex posix)..(requ
02a0: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
02b0: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
02c0: 63 70 20 72 70 63 29 0a 0a 28 69 6d 70 6f 72 74 cp rpc)..(import
02d0: 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 (prefix sqlite3
02e0: 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 69 6d 70 sqlite3:)).(imp
02f0: 6f 72 74 20 28 70 72 65 66 69 78 20 62 61 73 65 ort (prefix base
0300: 36 34 20 62 61 73 65 36 34 3a 29 29 0a 0a 28 64 64 base64:))..(d
0310: 65 63 6c 61 72 65 20 28 75 6e 69 74 20 63 6f 6d eclare (unit com
0320: 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 mon))..(include
0330: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
0340: 73 63 6d 22 29 0a 0a 3b 3b 20 28 72 65 71 75 69 scm")..;; (requi
0350: 72 65 2d 6c 69 62 72 61 72 79 20 6d 61 72 67 73 re-library margs
0360: 29 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 22 6d ).;; (include "m
0370: 61 72 67 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 28 args.scm")..;; (
0380: 64 65 66 69 6e 65 20 6f 6c 64 2d 65 78 69 74 20 define old-exit
0390: 65 78 69 74 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 exit).;; .;; (de
03a0: 66 69 6e 65 20 28 65 78 69 74 20 2e 20 63 6f 64 fine (exit . cod
03b0: 65 29 0a 3b 3b 20 20 20 28 69 66 20 28 6e 75 6c e).;; (if (nul
03c0: 6c 3f 20 63 6f 64 65 29 0a 3b 3b 20 20 20 20 20 l? code).;;
03d0: 20 20 28 6f 6c 64 2d 65 78 69 74 29 0a 3b 3b 20 (old-exit).;;
03e0: 20 20 20 20 20 20 28 6f 6c 64 2d 65 78 69 74 20 (old-exit
03f0: 63 6f 64 65 29 29 29 0a 0a 28 64 65 66 69 6e 65 code)))..(define
0400: 20 67 65 74 65 6e 76 20 67 65 74 2d 65 6e 76 69 getenv get-envi
0410: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
0420: 29 0a 28 64 65 66 69 6e 65 20 28 73 61 66 65 2d ).(define (safe-
0430: 73 65 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 0a setenv key val).
0440: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
0450: 6e 67 3f 20 76 61 6c 29 28 73 74 72 69 6e 67 3f ng? val)(string?
0460: 20 6b 65 79 29 29 0a 20 20 20 20 20 20 28 68 61 key)). (ha
0470: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
0480: 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 exn.
0490: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
04a0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
04b0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 76 log-port* "bad v
04c0: 61 6c 75 65 20 66 6f 72 20 73 65 74 65 6e 76 2c alue for setenv,
04d0: 20 6b 65 79 3d 22 20 6b 65 79 20 22 2c 20 76 61 key=" key ", va
04e0: 6c 75 65 3d 22 20 76 61 6c 29 0a 20 20 20 20 20 lue=" val).
04f0: 20 20 28 73 65 74 65 6e 76 20 6b 65 79 20 76 61 (setenv key va
0500: 6c 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 l)). (debug
0510: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
0520: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0530: 2a 20 22 62 61 64 20 76 61 6c 75 65 20 66 6f 72 * "bad value for
0540: 20 73 65 74 65 6e 76 2c 20 6b 65 79 3d 22 20 6b setenv, key=" k
0550: 65 79 20 22 2c 20 76 61 6c 75 65 3d 22 20 76 61 ey ", value=" va
0560: 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 6f l)))..(define ho
0570: 6d 65 20 28 67 65 74 65 6e 76 20 22 48 4f 4d 45 me (getenv "HOME
0580: 22 29 29 0a 28 64 65 66 69 6e 65 20 75 73 65 72 ")).(define user
0590: 20 28 67 65 74 65 6e 76 20 22 55 53 45 52 22 29 (getenv "USER")
05a0: 29 0a 0a 3b 3b 20 47 4c 4f 42 41 4c 20 47 4c 45 )..;; GLOBAL GLE
05b0: 54 43 48 45 53 0a 0a 3b 3b 20 43 4f 4e 54 45 58 TCHES..;; CONTEX
05c0: 54 53 0a 28 64 65 66 73 74 72 75 63 74 20 63 78 TS.(defstruct cx
05d0: 74 0a 20 20 28 74 61 73 6b 64 62 20 23 66 29 0a t. (taskdb #f).
05e0: 20 20 28 63 6d 75 74 65 78 20 28 6d 61 6b 65 2d (cmutex (make-
05f0: 6d 75 74 65 78 29 29 29 0a 28 64 65 66 69 6e 65 mutex))).(define
0600: 20 2a 63 6f 6e 74 65 78 74 73 2a 20 28 6d 61 6b *contexts* (mak
0610: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 e-hash-table)).(
0620: 64 65 66 69 6e 65 20 2a 63 6f 6e 74 65 78 74 2d define *context-
0630: 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 mutex* (make-mut
0640: 65 78 29 29 0a 0a 3b 3b 20 73 61 66 65 20 6d 65 ex))..;; safe me
0650: 74 68 6f 64 20 66 6f 72 20 61 63 63 65 73 73 69 thod for accessi
0660: 6e 67 20 61 20 63 6f 6e 74 65 78 74 20 67 69 76 ng a context giv
0670: 65 6e 20 61 20 74 6f 70 70 61 74 68 0a 3b 3b 0a en a toppath.;;.
0680: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
0690: 77 69 74 68 2d 63 78 74 20 74 6f 70 70 61 74 68 with-cxt toppath
06a0: 20 70 72 6f 63 29 0a 20 20 28 6d 75 74 65 78 2d proc). (mutex-
06b0: 6c 6f 63 6b 21 20 2a 63 6f 6e 74 65 78 74 2d 6d lock! *context-m
06c0: 75 74 65 78 2a 29 0a 20 20 28 6c 65 74 20 28 28 utex*). (let ((
06d0: 63 78 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d cxt (hash-table-
06e0: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e ref/default *con
06f0: 74 65 78 74 73 2a 20 74 6f 70 70 61 74 68 20 23 texts* toppath #
0700: 66 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f f))). (if (no
0710: 74 20 63 78 74 29 0a 20 20 20 20 20 20 20 20 28 t cxt). (
0720: 73 65 74 21 20 63 78 74 20 28 6c 65 74 20 28 28 set! cxt (let ((
0730: 78 20 28 6d 61 6b 65 2d 63 78 74 29 29 29 28 68 x (make-cxt)))(h
0740: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
0750: 63 6f 6e 74 65 78 74 73 2a 20 74 6f 70 70 61 74 contexts* toppat
0760: 68 20 78 29 20 78 29 29 29 0a 20 20 20 20 28 6c h x) x))). (l
0770: 65 74 20 28 28 63 78 74 2d 6d 75 74 65 78 20 28 et ((cxt-mutex (
0780: 63 78 74 2d 6d 75 74 65 78 20 63 78 74 29 29 29 cxt-mutex cxt)))
0790: 0a 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e . (mutex-un
07a0: 6c 6f 63 6b 21 20 2a 63 6f 6e 74 65 78 74 2d 6d lock! *context-m
07b0: 75 74 65 78 2a 29 0a 20 20 20 20 20 20 28 6d 75 utex*). (mu
07c0: 74 65 78 2d 6c 6f 63 6b 21 20 63 78 74 2d 6d 75 tex-lock! cxt-mu
07d0: 74 65 78 29 0a 20 20 20 20 20 20 28 6c 65 74 20 tex). (let
07e0: 28 28 72 65 73 20 28 70 72 6f 63 20 63 78 74 29 ((res (proc cxt)
07f0: 29 29 0a 20 20 20 20 20 20 20 20 28 6d 75 74 65 )). (mute
0800: 78 2d 75 6e 6c 6f 63 6b 21 20 63 78 74 2d 6d 75 x-unlock! cxt-mu
0810: 74 65 78 29 0a 20 20 20 20 20 20 20 20 72 65 73 tex). res
0820: 29 29 29 29 0a 20 20 20 20 20 20 20 20 0a 3b 3b )))). .;;
0830: 20 41 20 68 61 73 68 20 74 61 62 6c 65 20 74 68 A hash table th
0840: 61 74 20 63 61 6e 20 62 65 20 61 63 63 65 73 73 at can be access
0850: 65 64 20 62 79 20 23 7b 73 63 68 65 6d 65 20 2e ed by #{scheme .
0860: 2e 2e 7d 20 63 61 6c 6c 73 20 69 6e 0a 3b 3b 20 ..} calls in.;;
0870: 63 6f 6e 66 69 67 20 66 69 6c 65 73 2e 20 41 6c config files. Al
0880: 6c 6f 77 73 20 63 6f 6d 6d 75 6e 69 63 61 74 69 lows communicati
0890: 6e 67 20 62 65 74 77 65 65 6e 20 63 6f 6e 66 67 ng between confg
08a0: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 75 73 s.;;.(define *us
08b0: 65 72 2d 68 61 73 68 2d 64 61 74 61 2a 20 28 6d er-hash-data* (m
08c0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
08d0: 0a 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6b 65 ..(define *db-ke
08e0: 79 73 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 ys* #f)..(define
08f0: 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 20 20 20 *configinfo*
0900: 23 66 29 20 20 20 3b 3b 20 72 61 77 20 72 65 73 #f) ;; raw res
0910: 75 6c 74 73 20 66 72 6f 6d 20 73 65 74 75 70 2c ults from setup,
0920: 20 69 6e 63 6c 75 64 65 73 20 74 6f 70 70 61 74 includes toppat
0930: 68 20 61 6e 64 20 74 61 62 6c 65 20 66 72 6f 6d h and table from
0940: 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 megatest.config
0950: 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 63 6f 6e .(define *runcon
0960: 66 69 67 64 61 74 2a 20 23 66 29 20 20 20 3b 3b figdat* #f) ;;
0970: 20 72 75 6e 20 63 6f 6e 66 69 67 73 20 64 61 74 run configs dat
0980: 61 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 69 a.(define *confi
0990: 67 64 61 74 2a 20 20 20 20 23 66 29 20 20 20 3b gdat* #f) ;
09a0: 3b 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 ; megatest.confi
09b0: 67 20 64 61 74 61 0a 28 64 65 66 69 6e 65 20 2a g data.(define *
09c0: 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 23 66 configstatus* #f
09d0: 29 20 20 20 3b 3b 20 73 74 61 74 75 73 20 6f 66 ) ;; status of
09e0: 20 64 61 74 61 3b 20 27 66 75 6c 6c 64 61 74 61 data; 'fulldata
09f0: 20 3a 20 61 6c 6c 20 70 72 6f 63 65 73 73 69 6e : all processin
0a00: 67 20 64 6f 6e 65 2c 20 23 66 20 3a 20 6e 6f 20 g done, #f : no
0a10: 64 61 74 61 20 79 65 74 2c 20 27 70 61 72 74 69 data yet, 'parti
0a20: 61 6c 64 61 74 61 20 3a 20 70 61 72 74 69 61 6c aldata : partial
0a30: 20 72 65 61 64 20 64 6f 6e 65 0a 28 64 65 66 69 read done.(defi
0a40: 6e 65 20 2a 74 6f 70 70 61 74 68 2a 20 20 20 20 ne *toppath*
0a50: 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a 61 #f).(define *a
0a60: 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 lready-seen-runc
0a70: 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 23 66 29 0a onfig-info* #f).
0a80: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 6d .(define *test-m
0a90: 65 74 61 2d 75 70 64 61 74 65 64 2a 20 28 6d 61 eta-updated* (ma
0aa0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
0ab0: 28 64 65 66 69 6e 65 20 2a 67 6c 6f 62 61 6c 65 (define *globale
0ac0: 78 69 74 73 74 61 74 75 73 2a 20 20 30 29 20 3b xitstatus* 0) ;
0ad0: 3b 20 61 74 74 65 6d 70 74 20 74 6f 20 77 6f 72 ; attempt to wor
0ae0: 6b 20 61 72 6f 75 6e 64 20 70 6f 73 73 69 62 6c k around possibl
0af0: 65 20 74 68 72 65 61 64 20 69 73 73 75 65 73 0a e thread issues.
0b00: 28 64 65 66 69 6e 65 20 2a 70 61 73 73 6e 75 6d (define *passnum
0b10: 2a 20 20 20 20 20 20 20 20 20 20 20 30 29 20 3b * 0) ;
0b20: 3b 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 74 ; when running t
0b30: 72 61 63 6b 20 63 61 6c 6c 73 20 74 6f 20 72 75 rack calls to ru
0b40: 6e 2d 74 65 73 74 73 20 6f 72 20 73 69 6d 69 6c n-tests or simil
0b50: 61 72 0a 28 64 65 66 69 6e 65 20 2a 61 6c 74 2d ar.(define *alt-
0b60: 6c 6f 67 2d 66 69 6c 65 2a 20 23 66 29 20 20 3b log-file* #f) ;
0b70: 3b 20 75 73 65 64 20 62 79 20 2d 6c 6f 67 0a 28 ; used by -log.(
0b80: 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 64 define *common:d
0b90: 65 6e 6f 69 73 65 2a 20 20 20 20 28 6d 61 6b 65 enoise* (make
0ba0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
0bb0: 20 66 6f 72 20 6c 6f 77 20 6e 6f 69 73 65 20 70 for low noise p
0bc0: 72 69 6e 74 69 6e 67 0a 28 64 65 66 69 6e 65 20 rinting.(define
0bd0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0be0: 74 2a 20 20 28 63 75 72 72 65 6e 74 2d 65 72 72 t* (current-err
0bf0: 6f 72 2d 70 6f 72 74 29 29 0a 28 64 65 66 69 6e or-port)).(defin
0c00: 65 20 2a 74 69 6d 65 2d 7a 65 72 6f 2a 20 28 63 e *time-zero* (c
0c10: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
0c20: 20 3b 3b 20 66 6f 72 20 74 68 65 20 77 61 74 63 ;; for the watc
0c30: 68 64 6f 67 0a 0a 3b 3b 20 44 41 54 41 42 41 53 hdog..;; DATABAS
0c40: 45 0a 28 64 65 66 69 6e 65 20 2a 64 62 73 74 72 E.(define *dbstr
0c50: 75 63 74 2d 64 62 2a 20 20 20 20 20 20 20 20 20 uct-db*
0c60: 23 66 29 20 3b 3b 20 75 73 65 64 20 74 6f 20 63 #f) ;; used to c
0c70: 61 63 68 65 20 74 68 65 20 64 62 73 74 72 75 63 ache the dbstruc
0c80: 74 20 69 6e 20 64 62 3a 73 65 74 75 70 2e 20 47 t in db:setup. G
0c90: 6f 61 6c 20 69 73 20 74 6f 20 72 65 6d 6f 76 65 oal is to remove
0ca0: 20 74 68 69 73 2e 0a 3b 3b 20 64 62 20 73 74 61 this..;; db sta
0cb0: 74 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 ts.(define *db-s
0cc0: 74 61 74 73 2a 20 20 20 20 20 20 20 20 20 20 20 tats*
0cd0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
0ce0: 65 29 29 20 3b 3b 20 68 61 73 68 20 6f 66 20 76 e)) ;; hash of v
0cf0: 65 63 74 6f 72 73 20 3c 20 63 6f 75 6e 74 20 64 ectors < count d
0d00: 75 72 61 74 69 6f 6e 2d 74 6f 74 61 6c 20 3e 0a uration-total >.
0d10: 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 74 61 74 (define *db-stat
0d20: 73 2d 6d 75 74 65 78 2a 20 20 20 20 20 20 28 6d s-mutex* (m
0d30: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 64 ake-mutex)).;; d
0d40: 62 20 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 b access.(define
0d50: 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 *db-last-access
0d60: 2a 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d * (current-
0d70: 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 6c 61 73 seconds)) ;; las
0d80: 74 20 64 62 20 61 63 63 65 73 73 2c 20 75 73 65 t db access, use
0d90: 64 20 69 6e 20 73 65 72 76 65 72 0a 28 64 65 66 d in server.(def
0da0: 69 6e 65 20 2a 64 62 2d 77 72 69 74 65 2d 61 63 ine *db-write-ac
0db0: 63 65 73 73 2a 20 20 20 20 20 23 74 29 0a 3b 3b cess* #t).;;
0dc0: 20 64 62 20 73 79 6e 63 0a 28 64 65 66 69 6e 65 db sync.(define
0dd0: 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 *db-last-sync*
0de0: 20 20 20 20 20 20 20 30 29 20 20 20 20 20 20 20 0)
0df0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 ;; las
0e00: 74 20 74 69 6d 65 20 74 68 65 20 73 79 6e 63 20 t time the sync
0e10: 74 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 68 to megatest.db h
0e20: 61 70 70 65 6e 65 64 0a 28 64 65 66 69 6e 65 20 appened.(define
0e30: 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 *db-sync-in-prog
0e40: 72 65 73 73 2a 20 23 66 29 20 20 20 20 20 20 20 ress* #f)
0e50: 20 20 20 20 20 20 20 20 20 3b 3b 20 69 66 20 74 ;; if t
0e60: 68 65 72 65 20 69 73 20 61 20 73 79 6e 63 20 69 here is a sync i
0e70: 6e 20 70 72 6f 67 72 65 73 73 20 64 6f 20 6e 6f n progress do no
0e80: 74 20 74 72 79 20 74 6f 20 73 74 61 72 74 20 61 t try to start a
0e90: 6e 6f 74 68 65 72 0a 28 64 65 66 69 6e 65 20 2a nother.(define *
0ea0: 64 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 db-multi-sync-mu
0eb0: 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 tex* (make-mutex
0ec0: 29 29 20 20 20 20 20 20 3b 3b 20 70 72 6f 74 65 )) ;; prote
0ed0: 63 74 20 61 63 63 65 73 73 20 74 6f 20 2a 64 62 ct access to *db
0ee0: 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 -sync-in-progres
0ef0: 73 2a 2c 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e s*, *db-last-syn
0f00: 63 2a 0a 3b 3b 20 74 61 73 6b 20 64 62 0a 28 64 c*.;; task db.(d
0f10: 65 66 69 6e 65 20 2a 74 61 73 6b 2d 64 62 2a 20 efine *task-db*
0f20: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 #f)
0f30: 3b 3b 20 28 76 65 63 74 6f 72 20 64 62 20 70 61 ;; (vector db pa
0f40: 74 68 2d 74 6f 2d 64 62 29 0a 28 64 65 66 69 6e th-to-db).(defin
0f50: 65 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c e *db-access-all
0f60: 6f 77 65 64 2a 20 20 20 23 74 29 20 3b 3b 20 66 owed* #t) ;; f
0f70: 6c 61 67 20 74 6f 20 61 6c 6c 6f 77 20 61 63 63 lag to allow acc
0f80: 65 73 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d ess.(define *db-
0f90: 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 20 20 20 access-mutex*
0fa0: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a (make-mutex)).
0fb0: 28 64 65 66 69 6e 65 20 2a 64 62 2d 74 72 61 6e (define *db-tran
0fc0: 73 61 63 74 69 6f 6e 2d 6d 75 74 65 78 2a 20 28 saction-mutex* (
0fd0: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 make-mutex)).(de
0fe0: 66 69 6e 65 20 2a 64 62 2d 63 61 63 68 65 2d 70 fine *db-cache-p
0ff0: 61 74 68 2a 20 20 20 20 20 20 20 23 66 29 0a 28 ath* #f).(
1000: 64 65 66 69 6e 65 20 2a 64 62 2d 77 69 74 68 2d define *db-with-
1010: 64 62 2d 6d 75 74 65 78 2a 20 20 20 20 28 6d 61 db-mutex* (ma
1020: 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 ke-mutex)).(defi
1030: 6e 65 20 2a 64 62 2d 61 70 69 2d 63 61 6c 6c 2d ne *db-api-call-
1040: 74 69 6d 65 2a 20 20 20 20 28 6d 61 6b 65 2d 68 time* (make-h
1050: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 68 ash-table)) ;; h
1060: 61 73 68 20 6f 66 20 63 6f 6d 6d 61 6e 64 20 3d ash of command =
1070: 3e 20 28 6c 69 73 74 20 6f 66 20 74 69 6d 65 73 > (list of times
1080: 29 0a 0a 3b 3b 20 53 45 52 56 45 52 0a 28 64 65 )..;; SERVER.(de
1090: 66 69 6e 65 20 2a 6d 79 2d 63 6c 69 65 6e 74 2d fine *my-client-
10a0: 73 69 67 6e 61 74 75 72 65 2a 20 23 66 29 0a 28 signature* #f).(
10b0: 64 65 66 69 6e 65 20 2a 74 72 61 6e 73 70 6f 72 define *transpor
10c0: 74 2d 74 79 70 65 2a 20 20 20 20 27 68 74 74 70 t-type* 'http
10d0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ) ;;
10e0: 20 6f 76 65 72 72 69 64 65 20 77 69 74 68 20 5b override with [
10f0: 73 65 72 76 65 72 5d 20 74 72 61 6e 73 70 6f 72 server] transpor
1100: 74 20 68 74 74 70 7c 72 70 63 7c 6e 6d 73 67 0a t http|rpc|nmsg.
1110: 28 64 65 66 69 6e 65 20 2a 72 75 6e 72 65 6d 6f (define *runremo
1120: 74 65 2a 20 20 20 20 20 20 20 20 20 23 66 29 20 te* #f)
1130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
1140: 3b 20 69 66 20 73 65 74 20 75 70 20 66 6f 72 20 ; if set up for
1150: 73 65 72 76 65 72 20 63 6f 6d 6d 75 6e 69 63 61 server communica
1160: 74 69 6f 6e 20 74 68 69 73 20 77 69 6c 6c 20 68 tion this will h
1170: 6f 6c 64 20 3c 68 6f 73 74 20 70 6f 72 74 3e 0a old <host port>.
1180: 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d 63 61 63 (define *max-cac
1190: 68 65 2d 73 69 7a 65 2a 20 20 20 20 30 29 0a 28 he-size* 0).(
11a0: 64 65 66 69 6e 65 20 2a 6c 6f 67 67 65 64 2d 69 define *logged-i
11b0: 6e 2d 63 6c 69 65 6e 74 73 2a 20 28 6d 61 6b 65 n-clients* (make
11c0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 -hash-table)).(d
11d0: 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 64 efine *server-id
11e0: 2a 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 * #f).(d
11f0: 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 6e efine *server-in
1200: 66 6f 2a 20 20 20 20 20 20 20 23 66 29 0a 28 64 fo* #f).(d
1210: 65 66 69 6e 65 20 2a 74 69 6d 65 2d 74 6f 2d 65 efine *time-to-e
1220: 78 69 74 2a 20 20 20 20 20 20 23 66 29 0a 28 64 xit* #f).(d
1230: 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 72 75 efine *server-ru
1240: 6e 2a 20 20 20 20 20 20 20 20 23 74 29 0a 28 64 n* #t).(d
1250: 65 66 69 6e 65 20 2a 72 75 6e 2d 69 64 2a 20 20 efine *run-id*
1260: 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 #f).(d
1270: 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d 6b 69 efine *server-ki
1280: 6e 64 2d 72 75 6e 2a 20 20 20 28 6d 61 6b 65 2d nd-run* (make-
1290: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 hash-table)).(de
12a0: 66 69 6e 65 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a fine *home-host*
12b0: 20 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 #f).(de
12c0: 66 69 6e 65 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d fine *total-non-
12d0: 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 30 29 0a write-delay* 0).
12e0: 28 64 65 66 69 6e 65 20 2a 68 65 61 72 74 62 65 (define *heartbe
12f0: 61 74 2d 6d 75 74 65 78 2a 20 20 20 28 6d 61 6b at-mutex* (mak
1300: 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 6e e-mutex)).(defin
1310: 65 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 e *api-process-r
1320: 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 30 29 equest-count* 0)
1330: 0a 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d 61 70 .(define *max-ap
1340: 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 73 i-process-reques
1350: 74 73 2a 20 30 29 0a 0a 3b 3b 20 63 6c 69 65 6e ts* 0)..;; clien
1360: 74 0a 28 64 65 66 69 6e 65 20 2a 72 6d 74 2d 6d t.(define *rmt-m
1370: 75 74 65 78 2a 20 20 20 20 20 20 20 20 20 28 6d utex* (m
1380: 61 6b 65 2d 6d 75 74 65 78 29 29 20 20 20 20 20 ake-mutex))
1390: 3b 3b 20 72 65 6d 6f 74 65 20 61 63 63 65 73 73 ;; remote access
13a0: 20 63 61 6c 6c 73 20 6d 75 74 65 78 20 0a 0a 3b calls mutex ..;
13b0: 3b 20 52 50 43 20 74 72 61 6e 73 70 6f 72 74 0a ; RPC transport.
13c0: 28 64 65 66 69 6e 65 20 2a 72 70 63 3a 6c 69 73 (define *rpc:lis
13d0: 74 65 6e 65 72 2a 20 20 20 20 20 20 23 66 29 0a tener* #f).
13e0: 0a 3b 3b 20 4b 45 59 20 69 6e 66 6f 0a 28 64 65 .;; KEY info.(de
13f0: 66 69 6e 65 20 2a 74 61 72 67 65 74 2a 20 20 20 fine *target*
1400: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1410: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 ash-table)) ;; c
1420: 61 63 68 65 20 74 68 65 20 74 61 72 67 65 74 20 ache the target
1430: 68 65 72 65 3b 20 74 61 72 67 65 74 20 69 73 20 here; target is
1440: 6b 65 79 76 61 6c 31 2f 6b 65 79 76 61 6c 32 2f keyval1/keyval2/
1450: 2e 2e 2e 2f 6b 65 79 76 61 6c 4e 0a 28 64 65 66 .../keyvalN.(def
1460: 69 6e 65 20 2a 6b 65 79 73 2a 20 20 20 20 20 20 ine *keys*
1470: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1480: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 sh-table)) ;; ca
1490: 63 68 65 20 74 68 65 20 6b 65 79 73 20 68 65 72 che the keys her
14a0: 65 0a 28 64 65 66 69 6e 65 20 2a 6b 65 79 76 61 e.(define *keyva
14b0: 6c 73 2a 20 20 20 20 20 20 20 20 20 20 20 28 6d ls* (m
14c0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
14d0: 0a 28 64 65 66 69 6e 65 20 2a 74 6f 70 74 65 73 .(define *toptes
14e0: 74 2d 70 61 74 68 73 2a 20 20 20 20 20 28 6d 61 t-paths* (ma
14f0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1500: 3b 3b 20 63 61 63 68 65 20 74 6f 70 74 65 73 74 ;; cache toptest
1510: 20 70 61 74 68 20 73 65 74 74 69 6e 67 73 20 68 path settings h
1520: 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 ere.(define *tes
1530: 74 2d 70 61 74 68 73 2a 20 20 20 20 20 20 20 20 t-paths*
1540: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1550: 29 29 20 3b 3b 20 63 61 63 68 65 20 74 65 73 74 )) ;; cache test
1560: 2d 69 64 20 74 6f 20 74 65 73 74 20 72 75 6e 20 -id to test run
1570: 70 61 74 68 73 20 68 65 72 65 0a 28 64 65 66 69 paths here.(defi
1580: 6e 65 20 2a 74 65 73 74 2d 69 64 73 2a 20 20 20 ne *test-ids*
1590: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
15a0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 h-table)) ;; cac
15b0: 68 65 20 72 75 6e 2d 69 64 2c 20 74 65 73 74 6e he run-id, testn
15c0: 61 6d 65 2c 20 61 6e 64 20 69 74 65 6d 2d 70 61 ame, and item-pa
15d0: 74 68 20 3d 3e 20 74 65 73 74 2d 69 64 0a 28 64 th => test-id.(d
15e0: 65 66 69 6e 65 20 2a 74 65 73 74 2d 69 6e 66 6f efine *test-info
15f0: 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d * (make-
1600: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1610: 63 61 63 68 65 20 74 68 65 20 74 65 73 74 20 69 cache the test i
1620: 6e 66 6f 20 72 65 63 6f 72 64 73 2c 20 75 70 64 nfo records, upd
1630: 61 74 65 20 74 68 65 20 73 74 61 74 65 2c 20 73 ate the state, s
1640: 74 61 74 75 73 2c 20 72 75 6e 5f 64 75 72 61 74 tatus, run_durat
1650: 69 6f 6e 20 65 74 63 2e 20 66 72 6f 6d 20 74 65 ion etc. from te
1660: 73 74 64 61 74 2e 64 62 0a 0a 28 64 65 66 69 6e stdat.db..(defin
1670: 65 20 2a 72 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 e *run-info-cach
1680: 65 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 e* (make-has
1690: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 72 75 6e h-table)) ;; run
16a0: 20 69 6e 66 6f 20 69 73 20 73 74 61 62 6c 65 2c info is stable,
16b0: 20 6e 6f 20 6e 65 65 64 20 74 6f 20 72 65 67 65 no need to rege
16c0: 74 0a 28 64 65 66 69 6e 65 20 2a 6c 61 75 6e 63 t.(define *launc
16d0: 68 2d 73 65 74 75 70 2d 6d 75 74 65 78 2a 20 28 h-setup-mutex* (
16e0: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 20 20 20 make-mutex))
16f0: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 62 65 20 61 ;; need to be a
1700: 62 6c 65 20 74 6f 20 63 61 6c 6c 20 6c 61 75 6e ble to call laun
1710: 63 68 3a 73 65 74 75 70 20 6f 66 74 65 6e 20 73 ch:setup often s
1720: 6f 20 6d 75 74 65 78 20 69 74 20 61 6e 64 20 72 o mutex it and r
1730: 65 2d 63 61 6c 6c 20 74 68 65 20 72 65 61 6c 20 e-call the real
1740: 64 65 61 6c 20 6f 6e 6c 79 20 69 66 20 2a 74 6f deal only if *to
1750: 70 70 61 74 68 2a 20 6e 6f 74 20 73 65 74 0a 28 ppath* not set.(
1760: 64 65 66 69 6e 65 20 2a 68 6f 6d 65 68 6f 73 74 define *homehost
1770: 2d 6d 75 74 65 78 2a 20 20 20 20 20 28 6d 61 6b -mutex* (mak
1780: 65 2d 6d 75 74 65 78 29 29 0a 0a 28 64 65 66 73 e-mutex))..(defs
1790: 74 72 75 63 74 20 72 65 6d 6f 74 65 0a 20 20 28 truct remote. (
17a0: 68 68 2d 64 61 74 20 20 20 20 20 20 20 20 20 20 hh-dat
17b0: 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f (common:get-ho
17c0: 6d 65 68 6f 73 74 29 29 20 3b 3b 20 68 6f 6d 65 mehost)) ;; home
17d0: 68 6f 73 74 20 72 65 63 6f 72 64 20 28 20 61 64 host record ( ad
17e0: 64 72 20 2e 20 68 68 66 6c 61 67 20 29 0a 20 20 dr . hhflag ).
17f0: 28 73 65 72 76 65 72 2d 75 72 6c 20 20 20 20 20 (server-url
1800: 20 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a (if *toppath*
1810: 20 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 (server:check-i
1820: 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 f-running *toppa
1830: 74 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 65 th*))) ;; (serve
1840: 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 r:check-if-runni
1850: 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 20 23 66 ng *toppath*) #f
1860: 29 29 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 65 )). (last-serve
1870: 72 2d 63 68 65 63 6b 20 30 29 20 20 3b 3b 20 6c r-check 0) ;; l
1880: 61 73 74 20 74 69 6d 65 20 77 65 20 63 68 65 63 ast time we chec
1890: 6b 65 64 20 74 6f 20 73 65 65 20 69 66 20 74 68 ked to see if th
18a0: 65 20 73 65 72 76 65 72 20 77 61 73 20 61 6c 69 e server was ali
18b0: 76 65 0a 20 20 28 63 6f 6e 6e 64 61 74 20 20 20 ve. (conndat
18c0: 20 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 74 #f). (t
18d0: 72 61 6e 73 70 6f 72 74 20 20 20 20 20 20 20 20 ransport
18e0: 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 *transport-type
18f0: 2a 29 0a 20 20 28 73 65 72 76 65 72 2d 74 69 6d *). (server-tim
1900: 65 6f 75 74 20 20 20 20 28 6f 72 20 28 73 65 72 eout (or (ser
1910: 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 29 ver:get-timeout)
1920: 20 31 30 30 29 29 29 20 3b 3b 20 64 65 66 61 75 100))) ;; defau
1930: 6c 74 20 74 6f 20 31 30 30 20 73 65 63 6f 6e 64 lt to 100 second
1940: 73 0a 0a 3b 3b 20 6c 61 75 6e 63 68 69 6e 67 20 s..;; launching
1950: 61 6e 64 20 68 6f 73 74 73 0a 28 64 65 66 73 74 and hosts.(defst
1960: 72 75 63 74 20 68 6f 73 74 0a 20 20 28 72 65 61 ruct host. (rea
1970: 63 68 61 62 6c 65 20 20 20 20 23 66 29 0a 20 20 chable #f).
1980: 28 6c 61 73 74 2d 75 70 64 61 74 65 20 20 30 29 (last-update 0)
1990: 0a 20 20 28 6c 61 73 74 2d 75 73 65 64 20 20 20 . (last-used
19a0: 20 30 29 0a 20 20 28 6c 61 73 74 2d 63 70 75 6c 0). (last-cpul
19b0: 6f 61 64 20 31 29 29 0a 0a 28 64 65 66 69 6e 65 oad 1))..(define
19c0: 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 20 20 *host-loads*
19d0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
19e0: 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 -table))..;; cac
19f0: 68 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 he environment v
1a00: 61 72 73 20 66 6f 72 20 65 61 63 68 20 72 75 6e ars for each run
1a10: 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 65 here.(define *e
1a20: 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 nv-vars-by-run-i
1a30: 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 d* (make-hash-ta
1a40: 62 6c 65 29 29 0a 0a 3b 3b 20 54 65 73 74 63 6f ble))..;; Testco
1a50: 6e 66 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e 66 nfig and runconf
1a60: 69 67 20 63 61 63 68 65 73 2e 20 0a 28 64 65 66 ig caches. .(def
1a70: 69 6e 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 ine *testconfigs
1a80: 2a 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 * (make-h
1a90: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 ash-table)) ;; t
1aa0: 65 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 est-name => test
1ab0: 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 2a config.(define *
1ac0: 72 75 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 runconfigs*
1ad0: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1ae0: 61 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 74 able)) ;; target
1af0: 20 20 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 => runconfig
1b00: 0a 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 63 ..;; This is a c
1b10: 61 63 68 65 20 6f 66 20 70 72 65 2d 72 65 71 73 ache of pre-reqs
1b20: 20 6d 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d 63 met, don't re-c
1b30: 61 6c 63 20 69 6e 20 63 61 73 65 73 20 77 68 65 alc in cases whe
1b40: 72 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 73 re called with s
1b50: 61 6d 65 20 70 61 72 61 6d 73 20 6c 65 73 73 20 ame params less
1b60: 74 68 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 63 than.;; five sec
1b70: 6f 6e 64 73 20 61 67 6f 0a 28 64 65 66 69 6e 65 onds ago.(define
1b80: 20 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 *pre-reqs-met-c
1b90: 61 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 ache* (make-hash
1ba0: 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 -table))..;; cac
1bb0: 68 65 20 6f 66 20 76 65 72 62 6f 73 69 74 79 20 he of verbosity
1bc0: 67 69 76 65 6e 20 73 74 72 69 6e 67 0a 3b 3b 0a given string.;;.
1bd0: 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 (define *verbosi
1be0: 74 79 2d 63 61 63 68 65 2a 20 20 20 20 28 6d 61 ty-cache* (ma
1bf0: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
1c00: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
1c10: 3a 63 6c 65 61 72 2d 63 61 63 68 65 73 29 0a 20 :clear-caches).
1c20: 20 28 73 65 74 21 20 2a 74 61 72 67 65 74 2a 20 (set! *target*
1c30: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1c40: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1c50: 20 28 73 65 74 21 20 2a 6b 65 79 73 2a 20 20 20 (set! *keys*
1c60: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1c70: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1c80: 20 28 73 65 74 21 20 2a 6b 65 79 76 61 6c 73 2a (set! *keyvals*
1c90: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1ca0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1cb0: 20 28 73 65 74 21 20 2a 74 6f 70 74 65 73 74 2d (set! *toptest-
1cc0: 70 61 74 68 73 2a 20 20 20 20 20 20 28 6d 61 6b paths* (mak
1cd0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1ce0: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 70 61 74 (set! *test-pat
1cf0: 68 73 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b hs* (mak
1d00: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1d10: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 73 (set! *test-ids
1d20: 2a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b * (mak
1d30: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1d40: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 6e 66 (set! *test-inf
1d50: 6f 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b o* (mak
1d60: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1d70: 20 28 73 65 74 21 20 2a 72 75 6e 2d 69 6e 66 6f (set! *run-info
1d80: 2d 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 6b -cache* (mak
1d90: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1da0: 20 28 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 (set! *env-vars
1db0: 2d 62 79 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 6b -by-run-id* (mak
1dc0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 e-hash-table)).
1dd0: 20 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 2d (set! *test-id-
1de0: 63 61 63 68 65 2a 20 20 20 20 20 20 28 6d 61 6b cache* (mak
1df0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
1e00: 0a 3b 3b 20 47 65 6e 65 72 69 63 20 73 74 72 69 .;; Generic stri
1e10: 6e 67 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 ng database.(def
1e20: 69 6e 65 20 73 64 62 3a 71 72 79 20 23 66 29 20 ine sdb:qry #f)
1e30: 3b 3b 20 28 6d 61 6b 65 2d 73 64 62 3a 71 72 79 ;; (make-sdb:qry
1e40: 29 29 20 3b 3b 20 20 27 69 6e 69 74 20 23 66 29 )) ;; 'init #f)
1e50: 0a 3b 3b 20 47 65 6e 65 72 69 63 20 70 61 74 68 .;; Generic path
1e60: 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e database.(defin
1e70: 65 20 2a 66 64 62 2a 20 23 66 29 0a 0a 28 64 65 e *fdb* #f)..(de
1e80: 66 69 6e 65 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 fine *last-launc
1e90: 68 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f h* (current-seco
1ea0: 6e 64 73 29 29 20 3b 3b 20 75 73 65 20 66 6f 72 nds)) ;; use for
1eb0: 20 74 68 72 6f 74 74 6c 69 6e 67 20 74 68 65 20 throttling the
1ec0: 6c 61 75 6e 63 68 20 72 61 74 65 2e 20 57 6f 75 launch rate. Wou
1ed0: 6c 64 20 62 65 20 62 65 74 74 65 72 20 74 6f 20 ld be better to
1ee0: 75 73 65 20 74 68 65 20 64 62 20 61 6e 64 20 6c use the db and l
1ef0: 61 73 74 20 74 69 6d 65 20 6f 66 20 61 20 74 65 ast time of a te
1f00: 73 74 20 69 6e 20 4c 41 55 4e 43 48 45 44 20 73 st in LAUNCHED s
1f10: 74 61 74 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d tate...;;=======
1f20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1f60: 3b 3b 20 56 20 45 20 52 20 53 20 49 20 4f 20 4e ;; V E R S I O N
1f70: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
1f80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1f90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
1fc0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 ne (common:get-f
1fd0: 75 6c 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 ull-version). (
1fe0: 63 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 conc megatest-ve
1ff0: 72 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 rsion "-" megate
2000: 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 st-fossil-hash))
2010: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
2020: 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 n:version-signat
2030: 75 72 65 29 0a 20 20 28 63 6f 6e 63 20 6d 65 67 ure). (conc meg
2040: 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d atest-version "-
2050: 22 20 28 73 75 62 73 74 72 69 6e 67 20 6d 65 67 " (substring meg
2060: 61 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 atest-fossil-has
2070: 68 20 30 20 34 29 29 29 0a 0a 3b 3b 20 66 72 6f h 0 4)))..;; fro
2080: 6d 20 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 70 m metadat lookup
2090: 20 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f MEGATEST_VERSIO
20a0: 4e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f N.;;.(define (co
20b0: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
20c0: 6e 2d 76 65 72 73 69 6f 6e 29 20 3b 3b 20 52 41 n-version) ;; RA
20d0: 44 54 20 3d 3e 20 48 6f 77 20 64 6f 65 73 20 74 DT => How does t
20e0: 68 69 73 20 77 6f 72 6b 20 69 6e 20 73 65 6e 64 his work in send
20f0: 2d 72 65 63 65 69 76 65 20 66 75 6e 63 74 69 6f -receive functio
2100: 6e 3f 3f 3b 20 61 73 73 75 6d 65 20 69 74 20 69 n??; assume it i
2110: 73 20 74 68 65 20 76 61 6c 75 65 20 73 61 76 65 s the value save
2120: 64 20 69 6e 20 73 6f 6d 65 20 44 42 0a 20 20 28 d in some DB. (
2130: 72 6d 74 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 rmt:get-var "MEG
2140: 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 29 29 ATEST_VERSION"))
2150: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
2160: 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:get-last-run-v
2170: 65 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 ersion-number).
2180: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
2190: 20 0a 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 . (substring
21a0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 (common:get-last
21b0: 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 30 20 -run-version) 0
21c0: 36 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6)))..(define (c
21d0: 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 ommon:set-last-r
21e0: 75 6e 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 72 un-version). (r
21f0: 6d 74 3a 73 65 74 2d 76 61 72 20 22 4d 45 47 41 mt:set-var "MEGA
2200: 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 20 28 63 TEST_VERSION" (c
2210: 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 ommon:version-si
2220: 67 6e 61 74 75 72 65 29 29 29 0a 0a 28 64 65 66 gnature)))..(def
2230: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 ine (common:vers
2240: 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 ion-changed?).
2250: 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 28 63 6f (not (equal? (co
2260: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
2270: 6e 2d 76 65 72 73 69 6f 6e 29 0a 09 20 20 20 20 n-version)..
2280: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 (common:versi
2290: 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 29 29 on-signature))))
22a0: 0a 0a 3b 3b 20 4d 6f 76 65 20 6d 65 20 65 6c 73 ..;; Move me els
22b0: 65 77 68 65 72 65 20 2e 2e 2e 0a 3b 3b 20 52 41 ewhere ....;; RA
22c0: 44 54 20 3d 3e 20 57 68 79 20 64 6f 20 77 65 20 DT => Why do we
22d0: 6d 65 65 64 20 74 68 65 20 76 65 72 73 69 6f 6e meed the version
22e0: 20 63 68 65 63 6b 20 68 65 72 65 2c 20 74 68 69 check here, thi
22f0: 73 20 69 73 20 63 61 6c 6c 65 64 20 6f 6e 6c 79 s is called only
2300: 20 69 66 20 76 65 72 73 69 6f 6e 20 6d 69 73 6d if version mism
2310: 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f a.;;.(define (co
2320: 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 70 2d 64 62 20 mmon:cleanup-db
2330: 64 62 73 74 72 75 63 74 29 0a 20 20 28 64 62 3a dbstruct). (db:
2340: 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 0a 20 multi-db-sync .
2350: 20 20 64 62 73 74 72 75 63 74 0a 20 20 20 3b 3b dbstruct. ;;
2360: 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 27 6b 69 'new2old. 'ki
2370: 6c 6c 73 65 72 76 65 72 73 0a 20 20 20 27 64 65 llservers. 'de
2380: 6a 75 6e 6b 0a 20 20 20 3b 3b 20 27 61 64 6a 2d junk. ;; 'adj-
2390: 74 65 73 74 69 64 73 0a 20 20 20 3b 3b 20 27 6f testids. ;; 'o
23a0: 6c 64 32 6e 65 77 0a 20 20 20 27 6e 65 77 32 6f ld2new. 'new2o
23b0: 6c 64 0a 20 20 20 27 73 63 68 65 6d 61 29 0a 20 ld. 'schema).
23c0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 (if (common:ver
23d0: 73 69 6f 6e 2d 63 68 61 6e 67 65 64 3f 29 0a 20 sion-changed?).
23e0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 (common:set
23f0: 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f -last-run-versio
2400: 6e 29 29 29 0a 0a 3b 3b 20 52 6f 74 61 74 65 20 n)))..;; Rotate
2410: 6c 6f 67 73 2c 20 6c 6f 67 69 63 3a 20 0a 3b 3b logs, logic: .;;
2420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2430: 20 69 66 20 3e 20 35 30 30 6b 20 61 6e 64 20 6f if > 500k and o
2440: 6c 64 65 72 20 74 68 61 6e 20 31 20 77 65 65 6b lder than 1 week
2450: 3a 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 :.;;
2460: 20 20 20 20 20 20 20 20 20 72 65 6d 6f 76 65 20 remove
2470: 70 72 65 76 69 6f 75 73 20 63 6f 6d 70 72 65 73 previous compres
2480: 73 65 64 20 6c 6f 67 20 61 6e 64 20 63 6f 6d 70 sed log and comp
2490: 72 65 73 73 20 74 68 69 73 20 6c 6f 67 0a 3b 3b ress this log.;;
24a0: 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 73 20 70 WARNING: This p
24b0: 72 6f 63 20 6f 70 65 72 61 74 65 73 20 61 73 73 roc operates ass
24c0: 75 6d 69 6e 67 20 74 68 61 74 20 69 74 20 69 73 uming that it is
24d0: 20 69 6e 20 74 68 65 20 64 69 72 65 63 74 6f 72 in the director
24e0: 79 20 61 62 6f 76 65 20 74 68 65 0a 3b 3b 20 20 y above the.;;
24f0: 20 20 20 20 20 20 20 20 6c 6f 67 73 20 64 69 72 logs dir
2500: 65 63 74 6f 72 79 20 79 6f 75 20 77 69 73 68 20 ectory you wish
2510: 74 6f 20 6c 6f 67 2d 72 6f 74 61 74 65 2e 0a 3b to log-rotate..;
2520: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2530: 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 29 0a 20 n:rotate-logs).
2540: 20 28 69 66 20 28 6e 6f 74 20 28 64 69 72 65 63 (if (not (direc
2550: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 22 6c 6f tory-exists? "lo
2560: 67 73 22 29 29 28 63 72 65 61 74 65 2d 64 69 72 gs"))(create-dir
2570: 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 29 29 0a ectory "logs")).
2580: 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c (directory-fol
2590: 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 66 d . (lambda (f
25a0: 69 6c 65 20 72 65 6d 29 0a 20 20 20 20 20 28 63 ile rem). (c
25b0: 6f 6d 6d 6f 6e 3a 64 65 62 75 67 2d 68 61 6e 64 ommon:debug-hand
25c0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 23 74 le-exceptions #t
25d0: 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 . exn.
25e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
25f0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
2600: 67 2d 70 6f 72 74 2a 20 22 66 61 69 6c 65 64 20 g-port* "failed
2610: 74 6f 20 72 6f 74 61 74 65 20 6c 6f 67 20 22 20 to rotate log "
2620: 66 69 6c 65 20 22 2c 20 70 72 6f 62 61 62 6c 79 file ", probably
2630: 20 68 61 6e 64 6c 65 64 20 62 79 20 61 6e 6f 74 handled by anot
2640: 68 65 72 20 70 72 6f 63 65 73 73 2e 22 29 0a 20 her process.").
2650: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 66 75 6c (let* ((ful
2660: 6c 6e 61 6d 65 20 28 63 6f 6e 63 20 22 6c 6f 67 lname (conc "log
2670: 73 2f 22 20 66 69 6c 65 29 29 0a 20 20 20 20 20 s/" file)).
2680: 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d 61 67 (file-ag
2690: 65 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 e (- (current-se
26a0: 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f 64 69 conds)(file-modi
26b0: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 75 fication-time fu
26c0: 6c 6c 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 20 llname)))).
26d0: 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 (if (or (and
26e0: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e (string-match "^
26f0: 2e 2a 2e 6c 6f 67 22 20 66 69 6c 65 29 0a 20 20 .*.log" file).
2700: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2710: 20 20 20 28 3e 20 28 66 69 6c 65 2d 73 69 7a 65 (> (file-size
2720: 20 66 75 6c 6c 6e 61 6d 65 29 20 32 30 30 30 30 fullname) 20000
2730: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
2740: 20 20 20 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (and (string
2750: 2d 6d 61 74 63 68 20 22 5e 73 65 72 76 65 72 2d -match "^server-
2760: 2e 2a 2e 6c 6f 67 22 20 66 69 6c 65 29 0a 20 20 .*.log" file).
2770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2780: 20 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e (> (- (curren
2790: 74 2d 73 65 63 6f 6e 64 73 29 20 28 66 69 6c 65 t-seconds) (file
27a0: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
27b0: 6d 65 20 66 75 6c 6c 6e 61 6d 65 29 29 0a 20 20 me fullname)).
27c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
27d0: 20 20 20 20 20 20 28 2a 20 38 20 36 30 20 36 30 (* 8 60 60
27e0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
27f0: 20 28 6c 65 74 20 28 28 67 7a 66 69 6c 65 20 28 (let ((gzfile (
2800: 63 6f 6e 63 20 66 75 6c 6c 6e 61 6d 65 20 22 2e conc fullname ".
2810: 67 7a 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 gz"))).
2820: 20 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d 65 (if (file-e
2830: 78 69 73 74 73 3f 20 67 7a 66 69 6c 65 29 0a 20 xists? gzfile).
2840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2850: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
2860: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
2870: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
2880: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
2890: 74 2a 20 22 72 65 6d 6f 76 69 6e 67 20 22 20 67 t* "removing " g
28a0: 7a 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 zfile).
28b0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 65 (dele
28c0: 74 65 2d 66 69 6c 65 20 67 7a 66 69 6c 65 29 29 te-file gzfile))
28d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
28e0: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
28f0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
2900: 2d 70 6f 72 74 2a 20 22 63 6f 6d 70 72 65 73 73 -port* "compress
2910: 69 6e 67 20 22 20 66 69 6c 65 29 0a 20 20 20 20 ing " file).
2920: 20 20 20 20 20 20 20 20 20 20 28 73 79 73 74 65 (syste
2930: 6d 20 28 63 6f 6e 63 20 22 67 7a 69 70 20 22 20 m (conc "gzip "
2940: 66 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 fullname))).
2950: 20 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 66 (if (> f
2960: 69 6c 65 2d 61 67 65 20 28 2a 20 28 73 74 72 69 ile-age (* (stri
2970: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 ng->number (or (
2980: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
2990: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
29a0: 70 22 20 22 6c 6f 67 2d 65 78 70 69 72 65 2d 64 p" "log-expire-d
29b0: 61 79 73 22 29 20 22 33 30 22 29 29 20 32 34 20 ays") "30")) 24
29c0: 33 36 30 30 29 29 0a 20 20 20 20 20 20 20 20 20 3600)).
29d0: 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 (handle-e
29e0: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 xceptions.
29f0: 20 20 20 20 20 20 20 20 20 20 20 65 78 6e 0a 20 exn.
2a00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2a10: 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 #f.
2a20: 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 (delete-file
2a30: 20 66 75 6c 6c 6e 61 6d 65 29 29 29 29 29 29 29 fullname)))))))
2a40: 0a 20 20 20 27 28 29 0a 20 20 20 22 6c 6f 67 73 . '(). "logs
2a50: 22 29 29 0a 0a 3b 3b 20 46 6f 72 63 65 20 61 20 "))..;; Force a
2a60: 6d 65 67 61 74 65 73 74 20 63 6c 65 61 6e 75 70 megatest cleanup
2a70: 2d 64 62 20 69 66 20 76 65 72 73 69 6f 6e 20 69 -db if version i
2a80: 73 20 63 68 61 6e 67 65 64 20 61 6e 64 20 73 6b s changed and sk
2a90: 69 70 2d 76 65 72 73 69 6f 6e 2d 63 68 65 63 6b ip-version-check
2aa0: 20 6e 6f 74 20 73 70 65 63 69 66 69 65 64 0a 3b not specified.;
2ab0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2ac0: 6e 3a 65 78 69 74 2d 6f 6e 2d 76 65 72 73 69 6f n:exit-on-versio
2ad0: 6e 2d 63 68 61 6e 67 65 64 29 0a 20 20 28 69 66 n-changed). (if
2ae0: 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e (common:version
2af0: 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 20 20 20 -changed?).
2b00: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d (if (common:on-
2b10: 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 20 28 6c homehost?).. (l
2b20: 65 74 2a 20 28 28 6d 74 63 6f 6e 66 20 28 63 6f et* ((mtconf (co
2b30: 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d nc (get-environm
2b40: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 ent-variable "MT
2b50: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 _RUN_AREA_HOME")
2b60: 20 22 2f 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 "/megatest.conf
2b70: 69 67 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 ig")).
2b80: 20 20 20 20 20 20 28 64 62 66 69 6c 65 20 28 63 (dbfile (c
2b90: 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e onc (get-environ
2ba0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
2bb0: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
2bc0: 29 20 22 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 ) "/megatest.db"
2bd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
2be0: 20 20 20 28 72 65 61 64 2d 6f 6e 6c 79 20 28 6e (read-only (n
2bf0: 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 ot (file-write-a
2c00: 63 63 65 73 73 3f 20 64 62 66 69 6c 65 29 29 29 ccess? dbfile)))
2c10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2c20: 20 28 64 62 73 74 72 75 63 74 20 28 64 62 3a 73 (dbstruct (db:s
2c30: 65 74 75 70 29 29 29 0a 09 20 20 20 20 28 64 65 etup))).. (de
2c40: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
2c50: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 09 ault-log-port*..
2c60: 09 09 20 22 57 41 52 4e 49 4e 47 3a 20 56 65 72 .. "WARNING: Ver
2c70: 73 69 6f 6e 20 6d 69 73 6d 61 74 63 68 21 5c 6e sion mismatch!\n
2c80: 22 0a 09 09 09 20 22 20 20 20 65 78 70 65 63 74 ".... " expect
2c90: 65 64 3a 20 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 ed: " (common:ve
2ca0: 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 rsion-signature)
2cb0: 20 22 5c 6e 22 0a 09 09 09 20 22 20 20 20 67 6f "\n".... " go
2cc0: 74 3a 20 20 20 20 20 20 22 20 28 63 6f 6d 6d 6f t: " (commo
2cd0: 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:get-last-run-v
2ce0: 65 72 73 69 6f 6e 29 29 0a 20 20 20 20 20 20 20 ersion)).
2cf0: 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 (cond.
2d00: 20 20 20 20 20 20 20 20 28 28 67 65 74 2d 65 6e ((get-en
2d10: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
2d20: 6c 65 20 22 4d 54 5f 53 4b 49 50 5f 44 42 5f 4d le "MT_SKIP_DB_M
2d30: 49 47 52 41 54 45 22 29 20 23 74 29 0a 20 20 20 IGRATE") #t).
2d40: 20 20 20 20 20 20 20 20 20 20 28 28 61 6e 64 20 ((and
2d50: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d 74 (file-exists? mt
2d60: 63 6f 6e 66 29 20 28 66 69 6c 65 2d 65 78 69 73 conf) (file-exis
2d70: 74 73 3f 20 64 62 66 69 6c 65 29 20 28 6e 6f 74 ts? dbfile) (not
2d80: 20 72 65 61 64 2d 6f 6e 6c 79 29 0a 20 20 20 20 read-only).
2d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2da0: 65 71 3f 20 28 63 75 72 72 65 6e 74 2d 75 73 65 eq? (current-use
2db0: 72 2d 69 64 29 28 66 69 6c 65 2d 6f 77 6e 65 72 r-id)(file-owner
2dc0: 20 6d 74 63 6f 6e 66 29 29 29 20 3b 3b 20 73 61 mtconf))) ;; sa
2dd0: 66 65 20 74 6f 20 72 75 6e 20 2d 63 6c 65 61 6e fe to run -clean
2de0: 75 70 2d 64 62 0a 20 20 20 20 20 20 20 20 20 20 up-db.
2df0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2e00: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
2e10: 70 6f 72 74 2a 20 22 20 20 20 49 20 73 65 65 20 port* " I see
2e20: 79 6f 75 20 61 72 65 20 74 68 65 20 6f 77 6e 65 you are the owne
2e30: 72 20 6f 66 20 6d 65 67 61 74 65 73 74 2e 63 6f r of megatest.co
2e40: 6e 66 69 67 2c 20 61 74 74 65 6d 70 74 69 6e 67 nfig, attempting
2e50: 20 74 6f 20 63 6c 65 61 6e 75 70 20 61 6e 64 20 to cleanup and
2e60: 72 65 73 65 74 20 74 6f 20 6e 65 77 20 76 65 72 reset to new ver
2e70: 73 69 6f 6e 22 29 0a 20 20 20 20 20 20 20 20 20 sion").
2e80: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 64 65 62 (common:deb
2e90: 75 67 2d 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 ug-handle-except
2ea0: 69 6f 6e 73 20 23 74 0a 20 20 20 20 20 20 20 20 ions #t.
2eb0: 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 exn.
2ec0: 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e (begin
2ed0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2ee0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
2ef0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
2f00: 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 73 rt* "Failed to s
2f10: 77 69 74 63 68 20 76 65 72 73 69 6f 6e 73 2e 22 witch versions."
2f20: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
2f30: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
2f40: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
2f50: 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 ort* " message:
2f60: 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 " ((condition-pr
2f70: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
2f80: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
2f90: 78 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 xn)).
2fa0: 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c (print-cal
2fb0: 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 l-chain (current
2fc0: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 -error-port)).
2fd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2fe0: 65 78 69 74 20 31 29 29 0a 20 20 20 20 20 20 20 exit 1)).
2ff0: 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a (common:
3000: 63 6c 65 61 6e 75 70 2d 64 62 20 64 62 73 74 72 cleanup-db dbstr
3010: 75 63 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 uct))).
3020: 20 20 20 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d ((not (file-
3030: 65 78 69 73 74 73 3f 20 6d 74 63 6f 6e 66 29 29 exists? mtconf))
3040: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3050: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3060: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3070: 20 22 20 20 20 6d 65 67 61 74 65 73 74 2e 63 6f " megatest.co
3080: 6e 66 69 67 20 64 6f 65 73 20 6e 6f 74 20 65 78 nfig does not ex
3090: 69 73 74 20 69 6e 20 74 68 69 73 20 61 72 65 61 ist in this area
30a0: 2e 20 20 43 61 6e 6e 6f 74 20 70 72 6f 63 65 65 . Cannot procee
30b0: 64 20 77 69 74 68 20 6d 65 67 61 74 65 73 74 20 d with megatest
30c0: 76 65 72 73 69 6f 6e 20 6d 69 67 72 61 74 69 6f version migratio
30d0: 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 n.").
30e0: 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 20 20 (exit 1)).
30f0: 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f 74 20 ((not
3100: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 (file-exists? db
3110: 66 69 6c 65 29 29 0a 20 20 20 20 20 20 20 20 20 file)).
3120: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3130: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3140: 2d 70 6f 72 74 2a 20 22 20 20 20 6d 65 67 61 74 -port* " megat
3150: 65 73 74 2e 64 62 20 64 6f 65 73 20 6e 6f 74 20 est.db does not
3160: 65 78 69 73 74 20 69 6e 20 74 68 69 73 20 61 72 exist in this ar
3170: 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 6f 63 ea. Cannot proc
3180: 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 65 73 eed with megates
3190: 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 61 74 t version migrat
31a0: 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 20 ion.").
31b0: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 (exit 1)).
31c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f ((no
31d0: 74 20 28 65 71 3f 20 28 63 75 72 72 65 6e 74 2d t (eq? (current-
31e0: 75 73 65 72 2d 69 64 29 28 66 69 6c 65 2d 6f 77 user-id)(file-ow
31f0: 6e 65 72 20 6d 74 63 6f 6e 66 29 29 29 0a 20 20 ner mtconf))).
3200: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
3210: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
3220: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
3230: 20 20 59 6f 75 20 64 6f 20 6e 6f 74 20 6f 77 6e You do not own
3240: 20 6d 65 67 61 74 65 73 74 2e 64 62 20 69 6e 20 megatest.db in
3250: 74 68 69 73 20 61 72 65 61 2e 20 20 43 61 6e 6e this area. Cann
3260: 6f 74 20 70 72 6f 63 65 65 64 20 77 69 74 68 20 ot proceed with
3270: 6d 65 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e megatest version
3280: 20 6d 69 67 72 61 74 69 6f 6e 2e 22 29 0a 20 20 migration.").
3290: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
32a0: 74 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 1)).
32b0: 20 20 20 28 72 65 61 64 2d 6f 6e 6c 79 0a 20 20 (read-only.
32c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
32d0: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
32e0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
32f0: 20 20 59 6f 75 20 68 61 76 65 20 72 65 61 64 2d You have read-
3300: 6f 6e 6c 79 20 61 63 63 65 73 73 20 74 6f 20 74 only access to t
3310: 68 69 73 20 61 72 65 61 2e 20 20 43 61 6e 6e 6f his area. Canno
3320: 74 20 70 72 6f 63 65 65 64 20 77 69 74 68 20 6d t proceed with m
3330: 65 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e 20 egatest version
3340: 6d 69 67 72 61 74 69 6f 6e 2e 22 29 0a 20 20 20 migration.").
3350: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 (exit
3360: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1)).
3370: 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 (else.
3380: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
3390: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
33a0: 67 2d 70 6f 72 74 2a 20 22 20 74 6f 20 73 77 69 g-port* " to swi
33b0: 74 63 68 20 76 65 72 73 69 6f 6e 73 20 79 6f 75 tch versions you
33c0: 20 63 61 6e 20 72 75 6e 3a 20 5c 22 6d 65 67 61 can run: \"mega
33d0: 74 65 73 74 20 2d 63 6c 65 61 6e 75 70 2d 64 62 test -cleanup-db
33e0: 5c 22 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 \"").
33f0: 20 20 20 28 65 78 69 74 20 31 29 29 29 29 0a 09 (exit 1))))..
3400: 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 28 64 (begin.. (d
3410: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
3420: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
3430: 22 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 6d "ERROR: cannot m
3440: 69 67 72 61 74 65 20 76 65 72 73 69 6f 6e 20 75 igrate version u
3450: 6e 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 68 6f 73 nless on homehos
3460: 74 2e 20 45 78 69 74 69 6e 67 2e 22 29 0a 09 20 t. Exiting.")..
3470: 20 20 20 28 65 78 69 74 20 31 29 29 29 29 29 0a (exit 1))))).
3480: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
3490: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
34c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 50 =========.;; S P
34d0: 20 41 20 52 20 53 20 45 20 20 20 41 20 52 20 52 A R S E A R R
34e0: 20 41 20 59 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d A Y S.;;=======
34f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3500: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3510: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3520: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
3530: 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 2d 73 .(define (make-s
3540: 70 61 72 73 65 2d 61 72 72 61 79 29 0a 20 20 28 parse-array). (
3550: 6c 65 74 20 28 28 61 20 28 6d 61 6b 65 2d 73 70 let ((a (make-sp
3560: 61 72 73 65 2d 76 65 63 74 6f 72 29 29 29 0a 20 arse-vector))).
3570: 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f (sparse-vecto
3580: 72 2d 73 65 74 21 20 61 20 30 20 28 6d 61 6b 65 r-set! a 0 (make
3590: 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 -sparse-vector))
35a0: 0a 20 20 20 20 61 29 29 0a 0a 28 64 65 66 69 6e . a))..(defin
35b0: 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 3f e (sparse-array?
35c0: 20 61 29 0a 20 20 28 61 6e 64 20 28 73 70 61 72 a). (and (spar
35d0: 73 65 2d 76 65 63 74 6f 72 3f 20 61 29 0a 20 20 se-vector? a).
35e0: 20 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 (sparse-vec
35f0: 74 6f 72 3f 20 28 73 70 61 72 73 65 2d 76 65 63 tor? (sparse-vec
3600: 74 6f 72 2d 72 65 66 20 61 20 30 29 29 29 29 0a tor-ref a 0)))).
3610: 0a 28 64 65 66 69 6e 65 20 28 73 70 61 72 73 65 .(define (sparse
3620: 2d 61 72 72 61 79 2d 72 65 66 20 61 20 78 20 79 -array-ref a x y
3630: 29 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 ). (let ((row (
3640: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 sparse-vector-re
3650: 66 20 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 f a x))). (if
3660: 20 72 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 row..(sparse-ve
3670: 63 74 6f 72 2d 72 65 66 20 72 6f 77 20 79 29 0a ctor-ref row y).
3680: 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 .#f)))..(define
3690: 28 73 70 61 72 73 65 2d 61 72 72 61 79 2d 73 65 (sparse-array-se
36a0: 74 21 20 61 20 78 20 79 20 76 61 6c 29 0a 20 20 t! a x y val).
36b0: 28 6c 65 74 20 28 28 72 6f 77 20 28 73 70 61 72 (let ((row (spar
36c0: 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 se-vector-ref a
36d0: 78 29 29 29 0a 20 20 20 20 28 69 66 20 72 6f 77 x))). (if row
36e0: 0a 09 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 ..(sparse-vector
36f0: 2d 73 65 74 21 20 72 6f 77 20 79 20 76 61 6c 29 -set! row y val)
3700: 0a 09 28 6c 65 74 20 28 28 6e 65 77 2d 72 6f 77 ..(let ((new-row
3710: 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 (make-sparse-ve
3720: 63 74 6f 72 29 29 29 0a 09 20 20 28 73 70 61 72 ctor))).. (spar
3730: 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 61 se-vector-set! a
3740: 20 78 20 6e 65 77 2d 72 6f 77 29 0a 09 20 20 28 x new-row).. (
3750: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 sparse-vector-se
3760: 74 21 20 6e 65 77 2d 72 6f 77 20 79 20 76 61 6c t! new-row y val
3770: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
3780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
37a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
37b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
37c0: 3b 3b 20 4c 20 4f 20 43 20 4b 20 45 20 52 20 53 ;; L O C K E R S
37d0: 20 20 20 41 20 4e 20 44 20 20 20 42 20 4c 20 4f A N D B L O
37e0: 20 43 20 4b 20 45 20 52 20 53 20 0a 3b 3b 3d 3d C K E R S .;;==
37f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3800: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3810: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3830: 3d 3d 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 6b 20 66 ====..;; block f
3840: 75 72 74 68 65 72 20 61 63 63 65 73 73 65 73 20 urther accesses
3850: 74 6f 20 64 61 74 61 62 61 73 65 73 2e 20 43 61 to databases. Ca
3860: 6c 6c 20 74 68 69 73 20 62 65 66 6f 72 65 20 73 ll this before s
3870: 68 75 74 74 69 6e 67 20 64 62 20 64 6f 77 6e 0a hutting db down.
3880: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
3890: 64 62 2d 62 6c 6f 63 6b 2d 66 75 72 74 68 65 72 db-block-further
38a0: 2d 71 75 65 72 69 65 73 29 0a 20 20 28 6d 75 74 -queries). (mut
38b0: 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 ex-lock! *db-acc
38c0: 65 73 73 2d 6d 75 74 65 78 2a 29 0a 20 20 28 73 ess-mutex*). (s
38d0: 65 74 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 et! *db-access-a
38e0: 6c 6c 6f 77 65 64 2a 20 23 66 29 0a 20 20 28 6d llowed* #f). (m
38f0: 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 utex-unlock! *db
3900: 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 29 -access-mutex*))
3910: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
3920: 6e 3a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f n:db-access-allo
3930: 77 65 64 3f 29 0a 20 20 28 6c 65 74 20 28 28 76 wed?). (let ((v
3940: 61 6c 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 al (begin..
3950: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
3960: 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a db-access-mutex*
3970: 29 0a 09 20 20 20 20 20 20 20 2a 64 62 2d 61 63 ).. *db-ac
3980: 63 65 73 73 2d 61 6c 6c 6f 77 65 64 2a 0a 09 20 cess-allowed*..
3990: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
39a0: 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d ock! *db-access-
39b0: 6d 75 74 65 78 2a 29 29 29 29 0a 20 20 20 20 76 mutex*)))). v
39c0: 61 6c 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d al))..;;========
39d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
3a10: 3b 20 55 20 53 20 45 20 46 20 55 20 4c 20 20 20 ; U S E F U L
3a20: 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d S T U F F.;;====
3a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3a70: 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 74 ==..;; convert t
3a80: 68 69 6e 67 73 20 74 6f 20 61 6e 20 61 6c 69 73 hings to an alis
3a90: 74 20 6f 72 20 61 73 73 6f 63 20 6c 69 73 74 2c t or assoc list,
3aa0: 20 23 66 20 67 65 74 73 20 63 6f 6e 76 65 72 74 #f gets convert
3ab0: 65 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 65 66 ed to "".;;.(def
3ac0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 ine (common:to-a
3ad0: 6c 69 73 74 20 64 61 74 29 0a 20 20 28 63 6f 6e list dat). (con
3ae0: 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 64 61 74 d. ((list? dat
3af0: 29 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a ) (map common:
3b00: 74 6f 2d 61 6c 69 73 74 20 64 61 74 29 29 0a 20 to-alist dat)).
3b10: 20 20 28 28 76 65 63 74 6f 72 3f 20 64 61 74 29 ((vector? dat)
3b20: 0a 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e . (map common
3b30: 3a 74 6f 2d 61 6c 69 73 74 20 28 76 65 63 74 6f :to-alist (vecto
3b40: 72 2d 3e 6c 69 73 74 20 64 61 74 29 29 29 0a 20 r->list dat))).
3b50: 20 20 28 28 70 61 69 72 3f 20 64 61 74 29 0a 20 ((pair? dat).
3b60: 20 20 20 28 63 6f 6e 73 20 28 63 6f 6d 6d 6f 6e (cons (common
3b70: 3a 74 6f 2d 61 6c 69 73 74 20 28 63 61 72 20 64 :to-alist (car d
3b80: 61 74 29 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a at)).. (common:
3b90: 74 6f 2d 61 6c 69 73 74 20 28 63 64 72 20 64 61 to-alist (cdr da
3ba0: 74 29 29 29 29 0a 20 20 20 28 28 68 61 73 68 2d t)))). ((hash-
3bb0: 74 61 62 6c 65 3f 20 64 61 74 29 0a 20 20 20 20 table? dat).
3bc0: 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 (map common:to-a
3bd0: 6c 69 73 74 20 28 68 61 73 68 2d 74 61 62 6c 65 list (hash-table
3be0: 2d 3e 61 6c 69 73 74 20 64 61 74 29 29 29 0a 20 ->alist dat))).
3bf0: 20 20 28 65 6c 73 65 0a 20 20 20 20 28 69 66 20 (else. (if
3c00: 64 61 74 0a 09 64 61 74 0a 09 22 22 29 29 29 29 dat..dat..""))))
3c10: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
3c20: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
3c30: 74 20 77 61 69 74 76 61 6c 20 2e 20 6b 65 79 73 t waitval . keys
3c40: 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 ). (let* ((key
3c50: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 (string-int
3c60: 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 63 6f ersperse (map co
3c70: 6e 63 20 6b 65 79 73 29 20 22 2d 22 20 29 29 0a nc keys) "-" )).
3c80: 09 20 28 6c 61 73 74 74 69 6d 65 20 28 68 61 73 . (lasttime (has
3c90: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
3ca0: 75 6c 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f ult *common:deno
3cb0: 69 73 65 2a 20 6b 65 79 20 30 29 29 0a 09 20 28 ise* key 0)).. (
3cc0: 63 75 72 72 74 69 6d 65 20 28 63 75 72 72 65 6e currtime (curren
3cd0: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 t-seconds))).
3ce0: 20 28 69 66 20 28 3e 20 28 2d 20 63 75 72 72 74 (if (> (- currt
3cf0: 69 6d 65 20 6c 61 73 74 74 69 6d 65 29 20 77 61 ime lasttime) wa
3d00: 69 74 76 61 6c 29 0a 09 28 62 65 67 69 6e 0a 09 itval)..(begin..
3d10: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
3d20: 74 21 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 t! *common:denoi
3d30: 73 65 2a 20 6b 65 79 20 63 75 72 72 74 69 6d 65 se* key currtime
3d40: 29 0a 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a ).. #t)..#f))).
3d50: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
3d60: 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d 65 78 :get-megatest-ex
3d70: 65 29 0a 20 20 28 6f 72 20 28 67 65 74 65 6e 76 e). (or (getenv
3d80: 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 29 20 "MT_MEGATEST")
3d90: 22 6d 65 67 61 74 65 73 74 22 29 29 0a 0a 28 64 "megatest"))..(d
3da0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 efine (common:re
3db0: 61 64 2d 65 6e 63 6f 64 65 64 2d 73 74 72 69 6e ad-encoded-strin
3dc0: 67 20 69 6e 73 74 72 29 0a 20 20 28 63 6f 6d 6d g instr). (comm
3dd0: 6f 6e 3a 64 65 62 75 67 2d 68 61 6e 64 6c 65 2d on:debug-handle-
3de0: 65 78 63 65 70 74 69 6f 6e 73 20 23 74 0a 20 20 exceptions #t.
3df0: 20 65 78 6e 0a 20 20 20 28 63 6f 6d 6d 6f 6e 3a exn. (common:
3e00: 64 65 62 75 67 2d 68 61 6e 64 6c 65 2d 65 78 63 debug-handle-exc
3e10: 65 70 74 69 6f 6e 73 20 23 74 0a 20 20 20 20 65 eptions #t. e
3e20: 78 6e 0a 20 20 20 20 28 62 65 67 69 6e 0a 20 20 xn. (begin.
3e30: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
3e40: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
3e50: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 63 t-log-port* "rec
3e60: 65 69 76 65 64 20 62 61 64 20 65 6e 63 6f 64 65 eived bad encode
3e70: 64 20 73 74 72 69 6e 67 20 5c 22 22 20 69 6e 73 d string \"" ins
3e80: 74 72 20 22 5c 22 2c 20 6d 65 73 73 61 67 65 3a tr "\", message:
3e90: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
3ea0: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
3eb0: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
3ec0: 65 78 6e 29 29 0a 20 20 20 20 20 20 28 70 72 69 exn)). (pri
3ed0: 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 28 63 nt-call-chain (c
3ee0: 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 urrent-error-por
3ef0: 74 29 29 0a 20 20 20 20 20 20 23 66 29 0a 20 20 t)). #f).
3f00: 20 20 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e (read (open-in
3f10: 70 75 74 2d 73 74 72 69 6e 67 20 28 62 61 73 65 put-string (base
3f20: 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 64:base64-decode
3f30: 20 69 6e 73 74 72 29 29 29 29 0a 20 20 20 28 72 instr)))). (r
3f40: 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d ead (open-input-
3f50: 73 74 72 69 6e 67 20 28 7a 33 3a 64 65 63 6f 64 string (z3:decod
3f60: 65 2d 62 75 66 66 65 72 20 28 62 61 73 65 36 34 e-buffer (base64
3f70: 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 :base64-decode i
3f80: 6e 73 74 72 29 29 29 29 29 29 0a 0a 3b 3b 20 64 nstr))))))..;; d
3f90: 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 20 73 ot-locking egg s
3fa0: 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f 72 6b eems not to work
3fb0: 2c 20 75 73 69 6e 67 20 74 68 69 73 20 66 6f 72 , using this for
3fc0: 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 now.;; if lock
3fd0: 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 65 78 is older than ex
3fe0: 70 69 72 65 2d 74 69 6d 65 20 74 68 65 6e 20 72 pire-time then r
3ff0: 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 72 79 emove it and try
4000: 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 again.;; to get
4010: 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 the lock.;;.(de
4020: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d fine (common:sim
4030: 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e ple-file-lock fn
4040: 61 6d 65 20 23 21 6b 65 79 20 28 65 78 70 69 72 ame #!key (expir
4050: 65 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 e-time 300)). (
4060: 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
4070: 20 66 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 69 fname). (i
4080: 66 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e 74 f (> (- (current
4090: 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d -seconds)(file-m
40a0: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
40b0: 20 66 6e 61 6d 65 29 29 20 65 78 70 69 72 65 2d fname)) expire-
40c0: 74 69 6d 65 29 0a 09 20 20 28 62 65 67 69 6e 0a time).. (begin.
40d0: 09 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c . (delete-fil
40e0: 65 2a 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 28 e* fname).. (
40f0: 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 common:simple-fi
4100: 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 le-lock fname ex
4110: 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 pire-time: expir
4120: 65 2d 74 69 6d 65 29 29 0a 09 20 20 23 66 29 0a e-time)).. #f).
4130: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6b 65 79 (let ((key
4140: 2d 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 67 -string (conc (g
4150: 65 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d et-host-name) "-
4160: 22 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 " (current-proce
4170: 73 73 2d 69 64 29 29 29 29 0a 09 28 77 69 74 68 ss-id))))..(with
4180: 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 -output-to-file
4190: 66 6e 61 6d 65 0a 09 20 20 28 6c 61 6d 62 64 61 fname.. (lambda
41a0: 20 28 29 0a 09 20 20 20 20 28 70 72 69 6e 74 20 ().. (print
41b0: 6b 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 28 key-string)))..(
41c0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
41d0: 32 35 29 0a 09 28 69 66 20 28 66 69 6c 65 2d 65 25)..(if (file-e
41e0: 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 20 xists? fname)..
41f0: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
4200: 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 rom-file fname..
4210: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
4220: 0a 09 09 28 65 71 75 61 6c 3f 20 6b 65 79 2d 73 ...(equal? key-s
4230: 74 72 69 6e 67 20 28 72 65 61 64 2d 6c 69 6e 65 tring (read-line
4240: 29 29 29 29 0a 09 20 20 20 20 23 66 29 29 29 29 )))).. #f))))
4250: 0a 09 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ...(define (comm
4260: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 on:simple-file-r
4270: 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d elease-lock fnam
4280: 65 29 0a 20 20 28 64 65 6c 65 74 65 2d 66 69 6c e). (delete-fil
4290: 65 2a 20 66 6e 61 6d 65 29 29 0a 0a 3b 3b 3d 3d e* fname))..;;==
42a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42e0: 3d 3d 3d 3d 0a 3b 3b 20 53 20 54 20 41 20 54 20 ====.;; S T A T
42f0: 45 20 53 20 20 20 41 20 4e 20 44 20 20 20 53 20 E S A N D S
4300: 54 20 41 20 54 20 55 20 53 20 45 20 53 0a 3b 3b T A T U S E S.;;
4310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4350: 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
4360: 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 *common:std-stat
4370: 65 73 2a 20 20 20 0a 20 20 27 28 28 30 20 22 41 es* . '((0 "A
4380: 52 43 48 49 56 45 44 22 29 0a 20 20 20 20 28 31 RCHIVED"). (1
4390: 20 22 53 54 55 43 4b 22 29 0a 20 20 20 20 28 32 "STUCK"). (2
43a0: 20 22 4b 49 4c 4c 52 45 51 22 29 0a 20 20 20 20 "KILLREQ").
43b0: 28 33 20 22 4b 49 4c 4c 45 44 22 29 0a 20 20 20 (3 "KILLED").
43c0: 20 28 34 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 (4 "NOT_STARTED
43d0: 22 29 0a 20 20 20 20 28 35 20 22 43 4f 4d 50 4c "). (5 "COMPL
43e0: 45 54 45 44 22 29 0a 20 20 20 20 28 36 20 22 4c ETED"). (6 "L
43f0: 41 55 4e 43 48 45 44 22 29 0a 20 20 20 20 28 37 AUNCHED"). (7
4400: 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 "REMOTEHOSTSTAR
4410: 54 22 29 0a 20 20 20 20 28 38 20 22 52 55 4e 4e T"). (8 "RUNN
4420: 49 4e 47 22 29 0a 20 20 20 20 29 29 0a 0a 28 64 ING"). ))..(d
4430: 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 efine *common:st
4440: 64 2d 73 74 61 74 75 73 65 73 2a 0a 20 20 27 28 d-statuses*. '(
4450: 3b 3b 20 28 30 20 22 44 45 4c 45 54 45 44 22 29 ;; (0 "DELETED")
4460: 0a 20 20 20 20 28 31 20 22 6e 2f 61 22 29 0a 20 . (1 "n/a").
4470: 20 20 20 28 32 20 22 50 41 53 53 22 29 0a 20 20 (2 "PASS").
4480: 20 20 28 33 20 22 43 48 45 43 4b 22 29 0a 20 20 (3 "CHECK").
4490: 20 20 28 34 20 22 53 4b 49 50 22 29 0a 20 20 20 (4 "SKIP").
44a0: 20 28 35 20 22 57 41 52 4e 22 29 0a 20 20 20 20 (5 "WARN").
44b0: 28 36 20 22 57 41 49 56 45 44 22 29 0a 20 20 20 (6 "WAIVED").
44c0: 20 28 37 20 22 53 54 55 43 4b 2f 44 45 41 44 22 (7 "STUCK/DEAD"
44d0: 29 0a 20 20 20 20 28 38 20 22 46 41 49 4c 22 29 ). (8 "FAIL")
44e0: 0a 20 20 20 20 28 39 20 22 41 42 4f 52 54 22 29 . (9 "ABORT")
44f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d ))..(define *com
4500: 6d 6f 6e 3a 65 6e 64 65 64 2d 73 74 61 74 65 73 mon:ended-states
4510: 2a 20 20 20 20 20 20 20 3b 3b 20 73 74 61 74 65 * ;; state
4520: 73 20 77 68 69 63 68 20 69 6e 64 69 63 61 74 65 s which indicate
4530: 20 74 68 65 20 74 65 73 74 20 69 73 20 73 74 6f the test is sto
4540: 70 70 65 64 20 61 6e 64 20 77 69 6c 6c 20 6e 6f pped and will no
4550: 74 20 70 72 6f 63 65 65 64 0a 20 20 27 28 22 43 t proceed. '("C
4560: 4f 4d 50 4c 45 54 45 44 22 20 22 41 52 43 48 49 OMPLETED" "ARCHI
4570: 56 45 44 22 20 22 4b 49 4c 4c 45 44 22 20 22 4b VED" "KILLED" "K
4580: 49 4c 4c 52 45 51 22 20 22 53 54 55 43 4b 22 20 ILLREQ" "STUCK"
4590: 22 49 4e 43 4f 4d 50 4c 45 54 45 22 29 29 0a 0a "INCOMPLETE"))..
45a0: 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a (define *common:
45b0: 62 61 64 6c 79 2d 65 6e 64 65 64 2d 73 74 61 74 badly-ended-stat
45c0: 65 73 2a 20 3b 3b 20 74 68 65 73 65 20 72 6f 6c es* ;; these rol
45d0: 6c 20 75 70 20 61 73 20 43 48 45 43 4b 2c 20 69 l up as CHECK, i
45e0: 2e 65 2e 20 72 65 73 75 6c 74 73 20 6e 65 65 64 .e. results need
45f0: 20 74 6f 20 62 65 20 63 68 65 63 6b 65 64 0a 20 to be checked.
4600: 20 27 28 22 4b 49 4c 4c 45 44 22 20 22 4b 49 4c '("KILLED" "KIL
4610: 4c 52 45 51 22 20 22 53 54 55 43 4b 22 20 22 49 LREQ" "STUCK" "I
4620: 4e 43 4f 4d 50 4c 45 54 45 22 20 22 44 45 41 44 NCOMPLETE" "DEAD
4630: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f "))..(define *co
4640: 6d 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 61 mmon:running-sta
4650: 74 65 73 2a 20 20 20 20 20 3b 3b 20 74 65 73 74 tes* ;; test
4660: 20 69 73 20 65 69 74 68 65 72 20 72 75 6e 6e 69 is either runni
4670: 6e 67 20 6f 72 20 63 61 6e 20 62 65 20 72 75 6e ng or can be run
4680: 0a 20 20 27 28 22 52 55 4e 4e 49 4e 47 22 20 22 . '("RUNNING" "
4690: 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 REMOTEHOSTSTART"
46a0: 20 22 4c 41 55 4e 43 48 45 44 22 29 29 0a 0a 28 "LAUNCHED"))..(
46b0: 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 63 define *common:c
46c0: 61 6e 74 2d 72 75 6e 2d 73 74 61 74 65 73 2a 20 ant-run-states*
46d0: 20 20 20 3b 3b 20 54 68 65 73 65 20 61 72 65 20 ;; These are
46e0: 73 74 6f 70 70 69 6e 67 20 63 6f 6e 64 69 74 69 stopping conditi
46f0: 6f 6e 73 20 74 68 61 74 20 70 72 65 76 65 6e 74 ons that prevent
4700: 20 61 20 74 65 73 74 20 66 72 6f 6d 20 62 65 69 a test from bei
4710: 6e 67 20 72 75 6e 0a 20 20 27 28 22 43 4f 4d 50 ng run. '("COMP
4720: 4c 45 54 45 44 22 20 22 4b 49 4c 4c 45 44 22 20 LETED" "KILLED"
4730: 22 55 4e 4b 4e 4f 57 4e 22 20 22 49 4e 43 4f 4d "UNKNOWN" "INCOM
4740: 50 4c 45 54 45 22 20 22 41 52 43 48 49 56 45 44 PLETE" "ARCHIVED
4750: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f "))..(define *co
4760: 6d 6d 6f 6e 3a 6e 6f 74 2d 73 74 61 72 74 65 64 mmon:not-started
4770: 2d 6f 6b 2d 73 74 61 74 75 73 65 73 2a 20 3b 3b -ok-statuses* ;;
4780: 20 69 66 20 6e 6f 74 20 6f 6e 65 20 6f 66 20 74 if not one of t
4790: 68 65 73 65 20 73 74 61 74 75 73 65 73 20 77 68 hese statuses wh
47a0: 65 6e 20 69 6e 20 6e 6f 74 5f 73 74 61 72 74 65 en in not_starte
47b0: 64 20 73 74 61 74 65 20 74 72 65 61 74 20 61 73 d state treat as
47c0: 20 64 65 61 64 0a 20 20 27 28 22 6e 2f 61 22 20 dead. '("n/a"
47d0: 22 6e 61 22 20 22 50 41 53 53 22 20 22 46 41 49 "na" "PASS" "FAI
47e0: 4c 22 20 22 57 41 52 4e 22 20 22 43 48 45 43 4b L" "WARN" "CHECK
47f0: 22 20 22 57 41 49 56 45 44 22 20 22 44 45 41 44 " "WAIVED" "DEAD
4800: 22 20 22 53 4b 49 50 22 29 29 0a 0a 28 64 65 66 " "SKIP"))..(def
4810: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 70 65 63 ine (common:spec
4820: 69 61 6c 2d 73 6f 72 74 20 69 74 65 6d 73 20 6f ial-sort items o
4830: 72 64 65 72 20 63 6f 6d 70 29 0a 20 20 28 6c 65 rder comp). (le
4840: 74 20 28 28 69 74 65 6d 73 2d 6f 72 64 65 72 20 t ((items-order
4850: 28 6d 61 70 20 72 65 76 65 72 73 65 20 6f 72 64 (map reverse ord
4860: 65 72 29 29 0a 20 20 20 20 20 20 20 20 28 61 63 er)). (ac
4870: 6f 6d 70 20 20 20 20 20 20 20 28 6f 72 20 63 6f omp (or co
4880: 6d 70 20 3e 29 29 29 0a 20 20 20 20 28 73 6f 72 mp >))). (sor
4890: 74 20 69 74 65 6d 73 0a 20 20 20 20 20 20 20 20 t items.
48a0: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 20 (lambda (a b).
48b0: 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 61 (let ((a
48c0: 2d 6e 75 6d 20 28 63 61 64 72 20 28 6f 72 20 28 -num (cadr (or (
48d0: 61 73 73 6f 63 20 61 20 69 74 65 6d 73 2d 6f 72 assoc a items-or
48e0: 64 65 72 29 20 27 28 30 20 30 29 29 29 29 0a 20 der) '(0 0)))).
48f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
4900: 62 2d 6e 75 6d 20 28 63 61 64 72 20 28 6f 72 20 b-num (cadr (or
4910: 28 61 73 73 6f 63 20 62 20 69 74 65 6d 73 2d 6f (assoc b items-o
4920: 72 64 65 72 29 20 27 28 30 20 30 29 29 29 29 29 rder) '(0 0)))))
4930: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 61 63 . (ac
4940: 6f 6d 70 20 61 2d 6e 75 6d 20 62 2d 6e 75 6d 29 omp a-num b-num)
4950: 29 29 29 29 29 0a 0a 3b 3b 20 3b 3b 20 67 69 76 )))))..;; ;; giv
4960: 65 6e 20 61 20 74 6f 70 6c 65 76 65 6c 20 77 69 en a toplevel wi
4970: 74 68 20 63 75 72 72 73 74 61 74 65 2c 20 63 75 th currstate, cu
4980: 72 72 73 74 61 74 75 73 20 61 70 70 6c 79 20 73 rrstatus apply s
4990: 74 61 74 65 20 61 6e 64 20 73 74 61 74 75 73 0a tate and status.
49a0: 3b 3b 20 3b 3b 20 20 3d 3e 20 28 6e 65 77 73 74 ;; ;; => (newst
49b0: 61 74 65 20 2e 20 6e 65 77 73 74 61 74 75 73 29 ate . newstatus)
49c0: 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 63 6f 6d .;; (define (com
49d0: 6d 6f 6e 3a 61 70 70 6c 79 2d 73 74 61 74 65 2d mon:apply-state-
49e0: 73 74 61 74 75 73 20 63 75 72 72 73 74 61 74 65 status currstate
49f0: 20 63 75 72 72 73 74 61 74 75 73 20 73 74 61 74 currstatus stat
4a00: 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 28 e status).;; (
4a10: 6c 65 74 2a 20 28 28 63 73 74 61 74 65 20 20 28 let* ((cstate (
4a20: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
4a30: 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 string-downcase
4a40: 63 75 72 72 73 74 61 74 65 29 29 29 0a 3b 3b 20 currstate))).;;
4a50: 20 20 20 20 20 20 20 20 20 28 63 73 74 61 74 75 (cstatu
4a60: 73 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f s (string->symbo
4a70: 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 l (string-downca
4a80: 73 65 20 63 75 72 72 73 74 61 74 75 73 29 29 29 se currstatus)))
4a90: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 73 73 .;; (ss
4aa0: 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d 3e 73 tate (string->s
4ab0: 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f ymbol (string-do
4ac0: 77 6e 63 61 73 65 20 73 74 61 74 65 29 29 29 0a wncase state))).
4ad0: 3b 3b 20 20 20 20 20 20 20 20 20 20 28 73 73 74 ;; (sst
4ae0: 61 74 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 79 atus (string->sy
4af0: 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 mbol (string-dow
4b00: 6e 63 61 73 65 20 73 74 61 74 75 73 29 29 29 0a ncase status))).
4b10: 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6e 73 74 ;; (nst
4b20: 61 74 65 20 20 23 66 29 0a 3b 3b 20 20 20 20 20 ate #f).;;
4b30: 20 20 20 20 20 28 6e 73 74 61 74 75 73 20 23 66 (nstatus #f
4b40: 29 29 0a 3b 3b 20 20 20 20 20 28 73 65 74 21 20 )).;; (set!
4b50: 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 nstate.;;
4b60: 20 20 20 20 28 63 61 73 65 20 63 73 74 61 74 65 (case cstate
4b70: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
4b80: 28 28 63 6f 6d 70 6c 65 74 65 64 20 6e 6f 74 5f ((completed not_
4b90: 73 74 61 72 74 65 64 20 6b 69 6c 6c 65 64 20 6b started killed k
4ba0: 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 72 63 illreq stuck arc
4bb0: 68 69 76 65 64 29 20 0a 3b 3b 20 20 20 20 20 20 hived) .;;
4bc0: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 73 73 (case ss
4bd0: 74 61 74 65 20 3b 3b 20 63 6f 6d 70 6c 65 74 65 tate ;; complete
4be0: 64 20 2d 3e 20 73 73 74 61 74 65 0a 3b 3b 20 20 d -> sstate.;;
4bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
4c00: 63 6f 6d 70 6c 65 74 65 64 20 6b 69 6c 6c 65 64 completed killed
4c10: 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 killreq stuck a
4c20: 72 63 68 69 76 65 64 29 20 63 6f 6d 70 6c 65 74 rchived) complet
4c30: 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ed).;;
4c40: 20 20 20 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 ((running
4c50: 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 72 74 20 remotehoststart
4c60: 6c 61 75 6e 63 68 65 64 29 20 20 20 20 20 20 20 launched)
4c70: 20 72 75 6e 6e 69 6e 67 29 0a 3b 3b 20 20 20 20 running).;;
4c80: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
4c90: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e
4ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4cb0: 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 unknown-e
4cc0: 72 72 6f 72 2d 31 29 29 29 0a 3b 3b 20 20 20 20 rror-1))).;;
4cd0: 20 20 20 20 20 20 20 20 20 28 28 72 75 6e 6e 69 ((runni
4ce0: 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 61 ng remotehoststa
4cf0: 72 74 20 6c 61 75 6e 63 68 65 64 29 0a 3b 3b 20 rt launched).;;
4d00: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
4d10: 73 65 20 73 73 74 61 74 65 0a 3b 3b 20 20 20 20 se sstate.;;
4d20: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 6f ((co
4d30: 6d 70 6c 65 74 65 64 20 6b 69 6c 6c 65 64 20 6b mpleted killed k
4d40: 69 6c 6c 72 65 71 20 73 74 75 63 6b 20 61 72 63 illreq stuck arc
4d50: 68 69 76 65 64 29 20 23 66 29 20 3b 3b 20 6e 65 hived) #f) ;; ne
4d60: 65 64 20 74 6f 20 6c 6f 6f 6b 20 61 74 20 61 6c ed to look at al
4d70: 6c 20 69 74 65 6d 73 0a 3b 3b 20 20 20 20 20 20 l items.;;
4d80: 20 20 20 20 20 20 20 20 20 20 28 28 72 75 6e 6e ((runn
4d90: 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 ing remotehostst
4da0: 61 72 74 20 6c 61 75 6e 63 68 65 64 29 20 20 20 art launched)
4db0: 20 20 20 20 20 72 75 6e 6e 69 6e 67 29 0a 3b 3b running).;;
4dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4dd0: 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 (else
4de0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
4df0: 20 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f unkno
4e00: 77 6e 2d 65 72 72 6f 72 2d 32 29 29 29 0a 3b 3b wn-error-2))).;;
4e10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c (el
4e20: 73 65 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 se unknown-error
4e30: 2d 33 29 29 29 0a 3b 3b 20 20 20 20 20 28 73 65 -3))).;; (se
4e40: 74 21 20 6e 73 74 61 74 75 73 0a 3b 3b 20 20 20 t! nstatus.;;
4e50: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 73 73 (case ss
4e60: 74 61 74 75 73 0a 3b 3b 20 20 20 20 20 20 20 20 tatus.;;
4e70: 20 20 20 20 20 28 28 70 61 73 73 29 0a 3b 3b 20 ((pass).;;
4e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
4e90: 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 se nstate.;;
4ea0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 ((pa
4eb0: 73 73 20 6e 2f 61 20 64 65 6c 65 74 65 64 29 20 ss n/a deleted)
4ec0: 20 20 20 20 70 61 73 73 29 0a 3b 3b 20 20 20 20 pass).;;
4ed0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 77 61 ((wa
4ee0: 72 6e 29 20 20 20 20 20 20 20 20 20 20 20 20 20 rn)
4ef0: 20 20 20 20 77 61 72 6e 29 0a 3b 3b 20 20 20 20 warn).;;
4f00: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 66 61 ((fa
4f10: 69 6c 29 20 20 20 20 20 20 20 20 20 20 20 20 20 il)
4f20: 20 20 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 20 fail).;;
4f30: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 63 68 ((ch
4f40: 65 63 6b 29 20 20 20 20 20 20 20 20 20 20 20 20 eck)
4f50: 20 20 20 63 68 65 63 6b 29 0a 3b 3b 20 20 20 20 check).;;
4f60: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 77 61 ((wa
4f70: 69 76 65 64 29 20 20 20 20 20 20 20 20 20 20 20 ived)
4f80: 20 20 77 61 69 76 65 64 29 0a 3b 3b 20 20 20 20 waived).;;
4f90: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 6b ((sk
4fa0: 69 70 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ip)
4fb0: 20 20 20 20 73 6b 69 70 29 0a 3b 3b 20 20 20 20 skip).;;
4fc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 73 74 ((st
4fd0: 75 63 6b 2f 64 65 61 64 29 20 20 20 20 20 20 20 uck/dead)
4fe0: 20 20 20 73 74 75 63 6b 29 0a 3b 3b 20 20 20 20 stuck).;;
4ff0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 62 ((ab
5000: 6f 72 74 29 20 20 20 20 20 20 20 20 20 20 20 20 ort)
5010: 20 20 20 61 62 6f 72 74 29 0a 3b 3b 20 20 20 20 abort).;;
5020: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
5030: 65 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e e unknown
5040: 2d 65 72 72 6f 72 2d 34 29 29 29 0a 3b 3b 20 20 -error-4))).;;
5050: 20 20 20 20 20 20 20 20 20 20 20 28 28 77 61 72 ((war
5060: 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 n).;;
5070: 20 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 0a (case nstate.
5080: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5090: 20 20 28 28 70 61 73 73 20 77 61 72 6e 20 6e 2f ((pass warn n/
50a0: 61 20 73 6b 69 70 20 64 65 6c 65 74 65 64 29 20 a skip deleted)
50b0: 20 20 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 20 warn).;;
50c0: 20 20 20 20 20 20 20 20 20 20 28 28 66 61 69 6c ((fail
50d0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
50e0: 20 20 20 20 20 20 20 20 20 20 66 61 69 6c 29 0a fail).
50f0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5100: 20 20 28 28 63 68 65 63 6b 29 20 20 20 20 20 20 ((check)
5110: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5120: 20 63 68 65 63 6b 29 0a 3b 3b 20 20 20 20 20 20 check).;;
5130: 20 20 20 20 20 20 20 20 20 20 28 28 77 61 69 76 ((waiv
5140: 65 64 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ed)
5150: 20 20 20 20 20 20 20 20 77 61 69 76 65 64 29 0a waived).
5160: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5170: 20 20 28 28 73 74 75 63 6b 2f 64 65 61 64 29 20 ((stuck/dead)
5180: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5190: 20 73 74 75 63 6b 29 0a 3b 3b 20 20 20 20 20 20 stuck).;;
51a0: 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 (else
51b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 75 u
51c0: 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 35 29 29 nknown-error-5))
51d0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
51e0: 20 28 28 66 61 69 6c 29 0a 3b 3b 20 20 20 20 20 ((fail).;;
51f0: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 6e (case n
5200: 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 state.;;
5210: 20 20 20 20 20 20 20 20 28 28 70 61 73 73 20 77 ((pass w
5220: 61 72 6e 20 66 61 69 6c 20 63 68 65 63 6b 20 6e arn fail check n
5230: 2f 61 20 77 61 69 76 65 64 20 73 6b 69 70 20 64 /a waived skip d
5240: 65 6c 65 74 65 64 20 73 74 75 63 6b 2f 64 65 61 eleted stuck/dea
5250: 64 20 73 74 75 63 6b 29 20 20 66 61 69 6c 29 0a d stuck) fail).
5260: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5270: 20 20 28 28 61 62 6f 72 74 29 20 20 20 20 20 20 ((abort)
5280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52b0: 20 20 20 61 62 6f 72 74 29 0a 3b 3b 20 20 20 20 abort).;;
52c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 (els
52d0: 65 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 e
52e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
52f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5300: 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 unknown-error
5310: 2d 36 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 -6))).;;
5320: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 75 6e (else un
5330: 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 37 29 29 29 known-error-7)))
5340: 0a 3b 3b 20 20 20 20 20 28 63 6f 6e 73 20 0a 3b .;; (cons .;
5350: 3b 20 20 20 20 20 20 28 69 66 20 6e 73 74 61 74 ; (if nstat
5360: 65 20 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 e (symbol->stri
5370: 6e 67 20 6e 73 74 61 74 65 29 20 20 6e 73 74 61 ng nstate) nsta
5380: 74 65 29 0a 3b 3b 20 20 20 20 20 20 28 69 66 20 te).;; (if
5390: 6e 73 74 61 74 75 73 20 28 73 79 6d 62 6f 6c 2d nstatus (symbol-
53a0: 3e 73 74 72 69 6e 67 20 6e 73 74 61 74 75 73 29 >string nstatus)
53b0: 20 6e 73 74 61 74 75 73 29 29 29 29 0a 20 20 20 nstatus)))).
53c0: 20 20 20 20 20 20 20 20 20 20 20 20 0a 3b 3b 3d .;;=
53d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
53f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5410: 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 45 20 42 20 55 =====.;; D E B U
5420: 20 47 20 47 20 49 20 4e 20 47 20 20 20 53 20 54 G G I N G S T
5430: 20 55 20 46 20 46 20 0a 3b 3b 3d 3d 3d 3d 3d 3d U F F .;;======
5440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5480: 0a 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f ..(define *verbo
5490: 73 69 74 79 2a 20 20 20 20 20 20 20 20 20 31 29 sity* 1)
54a0: 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 67 67 69 6e .(define *loggin
54b0: 67 2a 20 20 20 20 20 20 20 20 20 20 20 23 66 29 g* #f)
54c0: 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 77 ..(define (get-w
54d0: 69 74 68 2d 64 65 66 61 75 6c 74 20 76 61 6c 20 ith-default val
54e0: 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 default). (let
54f0: 28 28 76 61 6c 20 28 61 72 67 73 3a 67 65 74 2d ((val (args:get-
5500: 61 72 67 20 76 61 6c 29 29 29 0a 20 20 20 20 28 arg val))). (
5510: 69 66 20 76 61 6c 20 76 61 6c 20 64 65 66 61 75 if val val defau
5520: 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 lt)))..(define (
5530: 61 73 73 6f 63 2f 64 65 66 61 75 6c 74 20 6b 65 assoc/default ke
5540: 79 20 6c 73 74 20 2e 20 64 65 66 61 75 6c 74 29 y lst . default)
5550: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 61 . (let ((res (a
5560: 73 73 6f 63 20 6b 65 79 20 6c 73 74 29 29 29 0a ssoc key lst))).
5570: 20 20 20 20 28 69 66 20 72 65 73 20 28 63 61 64 (if res (cad
5580: 72 20 72 65 73 29 28 69 66 20 28 6e 75 6c 6c 3f r res)(if (null?
5590: 20 64 65 66 61 75 6c 74 29 20 23 66 20 28 63 61 default) #f (ca
55a0: 72 20 64 65 66 61 75 6c 74 29 29 29 29 29 0a 0a r default)))))..
55b0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
55c0: 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e 61 get-testsuite-na
55d0: 6d 65 29 0a 20 20 28 6f 72 20 28 63 6f 6e 66 69 me). (or (confi
55e0: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
55f0: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 61 gdat* "setup" "a
5600: 72 65 61 2d 6e 61 6d 65 22 29 20 3b 3b 20 6d 65 rea-name") ;; me
5610: 67 61 74 65 73 74 20 69 73 20 61 20 66 6c 65 78 gatest is a flex
5620: 69 62 6c 65 20 74 6f 6f 6c 2c 20 74 65 73 74 73 ible tool, tests
5630: 75 69 74 65 20 69 73 20 74 6f 6f 20 6c 69 6d 69 uite is too limi
5640: 74 69 6e 67 20 61 20 64 65 73 63 72 69 70 74 69 ting a descripti
5650: 6f 6e 2e 0a 20 20 20 20 20 20 28 63 6f 6e 66 69 on.. (confi
5660: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
5670: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 74 gdat* "setup" "t
5680: 65 73 74 73 75 69 74 65 22 20 29 0a 20 20 20 20 estsuite" ).
5690: 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 (if *toppath*
56a0: 0a 20 20 20 20 20 20 20 20 20 20 28 70 61 74 68 . (path
56b0: 6e 61 6d 65 2d 66 69 6c 65 20 2a 74 6f 70 70 61 name-file *toppa
56c0: 74 68 2a 29 0a 20 20 20 20 20 20 20 20 20 20 28 th*). (
56d0: 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 pathname-file (c
56e0: 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
56f0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 )))))..(define c
5700: 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e ommon:get-area-n
5710: 61 6d 65 20 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 ame common:get-t
5720: 65 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a 0a estsuite-name)..
5730: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
5740: 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 get-db-tmp-area)
5750: 0a 20 20 28 69 66 20 2a 64 62 2d 63 61 63 68 65 . (if *db-cache
5760: 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 2a 64 62 -path*. *db
5770: 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 20 20 -cache-path*.
5780: 20 20 20 28 6c 65 74 20 28 28 64 62 70 61 74 68 (let ((dbpath
5790: 20 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f (create-directo
57a0: 72 79 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 ry (conc "/tmp/"
57b0: 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e (current-user-n
57c0: 61 6d 65 29 0a 09 09 09 09 09 20 20 20 20 22 2f ame)...... "/
57d0: 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c 64 62 megatest_localdb
57e0: 2f 22 0a 09 09 09 09 09 20 20 20 20 28 63 6f 6d /"...... (com
57f0: 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 mon:get-testsuit
5800: 65 2d 6e 61 6d 65 29 20 22 2f 22 0a 09 09 09 09 e-name) "/".....
5810: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 74 72 61 . (string-tra
5820: 6e 73 6c 61 74 65 20 2a 74 6f 70 70 61 74 68 2a nslate *toppath*
5830: 20 22 2f 22 20 22 2e 22 29 29 20 23 74 29 29 29 "/" ".")) #t)))
5840: 0a 09 28 73 65 74 21 20 2a 64 62 2d 63 61 63 68 ..(set! *db-cach
5850: 65 2d 70 61 74 68 2a 20 64 62 70 61 74 68 29 0a e-path* dbpath).
5860: 09 64 62 70 61 74 68 29 29 29 0a 0a 28 64 65 66 .dbpath)))..(def
5870: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
5880: 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e 61 74 area-path-signat
5890: 75 72 65 29 0a 20 20 28 6d 65 73 73 61 67 65 2d ure). (message-
58a0: 64 69 67 65 73 74 2d 73 74 72 69 6e 67 20 28 6d digest-string (m
58b0: 64 35 2d 70 72 69 6d 69 74 69 76 65 29 20 2a 74 d5-primitive) *t
58c0: 6f 70 70 61 74 68 2a 29 29 0a 0a 28 64 65 66 69 oppath*))..(defi
58d0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 73 ne (common:get-s
58e0: 69 67 6e 61 74 75 72 65 20 73 74 72 29 0a 20 20 ignature str).
58f0: 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 2d (message-digest-
5900: 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 6d string (md5-prim
5910: 69 74 69 76 65 29 20 73 74 72 29 29 0a 0a 3b 3b itive) str))..;;
5920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5960: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 58 20 49 20 ======.;; E X I
5970: 54 20 20 20 48 20 41 20 4e 20 44 20 4c 20 49 20 T H A N D L I
5980: 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d N G.;;==========
5990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
59a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
59b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
59c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 ============..(d
59d0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 efine (common:ru
59e0: 6e 2d 73 79 6e 63 3f 29 0a 20 20 20 20 28 61 6e n-sync?). (an
59f0: 64 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d d (common:on-hom
5a00: 65 68 6f 73 74 3f 29 0a 09 20 28 61 72 67 73 3a ehost?).. (args:
5a10: 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 72 get-arg "-server
5a20: 22 29 29 29 0a 0a 3b 3b 20 20 20 28 6c 65 74 20 ")))..;; (let
5a30: 28 28 6f 68 68 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e ((ohh (common:on
5a40: 2d 68 6f 6d 65 68 6f 73 74 3f 29 29 0a 3b 3b 20 -homehost?)).;;
5a50: 09 28 73 72 76 20 28 61 72 67 73 3a 67 65 74 2d .(srv (args:get-
5a60: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 29 arg "-server")))
5a70: 0a 3b 3b 20 20 20 20 20 28 61 6e 64 20 6f 68 68 .;; (and ohh
5a80: 20 73 72 76 29 29 29 0a 20 20 20 20 3b 3b 20 28 srv))). ;; (
5a90: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
5aa0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
5ab0: 70 6f 72 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 75 port* "common:ru
5ac0: 6e 2d 73 79 6e 63 3f 20 6f 68 68 3d 22 20 6f 68 n-sync? ohh=" oh
5ad0: 68 20 22 2c 20 73 72 76 3d 22 20 73 72 76 29 0a h ", srv=" srv).
5ae0: 0a 3b 3b 3b 3b 20 72 75 6e 2d 69 64 73 0a 3b 3b .;;;; run-ids.;;
5af0: 20 20 20 20 69 66 20 23 66 20 75 73 65 20 2a 64 if #f use *d
5b00: 62 2d 6c 6f 63 61 6c 2d 73 79 6e 63 2a 20 3a 20 b-local-sync* :
5b10: 6f 72 20 27 6c 6f 63 61 6c 2d 73 79 6e 63 2d 66 or 'local-sync-f
5b20: 6c 61 67 73 0a 3b 3b 20 20 20 20 69 66 20 23 74 lags.;; if #t
5b30: 20 75 73 65 20 74 69 6d 65 73 74 61 6d 70 73 20 use timestamps
5b40: 20 20 20 20 20 3a 20 6f 72 20 27 74 69 6d 65 73 : or 'times
5b50: 74 61 6d 70 73 0a 28 64 65 66 69 6e 65 20 28 63 tamps.(define (c
5b60: 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d 74 6f 2d 6d 65 ommon:sync-to-me
5b70: 67 61 74 65 73 74 2e 64 62 20 64 62 73 74 72 75 gatest.db dbstru
5b80: 63 74 29 20 0a 20 20 28 6c 65 74 20 28 28 73 74 ct) . (let ((st
5b90: 61 72 74 2d 74 69 6d 65 20 20 20 20 20 20 20 20 art-time
5ba0: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
5bb0: 73 29 29 0a 09 28 72 65 73 20 20 20 20 20 20 20 s))..(res
5bc0: 20 20 20 20 20 20 20 20 20 28 64 62 3a 6d 75 6c (db:mul
5bd0: 74 69 2d 64 62 2d 73 79 6e 63 20 64 62 73 74 72 ti-db-sync dbstr
5be0: 75 63 74 20 27 6e 65 77 32 6f 6c 64 29 29 29 0a uct 'new2old))).
5bf0: 20 20 20 20 28 6c 65 74 20 28 28 73 79 6e 63 2d (let ((sync-
5c00: 74 69 6d 65 20 28 2d 20 28 63 75 72 72 65 6e 74 time (- (current
5c10: 2d 73 65 63 6f 6e 64 73 29 20 73 74 61 72 74 2d -seconds) start-
5c20: 74 69 6d 65 29 29 29 0a 20 20 20 20 20 20 28 64 time))). (d
5c30: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
5c40: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
5c50: 6f 72 74 2a 20 22 53 79 6e 63 20 6f 66 20 6e 65 ort* "Sync of ne
5c60: 77 64 62 20 74 6f 20 6f 6c 64 64 62 20 63 6f 6d wdb to olddb com
5c70: 70 6c 65 74 65 64 20 69 6e 20 22 20 73 79 6e 63 pleted in " sync
5c80: 2d 74 69 6d 65 20 22 20 73 65 63 6f 6e 64 73 20 -time " seconds
5c90: 70 69 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 pid="(current-pr
5ca0: 6f 63 65 73 73 2d 69 64 29 29 0a 20 20 20 20 20 ocess-id)).
5cb0: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 (if (common:low
5cc0: 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 30 20 -noise-print 30
5cd0: 22 73 79 6e 63 20 6e 65 77 20 74 6f 20 6f 6c 64 "sync new to old
5ce0: 22 29 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 ").. (debug:pri
5cf0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
5d00: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 53 79 lt-log-port* "Sy
5d10: 6e 63 20 6f 66 20 6e 65 77 64 62 20 74 6f 20 6f nc of newdb to o
5d20: 6c 64 64 62 20 63 6f 6d 70 6c 65 74 65 64 20 69 lddb completed i
5d30: 6e 20 22 20 73 79 6e 63 2d 74 69 6d 65 20 22 20 n " sync-time "
5d40: 73 65 63 6f 6e 64 73 20 70 69 64 3d 22 28 63 75 seconds pid="(cu
5d50: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
5d60: 29 29 29 29 0a 20 20 20 20 72 65 73 29 29 0a 0a )))). res))..
5d70: 0a 0a 0a 28 64 65 66 69 6e 65 20 2a 77 64 6e 75 ...(define *wdnu
5d80: 6d 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 77 m* 0).(define *w
5d90: 64 6e 75 6d 2a 6d 75 74 65 78 20 28 6d 61 6b 65 dnum*mutex (make
5da0: 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 63 75 72 72 -mutex)).;; curr
5db0: 65 6e 74 6c 79 20 74 68 65 20 70 72 69 6d 61 72 ently the primar
5dc0: 79 20 6a 6f 62 20 6f 66 20 74 68 65 20 77 61 74 y job of the wat
5dd0: 63 68 64 6f 67 20 69 73 20 74 6f 20 72 75 6e 20 chdog is to run
5de0: 74 68 65 20 73 79 6e 63 20 62 61 63 6b 20 74 6f the sync back to
5df0: 20 6d 65 67 61 74 65 73 74 2e 64 62 20 66 72 6f megatest.db fro
5e00: 6d 20 74 68 65 20 64 62 20 69 6e 20 2f 74 6d 70 m the db in /tmp
5e10: 0a 3b 3b 20 69 66 20 77 65 20 61 72 65 20 6f 6e .;; if we are on
5e20: 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 61 6e the homehost an
5e30: 64 20 77 65 20 61 72 65 20 61 20 73 65 72 76 65 d we are a serve
5e40: 72 20 28 62 79 20 64 65 66 69 6e 69 74 69 6f 6e r (by definition
5e50: 20 77 65 20 61 72 65 20 6f 6e 20 74 68 65 20 68 we are on the h
5e60: 6f 6d 65 68 6f 73 74 20 69 66 20 77 65 20 61 72 omehost if we ar
5e70: 65 20 61 20 73 65 72 76 65 72 29 0a 3b 3b 0a 0a e a server).;;..
5e80: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
5e90: 3a 72 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 :readonly-watchd
5ea0: 6f 67 20 64 62 73 74 72 75 63 74 29 0a 20 20 28 og dbstruct). (
5eb0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e thread-sleep! 0.
5ec0: 30 35 29 20 3b 3b 20 64 65 6c 61 79 20 66 6f 72 05) ;; delay for
5ed0: 20 73 74 61 72 74 75 70 0a 20 20 28 64 65 62 75 startup. (debu
5ee0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 g:print-info 13
5ef0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
5f00: 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 65 61 64 6f t* "common:reado
5f10: 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 65 6e 74 nly-watchdog ent
5f20: 65 72 65 64 2e 22 29 0a 20 20 3b 3b 20 73 79 6e ered."). ;; syn
5f30: 63 20 6d 65 67 61 74 65 73 74 2e 64 62 20 74 6f c megatest.db to
5f40: 20 2f 74 6d 70 2f 2e 2e 2e 2f 6d 65 67 61 74 73 /tmp/.../megats
5f50: 74 2e 64 62 0a 20 20 28 6c 65 74 2a 20 28 28 73 t.db. (let* ((s
5f60: 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 ync-cool-off-dur
5f70: 61 74 69 6f 6e 20 20 20 33 29 0a 20 20 20 20 20 ation 3).
5f80: 20 20 20 28 67 6f 6c 64 65 6e 2d 6d 74 64 62 20 (golden-mtdb
5f90: 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 (dbr:dbstruc
5fa0: 74 2d 6d 74 64 62 20 64 62 73 74 72 75 63 74 29 t-mtdb dbstruct)
5fb0: 29 0a 20 20 20 20 20 20 20 20 28 67 6f 6c 64 65 ). (golde
5fc0: 6e 2d 6d 74 70 61 74 68 20 20 20 28 64 62 3a 64 n-mtpath (db:d
5fd0: 62 64 61 74 2d 67 65 74 2d 70 61 74 68 20 67 6f bdat-get-path go
5fe0: 6c 64 65 6e 2d 6d 74 64 62 29 29 0a 20 20 20 20 lden-mtdb)).
5ff0: 20 20 20 20 28 74 6d 70 2d 6d 74 64 62 20 20 20 (tmp-mtdb
6000: 20 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 (dbr:dbstru
6010: 63 74 2d 74 6d 70 64 62 20 64 62 73 74 72 75 63 ct-tmpdb dbstruc
6020: 74 29 29 0a 20 20 20 20 20 20 20 20 28 74 6d 70 t)). (tmp
6030: 2d 6d 74 70 61 74 68 20 20 20 20 20 20 28 64 62 -mtpath (db
6040: 3a 64 62 64 61 74 2d 67 65 74 2d 70 61 74 68 20 :dbdat-get-path
6050: 74 6d 70 2d 6d 74 64 62 29 29 29 0a 20 20 20 20 tmp-mtdb))).
6060: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6070: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
6080: 2d 70 6f 72 74 2a 20 22 52 65 61 64 2d 6f 6e 6c -port* "Read-onl
6090: 79 20 70 65 72 69 6f 64 69 63 20 73 79 6e 63 20 y periodic sync
60a0: 74 68 72 65 61 64 20 73 74 61 72 74 65 64 2e 22 thread started."
60b0: 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ). (let loop
60c0: 28 28 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 ((last-sync-time
60d0: 20 30 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 0)). (debu
60e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 g:print-info 13
60f0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6100: 74 2a 20 22 6c 6f 6f 70 20 74 6f 70 20 74 6d 70 t* "loop top tmp
6110: 2d 6d 74 70 61 74 68 3d 22 74 6d 70 2d 6d 74 70 -mtpath="tmp-mtp
6120: 61 74 68 22 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 ath" golden-mtpa
6130: 74 68 3d 22 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 th="golden-mtpat
6140: 68 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 h). (let* (
6150: 28 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 2d (duration-since-
6160: 6c 61 73 74 2d 73 79 6e 63 20 28 2d 20 28 63 75 last-sync (- (cu
6170: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c rrent-seconds) l
6180: 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 29 29 ast-sync-time)))
6190: 0a 20 20 20 20 20 20 20 20 28 64 65 62 75 67 3a . (debug:
61a0: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 print-info 13 *d
61b0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
61c0: 20 22 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 "duration-since
61d0: 2d 6c 61 73 74 2d 73 79 6e 63 3d 22 64 75 72 61 -last-sync="dura
61e0: 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 2d tion-since-last-
61f0: 73 79 6e 63 29 0a 20 20 20 20 20 20 20 20 28 69 sync). (i
6200: 66 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d f (and (not *tim
6210: 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 20 20 20 e-to-exit*).
6220: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3c 20 (<
6230: 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c duration-since-l
6240: 61 73 74 2d 73 79 6e 63 20 73 79 6e 63 2d 63 6f ast-sync sync-co
6250: 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 6f 6e 29 ol-off-duration)
6260: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 74 ). (t
6270: 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2d 20 hread-sleep! (-
6280: 73 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 sync-cool-off-du
6290: 72 61 74 69 6f 6e 20 64 75 72 61 74 69 6f 6e 2d ration duration-
62a0: 73 69 6e 63 65 2d 6c 61 73 74 2d 73 79 6e 63 29 since-last-sync)
62b0: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
62c0: 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 not *time-to-exi
62d0: 74 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 t*).
62e0: 28 6c 65 74 20 28 28 67 6f 6c 64 65 6e 2d 6d 74 (let ((golden-mt
62f0: 64 62 2d 6d 74 69 6d 65 20 28 66 69 6c 65 2d 6d db-mtime (file-m
6300: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
6310: 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 29 29 golden-mtpath))
6320: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6330: 20 20 20 28 74 6d 70 2d 6d 74 64 62 2d 6d 74 69 (tmp-mtdb-mti
6340: 6d 65 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 me (file-modi
6350: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 74 6d fication-time tm
6360: 70 2d 6d 74 70 61 74 68 29 29 29 0a 20 20 20 20 p-mtpath))).
6370: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 28 3e (if (>
6380: 20 67 6f 6c 64 65 6e 2d 6d 74 64 62 2d 6d 74 69 golden-mtdb-mti
6390: 6d 65 20 74 6d 70 2d 6d 74 64 62 2d 6d 74 69 6d me tmp-mtdb-mtim
63a0: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
63b0: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res
63c0: 28 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e (db:multi-db-syn
63d0: 63 20 64 62 73 74 72 75 63 74 20 27 6f 6c 64 32 c dbstruct 'old2
63e0: 6e 65 77 29 29 29 0a 20 20 20 20 20 20 20 20 20 new))).
63f0: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
6400: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 g:print-info 13
6410: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6420: 74 2a 20 22 72 6f 73 79 6e 63 20 63 61 6c 6c 65 t* "rosync calle
6430: 64 2c 20 22 20 72 65 73 20 22 20 72 65 63 6f 72 d, " res " recor
6440: 64 73 20 74 72 61 6e 73 66 65 72 72 65 64 2e 22 ds transferred."
6450: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
6460: 20 20 28 6c 6f 6f 70 20 28 63 75 72 72 65 6e 74 (loop (current
6470: 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 -seconds))).
6480: 20 20 20 20 20 20 20 20 23 74 29 29 29 0a 20 20 #t))).
6490: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
64a0: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
64b0: 6f 67 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e og-port* "Exitin
64c0: 67 20 72 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 g readonly-watch
64d0: 64 6f 67 20 74 69 6d 65 72 2c 20 2a 74 69 6d 65 dog timer, *time
64e0: 2d 74 6f 2d 65 78 69 74 2a 20 3d 20 22 20 2a 74 -to-exit* = " *t
64f0: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 22 20 70 69 ime-to-exit*" pi
6500: 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 d="(current-proc
6510: 65 73 73 2d 69 64 29 22 20 6d 74 70 61 74 68 3d ess-id)" mtpath=
6520: 22 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 29 29 "golden-mtpath))
6530: 29 0a 0a 0a 20 20 20 20 20 20 20 20 0a 28 64 65 )... .(de
6540: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 72 69 fine (common:wri
6550: 74 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 20 64 table-watchdog d
6560: 62 73 74 72 75 63 74 29 0a 20 20 28 74 68 72 65 bstruct). (thre
6570: 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 20 ad-sleep! 0.05)
6580: 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 73 74 61 ;; delay for sta
6590: 72 74 75 70 0a 20 20 28 6c 65 74 20 28 28 6c 65 rtup. (let ((le
65a0: 67 61 63 79 2d 73 79 6e 63 20 28 63 6f 6d 6d 6f gacy-sync (commo
65b0: 6e 3a 72 75 6e 2d 73 79 6e 63 3f 29 29 0a 09 28 n:run-sync?))..(
65c0: 64 65 62 75 67 2d 6d 6f 64 65 20 20 28 64 65 62 debug-mode (deb
65d0: 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 29 ug:debug-mode 1)
65e0: 29 0a 09 28 6c 61 73 74 2d 74 69 6d 65 20 20 20 )..(last-time
65f0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
6600: 29 29 0a 20 20 20 20 20 20 20 20 28 74 68 69 73 )). (this
6610: 2d 77 64 2d 6e 75 6d 20 20 20 20 20 28 62 65 67 -wd-num (beg
6620: 69 6e 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 in (mutex-lock!
6630: 2a 77 64 6e 75 6d 2a 6d 75 74 65 78 29 20 28 6c *wdnum*mutex) (l
6640: 65 74 20 28 28 78 20 2a 77 64 6e 75 6d 2a 29 29 et ((x *wdnum*))
6650: 20 28 73 65 74 21 20 2a 77 64 6e 75 6d 2a 20 28 (set! *wdnum* (
6660: 61 64 64 31 20 2a 77 64 6e 75 6d 2a 29 29 20 28 add1 *wdnum*)) (
6670: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 77 mutex-unlock! *w
6680: 64 6e 75 6d 2a 6d 75 74 65 78 29 20 78 29 29 29 dnum*mutex) x)))
6690: 29 0a 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 ). (debug:pri
66a0: 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 nt-info 2 *defau
66b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 65 lt-log-port* "Pe
66c0: 72 69 6f 64 69 63 20 73 79 6e 63 20 74 68 72 65 riodic sync thre
66d0: 61 64 20 73 74 61 72 74 65 64 2e 22 29 0a 20 20 ad started.").
66e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
66f0: 6e 66 6f 20 33 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 3 *default-l
6700: 6f 67 2d 70 6f 72 74 2a 20 22 77 61 74 63 68 64 og-port* "watchd
6710: 6f 67 20 73 74 61 72 74 69 6e 67 2e 20 6c 65 67 og starting. leg
6720: 61 63 79 2d 73 79 6e 63 20 69 73 20 22 20 6c 65 acy-sync is " le
6730: 67 61 63 79 2d 73 79 6e 63 22 20 70 69 64 3d 22 gacy-sync" pid="
6740: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
6750: 2d 69 64 29 22 20 74 68 69 73 2d 77 64 2d 6e 75 -id)" this-wd-nu
6760: 6d 3d 22 74 68 69 73 2d 77 64 2d 6e 75 6d 29 0a m="this-wd-num).
6770: 20 20 20 20 28 69 66 20 28 61 6e 64 20 6c 65 67 (if (and leg
6780: 61 63 79 2d 73 79 6e 63 20 28 6e 6f 74 20 2a 74 acy-sync (not *t
6790: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 29 0a 09 ime-to-exit*))..
67a0: 28 6c 65 74 2a 20 28 3b 3b 28 64 62 73 74 72 75 (let* (;;(dbstru
67b0: 63 74 20 28 64 62 3a 73 65 74 75 70 29 29 0a 09 ct (db:setup))..
67c0: 20 20 20 20 20 20 20 28 6d 74 64 62 20 20 20 20 (mtdb
67d0: 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 6d (dbr:dbstruct-m
67e0: 74 64 62 20 64 62 73 74 72 75 63 74 29 29 0a 09 tdb dbstruct))..
67f0: 20 20 20 20 20 20 20 28 6d 74 70 61 74 68 20 20 (mtpath
6800: 20 28 64 62 3a 64 62 64 61 74 2d 67 65 74 2d 70 (db:dbdat-get-p
6810: 61 74 68 20 6d 74 64 62 29 29 29 0a 09 20 20 28 ath mtdb))).. (
6820: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6830: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6840: 70 6f 72 74 2a 20 22 53 65 72 76 65 72 20 72 75 port* "Server ru
6850: 6e 6e 69 6e 67 2c 20 70 65 72 69 6f 64 69 63 20 nning, periodic
6860: 73 79 6e 63 20 73 74 61 72 74 65 64 2e 22 29 0a sync started.").
6870: 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 29 0a . (let loop ().
6880: 09 20 20 20 20 3b 3b 20 73 79 6e 63 20 66 6f 72 . ;; sync for
6890: 20 66 69 6c 65 73 79 73 74 65 6d 20 6c 6f 63 61 filesystem loca
68a0: 6c 20 64 62 20 77 72 69 74 65 73 0a 09 20 20 20 l db writes..
68b0: 20 3b 3b 0a 09 20 20 20 20 28 6d 75 74 65 78 2d ;;.. (mutex-
68c0: 6c 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d lock! *db-multi-
68d0: 73 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 sync-mutex*)..
68e0: 20 20 28 6c 65 74 2a 20 28 28 6e 65 65 64 2d 73 (let* ((need-s
68f0: 79 6e 63 20 20 20 20 20 20 20 20 28 3e 3d 20 2a ync (>= *
6900: 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 db-last-access*
6910: 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 29 *db-last-sync*))
6920: 20 3b 3b 20 6e 6f 20 73 79 6e 63 20 73 69 6e 63 ;; no sync sinc
6930: 65 20 6c 61 73 74 20 77 72 69 74 65 0a 09 09 20 e last write...
6940: 20 20 28 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 (sync-in-progr
6950: 65 73 73 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d ess *db-sync-in-
6960: 70 72 6f 67 72 65 73 73 2a 29 0a 09 09 20 20 20 progress*)...
6970: 28 73 68 6f 75 6c 64 2d 73 79 6e 63 20 20 20 20 (should-sync
6980: 20 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 69 6d (and (not *tim
6990: 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 20 20 20 e-to-exit*).
69a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
69c0: 20 20 20 20 20 20 28 3e 20 28 2d 20 28 63 75 72 (> (- (cur
69d0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 2a 64 rent-seconds) *d
69e0: 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 29 20 35 29 b-last-sync*) 5)
69f0: 29 29 20 3b 3b 20 73 79 6e 63 20 65 76 65 72 79 )) ;; sync every
6a00: 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 6d 69 five seconds mi
6a10: 6e 69 6d 75 6d 0a 09 09 20 20 20 28 73 74 61 72 nimum... (star
6a20: 74 2d 74 69 6d 65 20 20 20 20 20 20 20 28 63 75 t-time (cu
6a30: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
6a40: 09 09 20 20 20 28 6d 74 2d 6d 6f 64 2d 74 69 6d .. (mt-mod-tim
6a50: 65 20 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 e (file-mod
6a60: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 6d ification-time m
6a70: 74 70 61 74 68 29 29 0a 09 09 20 20 20 28 72 65 tpath))... (re
6a80: 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 20 20 28 cently-synced (
6a90: 3c 20 28 2d 20 73 74 61 72 74 2d 74 69 6d 65 20 < (- start-time
6aa0: 6d 74 2d 6d 6f 64 2d 74 69 6d 65 29 20 34 29 29 mt-mod-time) 4))
6ab0: 0a 09 09 20 20 20 28 77 69 6c 6c 2d 73 79 6e 63 ... (will-sync
6ac0: 20 20 20 20 20 20 20 20 28 61 6e 64 20 28 6f 72 (and (or
6ad0: 20 6e 65 65 64 2d 73 79 6e 63 20 73 68 6f 75 6c need-sync shoul
6ae0: 64 2d 73 79 6e 63 29 0a 09 09 09 09 09 20 20 28 d-sync)...... (
6af0: 6e 6f 74 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 not sync-in-prog
6b00: 72 65 73 73 29 0a 09 09 09 09 09 20 20 28 6e 6f ress)...... (no
6b10: 74 20 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 t recently-synce
6b20: 64 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 d)))).
6b30: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6b40: 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c -info 13 *defaul
6b50: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 44 20 t-log-port* "WD
6b60: 77 72 69 74 61 62 6c 65 2d 77 61 74 63 68 64 6f writable-watchdo
6b70: 67 20 74 6f 70 20 6f 66 20 6c 6f 6f 70 2e 20 20 g top of loop.
6b80: 6e 65 65 64 2d 73 79 6e 63 3d 22 6e 65 65 64 2d need-sync="need-
6b90: 73 79 6e 63 22 20 73 79 6e 63 2d 69 6e 2d 70 72 sync" sync-in-pr
6ba0: 6f 67 72 65 73 73 3d 22 73 79 6e 63 2d 69 6e 2d ogress="sync-in-
6bb0: 70 72 6f 67 72 65 73 73 22 20 73 68 6f 75 6c 64 progress" should
6bc0: 2d 73 79 6e 63 3d 22 73 68 6f 75 6c 64 2d 73 79 -sync="should-sy
6bd0: 6e 63 22 20 73 74 61 72 74 2d 74 69 6d 65 3d 22 nc" start-time="
6be0: 73 74 61 72 74 2d 74 69 6d 65 22 20 6d 74 2d 6d start-time" mt-m
6bf0: 6f 64 2d 74 69 6d 65 3d 22 6d 74 2d 6d 6f 64 2d od-time="mt-mod-
6c00: 74 69 6d 65 22 20 72 65 63 65 6e 74 6c 79 2d 73 time" recently-s
6c10: 79 6e 63 65 64 3d 22 72 65 63 65 6e 74 6c 79 2d ynced="recently-
6c20: 73 79 6e 63 65 64 22 20 77 69 6c 6c 2d 73 79 6e synced" will-syn
6c30: 63 3d 22 77 69 6c 6c 2d 73 79 6e 63 29 0a 09 20 c="will-sync)..
6c40: 20 20 20 20 20 3b 3b 20 28 69 66 20 72 65 63 65 ;; (if rece
6c50: 6e 74 6c 79 2d 73 79 6e 63 65 64 20 28 64 65 62 ntly-synced (deb
6c60: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
6c70: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6c80: 74 2a 20 22 53 6b 69 70 70 69 6e 67 20 73 79 6e t* "Skipping syn
6c90: 63 20 64 75 65 20 74 6f 20 72 65 63 65 6e 74 6c c due to recentl
6ca0: 79 2d 73 79 6e 63 65 64 20 66 6c 61 67 3d 22 20 y-synced flag="
6cb0: 72 65 63 65 6e 74 6c 79 2d 73 79 6e 63 65 64 29 recently-synced)
6cc0: 29 0a 09 20 20 20 20 20 20 3b 3b 20 28 64 65 62 ).. ;; (deb
6cd0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
6ce0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6cf0: 74 2a 20 22 6e 65 65 64 2d 73 79 6e 63 3a 20 22 t* "need-sync: "
6d00: 20 6e 65 65 64 2d 73 79 6e 63 20 22 20 73 79 6e need-sync " syn
6d10: 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 3a 20 22 c-in-progress: "
6d20: 20 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 sync-in-progres
6d30: 73 20 22 20 73 68 6f 75 6c 64 2d 73 79 6e 63 3a s " should-sync:
6d40: 20 22 20 73 68 6f 75 6c 64 2d 73 79 6e 63 20 22 " should-sync "
6d50: 20 77 69 6c 6c 2d 73 79 6e 63 3a 20 22 20 77 69 will-sync: " wi
6d60: 6c 6c 2d 73 79 6e 63 29 0a 09 20 20 20 20 20 20 ll-sync)..
6d70: 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 20 28 73 (if will-sync (s
6d80: 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d et! *db-sync-in-
6d90: 70 72 6f 67 72 65 73 73 2a 20 23 74 29 29 0a 09 progress* #t))..
6da0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
6db0: 6f 63 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 ock! *db-multi-s
6dc0: 79 6e 63 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 ync-mutex*)..
6dd0: 20 20 20 28 69 66 20 77 69 6c 6c 2d 73 79 6e 63 (if will-sync
6de0: 0a 09 09 20 20 28 6c 65 74 20 28 28 72 65 73 20 ... (let ((res
6df0: 28 63 6f 6d 6d 6f 6e 3a 73 79 6e 63 2d 74 6f 2d (common:sync-to-
6e00: 6d 65 67 61 74 65 73 74 2e 64 62 20 64 62 73 74 megatest.db dbst
6e10: 72 75 63 74 29 29 29 20 3b 3b 20 64 69 64 20 77 ruct))) ;; did w
6e20: 65 20 73 79 6e 63 20 61 6e 79 20 64 61 74 61 3f e sync any data?
6e30: 20 49 66 20 73 6f 20 6e 65 65 64 20 74 6f 20 73 If so need to s
6e40: 65 74 20 74 68 65 20 64 62 20 74 6f 75 63 68 65 et the db touche
6e50: 64 20 66 6c 61 67 20 74 6f 20 6b 65 65 70 20 74 d flag to keep t
6e60: 68 65 20 73 65 72 76 65 72 20 61 6c 69 76 65 0a he server alive.
6e70: 09 09 20 20 20 20 28 69 66 20 28 3e 20 72 65 73 .. (if (> res
6e80: 20 30 29 20 3b 3b 20 73 6f 6d 65 20 72 65 63 6f 0) ;; some reco
6e90: 72 64 73 20 77 65 72 65 20 74 72 61 6e 73 66 65 rds were transfe
6ea0: 72 72 65 64 2c 20 6b 65 65 70 20 74 68 65 20 64 rred, keep the d
6eb0: 62 20 61 6c 69 76 65 0a 09 09 09 28 62 65 67 69 b alive....(begi
6ec0: 6e 0a 09 09 09 20 20 28 6d 75 74 65 78 2d 6c 6f n.... (mutex-lo
6ed0: 63 6b 21 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ck! *heartbeat-m
6ee0: 75 74 65 78 2a 29 0a 09 09 09 20 20 28 73 65 74 utex*).... (set
6ef0: 21 20 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 ! *db-last-acces
6f00: 73 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f s* (current-seco
6f10: 6e 64 73 29 29 0a 09 09 09 20 20 28 6d 75 74 65 nds)).... (mute
6f20: 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 65 61 72 74 x-unlock! *heart
6f30: 62 65 61 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 beat-mutex*)....
6f40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6f50: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
6f60: 6f 67 2d 70 6f 72 74 2a 20 22 73 79 6e 63 20 63 og-port* "sync c
6f70: 61 6c 6c 65 64 2c 20 22 20 72 65 73 20 22 20 72 alled, " res " r
6f80: 65 63 6f 72 64 73 20 74 72 61 6e 73 66 65 72 72 ecords transferr
6f90: 65 64 2e 22 29 29 0a 09 09 09 28 64 65 62 75 67 ed."))....(debug
6fa0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 32 20 2a 64 :print-info 2 *d
6fb0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6fc0: 20 22 73 79 6e 63 20 63 61 6c 6c 65 64 20 62 75 "sync called bu
6fd0: 74 20 7a 65 72 6f 20 72 65 63 6f 72 64 73 20 74 t zero records t
6fe0: 72 61 6e 73 66 65 72 72 65 64 22 29 29 29 29 0a ransferred")))).
6ff0: 09 20 20 20 20 20 20 28 69 66 20 77 69 6c 6c 2d . (if will-
7000: 73 79 6e 63 0a 09 09 20 20 28 62 65 67 69 6e 0a sync... (begin.
7010: 09 09 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 .. (mutex-loc
7020: 6b 21 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e k! *db-multi-syn
7030: 63 2d 6d 75 74 65 78 2a 29 0a 09 09 20 20 20 20 c-mutex*)...
7040: 28 73 65 74 21 20 2a 64 62 2d 73 79 6e 63 2d 69 (set! *db-sync-i
7050: 6e 2d 70 72 6f 67 72 65 73 73 2a 20 23 66 29 0a n-progress* #f).
7060: 09 09 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d .. (set! *db-
7070: 6c 61 73 74 2d 73 79 6e 63 2a 20 73 74 61 72 74 last-sync* start
7080: 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 28 6d 75 -time)... (mu
7090: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d tex-unlock! *db-
70a0: 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 multi-sync-mutex
70b0: 2a 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 *))).. (if
70c0: 28 61 6e 64 20 64 65 62 75 67 2d 6d 6f 64 65 0a (and debug-mode.
70d0: 09 09 20 20 20 20 20 20 20 28 3e 20 28 2d 20 73 .. (> (- s
70e0: 74 61 72 74 2d 74 69 6d 65 20 6c 61 73 74 2d 74 tart-time last-t
70f0: 69 6d 65 29 20 36 30 29 29 0a 09 09 20 20 28 62 ime) 60))... (b
7100: 65 67 69 6e 0a 09 09 20 20 20 20 28 73 65 74 21 egin... (set!
7110: 20 6c 61 73 74 2d 74 69 6d 65 20 73 74 61 72 74 last-time start
7120: 2d 74 69 6d 65 29 0a 09 09 20 20 20 20 28 64 65 -time)... (de
7130: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 bug:print-info 4
7140: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
7150: 72 74 2a 20 22 74 69 6d 65 73 74 61 6d 70 20 2d rt* "timestamp -
7160: 3e 20 22 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 > " (seconds->ti
7170: 6d 65 2d 73 74 72 69 6e 67 20 28 63 75 72 72 65 me-string (curre
7180: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 22 2c 20 nt-seconds)) ",
7190: 74 69 6d 65 20 73 69 6e 63 65 20 73 74 61 72 74 time since start
71a0: 20 2d 3e 20 22 20 28 73 65 63 6f 6e 64 73 2d 3e -> " (seconds->
71b0: 68 72 2d 6d 69 6e 2d 73 65 63 20 28 2d 20 28 63 hr-min-sec (- (c
71c0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
71d0: 2a 74 69 6d 65 2d 7a 65 72 6f 2a 29 29 29 29 29 *time-zero*)))))
71e0: 29 0a 09 20 20 20 20 0a 09 20 20 20 20 3b 3b 20 ).. .. ;;
71f0: 6b 65 65 70 20 67 6f 69 6e 67 20 75 6e 6c 65 73 keep going unles
7200: 73 20 74 69 6d 65 20 74 6f 20 65 78 69 74 0a 09 s time to exit..
7210: 20 20 20 20 3b 3b 0a 09 20 20 20 20 28 69 66 20 ;;.. (if
7220: 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 (not *time-to-ex
7230: 69 74 2a 29 0a 09 09 28 6c 65 74 20 64 65 6c 61 it*)...(let dela
7240: 79 2d 6c 6f 6f 70 20 28 28 63 6f 75 6e 74 20 30 y-loop ((count 0
7250: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7260: 20 20 20 20 20 3b 3b 28 64 65 62 75 67 3a 70 72 ;;(debug:pr
7270: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
7280: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7290: 64 65 6c 61 79 2d 6c 6f 6f 70 20 74 6f 70 3b 20 delay-loop top;
72a0: 63 6f 75 6e 74 3d 22 63 6f 75 6e 74 22 20 70 69 count="count" pi
72b0: 64 3d 22 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 d="(current-proc
72c0: 65 73 73 2d 69 64 29 22 20 74 68 69 73 2d 77 64 ess-id)" this-wd
72d0: 2d 6e 75 6d 3d 22 74 68 69 73 2d 77 64 2d 6e 75 -num="this-wd-nu
72e0: 6d 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 m" *time-to-exit
72f0: 2a 3d 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 *="*time-to-exit
7300: 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 *).
7310: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7320: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7330: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a .
7340: 09 09 20 20 28 69 66 20 28 61 6e 64 20 28 6e 6f .. (if (and (no
7350: 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a t *time-to-exit*
7360: 29 0a 09 09 09 20 20 20 28 3c 20 63 6f 75 6e 74 ).... (< count
7370: 20 34 29 29 20 3b 3b 20 77 61 73 20 31 31 2c 20 4)) ;; was 11,
7380: 63 68 61 6e 67 69 6e 67 20 74 6f 20 34 2e 20 0a changing to 4. .
7390: 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
73a0: 09 09 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 ..(thread-sleep!
73b0: 20 31 29 0a 09 09 09 28 64 65 6c 61 79 2d 6c 6f 1)....(delay-lo
73c0: 6f 70 20 28 2b 20 63 6f 75 6e 74 20 31 29 29 29 op (+ count 1)))
73d0: 29 0a 09 09 20 20 28 69 66 20 28 6e 6f 74 20 2a )... (if (not *
73e0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 20 28 time-to-exit*) (
73f0: 6c 6f 6f 70 29 29 29 29 0a 09 20 20 20 20 28 69 loop)))).. (i
7400: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
7410: 69 73 65 2d 70 72 69 6e 74 20 33 30 29 0a 09 09 ise-print 30)...
7420: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7430: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
7440: 2d 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 -port* "Exiting
7450: 77 61 74 63 68 64 6f 67 20 74 69 6d 65 72 2c 20 watchdog timer,
7460: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3d *time-to-exit* =
7470: 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 " *time-to-exit
7480: 2a 22 20 70 69 64 3d 22 28 63 75 72 72 65 6e 74 *" pid="(current
7490: 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 20 74 68 -process-id)" th
74a0: 69 73 2d 77 64 2d 6e 75 6d 3d 22 74 68 69 73 2d is-wd-num="this-
74b0: 77 64 2d 6e 75 6d 29 29 29 29 29 29 29 0a 0a 3b wd-num)))))))..;
74c0: 3b 20 54 4f 44 4f 3a 20 66 6f 72 20 6d 75 6c 74 ; TODO: for mult
74d0: 69 70 6c 65 20 61 72 65 61 73 2c 20 77 65 20 77 iple areas, we w
74e0: 69 6c 6c 20 68 61 76 65 20 6d 75 6c 74 69 70 6c ill have multipl
74f0: 65 20 77 61 74 63 68 64 6f 67 73 3b 20 61 6e 64 e watchdogs; and
7500: 20 6d 75 6c 74 69 70 6c 65 20 74 68 72 65 61 64 multiple thread
7510: 73 20 74 6f 20 6d 61 6e 61 67 65 0a 28 64 65 66 s to manage.(def
7520: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 74 63 ine (common:watc
7530: 68 64 6f 67 29 0a 20 20 3b 3b 23 74 29 0a 20 20 hdog). ;;#t).
7540: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7550: 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f o 13 *default-lo
7560: 67 2d 70 6f 72 74 2a 20 22 63 6f 6d 6d 6f 6e 3a g-port* "common:
7570: 77 61 74 63 68 64 6f 67 20 65 6e 74 65 72 65 64 watchdog entered
7580: 2e 22 29 0a 0a 20 28 6c 65 74 20 28 28 64 62 73 .").. (let ((dbs
7590: 74 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 29 truct (db:setup)
75a0: 29 29 0a 20 20 20 28 64 65 62 75 67 3a 70 72 69 )). (debug:pri
75b0: 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 nt-info 13 *defa
75c0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 ult-log-port* "a
75d0: 66 74 65 72 20 64 62 3a 73 65 74 75 70 20 77 69 fter db:setup wi
75e0: 74 68 20 64 62 73 74 72 75 63 74 3d 22 64 62 73 th dbstruct="dbs
75f0: 74 72 75 63 74 29 0a 20 20 20 28 63 6f 6e 64 0a truct). (cond.
7600: 20 20 20 20 28 28 64 62 72 3a 64 62 73 74 72 75 ((dbr:dbstru
7610: 63 74 2d 72 65 61 64 2d 6f 6e 6c 79 20 64 62 73 ct-read-only dbs
7620: 74 72 75 63 74 29 0a 20 20 20 20 20 28 64 65 62 truct). (deb
7630: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 ug:print-info 13
7640: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
7650: 72 74 2a 20 22 6c 6f 61 64 69 6e 67 20 72 65 61 rt* "loading rea
7660: 64 2d 6f 6e 6c 79 20 77 61 74 63 68 64 6f 67 22 d-only watchdog"
7670: 29 0a 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 72 ). (common:r
7680: 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 eadonly-watchdog
7690: 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 20 20 dbstruct)).
76a0: 28 65 6c 73 65 0a 20 20 20 20 20 28 64 65 62 75 (else. (debu
76b0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 g:print-info 13
76c0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
76d0: 74 2a 20 22 6c 6f 61 64 69 6e 67 20 77 72 69 74 t* "loading writ
76e0: 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 2e 22 29 able-watchdog.")
76f0: 0a 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 72 . (common:wr
7700: 69 74 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 20 itable-watchdog
7710: 64 62 73 74 72 75 63 74 29 29 29 29 0a 20 28 64 dbstruct)))). (d
7720: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
7730: 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 13 *default-log-
7740: 70 6f 72 74 2a 20 22 77 61 74 63 68 64 6f 67 20 port* "watchdog
7750: 64 6f 6e 65 2e 22 29 3b 3b 29 0a 20 29 0a 0a 0a done.");;). )...
7760: 28 64 65 66 69 6e 65 20 28 73 74 64 2d 65 78 69 (define (std-exi
7770: 74 2d 70 72 6f 63 65 64 75 72 65 29 0a 20 20 28 t-procedure). (
7780: 6f 6e 2d 65 78 69 74 20 28 6c 61 6d 62 64 61 20 on-exit (lambda
7790: 28 29 20 30 29 29 0a 20 20 3b 3b 28 64 65 62 75 () 0)). ;;(debu
77a0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 g:print-info 13
77b0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
77c0: 74 2a 20 22 73 74 64 2d 65 78 69 74 2d 70 72 6f t* "std-exit-pro
77d0: 63 65 64 75 72 65 20 63 61 6c 6c 65 64 3b 20 2a cedure called; *
77e0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 3d 22 2a time-to-exit*="*
77f0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 time-to-exit*).
7800: 20 28 6c 65 74 20 28 28 6e 6f 2d 68 75 72 72 79 (let ((no-hurry
7810: 20 20 28 69 66 20 2a 74 69 6d 65 2d 74 6f 2d 65 (if *time-to-e
7820: 78 69 74 2a 20 3b 3b 20 68 75 72 72 79 20 75 70 xit* ;; hurry up
7830: 0a 09 09 20 20 20 20 20 20 20 23 66 0a 09 09 20 ... #f...
7840: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 (begin....
7850: 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d (set! *time-to-
7860: 65 78 69 74 2a 20 23 74 29 0a 09 09 09 20 23 74 exit* #t).... #t
7870: 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 3a )))). (debug:
7880: 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a 64 65 print-info 4 *de
7890: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
78a0: 22 73 74 61 72 74 69 6e 67 20 65 78 69 74 20 70 "starting exit p
78b0: 72 6f 63 65 73 73 2c 20 66 69 6e 61 6c 69 7a 69 rocess, finalizi
78c0: 6e 67 20 64 61 74 61 62 61 73 65 73 2e 22 29 0a ng databases.").
78d0: 20 20 20 20 28 69 66 20 28 61 6e 64 20 6e 6f 2d (if (and no-
78e0: 68 75 72 72 79 20 28 64 65 62 75 67 3a 64 65 62 hurry (debug:deb
78f0: 75 67 2d 6d 6f 64 65 20 31 38 29 29 0a 09 28 72 ug-mode 18))..(r
7900: 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 61 74 mt:print-db-stat
7910: 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 74 s)). (let ((t
7920: 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 20 h1 (make-thread
7930: 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b 20 74 68 (lambda () ;; th
7940: 72 65 61 64 20 66 6f 72 20 63 6c 65 61 6e 69 6e read for cleanin
7950: 67 20 75 70 2c 20 67 69 76 65 20 69 74 20 66 69 g up, give it fi
7960: 76 65 20 73 65 63 6f 6e 64 73 0a 20 20 20 20 20 ve seconds.
7970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7980: 20 20 20 20 20 20 20 20 20 28 69 66 20 2a 64 62 (if *db
7990: 73 74 72 75 63 74 2d 64 62 2a 20 28 64 62 3a 63 struct-db* (db:c
79a0: 6c 6f 73 65 2d 61 6c 6c 20 2a 64 62 73 74 72 75 lose-all *dbstru
79b0: 63 74 2d 64 62 2a 29 29 20 3b 3b 20 6f 6e 65 20 ct-db*)) ;; one
79c0: 73 65 63 6f 6e 64 20 61 6c 6c 6f 63 61 74 65 64 second allocated
79d0: 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 2a 74 .... (if *t
79e0: 61 73 6b 2d 64 62 2a 20 20 20 20 0a 09 09 09 09 ask-db* .....
79f0: 20 20 28 6c 65 74 20 28 28 64 62 20 28 63 64 72 (let ((db (cdr
7a00: 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 0a 09 09 *task-db*)))...
7a10: 09 09 20 20 20 20 28 69 66 20 28 73 71 6c 69 74 .. (if (sqlit
7a20: 65 33 3a 64 61 74 61 62 61 73 65 3f 20 64 62 29 e3:database? db)
7a30: 0a 09 09 09 09 09 28 62 65 67 69 6e 0a 09 09 09 ......(begin....
7a40: 09 09 20 20 28 73 71 6c 69 74 65 33 3a 69 6e 74 .. (sqlite3:int
7a50: 65 72 72 75 70 74 21 20 64 62 29 0a 09 09 09 09 errupt! db).....
7a60: 09 20 20 28 73 71 6c 69 74 65 33 3a 66 69 6e 61 . (sqlite3:fina
7a70: 6c 69 7a 65 21 20 64 62 20 23 74 29 0a 09 09 09 lize! db #t)....
7a80: 09 09 20 20 3b 3b 20 28 76 65 63 74 6f 72 2d 73 .. ;; (vector-s
7a90: 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 30 20 et! *task-db* 0
7aa0: 23 66 29 0a 09 09 09 09 09 20 20 28 73 65 74 21 #f)...... (set!
7ab0: 20 2a 74 61 73 6b 2d 64 62 2a 20 23 66 29 29 29 *task-db* #f)))
7ac0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
7ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ae0: 20 28 69 66 20 28 61 6e 64 20 2a 72 75 6e 72 65 (if (and *runre
7af0: 6d 6f 74 65 2a 0a 20 20 20 20 20 20 20 20 20 20 mote*.
7b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b10: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 (re
7b20: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 2a 72 75 mote-conndat *ru
7b30: 6e 72 65 6d 6f 74 65 2a 29 29 0a 20 20 20 20 20 nremote*)).
7b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 65 (be
7b60: 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 gin.
7b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b80: 20 20 20 20 20 20 20 20 28 68 74 74 70 2d 63 6c (http-cl
7b90: 69 65 6e 74 23 63 6c 6f 73 65 2d 61 6c 6c 2d 63 ient#close-all-c
7ba0: 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 20 3b onnections!))) ;
7bb0: 3b 20 66 6f 72 20 68 74 74 70 2d 63 6c 69 65 6e ; for http-clien
7bc0: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
7bd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7be0: 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a 64 (if (not (eq? *d
7bf0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
7c00: 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d (current-error-
7c10: 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 20 20 port))).
7c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c30: 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 65 (close
7c40: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 2a 64 65 -output-port *de
7c50: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 29 fault-log-port*)
7c60: 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 21 ).... (set!
7c70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
7c80: 72 74 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 72 rt* (current-err
7c90: 6f 72 2d 70 6f 72 74 29 29 29 20 22 43 6c 65 61 or-port))) "Clea
7ca0: 6e 75 70 20 64 62 20 65 78 69 74 20 74 68 72 65 nup db exit thre
7cb0: 61 64 22 29 29 0a 09 20 20 28 74 68 32 20 28 6d ad")).. (th2 (m
7cc0: 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d 62 ake-thread (lamb
7cd0: 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 28 da ().... (
7ce0: 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 debug:print 4 *d
7cf0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
7d00: 20 22 41 74 74 65 6d 70 74 69 6e 67 20 63 6c 65 "Attempting cle
7d10: 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 20 an exit. Please
7d20: 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 77 be patient and w
7d30: 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e 64 ait a few second
7d40: 73 2e 2e 2e 22 29 0a 09 09 09 20 20 20 20 20 20 s...")....
7d50: 28 69 66 20 6e 6f 2d 68 75 72 72 79 0a 20 20 20 (if no-hurry.
7d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7d80: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
7d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7da0: 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 (threa
7db0: 64 2d 73 6c 65 65 70 21 20 35 29 29 20 3b 3b 20 d-sleep! 5)) ;;
7dc0: 67 69 76 65 20 74 68 65 20 63 6c 65 61 6e 20 75 give the clean u
7dd0: 70 20 66 65 77 20 73 65 63 6f 6e 64 73 20 74 6f p few seconds to
7de0: 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a 20 do it's stuff.
7df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7e10: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 09 09 (begin. ..
7e20: 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 .. (thread-slee
7e30: 70 21 20 32 29 29 29 0a 20 20 20 20 20 20 09 09 p! 2))). ..
7e40: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
7e50: 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c int 4 *default-l
7e60: 6f 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 64 og-port* " ... d
7e70: 6f 6e 65 22 29 0a 20 20 20 20 20 20 09 09 09 20 one"). ...
7e80: 20 20 20 20 20 29 0a 09 09 09 20 20 20 20 22 63 ).... "c
7e90: 6c 65 61 6e 20 65 78 69 74 22 29 29 29 0a 20 20 lean exit"))).
7ea0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
7eb0: 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 28 74 t! th1). (t
7ec0: 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 32 hread-start! th2
7ed0: 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d ). (thread-
7ee0: 6a 6f 69 6e 21 20 74 68 31 29 0a 20 20 20 20 20 join! th1).
7ef0: 20 29 0a 20 20 20 20 29 0a 0a 20 20 30 29 0a 0a ). ).. 0)..
7f00: 28 64 65 66 69 6e 65 20 28 73 74 64 2d 73 69 67 (define (std-sig
7f10: 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 6e nal-handler sign
7f20: 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 6e 61 6c um). ;; (signal
7f30: 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a 20 -mask! signum).
7f40: 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f 2d (set! *time-to-
7f50: 65 78 69 74 2a 20 23 74 29 0a 20 20 3b 3b 28 64 exit* #t). ;;(d
7f60: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
7f70: 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 13 *default-log-
7f80: 70 6f 72 74 2a 20 22 67 6f 74 20 73 69 67 6e 61 port* "got signa
7f90: 6c 20 22 73 69 67 6e 75 6d 29 0a 20 20 28 64 65 l "signum). (de
7fa0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
7fb0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
7fc0: 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 20 73 ort* "Received s
7fd0: 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 22 ignal " signum "
7fe0: 20 65 78 69 74 69 6e 67 20 70 72 6f 6d 70 74 6c exiting promptl
7ff0: 79 22 29 0a 20 20 3b 3b 20 28 73 74 64 2d 65 78 y"). ;; (std-ex
8000: 69 74 2d 70 72 6f 63 65 64 75 72 65 29 20 3b 3b it-procedure) ;;
8010: 20 73 68 6f 75 6c 64 6e 27 74 20 6e 65 65 64 20 shouldn't need
8020: 74 68 69 73 20 73 69 6e 63 65 20 77 65 20 61 72 this since we ar
8030: 65 20 65 78 69 74 69 6e 67 20 61 6e 64 20 69 74 e exiting and it
8040: 20 77 69 6c 6c 20 62 65 20 63 61 6c 6c 65 64 20 will be called
8050: 61 6e 79 77 61 79 0a 20 20 28 65 78 69 74 29 29 anyway. (exit))
8060: 0a 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 ..(set-signal-ha
8070: 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 6e ndler! signal/in
8080: 74 20 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 t std-signal-ha
8090: 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 43 0a 28 73 ndler) ;; ^C.(s
80a0: 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 et-signal-handle
80b0: 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 6d 20 73 r! signal/term s
80c0: 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 td-signal-handle
80d0: 72 29 0a 3b 3b 20 28 73 65 74 2d 73 69 67 6e 61 r).;; (set-signa
80e0: 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 l-handler! signa
80f0: 6c 2f 73 74 6f 70 20 73 74 64 2d 73 69 67 6e 61 l/stop std-signa
8100: 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b 20 5e l-handler) ;; ^
8110: 5a 20 4e 4f 2c 20 64 6f 20 4e 4f 54 20 68 61 6e Z NO, do NOT han
8120: 64 6c 65 20 5e 5a 21 0a 0a 3b 3b 3d 3d 3d 3d 3d dle ^Z!..;;=====
8130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8170: 3d 0a 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 55 =.;; M I S C U
8180: 20 54 20 49 20 4c 20 53 0a 3b 3b 3d 3d 3d 3d 3d T I L S.;;=====
8190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
81d0: 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 73 74 =..;; convert st
81e0: 75 66 66 20 74 6f 20 61 20 6e 75 6d 62 65 72 20 uff to a number
81f0: 69 66 20 70 6f 73 73 69 62 6c 65 0a 28 64 65 66 if possible.(def
8200: 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 ine (any->number
8210: 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 20 0a 20 val). (cond .
8220: 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c 29 ((number? val)
8230: 20 76 61 6c 29 0a 20 20 20 28 28 73 74 72 69 6e val). ((strin
8240: 67 3f 20 76 61 6c 29 20 28 73 74 72 69 6e 67 2d g? val) (string-
8250: 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 20 >number val)).
8260: 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 20 ((symbol? val)
8270: 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 73 79 (any->number (sy
8280: 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 6c mbol->string val
8290: 29 29 29 0a 20 20 20 28 65 6c 73 65 20 23 66 29 ))). (else #f)
82a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 ))..(define (any
82b0: 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 6f 73 73 ->number-if-poss
82c0: 69 62 6c 65 20 76 61 6c 29 0a 20 20 28 6c 65 74 ible val). (let
82d0: 20 28 28 6e 75 6d 20 28 61 6e 79 2d 3e 6e 75 6d ((num (any->num
82e0: 62 65 72 20 76 61 6c 29 29 29 0a 20 20 20 20 28 ber val))). (
82f0: 69 66 20 6e 75 6d 20 6e 75 6d 20 76 61 6c 29 29 if num num val))
8300: 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 74 74 )..(define (patt
8310: 2d 6c 69 73 74 2d 6d 61 74 63 68 20 69 74 65 6d -list-match item
8320: 20 70 61 74 74 73 29 0a 20 20 28 64 65 62 75 67 patts). (debug
8330: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a 64 :print-info 8 *d
8340: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
8350: 20 22 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 "patt-list-matc
8360: 68 20 69 74 65 6d 3d 22 20 69 74 65 6d 20 22 20 h item=" item "
8370: 70 61 74 74 73 3d 22 20 70 61 74 74 73 29 0a 20 patts=" patts).
8380: 20 28 69 66 20 28 61 6e 64 20 69 74 65 6d 20 70 (if (and item p
8390: 61 74 74 73 29 20 20 3b 3b 20 68 65 72 65 20 77 atts) ;; here w
83a0: 65 20 61 72 65 20 66 69 6c 74 65 72 69 6e 67 20 e are filtering
83b0: 66 6f 72 20 6d 61 74 63 68 65 73 20 77 69 74 68 for matches with
83c0: 20 69 74 65 6d 20 70 61 74 74 65 72 6e 73 0a 20 item patterns.
83d0: 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 (let ((res
83e0: 23 66 29 29 20 20 20 3b 3b 20 6c 6f 6f 6b 20 74 #f)) ;; look t
83f0: 68 72 6f 75 67 68 20 61 6c 6c 20 74 68 65 20 69 hrough all the i
8400: 74 65 6d 2d 70 61 74 74 73 20 69 66 20 64 65 66 tem-patts if def
8410: 69 6e 65 64 2c 20 66 6f 72 6d 61 74 20 69 73 20 ined, format is
8420: 70 61 74 74 31 2c 70 61 74 74 32 2c 70 61 74 74 patt1,patt2,patt
8430: 33 20 2e 2e 2e 20 77 69 6c 64 63 61 72 64 20 69 3 ... wildcard i
8440: 73 20 25 0a 09 28 66 6f 72 2d 65 61 63 68 20 0a s %..(for-each .
8450: 09 20 28 6c 61 6d 62 64 61 20 28 70 61 74 74 29 . (lambda (patt)
8460: 0a 09 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 70 .. (let ((modp
8470: 61 74 74 20 28 73 74 72 69 6e 67 2d 73 75 62 73 att (string-subs
8480: 74 69 74 75 74 65 20 22 25 22 20 22 2e 2a 22 20 titute "%" ".*"
8490: 70 61 74 74 20 23 74 29 29 29 0a 09 20 20 20 20 patt #t)))..
84a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
84b0: 66 6f 20 31 30 20 2a 64 65 66 61 75 6c 74 2d 6c fo 10 *default-l
84c0: 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 20 22 og-port* "patt "
84d0: 20 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 20 patt " modpatt
84e0: 22 20 6d 6f 64 70 61 74 74 29 0a 09 20 20 20 20 " modpatt)..
84f0: 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 (if (string-mat
8500: 63 68 20 28 72 65 67 65 78 70 20 6d 6f 64 70 61 ch (regexp modpa
8510: 74 74 29 20 69 74 65 6d 29 0a 09 09 20 28 73 65 tt) item)... (se
8520: 74 21 20 72 65 73 20 23 74 29 29 29 29 0a 09 20 t! res #t))))..
8530: 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 61 (string-split pa
8540: 74 74 73 20 22 2c 22 29 29 0a 09 72 65 73 29 0a tts ","))..res).
8550: 20 20 20 20 20 20 23 74 29 29 0a 0a 3b 3b 20 27 #t))..;; '
8560: 28 70 72 69 6e 74 20 28 73 74 72 69 6e 67 2d 69 (print (string-i
8570: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
8580: 63 61 64 72 20 28 68 61 73 68 2d 74 61 62 6c 65 cadr (hash-table
8590: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 72 65 -ref/default (re
85a0: 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 74 ad-config "megat
85b0: 65 73 74 2e 63 6f 6e 66 69 67 22 20 5c 23 66 20 est.config" \#f
85c0: 5c 23 74 29 20 22 64 69 73 6b 73 22 20 27 22 27 \#t) "disks" '"'
85d0: 22 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 20 "'("none" "")))
85e0: 22 5c 6e 22 29 29 27 0a 28 64 65 66 69 6e 65 20 "\n"))'.(define
85f0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b (common:get-disk
8600: 73 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 s #!key (configf
8610: 20 23 66 29 29 0a 20 20 28 68 61 73 68 2d 74 61 #f)). (hash-ta
8620: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
8630: 0a 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 20 . (or configf
8640: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 (read-config "me
8650: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 23 gatest.config" #
8660: 66 20 23 74 29 29 0a 20 20 20 22 64 69 73 6b 73 f #t)). "disks
8670: 22 20 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 " '("none" "")))
8680: 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 73 ..;; return firs
8690: 74 20 63 6f 6d 6d 61 6e 64 20 74 68 61 74 20 65 t command that e
86a0: 78 69 73 74 73 2c 20 65 6c 73 65 20 23 66 0a 3b xists, else #f.;
86b0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
86c0: 6e 3a 77 68 69 63 68 20 63 6d 64 73 29 0a 20 20 n:which cmds).
86d0: 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 29 (if (null? cmds)
86e0: 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 . #f.
86f0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 (let loop ((hed
8700: 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 20 28 (car cmds))... (
8710: 74 61 6c 20 28 63 64 72 20 63 6d 64 73 29 29 29 tal (cdr cmds)))
8720: 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 77 69 ..(let ((res (wi
8730: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
8740: 70 65 20 28 63 6f 6e 63 20 22 77 68 69 63 68 20 pe (conc "which
8750: 22 20 68 65 64 29 20 72 65 61 64 2d 6c 69 6e 65 " hed) read-line
8760: 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ))).. (if (and
8770: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 (string? res)...
8780: 20 20 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f (file-exists?
8790: 20 72 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 res)).. re
87a0: 73 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 s.. (if (nu
87b0: 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a ll? tal)... #f.
87c0: 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 .. (loop (car t
87d0: 61 6c 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 al)(cdr tal)))))
87e0: 29 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 ))). .(define (
87f0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 common:get-insta
8800: 6c 6c 2d 61 72 65 61 29 0a 20 20 28 6c 65 74 20 ll-area). (let
8810: 28 28 65 78 65 2d 70 61 74 68 20 28 63 61 72 20 ((exe-path (car
8820: 28 61 72 67 76 29 29 29 29 0a 20 20 20 20 28 69 (argv)))). (i
8830: 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 f (file-exists?
8840: 65 78 65 2d 70 61 74 68 29 0a 09 28 63 6f 6d 6d exe-path)..(comm
8850: 6f 6e 3a 64 65 62 75 67 2d 68 61 6e 64 6c 65 2d on:debug-handle-
8860: 65 78 63 65 70 74 69 6f 6e 73 20 23 74 0a 09 20 exceptions #t..
8870: 65 78 6e 0a 09 20 23 66 0a 09 20 28 70 61 74 68 exn.. #f.. (path
8880: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 0a 09 name-directory..
8890: 20 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 (pathname-dire
88a0: 63 74 6f 72 79 20 0a 09 20 20 20 28 70 61 74 68 ctory .. (path
88b0: 6e 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 65 name-directory e
88c0: 78 65 2d 70 61 74 68 29 29 29 29 0a 09 23 66 29 xe-path))))..#f)
88d0: 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 ))..;; return fi
88e0: 72 73 74 20 70 61 74 68 20 74 68 61 74 20 63 61 rst path that ca
88f0: 6e 20 62 65 20 63 72 65 61 74 65 64 20 6f 72 20 n be created or
8900: 61 6c 72 65 61 64 79 20 65 78 69 73 74 73 20 61 already exists a
8910: 6e 64 20 69 73 20 77 72 69 74 61 62 6c 65 0a 3b nd is writable.;
8920: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
8930: 6e 3a 67 65 74 2d 63 72 65 61 74 65 2d 77 72 69 n:get-create-wri
8940: 74 65 61 62 6c 65 2d 64 69 72 20 64 69 72 73 29 teable-dir dirs)
8950: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 69 . (if (null? di
8960: 72 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 rs). #f.
8970: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 (let loop ((h
8980: 65 64 20 28 63 61 72 20 64 69 72 73 29 29 0a 09 ed (car dirs))..
8990: 09 20 28 74 61 6c 20 28 63 64 72 20 64 69 72 73 . (tal (cdr dirs
89a0: 29 29 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 )))..(let ((res
89b0: 28 6f 72 20 28 61 6e 64 20 28 64 69 72 65 63 74 (or (and (direct
89c0: 6f 72 79 3f 20 68 65 64 29 0a 09 09 09 20 20 20 ory? hed)....
89d0: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
89e0: 65 73 73 3f 20 68 65 64 29 0a 09 09 09 20 20 20 ess? hed)....
89f0: 20 68 65 64 29 0a 09 09 20 20 20 20 20 20 20 28 hed)... (
8a00: 63 6f 6d 6d 6f 6e 3a 64 65 62 75 67 2d 68 61 6e common:debug-han
8a10: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 23 dle-exceptions #
8a20: 74 0a 09 09 09 65 78 6e 0a 09 09 09 23 66 0a 09 t....exn....#f..
8a30: 09 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 ..(create-direct
8a40: 6f 72 79 20 68 65 64 20 23 74 29 29 29 29 29 0a ory hed #t))))).
8a50: 09 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 . (if (and (str
8a60: 69 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 28 ing? res)... (
8a70: 64 69 72 65 63 74 6f 72 79 3f 20 72 65 73 29 29 directory? res))
8a80: 0a 09 20 20 20 20 20 20 72 65 73 0a 09 20 20 20 .. res..
8a90: 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 (if (null? ta
8aa0: 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 20 28 6c l)... #f... (l
8ab0: 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 oop (car tal)(cd
8ac0: 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a 0a 3b r tal))))))))..;
8ad0: 3b 20 72 65 74 75 72 6e 20 74 68 65 20 79 6f 75 ; return the you
8ae0: 6e 67 65 73 74 20 74 69 6d 65 73 74 61 6d 70 20 ngest timestamp
8af0: 2e 20 66 69 6c 65 6e 61 6d 65 0a 3b 3b 0a 28 64 . filename.;;.(d
8b00: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
8b10: 74 2d 79 6f 75 6e 67 65 73 74 20 67 6c 6f 62 2d t-youngest glob-
8b20: 6c 69 73 74 29 0a 20 20 28 6c 65 74 20 28 28 61 list). (let ((a
8b30: 6c 6c 2d 66 69 6c 65 73 20 28 61 70 70 6c 79 20 ll-files (apply
8b40: 61 70 70 65 6e 64 0a 09 09 09 20 20 28 6d 61 70 append.... (map
8b50: 20 28 6c 61 6d 62 64 61 20 28 70 61 74 74 29 0a (lambda (patt).
8b60: 09 09 09 09 20 28 63 6f 6d 6d 6f 6e 3a 64 65 62 .... (common:deb
8b70: 75 67 2d 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 ug-handle-except
8b80: 69 6f 6e 73 20 23 74 0a 09 09 09 09 20 20 20 20 ions #t.....
8b90: 20 65 78 6e 0a 09 09 09 09 20 20 20 20 20 27 28 exn..... '(
8ba0: 29 0a 09 09 09 09 20 20 20 28 67 6c 6f 62 20 70 )..... (glob p
8bb0: 61 74 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 att)))....
8bc0: 20 67 6c 6f 62 2d 6c 69 73 74 29 29 29 29 0a 20 glob-list)))).
8bd0: 20 20 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 (fold (lambda
8be0: 20 28 66 6e 61 6d 65 20 72 65 73 29 0a 09 20 20 (fname res)..
8bf0: 20 20 28 6c 65 74 20 28 28 6c 61 73 74 2d 6d 6f (let ((last-mo
8c00: 64 20 28 63 61 72 20 72 65 73 29 29 0a 09 09 20 d (car res))...
8c10: 20 28 63 75 72 6d 6f 64 20 20 20 28 63 6f 6d 6d (curmod (comm
8c20: 6f 6e 3a 64 65 62 75 67 2d 68 61 6e 64 6c 65 2d on:debug-handle-
8c30: 65 78 63 65 70 74 69 6f 6e 73 20 23 74 0a 09 09 exceptions #t...
8c40: 09 09 65 78 6e 0a 09 09 09 09 30 0a 09 09 09 20 ..exn.....0....
8c50: 20 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 (file-modif
8c60: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 6e 61 ication-time fna
8c70: 6d 65 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 me)))).. (i
8c80: 66 20 28 3e 20 63 75 72 6d 6f 64 20 6c 61 73 74 f (> curmod last
8c90: 2d 6d 6f 64 29 0a 09 09 20 20 28 6c 69 73 74 20 -mod)... (list
8ca0: 63 75 72 6d 6f 64 20 66 6e 61 6d 65 29 0a 09 09 curmod fname)...
8cb0: 20 20 72 65 73 29 29 29 0a 09 20 20 27 28 30 20 res))).. '(0
8cc0: 22 6e 2f 61 22 29 0a 09 20 20 61 6c 6c 2d 66 69 "n/a").. all-fi
8cd0: 6c 65 73 29 29 29 0a 0a 3b 3b 20 75 73 65 20 62 les)))..;; use b
8ce0: 61 73 68 20 74 6f 20 65 78 70 61 6e 64 20 61 20 ash to expand a
8cf0: 67 6c 6f 62 2e 20 44 6f 65 73 20 4e 4f 54 20 68 glob. Does NOT h
8d00: 61 6e 64 6c 65 20 70 61 74 68 73 20 77 69 74 68 andle paths with
8d10: 20 73 70 61 63 65 73 21 0a 3b 3b 0a 28 64 65 66 spaces!.;;.(def
8d20: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 62 61 73 68 ine (common:bash
8d30: 2d 67 6c 6f 62 20 69 6e 73 74 72 29 0a 20 20 28 -glob instr). (
8d40: 73 74 72 69 6e 67 2d 73 70 6c 69 74 0a 20 20 20 string-split.
8d50: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
8d60: 2d 70 69 70 65 0a 20 20 20 20 20 20 20 28 63 6f -pipe. (co
8d70: 6e 63 20 22 2f 62 69 6e 2f 62 61 73 68 20 2d 63 nc "/bin/bash -c
8d80: 20 5c 22 65 63 68 6f 20 22 20 69 6e 73 74 72 20 \"echo " instr
8d90: 22 5c 22 22 29 0a 20 20 20 20 20 72 65 61 64 2d "\""). read-
8da0: 6c 69 6e 65 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d line))). .;;===
8db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8dd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8de0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8df0: 3d 3d 3d 0a 3b 3b 20 54 20 41 20 52 20 47 20 45 ===.;; T A R G E
8e00: 20 54 20 53 20 20 2c 20 20 20 53 20 54 20 41 20 T S , S T A
8e10: 54 20 45 20 2c 20 20 20 53 20 54 20 41 20 54 20 T E , S T A T
8e20: 55 20 53 20 2c 20 20 20 0a 3b 3b 20 20 20 20 20 U S , .;;
8e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 52 R
8e40: 20 55 20 4e 20 4e 20 41 20 4d 20 45 20 20 20 20 U N N A M E
8e50: 41 20 4e 20 44 20 20 20 54 20 45 20 53 20 54 20 A N D T E S T
8e60: 50 20 41 20 54 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d P A T T.;;======
8e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8eb0: 0a 0a 3b 3b 20 28 6d 61 70 20 70 72 69 6e 74 20 ..;; (map print
8ec0: 28 6d 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 (map car (hash-t
8ed0: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 28 72 65 61 able->alist (rea
8ee0: 64 2d 63 6f 6e 66 69 67 20 22 72 75 6e 63 6f 6e d-config "runcon
8ef0: 66 69 67 73 2e 63 6f 6e 66 69 67 22 20 23 66 20 figs.config" #f
8f00: 23 74 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e #t)))).;;.(defin
8f10: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 75 e (common:get-ru
8f20: 6e 63 6f 6e 66 69 67 2d 74 61 72 67 65 74 73 20 nconfig-targets
8f30: 23 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 23 #!key (configf #
8f40: 66 29 29 0a 20 20 28 6c 65 74 20 28 28 74 61 72 f)). (let ((tar
8f50: 67 73 20 20 20 20 20 20 20 28 73 6f 72 74 20 28 gs (sort (
8f60: 6d 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 map car (hash-ta
8f70: 62 6c 65 2d 3e 61 6c 69 73 74 0a 09 09 09 09 20 ble->alist.....
8f80: 20 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 20 (or configf
8f90: 3b 3b 20 4e 4f 54 45 3a 20 54 68 65 72 65 20 69 ;; NOTE: There i
8fa0: 73 20 6e 6f 20 76 61 6c 75 65 20 69 6e 20 75 73 s no value in us
8fb0: 69 6e 67 20 72 75 6e 63 6f 6e 66 69 67 3a 72 65 ing runconfig:re
8fc0: 61 64 20 68 65 72 65 2e 0a 09 09 09 09 09 20 28 ad here....... (
8fd0: 72 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e read-config (con
8fe0: 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 c *toppath* "/ru
8ff0: 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 nconfigs.config"
9000: 29 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 )....... #f
9010: 20 23 74 29 0a 09 09 09 09 09 20 28 6d 61 6b 65 #t)...... (make
9020: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a -hash-table)))).
9030: 09 09 09 20 20 20 73 74 72 69 6e 67 3c 3f 29 29 ... string<?))
9040: 0a 09 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 ..(target-patt (
9050: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
9060: 61 72 67 65 74 22 29 29 29 0a 20 20 20 20 28 69 arget"))). (i
9070: 66 20 74 61 72 67 65 74 2d 70 61 74 74 0a 09 28 f target-patt..(
9080: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
9090: 78 29 0a 09 09 20 20 28 70 61 74 74 2d 6c 69 73 x)... (patt-lis
90a0: 74 2d 6d 61 74 63 68 20 78 20 74 61 72 67 65 74 t-match x target
90b0: 2d 70 61 74 74 29 29 0a 09 09 74 61 72 67 73 29 -patt))...targs)
90c0: 0a 09 74 61 72 67 73 29 29 29 0a 0a 3b 3b 20 4c ..targs)))..;; L
90d0: 6f 6f 6b 75 70 20 61 20 76 61 6c 75 65 20 69 6e ookup a value in
90e0: 20 72 75 6e 63 6f 6e 66 69 67 73 20 62 61 73 65 runconfigs base
90f0: 64 20 6f 6e 20 2d 72 65 71 74 61 72 67 20 6f 72 d on -reqtarg or
9100: 20 2d 74 61 72 67 65 74 0a 3b 3b 20 0a 28 64 65 -target.;; .(de
9110: 66 69 6e 65 20 28 72 75 6e 63 6f 6e 66 69 67 73 fine (runconfigs
9120: 2d 67 65 74 20 63 6f 6e 66 69 67 20 76 61 72 29 -get config var)
9130: 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 20 28 . (let ((targ (
9140: 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d common:args-get-
9150: 74 61 72 67 65 74 29 29 29 20 3b 3b 20 28 6f 72 target))) ;; (or
9160: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
9170: 2d 72 65 71 74 61 72 67 22 29 28 61 72 67 73 3a -reqtarg")(args:
9180: 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 get-arg "-target
9190: 22 29 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 ")(getenv "MT_TA
91a0: 52 47 45 54 22 29 29 29 29 0a 20 20 20 20 28 69 RGET")))). (i
91b0: 66 20 74 61 72 67 0a 09 28 6f 72 20 28 63 6f 6e f targ..(or (con
91c0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 figf:lookup conf
91d0: 69 67 20 74 61 72 67 20 76 61 72 29 0a 09 20 20 ig targ var)..
91e0: 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 (configf:looku
91f0: 70 20 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c p config "defaul
9200: 74 22 20 76 61 72 29 29 0a 09 28 63 6f 6e 66 69 t" var))..(confi
9210: 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 gf:lookup config
9220: 20 22 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 "default" var))
9230: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
9240: 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 mon:args-get-sta
9250: 74 65 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a te). (or (args:
9260: 67 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 get-arg "-state"
9270: 29 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 )(args:get-arg "
9280: 3a 73 74 61 74 65 22 29 29 29 0a 0a 28 64 65 66 :state")))..(def
9290: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 ine (common:args
92a0: 2d 67 65 74 2d 73 74 61 74 75 73 29 0a 20 20 28 -get-status). (
92b0: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
92c0: 20 22 2d 73 74 61 74 75 73 22 29 28 61 72 67 73 "-status")(args
92d0: 3a 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 :get-arg ":statu
92e0: 73 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 s")))..(define (
92f0: 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d common:args-get-
9300: 74 65 73 74 70 61 74 74 20 72 63 6f 6e 66 29 0a testpatt rconf).
9310: 20 20 28 6c 65 74 2a 20 28 3b 3b 20 28 74 61 67 (let* (;; (tag
9320: 65 78 70 72 20 20 20 20 20 20 20 28 61 72 67 73 expr (args
9330: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 67 65 78 :get-arg "-tagex
9340: 70 72 22 29 29 0a 20 20 20 20 20 20 20 20 20 3b pr")). ;
9350: 3b 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 ; (tags-testpatt
9360: 20 28 69 66 20 74 61 67 65 78 70 72 20 28 73 74 (if tagexpr (st
9370: 72 69 6e 67 2d 6a 6f 69 6e 20 28 72 75 6e 73 3a ring-join (runs:
9380: 67 65 74 2d 74 65 73 74 73 2d 6d 61 74 63 68 69 get-tests-matchi
9390: 6e 67 2d 74 61 67 73 20 74 61 67 65 78 70 72 29 ng-tags tagexpr)
93a0: 20 22 2c 22 29 20 23 66 29 29 0a 20 20 20 20 20 ",") #f)).
93b0: 20 20 20 20 28 74 65 73 74 70 61 74 74 2d 6b 65 (testpatt-ke
93c0: 79 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 y (if (args:get
93d0: 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 70 61 74 74 -arg "--modepatt
93e0: 22 29 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ") (args:get-arg
93f0: 20 22 2d 2d 6d 6f 64 65 70 61 74 74 22 29 20 22 "--modepatt") "
9400: 54 45 53 54 50 41 54 54 22 29 29 0a 20 20 20 20 TESTPATT")).
9410: 20 20 20 20 20 28 61 72 67 73 2d 74 65 73 74 70 (args-testp
9420: 61 74 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 att (or (args:ge
9430: 74 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 t-arg "-testpatt
9440: 22 29 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 ") (args:get-arg
9450: 20 22 2d 72 75 6e 74 65 73 74 73 22 29 20 22 25 "-runtests") "%
9460: 22 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 74 ")). (rt
9470: 65 73 74 70 61 74 74 20 20 20 20 20 28 69 66 20 estpatt (if
9480: 72 63 6f 6e 66 20 28 72 75 6e 63 6f 6e 66 69 67 rconf (runconfig
9490: 73 2d 67 65 74 20 72 63 6f 6e 66 20 74 65 73 74 s-get rconf test
94a0: 70 61 74 74 2d 6b 65 79 29 20 23 66 29 29 29 0a patt-key) #f))).
94b0: 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 3b (cond. ;
94c0: 3b 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 ; (tags-testpatt
94d0: 0a 20 20 20 20 20 3b 3b 20 20 28 64 65 62 75 67 . ;; (debug
94e0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
94f0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
9500: 20 22 2d 74 61 67 65 78 70 72 20 22 74 61 67 65 "-tagexpr "tage
9510: 78 70 72 22 20 73 65 6c 65 63 74 73 20 74 65 73 xpr" selects tes
9520: 74 70 61 74 74 20 22 74 61 67 73 2d 74 65 73 74 tpatt "tags-test
9530: 70 61 74 74 29 0a 20 20 20 20 20 3b 3b 20 20 74 patt). ;; t
9540: 61 67 73 2d 74 65 73 74 70 61 74 74 29 0a 20 20 ags-testpatt).
9550: 20 20 20 28 28 61 6e 64 20 28 65 71 75 61 6c 3f ((and (equal?
9560: 20 61 72 67 73 2d 74 65 73 74 70 61 74 74 20 22 args-testpatt "
9570: 25 22 29 20 72 74 65 73 74 70 61 74 74 29 0a 20 %") rtestpatt).
9580: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
9590: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
95a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 t-log-port* "tes
95b0: 74 70 61 74 74 20 64 65 66 69 6e 65 64 20 69 6e tpatt defined in
95c0: 20 22 74 65 73 74 70 61 74 74 2d 6b 65 79 22 20 "testpatt-key"
95d0: 66 72 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 3a from runconfigs:
95e0: 20 22 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 " rtestpatt).
95f0: 20 20 20 20 72 74 65 73 74 70 61 74 74 29 0a 20 rtestpatt).
9600: 20 20 20 20 28 65 6c 73 65 20 61 72 67 73 2d 74 (else args-t
9610: 65 73 74 70 61 74 74 29 29 29 29 0a 20 20 20 20 estpatt)))).
9620: 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f .(define (commo
9630: 6e 3a 67 65 74 2d 6c 69 6e 6b 74 72 65 65 29 0a n:get-linktree).
9640: 20 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d (or (getenv "M
9650: 54 5f 4c 49 4e 4b 54 52 45 45 22 29 0a 20 20 20 T_LINKTREE").
9660: 20 20 20 28 69 66 20 2a 63 6f 6e 66 69 67 64 61 (if *configda
9670: 74 2a 0a 09 20 20 28 63 6f 6e 66 69 67 66 3a 6c t*.. (configf:l
9680: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
9690: 2a 20 22 73 65 74 75 70 22 20 22 6c 69 6e 6b 74 * "setup" "linkt
96a0: 72 65 65 22 29 29 29 29 0a 0a 28 64 65 66 69 6e ree"))))..(defin
96b0: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 e (common:args-g
96c0: 65 74 2d 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c et-runname). (l
96d0: 65 74 20 28 28 72 65 73 20 28 6f 72 20 28 61 72 et ((res (or (ar
96e0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
96f0: 6e 61 6d 65 22 29 0a 09 09 20 28 61 72 67 73 3a name")... (args:
9700: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
9710: 65 22 29 0a 09 09 20 28 67 65 74 65 6e 76 20 22 e")... (getenv "
9720: 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 29 29 29 0a MT_RUNNAME")))).
9730: 20 20 20 20 3b 3b 20 28 69 66 20 72 65 73 20 28 ;; (if res (
9740: 73 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d set-environment-
9750: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e variable "MT_RUN
9760: 4e 41 4d 45 22 20 72 65 73 29 29 20 3b 3b 20 6e NAME" res)) ;; n
9770: 6f 74 20 73 75 72 65 20 69 66 20 74 68 69 73 20 ot sure if this
9780: 69 73 20 61 20 67 6f 6f 64 20 69 64 65 61 2e 20 is a good idea.
9790: 73 69 64 65 20 65 66 66 65 63 74 20 61 6e 64 20 side effect and
97a0: 61 6c 6c 20 2e 2e 2e 0a 20 20 20 20 72 65 73 29 all .... res)
97b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
97c0: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 on:args-get-targ
97d0: 65 74 20 23 21 6b 65 79 20 28 73 70 6c 69 74 20 et #!key (split
97e0: 23 66 29 28 65 78 69 74 2d 69 66 2d 62 61 64 20 #f)(exit-if-bad
97f0: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b #f)). (let* ((k
9800: 65 79 73 20 20 20 20 28 69 66 20 28 68 61 73 68 eys (if (hash
9810: 2d 74 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 -table? *configd
9820: 61 74 2a 29 20 28 6b 65 79 73 3a 63 6f 6e 66 69 at*) (keys:confi
9830: 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f g-get-fields *co
9840: 6e 66 69 67 64 61 74 2a 29 20 27 28 29 29 29 0a nfigdat*) '())).
9850: 09 20 28 6e 75 6d 6b 65 79 73 20 28 6c 65 6e 67 . (numkeys (leng
9860: 74 68 20 6b 65 79 73 29 29 0a 09 20 28 74 61 72 th keys)).. (tar
9870: 67 65 74 20 20 28 6f 72 20 28 61 72 67 73 3a 67 get (or (args:g
9880: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
9890: 22 29 0a 09 09 20 20 20 20 20 20 28 61 72 67 73 ")... (args
98a0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
98b0: 74 22 29 0a 09 09 20 20 20 20 20 20 28 67 65 74 t")... (get
98c0: 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 env "MT_TARGET")
98d0: 29 29 0a 09 20 28 74 6c 69 73 74 20 20 20 28 69 )).. (tlist (i
98e0: 66 20 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 f target (string
98f0: 2d 73 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f -split target "/
9900: 22 20 23 74 29 20 27 28 29 29 29 0a 09 20 28 76 " #t) '())).. (v
9910: 61 6c 69 64 20 20 20 28 69 66 20 74 61 72 67 65 alid (if targe
9920: 74 0a 09 09 20 20 20 20 20 20 28 6f 72 20 28 6e t... (or (n
9930: 75 6c 6c 3f 20 6b 65 79 73 29 20 3b 3b 20 70 72 ull? keys) ;; pr
9940: 6f 62 61 62 6c 79 20 64 6f 6e 27 74 20 6b 6e 6f obably don't kno
9950: 77 20 6f 75 72 20 6b 65 79 73 20 79 65 74 0a 09 w our keys yet..
9960: 09 09 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e .. (and (not (n
9970: 75 6c 6c 3f 20 74 6c 69 73 74 29 29 0a 09 09 09 ull? tlist))....
9980: 20 20 20 20 20 20 20 28 65 71 3f 20 6e 75 6d 6b (eq? numk
9990: 65 79 73 20 28 6c 65 6e 67 74 68 20 74 6c 69 73 eys (length tlis
99a0: 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e t)).... (n
99b0: 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 73 74 72 ull? (filter str
99c0: 69 6e 67 2d 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 ing-null? tlist)
99d0: 29 29 29 0a 09 09 20 20 20 20 20 20 23 66 29 29 )))... #f))
99e0: 29 0a 20 20 20 20 28 69 66 20 76 61 6c 69 64 0a ). (if valid.
99f0: 09 28 69 66 20 73 70 6c 69 74 0a 09 20 20 20 20 .(if split..
9a00: 74 6c 69 73 74 0a 09 20 20 20 20 74 61 72 67 65 tlist.. targe
9a10: 74 29 0a 09 28 69 66 20 74 61 72 67 65 74 0a 09 t)..(if target..
9a20: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
9a30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
9a40: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
9a50: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 76 61 6c log-port* "Inval
9a60: 69 64 20 74 61 72 67 65 74 2c 20 73 70 61 63 65 id target, space
9a70: 73 20 6f 72 20 62 6c 61 6e 6b 73 20 6e 6f 74 20 s or blanks not
9a80: 61 6c 6c 6f 77 65 64 20 5c 22 22 20 74 61 72 67 allowed \"" targ
9a90: 65 74 20 22 5c 22 2c 20 74 61 72 67 65 74 20 73 et "\", target s
9aa0: 68 6f 75 6c 64 20 62 65 3a 20 22 20 28 73 74 72 hould be: " (str
9ab0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
9ac0: 6b 65 79 73 20 22 2f 22 29 20 22 2c 20 68 61 76 keys "/") ", hav
9ad0: 65 20 22 20 74 6c 69 73 74 20 22 20 66 6f 72 20 e " tlist " for
9ae0: 65 6c 65 6d 65 6e 74 73 22 29 0a 09 20 20 20 20 elements")..
9af0: 20 20 28 69 66 20 65 78 69 74 2d 69 66 2d 62 61 (if exit-if-ba
9b00: 64 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 d (exit 1))..
9b10: 20 20 20 23 66 29 0a 09 20 20 20 20 23 66 29 29 #f).. #f))
9b20: 29 29 0a 0a 3b 3b 20 6c 6f 67 69 63 20 66 6f 72 ))..;; logic for
9b30: 20 67 65 74 74 69 6e 67 20 68 6f 6d 65 68 6f 73 getting homehos
9b40: 74 2e 20 52 65 74 75 72 6e 73 20 28 68 6f 73 74 t. Returns (host
9b50: 20 2e 20 61 74 2d 68 6f 6d 65 29 0a 3b 3b 20 49 . at-home).;; I
9b60: 46 20 2a 74 6f 70 70 61 74 68 2a 20 69 73 20 6e F *toppath* is n
9b70: 6f 74 20 73 65 74 2c 20 77 61 69 74 20 75 70 20 ot set, wait up
9b80: 74 6f 20 66 69 76 65 20 73 65 63 6f 6e 64 73 20 to five seconds
9b90: 74 72 79 69 6e 67 20 65 76 65 72 79 20 74 77 6f trying every two
9ba0: 20 73 65 63 6f 6e 64 73 0a 3b 3b 20 28 74 68 69 seconds.;; (thi
9bb0: 73 20 69 73 20 74 6f 20 61 63 63 6f 6d 6f 64 61 s is to accomoda
9bc0: 74 65 20 74 68 65 20 77 61 74 63 68 64 6f 67 29 te the watchdog)
9bd0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
9be0: 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mon:get-homehost
9bf0: 20 23 21 6b 65 79 20 28 74 72 79 6e 75 6d 20 35 #!key (trynum 5
9c00: 29 29 0a 20 20 3b 3b 20 63 61 6c 6c 65 64 20 6f )). ;; called o
9c10: 66 74 65 6e 20 65 73 70 65 63 69 61 6c 6c 79 20 ften especially
9c20: 61 74 20 73 74 61 72 74 20 75 70 2e 20 75 73 65 at start up. use
9c30: 20 6d 75 74 65 78 20 74 6f 20 65 6c 69 6d 69 6e mutex to elimin
9c40: 61 74 65 20 63 6f 6c 6c 69 73 69 6f 6e 73 0a 20 ate collisions.
9c50: 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 68 (mutex-lock! *h
9c60: 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a omehost-mutex*).
9c70: 20 20 28 63 6f 6e 64 0a 20 20 20 28 2a 68 6f 6d (cond. (*hom
9c80: 65 2d 68 6f 73 74 2a 0a 20 20 20 20 28 6d 75 74 e-host*. (mut
9c90: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 ex-unlock! *home
9ca0: 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 host-mutex*).
9cb0: 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 29 0a 20 20 *home-host*).
9cc0: 20 28 28 6e 6f 74 20 2a 74 6f 70 70 61 74 68 2a ((not *toppath*
9cd0: 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c ). (mutex-unl
9ce0: 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d ock! *homehost-m
9cf0: 75 74 65 78 2a 29 0a 20 20 20 20 28 6c 61 75 6e utex*). (laun
9d00: 63 68 3a 73 65 74 75 70 29 20 3b 3b 20 73 61 66 ch:setup) ;; saf
9d10: 65 6c 79 20 6d 75 74 65 78 65 64 20 6e 6f 77 0a ely mutexed now.
9d20: 20 20 20 20 28 69 66 20 28 3e 20 74 72 79 6e 75 (if (> trynu
9d30: 6d 20 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 m 0)..(begin..
9d40: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 32 (thread-sleep! 2
9d50: 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 ).. (common:get
9d60: 2d 68 6f 6d 65 68 6f 73 74 20 74 72 79 6e 75 6d -homehost trynum
9d70: 3a 20 28 2d 20 74 72 79 6e 75 6d 20 31 29 29 29 : (- trynum 1)))
9d80: 0a 09 23 66 29 29 0a 20 20 20 28 65 6c 73 65 0a ..#f)). (else.
9d90: 20 20 20 20 28 6c 65 74 2a 20 28 28 63 75 72 72 (let* ((curr
9da0: 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 74 2d 6e host (get-host-n
9db0: 61 6d 65 29 29 0a 09 20 20 20 28 62 65 73 74 61 ame)).. (besta
9dc0: 64 72 73 20 28 73 65 72 76 65 72 3a 67 65 74 2d drs (server:get-
9dd0: 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 65 best-guess-addre
9de0: 73 73 20 63 75 72 72 68 6f 73 74 29 29 0a 09 20 ss currhost))..
9df0: 20 20 3b 3b 20 66 69 72 73 74 20 6c 6f 6f 6b 20 ;; first look
9e00: 69 6e 20 63 6f 6e 66 69 67 2c 20 74 68 65 6e 20 in config, then
9e10: 6c 6f 6f 6b 20 69 6e 20 66 69 6c 65 20 2e 68 6f look in file .ho
9e20: 6d 65 68 6f 73 74 2c 20 63 72 65 61 74 65 20 69 mehost, create i
9e30: 74 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a 09 t if not found..
9e40: 20 20 20 28 68 6f 6d 65 68 6f 73 74 20 28 6f 72 (homehost (or
9e50: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
9e60: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
9e70: 72 76 65 72 22 20 22 68 6f 6d 65 68 6f 73 74 22 rver" "homehost"
9e80: 20 29 0a 09 09 09 20 28 6c 65 74 20 28 28 68 68 ).... (let ((hh
9e90: 66 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 f (conc *toppath
9ea0: 2a 20 22 2f 2e 68 6f 6d 65 68 6f 73 74 22 29 29 * "/.homehost"))
9eb0: 29 0a 09 09 09 20 20 20 28 69 66 20 28 66 69 6c ).... (if (fil
9ec0: 65 2d 65 78 69 73 74 73 3f 20 68 68 66 29 0a 09 e-exists? hhf)..
9ed0: 09 09 20 20 20 20 20 20 20 28 77 69 74 68 2d 69 .. (with-i
9ee0: 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 68 nput-from-file h
9ef0: 68 66 20 72 65 61 64 2d 6c 69 6e 65 29 0a 09 09 hf read-line)...
9f00: 09 20 20 20 20 20 20 20 28 69 66 20 28 66 69 6c . (if (fil
9f10: 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 e-write-access?
9f20: 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 09 09 20 *toppath*).....
9f30: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 (begin.....
9f40: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
9f50: 6f 2d 66 69 6c 65 20 68 68 66 0a 09 09 09 09 20 o-file hhf.....
9f60: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
9f70: 0a 09 09 09 09 09 20 28 70 72 69 6e 74 20 62 65 ...... (print be
9f80: 73 74 61 64 72 73 29 29 29 0a 09 09 09 09 20 20 stadrs))).....
9f90: 20 20 20 28 62 65 67 69 6e 0a 09 09 09 09 20 20 (begin.....
9fa0: 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f (mutex-unlo
9fb0: 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 ck! *homehost-mu
9fc0: 74 65 78 2a 29 0a 09 09 09 09 20 20 20 20 20 20 tex*).....
9fd0: 20 28 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a 67 65 (car (common:ge
9fe0: 74 2d 68 6f 6d 65 68 6f 73 74 29 29 29 29 0a 09 t-homehost))))..
9ff0: 09 09 09 20 20 20 23 66 29 29 29 29 29 0a 09 20 ... #f)))))..
a000: 20 20 28 61 74 2d 68 6f 6d 65 20 20 28 6f 72 20 (at-home (or
a010: 28 65 71 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 (equal? homehost
a020: 20 63 75 72 72 68 6f 73 74 29 0a 09 09 09 20 28 currhost).... (
a030: 65 71 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 equal? homehost
a040: 62 65 73 74 61 64 72 73 29 29 29 29 0a 20 20 20 bestadrs)))).
a050: 20 20 20 28 73 65 74 21 20 2a 68 6f 6d 65 2d 68 (set! *home-h
a060: 6f 73 74 2a 20 28 63 6f 6e 73 20 68 6f 6d 65 68 ost* (cons homeh
a070: 6f 73 74 20 61 74 2d 68 6f 6d 65 29 29 0a 20 20 ost at-home)).
a080: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
a090: 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 k! *homehost-mut
a0a0: 65 78 2a 29 0a 20 20 20 20 20 20 2a 68 6f 6d 65 ex*). *home
a0b0: 2d 68 6f 73 74 2a 29 29 29 29 0a 0a 3b 3b 20 61 -host*))))..;; a
a0c0: 6d 20 49 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 m I on the homeh
a0d0: 6f 73 74 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 ost?.;;.(define
a0e0: 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 (common:on-homeh
a0f0: 6f 73 74 3f 29 0a 20 20 28 6c 65 74 20 28 28 68 ost?). (let ((h
a100: 68 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f h (common:get-ho
a110: 6d 65 68 6f 73 74 29 29 29 0a 20 20 20 20 28 69 mehost))). (i
a120: 66 20 68 68 0a 09 28 63 64 72 20 68 68 29 0a 09 f hh..(cdr hh)..
a130: 23 66 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d #f)))..;;=======
a140: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a150: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
a180: 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 4c 20 49 ;; M I S C L I
a190: 20 53 20 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d S T S.;;=======
a1a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a1b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a1c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
a1d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
a1e0: 0a 3b 3b 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 .;; items in lis
a1f0: 74 61 20 61 72 65 20 6d 61 74 63 68 65 64 20 76 ta are matched v
a200: 61 6c 75 65 20 61 6e 64 20 70 6f 73 69 74 69 6f alue and positio
a210: 6e 20 69 6e 20 6c 69 73 74 62 0a 3b 3b 20 72 65 n in listb.;; re
a220: 74 75 72 6e 20 74 68 65 20 72 65 6d 61 69 6e 69 turn the remaini
a230: 6e 67 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 ng items in list
a240: 62 20 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 b or #f.;;.(defi
a250: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d ne (common:list-
a260: 69 73 2d 73 75 62 6c 69 73 74 20 6c 69 73 74 61 is-sublist lista
a270: 20 6c 69 73 74 62 29 0a 20 20 28 69 66 20 28 6e listb). (if (n
a280: 75 6c 6c 3f 20 6c 69 73 74 61 29 0a 20 20 20 20 ull? lista).
a290: 20 20 6c 69 73 74 62 20 3b 3b 20 61 6c 6c 20 69 listb ;; all i
a2a0: 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 61 72 tems in listb ar
a2b0: 65 20 22 72 65 6d 61 69 6e 69 6e 67 22 0a 20 20 e "remaining".
a2c0: 20 20 20 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 (if (> (leng
a2d0: 74 68 20 6c 69 73 74 61 29 28 6c 65 6e 67 74 68 th lista)(length
a2e0: 20 6c 69 73 74 62 29 29 20 0a 09 20 20 23 66 0a listb)) .. #f.
a2f0: 09 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 . (let loop ((h
a300: 65 64 61 20 28 63 61 72 20 6c 69 73 74 61 29 29 eda (car lista))
a310: 0a 09 09 20 20 20 20 20 28 74 61 6c 61 20 28 63 ... (tala (c
a320: 64 72 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 dr lista))...
a330: 20 20 28 68 65 64 62 20 28 63 61 72 20 6c 69 73 (hedb (car lis
a340: 74 62 29 29 0a 09 09 20 20 20 20 20 28 74 61 6c tb))... (tal
a350: 62 20 28 63 64 72 20 6c 69 73 74 62 29 29 29 0a b (cdr listb))).
a360: 09 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f . (if (equal?
a370: 20 68 65 64 61 20 68 65 64 62 29 0a 09 09 28 69 heda hedb)...(i
a380: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 61 29 20 3b f (null? tala) ;
a390: 3b 20 77 65 20 61 72 65 20 64 6f 6e 65 0a 09 09 ; we are done...
a3a0: 20 20 20 20 74 61 6c 62 0a 09 09 20 20 20 20 28 talb... (
a3b0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 61 29 0a loop (car tala).
a3c0: 09 09 09 20 20 28 63 64 72 20 74 61 6c 61 29 0a ... (cdr tala).
a3d0: 09 09 09 20 20 28 63 61 72 20 74 61 6c 62 29 0a ... (car talb).
a3e0: 09 09 09 20 20 0a 09 09 09 20 20 28 63 64 72 20 ... .... (cdr
a3f0: 74 61 6c 62 29 29 29 0a 09 09 23 66 29 29 29 29 talb)))...#f))))
a400: 29 0a 0a 3b 3b 20 4e 65 65 64 65 64 20 66 6f 72 )..;; Needed for
a410: 20 6c 6f 6e 67 20 6c 69 73 74 73 20 74 6f 20 62 long lists to b
a420: 65 20 73 6f 72 74 65 64 20 77 68 65 72 65 20 28 e sorted where (
a430: 61 70 70 6c 79 20 6d 61 78 20 2e 2e 2e 20 29 20 apply max ... )
a440: 64 69 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 dies.;;.(define
a450: 28 63 6f 6d 6d 6f 6e 3a 6d 61 78 20 69 6e 6c 73 (common:max inls
a460: 74 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 t). (let loop (
a470: 28 6d 61 78 2d 76 61 6c 20 28 63 61 72 20 69 6e (max-val (car in
a480: 6c 73 74 29 29 0a 09 20 20 20 20 20 28 68 65 64 lst)).. (hed
a490: 20 20 20 20 20 28 63 61 72 20 69 6e 6c 73 74 29 (car inlst)
a4a0: 29 0a 09 20 20 20 20 20 28 74 61 6c 20 20 20 20 ).. (tal
a4b0: 20 28 63 64 72 20 69 6e 6c 73 74 29 29 29 0a 20 (cdr inlst))).
a4c0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c (if (not (nul
a4d0: 6c 3f 20 74 61 6c 29 29 0a 09 28 6c 6f 6f 70 20 l? tal))..(loop
a4e0: 28 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c (max hed max-val
a4f0: 29 0a 09 20 20 20 20 20 20 28 63 61 72 20 74 61 ).. (car ta
a500: 6c 29 0a 09 20 20 20 20 20 20 28 63 64 72 20 74 l).. (cdr t
a510: 61 6c 29 29 0a 09 28 6d 61 78 20 68 65 64 20 6d al))..(max hed m
a520: 61 78 2d 76 61 6c 29 29 29 29 0a 0a 3b 3b 20 67 ax-val))))..;; g
a530: 65 74 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 75 et min or max, u
a540: 73 65 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e 64 se > for max and
a550: 20 3c 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 73 < for min, this
a560: 20 77 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 68 works around th
a570: 65 20 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 6c e limits on appl
a580: 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f y.;;.(define (co
a590: 6d 6d 6f 6e 3a 6d 69 6e 2d 6d 61 78 20 63 6f 6d mmon:min-max com
a5a0: 70 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6e 75 p lst). (if (nu
a5b0: 6c 6c 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 23 ll? lst). #
a5c0: 66 20 3b 3b 20 62 65 74 74 65 72 20 74 68 61 6e f ;; better than
a5d0: 20 61 6e 20 65 78 63 65 70 74 69 6f 6e 20 66 6f an exception fo
a5e0: 72 20 6d 79 20 6e 65 65 64 73 0a 20 20 20 20 20 r my needs.
a5f0: 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 (fold (lambda (
a600: 61 20 62 29 0a 09 20 20 20 20 20 20 28 69 66 20 a b).. (if
a610: 28 63 6f 6d 70 20 61 20 62 29 20 61 20 62 29 29 (comp a b) a b))
a620: 0a 09 20 20 20 20 28 63 61 72 20 6c 73 74 29 0a .. (car lst).
a630: 09 20 20 20 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 . lst)))..;;
a640: 67 65 74 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 get min or max,
a650: 75 73 65 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e use > for max an
a660: 64 20 3c 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 d < for min, thi
a670: 73 20 77 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 s works around t
a680: 68 65 20 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 he limits on app
a690: 6c 79 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ly.;;.(define (c
a6a0: 6f 6d 6d 6f 6e 3a 73 75 6d 20 6c 73 74 29 0a 20 ommon:sum lst).
a6b0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 29 (if (null? lst)
a6c0: 0a 20 20 20 20 20 20 30 0a 20 20 20 20 20 20 28 . 0. (
a6d0: 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 20 fold (lambda (a
a6e0: 62 29 0a 09 20 20 20 20 20 20 28 2b 20 61 20 62 b).. (+ a b
a6f0: 29 29 0a 09 20 20 20 20 28 63 61 72 20 6c 73 74 )).. (car lst
a700: 29 0a 09 20 20 20 20 6c 73 74 29 29 29 0a 0a 3b ).. lst)))..;
a710: 3b 20 70 61 74 68 20 6c 69 73 74 20 74 6f 20 68 ; path list to h
a720: 61 73 68 2d 74 61 62 6c 65 20 74 72 65 65 0a 3b ash-table tree.;
a730: 3b 20 20 20 28 28 61 20 62 20 63 29 28 61 20 62 ; ((a b c)(a b
a740: 20 64 29 28 65 20 62 20 63 29 29 20 3d 3e 20 28 d)(e b c)) => (
a750: 28 61 20 28 62 20 28 64 29 20 28 63 29 29 29 20 (a (b (d) (c)))
a760: 28 65 20 28 62 20 28 63 29 29 29 29 0a 3b 3b 0a (e (b (c)))).;;.
a770: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
a780: 6c 69 73 74 2d 3e 68 74 72 65 65 20 6c 73 74 29 list->htree lst)
a790: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 68 20 28 . (let ((resh (
a7a0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
a7b0: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
a7c0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 . (lambda (i
a7d0: 6e 6c 73 74 29 0a 20 20 20 20 20 20 20 28 6c 65 nlst). (le
a7e0: 74 20 6c 6f 6f 70 20 28 28 68 74 20 20 72 65 73 t loop ((ht res
a7f0: 68 29 0a 09 09 20 20 28 68 65 64 20 28 63 61 72 h)... (hed (car
a800: 20 69 6e 6c 73 74 29 29 0a 09 09 20 20 28 74 61 inlst))... (ta
a810: 6c 20 28 63 64 72 20 69 6e 6c 73 74 29 29 29 0a l (cdr inlst))).
a820: 09 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c . (if (hash-tabl
a830: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 68 74 e-ref/default ht
a840: 20 68 65 64 20 23 66 29 0a 09 20 20 20 20 20 28 hed #f).. (
a850: 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 if (not (null? t
a860: 61 6c 29 29 0a 09 09 20 28 6c 6f 6f 70 20 28 68 al))... (loop (h
a870: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 20 68 74 ash-table-ref ht
a880: 20 68 65 64 29 0a 09 09 20 20 20 20 20 20 20 28 hed)... (
a890: 63 61 72 20 74 61 6c 29 0a 09 09 20 20 20 20 20 car tal)...
a8a0: 20 20 28 63 64 72 20 74 61 6c 29 29 29 0a 09 20 (cdr tal)))..
a8b0: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
a8c0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 (hash-table-s
a8d0: 65 74 21 20 68 74 20 68 65 64 20 28 6d 61 6b 65 et! ht hed (make
a8e0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 -hash-table))..
a8f0: 20 20 20 20 20 20 28 6c 6f 6f 70 20 68 74 20 68 (loop ht h
a900: 65 64 20 74 61 6c 29 29 29 29 29 0a 20 20 20 20 ed tal))))).
a910: 20 6c 73 74 29 0a 20 20 20 20 72 65 73 68 29 29 lst). resh))
a920: 0a 0a 3b 3b 20 68 61 73 68 2d 74 61 62 6c 65 20 ..;; hash-table
a930: 74 72 65 65 20 74 6f 20 68 74 6d 6c 20 6c 69 73 tree to html lis
a940: 74 20 74 72 65 65 0a 3b 3b 0a 3b 3b 20 20 20 74 t tree.;;.;; t
a950: 69 70 66 75 6e 63 20 74 61 6b 65 73 20 74 77 6f ipfunc takes two
a960: 20 70 61 72 61 6d 65 74 65 72 73 3a 20 79 20 74 parameters: y t
a970: 68 65 20 74 69 70 20 76 61 6c 75 65 20 61 6e 64 he tip value and
a980: 20 70 61 74 68 20 74 68 65 20 70 61 74 68 20 74 path the path t
a990: 6f 20 74 68 61 74 20 70 6f 69 6e 74 0a 3b 3b 0a o that point.;;.
a9a0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
a9b0: 68 74 72 65 65 2d 3e 68 74 6d 6c 20 68 74 20 70 htree->html ht p
a9c0: 61 74 68 20 74 69 70 66 75 6e 63 29 0a 20 20 28 ath tipfunc). (
a9d0: 6c 65 74 20 28 28 64 61 74 6c 69 73 74 20 09 28 let ((datlist .(
a9e0: 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 6c 65 sort (hash-table
a9f0: 2d 3e 61 6c 69 73 74 20 68 74 29 0a 20 20 20 20 ->alist ht).
aa00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa10: 20 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 (lambd
aa20: 61 20 28 61 20 62 29 0a 20 20 20 20 20 20 20 20 a (a b).
aa30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
aa40: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 3c (string<
aa50: 20 28 63 61 72 20 61 29 28 63 61 72 20 62 29 29 (car a)(car b))
aa60: 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 75 )))). (if (nu
aa70: 6c 6c 3f 20 64 61 74 6c 69 73 74 29 0a 20 20 20 ll? datlist).
aa80: 20 09 28 74 69 70 66 75 6e 63 20 23 66 20 70 61 .(tipfunc #f pa
aa90: 74 68 29 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 th) ;; really sh
aaa0: 6f 75 6c 64 6e 27 74 20 67 65 74 20 68 65 72 65 ouldn't get here
aab0: 0a 09 28 73 3a 75 6c 0a 09 20 28 6d 61 70 20 28 ..(s:ul.. (map (
aac0: 6c 61 6d 62 64 61 20 28 78 29 0a 09 09 28 6c 65 lambda (x)...(le
aad0: 74 2a 20 28 28 6c 65 76 65 6c 6e 61 6d 65 20 28 t* ((levelname (
aae0: 63 61 72 20 78 29 29 0a 09 09 20 20 20 20 20 20 car x))...
aaf0: 20 28 79 20 20 20 20 20 20 20 20 20 28 63 64 72 (y (cdr
ab00: 20 78 29 29 0a 09 09 20 20 20 20 20 20 20 28 6e x))... (n
ab10: 65 77 70 61 74 68 20 20 20 28 61 70 70 65 6e 64 ewpath (append
ab20: 20 70 61 74 68 20 28 6c 69 73 74 20 6c 65 76 65 path (list leve
ab30: 6c 6e 61 6d 65 29 29 29 0a 09 09 20 20 20 20 20 lname)))...
ab40: 20 20 28 6c 65 61 66 20 20 20 20 20 20 28 6f 72 (leaf (or
ab50: 20 28 6e 6f 74 20 28 68 61 73 68 2d 74 61 62 6c (not (hash-tabl
ab60: 65 3f 20 79 29 29 0a 09 09 09 09 20 20 20 20 20 e? y)).....
ab70: 20 28 6e 75 6c 6c 3f 20 28 68 61 73 68 2d 74 61 (null? (hash-ta
ab80: 62 6c 65 2d 6b 65 79 73 20 79 29 29 29 29 29 0a ble-keys y))))).
ab90: 09 09 20 20 28 69 66 20 6c 65 61 66 0a 09 09 20 .. (if leaf...
aba0: 20 20 20 20 20 28 73 3a 6c 69 20 28 74 69 70 66 (s:li (tipf
abb0: 75 6e 63 20 79 20 6e 65 77 70 61 74 68 29 29 0a unc y newpath)).
abc0: 09 09 20 20 20 20 20 20 28 73 3a 6c 69 0a 09 09 .. (s:li...
abd0: 20 20 20 20 20 20 20 28 6c 69 73 74 20 0a 09 09 (list ...
abe0: 09 6c 65 76 65 6c 6e 61 6d 65 0a 09 09 09 28 63 .levelname....(c
abf0: 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d ommon:htree->htm
ac00: 6c 20 79 20 6e 65 77 70 61 74 68 20 74 69 70 66 l y newpath tipf
ac10: 75 6e 63 29 29 29 29 29 29 0a 09 20 20 20 20 20 unc))))))..
ac20: 20 64 61 74 6c 69 73 74 29 29 29 29 29 0a 0a 3b datlist)))))..;
ac30: 3b 20 68 61 73 68 2d 74 61 62 6c 65 20 74 72 65 ; hash-table tre
ac40: 65 20 74 6f 20 61 6c 69 73 74 20 74 72 65 65 0a e to alist tree.
ac50: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
ac60: 6f 6e 3a 68 74 72 65 65 2d 3e 61 74 72 65 65 20 on:htree->atree
ac70: 68 74 29 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 ht). (map (lamb
ac80: 64 61 20 28 78 29 0a 09 20 28 63 6f 6e 73 20 28 da (x).. (cons (
ac90: 63 61 72 20 78 29 0a 09 20 20 20 20 20 20 20 28 car x).. (
aca0: 6c 65 74 20 28 28 79 20 28 63 64 72 20 78 29 29 let ((y (cdr x))
acb0: 29 0a 09 09 20 28 69 66 20 28 68 61 73 68 2d 74 )... (if (hash-t
acc0: 61 62 6c 65 3f 20 79 29 0a 09 09 20 20 20 20 20 able? y)...
acd0: 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 61 (common:htree->a
ace0: 74 72 65 65 20 79 29 0a 09 09 20 20 20 20 20 79 tree y)... y
acf0: 29 29 29 29 0a 20 20 20 20 20 20 20 28 68 61 73 )))). (has
ad00: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 h-table->alist h
ad10: 74 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d t)))..;;========
ad20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ad50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
ad60: 3b 20 4d 20 55 20 4e 20 47 20 45 20 20 20 44 20 ; M U N G E D
ad70: 41 20 54 20 41 20 20 20 49 20 4e 20 54 20 4f 20 A T A I N T O
ad80: 20 20 4e 20 49 20 43 20 45 20 20 20 46 20 4f 20 N I C E F O
ad90: 52 20 4d 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d R M S.;;========
ada0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
adb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
adc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
add0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
ade0: 3b 3b 20 47 65 6e 65 72 61 74 65 20 61 6e 20 69 ;; Generate an i
adf0: 6e 64 65 78 20 66 6f 72 20 61 20 73 70 61 72 73 ndex for a spars
ae00: 65 20 6c 69 73 74 20 6f 66 20 6b 65 79 20 76 61 e list of key va
ae10: 6c 75 65 73 0a 3b 3b 20 20 20 28 20 28 72 6f 77 lues.;; ( (row
ae20: 6e 61 6d 65 31 20 63 6f 6c 6e 61 6d 65 31 20 76 name1 colname1 v
ae30: 61 6c 31 29 28 72 6f 77 6e 61 6d 65 32 20 63 6f al1)(rowname2 co
ae40: 6c 6e 61 6d 65 32 20 76 61 6c 32 29 20 29 0a 3b lname2 val2) ).;
ae50: 3b 0a 3b 3b 20 3d 3e 20 0a 3b 3b 0a 3b 3b 20 20 ;.;; => .;;.;;
ae60: 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 30 29 28 ( (rowname1 0)(
ae70: 72 6f 77 6e 61 6d 65 32 20 31 29 29 20 20 20 20 rowname2 1))
ae80: 3b 3b 20 72 6f 77 6e 61 6d 65 73 20 2d 3e 20 6e ;; rownames -> n
ae90: 75 6d 0a 3b 3b 20 20 20 20 20 28 63 6f 6c 6e 61 um.;; (colna
aea0: 6d 65 31 20 30 29 28 63 6f 6c 6e 61 6d 65 32 20 me1 0)(colname2
aeb0: 31 29 29 20 29 20 20 3b 3b 20 63 6f 6c 6e 61 6d 1)) ) ;; colnam
aec0: 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 0a 3b 3b es -> num.;; .;;
aed0: 20 6f 70 74 69 6f 6e 61 6c 20 61 70 70 6c 79 20 optional apply
aee0: 70 72 6f 63 20 74 6f 20 72 6f 77 6e 75 6d 20 63 proc to rownum c
aef0: 6f 6c 6e 75 6d 20 76 61 6c 75 65 0a 28 64 65 66 olnum value.(def
af00: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 70 61 72 ine (common:spar
af10: 73 65 2d 6c 69 73 74 2d 67 65 6e 65 72 61 74 65 se-list-generate
af20: 2d 69 6e 64 65 78 20 64 61 74 61 20 23 21 6b 65 -index data #!ke
af30: 79 20 28 70 72 6f 63 20 23 66 29 29 0a 20 20 28 y (proc #f)). (
af40: 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 61 29 0a if (null? data).
af50: 20 20 20 20 20 20 28 6c 69 73 74 20 27 28 29 20 (list '()
af60: 27 28 29 29 0a 20 20 20 20 20 20 28 6c 65 74 20 '()). (let
af70: 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 loop ((hed (car
af80: 64 61 74 61 29 29 0a 09 09 20 28 74 61 6c 20 28 data))... (tal (
af90: 63 64 72 20 64 61 74 61 29 29 0a 09 09 20 28 72 cdr data))... (r
afa0: 6f 77 6e 61 6d 65 73 20 27 28 29 29 0a 09 09 20 ownames '())...
afb0: 28 63 6f 6c 6e 61 6d 65 73 20 27 28 29 29 0a 09 (colnames '())..
afc0: 09 20 28 72 6f 77 6e 75 6d 20 20 20 30 29 0a 09 . (rownum 0)..
afd0: 09 20 28 63 6f 6c 6e 75 6d 20 20 20 30 29 29 0a . (colnum 0)).
afe0: 09 28 6c 65 74 2a 20 28 28 72 6f 77 6b 65 79 20 .(let* ((rowkey
aff0: 20 20 20 20 20 20 20 20 20 28 63 61 72 20 20 20 (car
b000: 68 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 63 hed)).. (c
b010: 6f 6c 6b 65 79 20 20 20 20 20 20 20 20 20 20 28 olkey (
b020: 63 61 64 72 20 20 68 65 64 29 29 0a 09 20 20 20 cadr hed))..
b030: 20 20 20 20 28 76 61 6c 75 65 20 20 20 20 20 20 (value
b040: 20 20 20 20 20 28 63 61 64 64 72 20 68 65 64 29 (caddr hed)
b050: 29 0a 09 20 20 20 20 20 20 20 28 65 78 69 73 74 ).. (exist
b060: 69 6e 67 2d 72 6f 77 64 61 74 20 28 61 73 73 6f ing-rowdat (asso
b070: 63 20 72 6f 77 6b 65 79 20 72 6f 77 6e 61 6d 65 c rowkey rowname
b080: 73 29 29 0a 09 20 20 20 20 20 20 20 28 65 78 69 s)).. (exi
b090: 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 28 61 73 sting-coldat (as
b0a0: 73 6f 63 20 63 6f 6c 6b 65 79 20 63 6f 6c 6e 61 soc colkey colna
b0b0: 6d 65 73 29 29 0a 09 20 20 20 20 20 20 20 28 63 mes)).. (c
b0c0: 75 72 72 2d 72 6f 77 6e 75 6d 20 20 20 20 20 28 urr-rownum (
b0d0: 69 66 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 if existing-rowd
b0e0: 61 74 20 72 6f 77 6e 75 6d 20 28 2b 20 72 6f 77 at rownum (+ row
b0f0: 6e 75 6d 20 31 29 29 29 0a 09 20 20 20 20 20 20 num 1)))..
b100: 20 28 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 20 20 (curr-colnum
b110: 20 20 28 69 66 20 65 78 69 73 74 69 6e 67 2d 63 (if existing-c
b120: 6f 6c 64 61 74 20 63 6f 6c 6e 75 6d 20 28 2b 20 oldat colnum (+
b130: 63 6f 6c 6e 75 6d 20 31 29 29 29 0a 09 20 20 20 colnum 1)))..
b140: 20 20 20 20 28 6e 65 77 2d 72 6f 77 6e 61 6d 65 (new-rowname
b150: 73 20 20 20 20 28 69 66 20 65 78 69 73 74 69 6e s (if existin
b160: 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e 61 6d 65 g-rowdat rowname
b170: 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 72 6f s (cons (list ro
b180: 77 6b 65 79 20 63 75 72 72 2d 72 6f 77 6e 75 6d wkey curr-rownum
b190: 29 20 72 6f 77 6e 61 6d 65 73 29 29 29 0a 09 20 ) rownames)))..
b1a0: 20 20 20 20 20 20 28 6e 65 77 2d 63 6f 6c 6e 61 (new-colna
b1b0: 6d 65 73 20 20 20 20 28 69 66 20 65 78 69 73 74 mes (if exist
b1c0: 69 6e 67 2d 63 6f 6c 64 61 74 20 63 6f 6c 6e 61 ing-coldat colna
b1d0: 6d 65 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 mes (cons (list
b1e0: 63 6f 6c 6b 65 79 20 63 75 72 72 2d 63 6f 6c 6e colkey curr-coln
b1f0: 75 6d 29 20 63 6f 6c 6e 61 6d 65 73 29 29 29 29 um) colnames))))
b200: 0a 09 20 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 .. ;; (debug:pr
b210: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
b220: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 ult-log-port* "P
b230: 72 6f 63 65 73 73 69 6e 67 20 72 65 63 6f 72 64 rocessing record
b240: 3a 20 22 20 68 65 64 20 29 0a 09 20 20 28 69 66 : " hed ).. (if
b250: 20 70 72 6f 63 20 28 70 72 6f 63 20 63 75 72 72 proc (proc curr
b260: 2d 72 6f 77 6e 75 6d 20 63 75 72 72 2d 63 6f 6c -rownum curr-col
b270: 6e 75 6d 20 72 6f 77 6b 65 79 20 63 6f 6c 6b 65 num rowkey colke
b280: 79 20 76 61 6c 75 65 29 29 0a 09 20 20 28 69 66 y value)).. (if
b290: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 (null? tal)..
b2a0: 20 20 20 20 28 6c 69 73 74 20 6e 65 77 2d 72 6f (list new-ro
b2b0: 77 6e 61 6d 65 73 20 6e 65 77 2d 63 6f 6c 6e 61 wnames new-colna
b2c0: 6d 65 73 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f mes).. (loo
b2d0: 70 20 28 63 61 72 20 74 61 6c 29 0a 09 09 20 20 p (car tal)...
b2e0: 20 20 28 63 64 72 20 74 61 6c 29 0a 09 09 20 20 (cdr tal)...
b2f0: 20 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 0a 09 new-rownames..
b300: 09 20 20 20 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 . new-colname
b310: 73 0a 09 09 20 20 20 20 28 69 66 20 28 3e 20 63 s... (if (> c
b320: 75 72 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 urr-rownum rownu
b330: 6d 29 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 72 m) curr-rownum r
b340: 6f 77 6e 75 6d 29 0a 09 09 20 20 20 20 28 69 66 ownum)... (if
b350: 20 28 3e 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 (> curr-colnum
b360: 63 6f 6c 6e 75 6d 29 20 63 75 72 72 2d 63 6f 6c colnum) curr-col
b370: 6e 75 6d 20 63 6f 6c 6e 75 6d 29 0a 09 09 20 20 num colnum)...
b380: 20 20 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d ))))))..;;====
b390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3d0: 3d 3d 0a 3b 3b 20 53 20 59 20 53 20 54 20 45 20 ==.;; S Y S T E
b3e0: 4d 20 20 20 53 20 54 20 55 20 46 20 46 0a 3b 3b M S T U F F.;;
b3f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b420: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b430: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6c 61 7a 79 2d ======..;; lazy-
b440: 73 61 66 65 20 67 65 74 20 66 69 6c 65 20 6d 6f safe get file mo
b450: 64 20 74 69 6d 65 2e 20 6f 6e 20 61 6e 79 20 65 d time. on any e
b460: 72 72 6f 72 20 28 66 69 6c 65 20 6e 6f 74 20 65 rror (file not e
b470: 78 69 73 74 69 6e 67 20 65 74 63 2e 29 20 72 65 xisting etc.) re
b480: 74 75 72 6e 20 30 0a 3b 3b 0a 28 64 65 66 69 6e turn 0.;;.(defin
b490: 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d e (common:lazy-m
b4a0: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
b4b0: 20 66 70 61 74 68 29 0a 20 20 28 68 61 6e 64 6c fpath). (handl
b4c0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
b4d0: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 30 0a 20 exn. 0.
b4e0: 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 (file-modific
b4f0: 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 ation-time fpath
b500: 29 29 29 0a 0a 3b 3b 20 66 69 6e 64 20 74 69 6d )))..;; find tim
b510: 65 73 74 61 6d 70 20 6f 66 20 6e 65 77 65 73 74 estamp of newest
b520: 20 66 69 6c 65 20 61 73 73 6f 63 69 61 74 65 64 file associated
b530: 20 77 69 74 68 20 61 20 73 71 6c 69 74 65 20 64 with a sqlite d
b540: 62 20 66 69 6c 65 0a 28 64 65 66 69 6e 65 20 28 b file.(define (
b550: 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 73 71 6c 69 common:lazy-sqli
b560: 74 65 2d 64 62 2d 6d 6f 64 69 66 69 63 61 74 69 te-db-modificati
b570: 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a 20 on-time fpath).
b580: 20 28 6c 65 74 2a 20 28 28 67 6c 6f 62 2d 6c 69 (let* ((glob-li
b590: 73 74 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 st (handle-excep
b5a0: 74 69 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 09 09 tions....exn....
b5b0: 60 28 2c 28 63 6f 6e 63 20 22 2f 6e 6f 2f 73 75 `(,(conc "/no/su
b5c0: 63 68 2f 66 69 6c 65 2c 20 6d 65 73 73 61 67 65 ch/file, message
b5d0: 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d : " ((condition-
b5e0: 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f property-accesso
b5f0: 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 r 'exn 'message)
b600: 20 65 78 6e 29 29 29 0a 09 09 20 20 20 20 20 20 exn)))...
b610: 28 67 6c 6f 62 20 28 63 6f 6e 63 20 66 70 61 74 (glob (conc fpat
b620: 68 20 22 2a 22 29 29 29 29 0a 20 20 20 20 20 20 h "*")))).
b630: 20 20 20 28 66 69 6c 65 2d 6c 69 73 74 20 28 69 (file-list (i
b640: 66 20 28 65 71 3f 20 30 20 28 6c 65 6e 67 74 68 f (eq? 0 (length
b650: 20 67 6c 6f 62 2d 6c 69 73 74 29 29 0a 09 09 09 glob-list))....
b660: 27 28 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 '("/no/such/file
b670: 22 29 0a 09 09 09 67 6c 6f 62 2d 6c 69 73 74 29 ")....glob-list)
b680: 29 29 0a 20 20 28 61 70 70 6c 79 20 6d 61 78 0a )). (apply max.
b690: 20 20 20 28 6d 61 70 0a 20 20 20 20 63 6f 6d 6d (map. comm
b6a0: 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 on:lazy-modifica
b6b0: 74 69 6f 6e 2d 74 69 6d 65 20 0a 20 20 20 20 66 tion-time . f
b6c0: 69 6c 65 2d 6c 69 73 74 29 29 29 29 0a 0a 3b 3b ile-list))))..;;
b6d0: 20 72 65 74 75 72 6e 20 61 20 6e 69 63 65 20 63 return a nice c
b6e0: 6c 65 61 6e 20 70 61 74 68 6e 61 6d 65 20 6d 61 lean pathname ma
b6f0: 64 65 20 61 62 73 6f 6c 75 74 65 0a 28 64 65 66 de absolute.(def
b700: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 ine (common:nice
b710: 2d 70 61 74 68 20 64 69 72 29 0a 20 20 28 6c 65 -path dir). (le
b720: 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
b730: 67 2d 6d 61 74 63 68 20 22 5e 28 7e 5b 5e 5c 5c g-match "^(~[^\\
b740: 2f 5d 2a 29 28 5c 5c 2f 2e 2a 7c 29 24 22 20 64 /]*)(\\/.*|)$" d
b750: 69 72 29 29 29 0a 20 20 20 20 28 69 66 20 6d 61 ir))). (if ma
b760: 74 63 68 20 3b 3b 20 75 73 69 6e 67 20 7e 20 66 tch ;; using ~ f
b770: 6f 72 20 68 6f 6d 65 3f 0a 09 28 63 6f 6d 6d 6f or home?..(commo
b780: 6e 3a 6e 69 63 65 2d 70 61 74 68 20 28 63 6f 6e n:nice-path (con
b790: 63 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c c (common:read-l
b7a0: 69 6e 6b 2d 66 20 28 63 61 64 72 20 6d 61 74 63 ink-f (cadr matc
b7b0: 68 29 29 20 22 2f 22 20 28 63 61 64 64 72 20 6d h)) "/" (caddr m
b7c0: 61 74 63 68 29 29 29 0a 09 28 6e 6f 72 6d 61 6c atch)))..(normal
b7d0: 69 7a 65 2d 70 61 74 68 6e 61 6d 65 20 28 69 66 ize-pathname (if
b7e0: 20 28 61 62 73 6f 6c 75 74 65 2d 70 61 74 68 6e (absolute-pathn
b7f0: 61 6d 65 3f 20 64 69 72 29 0a 09 09 09 09 64 69 ame? dir).....di
b800: 72 0a 09 09 09 09 28 63 6f 6e 63 20 28 63 75 72 r.....(conc (cur
b810: 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 20 rent-directory)
b820: 22 2f 22 20 64 69 72 29 29 29 29 29 29 0a 0a 3b "/" dir))))))..;
b830: 3b 20 6d 61 6b 65 20 22 6e 69 63 65 2d 70 61 74 ; make "nice-pat
b840: 68 22 20 61 76 61 69 6c 61 62 6c 65 20 69 6e 20 h" available in
b850: 63 6f 6e 66 69 67 20 66 69 6c 65 73 20 61 6e 64 config files and
b860: 20 74 68 65 20 72 65 70 6c 0a 28 64 65 66 69 6e the repl.(defin
b870: 65 20 6e 69 63 65 2d 70 61 74 68 20 63 6f 6d 6d e nice-path comm
b880: 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 29 0a 0a 28 on:nice-path)..(
b890: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 define (common:r
b8a0: 65 61 64 2d 6c 69 6e 6b 2d 66 20 70 61 74 68 29 ead-link-f path)
b8b0: 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 64 65 62 75 67 . (common:debug
b8c0: 2d 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f -handle-exceptio
b8d0: 6e 73 20 23 74 0a 20 20 20 20 20 20 65 78 6e 0a ns #t. exn.
b8e0: 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 28 64 (begin..(d
b8f0: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
b900: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
b910: 70 6f 72 74 2a 20 22 63 6f 6d 6d 61 6e 64 20 5c port* "command \
b920: 22 2f 62 69 6e 2f 72 65 61 64 6c 69 6e 6b 20 2d "/bin/readlink -
b930: 66 20 22 20 70 61 74 68 20 22 5c 22 20 66 61 69 f " path "\" fai
b940: 6c 65 64 2e 22 29 0a 09 70 61 74 68 29 20 3b 3b led.")..path) ;;
b950: 20 6a 75 73 74 20 67 69 76 65 20 75 70 0a 20 20 just give up.
b960: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
b970: 6f 6d 2d 70 69 70 65 0a 09 28 63 6f 6e 63 20 22 om-pipe..(conc "
b980: 2f 62 69 6e 2f 72 65 61 64 6c 69 6e 6b 20 2d 66 /bin/readlink -f
b990: 20 22 20 70 61 74 68 29 0a 20 20 20 20 20 20 28 " path). (
b9a0: 6c 61 6d 62 64 61 20 28 29 0a 09 28 72 65 61 64 lambda ()..(read
b9b0: 2d 6c 69 6e 65 29 29 29 29 29 0a 0a 28 64 65 66 -line)))))..(def
b9c0: 69 6e 65 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 ine (get-cpu-loa
b9d0: 64 20 23 21 6b 65 79 20 28 72 65 6d 6f 74 65 2d d #!key (remote-
b9e0: 68 6f 73 74 20 23 66 29 29 0a 20 20 28 63 61 72 host #f)). (car
b9f0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 (common:get-cpu
ba00: 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 -load remote-hos
ba10: 74 29 29 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 t))).;; (let*
ba20: 28 28 6c 6f 61 64 2d 72 65 73 20 28 70 72 6f 63 ((load-res (proc
ba30: 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 ess:cmd-run->lis
ba40: 74 20 22 75 70 74 69 6d 65 22 29 29 0a 3b 3b 20 t "uptime")).;;
ba50: 09 20 28 6c 6f 61 64 2d 72 78 20 20 28 72 65 67 . (load-rx (reg
ba60: 65 78 70 20 22 6c 6f 61 64 20 61 76 65 72 61 67 exp "load averag
ba70: 65 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 22 29 29 0a e:\\s+(\\d+)")).
ba80: 3b 3b 20 09 20 28 63 70 75 2d 6c 6f 61 64 20 23 ;; . (cpu-load #
ba90: 66 29 29 0a 3b 3b 20 20 20 20 20 28 66 6f 72 2d f)).;; (for-
baa0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6c 29 each (lambda (l)
bab0: 0a 3b 3b 20 09 09 28 6c 65 74 20 28 28 6d 61 74 .;; ..(let ((mat
bac0: 63 68 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 ch (string-searc
bad0: 68 20 6c 6f 61 64 2d 72 78 20 6c 29 29 29 0a 3b h load-rx l))).;
bae0: 3b 20 09 09 20 20 28 69 66 20 6d 61 74 63 68 0a ; .. (if match.
baf0: 3b 3b 20 09 09 20 20 20 20 20 20 28 6c 65 74 20 ;; .. (let
bb00: 28 28 6e 65 77 76 61 6c 20 28 73 74 72 69 6e 67 ((newval (string
bb10: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d ->number (cadr m
bb20: 61 74 63 68 29 29 29 29 0a 3b 3b 20 09 09 09 28 atch)))).;; ...(
bb30: 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 if (number? newv
bb40: 61 6c 29 0a 3b 3b 20 09 09 09 20 20 20 20 28 73 al).;; ... (s
bb50: 65 74 21 20 63 70 75 2d 6c 6f 61 64 20 6e 65 77 et! cpu-load new
bb60: 76 61 6c 29 29 29 29 29 29 0a 3b 3b 20 09 20 20 val)))))).;; .
bb70: 20 20 20 20 28 63 61 72 20 6c 6f 61 64 2d 72 65 (car load-re
bb80: 73 29 29 0a 3b 3b 20 20 20 20 20 63 70 75 2d 6c s)).;; cpu-l
bb90: 6f 61 64 29 29 0a 0a 3b 3b 20 67 65 74 20 63 70 oad))..;; get cp
bba0: 75 20 6c 6f 61 64 20 62 79 20 72 65 61 64 69 6e u load by readin
bbb0: 67 20 66 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 g from /proc/loa
bbc0: 64 61 76 67 2c 20 72 65 74 75 72 6e 20 61 6c 6c davg, return all
bbd0: 20 74 68 72 65 65 20 76 61 6c 75 65 73 0a 3b 3b three values.;;
bbe0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
bbf0: 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 :get-cpu-load re
bc00: 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 20 28 69 66 mote-host). (if
bc10: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 remote-host.
bc20: 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 (map (lambda
bc30: 28 72 65 73 29 0a 09 20 20 20 20 20 28 69 66 20 (res).. (if
bc40: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 72 65 73 (eof-object? res
bc50: 29 20 39 65 39 39 20 72 65 73 29 29 0a 09 20 20 ) 9e99 res))..
bc60: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
bc70: 6d 2d 70 69 70 65 20 0a 09 20 20 20 20 28 63 6f m-pipe .. (co
bc80: 6e 63 20 22 73 73 68 20 22 20 72 65 6d 6f 74 65 nc "ssh " remote
bc90: 2d 68 6f 73 74 20 22 20 63 61 74 20 2f 70 72 6f -host " cat /pro
bca0: 63 2f 6c 6f 61 64 61 76 67 22 29 0a 09 20 20 20 c/loadavg")..
bcb0: 20 28 6c 61 6d 62 64 61 20 28 29 28 6c 69 73 74 (lambda ()(list
bcc0: 20 28 72 65 61 64 29 28 72 65 61 64 29 28 72 65 (read)(read)(re
bcd0: 61 64 29 29 29 29 29 0a 20 20 20 20 20 20 28 77 ad))))). (w
bce0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
bcf0: 69 6c 65 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 ile "/proc/loada
bd00: 76 67 22 20 0a 09 28 6c 61 6d 62 64 61 20 28 29 vg" ..(lambda ()
bd10: 28 6c 69 73 74 20 28 72 65 61 64 29 28 72 65 61 (list (read)(rea
bd20: 64 29 28 72 65 61 64 29 29 29 29 29 29 0a 0a 3b d)(read))))))..;
bd30: 3b 20 67 65 74 20 6e 6f 72 6d 61 6c 69 7a 65 64 ; get normalized
bd40: 20 63 70 75 20 6c 6f 61 64 20 62 79 20 72 65 61 cpu load by rea
bd50: 64 69 6e 67 20 66 72 6f 6d 20 2f 70 72 6f 63 2f ding from /proc/
bd60: 6c 6f 61 64 61 76 67 20 61 6e 64 20 2f 70 72 6f loadavg and /pro
bd70: 63 2f 63 70 75 69 6e 66 6f 20 72 65 74 75 72 6e c/cpuinfo return
bd80: 20 61 6c 6c 20 74 68 72 65 65 20 76 61 6c 75 65 all three value
bd90: 73 20 61 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 s and the number
bda0: 20 6f 66 20 72 65 61 6c 20 63 70 75 73 20 61 6e of real cpus an
bdb0: 64 20 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 d the number of
bdc0: 74 68 72 65 61 64 73 0a 3b 3b 20 72 65 74 75 72 threads.;; retur
bdd0: 6e 73 20 61 6c 69 73 74 20 27 28 28 61 64 6a 2d ns alist '((adj-
bde0: 63 70 75 2d 6c 6f 61 64 20 2e 20 6e 6f 72 6d 61 cpu-load . norma
bdf0: 6c 69 7a 65 64 2d 70 72 6f 63 2d 6c 6f 61 64 29 lized-proc-load)
be00: 20 2e 2e 2e 20 65 74 63 2e 0a 3b 3b 20 20 6b 65 ... etc..;; ke
be10: 79 73 3a 20 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 ys: adj-proc-loa
be20: 64 2c 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 d, adj-core-load
be30: 2c 20 31 6d 2d 6c 6f 61 64 2c 20 35 6d 2d 6c 6f , 1m-load, 5m-lo
be40: 61 64 2c 20 31 35 6d 2d 6c 6f 61 64 0a 3b 3b 0a ad, 15m-load.;;.
be50: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
be60: 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 get-normalized-c
be70: 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 pu-load remote-h
be80: 6f 73 74 29 0a 20 20 28 6c 65 74 20 28 28 64 61 ost). (let ((da
be90: 74 61 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f ta (if remote-ho
bea0: 73 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 st.
beb0: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
bec0: 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 -from-pipe .
bed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
bee0: 63 6f 6e 63 20 22 73 73 68 20 22 20 72 65 6d 6f conc "ssh " remo
bef0: 74 65 2d 68 6f 73 74 20 22 20 63 61 74 20 2f 70 te-host " cat /p
bf00: 72 6f 63 2f 6c 6f 61 64 61 76 67 3b 63 61 74 20 roc/loadavg;cat
bf10: 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 3b 65 63 /proc/cpuinfo;ec
bf20: 68 6f 20 65 6e 64 22 29 0a 20 20 20 20 20 20 20 ho end").
bf30: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 61 64 read
bf40: 2d 6c 69 6e 65 73 29 0a 20 20 20 20 20 20 20 20 -lines).
bf50: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 65 6e (appen
bf60: 64 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d .
bf70: 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 (with-inpu
bf80: 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 t-from-file "/pr
bf90: 6f 63 2f 6c 6f 61 64 61 76 67 22 20 0a 20 20 20 oc/loadavg" .
bfa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bfb0: 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 20 20 read-lines).
bfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bfd0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
bfe0: 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 63 70 m-file "/proc/cp
bff0: 75 69 6e 66 6f 22 0a 20 20 20 20 20 20 20 20 20 uinfo".
c000: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 61 64 read
c010: 2d 6c 69 6e 65 73 29 0a 20 20 20 20 20 20 20 20 -lines).
c020: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
c030: 20 22 65 6e 64 22 29 29 29 29 0a 20 20 20 20 20 "end")))).
c040: 20 20 20 28 6c 6f 61 64 2d 72 78 20 20 28 72 65 (load-rx (re
c050: 67 65 78 70 20 22 5e 28 5b 5c 5c 64 5c 5c 2e 5d gexp "^([\\d\\.]
c060: 2b 29 5c 5c 73 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b +)\\s+([\\d\\.]+
c070: 29 5c 5c 73 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 )\\s+([\\d\\.]+)
c080: 5c 5c 73 2b 2e 2a 24 22 29 29 0a 20 20 20 20 20 \\s+.*$")).
c090: 20 20 20 28 70 72 6f 63 2d 72 78 20 20 28 72 65 (proc-rx (re
c0a0: 67 65 78 70 20 22 5e 70 72 6f 63 65 73 73 6f 72 gexp "^processor
c0b0: 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 5c \\s+:\\s+(\\d+)\
c0c0: 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 20 20 20 \s*$")).
c0d0: 28 63 6f 72 65 2d 72 78 20 20 28 72 65 67 65 78 (core-rx (regex
c0e0: 70 20 22 5e 63 6f 72 65 20 69 64 5c 5c 73 2b 3a p "^core id\\s+:
c0f0: 5c 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 \\s+(\\d+)\\s*$"
c100: 29 29 0a 20 20 20 20 20 20 20 20 28 70 68 79 73 )). (phys
c110: 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 70 -rx (regexp "^p
c120: 68 79 73 69 63 61 6c 20 69 64 5c 5c 73 2b 3a 5c hysical id\\s+:\
c130: 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 \s+(\\d+)\\s*$")
c140: 29 0a 20 20 20 20 20 20 20 20 28 6d 61 78 2d 6e ). (max-n
c150: 75 6d 20 20 28 6c 61 6d 62 64 61 20 28 70 20 6e um (lambda (p n
c160: 29 28 6d 61 78 20 28 73 74 72 69 6e 67 2d 3e 6e )(max (string->n
c170: 75 6d 62 65 72 20 70 29 20 6e 29 29 29 29 0a 20 umber p) n)))).
c180: 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 64 61 ;; (print "da
c190: 74 61 3d 22 20 64 61 74 61 29 0a 20 20 20 20 28 ta=" data). (
c1a0: 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 61 29 20 if (null? data)
c1b0: 3b 3b 20 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e ;; something wen
c1c0: 74 20 77 72 6f 6e 67 0a 20 20 20 20 20 20 20 20 t wrong.
c1d0: 23 66 0a 20 20 20 20 20 20 20 20 28 6c 65 74 20 #f. (let
c1e0: 6c 6f 6f 70 20 28 28 68 65 64 20 20 20 20 20 20 loop ((hed
c1f0: 28 63 61 72 20 64 61 74 61 29 29 0a 20 20 20 20 (car data)).
c200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
c210: 74 61 6c 20 20 20 20 20 20 28 63 64 72 20 64 61 tal (cdr da
c220: 74 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ta)).
c230: 20 20 20 20 20 20 20 20 28 6c 6f 61 64 73 20 20 (loads
c240: 20 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 #f).
c250: 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 2d 6e (proc-n
c260: 75 6d 20 30 29 20 20 3b 3b 20 70 72 6f 63 65 73 um 0) ;; proces
c270: 73 6f 72 20 69 6e 63 6c 75 64 65 73 20 74 68 72 sor includes thr
c280: 65 61 64 73 0a 20 20 20 20 20 20 20 20 20 20 20 eads.
c290: 20 20 20 20 20 20 20 20 28 70 68 79 73 2d 6e 75 (phys-nu
c2a0: 6d 20 30 29 20 20 3b 3b 20 70 68 79 73 69 63 61 m 0) ;; physica
c2b0: 6c 20 63 68 69 70 20 6f 6e 20 6d 6f 74 68 65 72 l chip on mother
c2c0: 62 6f 61 72 64 0a 20 20 20 20 20 20 20 20 20 20 board.
c2d0: 20 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d 6e (core-n
c2e0: 75 6d 20 30 29 29 20 3b 3b 20 63 6f 72 65 0a 20 um 0)) ;; core.
c2f0: 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 ;; (pri
c300: 6e 74 20 68 65 64 20 22 2c 20 22 20 6c 6f 61 64 nt hed ", " load
c310: 73 20 22 2c 20 22 20 70 72 6f 63 2d 6e 75 6d 20 s ", " proc-num
c320: 22 2c 20 22 20 70 68 79 73 2d 6e 75 6d 20 22 2c ", " phys-num ",
c330: 20 22 20 63 6f 72 65 2d 6e 75 6d 29 0a 20 20 20 " core-num).
c340: 20 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c (if (null
c350: 3f 20 74 61 6c 29 20 3b 3b 20 68 61 76 65 20 61 ? tal) ;; have a
c360: 6c 6c 20 6f 75 72 20 64 61 74 61 2c 20 63 61 6c ll our data, cal
c370: 63 75 6c 61 74 65 20 6e 6f 72 6d 61 6c 69 7a 65 culate normalize
c380: 64 20 6c 6f 61 64 20 61 6e 64 20 72 65 74 75 72 d load and retur
c390: 6e 20 72 65 73 75 6c 74 0a 20 20 20 20 20 20 20 n result.
c3a0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 61 (let* ((a
c3b0: 63 74 2d 70 72 6f 63 20 28 2b 20 70 72 6f 63 2d ct-proc (+ proc-
c3c0: 6e 75 6d 20 31 29 29 0a 20 20 20 20 20 20 20 20 num 1)).
c3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 63 (ac
c3e0: 74 2d 70 68 79 73 20 28 2b 20 70 68 79 73 2d 6e t-phys (+ phys-n
c3f0: 75 6d 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 um 1)).
c400: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 63 74 (act
c410: 2d 63 6f 72 65 20 28 2b 20 63 6f 72 65 2d 6e 75 -core (+ core-nu
c420: 6d 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 m 1)).
c430: 20 20 20 20 20 20 20 20 20 20 20 28 61 64 6a 2d (adj-
c440: 70 72 6f 63 2d 6c 6f 61 64 20 28 2f 20 28 63 61 proc-load (/ (ca
c450: 72 20 6c 6f 61 64 73 29 20 61 63 74 2d 70 72 6f r loads) act-pro
c460: 63 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 c)).
c470: 20 20 20 20 20 20 20 20 20 28 61 64 6a 2d 63 6f (adj-co
c480: 72 65 2d 6c 6f 61 64 20 28 2f 20 28 63 61 72 20 re-load (/ (car
c490: 6c 6f 61 64 73 29 20 61 63 74 2d 63 6f 72 65 29 loads) act-core)
c4a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
c4b0: 20 20 20 28 61 70 70 65 6e 64 20 28 6c 69 73 74 (append (list
c4c0: 20 28 63 6f 6e 73 20 27 61 64 6a 2d 70 72 6f 63 (cons 'adj-proc
c4d0: 2d 6c 6f 61 64 20 61 64 6a 2d 70 72 6f 63 2d 6c -load adj-proc-l
c4e0: 6f 61 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 oad).
c4f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c500: 20 20 20 28 63 6f 6e 73 20 27 61 64 6a 2d 63 6f (cons 'adj-co
c510: 72 65 2d 6c 6f 61 64 20 61 64 6a 2d 63 6f 72 65 re-load adj-core
c520: 2d 6c 6f 61 64 29 29 0a 20 20 20 20 20 20 20 20 -load)).
c530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c540: 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 31 6d 2d (list (cons '1m-
c550: 6c 6f 61 64 20 28 63 61 72 20 6c 6f 61 64 73 29 load (car loads)
c560: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
c570: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c580: 28 63 6f 6e 73 20 27 35 6d 2d 6c 6f 61 64 20 28 (cons '5m-load (
c590: 63 61 64 72 20 6c 6f 61 64 73 29 29 0a 20 20 20 cadr loads)).
c5a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c5b0: 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 (cons
c5c0: 20 27 31 35 6d 2d 6c 6f 61 64 20 28 63 61 64 64 '15m-load (cadd
c5d0: 72 20 6c 6f 61 64 73 29 29 29 0a 20 20 20 20 20 r loads))).
c5e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c5f0: 20 20 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 (list (cons '
c600: 70 72 6f 63 20 61 63 74 2d 70 72 6f 63 29 0a 20 proc act-proc).
c610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c620: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
c630: 6e 73 20 27 63 6f 72 65 20 61 63 74 2d 63 6f 72 ns 'core act-cor
c640: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
c650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c660: 20 28 63 6f 6e 73 20 27 70 68 79 73 20 61 63 74 (cons 'phys act
c670: 2d 70 68 79 73 29 29 29 29 0a 20 20 20 20 20 20 -phys)))).
c680: 20 20 20 20 20 20 20 20 28 72 65 67 65 78 2d 63 (regex-c
c690: 61 73 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ase.
c6a0: 20 20 20 68 65 64 0a 20 20 20 20 20 20 20 20 20 hed.
c6b0: 20 20 20 20 20 20 28 6c 6f 61 64 2d 72 78 20 20 (load-rx
c6c0: 28 20 78 20 6c 31 20 6c 35 20 6c 31 35 20 29 20 ( x l1 l5 l15 )
c6d0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
c6e0: 63 64 72 20 74 61 6c 29 28 6d 61 70 20 73 74 72 cdr tal)(map str
c6f0: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6c 69 73 ing->number (lis
c700: 74 20 6c 31 20 6c 35 20 6c 31 35 29 29 20 70 72 t l1 l5 l15)) pr
c710: 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 oc-num phys-num
c720: 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 core-num)).
c730: 20 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 2d (proc-
c740: 72 78 20 20 28 20 78 20 70 20 20 20 20 20 20 20 rx ( x p
c750: 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 ) (loop (car t
c760: 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 al)(cdr tal) loa
c770: 64 73 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 ds (ma
c780: 78 2d 6e 75 6d 20 70 20 70 72 6f 63 2d 6e 75 6d x-num p proc-num
c790: 29 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d ) phys-num core-
c7a0: 6e 75 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 num)).
c7b0: 20 20 20 20 20 28 70 68 79 73 2d 72 78 20 20 28 (phys-rx (
c7c0: 20 78 20 70 20 20 20 20 20 20 20 20 20 29 20 28 x p ) (
c7d0: 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 loop (car tal)(c
c7e0: 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 dr tal) loads
c7f0: 20 20 20 20 20 20 20 20 70 72 6f 63 2d 6e 75 6d proc-num
c800: 20 28 6d 61 78 2d 6e 75 6d 20 70 20 70 68 79 73 (max-num p phys
c810: 2d 6e 75 6d 29 20 63 6f 72 65 2d 6e 75 6d 29 29 -num) core-num))
c820: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c830: 28 63 6f 72 65 2d 72 78 20 20 28 20 78 20 63 20 (core-rx ( x c
c840: 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 ) (loop
c850: 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
c860: 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 l) loads
c870: 20 20 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 proc-num phys
c880: 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 6d 20 63 20 -num (max-num c
c890: 63 6f 72 65 2d 6e 75 6d 29 29 29 0a 20 20 20 20 core-num))).
c8a0: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
c8b0: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
c8c0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
c8d0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 ;; (p
c8e0: 72 69 6e 74 20 22 4e 4f 20 4d 41 54 43 48 3a 20 rint "NO MATCH:
c8f0: 22 20 68 65 64 29 0a 20 20 20 20 20 20 20 20 20 " hed).
c900: 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 (loop (
c910: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
c920: 29 20 6c 6f 61 64 73 20 70 72 6f 63 2d 6e 75 6d ) loads proc-num
c930: 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e phys-num core-n
c940: 75 6d 29 29 29 29 29 29 29 29 29 0a 0a 28 64 65 um)))))))))..(de
c950: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 fine (common:uni
c960: 78 2d 70 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 x-ping hostname)
c970: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 73 . (let ((res (s
c980: 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 70 69 6e ystem (conc "pin
c990: 67 20 2d 63 20 31 20 22 20 68 6f 73 74 6e 61 6d g -c 1 " hostnam
c9a0: 65 20 22 20 3e 20 2f 64 65 76 2f 6e 75 6c 6c 22 e " > /dev/null"
c9b0: 29 29 29 29 0a 20 20 20 20 28 65 71 3f 20 72 65 )))). (eq? re
c9c0: 73 20 30 29 29 29 0a 0a 3b 3b 20 69 64 65 61 6c s 0)))..;; ideal
c9d0: 6c 79 20 70 75 74 20 61 6c 6c 20 74 68 69 73 20 ly put all this
c9e0: 69 6e 66 6f 20 69 6e 74 6f 20 74 68 65 20 64 62 info into the db
c9f0: 2c 20 6e 6f 20 6e 65 65 64 20 74 6f 20 70 72 65 , no need to pre
ca00: 73 65 72 76 65 20 69 74 20 61 63 72 6f 73 73 20 serve it across
ca10: 6d 6f 76 69 6e 67 20 68 6f 6d 65 68 6f 73 74 0a moving homehost.
ca20: 3b 3b 0a 3b 3b 20 72 65 74 75 72 6e 20 6c 69 73 ;;.;; return lis
ca30: 74 20 6f 66 0a 3b 3b 20 20 28 20 72 65 61 63 68 t of.;; ( reach
ca40: 61 62 6c 65 3f 20 63 70 75 6c 6f 61 64 20 75 70 able? cpuload up
ca50: 64 61 74 65 2d 74 69 6d 65 20 29 0a 28 64 65 66 date-time ).(def
ca60: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
ca70: 68 6f 73 74 2d 69 6e 66 6f 20 68 6f 73 74 6e 61 host-info hostna
ca80: 6d 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f me). (let* ((lo
ca90: 61 64 69 6e 66 6f 20 28 72 6d 74 3a 67 65 74 2d adinfo (rmt:get-
caa0: 6c 61 74 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 latest-host-load
cab0: 20 68 6f 73 74 6e 61 6d 65 29 29 0a 20 20 20 20 hostname)).
cac0: 20 20 20 20 20 28 6c 6f 61 64 20 28 63 61 72 20 (load (car
cad0: 6c 6f 61 64 69 6e 66 6f 29 29 0a 20 20 20 20 20 loadinfo)).
cae0: 20 20 20 20 28 6c 6f 61 64 2d 73 61 6d 70 6c 65 (load-sample
caf0: 2d 74 69 6d 65 20 28 63 64 72 20 6c 6f 61 64 69 -time (cdr loadi
cb00: 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 nfo)). (
cb10: 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 61 67 65 20 load-sample-age
cb20: 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f (- (current-seco
cb30: 6e 64 73 29 20 6c 6f 61 64 2d 73 61 6d 70 6c 65 nds) load-sample
cb40: 2d 74 69 6d 65 29 29 0a 20 20 20 20 20 20 20 20 -time)).
cb50: 20 28 6c 6f 61 64 69 6e 66 6f 2d 74 69 6d 65 6f (loadinfo-timeo
cb60: 75 74 2d 73 65 63 6f 6e 64 73 20 32 30 29 0a 20 ut-seconds 20).
cb70: 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 (host-la
cb80: 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 st-update-timeou
cb90: 74 2d 73 65 63 6f 6e 64 73 20 31 30 29 0a 20 20 t-seconds 10).
cba0: 20 20 20 20 20 20 20 28 68 6f 73 74 2d 72 65 63 (host-rec
cbb0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 (hash-table-ref
cbc0: 2f 64 65 66 61 75 6c 74 20 2a 68 6f 73 74 2d 6c /default *host-l
cbd0: 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 23 oads* hostname #
cbe0: 66 29 29 0a 20 20 20 20 20 20 20 20 20 29 0a 20 f)). ).
cbf0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
cc00: 3c 20 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 61 67 < load-sample-ag
cc10: 65 20 6c 6f 61 64 69 6e 66 6f 2d 74 69 6d 65 6f e loadinfo-timeo
cc20: 75 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 20 ut-seconds).
cc30: 20 20 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 (list #t.
cc40: 20 20 20 20 20 20 20 6c 6f 61 64 2d 73 61 6d 70 load-samp
cc50: 6c 65 2d 74 69 6d 65 0a 20 20 20 20 20 20 20 20 le-time.
cc60: 20 20 20 20 6c 6f 61 64 29 29 0a 20 20 20 20 20 load)).
cc70: 28 28 61 6e 64 20 68 6f 73 74 2d 72 65 63 0a 20 ((and host-rec.
cc80: 20 20 20 20 20 20 20 20 20 20 28 3c 20 28 63 75 (< (cu
cc90: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 rrent-seconds) (
cca0: 2b 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 + (host-last-upd
ccb0: 61 74 65 20 68 6f 73 74 2d 72 65 63 29 20 68 6f ate host-rec) ho
ccc0: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 st-last-update-t
ccd0: 69 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 73 29 29 imeout-seconds))
cce0: 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 23 74 ). (list #t
ccf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 6f . (ho
cd00: 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 68 st-last-update h
cd10: 6f 73 74 2d 72 65 63 29 0a 20 20 20 20 20 20 20 ost-rec).
cd20: 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d (host-last-
cd30: 63 70 75 6c 6f 61 64 20 68 6f 73 74 2d 72 65 63 cpuload host-rec
cd40: 20 29 29 29 0a 20 20 20 20 20 28 28 63 6f 6d 6d ))). ((comm
cd50: 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 20 68 6f 73 on:unix-ping hos
cd60: 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 28 6c 69 tname). (li
cd70: 73 74 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 st #t.
cd80: 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e (current-secon
cd90: 64 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ds).
cda0: 28 61 6c 69 73 74 2d 72 65 66 20 27 61 64 6a 2d (alist-ref 'adj-
cdb0: 63 6f 72 65 2d 6c 6f 61 64 20 28 63 6f 6d 6d 6f core-load (commo
cdc0: 6e 3a 67 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 n:get-normalized
cdd0: 2d 63 70 75 2d 6c 6f 61 64 20 68 6f 73 74 6e 61 -cpu-load hostna
cde0: 6d 65 29 29 29 29 0a 20 20 20 20 20 28 65 6c 73 me)))). (els
cdf0: 65 0a 20 20 20 20 20 20 28 6c 69 73 74 20 23 66 e. (list #f
ce00: 20 30 20 2d 31 29 29 29 29 29 0a 20 20 20 20 0a 0 -1))))). .
ce10: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
ce20: 75 70 64 61 74 65 2d 68 6f 73 74 2d 6c 6f 61 64 update-host-load
ce30: 73 2d 74 61 62 6c 65 20 68 6f 73 74 73 2d 72 61 s-table hosts-ra
ce40: 77 29 0a 20 20 28 6c 65 74 2a 20 28 28 68 6f 73 w). (let* ((hos
ce50: 74 73 20 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 ts (filter (lamb
ce60: 64 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 da (x).
ce70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce80: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 (string-match (
ce90: 72 65 67 65 78 70 20 22 5e 5c 5c 53 2b 24 22 29 regexp "^\\S+$")
cea0: 20 78 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 x)).
ceb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 6f 73 hos
cec0: 74 73 2d 72 61 77 29 29 29 0a 20 20 20 20 28 66 ts-raw))). (f
ced0: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
cee0: 6d 62 64 61 20 28 68 6f 73 74 6e 61 6d 65 29 0a mbda (hostname).
cef0: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 (let* ((r
cf00: 65 63 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 ec (let ((
cf10: 68 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 h (hash-table-re
cf20: 66 2f 64 65 66 61 75 6c 74 20 2a 68 6f 73 74 2d f/default *host-
cf30: 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 loads* hostname
cf40: 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 #f))).
cf50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf60: 28 69 66 20 68 0a 20 20 20 20 20 20 20 20 20 20 (if h.
cf70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf80: 20 20 20 20 68 0a 20 20 20 20 20 20 20 20 20 20 h.
cf90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfa0: 20 20 20 20 28 6c 65 74 20 28 28 68 20 28 6d 61 (let ((h (ma
cfb0: 6b 65 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 20 ke-host))).
cfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfd0: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
cfe0: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 -table-set! *hos
cff0: 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d t-loads* hostnam
d000: 65 20 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 e h).
d010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d020: 20 20 20 20 20 68 29 29 29 29 0a 20 20 20 20 20 h)))).
d030: 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d 69 (host-i
d040: 6e 66 6f 20 20 20 20 20 20 20 20 20 28 63 6f 6d nfo (com
d050: 6d 6f 6e 3a 67 65 74 2d 68 6f 73 74 2d 69 6e 66 mon:get-host-inf
d060: 6f 20 68 6f 73 74 6e 61 6d 65 29 29 0a 20 20 20 o hostname)).
d070: 20 20 20 20 20 20 20 20 20 20 20 28 69 73 2d 72 (is-r
d080: 65 61 63 68 61 62 6c 65 20 20 20 20 20 20 28 63 eachable (c
d090: 61 72 20 68 6f 73 74 2d 69 6e 66 6f 29 29 0a 20 ar host-info)).
d0a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 61 (la
d0b0: 73 74 2d 72 65 61 63 68 65 64 2d 74 69 6d 65 20 st-reached-time
d0c0: 28 63 61 64 72 20 68 6f 73 74 2d 69 6e 66 6f 29 (cadr host-info)
d0d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d0e0: 28 6c 6f 61 64 20 20 20 20 20 20 20 20 20 20 20 (load
d0f0: 20 20 20 28 63 61 64 64 72 20 68 6f 73 74 2d 69 (caddr host-i
d100: 6e 66 6f 29 29 29 0a 20 20 20 20 20 20 20 20 20 nfo))).
d110: 28 68 6f 73 74 2d 72 65 61 63 68 61 62 6c 65 2d (host-reachable-
d120: 73 65 74 21 20 20 20 20 72 65 63 20 69 73 2d 72 set! rec is-r
d130: 65 61 63 68 61 62 6c 65 29 0a 20 20 20 20 20 20 eachable).
d140: 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 (host-last-up
d150: 64 61 74 65 2d 73 65 74 21 20 20 72 65 63 20 6c date-set! rec l
d160: 61 73 74 2d 72 65 61 63 68 65 64 2d 74 69 6d 65 ast-reached-time
d170: 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 ). (host
d180: 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 64 2d 73 65 -last-cpuload-se
d190: 74 21 20 72 65 63 20 6c 6f 61 64 29 29 29 0a 20 t! rec load))).
d1a0: 20 20 20 20 68 6f 73 74 73 29 29 29 0a 0a 28 64 hosts)))..(d
d1b0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
d1c0: 74 2d 6c 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 t-least-loaded-h
d1d0: 6f 73 74 20 68 6f 73 74 73 2d 72 61 77 29 0a 20 ost hosts-raw).
d1e0: 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 73 20 28 (let* ((hosts (
d1f0: 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 filter (lambda (
d200: 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 x).
d210: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 (st
d220: 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 ring-match (rege
d230: 78 70 20 22 5e 5c 5c 53 2b 24 22 29 20 78 29 29 xp "^\\S+$") x))
d240: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d250: 20 20 20 20 20 20 20 20 20 68 6f 73 74 73 2d 72 hosts-r
d260: 61 77 29 29 0a 20 20 20 20 20 20 20 20 20 28 62 aw)). (b
d270: 65 73 74 2d 68 6f 73 74 20 23 66 29 0a 20 20 20 est-host #f).
d280: 20 20 20 20 20 20 28 62 65 73 74 2d 6c 6f 61 64 (best-load
d290: 20 39 39 39 39 39 29 0a 20 20 20 20 20 20 20 20 99999).
d2a0: 20 28 63 75 72 72 2d 74 69 6d 65 20 28 63 75 72 (curr-time (cur
d2b0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a rent-seconds))).
d2c0: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 (common:upda
d2d0: 74 65 2d 68 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 te-host-loads-ta
d2e0: 62 6c 65 20 68 6f 73 74 73 29 0a 20 20 20 20 28 ble hosts). (
d2f0: 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c for-each. (l
d300: 61 6d 62 64 61 20 28 68 6f 73 74 6e 61 6d 65 29 ambda (hostname)
d310: 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 . (let* ((
d320: 72 65 63 0a 20 20 20 20 20 20 20 20 20 20 20 20 rec.
d330: 20 20 20 28 6c 65 74 20 28 28 68 20 28 68 61 73 (let ((h (has
d340: 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
d350: 75 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a ult *host-loads*
d360: 20 68 6f 73 74 6e 61 6d 65 20 23 66 29 29 29 0a hostname #f))).
d370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d380: 20 28 69 66 20 68 0a 20 20 20 20 20 20 20 20 20 (if h.
d390: 20 20 20 20 20 20 20 20 20 20 20 20 68 0a 20 20 h.
d3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3b0: 20 20 20 28 6c 65 74 20 28 28 68 20 28 6d 61 6b (let ((h (mak
d3c0: 65 2d 68 6f 73 74 29 29 29 0a 20 20 20 20 20 20 e-host))).
d3d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3e0: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 (hash-table-set
d3f0: 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 ! *host-loads* h
d400: 6f 73 74 6e 61 6d 65 20 68 29 0a 20 20 20 20 20 ostname h).
d410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d420: 20 20 68 29 29 29 29 0a 20 20 20 20 20 20 20 20 h)))).
d430: 20 20 20 20 20 20 28 72 65 61 63 68 61 62 6c 65 (reachable
d440: 20 28 68 6f 73 74 2d 72 65 61 63 68 61 62 6c 65 (host-reachable
d450: 20 72 65 63 29 29 0a 20 20 20 20 20 20 20 20 20 rec)).
d460: 20 20 20 20 20 28 6c 6f 61 64 20 20 20 20 20 20 (load
d470: 28 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f (host-last-cpulo
d480: 61 64 20 20 20 72 65 63 29 29 29 0a 20 20 20 20 ad rec))).
d490: 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 (cond.
d4a0: 20 20 20 20 20 28 28 6e 6f 74 20 72 65 61 63 68 ((not reach
d4b0: 61 62 6c 65 29 20 23 66 29 0a 20 20 20 20 20 20 able) #f).
d4c0: 20 20 20 20 28 28 3c 20 28 2b 20 6c 6f 61 64 20 ((< (+ load
d4d0: 28 2f 20 28 72 61 6e 64 6f 6d 20 32 35 30 29 20 (/ (random 250)
d4e0: 31 30 30 30 29 29 20 20 20 20 20 20 20 20 20 3b 1000)) ;
d4f0: 3b 20 61 64 64 20 61 20 72 61 6e 64 6f 6d 20 66 ; add a random f
d500: 61 63 74 6f 72 20 74 6f 20 6b 65 65 70 20 66 72 actor to keep fr
d510: 6f 6d 20 67 65 74 74 69 6e 67 20 69 6e 20 61 20 om getting in a
d520: 72 75 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 rut.
d530: 20 20 28 2b 20 62 65 73 74 2d 6c 6f 61 64 20 28 (+ best-load (
d540: 2f 20 28 72 61 6e 64 6f 6d 20 32 35 30 29 20 31 / (random 250) 1
d550: 30 30 30 29 29 20 20 29 0a 20 20 20 20 20 20 20 000)) ).
d560: 20 20 20 20 28 73 65 74 21 20 62 65 73 74 2d 6c (set! best-l
d570: 6f 61 64 20 6c 6f 61 64 29 0a 20 20 20 20 20 20 oad load).
d580: 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 2d (set! best-
d590: 68 6f 73 74 20 68 6f 73 74 6e 61 6d 65 29 29 29 host hostname)))
d5a0: 29 29 0a 20 20 20 20 20 68 6f 73 74 73 29 0a 20 )). hosts).
d5b0: 20 20 20 62 65 73 74 2d 68 6f 73 74 29 29 0a 0a best-host))..
d5c0: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ...(define (comm
d5d0: 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c on:wait-for-cpul
d5e0: 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 oad maxload numc
d5f0: 70 75 73 20 77 61 69 74 64 65 6c 61 79 20 23 21 pus waitdelay #!
d600: 6b 65 79 20 28 63 6f 75 6e 74 20 31 30 30 30 29 key (count 1000)
d610: 20 28 6d 73 67 20 23 66 29 28 72 65 6d 6f 74 65 (msg #f)(remote
d620: 2d 68 6f 73 74 20 23 66 29 29 0a 20 20 28 6c 65 -host #f)). (le
d630: 74 2a 20 28 28 6c 6f 61 64 61 76 67 20 28 63 6f t* ((loadavg (co
d640: 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 mmon:get-cpu-loa
d650: 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 0a d remote-host)).
d660: 09 20 28 66 69 72 73 74 20 20 20 28 63 61 72 20 . (first (car
d670: 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 6e 65 78 loadavg)).. (nex
d680: 74 20 20 20 20 28 63 61 64 72 20 6c 6f 61 64 61 t (cadr loada
d690: 76 67 29 29 0a 09 20 28 61 64 6a 6c 6f 61 64 20 vg)).. (adjload
d6a0: 28 2a 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 (* maxload numcp
d6b0: 75 73 29 29 0a 09 20 28 6c 6f 61 64 6a 6d 70 20 us)).. (loadjmp
d6c0: 28 2d 20 66 69 72 73 74 20 6e 65 78 74 29 29 29 (- first next)))
d6d0: 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 . (cond.
d6e0: 28 28 61 6e 64 20 28 3e 20 66 69 72 73 74 20 61 ((and (> first a
d6f0: 64 6a 6c 6f 61 64 29 0a 09 20 20 20 28 3e 20 63 djload).. (> c
d700: 6f 75 6e 74 20 30 29 29 0a 20 20 20 20 20 20 28 ount 0)). (
d710: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
d720: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
d730: 70 6f 72 74 2a 20 22 77 61 69 74 69 6e 67 20 22 port* "waiting "
d740: 20 77 61 69 74 64 65 6c 61 79 20 22 20 73 65 63 waitdelay " sec
d750: 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c 6f 61 64 onds due to load
d760: 20 22 20 66 69 72 73 74 20 22 20 65 78 63 65 65 " first " excee
d770: 64 69 6e 67 20 6d 61 78 20 6f 66 20 22 20 61 64 ding max of " ad
d780: 6a 6c 6f 61 64 20 28 69 66 20 6d 73 67 20 6d 73 jload (if msg ms
d790: 67 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 68 g "")). (th
d7a0: 72 65 61 64 2d 73 6c 65 65 70 21 20 77 61 69 74 read-sleep! wait
d7b0: 64 65 6c 61 79 29 0a 20 20 20 20 20 20 28 63 6f delay). (co
d7c0: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 mmon:wait-for-cp
d7d0: 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 uload maxload nu
d7e0: 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 20 mcpus waitdelay
d7f0: 63 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 20 count: (- count
d800: 31 29 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 1))). ((and
d810: 28 3e 20 6c 6f 61 64 6a 6d 70 20 6e 75 6d 63 70 (> loadjmp numcp
d820: 75 73 29 0a 09 20 20 20 28 3e 20 63 6f 75 6e 74 us).. (> count
d830: 20 30 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 0)). (debu
d840: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
d850: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
d860: 2a 20 22 77 61 69 74 69 6e 67 20 22 20 77 61 69 * "waiting " wai
d870: 74 64 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 tdelay " seconds
d880: 20 64 75 65 20 74 6f 20 6c 6f 61 64 20 6a 75 6d due to load jum
d890: 70 20 22 20 6c 6f 61 64 6a 6d 70 20 22 20 3e 20 p " loadjmp " >
d8a0: 6e 75 6d 63 70 75 73 20 22 20 6e 75 6d 63 70 75 numcpus " numcpu
d8b0: 73 20 28 69 66 20 6d 73 67 20 6d 73 67 20 22 22 s (if msg msg ""
d8c0: 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 )). (thread
d8d0: 2d 73 6c 65 65 70 21 20 77 61 69 74 64 65 6c 61 -sleep! waitdela
d8e0: 79 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e y). (common
d8f0: 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 :wait-for-cpuloa
d900: 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 75 d maxload numcpu
d910: 73 20 77 61 69 74 64 65 6c 61 79 20 63 6f 75 6e s waitdelay coun
d920: 74 3a 20 28 2d 20 63 6f 75 6e 74 20 31 29 29 29 t: (- count 1)))
d930: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
d940: 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 mmon:get-num-cpu
d950: 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 s remote-host).
d960: 20 28 6c 65 74 20 28 28 70 72 6f 63 20 28 6c 61 (let ((proc (la
d970: 6d 62 64 61 20 28 29 0a 09 09 28 6c 65 74 20 6c mbda ()...(let l
d980: 6f 6f 70 20 28 28 6e 75 6d 63 70 75 20 30 29 0a oop ((numcpu 0).
d990: 09 09 09 20 20 20 28 69 6e 6c 20 20 20 20 28 72 ... (inl (r
d9a0: 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 09 20 20 ead-line)))...
d9b0: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
d9c0: 20 69 6e 6c 29 0a 09 09 20 20 20 20 20 20 6e 75 inl)... nu
d9d0: 6d 63 70 75 0a 09 09 20 20 20 20 20 20 28 6c 6f mcpu... (lo
d9e0: 6f 70 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d op (if (string-m
d9f0: 61 74 63 68 20 22 5e 70 72 6f 63 65 73 73 6f 72 atch "^processor
da00: 5c 5c 73 2b 3a 5c 5c 73 2b 5c 5c 64 2b 24 22 20 \\s+:\\s+\\d+$"
da10: 69 6e 6c 29 0a 09 09 09 09 28 2b 20 6e 75 6d 63 inl).....(+ numc
da20: 70 75 20 31 29 0a 09 09 09 09 6e 75 6d 63 70 75 pu 1).....numcpu
da30: 29 0a 09 09 09 20 20 20 20 28 72 65 61 64 2d 6c ).... (read-l
da40: 69 6e 65 29 29 29 29 29 29 29 0a 20 20 20 20 28 ine))))))). (
da50: 69 66 20 72 65 6d 6f 74 65 2d 68 6f 73 74 0a 09 if remote-host..
da60: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
da70: 2d 70 69 70 65 20 0a 09 20 28 63 6f 6e 63 20 22 -pipe .. (conc "
da80: 73 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 ssh " remote-hos
da90: 74 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 63 70 t " cat /proc/cp
daa0: 75 69 6e 66 6f 22 29 0a 09 20 70 72 6f 63 29 0a uinfo").. proc).
dab0: 09 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f .(with-input-fro
dac0: 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 63 70 m-file "/proc/cp
dad0: 75 69 6e 66 6f 22 20 70 72 6f 63 29 29 29 29 0a uinfo" proc)))).
dae0: 0a 3b 3b 20 77 61 69 74 20 66 6f 72 20 6e 6f 72 .;; wait for nor
daf0: 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f 61 64 malized cpu load
db00: 20 74 6f 20 64 72 6f 70 20 62 65 6c 6f 77 20 6d to drop below m
db10: 61 78 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e axload.;;.(defin
db20: 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 e (common:wait-f
db30: 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c 6f or-normalized-lo
db40: 61 64 20 6d 61 78 6c 6f 61 64 20 23 21 6b 65 79 ad maxload #!key
db50: 20 28 6d 73 67 20 23 66 29 28 72 65 6d 6f 74 65 (msg #f)(remote
db60: 2d 68 6f 73 74 20 23 66 29 29 0a 20 20 28 6c 65 -host #f)). (le
db70: 74 20 28 28 6e 75 6d 2d 63 70 75 73 20 28 63 6f t ((num-cpus (co
db80: 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 mmon:get-num-cpu
db90: 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 s remote-host)))
dba0: 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 . (common:wai
dbb0: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
dbc0: 78 6c 6f 61 64 20 6e 75 6d 2d 63 70 75 73 20 31 xload num-cpus 1
dbd0: 35 20 6d 73 67 3a 20 6d 73 67 29 29 29 0a 0a 28 5 msg: msg)))..(
dbe0: 64 65 66 69 6e 65 20 28 67 65 74 2d 75 6e 61 6d define (get-unam
dbf0: 65 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 6c e . params). (l
dc00: 65 74 2a 20 28 28 75 6e 61 6d 65 2d 72 65 73 20 et* ((uname-res
dc10: 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e (process:cmd-run
dc20: 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 6e ->list (conc "un
dc30: 61 6d 65 20 22 20 28 69 66 20 28 6e 75 6c 6c 3f ame " (if (null?
dc40: 20 70 61 72 61 6d 73 29 20 22 2d 61 22 20 28 63 params) "-a" (c
dc50: 61 72 20 70 61 72 61 6d 73 29 29 29 29 29 0a 09 ar params)))))..
dc60: 20 28 75 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 (uname #f)).
dc70: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 61 72 (if (null? (car
dc80: 20 75 6e 61 6d 65 2d 72 65 73 29 29 0a 09 22 75 uname-res)).."u
dc90: 6e 6b 6e 6f 77 6e 22 0a 09 28 63 61 61 72 20 75 nknown"..(caar u
dca0: 6e 61 6d 65 2d 72 65 73 29 29 29 29 0a 0a 3b 3b name-res))))..;;
dcb0: 20 66 6f 72 20 72 65 61 73 6f 6e 73 20 49 20 64 for reasons I d
dcc0: 6f 6e 27 74 20 75 6e 64 65 72 73 74 61 6e 64 20 on't understand
dcd0: 6d 75 6c 74 69 70 6c 65 20 63 61 6c 6c 73 20 74 multiple calls t
dce0: 6f 20 72 65 61 6c 2d 70 61 74 68 20 69 6e 20 70 o real-path in p
dcf0: 61 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 73 0a arallel threads.
dd00: 3b 3b 20 6d 75 73 74 20 62 65 20 70 72 6f 74 65 ;; must be prote
dd10: 63 74 65 64 20 62 79 20 6d 75 74 65 78 65 73 0a cted by mutexes.
dd20: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
dd30: 6f 6e 3a 72 65 61 6c 2d 70 61 74 68 20 69 6e 70 on:real-path inp
dd40: 61 74 68 29 0a 20 20 3b 3b 20 28 70 72 6f 63 65 ath). ;; (proce
dd50: 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 68 2d ss:cmd-run-with-
dd60: 73 74 64 65 72 72 2d 3e 6c 69 73 74 20 22 72 65 stderr->list "re
dd70: 61 64 6c 69 6e 6b 22 20 22 2d 66 22 20 69 6e 70 adlink" "-f" inp
dd80: 61 74 68 29 29 20 3b 3b 20 63 6d 64 20 2e 20 70 ath)) ;; cmd . p
dd90: 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 6c 65 74 arams). ;; (let
dda0: 2d 76 61 6c 75 65 73 20 0a 20 20 3b 3b 20 20 28 -values . ;; (
ddb0: 28 28 69 6e 70 20 6f 75 70 20 70 69 64 29 20 28 ((inp oup pid) (
ddc0: 70 72 6f 63 65 73 73 20 22 72 65 61 64 6c 69 6e process "readlin
ddd0: 6b 22 20 28 6c 69 73 74 20 22 2d 66 22 20 69 6e k" (list "-f" in
dde0: 70 61 74 68 29 29 29 29 0a 20 20 3b 3b 20 20 28 path)))). ;; (
ddf0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
de00: 70 6f 72 74 20 69 6e 70 0a 20 20 3b 3b 20 20 20 port inp. ;;
de10: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c (let loop ((inl
de20: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 20 20 (read-line)).
de30: 3b 3b 20 20 20 20 20 20 20 09 28 72 65 73 20 23 ;; .(res #
de40: 66 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 28 70 f)). ;; (p
de50: 72 69 6e 74 20 22 69 6e 6c 3d 22 20 69 6e 6c 29 rint "inl=" inl)
de60: 0a 20 20 3b 3b 20 20 20 20 20 20 28 69 66 20 28 . ;; (if (
de70: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 eof-object? inl)
de80: 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 . ;; (
de90: 62 65 67 69 6e 0a 20 20 3b 3b 20 20 20 20 20 20 begin. ;;
dea0: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 (close-inp
deb0: 75 74 2d 70 6f 72 74 20 69 6e 70 29 0a 20 20 3b ut-port inp). ;
dec0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6c ; (cl
ded0: 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 ose-output-port
dee0: 6f 75 70 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 oup). ;;
def0: 20 20 20 20 20 3b 3b 20 28 70 72 6f 63 65 73 73 ;; (process
df00: 2d 77 61 69 74 20 70 69 64 29 0a 20 20 3b 3b 20 -wait pid). ;;
df10: 20 20 20 20 20 20 20 20 20 20 20 72 65 73 29 0a res).
df20: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6c ;; (l
df30: 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 20 oop (read-line)
df40: 69 6e 6c 29 29 29 29 29 29 0a 20 20 28 77 69 74 inl)))))). (wit
df50: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
df60: 65 20 28 63 6f 6e 63 20 22 72 65 61 64 6c 69 6e e (conc "readlin
df70: 6b 20 2d 66 20 22 20 69 6e 70 61 74 68 29 20 72 k -f " inpath) r
df80: 65 61 64 2d 6c 69 6e 65 29 29 0a 0a 3b 3b 3d 3d ead-line))..;;==
df90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dfa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dfb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dfc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
dfd0: 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 20 53 20 4b 20 ====.;; D I S K
dfe0: 20 20 53 20 50 20 41 20 43 20 45 20 0a 3b 3b 3d S P A C E .;;=
dff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
e030: 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
e040: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d common:get-disk-
e050: 73 70 61 63 65 2d 75 73 65 64 20 66 70 61 74 68 space-used fpath
e060: 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ). (with-input-
e070: 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 from-pipe (conc
e080: 22 2f 75 73 72 2f 62 69 6e 2f 64 75 20 2d 73 20 "/usr/bin/du -s
e090: 22 20 66 70 61 74 68 29 20 72 65 61 64 29 29 0a " fpath) read)).
e0a0: 0a 3b 3b 20 67 69 76 65 6e 20 70 61 74 68 20 67 .;; given path g
e0b0: 65 74 20 66 72 65 65 20 73 70 61 63 65 2c 20 61 et free space, a
e0c0: 6c 6c 6f 77 73 20 6f 76 65 72 72 69 64 65 20 69 llows override i
e0d0: 6e 20 5b 73 65 74 75 70 5d 0a 3b 3b 20 77 69 74 n [setup].;; wit
e0e0: 68 20 66 72 65 65 2d 73 70 61 63 65 2d 73 63 72 h free-space-scr
e0f0: 69 70 74 20 2f 70 61 74 68 2f 74 6f 2f 73 6f 6d ipt /path/to/som
e100: 65 2f 73 63 72 69 70 74 2e 73 68 0a 3b 3b 0a 28 e/script.sh.;;.(
e110: 64 65 66 69 6e 65 20 28 67 65 74 2d 64 66 20 70 define (get-df p
e120: 61 74 68 29 0a 20 20 28 69 66 20 28 63 6f 6e 66 ath). (if (conf
e130: 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 igf:lookup *conf
e140: 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 igdat* "setup" "
e150: 66 72 65 65 2d 73 70 61 63 65 2d 73 63 72 69 70 free-space-scrip
e160: 74 22 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d t"). (with-
e170: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
e180: 0a 20 20 20 20 20 20 20 28 63 6f 6e 63 20 28 63 . (conc (c
e190: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
e1a0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
e1b0: 22 20 22 66 72 65 65 2d 73 70 61 63 65 2d 73 63 " "free-space-sc
e1c0: 72 69 70 74 22 29 20 22 20 22 20 70 61 74 68 29 ript") " " path)
e1d0: 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
e1e0: 28 29 0a 09 20 28 6c 65 74 20 28 28 72 65 73 20 ().. (let ((res
e1f0: 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 20 (read-line)))..
e200: 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 (if (string? r
e210: 65 73 29 0a 09 20 20 20 20 20 20 20 28 73 74 72 es).. (str
e220: 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 ing->number res)
e230: 29 29 29 29 0a 20 20 20 20 20 20 28 67 65 74 2d )))). (get-
e240: 75 6e 69 78 2d 64 66 20 70 61 74 68 29 29 29 0a unix-df path))).
e250: 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d 75 6e .(define (get-un
e260: 69 78 2d 64 66 20 70 61 74 68 29 0a 20 20 28 6c ix-df path). (l
e270: 65 74 2a 20 28 28 64 66 2d 72 65 73 75 6c 74 73 et* ((df-results
e280: 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 (process:cmd-ru
e290: 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 64 n->list (conc "d
e2a0: 66 20 22 20 70 61 74 68 29 29 29 0a 09 20 28 73 f " path))).. (s
e2b0: 70 61 63 65 2d 72 78 20 20 20 28 72 65 67 65 78 pace-rx (regex
e2c0: 70 20 22 28 5b 30 2d 39 5d 2b 29 5c 5c 73 2b 28 p "([0-9]+)\\s+(
e2d0: 5b 30 2d 39 5d 2b 29 25 22 29 29 0a 09 20 28 66 [0-9]+)%")).. (f
e2e0: 72 65 65 73 70 63 20 20 20 20 23 66 29 29 0a 20 reespc #f)).
e2f0: 20 20 20 3b 3b 20 28 77 72 69 74 65 20 64 66 2d ;; (write df-
e300: 72 65 73 75 6c 74 73 29 0a 20 20 20 20 28 66 6f results). (fo
e310: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
e320: 6c 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 74 63 l)...(let ((matc
e330: 68 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 h (string-search
e340: 20 73 70 61 63 65 2d 72 78 20 6c 29 29 29 0a 09 space-rx l)))..
e350: 09 20 20 28 69 66 20 6d 61 74 63 68 20 0a 09 09 . (if match ...
e360: 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 (let ((new
e370: 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d val (string->num
e380: 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 ber (cadr match)
e390: 29 29 29 0a 09 09 09 28 69 66 20 28 6e 75 6d 62 )))....(if (numb
e3a0: 65 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 09 20 er? newval)....
e3b0: 20 20 20 28 73 65 74 21 20 66 72 65 65 73 70 63 (set! freespc
e3c0: 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a 09 20 newval))))))..
e3d0: 20 20 20 20 20 28 63 61 72 20 64 66 2d 72 65 73 (car df-res
e3e0: 75 6c 74 73 29 29 0a 20 20 20 20 66 72 65 65 73 ults)). frees
e3f0: 70 63 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 pc))..(define (c
e400: 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 63 ommon:check-spac
e410: 65 2d 69 6e 2d 64 69 72 20 64 69 72 70 61 74 68 e-in-dir dirpath
e420: 20 72 65 71 75 69 72 65 64 29 0a 20 20 28 6c 65 required). (le
e430: 74 2a 20 28 28 64 62 73 70 61 63 65 20 20 28 69 t* ((dbspace (i
e440: 66 20 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 f (directory? di
e450: 72 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 rpath)...
e460: 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 29 (get-df dirpath)
e470: 0a 09 09 20 20 20 20 20 20 20 30 29 29 29 0a 20 ... 0))).
e480: 20 20 20 28 6c 69 73 74 20 28 3e 20 64 62 73 70 (list (> dbsp
e490: 61 63 65 20 72 65 71 75 69 72 65 64 29 0a 09 20 ace required)..
e4a0: 20 64 62 73 70 61 63 65 0a 09 20 20 72 65 71 75 dbspace.. requ
e4b0: 69 72 65 64 0a 09 20 20 64 69 72 70 61 74 68 29 ired.. dirpath)
e4c0: 29 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 73 70 61 ))..;; check spa
e4d0: 63 65 20 69 6e 20 64 62 64 69 72 20 61 6e 64 20 ce in dbdir and
e4e0: 69 6e 20 6d 65 67 61 74 65 73 74 20 64 69 72 0a in megatest dir.
e4f0: 3b 3b 20 72 65 74 75 72 6e 73 3a 20 6f 6b 2f 6e ;; returns: ok/n
e500: 6f 74 20 64 62 73 70 61 63 65 20 72 65 71 75 69 ot dbspace requi
e510: 72 65 64 2d 73 70 61 63 65 0a 3b 3b 0a 28 64 65 red-space.;;.(de
e520: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 fine (common:che
e530: 63 6b 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 29 ck-db-dir-space)
e540: 0a 20 20 28 6c 65 74 2a 20 28 28 72 65 71 75 69 . (let* ((requi
e550: 72 65 64 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d red (string->num
e560: 62 65 72 20 0a 09 09 20 20 20 20 28 6f 72 20 28 ber ... (or (
e570: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
e580: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
e590: 70 22 20 22 64 62 64 69 72 2d 73 70 61 63 65 2d p" "dbdir-space-
e5a0: 72 65 71 75 69 72 65 64 22 29 0a 09 09 09 22 31 required")...."1
e5b0: 30 30 30 30 30 22 29 29 29 0a 09 20 28 64 62 64 00000"))).. (dbd
e5c0: 69 72 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 ir (common:ge
e5d0: 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 20 t-db-tmp-area))
e5e0: 3b 3b 20 28 64 62 3a 67 65 74 2d 64 62 64 69 72 ;; (db:get-dbdir
e5f0: 29 29 0a 09 20 28 74 64 62 73 70 61 63 65 20 28 )).. (tdbspace (
e600: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 common:check-spa
e610: 63 65 2d 69 6e 2d 64 69 72 20 64 62 64 69 72 20 ce-in-dir dbdir
e620: 72 65 71 75 69 72 65 64 29 29 0a 09 20 28 6d 64 required)).. (md
e630: 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a 63 bspace (common:c
e640: 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 heck-space-in-di
e650: 72 20 2a 74 6f 70 70 61 74 68 2a 20 72 65 71 75 r *toppath* requ
e660: 69 72 65 64 29 29 29 0a 20 20 20 20 28 73 6f 72 ired))). (sor
e670: 74 20 28 6c 69 73 74 20 74 64 62 73 70 61 63 65 t (list tdbspace
e680: 20 6d 64 62 73 70 61 63 65 29 20 28 6c 61 6d 62 mdbspace) (lamb
e690: 64 61 20 28 61 20 62 29 0a 09 09 09 09 20 20 20 da (a b).....
e6a0: 20 20 28 3c 20 28 63 61 64 72 20 61 29 28 63 61 (< (cadr a)(ca
e6b0: 64 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 0a dr b)))))). .
e6c0: 3b 3b 20 63 68 65 63 6b 20 61 76 61 69 6c 61 62 ;; check availab
e6d0: 6c 65 20 73 70 61 63 65 20 69 6e 20 64 62 64 69 le space in dbdi
e6e0: 72 2c 20 65 78 69 74 20 69 66 20 69 6e 73 75 66 r, exit if insuf
e6f0: 66 69 63 69 65 6e 74 0a 3b 3b 0a 28 64 65 66 69 ficient.;;.(defi
e700: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b ne (common:check
e710: 2d 64 62 2d 64 69 72 2d 61 6e 64 2d 65 78 69 74 -db-dir-and-exit
e720: 2d 69 66 2d 69 6e 73 75 66 66 69 63 69 65 6e 74 -if-insufficient
e730: 29 0a 20 20 28 6c 65 74 2a 20 28 28 73 70 61 63 ). (let* ((spac
e740: 65 64 61 74 20 28 63 61 72 20 28 63 6f 6d 6d 6f edat (car (commo
e750: 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 73 n:check-db-dir-s
e760: 70 61 63 65 29 29 29 20 3b 3b 20 6c 6f 6f 6b 20 pace))) ;; look
e770: 6f 6e 6c 79 20 61 74 20 77 6f 72 73 74 20 66 6f only at worst fo
e780: 72 20 6e 6f 77 0a 09 20 28 69 73 2d 6f 6b 20 20 r now.. (is-ok
e790: 20 20 28 63 61 72 20 73 70 61 63 65 64 61 74 29 (car spacedat)
e7a0: 29 0a 09 20 28 64 62 73 70 61 63 65 20 20 28 63 ).. (dbspace (c
e7b0: 61 64 72 20 73 70 61 63 65 64 61 74 29 29 0a 09 adr spacedat))..
e7c0: 20 28 72 65 71 75 69 72 65 64 20 28 63 61 64 64 (required (cadd
e7d0: 72 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 28 r spacedat)).. (
e7e0: 64 62 64 69 72 20 20 20 20 28 63 61 64 64 64 72 dbdir (cadddr
e7f0: 20 73 70 61 63 65 64 61 74 29 29 29 0a 20 20 20 spacedat))).
e800: 20 28 69 66 20 28 6e 6f 74 20 69 73 2d 6f 6b 29 (if (not is-ok)
e810: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
e820: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
e830: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
e840: 72 74 2a 20 22 49 6e 73 75 66 66 69 63 69 65 6e rt* "Insufficien
e850: 74 20 73 70 61 63 65 20 69 6e 20 22 20 64 62 64 t space in " dbd
e860: 69 72 20 22 2c 20 72 65 71 75 69 72 65 20 22 20 ir ", require "
e870: 72 65 71 75 69 72 65 64 20 22 2c 20 68 61 76 65 required ", have
e880: 20 22 20 64 62 73 70 61 63 65 20 20 22 2c 20 65 " dbspace ", e
e890: 78 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 20 xiting now.")..
e8a0: 20 28 65 78 69 74 20 31 29 29 29 29 29 0a 20 20 (exit 1))))).
e8b0: 0a 3b 3b 20 70 61 74 68 73 20 69 73 20 6c 69 73 .;; paths is lis
e8c0: 74 20 6f 66 20 6c 69 73 74 73 20 28 28 6e 61 6d t of lists ((nam
e8d0: 65 20 70 61 74 68 29 20 2e 2e 2e 20 29 0a 3b 3b e path) ... ).;;
e8e0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
e8f0: 3a 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d 6d :get-disk-with-m
e900: 6f 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 64 ost-free-space d
e910: 69 73 6b 73 20 6d 69 6e 73 69 7a 65 29 0a 20 20 isks minsize).
e920: 28 6c 65 74 20 28 28 62 65 73 74 20 20 20 20 20 (let ((best
e930: 23 66 29 0a 09 28 62 65 73 74 73 69 7a 65 20 30 #f)..(bestsize 0
e940: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
e950: 20 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 . (lambda (
e960: 64 69 73 6b 2d 6e 75 6d 29 0a 20 20 20 20 20 20 disk-num).
e970: 20 28 6c 65 74 2a 20 28 28 64 69 72 70 61 74 68 (let* ((dirpath
e980: 20 20 20 20 28 63 61 64 72 20 28 61 73 73 6f 63 (cadr (assoc
e990: 20 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 29 disk-num disks)
e9a0: 29 29 0a 09 20 20 20 20 20 20 28 66 72 65 65 73 )).. (frees
e9b0: 70 63 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 20 pc (cond....
e9c0: 20 20 28 28 6e 6f 74 20 28 64 69 72 65 63 74 6f ((not (directo
e9d0: 72 79 3f 20 64 69 72 70 61 74 68 29 29 0a 09 09 ry? dirpath))...
e9e0: 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
e9f0: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
ea00: 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 300 "disks not
ea10: 61 20 64 69 72 20 22 20 64 69 73 6b 2d 6e 75 6d a dir " disk-num
ea20: 29 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 ).....(debug:pri
ea30: 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
ea40: 67 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 g-port* "WARNING
ea50: 3a 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 : disk " disk-nu
ea60: 6d 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 20 m " at path \""
ea70: 64 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 6e dirpath "\" is n
ea80: 6f 74 20 61 20 64 69 72 65 63 74 6f 72 79 20 2d ot a directory -
ea90: 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 29 ignoring it."))
eaa0: 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 20 .... -1)....
eab0: 20 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 ((not (file-wr
eac0: 69 74 65 2d 61 63 63 65 73 73 3f 20 64 69 72 70 ite-access? dirp
ead0: 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 66 ath)).... (if
eae0: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
eaf0: 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 se-print 300 "di
eb00: 73 6b 73 20 6e 6f 74 20 77 72 69 74 65 61 62 6c sks not writeabl
eb10: 65 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 e " disk-num)...
eb20: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 ..(debug:print 0
eb30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
eb40: 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 rt* "WARNING: di
eb50: 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 sk " disk-num "
eb60: 61 74 20 70 61 74 68 20 5c 22 22 20 64 69 72 70 at path \"" dirp
eb70: 61 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 77 ath "\" is not w
eb80: 72 69 74 65 61 62 6c 65 20 2d 20 69 67 6e 6f 72 riteable - ignor
eb90: 69 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 ing it."))....
eba0: 20 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f -1).... ((no
ebb0: 74 20 28 65 71 3f 20 28 73 74 72 69 6e 67 2d 72 t (eq? (string-r
ebc0: 65 66 20 64 69 72 70 61 74 68 20 30 29 20 23 5c ef dirpath 0) #\
ebd0: 2f 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 /)).... (if (
ebe0: 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 common:low-noise
ebf0: 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 73 6b -print 300 "disk
ec00: 73 20 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 70 s not a proper p
ec10: 61 74 68 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a ath " disk-num).
ec20: 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 ....(debug:print
ec30: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
ec40: 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 port* "WARNING:
ec50: 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 disk " disk-num
ec60: 22 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 69 " at path \"" di
ec70: 72 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 rpath "\" is not
ec80: 20 61 20 66 75 6c 6c 79 20 71 75 61 6c 69 66 69 a fully qualifi
ec90: 65 64 20 70 61 74 68 20 2d 20 69 67 6e 6f 72 69 ed path - ignori
eca0: 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 ng it."))....
ecb0: 20 2d 31 29 0a 09 09 09 20 20 20 28 65 6c 73 65 -1).... (else
ecc0: 0a 09 09 09 20 20 20 20 28 67 65 74 2d 64 66 20 .... (get-df
ecd0: 64 69 72 70 61 74 68 29 29 29 29 29 0a 09 20 28 dirpath))))).. (
ece0: 69 66 20 28 3e 20 66 72 65 65 73 70 63 20 62 65 if (> freespc be
ecf0: 73 74 73 69 7a 65 29 0a 09 20 20 20 20 20 28 62 stsize).. (b
ed00: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 73 65 egin.. (se
ed10: 74 21 20 62 65 73 74 20 20 20 20 20 28 63 6f 6e t! best (con
ed20: 73 20 64 69 73 6b 2d 6e 75 6d 20 64 69 72 70 61 s disk-num dirpa
ed30: 74 68 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 th)).. (se
ed40: 74 21 20 62 65 73 74 73 69 7a 65 20 66 72 65 65 t! bestsize free
ed50: 73 70 63 29 29 29 29 29 0a 20 20 20 20 20 28 6d spc))))). (m
ed60: 61 70 20 63 61 72 20 64 69 73 6b 73 29 29 0a 20 ap car disks)).
ed70: 20 20 20 28 69 66 20 28 61 6e 64 20 62 65 73 74 (if (and best
ed80: 20 28 3e 20 62 65 73 74 73 69 7a 65 20 6d 69 6e (> bestsize min
ed90: 73 69 7a 65 29 29 0a 09 62 65 73 74 0a 09 23 66 size))..best..#f
eda0: 29 29 29 20 3b 3b 20 23 66 20 6d 65 61 6e 73 20 ))) ;; #f means
edb0: 6e 6f 20 64 69 73 6b 20 63 61 6e 64 69 64 61 74 no disk candidat
edc0: 65 20 66 6f 75 6e 64 0a 0a 3b 3b 3d 3d 3d 3d 3d e found..;;=====
edd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ede0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
edf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee10: 3d 0a 3b 3b 20 45 20 4e 20 56 20 49 20 52 20 4f =.;; E N V I R O
ee20: 20 4e 20 4d 20 45 20 4e 20 54 20 20 20 56 20 41 N M E N T V A
ee30: 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d R S.;;=========
ee40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ee70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 09 20 =============..
ee80: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 73 .(define (s
ee90: 61 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d ave-environment-
eea0: 61 73 2d 66 69 6c 65 73 20 66 6e 61 6d 65 20 23 as-files fname #
eeb0: 21 6b 65 79 20 28 69 67 6e 6f 72 65 76 61 72 73 !key (ignorevars
eec0: 20 28 6c 69 73 74 20 22 55 53 45 52 22 20 22 48 (list "USER" "H
eed0: 4f 4d 45 22 20 22 44 49 53 50 4c 41 59 22 20 22 OME" "DISPLAY" "
eee0: 4c 53 5f 43 4f 4c 4f 52 53 22 20 22 58 4b 45 59 LS_COLORS" "XKEY
eef0: 53 59 4d 44 42 22 20 22 45 44 49 54 4f 52 22 20 SYMDB" "EDITOR"
ef00: 22 4d 41 4b 45 46 4c 41 47 53 22 20 22 4d 41 4b "MAKEFLAGS" "MAK
ef10: 45 46 22 20 22 4d 41 4b 45 4f 56 45 52 52 49 44 EF" "MAKEOVERRID
ef20: 45 53 22 29 29 29 0a 20 20 28 6c 65 74 20 28 28 ES"))). (let ((
ef30: 65 6e 76 76 61 72 73 20 28 67 65 74 2d 65 6e 76 envvars (get-env
ef40: 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c ironment-variabl
ef50: 65 73 29 29 0a 20 20 20 20 20 20 20 20 28 77 68 es)). (wh
ef60: 69 74 65 73 70 20 28 72 65 67 65 78 70 20 22 5b itesp (regexp "[
ef70: 5e 61 2d 7a 41 2d 5a 30 2d 39 5f 5c 5c 2d 3a 2c ^a-zA-Z0-9_\\-:,
ef80: 2e 5c 5c 2f 25 24 5d 22 29 29 0a 09 28 6d 75 6e .\\/%$]"))..(mun
ef90: 67 65 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 76 geval (lambda (v
efa0: 61 6c 29 0a 09 09 20 20 20 20 28 63 6f 6e 64 0a al)... (cond.
efb0: 09 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 6c .. ((eq? val
efc0: 20 23 74 29 20 22 22 29 20 3b 3b 20 63 6f 6e 76 #t) "") ;; conv
efd0: 65 72 74 20 23 74 20 74 6f 20 65 6d 70 74 79 20 ert #t to empty
efe0: 73 74 72 69 6e 67 0a 09 09 20 20 20 20 20 28 28 string... ((
eff0: 65 71 3f 20 76 61 6c 20 23 66 29 20 23 66 29 20 eq? val #f) #f)
f000: 3b 3b 20 63 6f 6e 76 65 72 74 20 23 66 20 74 6f ;; convert #f to
f010: 20 69 74 73 65 6c 66 20 28 73 74 69 6c 6c 20 74 itself (still t
f020: 68 69 6e 6b 69 6e 67 20 61 62 6f 75 74 20 74 68 hinking about th
f030: 69 73 20 6f 6e 65 0a 09 09 20 20 20 20 20 28 65 is one... (e
f040: 6c 73 65 20 76 61 6c 29 29 29 29 29 0a 20 20 20 lse val))))).
f050: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
f060: 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e 61 o-file (conc fna
f070: 6d 65 20 22 2e 63 73 68 22 29 0a 20 20 20 20 20 me ".csh").
f080: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
f090: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
f0a0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c (lambda (keyval
f0b0: 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 )... (let*
f0c0: 28 28 6b 65 79 20 20 20 28 63 61 72 20 6b 65 79 ((key (car key
f0d0: 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 76 val)).... (v
f0e0: 61 6c 20 20 20 28 63 64 72 20 6b 65 79 76 61 6c al (cdr keyval
f0f0: 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 6c 69 )).... (deli
f100: 6d 20 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 m (if (string-se
f110: 61 72 63 68 20 77 68 69 74 65 73 70 20 76 61 6c arch whitesp val
f120: 29 20 0a 09 09 09 09 09 22 5c 22 22 0a 09 09 09 ) ......"\""....
f130: 09 09 22 22 29 29 29 0a 09 09 09 28 70 72 69 6e .."")))....(prin
f140: 74 20 28 69 66 20 28 6d 65 6d 62 65 72 20 6b 65 t (if (member ke
f150: 79 20 69 67 6e 6f 72 65 76 61 72 73 29 0a 09 09 y ignorevars)...
f160: 09 09 20 20 20 22 23 20 73 65 74 65 6e 76 20 22 .. "# setenv "
f170: 0a 09 09 09 09 20 20 20 22 73 65 74 65 6e 76 20 ..... "setenv
f180: 22 29 0a 09 09 09 20 20 20 20 20 20 20 6b 65 79 ").... key
f190: 20 22 20 22 20 64 65 6c 69 6d 20 28 6d 75 6e 67 " " delim (mung
f1a0: 65 76 61 6c 20 76 61 6c 29 20 64 65 6c 69 6d 29 eval val) delim)
f1b0: 29 29 0a 09 09 20 20 20 20 65 6e 76 76 61 72 73 ))... envvars
f1c0: 29 29 29 0a 20 20 20 20 20 28 77 69 74 68 2d 6f ))). (with-o
f1d0: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 utput-to-file (c
f1e0: 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 73 68 22 29 onc fname ".sh")
f1f0: 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 . (lambda
f200: 28 29 0a 20 20 20 20 20 20 20 20 20 20 28 66 6f (). (fo
f210: 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
f220: 6b 65 79 76 61 6c 29 0a 09 09 20 20 20 20 20 20 keyval)...
f230: 28 6c 65 74 2a 20 28 28 6b 65 79 20 28 63 61 72 (let* ((key (car
f240: 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 keyval))....
f250: 20 20 28 76 61 6c 20 28 63 64 72 20 6b 65 79 76 (val (cdr keyv
f260: 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 al)).... (de
f270: 6c 69 6d 20 28 69 66 20 28 73 74 72 69 6e 67 2d lim (if (string-
f280: 73 65 61 72 63 68 20 77 68 69 74 65 73 70 20 76 search whitesp v
f290: 61 6c 29 20 0a 09 09 09 09 09 22 5c 22 22 0a 09 al) ......"\""..
f2a0: 09 09 09 09 22 22 29 29 29 0a 09 09 09 28 70 72 ...."")))....(pr
f2b0: 69 6e 74 20 28 69 66 20 28 6d 65 6d 62 65 72 20 int (if (member
f2c0: 6b 65 79 20 69 67 6e 6f 72 65 76 61 72 73 29 0a key ignorevars).
f2d0: 09 09 09 09 20 20 20 22 23 20 65 78 70 6f 72 74 .... "# export
f2e0: 20 22 0a 09 09 09 09 20 20 20 22 65 78 70 6f 72 "..... "expor
f2f0: 74 20 22 29 0a 09 09 09 20 20 20 20 20 20 20 6b t ").... k
f300: 65 79 20 22 3d 22 20 64 65 6c 69 6d 20 28 6d 75 ey "=" delim (mu
f310: 6e 67 65 76 61 6c 20 76 61 6c 29 20 64 65 6c 69 ngeval val) deli
f320: 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 m))).
f330: 20 20 20 20 20 20 20 20 20 65 6e 76 76 61 72 73 envvars
f340: 29 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 73 6f )))))..;; set so
f350: 6d 65 20 65 6e 76 20 76 61 72 73 20 66 72 6f 6d me env vars from
f360: 20 61 6e 20 61 6c 69 73 74 2c 20 72 65 74 75 72 an alist, retur
f370: 6e 20 61 6e 20 61 6c 69 73 74 20 77 69 74 68 20 n an alist with
f380: 6f 72 69 67 69 6e 61 6c 20 76 61 6c 75 65 73 0a original values.
f390: 3b 3b 20 28 28 22 56 41 52 22 20 22 76 61 6c 75 ;; (("VAR" "valu
f3a0: 65 22 29 20 2e 2e 2e 29 0a 28 64 65 66 69 6e 65 e") ...).(define
f3b0: 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 61 72 (alist->env-var
f3c0: 73 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6c 69 s lst). (if (li
f3d0: 73 74 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 28 st? lst). (
f3e0: 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 29 0a let ((res '())).
f3f0: 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 .(for-each (lamb
f400: 64 61 20 28 70 29 0a 09 09 20 20 20 20 28 6c 65 da (p)... (le
f410: 74 2a 20 28 28 76 61 72 20 28 63 61 72 20 20 70 t* ((var (car p
f420: 29 29 0a 09 09 09 20 20 20 28 76 61 6c 20 28 63 )).... (val (c
f430: 61 64 72 20 70 29 29 0a 09 09 09 20 20 20 28 70 adr p)).... (p
f440: 72 76 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d rv (get-environm
f450: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 76 61 72 ent-variable var
f460: 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 65 74 )))... (set
f470: 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c 69 73 ! res (cons (lis
f480: 74 20 76 61 72 20 70 72 76 29 20 72 65 73 29 29 t var prv) res))
f490: 0a 09 09 20 20 20 20 20 20 28 69 66 20 76 61 6c ... (if val
f4a0: 20 0a 09 09 09 20 20 28 73 65 74 65 6e 76 20 76 .... (setenv v
f4b0: 61 72 20 28 2d 3e 73 74 72 69 6e 67 20 76 61 6c ar (->string val
f4c0: 29 29 0a 09 09 09 20 20 28 75 6e 73 65 74 65 6e )).... (unseten
f4d0: 76 20 76 61 72 29 29 29 29 0a 09 09 20 20 6c 73 v var))))... ls
f4e0: 74 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 27 t)..res). '
f4f0: 28 29 29 29 0a 0a 3b 3b 20 63 6c 65 61 72 20 76 ()))..;; clear v
f500: 61 72 73 20 6d 61 74 63 68 69 6e 67 20 70 61 74 ars matching pat
f510: 74 65 72 6e 2c 20 72 75 6e 20 70 72 6f 63 2c 20 tern, run proc,
f520: 73 65 74 20 76 61 72 73 20 62 61 63 6b 0a 3b 3b set vars back.;;
f530: 20 69 66 20 70 72 6f 63 20 69 73 20 61 20 73 74 if proc is a st
f540: 72 69 6e 67 20 72 75 6e 20 74 68 61 74 20 73 74 ring run that st
f550: 72 69 6e 67 20 61 73 20 61 20 63 6f 6d 6d 61 6e ring as a comman
f560: 64 20 77 69 74 68 0a 3b 3b 20 73 79 73 74 65 6d d with.;; system
f570: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ..;;.(define (co
f580: 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 mmon:without-var
f590: 73 20 70 72 6f 63 20 2e 20 76 61 72 2d 70 61 74 s proc . var-pat
f5a0: 74 73 29 0a 20 20 28 6c 65 74 20 28 28 76 61 72 ts). (let ((var
f5b0: 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 s (make-hash-tab
f5c0: 6c 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 le))). (for-e
f5d0: 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
f5e0: 20 28 76 61 72 64 61 74 29 20 3b 3b 20 65 61 63 (vardat) ;; eac
f5f0: 68 20 65 6e 76 20 76 61 72 0a 20 20 20 20 20 20 h env var.
f600: 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 6d (for-each..(lam
f610: 62 64 61 20 28 76 61 72 2d 70 61 74 74 29 0a 09 bda (var-patt)..
f620: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
f630: 74 63 68 20 76 61 72 2d 70 61 74 74 20 28 63 61 tch var-patt (ca
f640: 72 20 76 61 72 64 61 74 29 29 0a 09 20 20 20 20 r vardat))..
f650: 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 61 (let ((var (ca
f660: 72 20 76 61 72 64 61 74 29 29 0a 09 09 20 20 20 r vardat))...
f670: 20 28 76 61 6c 20 28 63 64 72 20 76 61 72 64 61 (val (cdr varda
f680: 74 29 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 t)))...(hash-tab
f690: 6c 65 2d 73 65 74 21 20 76 61 72 73 20 76 61 72 le-set! vars var
f6a0: 20 76 61 6c 29 0a 09 09 28 75 6e 73 65 74 65 6e val)...(unseten
f6b0: 76 20 76 61 72 29 29 29 29 0a 09 76 61 72 2d 70 v var))))..var-p
f6c0: 61 74 74 73 29 29 0a 20 20 20 20 20 28 67 65 74 atts)). (get
f6d0: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
f6e0: 69 61 62 6c 65 73 29 29 0a 20 20 20 20 28 63 6f iables)). (co
f6f0: 6e 64 0a 20 20 20 20 20 28 28 73 74 72 69 6e 67 nd. ((string
f700: 3f 20 70 72 6f 63 29 28 73 79 73 74 65 6d 20 70 ? proc)(system p
f710: 72 6f 63 29 29 0a 20 20 20 20 20 28 70 72 6f 63 roc)). (proc
f720: 20 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 29 (proc)
f730: 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 )). (hash-tab
f740: 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 le-for-each.
f750: 20 76 61 72 73 0a 20 20 20 20 20 28 6c 61 6d 62 vars. (lamb
f760: 64 61 20 28 76 61 72 20 76 61 6c 29 0a 20 20 20 da (var val).
f770: 20 20 20 20 28 73 65 74 65 6e 76 20 76 61 72 20 (setenv var
f780: 76 61 6c 29 29 29 0a 20 20 20 20 76 61 72 73 29 val))). vars)
f790: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
f7a0: 6f 6e 3a 72 75 6e 2d 61 2d 63 6f 6d 6d 61 6e 64 on:run-a-command
f7b0: 20 63 6d 64 20 23 21 6b 65 79 20 28 77 69 74 68 cmd #!key (with
f7c0: 2d 76 61 72 73 20 23 66 29 29 0a 20 20 28 6c 65 -vars #f)). (le
f7d0: 74 2a 20 28 28 70 72 65 2d 63 6d 64 20 20 28 64 t* ((pre-cmd (d
f7e0: 74 65 73 74 73 3a 67 65 74 2d 70 72 65 2d 63 6f tests:get-pre-co
f7f0: 6d 6d 61 6e 64 29 29 0a 20 20 20 20 20 20 20 20 mmand)).
f800: 20 28 70 6f 73 74 2d 63 6d 64 20 28 64 74 65 73 (post-cmd (dtes
f810: 74 73 3a 67 65 74 2d 70 6f 73 74 2d 63 6f 6d 6d ts:get-post-comm
f820: 61 6e 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 and)). (
f830: 66 75 6c 6c 63 6d 64 20 20 28 69 66 20 28 6f 72 fullcmd (if (or
f840: 20 70 72 65 2d 63 6d 64 20 70 6f 73 74 2d 63 6d pre-cmd post-cm
f850: 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d).
f860: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 (conc
f870: 70 72 65 2d 63 6d 64 20 63 6d 64 20 70 6f 73 74 pre-cmd cmd post
f880: 2d 63 6d 64 29 0a 20 20 20 20 20 20 20 20 20 20 -cmd).
f890: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
f8a0: 6e 63 20 22 76 69 65 77 73 63 72 65 65 6e 20 22 nc "viewscreen "
f8b0: 20 63 6d 64 29 29 29 29 0a 20 20 20 20 28 64 65 cmd)))). (de
f8c0: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
f8d0: 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
f8e0: 6f 72 74 2a 20 22 52 75 6e 6e 69 6e 67 20 63 6f ort* "Running co
f8f0: 6d 6d 61 6e 64 3a 20 22 20 66 75 6c 6c 63 6d 64 mmand: " fullcmd
f900: 29 0a 20 20 20 20 28 69 66 20 77 69 74 68 2d 76 ). (if with-v
f910: 61 72 73 0a 20 20 20 20 20 20 20 20 28 63 6f 6d ars. (com
f920: 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 73 mon:without-vars
f930: 20 63 6d 64 29 0a 20 20 20 20 20 20 20 20 28 63 cmd). (c
f940: 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 ommon:without-va
f950: 72 73 20 66 75 6c 6c 63 6d 64 20 22 4d 54 5f 2e rs fullcmd "MT_.
f960: 2a 22 29 29 29 29 0a 09 09 20 20 0a 3b 3b 3d 3d *"))))... .;;==
f970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9b0: 3d 3d 3d 3d 0a 3b 3b 20 54 20 49 20 4d 20 45 20 ====.;; T I M E
f9c0: 20 20 41 20 4e 20 44 20 20 20 44 20 41 20 54 20 A N D D A T
f9d0: 45 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E.;;============
f9e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fa00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fa10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 43 ==========..;; C
fa20: 6f 6e 76 65 72 74 20 73 74 72 69 6e 67 73 20 6c onvert strings l
fa30: 69 6b 65 20 22 35 73 20 32 68 20 33 6d 22 20 3d ike "5s 2h 3m" =
fa40: 3e 20 36 30 78 36 30 78 32 20 2b 20 33 78 36 30 > 60x60x2 + 3x60
fa50: 20 2b 20 35 0a 28 64 65 66 69 6e 65 20 28 63 6f + 5.(define (co
fa60: 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 2d mmon:hms-string-
fa70: 3e 73 65 63 6f 6e 64 73 20 74 73 74 72 29 0a 20 >seconds tstr).
fa80: 20 28 6c 65 74 20 28 28 70 61 72 74 73 20 20 20 (let ((parts
fa90: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
faa0: 74 73 74 72 29 29 0a 09 28 74 69 6d 65 2d 73 65 tstr))..(time-se
fab0: 63 73 20 30 29 0a 09 3b 3b 20 73 3d 73 65 63 6f cs 0)..;; s=seco
fac0: 6e 64 73 2c 20 6d 3d 6d 69 6e 75 74 65 73 2c 20 nds, m=minutes,
fad0: 68 3d 68 6f 75 72 73 2c 20 64 3d 64 61 79 73 0a h=hours, d=days.
fae0: 09 28 74 72 78 20 20 20 20 20 20 20 28 72 65 67 .(trx (reg
faf0: 65 78 70 20 22 28 5c 5c 64 2b 29 28 5b 73 6d 68 exp "(\\d+)([smh
fb00: 64 5d 29 22 29 29 29 0a 20 20 20 20 28 66 6f 72 d])"))). (for
fb10: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 -each (lambda (p
fb20: 61 72 74 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 art)...(let ((ma
fb30: 74 63 68 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 tch (string-mat
fb40: 63 68 20 74 72 78 20 70 61 72 74 29 29 29 0a 09 ch trx part)))..
fb50: 09 20 20 28 69 66 20 6d 61 74 63 68 0a 09 09 20 . (if match...
fb60: 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 (let ((val
fb70: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
fb80: 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 0a 09 (cadr match)))..
fb90: 09 09 20 20 20 20 28 75 6e 74 20 28 63 61 64 64 .. (unt (cadd
fba0: 72 20 6d 61 74 63 68 29 29 29 0a 09 09 09 28 69 r match)))....(i
fbb0: 66 20 76 61 6c 20 0a 09 09 09 20 20 20 20 28 73 f val .... (s
fbc0: 65 74 21 20 74 69 6d 65 2d 73 65 63 73 20 28 2b et! time-secs (+
fbd0: 20 74 69 6d 65 2d 73 65 63 73 20 28 2a 20 76 61 time-secs (* va
fbe0: 6c 0a 09 09 09 09 09 09 09 20 20 20 20 28 63 61 l........ (ca
fbf0: 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 se (string->symb
fc00: 6f 6c 20 75 6e 74 29 0a 09 09 09 09 09 09 09 20 ol unt)........
fc10: 20 20 20 20 20 28 28 73 29 20 31 29 0a 09 09 09 ((s) 1)....
fc20: 09 09 09 09 20 20 20 20 20 20 28 28 6d 29 20 36 .... ((m) 6
fc30: 30 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 0)........
fc40: 28 28 68 29 20 28 2a 20 36 30 20 36 30 29 29 0a ((h) (* 60 60)).
fc50: 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 64 ....... ((d
fc60: 29 20 28 2a 20 32 34 20 36 30 20 36 30 29 29 0a ) (* 24 60 60)).
fc70: 09 09 09 09 09 09 09 20 20 20 20 20 20 28 65 6c ....... (el
fc80: 73 65 20 30 29 29 29 29 29 29 29 29 29 29 0a 09 se 0))))))))))..
fc90: 20 20 20 20 20 20 70 61 72 74 73 29 0a 20 20 20 parts).
fca0: 20 74 69 6d 65 2d 73 65 63 73 29 29 0a 09 09 20 time-secs))...
fcb0: 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 .(define (
fcc0: 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d seconds->hr-min-
fcd0: 73 65 63 20 73 65 63 73 29 0a 20 20 28 6c 65 74 sec secs). (let
fce0: 2a 20 28 28 68 72 73 20 28 71 75 6f 74 69 65 6e * ((hrs (quotien
fcf0: 74 20 73 65 63 73 20 33 36 30 30 29 29 0a 09 20 t secs 3600))..
fd00: 28 6d 69 6e 20 28 71 75 6f 74 69 65 6e 74 20 28 (min (quotient (
fd10: 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 33 36 - secs (* hrs 36
fd20: 30 30 29 29 20 36 30 29 29 0a 09 20 28 73 65 63 00)) 60)).. (sec
fd30: 20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 (- secs (* hrs
fd40: 33 36 30 30 29 28 2a 20 6d 69 6e 20 36 30 29 29 3600)(* min 60))
fd50: 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 69 66 )). (conc (if
fd60: 20 28 3e 20 68 72 73 20 30 29 28 63 6f 6e 63 20 (> hrs 0)(conc
fd70: 68 72 73 20 22 68 72 20 22 29 20 22 22 29 0a 09 hrs "hr ") "")..
fd80: 20 20 28 69 66 20 28 3e 20 6d 69 6e 20 30 29 28 (if (> min 0)(
fd90: 63 6f 6e 63 20 6d 69 6e 20 22 6d 20 22 29 20 20 conc min "m ")
fda0: 22 22 29 0a 09 20 20 73 65 63 20 22 73 22 29 29 "").. sec "s"))
fdb0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
fdc0: 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 nds->time-string
fdd0: 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
fde0: 74 72 69 6e 67 20 0a 20 20 20 28 73 65 63 6f 6e tring . (secon
fdf0: 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 ds->local-time s
fe00: 65 63 29 20 22 25 48 3a 25 4d 3a 25 53 22 29 29 ec) "%H:%M:%S"))
fe10: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e ..(define (secon
fe20: 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 ds->work-week/da
fe30: 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 y-time sec). (t
fe40: 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 ime->string. (
fe50: 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
fe60: 69 6d 65 20 73 65 63 29 20 22 77 77 25 56 2e 25 ime sec) "ww%V.%
fe70: 75 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 u %H:%M"))..(def
fe80: 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f ine (seconds->wo
fe90: 72 6b 2d 77 65 65 6b 2f 64 61 79 20 73 65 63 29 rk-week/day sec)
fea0: 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 . (time->string
feb0: 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
fec0: 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 77 cal-time sec) "w
fed0: 77 25 56 2e 25 75 22 29 29 0a 0a 28 64 65 66 69 w%V.%u"))..(defi
fee0: 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 ne (seconds->yea
fef0: 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 20 r-work-week/day
ff00: 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
ff10: 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
ff20: 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
ff30: 29 20 22 25 79 77 77 25 56 2e 25 77 22 29 29 0a ) "%yww%V.%w")).
ff40: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
ff50: 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 65 s->year-work-wee
ff60: 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 0a k/day-time sec).
ff70: 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a (time->string.
ff80: 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
ff90: 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 59 al-time sec) "%Y
ffa0: 77 77 25 56 2e 25 77 20 25 48 3a 25 4d 22 29 29 ww%V.%w %H:%M"))
ffb0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e ..(define (secon
ffc0: 64 73 2d 3e 79 65 61 72 2d 77 65 65 6b 2f 64 61 ds->year-week/da
ffd0: 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 y-time sec). (t
ffe0: 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 ime->string. (
fff0: 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
10000 69 6d 65 20 73 65 63 29 20 22 25 59 77 25 56 2e ime sec) "%Yw%V.
10010 25 77 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 %w %H:%M"))..(de
10020 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 71 fine (seconds->q
10030 75 61 72 74 65 72 20 73 65 63 29 0a 20 20 28 63 uarter sec). (c
10040 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ase (string->num
10050 62 65 72 0a 09 20 28 74 69 6d 65 2d 3e 73 74 72 ber.. (time->str
10060 69 6e 67 20 0a 09 20 20 28 73 65 63 6f 6e 64 73 ing .. (seconds
10070 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
10080 29 0a 09 20 20 22 25 6d 22 29 29 0a 20 20 20 20 ).. "%m")).
10090 28 28 31 20 32 20 33 29 20 31 29 0a 20 20 20 20 ((1 2 3) 1).
100a0 28 28 34 20 35 20 36 29 20 32 29 0a 20 20 20 20 ((4 5 6) 2).
100b0 28 28 37 20 38 20 39 29 20 33 29 0a 20 20 20 20 ((7 8 9) 3).
100c0 28 28 31 30 20 31 31 20 31 32 29 20 34 29 0a 20 ((10 11 12) 4).
100d0 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 0a 0a (else #f)))..
100e0 3b 3b 20 62 61 73 69 63 20 49 53 4f 38 36 30 31 ;; basic ISO8601
100f0 20 66 6f 72 6d 61 74 20 28 65 2e 67 2e 20 22 32 format (e.g. "2
10100 30 31 37 2d 30 32 2d 32 38 20 30 36 3a 30 32 3a 017-02-28 06:02:
10110 35 34 22 29 20 64 61 74 65 20 74 69 6d 65 20 3d 54") date time =
10120 3e 20 55 6e 69 78 20 65 70 6f 63 68 0a 3b 3b 0a > Unix epoch.;;.
10130 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
10140 64 61 74 65 2d 74 69 6d 65 2d 3e 73 65 63 6f 6e date-time->secon
10150 64 73 20 64 61 74 65 74 69 6d 65 29 0a 20 20 28 ds datetime). (
10160 6c 6f 63 61 6c 2d 74 69 6d 65 2d 3e 73 65 63 6f local-time->seco
10170 6e 64 73 20 28 73 74 72 69 6e 67 2d 3e 74 69 6d nds (string->tim
10180 65 20 64 61 74 65 74 69 6d 65 20 22 25 59 2d 25 e datetime "%Y-%
10190 6d 2d 25 64 20 25 48 3a 25 4d 3a 25 53 22 29 29 m-%d %H:%M:%S"))
101a0 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 73 70 61 6e )..;; given span
101b0 20 6f 66 20 73 65 63 6f 6e 64 73 20 74 73 74 61 of seconds tsta
101c0 72 74 20 74 6f 20 74 65 6e 64 0a 3b 3b 20 66 69 rt to tend.;; fi
101d0 6e 64 20 73 74 61 72 74 20 74 69 6d 65 20 74 6f nd start time to
101e0 20 6d 61 72 6b 20 61 6e 64 20 6d 61 72 6b 20 64 mark and mark d
101f0 65 6c 74 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 elta.;;.(define
10200 28 63 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 73 74 61 (common:find-sta
10210 72 74 2d 6d 61 72 6b 2d 61 6e 64 2d 6d 61 72 6b rt-mark-and-mark
10220 2d 64 65 6c 74 61 20 74 73 74 61 72 74 20 74 65 -delta tstart te
10230 6e 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 65 nd). (let* ((de
10240 6c 74 61 74 20 20 20 28 2d 20 28 6d 61 78 20 74 ltat (- (max t
10250 65 6e 64 20 28 2b 20 74 65 6e 64 20 31 30 29 29 end (+ tend 10))
10260 20 74 73 74 61 72 74 29 29 20 3b 3b 20 63 61 6e tstart)) ;; can
10270 27 74 20 68 61 6e 64 6c 65 20 72 75 6e 73 20 6f 't handle runs o
10280 66 20 6c 65 73 73 20 74 68 61 6e 20 34 20 73 65 f less than 4 se
10290 63 6f 6e 64 73 2e 20 50 61 64 20 69 74 20 74 6f conds. Pad it to
102a0 20 31 30 20 73 65 63 6f 6e 64 73 20 2e 2e 2e 0a 10 seconds ....
102b0 09 20 28 72 65 73 75 6c 74 20 20 20 23 66 29 0a . (result #f).
102c0 09 20 28 6d 69 6e 20 20 20 20 20 20 36 30 29 0a . (min 60).
102d0 09 20 28 68 72 20 20 20 20 20 20 20 28 2a 20 36 . (hr (* 6
102e0 30 20 36 30 29 29 0a 09 20 28 64 61 79 20 20 20 0 60)).. (day
102f0 20 20 20 28 2a 20 32 34 20 68 72 29 29 0a 09 20 (* 24 hr))..
10300 28 79 72 20 20 20 20 20 20 20 28 2a 20 33 36 35 (yr (* 365
10310 20 64 61 79 29 29 20 3b 3b 20 79 65 61 72 0a 09 day)) ;; year..
10320 20 28 6d 6f 20 20 20 20 20 20 20 28 2f 20 79 72 (mo (/ yr
10330 20 31 32 29 29 0a 09 20 28 77 6b 20 20 20 20 20 12)).. (wk
10340 20 20 28 2a 20 64 61 79 20 37 29 29 29 0a 20 20 (* day 7))).
10350 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
10360 20 28 6c 61 6d 62 64 61 20 28 6d 61 78 2d 62 6c (lambda (max-bl
10370 6b 73 29 0a 20 20 20 20 20 20 20 28 66 6f 72 2d ks). (for-
10380 65 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 73 each..(lambda (s
10390 70 61 6e 29 20 3b 3b 20 35 20 32 20 31 0a 09 20 pan) ;; 5 2 1..
103a0 20 28 69 66 20 28 6e 6f 74 20 72 65 73 75 6c 74 (if (not result
103b0 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 ).. (for-ea
103c0 63 68 20 0a 09 20 20 20 20 20 20 20 28 6c 61 6d ch .. (lam
103d0 62 64 61 20 28 74 69 6d 65 75 6e 69 74 20 74 69 bda (timeunit ti
103e0 6d 65 73 79 6d 29 20 3b 3b 20 79 65 61 72 20 6d mesym) ;; year m
103f0 6f 6e 74 68 20 64 61 79 20 68 72 20 6d 69 6e 20 onth day hr min
10400 73 65 63 0a 09 09 20 28 69 66 20 28 6e 6f 74 20 sec... (if (not
10410 72 65 73 75 6c 74 29 0a 09 09 20 20 20 20 20 28 result)... (
10420 6c 65 74 2a 20 28 28 74 69 6d 65 2d 62 6c 6b 20 let* ((time-blk
10430 28 2a 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 (* span timeunit
10440 29 29 0a 09 09 09 20 20 20 20 28 6e 75 6d 2d 62 )).... (num-b
10450 6c 6b 73 20 28 71 75 6f 74 69 65 6e 74 20 64 65 lks (quotient de
10460 6c 74 61 74 20 74 69 6d 65 2d 62 6c 6b 29 29 29 ltat time-blk)))
10470 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 28 61 ... (if (a
10480 6e 64 20 28 3e 20 6e 75 6d 2d 62 6c 6b 73 20 34 nd (> num-blks 4
10490 29 28 3c 20 6e 75 6d 2d 62 6c 6b 73 20 6d 61 78 )(< num-blks max
104a0 2d 62 6c 6b 73 29 29 0a 09 09 09 20 20 20 28 6c -blks)).... (l
104b0 65 74 20 28 28 66 69 72 73 74 20 28 2a 20 28 71 et ((first (* (q
104c0 75 6f 74 69 65 6e 74 20 74 73 74 61 72 74 20 74 uotient tstart t
104d0 69 6d 65 2d 62 6c 6b 29 20 74 69 6d 65 2d 62 6c ime-blk) time-bl
104e0 6b 29 29 29 0a 09 09 09 20 20 20 20 20 28 73 65 k))).... (se
104f0 74 21 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 t! result (list
10500 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 20 74 69 span timeunit ti
10510 6d 65 2d 62 6c 6b 20 66 69 72 73 74 20 74 69 6d me-blk first tim
10520 65 73 79 6d 29 29 0a 09 09 09 20 20 20 20 20 29 esym)).... )
10530 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 6c 69 )))).. (li
10540 73 74 20 79 72 20 6d 6f 20 77 6b 20 64 61 79 20 st yr mo wk day
10550 68 72 20 6d 69 6e 20 31 29 0a 09 20 20 20 20 20 hr min 1)..
10560 20 20 27 28 20 20 20 20 20 79 20 20 6d 6f 20 77 '( y mo w
10570 20 20 64 20 20 20 68 20 20 6d 20 20 20 73 29 29 d h m s))
10580 29 29 0a 09 28 6c 69 73 74 20 38 20 36 20 35 20 ))..(list 8 6 5
10590 32 20 31 29 29 29 0a 20 20 20 20 20 27 28 35 20 2 1))). '(5
105a0 31 30 20 31 35 20 32 30 20 33 30 20 34 30 20 35 10 15 20 30 40 5
105b0 30 20 35 30 30 29 29 0a 20 20 20 20 28 69 66 20 0 500)). (if
105c0 76 61 6c 75 65 73 0a 09 28 61 70 70 6c 79 20 76 values..(apply v
105d0 61 6c 75 65 73 20 72 65 73 75 6c 74 29 0a 09 28 alues result)..(
105e0 76 61 6c 75 65 73 20 30 20 64 61 79 20 31 20 30 values 0 day 1 0
105f0 20 27 64 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 'd))))..;; give
10600 6e 20 78 20 79 20 6c 69 6d 20 72 65 74 75 72 6e n x y lim return
10610 20 74 68 65 20 63 72 6f 6e 20 65 78 70 61 6e 73 the cron expans
10620 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ion.;;.(define (
10630 63 6f 6d 6d 6f 6e 3a 65 78 70 61 6e 64 2d 63 72 common:expand-cr
10640 6f 6e 2d 73 6c 61 73 68 20 78 20 79 20 6c 69 6d on-slash x y lim
10650 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
10660 63 75 72 72 20 78 29 0a 09 20 20 20 20 20 28 72 curr x).. (r
10670 65 73 20 20 60 28 29 29 29 0a 20 20 20 20 28 69 es `())). (i
10680 66 20 28 3c 20 63 75 72 72 20 6c 69 6d 29 0a 09 f (< curr lim)..
10690 28 6c 6f 6f 70 20 28 2b 20 63 75 72 72 20 79 29 (loop (+ curr y)
106a0 20 28 63 6f 6e 73 20 63 75 72 72 20 72 65 73 29 (cons curr res)
106b0 29 0a 09 28 72 65 76 65 72 73 65 20 72 65 73 29 )..(reverse res)
106c0 29 29 29 0a 0a 3b 3b 20 65 78 70 61 6e 64 20 61 )))..;; expand a
106d0 20 63 6f 6d 70 6c 65 78 20 63 72 6f 6e 20 73 74 complex cron st
106e0 72 69 6e 67 20 74 6f 20 61 20 6c 69 73 74 20 6f ring to a list o
106f0 66 20 63 72 6f 6e 20 73 74 72 69 6e 67 73 0a 3b f cron strings.;
10700 3b 0a 3b 3b 20 20 78 2f 79 20 20 20 3d 3e 20 78 ;.;; x/y => x
10710 2c 20 78 2b 79 2c 20 78 2b 32 79 2c 20 78 2b 33 , x+y, x+2y, x+3
10720 79 20 77 68 69 6c 65 20 78 2b 4e 79 3c 6d 61 78 y while x+Ny<max
10730 5f 66 6f 72 5f 66 69 65 6c 64 0a 3b 3b 20 20 61 _for_field.;; a
10740 2c 62 2c 63 20 3d 3e 20 61 2c 20 62 20 2c 63 0a ,b,c => a, b ,c.
10750 3b 3b 0a 3b 3b 20 20 20 4e 4f 54 45 3a 20 77 69 ;;.;; NOTE: wi
10760 74 68 20 66 6c 61 74 74 65 6e 20 61 20 6c 6f 74 th flatten a lot
10770 20 6f 66 20 74 68 65 20 63 72 75 64 20 62 65 6c of the crud bel
10780 6f 77 20 63 61 6e 20 62 65 20 66 61 63 74 6f 72 ow can be factor
10790 65 64 20 64 6f 77 6e 2e 0a 3b 3b 0a 28 64 65 66 ed down..;;.(def
107a0 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e ine (common:cron
107b0 2d 65 78 70 61 6e 64 20 63 72 6f 6e 2d 73 74 72 -expand cron-str
107c0 29 0a 20 20 28 69 66 20 28 6c 69 73 74 3f 20 63 ). (if (list? c
107d0 72 6f 6e 2d 73 74 72 29 0a 20 20 20 20 20 20 28 ron-str). (
107e0 66 6c 61 74 74 65 6e 0a 20 20 20 20 20 20 20 28 flatten. (
107f0 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 78 20 fold (lambda (x
10800 72 65 73 29 0a 09 20 20 20 20 20 20 20 28 69 66 res).. (if
10810 20 28 6c 69 73 74 3f 20 78 29 0a 09 09 20 20 20 (list? x)...
10820 28 6c 65 74 20 28 28 6e 65 77 72 65 73 20 28 6d (let ((newres (m
10830 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 ap common:cron-e
10840 78 70 61 6e 64 20 78 29 29 29 0a 09 09 20 20 20 xpand x)))...
10850 20 20 28 61 70 70 65 6e 64 20 78 20 6e 65 77 72 (append x newr
10860 65 73 29 29 0a 09 09 20 20 20 28 63 6f 6e 73 20 es))... (cons
10870 78 20 72 65 73 29 29 29 0a 09 20 20 20 20 20 27 x res))).. '
10880 28 29 0a 09 20 20 20 20 20 63 72 6f 6e 2d 73 74 ().. cron-st
10890 72 29 29 20 3b 3b 20 28 6d 61 70 20 63 6f 6d 6d r)) ;; (map comm
108a0 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 63 on:cron-expand c
108b0 72 6f 6e 2d 73 74 72 29 29 0a 20 20 20 20 20 20 ron-str)).
108c0 28 6c 65 74 20 28 28 63 72 6f 6e 2d 69 74 65 6d (let ((cron-item
108d0 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
108e0 63 72 6f 6e 2d 73 74 72 29 29 0a 09 20 20 20 20 cron-str))..
108f0 28 73 6c 61 73 68 2d 72 78 20 20 20 28 72 65 67 (slash-rx (reg
10900 65 78 70 20 22 28 5c 5c 64 2b 29 2f 28 5c 5c 64 exp "(\\d+)/(\\d
10910 2b 29 22 29 29 0a 09 20 20 20 20 28 63 6f 6d 6d +)")).. (comm
10920 61 2d 72 78 20 20 20 28 72 65 67 65 78 70 20 22 a-rx (regexp "
10930 2e 2a 2c 2e 2a 22 29 29 0a 09 20 20 20 20 28 6d .*,.*")).. (m
10940 61 78 2d 76 61 6c 73 20 20 20 27 28 28 6d 69 6e ax-vals '((min
10950 20 20 20 20 20 20 20 20 2e 20 36 30 29 0a 09 09 . 60)...
10960 09 20 20 28 68 6f 75 72 20 20 20 20 20 20 20 2e . (hour .
10970 20 32 34 29 0a 09 09 09 20 20 28 64 61 79 6f 66 24).... (dayof
10980 6d 6f 6e 74 68 20 2e 20 32 38 29 20 3b 3b 3b 20 month . 28) ;;;
10990 42 55 47 21 21 21 21 20 54 68 69 73 20 77 69 6c BUG!!!! This wil
109a0 6c 20 62 65 20 61 20 62 75 67 20 66 6f 72 20 73 l be a bug for s
109b0 6f 6d 65 20 63 6f 6d 62 69 6e 61 74 69 6f 6e 73 ome combinations
109c0 0a 09 09 09 20 20 28 6d 6f 6e 74 68 20 20 20 20 .... (month
109d0 20 20 2e 20 31 32 29 0a 09 09 09 20 20 28 64 61 . 12).... (da
109e0 79 6f 66 77 65 65 6b 20 20 2e 20 37 29 29 29 29 yofweek . 7))))
109f0 0a 09 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 ..(if (< (length
10a00 20 63 72 6f 6e 2d 69 74 65 6d 73 29 20 35 29 20 cron-items) 5)
10a10 3b 3b 20 62 61 64 20 73 70 65 63 0a 09 20 20 20 ;; bad spec..
10a20 20 63 72 6f 6e 2d 73 74 72 20 3b 3b 20 60 28 2c cron-str ;; `(,
10a30 63 72 6f 6e 2d 73 74 72 29 20 20 20 20 20 20 20 cron-str)
10a40 20 20 20 20 20 20 20 3b 3b 20 6a 75 73 74 20 72 ;; just r
10a50 65 74 75 72 6e 20 74 68 65 20 73 74 72 69 6e 67 eturn the string
10a60 2c 20 73 6f 6d 65 74 68 69 6e 67 20 64 6f 77 6e , something down
10a70 73 74 72 65 61 6d 20 77 69 6c 6c 20 66 69 78 20 stream will fix
10a80 69 74 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f it.. (let loo
10a90 70 20 28 28 68 65 64 20 20 28 63 61 72 20 63 72 p ((hed (car cr
10aa0 6f 6e 2d 69 74 65 6d 73 29 29 0a 09 09 20 20 20 on-items))...
10ab0 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 63 (tal (cdr c
10ac0 72 6f 6e 2d 69 74 65 6d 73 29 29 0a 09 09 20 20 ron-items))...
10ad0 20 20 20 20 20 28 74 79 70 65 20 27 6d 69 6e 29 (type 'min)
10ae0 0a 09 09 20 20 20 20 20 20 20 28 74 79 70 65 2d ... (type-
10af0 74 61 6c 20 27 28 68 6f 75 72 20 64 61 79 6f 66 tal '(hour dayof
10b00 6d 6f 6e 74 68 20 6d 6f 6e 74 68 20 64 61 79 6f month month dayo
10b10 66 77 65 65 6b 29 29 0a 09 09 20 20 20 20 20 20 fweek))...
10b20 20 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 20 (res '()))..
10b30 20 20 20 20 28 72 65 67 65 78 2d 63 61 73 65 0a (regex-case.
10b40 09 09 20 20 68 65 64 0a 09 09 28 73 6c 61 73 68 .. hed...(slash
10b50 2d 72 78 20 28 20 5f 20 62 61 73 65 20 69 6e 63 -rx ( _ base inc
10b60 72 20 29 20 28 6c 65 74 2a 20 28 28 62 61 73 65 r ) (let* ((base
10b70 6e 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 n (stri
10b80 6e 67 2d 3e 6e 75 6d 62 65 72 20 62 61 73 65 29 ng->number base)
10b90 29 0a 09 09 09 09 09 09 20 28 69 6e 63 72 6e 20 )....... (incrn
10ba0 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
10bb0 2d 3e 6e 75 6d 62 65 72 20 69 6e 63 72 29 29 0a ->number incr)).
10bc0 09 09 09 09 09 09 20 28 65 78 70 61 6e 64 65 64 ...... (expanded
10bd0 2d 76 61 6c 73 20 20 28 63 6f 6d 6d 6f 6e 3a 65 -vals (common:e
10be0 78 70 61 6e 64 2d 63 72 6f 6e 2d 73 6c 61 73 68 xpand-cron-slash
10bf0 20 62 61 73 65 6e 20 69 6e 63 72 6e 20 28 61 6c basen incrn (al
10c00 69 73 74 2d 72 65 66 20 74 79 70 65 20 6d 61 78 ist-ref type max
10c10 2d 76 61 6c 73 29 29 29 0a 09 09 09 09 09 09 20 -vals))).......
10c20 28 6e 65 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 20 (new-list-crons
10c30 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 78 (fold (lambda (x
10c40 20 6d 79 72 65 73 29 0a 09 09 09 09 09 09 09 09 myres).........
10c50 09 20 28 63 6f 6e 73 20 28 63 6f 6e 63 20 28 69 . (cons (conc (i
10c60 66 20 28 6e 75 6c 6c 3f 20 72 65 73 29 0a 09 09 f (null? res)...
10c70 09 09 09 09 09 09 09 09 09 20 22 22 0a 09 09 09 ......... ""....
10c80 09 09 09 09 09 09 09 09 20 28 63 6f 6e 63 20 28 ........ (conc (
10c90 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
10ca0 73 65 20 72 65 73 20 22 20 22 29 20 22 20 22 29 se res " ") " ")
10cb0 29 0a 09 09 09 09 09 09 09 09 09 09 20 20 20 20 )...........
10cc0 20 78 20 22 20 22 20 28 73 74 72 69 6e 67 2d 69 x " " (string-i
10cd0 6e 74 65 72 73 70 65 72 73 65 20 74 61 6c 20 22 ntersperse tal "
10ce0 20 22 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 "))..........
10cf0 20 20 20 20 20 6d 79 72 65 73 29 29 0a 09 09 09 myres))....
10d00 09 09 09 09 09 20 20 20 20 20 20 20 27 28 29 20 ..... '()
10d10 65 78 70 61 6e 64 65 64 2d 76 61 6c 73 29 29 29 expanded-vals)))
10d20 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 28 70 72 ...... ;; (pr
10d30 69 6e 74 20 22 6e 65 77 2d 6c 69 73 74 2d 63 72 int "new-list-cr
10d40 6f 6e 73 3a 20 22 20 6e 65 77 2d 6c 69 73 74 2d ons: " new-list-
10d50 63 72 6f 6e 73 29 0a 09 09 09 09 09 20 20 20 20 crons)......
10d60 3b 3b 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 ;; (fold (lambda
10d70 20 28 78 20 72 65 73 29 0a 09 09 09 09 09 20 20 (x res)......
10d80 20 20 3b 3b 20 09 20 20 20 20 28 69 66 20 28 6c ;; . (if (l
10d90 69 73 74 3f 20 78 29 0a 09 09 09 09 09 20 20 20 ist? x)......
10da0 20 3b 3b 20 09 09 28 6c 65 74 20 28 28 6e 65 77 ;; ..(let ((new
10db0 72 65 73 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a res (map common:
10dc0 63 72 6f 6e 2d 65 78 70 61 6e 64 20 78 29 29 29 cron-expand x)))
10dd0 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 09 09 20 ...... ;; ..
10de0 20 28 61 70 70 65 6e 64 20 78 20 6e 65 77 72 65 (append x newre
10df0 73 29 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 s))...... ;;
10e00 09 09 28 63 6f 6e 73 20 78 20 72 65 73 29 29 29 ..(cons x res)))
10e10 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 09 20 20 ...... ;; .
10e20 27 28 29 0a 09 09 09 09 09 20 20 20 20 28 66 6c '()...... (fl
10e30 61 74 74 65 6e 20 28 6d 61 70 20 63 6f 6d 6d 6f atten (map commo
10e40 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 6e 65 n:cron-expand ne
10e50 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 29 29 29 29 w-list-crons))))
10e60 0a 09 09 3b 3b 09 09 09 09 09 20 20 20 20 28 6d ...;;..... (m
10e70 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 ap common:cron-e
10e80 78 70 61 6e 64 20 28 6d 61 70 20 63 6f 6d 6d 6f xpand (map commo
10e90 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 6e 65 n:cron-expand ne
10ea0 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 29 29 29 29 w-list-crons))))
10eb0 0a 09 09 28 65 6c 73 65 20 28 69 66 20 28 6e 75 ...(else (if (nu
10ec0 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 63 72 ll? tal).... cr
10ed0 6f 6e 2d 73 74 72 0a 09 09 09 20 20 28 6c 6f 6f on-str.... (loo
10ee0 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
10ef0 74 61 6c 29 28 63 61 72 20 74 79 70 65 2d 74 61 tal)(car type-ta
10f00 6c 29 28 63 64 72 20 74 79 70 65 2d 74 61 6c 29 l)(cdr type-tal)
10f10 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 (append res (lis
10f20 74 20 68 65 64 29 29 29 29 29 29 29 29 29 29 29 t hed)))))))))))
10f30 0a 09 09 20 20 20 20 20 20 0a 09 20 20 20 20 0a ... .. .
10f40 3b 3b 20 67 69 76 65 6e 20 61 20 63 72 6f 6e 20 ;; given a cron
10f50 73 74 72 69 6e 67 20 61 6e 64 20 74 68 65 20 6c string and the l
10f60 61 73 74 20 74 69 6d 65 20 65 76 65 6e 74 20 77 ast time event w
10f70 61 73 20 70 72 6f 63 65 73 73 65 64 20 72 65 74 as processed ret
10f80 75 72 6e 20 23 74 20 74 6f 20 72 75 6e 20 6f 72 urn #t to run or
10f90 20 23 66 20 74 6f 20 6e 6f 74 20 72 75 6e 0a 3b #f to not run.;
10fa0 3b 0a 3b 3b 20 20 6d 69 6e 20 20 20 20 68 6f 75 ;.;; min hou
10fb0 72 20 20 20 64 61 79 6f 66 6d 6f 6e 74 68 20 6d r dayofmonth m
10fc0 6f 6e 74 68 20 20 64 61 79 6f 66 77 65 65 6b 0a onth dayofweek.
10fd0 3b 3b 20 30 2d 35 39 20 20 20 20 30 2d 32 33 20 ;; 0-59 0-23
10fe0 20 20 31 2d 33 31 20 20 20 20 20 20 20 31 2d 31 1-31 1-1
10ff0 32 20 20 20 30 2d 36 20 20 20 20 20 20 20 20 20 2 0-6
11000 20 23 23 23 20 4e 4f 54 45 3a 20 64 61 79 6f 66 ### NOTE: dayof
11010 77 65 65 6b 20 64 6f 65 73 20 6e 6f 74 20 69 6e week does not in
11020 63 6c 75 64 65 20 37 0a 3b 3b 0a 3b 3b 20 20 23 clude 7.;;.;; #
11030 74 20 3d 3e 20 79 65 73 2c 20 72 75 6e 20 74 68 t => yes, run th
11040 65 20 6a 6f 62 0a 3b 3b 20 20 23 66 20 3d 3e 20 e job.;; #f =>
11050 6e 6f 2c 20 64 6f 20 6e 6f 74 20 72 75 6e 20 74 no, do not run t
11060 68 65 20 6a 6f 62 0a 3b 3b 0a 28 64 65 66 69 6e he job.;;.(defin
11070 65 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 e (common:cron-e
11080 76 65 6e 74 20 63 72 6f 6e 2d 73 74 72 20 6e 6f vent cron-str no
11090 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 w-seconds-in las
110a0 74 2d 64 6f 6e 65 29 20 3b 3b 20 72 65 66 2d 73 t-done) ;; ref-s
110b0 65 63 6f 6e 64 73 20 3d 20 23 66 20 69 73 20 4e econds = #f is N
110c0 4f 57 2e 0a 20 20 28 6c 65 74 2a 20 28 28 63 72 OW.. (let* ((cr
110d0 6f 6e 2d 69 74 65 6d 73 20 20 20 20 20 28 6d 61 on-items (ma
110e0 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 p string->number
110f0 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 63 (string-split c
11100 72 6f 6e 2d 73 74 72 29 29 29 0a 09 20 28 6e 6f ron-str))).. (no
11110 77 2d 73 65 63 6f 6e 64 73 20 20 20 20 28 6f 72 w-seconds (or
11120 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 now-seconds-in
11130 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
11140 29 29 29 0a 09 20 28 6e 6f 77 2d 74 69 6d 65 20 ))).. (now-time
11150 20 20 20 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e (seconds->
11160 6c 6f 63 61 6c 2d 74 69 6d 65 20 6e 6f 77 2d 73 local-time now-s
11170 65 63 6f 6e 64 73 29 29 0a 09 20 28 6c 61 73 74 econds)).. (last
11180 2d 64 6f 6e 65 2d 74 69 6d 65 20 28 73 65 63 6f -done-time (seco
11190 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 nds->local-time
111a0 6c 61 73 74 2d 64 6f 6e 65 29 29 0a 09 20 28 61 last-done)).. (a
111b0 6c 6c 2d 74 69 6d 65 73 20 20 20 20 20 20 28 6d ll-times (m
111c0 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
111d0 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
111e0 22 63 72 6f 6e 2d 69 74 65 6d 73 3a 20 22 20 63 "cron-items: " c
111f0 72 6f 6e 2d 69 74 65 6d 73 20 22 28 6c 65 6e 67 ron-items "(leng
11200 74 68 20 63 72 6f 6e 2d 69 74 65 6d 73 29 3a 20 th cron-items):
11210 22 20 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 " (length cron-i
11220 74 65 6d 73 29 29 0a 20 20 20 20 28 69 66 20 28 tems)). (if (
11230 6e 6f 74 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 not (eq? (length
11240 20 63 72 6f 6e 2d 69 74 65 6d 73 29 20 35 29 29 cron-items) 5))
11250 20 3b 3b 20 64 6f 6e 27 74 20 65 76 65 6e 20 74 ;; don't even t
11260 72 79 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 ry to figure out
11270 20 6a 75 6e 6b 20 73 74 72 69 6e 67 73 0a 09 23 junk strings..#
11280 66 0a 09 28 6d 61 74 63 68 2d 6c 65 74 20 28 28 f..(match-let ((
11290 28 20 20 20 20 20 63 6d 69 6e 20 63 68 6f 75 72 ( cmin chour
112a0 20 63 64 61 79 6f 66 6d 6f 6e 74 68 20 63 6d 6f cdayofmonth cmo
112b0 6e 74 68 20 20 20 20 63 64 61 79 6f 66 77 65 65 nth cdayofwee
112c0 6b 29 0a 09 09 20 20 20 20 20 63 72 6f 6e 2d 69 k)... cron-i
112d0 74 65 6d 73 29 0a 09 09 20 20 20 20 3b 3b 20 30 tems)... ;; 0
112e0 20 20 20 20 20 31 20 20 20 20 32 20 20 20 20 20 1 2
112f0 20 20 20 33 20 20 20 20 20 20 20 20 20 34 20 20 3 4
11300 20 20 35 20 20 20 20 20 20 36 0a 09 09 20 20 20 5 6...
11310 20 28 28 6e 73 65 63 20 6e 6d 69 6e 20 6e 68 6f ((nsec nmin nho
11320 75 72 20 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 6e ur ndayofmonth n
11330 6d 6f 6e 74 68 20 6e 79 72 20 6e 64 61 79 6f 66 month nyr ndayof
11340 77 65 65 6b 20 6e 37 20 6e 38 20 6e 39 29 0a 09 week n7 n8 n9)..
11350 09 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c . (vector->l
11360 69 73 74 20 6e 6f 77 2d 74 69 6d 65 29 29 0a 09 ist now-time))..
11370 09 20 20 20 20 28 28 6c 73 65 63 20 6c 6d 69 6e . ((lsec lmin
11380 20 6c 68 6f 75 72 20 6c 64 61 79 6f 66 6d 6f 6e lhour ldayofmon
11390 74 68 20 6c 6d 6f 6e 74 68 20 6c 79 72 20 6c 64 th lmonth lyr ld
113a0 61 79 6f 66 77 65 65 6b 20 6c 37 20 6c 38 20 6c ayofweek l7 l8 l
113b0 39 29 0a 09 09 20 20 20 20 20 28 76 65 63 74 6f 9)... (vecto
113c0 72 2d 3e 6c 69 73 74 20 6c 61 73 74 2d 64 6f 6e r->list last-don
113d0 65 2d 74 69 6d 65 29 29 29 0a 09 20 20 3b 3b 20 e-time))).. ;;
113e0 63 72 65 61 74 65 20 61 6c 6c 20 70 6f 73 73 69 create all possi
113f0 62 6c 65 20 74 69 6d 65 20 73 6c 6f 74 73 0a 09 ble time slots..
11400 20 20 3b 3b 20 72 65 6d 6f 76 65 20 69 6e 76 61 ;; remove inva
11410 6c 69 64 20 73 6c 6f 74 73 20 64 75 65 20 74 6f lid slots due to
11420 20 28 66 6f 72 20 65 78 61 6d 70 6c 65 29 20 64 (for example) d
11430 61 79 20 6f 66 20 77 65 65 6b 0a 09 20 20 3b 3b ay of week.. ;;
11440 20 67 65 74 20 74 68 65 20 73 74 61 72 74 20 61 get the start a
11450 6e 64 20 65 6e 64 20 65 6e 74 72 69 65 73 20 66 nd end entries f
11460 6f 72 20 74 68 65 20 72 65 66 2d 73 65 63 6f 6e or the ref-secon
11470 64 73 20 28 63 75 72 72 65 6e 74 29 20 74 69 6d ds (current) tim
11480 65 0a 09 20 20 3b 3b 20 69 66 20 6c 61 73 74 2d e.. ;; if last-
11490 64 6f 6e 65 20 3e 20 72 65 66 2d 73 65 63 6f 6e done > ref-secon
114a0 64 73 20 3d 3e 20 74 68 69 73 20 69 73 20 61 6e ds => this is an
114b0 20 45 52 52 4f 52 21 0a 09 20 20 3b 3b 20 64 6f ERROR!.. ;; do
114c0 65 73 20 74 68 65 20 6c 61 73 74 2d 64 6f 6e 65 es the last-done
114d0 20 74 69 6d 65 20 66 61 6c 6c 20 69 6e 20 74 68 time fall in th
114e0 65 20 6c 65 67 69 74 20 72 65 67 69 6f 6e 3f 0a e legit region?.
114f0 09 20 20 3b 3b 20 20 20 20 79 65 73 20 3d 3e 20 . ;; yes =>
11500 23 66 20 20 64 6f 20 6e 6f 74 20 72 75 6e 20 61 #f do not run a
11510 67 61 69 6e 20 74 68 69 73 20 63 6f 6d 6d 61 6e gain this comman
11520 64 0a 09 20 20 3b 3b 20 20 20 20 6e 6f 20 20 3d d.. ;; no =
11530 3e 20 23 74 20 20 6f 6b 20 74 6f 20 72 75 6e 20 > #t ok to run
11540 74 68 65 20 63 6f 6d 6d 61 6e 64 0a 09 20 20 28 the command.. (
11550 66 6f 72 2d 65 61 63 68 20 3b 3b 20 6d 6f 6e 74 for-each ;; mont
11560 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6d h.. (lambda (m
11570 6f 6e 74 68 29 0a 09 20 20 20 20 20 28 66 6f 72 onth).. (for
11580 2d 65 61 63 68 20 3b 3b 20 64 61 79 6f 66 6d 6f -each ;; dayofmo
11590 6e 74 68 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 nth.. (lamb
115a0 64 61 20 28 64 6f 6d 29 0a 09 09 28 66 6f 72 2d da (dom)...(for-
115b0 65 61 63 68 0a 09 09 20 28 6c 61 6d 62 64 61 20 each... (lambda
115c0 28 68 72 29 20 3b 3b 20 68 6f 75 72 0a 09 09 20 (hr) ;; hour...
115d0 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 (for-each...
115e0 20 20 28 6c 61 6d 62 64 61 20 28 6d 69 6e 75 74 (lambda (minut
115f0 65 29 20 3b 3b 20 6d 69 6e 75 74 65 0a 09 09 20 e) ;; minute...
11600 20 20 20 20 20 28 6c 65 74 20 28 28 63 6f 70 79 (let ((copy
11610 2d 6e 6f 77 20 28 61 70 70 6c 79 20 76 65 63 74 -now (apply vect
11620 6f 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 or (vector->list
11630 20 6e 6f 77 2d 74 69 6d 65 29 29 29 29 0a 09 09 now-time))))...
11640 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 6f .(vector-set! co
11650 70 79 2d 6e 6f 77 20 30 20 30 29 20 3b 3b 20 66 py-now 0 0) ;; f
11660 6f 72 63 65 20 73 65 63 6f 6e 64 73 20 74 6f 20 orce seconds to
11670 7a 65 72 6f 0a 09 09 09 28 76 65 63 74 6f 72 2d zero....(vector-
11680 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 20 31 20 set! copy-now 1
11690 6d 69 6e 75 74 65 29 0a 09 09 09 28 76 65 63 74 minute)....(vect
116a0 6f 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 or-set! copy-now
116b0 20 32 20 68 72 29 0a 09 09 09 28 76 65 63 74 6f 2 hr)....(vecto
116c0 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 20 r-set! copy-now
116d0 33 20 64 6f 6d 29 20 20 3b 3b 20 64 6f 6d 20 69 3 dom) ;; dom i
116e0 73 20 61 6c 72 65 61 64 79 20 63 6f 72 72 65 63 s already correc
116f0 74 65 64 20 66 6f 72 20 7a 65 72 6f 20 72 65 66 ted for zero ref
11700 65 72 65 6e 63 65 64 0a 09 09 09 28 76 65 63 74 erenced....(vect
11710 6f 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 or-set! copy-now
11720 20 34 20 6d 6f 6e 74 68 29 0a 09 09 09 28 6c 65 4 month)....(le
11730 74 2a 20 28 28 63 6f 70 79 2d 6e 6f 77 2d 73 65 t* ((copy-now-se
11740 63 73 20 28 6c 6f 63 61 6c 2d 74 69 6d 65 2d 3e cs (local-time->
11750 73 65 63 6f 6e 64 73 20 63 6f 70 79 2d 6e 6f 77 seconds copy-now
11760 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e 65 )).... (ne
11770 77 2d 63 6f 70 79 20 20 20 20 20 20 28 73 65 63 w-copy (sec
11780 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
11790 20 63 6f 70 79 2d 6e 6f 77 2d 73 65 63 73 29 29 copy-now-secs))
117a0 29 20 3b 3b 20 72 65 6d 61 6b 65 20 74 68 65 20 ) ;; remake the
117b0 74 69 6d 65 20 76 65 63 74 6f 72 0a 09 09 09 20 time vector....
117c0 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 63 64 (if (or (not cd
117d0 61 79 6f 66 77 65 65 6b 29 0a 09 09 09 09 20 20 ayofweek).....
117e0 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d (equal? (vector-
117f0 72 65 66 20 6e 65 77 2d 63 6f 70 79 20 36 29 0a ref new-copy 6).
11800 09 09 09 09 09 20 20 63 64 61 79 6f 66 77 65 65 ..... cdayofwee
11810 6b 29 29 20 3b 3b 20 69 66 20 74 68 65 20 64 61 k)) ;; if the da
11820 79 20 69 73 20 73 70 65 63 69 66 69 65 64 20 61 y is specified a
11830 6e 64 20 61 20 6d 61 74 63 68 20 4f 52 20 69 66 nd a match OR if
11840 20 74 68 65 20 64 61 79 20 69 73 20 4e 4f 54 20 the day is NOT
11850 73 70 65 63 69 66 69 65 64 0a 09 09 09 20 20 20 specified....
11860 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
11870 63 64 61 79 6f 66 6d 6f 6e 74 68 29 0a 09 09 09 cdayofmonth)....
11880 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 . (equal? (
11890 76 65 63 74 6f 72 2d 72 65 66 20 6e 65 77 2d 63 vector-ref new-c
118a0 6f 70 79 20 33 29 0a 09 09 09 09 09 20 20 20 20 opy 3)......
118b0 20 20 28 2b 20 31 20 63 64 61 79 6f 66 6d 6f 6e (+ 1 cdayofmon
118c0 74 68 29 29 29 20 3b 3b 20 69 66 20 74 68 65 20 th))) ;; if the
118d0 6d 6f 6e 74 68 20 69 73 20 73 70 65 63 69 66 69 month is specifi
118e0 65 64 20 61 6e 64 20 61 20 6d 61 74 63 68 20 4f ed and a match O
118f0 52 20 69 66 20 74 68 65 20 6d 6f 6e 74 68 20 69 R if the month i
11900 73 20 4e 4f 54 20 73 70 65 63 69 66 69 65 64 0a s NOT specified.
11910 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c .... (hash-tabl
11920 65 2d 73 65 74 21 20 61 6c 6c 2d 74 69 6d 65 73 e-set! all-times
11930 20 63 6f 70 79 2d 6e 6f 77 2d 73 65 63 73 20 6e copy-now-secs n
11940 65 77 2d 63 6f 70 79 29 29 29 29 29 29 0a 09 09 ew-copy))))))...
11950 20 20 20 20 28 69 66 20 63 6d 69 6e 0a 09 09 09 (if cmin....
11960 60 28 2c 63 6d 69 6e 29 20 20 3b 3b 20 69 66 20 `(,cmin) ;; if
11970 67 69 76 65 6e 20 63 6d 69 6e 2c 20 68 61 76 65 given cmin, have
11980 20 74 6f 20 75 73 65 20 69 74 0a 09 09 09 28 6c to use it....(l
11990 69 73 74 20 28 2d 20 6e 6d 69 6e 20 31 29 20 6e ist (- nmin 1) n
119a0 6d 69 6e 20 28 2b 20 6e 6d 69 6e 20 31 29 29 29 min (+ nmin 1)))
119b0 29 29 20 3b 3b 20 6d 69 6e 75 74 65 0a 09 09 20 )) ;; minute...
119c0 28 69 66 20 63 68 6f 75 72 0a 09 09 20 20 20 20 (if chour...
119d0 20 60 28 2c 63 68 6f 75 72 29 0a 09 09 20 20 20 `(,chour)...
119e0 20 20 28 6c 69 73 74 20 28 2d 20 6e 68 6f 75 72 (list (- nhour
119f0 20 31 29 20 6e 68 6f 75 72 20 28 2b 20 6e 68 6f 1) nhour (+ nho
11a00 75 72 20 31 29 29 29 29 29 20 3b 3b 20 68 6f 75 ur 1))))) ;; hou
11a10 72 0a 09 20 20 20 20 20 20 28 69 66 20 63 64 61 r.. (if cda
11a20 79 6f 66 6d 6f 6e 74 68 0a 09 09 20 20 60 28 2c yofmonth... `(,
11a30 63 64 61 79 6f 66 6d 6f 6e 74 68 29 0a 09 09 20 cdayofmonth)...
11a40 20 28 6c 69 73 74 20 28 2d 20 6e 64 61 79 6f 66 (list (- ndayof
11a50 6d 6f 6e 74 68 20 31 29 20 6e 64 61 79 6f 66 6d month 1) ndayofm
11a60 6f 6e 74 68 20 28 2b 20 6e 64 61 79 6f 66 6d 6f onth (+ ndayofmo
11a70 6e 74 68 20 31 29 29 29 29 29 0a 09 20 20 20 28 nth 1))))).. (
11a80 69 66 20 63 6d 6f 6e 74 68 0a 09 20 20 20 20 20 if cmonth..
11a90 20 20 60 28 2c 63 6d 6f 6e 74 68 29 0a 09 20 20 `(,cmonth)..
11aa0 20 20 20 20 20 28 6c 69 73 74 20 28 2d 20 6e 6d (list (- nm
11ab0 6f 6e 74 68 20 31 29 20 6e 6d 6f 6e 74 68 20 28 onth 1) nmonth (
11ac0 2b 20 6e 6d 6f 6e 74 68 20 31 29 29 29 29 0a 09 + nmonth 1))))..
11ad0 20 20 28 6c 65 74 20 28 28 62 65 66 6f 72 65 20 (let ((before
11ae0 23 66 29 0a 09 09 28 69 73 2d 69 6e 20 20 23 66 #f)...(is-in #f
11af0 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 )).. (for-eac
11b00 68 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h.. (lambda
11b10 28 6d 6f 6d 65 6e 74 29 0a 09 20 20 20 20 20 20 (moment)..
11b20 20 28 69 66 20 28 61 6e 64 20 62 65 66 6f 72 65 (if (and before
11b30 0a 09 09 09 28 3c 3d 20 62 65 66 6f 72 65 20 6e ....(<= before n
11b40 6f 77 2d 73 65 63 6f 6e 64 73 29 0a 09 09 09 28 ow-seconds)....(
11b50 3e 3d 20 6d 6f 6d 65 6e 74 20 6e 6f 77 2d 73 65 >= moment now-se
11b60 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 28 62 65 conds))... (be
11b70 67 69 6e 0a 09 09 20 20 20 20 20 3b 3b 20 28 70 gin... ;; (p
11b80 72 69 6e 74 29 0a 09 09 20 20 20 20 20 3b 3b 20 rint)... ;;
11b90 28 70 72 69 6e 74 20 22 42 65 66 6f 72 65 3a 20 (print "Before:
11ba0 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
11bb0 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
11bc0 74 69 6d 65 20 62 65 66 6f 72 65 29 29 29 0a 09 time before)))..
11bd0 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 . ;; (print
11be0 22 4e 6f 77 3a 20 20 20 20 22 20 28 74 69 6d 65 "Now: " (time
11bf0 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 ->string (second
11c00 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6e 6f s->local-time no
11c10 77 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 20 w-seconds)))...
11c20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 41 ;; (print "A
11c30 66 74 65 72 3a 20 20 22 20 28 74 69 6d 65 2d 3e fter: " (time->
11c40 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d string (seconds-
11c50 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6d 6f 6d 65 >local-time mome
11c60 6e 74 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 nt)))... ;;
11c70 28 70 72 69 6e 74 20 22 4c 61 73 74 3a 20 20 20 (print "Last:
11c80 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
11c90 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
11ca0 74 69 6d 65 20 6c 61 73 74 2d 64 6f 6e 65 29 29 time last-done))
11cb0 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 3c 20 )... (if (<
11cc0 20 6c 61 73 74 2d 64 6f 6e 65 20 62 65 66 6f 72 last-done befor
11cd0 65 29 0a 09 09 09 20 28 73 65 74 21 20 69 73 2d e).... (set! is-
11ce0 69 6e 20 62 65 66 6f 72 65 29 29 0a 09 09 20 20 in before))...
11cf0 20 20 20 29 29 0a 09 20 20 20 20 20 20 20 28 73 )).. (s
11d00 65 74 21 20 62 65 66 6f 72 65 20 6d 6f 6d 65 6e et! before momen
11d10 74 29 29 0a 09 20 20 20 20 20 28 73 6f 72 74 20 t)).. (sort
11d20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
11d30 20 61 6c 6c 2d 74 69 6d 65 73 29 20 3c 29 29 0a all-times) <)).
11d40 09 20 20 20 20 69 73 2d 69 6e 29 29 29 29 29 0a . is-in))))).
11d50 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
11d60 3a 65 78 74 65 6e 64 65 64 2d 63 72 6f 6e 20 20 :extended-cron
11d70 63 72 6f 6e 2d 73 74 72 20 6e 6f 77 2d 73 65 63 cron-str now-sec
11d80 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 2d 64 6f 6e onds-in last-don
11d90 65 29 0a 20 20 28 6c 65 74 20 28 28 65 78 70 61 e). (let ((expa
11da0 6e 64 65 64 2d 63 72 6f 6e 20 28 63 6f 6d 6d 6f nded-cron (commo
11db0 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 63 72 n:cron-expand cr
11dc0 6f 6e 2d 73 74 72 29 29 29 0a 20 20 20 20 28 69 on-str))). (i
11dd0 66 20 28 73 74 72 69 6e 67 3f 20 65 78 70 61 6e f (string? expan
11de0 64 65 64 2d 63 72 6f 6e 29 0a 09 28 63 6f 6d 6d ded-cron)..(comm
11df0 6f 6e 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 65 78 on:cron-event ex
11e00 70 61 6e 64 65 64 2d 63 72 6f 6e 20 6e 6f 77 2d panded-cron now-
11e10 73 65 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 2d seconds-in last-
11e20 64 6f 6e 65 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 done)..(let loop
11e30 20 28 28 68 65 64 20 28 63 61 72 20 65 78 70 61 ((hed (car expa
11e40 6e 64 65 64 2d 63 72 6f 6e 29 29 0a 09 09 20 20 nded-cron))...
11e50 20 28 74 61 6c 20 28 63 64 72 20 65 78 70 61 6e (tal (cdr expan
11e60 64 65 64 2d 63 72 6f 6e 29 29 29 0a 09 20 20 28 ded-cron))).. (
11e70 69 66 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d if (common:cron-
11e80 65 76 65 6e 74 20 68 65 64 20 6e 6f 77 2d 73 65 event hed now-se
11e90 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 2d 64 6f conds-in last-do
11ea0 6e 65 29 0a 09 20 20 20 20 20 20 23 74 0a 09 20 ne).. #t..
11eb0 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
11ec0 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 20 tal)... #f...
11ed0 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
11ee0 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a cdr tal)))))))).
11ef0 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
11f00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f30 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 4f =========.;; C O
11f40 20 4c 20 4f 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d L O R S.;;=====
11f50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11f90 3d 0a 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 =. .(define
11fa0 20 28 63 6f 6d 6d 6f 6e 3a 6e 61 6d 65 2d 3e 69 (common:name->i
11fb0 75 70 2d 63 6f 6c 6f 72 20 6e 61 6d 65 29 0a 20 up-color name).
11fc0 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
11fd0 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 symbol (string-d
11fe0 6f 77 6e 63 61 73 65 20 6e 61 6d 65 29 29 0a 20 owncase name)).
11ff0 20 20 20 28 28 72 65 64 29 20 20 20 20 22 32 32 ((red) "22
12000 33 20 33 33 20 34 39 22 29 0a 20 20 20 20 28 28 3 33 49"). ((
12010 67 72 65 79 29 20 20 20 22 31 39 32 20 31 39 32 grey) "192 192
12020 20 31 39 32 22 29 0a 20 20 20 20 28 28 6f 72 61 192"). ((ora
12030 6e 67 65 29 20 22 32 35 35 20 31 37 32 20 31 33 nge) "255 172 13
12040 22 29 0a 20 20 20 20 28 28 70 75 72 70 6c 65 29 "). ((purple)
12050 20 22 54 68 69 73 20 69 73 20 75 6e 66 69 6e 69 "This is unfini
12060 73 68 65 64 20 2e 2e 2e 22 29 29 29 0a 0a 3b 3b shed ...")))..;;
12070 20 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e (define (common
12080 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 6f 72 2d 73 :get-color-for-s
12090 74 61 74 65 2d 73 74 61 74 75 73 20 73 74 61 74 tate-status stat
120a0 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 28 e status).;; (
120b0 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
120c0 6d 62 6f 6c 20 73 74 61 74 65 29 0a 3b 3b 20 20 mbol state).;;
120d0 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 29 0a ((COMPLETED).
120e0 3b 3b 20 20 20 20 20 20 28 63 61 73 65 20 28 73 ;; (case (s
120f0 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 tring->symbol st
12100 61 74 75 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 atus).;;
12110 28 28 50 41 53 53 29 20 20 20 20 20 20 20 20 22 ((PASS) "
12120 37 30 20 20 32 34 39 20 37 33 22 29 0a 3b 3b 20 70 249 73").;;
12130 20 20 20 20 20 20 20 28 28 57 41 52 4e 20 57 41 ((WARN WA
12140 49 56 45 44 29 20 22 32 35 35 20 31 37 32 20 31 IVED) "255 172 1
12150 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 3").;; ((
12160 53 4b 49 50 29 20 20 20 20 20 20 20 20 22 32 33 SKIP) "23
12170 30 20 32 33 30 20 30 22 29 0a 3b 3b 20 20 20 20 0 230 0").;;
12180 20 20 20 20 28 65 6c 73 65 20 22 32 32 33 20 33 (else "223 3
12190 33 20 34 39 22 29 29 29 0a 3b 3b 20 20 20 20 20 3 49"))).;;
121a0 28 28 4c 41 55 4e 43 48 45 44 29 20 20 20 20 20 ((LAUNCHED)
121b0 20 20 20 20 22 31 30 31 20 31 32 33 20 31 34 32 "101 123 142
121c0 22 29 0a 3b 3b 20 20 20 20 20 28 28 43 48 45 43 ").;; ((CHEC
121d0 4b 29 20 20 20 20 20 20 20 20 20 20 20 20 22 32 K) "2
121e0 35 35 20 31 30 30 20 35 30 22 29 0a 3b 3b 20 20 55 100 50").;;
121f0 20 20 20 28 28 52 45 4d 4f 54 45 48 4f 53 54 53 ((REMOTEHOSTS
12200 54 41 52 54 29 20 20 22 35 30 20 20 31 33 30 20 TART) "50 130
12210 31 39 35 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 195").;; ((R
12220 55 4e 4e 49 4e 47 29 20 20 20 20 20 20 20 20 20 UNNING)
12230 20 22 39 20 20 20 31 33 31 20 32 33 32 22 29 0a "9 131 232").
12240 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c 52 45 51 ;; ((KILLREQ
12250 29 20 20 20 20 20 20 20 20 20 20 22 33 39 20 20 ) "39
12260 38 32 20 20 32 30 36 22 29 0a 3b 3b 20 20 20 20 82 206").;;
12270 20 28 28 4b 49 4c 4c 45 44 29 20 20 20 20 20 20 ((KILLED)
12280 20 20 20 20 20 22 32 33 34 20 31 30 31 20 31 37 "234 101 17
12290 22 29 0a 3b 3b 20 20 20 20 20 28 28 4e 4f 54 5f ").;; ((NOT_
122a0 53 54 41 52 54 45 44 29 20 20 20 20 20 20 22 32 STARTED) "2
122b0 34 30 20 32 34 30 20 32 34 30 22 29 0a 3b 3b 20 40 240 240").;;
122c0 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 (else
122d0 20 20 20 20 20 20 20 20 22 31 39 32 20 31 39 32 "192 192
122e0 20 31 39 32 22 29 29 29 0a 0a 28 64 65 66 69 6e 192")))..(defin
122f0 65 20 28 63 6f 6d 6d 6f 6e 3a 69 75 70 2d 63 6f e (common:iup-co
12300 6c 6f 72 2d 3e 72 67 62 2d 68 65 78 20 69 6e 73 lor->rgb-hex ins
12310 74 72 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e tr). (string-in
12320 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 6d tersperse . (m
12330 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 ap (lambda (x).
12340 20 20 20 20 20 20 20 20 20 28 6e 75 6d 62 65 72 (number
12350 2d 3e 73 74 72 69 6e 67 20 78 20 31 36 29 29 0a ->string x 16)).
12360 20 20 20 20 20 20 20 20 28 6d 61 70 20 73 74 72 (map str
12370 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 20 20 20 20 ing->number.
12380 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
12390 2d 73 70 6c 69 74 20 69 6e 73 74 72 29 29 29 0a -split instr))).
123a0 20 20 20 22 2f 22 29 29 0a 0a 28 64 65 66 69 6e "/"))..(defin
123b0 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f e (common:get-co
123c0 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 lor-from-status
123d0 73 74 61 74 75 73 29 0a 20 20 28 63 6f 6e 64 0a status). (cond.
123e0 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
123f0 75 73 20 22 50 41 53 53 22 29 20 20 20 20 22 67 us "PASS") "g
12400 72 65 65 6e 22 29 0a 20 20 20 28 28 65 71 75 61 reen"). ((equa
12410 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 l? status "FAIL"
12420 29 20 20 20 20 22 72 65 64 22 29 0a 20 20 20 28 ) "red"). (
12430 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
12440 57 41 52 4e 22 29 20 20 20 20 22 6f 72 61 6e 67 WARN") "orang
12450 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
12460 73 74 61 74 75 73 20 22 4b 49 4c 4c 45 44 22 29 status "KILLED")
12470 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 "orange"). (
12480 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
12490 4b 49 4c 4c 52 45 51 22 29 20 22 70 75 72 70 6c KILLREQ") "purpl
124a0 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
124b0 73 74 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 status "RUNNING"
124c0 29 20 22 62 6c 75 65 22 29 0a 20 20 20 28 28 65 ) "blue"). ((e
124d0 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 41 42 qual? status "AB
124e0 4f 52 54 22 29 20 20 20 22 62 72 6f 77 6e 22 29 ORT") "brown")
124f0 0a 20 20 20 28 65 6c 73 65 20 22 62 6c 61 63 6b . (else "black
12500 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ")))..;;========
12510 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12520 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12530 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12540 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
12550 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 53 20 47 20 ; N A N O M S G
12560 20 20 43 20 4c 20 49 20 45 20 4e 20 54 0a 3b 3b C L I E N T.;;
12570 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12580 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12590 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
125a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
125b0 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
125c0 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
125d0 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 -guess-address h
125e0 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 ostname). (let
125f0 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 ((res #f)). (
12600 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
12610 6c 61 6d 62 64 61 20 28 61 64 72 29 0a 20 20 20 lambda (adr).
12620 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
12630 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 65 66 20 ? (u8vector-ref
12640 61 64 72 20 30 29 20 31 32 37 29 29 0a 09 20 20 adr 0) 127))..
12650 20 28 73 65 74 21 20 72 65 73 20 61 64 72 29 29 (set! res adr))
12660 29 0a 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 ). ;; NOTE:
12670 54 68 69 73 20 63 61 6e 20 66 61 69 6c 20 77 68 This can fail wh
12680 65 6e 20 74 68 65 72 65 20 69 73 20 6e 6f 20 6d en there is no m
12690 65 6e 74 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f ention of the ho
126a0 73 74 20 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 st in /etc/hosts
126b0 2e 20 46 49 58 4d 45 0a 20 20 20 20 20 28 76 65 . FIXME. (ve
126c0 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 ctor->list (host
126d0 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 info-addresses (
126e0 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e hostname->hostin
126f0 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a fo hostname)))).
12700 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
12710 72 73 70 65 72 73 65 20 0a 20 20 20 20 20 28 6d rsperse . (m
12720 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e ap number->strin
12730 67 0a 09 20 20 28 75 38 76 65 63 74 6f 72 2d 3e g.. (u8vector->
12740 6c 69 73 74 0a 09 20 20 20 28 69 66 20 72 65 73 list.. (if res
12750 20 72 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e res (hostname->
12760 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 ip hostname))))
12770 22 2e 22 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 ".")))...(define
12780 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e 64 2d 64 62 (common:send-db
12790 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 61 6e 67 65 oard-main-change
127a0 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 61 73 d). (let* ((das
127b0 68 62 6f 61 72 64 2d 69 70 73 20 28 6d 64 64 62 hboard-ips (mddb
127c0 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 64 73 29 :get-dashboards)
127d0 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
127e0 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 . (lambda (i
127f0 70 61 64 72 29 0a 20 20 20 20 20 20 20 28 6c 65 padr). (le
12800 74 2a 20 28 28 73 6f 63 20 28 63 6f 6d 6d 6f 6e t* ((soc (common
12810 3a 6f 70 65 6e 2d 6e 6d 2d 72 65 71 20 28 63 6f :open-nm-req (co
12820 6e 63 20 22 74 63 70 3a 2f 2f 22 20 69 70 61 64 nc "tcp://" ipad
12830 72 29 29 29 0a 09 20 20 20 20 20 20 28 6d 73 67 r))).. (msg
12840 20 28 63 6f 6e 63 20 22 6d 61 69 6e 20 22 20 2a (conc "main " *
12850 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 20 20 20 toppath*))..
12860 20 20 28 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a 6e (res (common:n
12870 6d 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 74 m-send-receive-t
12880 69 6d 65 6f 75 74 20 73 6f 63 20 6d 73 67 29 29 imeout soc msg))
12890 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 72 65 73 ).. (if (not res
128a0 29 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 65 ) ;; couldn't re
128b0 61 63 68 20 74 68 61 74 20 64 61 73 68 62 6f 61 ach that dashboa
128c0 72 64 20 2d 20 72 65 6d 6f 76 65 20 69 74 20 66 rd - remove it f
128d0 72 6f 6d 20 64 62 0a 09 20 20 20 20 20 28 70 72 rom db.. (pr
128e0 69 6e 74 20 22 45 52 52 4f 52 3a 20 63 6f 75 6c int "ERROR: coul
128f0 64 6e 27 74 20 72 65 61 63 68 20 64 61 73 68 62 dn't reach dashb
12900 6f 61 72 64 20 22 20 69 70 61 64 72 29 29 0a 09 oard " ipadr))..
12910 20 72 65 73 29 29 0a 20 20 20 20 20 64 61 73 68 res)). dash
12920 62 6f 61 72 64 2d 69 70 73 29 29 29 0a 20 20 20 board-ips))).
12930 20 0a 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d . .;;=======
12940 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12950 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12960 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12970 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
12980 3b 3b 20 44 20 41 20 53 20 48 20 42 20 4f 20 41 ;; D A S H B O A
12990 20 52 20 44 20 20 20 44 20 42 20 0a 3b 3b 3d 3d R D D B .;;==
129a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
129b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
129c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
129d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
129e0 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d ====..(define (m
129f0 64 64 62 3a 6f 70 65 6e 2d 64 62 29 0a 20 20 28 ddb:open-db). (
12a00 6c 65 74 2a 20 28 28 64 62 20 28 6f 70 65 6e 2d let* ((db (open-
12a10 64 61 74 61 62 61 73 65 20 28 63 6f 6e 63 20 28 database (conc (
12a20 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
12a30 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 variable "HOME")
12a40 20 22 2f 2e 64 61 73 68 62 6f 61 72 64 2e 64 62 "/.dashboard.db
12a50 22 29 29 29 29 0a 20 20 20 20 28 73 65 74 2d 62 ")))). (set-b
12a60 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 usy-handler! db
12a70 28 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 30 (busy-timeout 10
12a80 30 30 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 000)). (for-e
12a90 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
12aa0 20 28 71 72 79 29 0a 20 20 20 20 20 20 20 28 65 (qry). (e
12ab0 78 65 63 20 28 73 71 6c 20 64 62 20 71 72 79 29 xec (sql db qry)
12ac0 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 0a 20 )). (list .
12ad0 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 "CREATE TAB
12ae0 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 LE IF NOT EXISTS
12af0 20 76 61 72 73 20 20 20 20 20 20 20 28 69 64 20 vars (id
12b00 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
12b10 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 20 76 61 KEY,key TEXT, va
12b20 6c 20 54 45 58 54 2c 20 43 4f 4e 53 54 52 41 49 l TEXT, CONSTRAI
12b30 4e 54 20 76 61 72 73 63 6f 6e 73 74 72 61 69 6e NT varsconstrain
12b40 74 20 55 4e 49 51 55 45 20 28 6b 65 79 29 29 3b t UNIQUE (key));
12b50 22 0a 20 20 20 20 20 20 22 43 52 45 41 54 45 20 ". "CREATE
12b60 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 TABLE IF NOT EXI
12b70 53 54 53 20 64 61 73 68 62 6f 61 72 64 73 20 28 STS dashboards (
12b80 0a 20 20 20 20 20 20 20 20 20 20 69 64 20 20 20 . id
12b90 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 52 INTEGER PR
12ba0 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 IMARY KEY,.
12bb0 20 20 20 20 20 70 69 64 20 20 20 20 20 20 20 20 pid
12bc0 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 INTEGER,.
12bd0 20 20 20 75 73 65 72 6e 61 6d 65 20 20 20 54 45 username TE
12be0 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 68 6f XT,. ho
12bf0 73 74 6e 61 6d 65 20 20 20 54 45 58 54 2c 0a 20 stname TEXT,.
12c00 20 20 20 20 20 20 20 20 20 69 70 61 64 64 72 20 ipaddr
12c10 20 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 20 TEXT,.
12c20 20 20 20 20 70 6f 72 74 6e 75 6d 20 20 20 20 49 portnum I
12c30 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 NTEGER,.
12c40 20 20 73 74 61 72 74 5f 74 69 6d 65 20 54 49 4d start_time TIM
12c50 45 53 54 41 4d 50 20 44 45 46 41 55 4c 54 20 28 ESTAMP DEFAULT (
12c60 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
12c70 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 20 20 20 ow')),.
12c80 20 20 20 20 43 4f 4e 53 54 52 41 49 4e 54 20 68 CONSTRAINT h
12c90 6f 73 74 70 6f 72 74 20 55 4e 49 51 55 45 20 28 ostport UNIQUE (
12ca0 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 6e 75 6d hostname,portnum
12cb0 29 0a 20 20 20 20 20 20 20 20 29 3b 22 0a 20 20 ). );".
12cc0 20 20 20 20 29 29 0a 20 20 20 20 64 62 29 29 0a )). db)).
12cd0 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 64 .;; register a d
12ce0 61 73 68 62 6f 61 72 64 20 0a 3b 3b 0a 28 64 65 ashboard .;;.(de
12cf0 66 69 6e 65 20 28 6d 64 64 62 3a 72 65 67 69 73 fine (mddb:regis
12d00 74 65 72 2d 64 61 73 68 62 6f 61 72 64 20 70 6f ter-dashboard po
12d10 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 69 rt). (let* ((pi
12d20 64 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d d (current-
12d30 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 09 20 28 process-id)).. (
12d40 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f hostname (get-ho
12d50 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 st-name)).. (ipa
12d60 64 64 72 20 20 20 28 73 65 72 76 65 72 3a 67 65 ddr (server:ge
12d70 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 t-best-guess-add
12d80 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 29 0a ress hostname)).
12d90 09 20 28 75 73 65 72 6e 61 6d 65 20 28 63 75 72 . (username (cur
12da0 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 rent-user-name))
12db0 20 3b 3b 20 28 63 61 72 20 75 73 65 72 69 6e 66 ;; (car userinf
12dc0 6f 29 29 29 0a 09 20 28 64 62 20 20 20 20 20 20 o))).. (db
12dd0 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 (mddb:open-db)))
12de0 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 67 . (print "Reg
12df0 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 70 ister monitor, p
12e00 69 64 3a 20 22 20 70 69 64 20 22 2c 20 68 6f 73 id: " pid ", hos
12e10 74 6e 61 6d 65 3a 20 22 20 68 6f 73 74 6e 61 6d tname: " hostnam
12e20 65 20 22 2c 20 70 6f 72 74 3a 20 22 20 70 6f 72 e ", port: " por
12e30 74 20 22 2c 20 75 73 65 72 6e 61 6d 65 3a 20 22 t ", username: "
12e40 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 20 28 username). (
12e50 65 78 65 63 20 28 73 71 6c 20 64 62 20 22 49 4e exec (sql db "IN
12e60 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 SERT OR REPLACE
12e70 49 4e 54 4f 20 64 61 73 68 62 6f 61 72 64 73 20 INTO dashboards
12e80 28 70 69 64 2c 75 73 65 72 6e 61 6d 65 2c 68 6f (pid,username,ho
12e90 73 74 6e 61 6d 65 2c 69 70 61 64 64 72 2c 70 6f stname,ipaddr,po
12ea0 72 74 6e 75 6d 29 20 56 41 4c 55 45 53 20 28 3f rtnum) VALUES (?
12eb0 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 ,?,?,?,?);")..
12ec0 20 70 69 64 20 75 73 65 72 6e 61 6d 65 20 68 6f pid username ho
12ed0 73 74 6e 61 6d 65 20 69 70 61 64 64 72 20 70 6f stname ipaddr po
12ee0 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 64 rt). (close-d
12ef0 61 74 61 62 61 73 65 20 64 62 29 29 29 0a 0a 3b atabase db)))..;
12f00 3b 20 75 6e 72 65 67 69 73 74 65 72 20 61 20 6d ; unregister a m
12f10 6f 6e 69 74 6f 72 0a 3b 3b 0a 28 64 65 66 69 6e onitor.;;.(defin
12f20 65 20 28 6d 64 64 62 3a 75 6e 72 65 67 69 73 74 e (mddb:unregist
12f30 65 72 2d 64 61 73 68 62 6f 61 72 64 20 68 6f 73 er-dashboard hos
12f40 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 t port). (let*
12f50 28 28 64 62 20 20 20 20 20 20 28 6d 64 64 62 3a ((db (mddb:
12f60 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 open-db))). (
12f70 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 20 print "Register
12f80 75 6e 72 65 67 69 73 74 65 72 20 6d 6f 6e 69 74 unregister monit
12f90 6f 72 2c 20 68 6f 73 74 3a 70 6f 72 74 3d 22 20 or, host:port="
12fa0 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 0a 20 host ":" port).
12fb0 20 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 (exec (sql db
12fc0 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 64 61 "DELETE FROM da
12fd0 73 68 62 6f 61 72 64 73 20 57 48 45 52 45 20 68 shboards WHERE h
12fe0 6f 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 70 6f ostname=? AND po
12ff0 72 74 6e 75 6d 3d 3f 3b 22 29 20 68 6f 73 74 20 rtnum=?;") host
13000 70 6f 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 65 port). (close
13010 2d 64 61 74 61 62 61 73 65 20 64 62 29 29 29 0a -database db))).
13020 0a 3b 3b 20 67 65 74 20 72 65 67 69 73 74 65 72 .;; get register
13030 65 64 20 64 61 73 68 62 6f 61 72 64 73 0a 3b 3b ed dashboards.;;
13040 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 67 .(define (mddb:g
13050 65 74 2d 64 61 73 68 62 6f 61 72 64 73 29 0a 20 et-dashboards).
13060 20 28 6c 65 74 20 28 28 64 62 20 28 6d 64 64 62 (let ((db (mddb
13070 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 :open-db))).
13080 28 71 75 65 72 79 20 66 65 74 63 68 2d 63 6f 6c (query fetch-col
13090 75 6d 6e 0a 09 20 20 20 28 73 71 6c 20 64 62 20 umn.. (sql db
130a0 22 53 45 4c 45 43 54 20 69 70 61 64 64 72 20 7c "SELECT ipaddr |
130b0 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 74 6e 75 6d | ':' || portnum
130c0 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 73 FROM dashboards
130d0 3b 22 29 29 29 29 0a 20 20 20 20 0a 3b 3b 3d 3d ;")))). .;;==
130e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
130f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13100 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13110 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13120 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 ====.;; T E S T
13130 20 20 20 4c 20 41 20 55 20 4e 20 43 20 48 20 49 L A U N C H I
13140 20 4e 20 47 20 20 20 50 20 45 20 52 20 20 20 49 N G P E R I
13150 20 54 20 45 20 4d 20 20 20 57 20 49 20 54 20 48 T E M W I T H
13160 20 20 20 48 20 4f 20 53 20 54 20 20 20 54 20 59 H O S T T Y
13170 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d P E S.;;=======
13180 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13190 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
131a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
131b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
131c0 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 73 5d 0a 3b ;; .;; [hosts].;
131d0 3b 20 61 72 6d 20 63 75 62 69 65 30 31 20 63 75 ; arm cubie01 cu
131e0 62 69 65 30 32 0a 3b 3b 20 78 38 36 5f 36 34 20 bie02.;; x86_64
131f0 7a 65 75 73 20 78 65 6e 61 20 6d 79 74 68 30 31 zeus xena myth01
13200 0a 3b 3b 20 61 6c 6c 68 6f 73 74 73 20 23 7b 67 .;; allhosts #{g
13210 20 68 6f 73 74 73 20 61 72 6d 7d 20 23 7b 67 20 hosts arm} #{g
13220 68 6f 73 74 73 20 78 38 36 5f 36 34 7d 0a 3b 3b hosts x86_64}.;;
13230 20 0a 3b 3b 20 5b 68 6f 73 74 2d 74 79 70 65 73 .;; [host-types
13240 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 23 4d 54 ].;; general #MT
13250 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 68 LOWESTLOAD #{g h
13260 6f 73 74 73 20 61 6c 6c 68 6f 73 74 73 7d 0a 3b osts allhosts}.;
13270 3b 20 61 72 6d 20 20 20 20 20 23 4d 54 4c 4f 57 ; arm #MTLOW
13280 45 53 54 4c 4f 41 44 20 23 7b 67 20 68 6f 73 74 ESTLOAD #{g host
13290 73 20 61 72 6d 7d 0a 3b 3b 20 6e 62 67 65 6e 65 s arm}.;; nbgene
132a0 72 61 6c 20 6e 62 6a 6f 62 20 72 75 6e 20 4a 4f ral nbjob run JO
132b0 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f 67 20 24 4d BCOMMAND -log $M
132c0 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 4d 54 5f 54 T_LINKTREE/$MT_T
132d0 41 52 47 45 54 2f 24 4d 54 5f 52 55 4e 4e 41 4d ARGET/$MT_RUNNAM
132e0 45 2e 24 4d 54 5f 54 45 53 54 4e 41 4d 45 2d 24 E.$MT_TESTNAME-$
132f0 4d 54 5f 49 54 45 4d 5f 50 41 54 48 2e 6c 67 6f MT_ITEM_PATH.lgo
13300 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 6e 63 68 65 .;; .;; [launche
13310 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 74 75 70 20 rs].;; envsetup
13320 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 6f 72 2f 25 general.;; xor/%
13330 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 25 20 6e 62 /n 4C16G.;; % nb
13340 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a 3b 3b 20 5b general.;; .;; [
13350 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b 20 23 20 69 jobtools].;; # i
13360 66 20 64 65 66 69 6e 65 64 20 61 6e 64 20 6e 6f f defined and no
13370 74 20 22 6e 6f 22 20 66 6c 65 78 69 2d 6c 61 75 t "no" flexi-lau
13380 6e 63 68 65 72 20 77 69 6c 6c 20 62 79 70 61 73 ncher will bypas
13390 73 20 22 6c 61 75 6e 63 68 65 72 22 20 75 6e 6c s "launcher" unl
133a0 65 73 73 20 6e 6f 20 6d 61 74 63 68 2e 0a 3b 3b ess no match..;;
133b0 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 flexi-launcher
133c0 79 65 73 20 20 0a 3b 3b 20 6c 61 75 6e 63 68 65 yes .;; launche
133d0 72 20 6e 62 66 61 6b 65 0a 3b 3b 0a 28 64 65 66 r nbfake.;;.(def
133e0 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
133f0 6c 61 75 6e 63 68 65 72 20 63 6f 6e 66 69 67 64 launcher configd
13400 61 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d at testname item
13410 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 66 path). (let ((f
13420 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 allback-launcher
13430 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
13440 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 configdat "jobt
13450 6f 6f 6c 73 22 20 22 6c 61 75 6e 63 68 65 72 22 ools" "launcher"
13460 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ))). (if (and
13470 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
13480 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 configdat "jobt
13490 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 75 ools" "flexi-lau
134a0 6e 63 68 65 72 22 29 20 3b 3b 20 6f 76 65 72 72 ncher") ;; overr
134b0 69 64 65 73 20 6c 61 75 6e 63 68 65 72 0a 09 20 ides launcher..
134c0 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (not (equal?
134d0 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
134e0 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 configdat "jobt
134f0 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 75 ools" "flexi-lau
13500 6e 63 68 65 72 22 29 20 22 6e 6f 22 29 29 29 0a ncher") "no"))).
13510 09 28 6c 65 74 2a 20 28 28 6c 61 75 6e 63 68 65 .(let* ((launche
13520 72 73 20 20 20 20 20 20 20 20 20 28 68 61 73 68 rs (hash
13530 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
13540 6c 74 20 63 6f 6e 66 69 67 64 61 74 20 22 6c 61 lt configdat "la
13550 75 6e 63 68 65 72 73 22 20 27 28 29 29 29 29 0a unchers" '()))).
13560 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 61 . (if (null? la
13570 75 6e 63 68 65 72 73 29 0a 09 20 20 20 20 20 20 unchers)..
13580 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 fallback-launche
13590 72 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f r.. (let lo
135a0 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 6c 61 op ((hed (car la
135b0 75 6e 63 68 65 72 73 29 29 0a 09 09 09 20 28 74 unchers)).... (t
135c0 61 6c 20 28 63 64 72 20 6c 61 75 6e 63 68 65 72 al (cdr launcher
135d0 73 29 29 29 0a 09 09 28 6c 65 74 20 28 28 70 61 s)))...(let ((pa
135e0 74 74 20 20 20 20 20 20 28 63 61 72 20 68 65 64 tt (car hed
135f0 29 29 0a 09 09 20 20 20 20 20 20 28 68 6f 73 74 ))... (host
13600 2d 74 79 70 65 20 28 63 61 64 72 20 68 65 64 29 -type (cadr hed)
13610 29 29 0a 09 09 20 20 28 69 66 20 28 74 65 73 74 ))... (if (test
13620 73 3a 6d 61 74 63 68 20 70 61 74 74 20 74 65 73 s:match patt tes
13630 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a tname itempath).
13640 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
13650 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
13660 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 2 *default-l
13670 6f 67 2d 70 6f 72 74 2a 20 22 48 61 76 65 20 66 og-port* "Have f
13680 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 6d 61 lexi-launcher ma
13690 74 63 68 20 66 6f 72 20 22 20 74 65 73 74 6e 61 tch for " testna
136a0 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 20 me "/" itempath
136b0 22 20 3d 20 22 20 68 6f 73 74 2d 74 79 70 65 29 " = " host-type)
136c0 0a 09 09 09 28 6c 65 74 20 28 28 6c 61 75 6e 63 ....(let ((launc
136d0 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f her (configf:loo
136e0 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 68 kup configdat "h
136f0 6f 73 74 2d 74 79 70 65 73 22 20 68 6f 73 74 2d ost-types" host-
13700 74 79 70 65 29 29 29 0a 09 09 09 20 20 28 69 66 type))).... (if
13710 20 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 20 launcher....
13720 20 20 20 28 6c 65 74 2a 20 28 28 6c 61 75 6e 63 (let* ((launc
13730 68 65 72 2d 70 61 72 74 73 20 28 73 74 72 69 6e her-parts (strin
13740 67 2d 73 70 6c 69 74 20 6c 61 75 6e 63 68 65 72 g-split launcher
13750 29 29 0a 09 09 09 09 20 20 20 20 20 28 6c 61 75 ))..... (lau
13760 6e 63 68 65 72 2d 65 78 65 20 20 20 28 63 61 72 ncher-exe (car
13770 20 6c 61 75 6e 63 68 65 72 2d 70 61 72 74 73 29 launcher-parts)
13780 29 29 0a 09 09 09 09 28 69 66 20 28 65 71 75 61 )).....(if (equa
13790 6c 3f 20 6c 61 75 6e 63 68 65 72 2d 65 78 65 20 l? launcher-exe
137a0 22 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 22 29 "#MTLOWESTLOAD")
137b0 20 3b 3b 20 74 68 69 73 20 69 73 20 6f 75 72 20 ;; this is our
137c0 73 70 65 63 69 61 6c 20 63 61 73 65 2c 20 77 65 special case, we
137d0 20 77 69 6c 6c 20 66 69 6e 64 20 74 68 65 20 6c will find the l
137e0 6f 77 65 73 74 20 6c 6f 61 64 20 61 6e 64 20 63 owest load and c
137f0 72 61 66 74 20 61 20 6e 62 66 61 6b 65 20 63 6f raft a nbfake co
13800 6d 6d 61 6e 64 6c 69 6e 65 0a 09 09 09 09 20 20 mmandline.....
13810 20 20 28 6c 65 74 20 28 28 74 61 72 67 2d 68 6f (let ((targ-ho
13820 73 74 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c st (common:get-l
13830 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 east-loaded-host
13840 20 28 63 64 72 20 6c 61 75 6e 63 68 65 72 2d 70 (cdr launcher-p
13850 61 72 74 73 29 29 29 29 0a 09 09 09 09 20 20 20 arts)))).....
13860 20 20 20 28 63 6f 6e 63 20 22 72 65 6d 72 75 6e (conc "remrun
13870 20 22 20 74 61 72 67 2d 68 6f 73 74 29 29 0a 09 " targ-host))..
13880 09 09 09 20 20 20 20 6c 61 75 6e 63 68 65 72 29 ... launcher)
13890 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 ).... (begi
138a0 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 n.....(debug:pri
138b0 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
138c0 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
138d0 52 4e 49 4e 47 3a 20 6e 6f 20 6c 61 75 6e 63 68 RNING: no launch
138e0 65 72 20 66 6f 75 6e 64 20 66 6f 72 20 68 6f 73 er found for hos
138f0 74 2d 74 79 70 65 20 22 20 68 6f 73 74 2d 74 79 t-type " host-ty
13900 70 65 29 0a 09 09 09 09 28 69 66 20 28 6e 75 6c pe).....(if (nul
13910 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 20 20 l? tal).....
13920 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 fallback-launche
13930 72 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 r..... (loop
13940 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
13950 6c 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 l)))))))...
13960 20 3b 3b 20 6e 6f 20 6d 61 74 63 68 2c 20 74 72 ;; no match, tr
13970 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 20 y again...
13980 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
13990 09 09 09 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 ... fallback-la
139a0 75 6e 63 68 65 72 0a 09 09 09 20 20 28 6c 6f 6f uncher.... (loo
139b0 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
139c0 74 61 6c 29 29 29 29 29 29 29 29 0a 09 66 61 6c tal))))))))..fal
139d0 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 29 29 lback-launcher))
139e0 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d ). .;;=========
139f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
13a30 20 44 20 41 20 53 20 48 20 42 20 4f 20 41 20 52 D A S H B O A R
13a40 20 44 20 20 20 55 20 53 20 45 20 52 20 20 20 56 D U S E R V
13a50 20 49 20 45 20 57 20 53 0a 3b 3b 3d 3d 3d 3d 3d I E W S.;;=====
13a60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13aa0 3d 0a 0a 3b 3b 20 66 69 72 73 74 20 72 65 61 64 =..;; first read
13ab0 20 7e 2f 76 69 65 77 73 2e 63 6f 6e 66 69 67 20 ~/views.config
13ac0 69 66 20 69 74 20 65 78 69 73 74 73 2c 20 74 68 if it exists, th
13ad0 65 6e 20 72 65 61 64 20 24 4d 54 52 41 48 2f 76 en read $MTRAH/v
13ae0 69 65 77 73 2e 63 6f 6e 66 69 67 20 69 66 20 69 iews.config if i
13af0 74 20 65 78 69 73 74 73 0a 3b 3b 0a 28 64 65 66 t exists.;;.(def
13b00 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 61 64 ine (common:load
13b10 2d 76 69 65 77 73 2d 63 6f 6e 66 69 67 29 0a 20 -views-config).
13b20 20 28 6c 65 74 2a 20 28 28 76 69 65 77 2d 63 66 (let* ((view-cf
13b30 67 64 61 74 20 20 20 20 28 6d 61 6b 65 2d 68 61 gdat (make-ha
13b40 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 68 6f sh-table)).. (ho
13b50 6d 65 2d 63 66 67 66 69 6c 65 20 20 20 28 63 6f me-cfgfile (co
13b60 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d nc (get-environm
13b70 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 4f ent-variable "HO
13b80 4d 45 22 29 20 22 2f 2e 6d 74 76 69 65 77 73 2e ME") "/.mtviews.
13b90 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 6d 74 68 config")).. (mth
13ba0 6f 6d 65 2d 63 66 67 66 69 6c 65 20 28 63 6f 6e ome-cfgfile (con
13bb0 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e 6d c *toppath* "/.m
13bc0 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 29 29 tviews.config"))
13bd0 29 0a 20 20 20 20 28 69 66 20 28 66 69 6c 65 2d ). (if (file-
13be0 65 78 69 73 74 73 3f 20 6d 74 68 6f 6d 65 2d 63 exists? mthome-c
13bf0 66 67 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 fgfile)..(read-c
13c00 6f 6e 66 69 67 20 6d 74 68 6f 6d 65 2d 63 66 67 onfig mthome-cfg
13c10 66 69 6c 65 20 76 69 65 77 2d 63 66 67 64 61 74 file view-cfgdat
13c20 20 23 74 29 29 0a 20 20 20 20 3b 3b 20 77 65 20 #t)). ;; we
13c30 6c 6f 61 64 20 74 68 65 20 68 6f 6d 65 20 64 69 load the home di
13c40 72 20 66 69 6c 65 20 41 46 54 45 52 20 74 68 65 r file AFTER the
13c50 20 4d 54 52 41 48 20 66 69 6c 65 20 73 6f 20 74 MTRAH file so t
13c60 68 65 20 75 73 65 72 20 63 61 6e 20 63 6c 6f 62 he user can clob
13c70 62 65 72 20 73 65 74 74 69 6e 67 73 20 77 68 65 ber settings whe
13c80 6e 20 72 75 6e 6e 69 6e 67 20 74 68 65 20 64 61 n running the da
13c90 73 68 62 6f 61 72 64 20 69 6e 20 72 65 61 64 2d shboard in read-
13ca0 6f 6e 6c 79 20 61 72 65 61 73 0a 20 20 20 20 28 only areas. (
13cb0 69 66 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f if (file-exists?
13cc0 20 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a 09 home-cfgfile)..
13cd0 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 68 6f 6d (read-config hom
13ce0 65 2d 63 66 67 66 69 6c 65 20 76 69 65 77 2d 63 e-cfgfile view-c
13cf0 66 67 64 61 74 20 23 74 29 29 0a 20 20 20 20 76 fgdat #t)). v
13d00 69 65 77 2d 63 66 67 64 61 74 29 29 0a 0a iew-cfgdat))..