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 20 70 6b 74 73 20 28 70 atchable pkts (p
0280: 72 65 66 69 78 20 64 62 69 20 64 62 69 3a 29 0a refix dbi dbi:).
0290: 20 20 20 20 20 72 65 67 65 78 29 0a 0a 28 69 6d regex)..(im
02a0: 70 6f 72 74 20 28 70 72 65 66 69 78 20 73 71 6c port (prefix sql
02b0: 69 74 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a ite3 sqlite3:)).
02c0: 28 69 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 (import (prefix
02d0: 62 61 73 65 36 34 20 62 61 73 65 36 34 3a 29 29 base64 base64:))
02e0: 0a 0a 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 ..(declare (unit
02f0: 20 63 6f 6d 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c common))..(incl
0300: 75 64 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f ude "common_reco
0310: 72 64 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 28 72 rds.scm")..;; (r
0320: 65 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 6d equire-library m
0330: 61 72 67 73 29 0a 3b 3b 20 28 69 6e 63 6c 75 64 args).;; (includ
0340: 65 20 22 6d 61 72 67 73 2e 73 63 6d 22 29 0a 0a e "margs.scm")..
0350: 3b 3b 20 28 64 65 66 69 6e 65 20 6f 6c 64 2d 65 ;; (define old-e
0360: 78 69 74 20 65 78 69 74 29 0a 3b 3b 20 0a 3b 3b xit exit).;; .;;
0370: 20 28 64 65 66 69 6e 65 20 28 65 78 69 74 20 2e (define (exit .
0380: 20 63 6f 64 65 29 0a 3b 3b 20 20 20 28 69 66 20 code).;; (if
0390: 28 6e 75 6c 6c 3f 20 63 6f 64 65 29 0a 3b 3b 20 (null? code).;;
03a0: 20 20 20 20 20 20 28 6f 6c 64 2d 65 78 69 74 29 (old-exit)
03b0: 0a 3b 3b 20 20 20 20 20 20 20 28 6f 6c 64 2d 65 .;; (old-e
03c0: 78 69 74 20 63 6f 64 65 29 29 29 0a 0a 28 64 65 xit code)))..(de
03d0: 66 69 6e 65 20 67 65 74 65 6e 76 20 67 65 74 2d fine getenv get-
03e0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
03f0: 61 62 6c 65 29 0a 28 64 65 66 69 6e 65 20 28 73 able).(define (s
0400: 61 66 65 2d 73 65 74 65 6e 76 20 6b 65 79 20 76 afe-setenv key v
0410: 61 6c 29 0a 20 20 28 69 66 20 28 73 75 62 73 74 al). (if (subst
0420: 72 69 6e 67 2d 69 6e 64 65 78 20 22 3a 22 20 6b ring-index ":" k
0430: 65 79 29 20 3b 3b 20 76 61 72 69 61 62 6c 65 73 ey) ;; variables
0440: 20 63 6f 6e 74 61 69 6e 69 6e 67 20 3a 20 61 72 containing : ar
0450: 65 20 66 6f 72 20 69 6e 74 65 72 6e 61 6c 20 75 e for internal u
0460: 73 65 20 61 6e 64 20 63 61 6e 6e 6f 74 20 62 65 se and cannot be
0470: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 environment var
0480: 69 61 62 6c 65 73 2e 0a 20 20 20 20 20 20 28 64 iables.. (d
0490: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
04a0: 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 4 *default-log-
04b0: 70 6f 72 74 2a 20 22 73 6b 69 70 20 73 65 74 74 port* "skip sett
04c0: 69 6e 67 20 69 6e 74 65 72 6e 61 6c 20 75 73 65 ing internal use
04d0: 20 6f 6e 6c 79 20 76 61 72 69 61 62 6c 65 73 20 only variables
04e0: 63 6f 6e 74 61 69 6e 69 6e 67 20 5c 22 3a 5c 22 containing \":\"
04f0: 22 29 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e "). (if (an
0500: 64 20 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 0a d (string? val).
0510: 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 3f . (string?
0520: 20 6b 65 79 29 29 0a 09 20 20 28 68 61 6e 64 6c key)).. (handl
0530: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 e-exceptions..
0540: 20 20 20 20 65 78 6e 0a 09 20 20 20 20 20 20 28 exn.. (
0550: 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f debug:print-erro
0560: 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 r 0 *default-log
0570: 2d 70 6f 72 74 2a 20 22 62 61 64 20 76 61 6c 75 -port* "bad valu
0580: 65 20 66 6f 72 20 73 65 74 65 6e 76 2c 20 6b 65 e for setenv, ke
0590: 79 3d 22 20 6b 65 79 20 22 2c 20 76 61 6c 75 65 y=" key ", value
05a0: 3d 22 20 76 61 6c 29 0a 09 20 20 20 20 28 73 65 =" val).. (se
05b0: 74 65 6e 76 20 6b 65 79 20 76 61 6c 29 29 0a 09 tenv key val))..
05c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
05d0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
05e0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 61 64 20 76 log-port* "bad v
05f0: 61 6c 75 65 20 66 6f 72 20 73 65 74 65 6e 76 2c alue for setenv,
0600: 20 6b 65 79 3d 22 20 6b 65 79 20 22 2c 20 76 61 key=" key ", va
0610: 6c 75 65 3d 22 20 76 61 6c 29 29 29 29 0a 0a 28 lue=" val))))..(
0620: 64 65 66 69 6e 65 20 68 6f 6d 65 20 28 67 65 74 define home (get
0630: 65 6e 76 20 22 48 4f 4d 45 22 29 29 0a 28 64 65 env "HOME")).(de
0640: 66 69 6e 65 20 75 73 65 72 20 28 67 65 74 65 6e fine user (geten
0650: 76 20 22 55 53 45 52 22 29 29 0a 0a 3b 3b 20 47 v "USER"))..;; G
0660: 4c 4f 42 41 4c 53 0a 0a 3b 3b 20 43 4f 4e 54 45 LOBALS..;; CONTE
0670: 58 54 53 0a 28 64 65 66 73 74 72 75 63 74 20 63 XTS.(defstruct c
0680: 78 74 0a 20 20 28 74 61 73 6b 64 62 20 23 66 29 xt. (taskdb #f)
0690: 0a 20 20 28 63 6d 75 74 65 78 20 28 6d 61 6b 65 . (cmutex (make
06a0: 2d 6d 75 74 65 78 29 29 29 0a 3b 3b 20 28 64 65 -mutex))).;; (de
06b0: 66 69 6e 65 20 2a 63 6f 6e 74 65 78 74 73 2a 20 fine *contexts*
06c0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
06d0: 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a 63 )).;; (define *c
06e0: 6f 6e 74 65 78 74 2d 6d 75 74 65 78 2a 20 28 6d ontext-mutex* (m
06f0: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b 20 ake-mutex))..;;
0700: 3b 3b 20 73 61 66 65 20 6d 65 74 68 6f 64 20 66 ;; safe method f
0710: 6f 72 20 61 63 63 65 73 73 69 6e 67 20 61 20 63 or accessing a c
0720: 6f 6e 74 65 78 74 20 67 69 76 65 6e 20 61 20 74 ontext given a t
0730: 6f 70 70 61 74 68 0a 3b 3b 20 3b 3b 0a 3b 3b 20 oppath.;; ;;.;;
0740: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
0750: 77 69 74 68 2d 63 78 74 20 74 6f 70 70 61 74 68 with-cxt toppath
0760: 20 70 72 6f 63 29 0a 3b 3b 20 20 20 28 6d 75 74 proc).;; (mut
0770: 65 78 2d 6c 6f 63 6b 21 20 2a 63 6f 6e 74 65 78 ex-lock! *contex
0780: 74 2d 6d 75 74 65 78 2a 29 0a 3b 3b 20 20 20 28 t-mutex*).;; (
0790: 6c 65 74 20 28 28 63 78 74 20 28 68 61 73 68 2d let ((cxt (hash-
07a0: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
07b0: 74 20 2a 63 6f 6e 74 65 78 74 73 2a 20 74 6f 70 t *contexts* top
07c0: 70 61 74 68 20 23 66 29 29 29 0a 3b 3b 20 20 20 path #f))).;;
07d0: 20 20 28 69 66 20 28 6e 6f 74 20 63 78 74 29 0a (if (not cxt).
07e0: 3b 3b 20 20 20 20 20 20 20 20 20 28 73 65 74 21 ;; (set!
07f0: 20 63 78 74 20 28 6c 65 74 20 28 28 78 20 28 6d cxt (let ((x (m
0800: 61 6b 65 2d 63 78 74 29 29 29 28 68 61 73 68 2d ake-cxt)))(hash-
0810: 74 61 62 6c 65 2d 73 65 74 21 20 2a 63 6f 6e 74 table-set! *cont
0820: 65 78 74 73 2a 20 74 6f 70 70 61 74 68 20 78 29 exts* toppath x)
0830: 20 78 29 29 29 0a 3b 3b 20 20 20 20 20 28 6c 65 x))).;; (le
0840: 74 20 28 28 63 78 74 2d 6d 75 74 65 78 20 28 63 t ((cxt-mutex (c
0850: 78 74 2d 6d 75 74 65 78 20 63 78 74 29 29 29 0a xt-mutex cxt))).
0860: 3b 3b 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d ;; (mutex-
0870: 75 6e 6c 6f 63 6b 21 20 2a 63 6f 6e 74 65 78 74 unlock! *context
0880: 2d 6d 75 74 65 78 2a 29 0a 3b 3b 20 20 20 20 20 -mutex*).;;
0890: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 63 (mutex-lock! c
08a0: 78 74 2d 6d 75 74 65 78 29 0a 3b 3b 20 20 20 20 xt-mutex).;;
08b0: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 70 (let ((res (p
08c0: 72 6f 63 20 63 78 74 29 29 29 0a 3b 3b 20 20 20 roc cxt))).;;
08d0: 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c (mutex-unl
08e0: 6f 63 6b 21 20 63 78 74 2d 6d 75 74 65 78 29 0a ock! cxt-mutex).
08f0: 3b 3b 20 20 20 20 20 20 20 20 20 72 65 73 29 29 ;; res))
0900: 29 29 0a 20 20 20 20 20 20 20 20 0a 3b 3b 20 41 )). .;; A
0910: 20 68 61 73 68 20 74 61 62 6c 65 20 74 68 61 74 hash table that
0920: 20 63 61 6e 20 62 65 20 61 63 63 65 73 73 65 64 can be accessed
0930: 20 62 79 20 23 7b 73 63 68 65 6d 65 20 2e 2e 2e by #{scheme ...
0940: 7d 20 63 61 6c 6c 73 20 69 6e 0a 3b 3b 20 63 6f } calls in.;; co
0950: 6e 66 69 67 20 66 69 6c 65 73 2e 20 41 6c 6c 6f nfig files. Allo
0960: 77 73 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6e 67 ws communicating
0970: 20 62 65 74 77 65 65 6e 20 63 6f 6e 66 67 73 0a between confgs.
0980: 3b 3b 0a 28 64 65 66 69 6e 65 20 2a 75 73 65 72 ;;.(define *user
0990: 2d 68 61 73 68 2d 64 61 74 61 2a 20 28 6d 61 6b -hash-data* (mak
09a0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a e-hash-table))..
09b0: 28 64 65 66 69 6e 65 20 2a 64 62 2d 6b 65 79 73 (define *db-keys
09c0: 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 2a * #f)..(define *
09d0: 70 6b 74 73 2d 69 6e 66 6f 2a 20 20 20 20 28 6d pkts-info* (m
09e0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
09f0: 20 3b 3b 20 73 74 6f 72 65 20 73 74 75 66 66 20 ;; store stuff
0a00: 6c 69 6b 65 20 74 68 65 20 6c 61 73 74 20 70 61 like the last pa
0a10: 72 65 6e 74 20 68 65 72 65 0a 28 64 65 66 69 6e rent here.(defin
0a20: 65 20 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 20 20 e *configinfo*
0a30: 20 23 66 29 20 20 20 3b 3b 20 72 61 77 20 72 65 #f) ;; raw re
0a40: 73 75 6c 74 73 20 66 72 6f 6d 20 73 65 74 75 70 sults from setup
0a50: 2c 20 69 6e 63 6c 75 64 65 73 20 74 6f 70 70 61 , includes toppa
0a60: 74 68 20 61 6e 64 20 74 61 62 6c 65 20 66 72 6f th and table fro
0a70: 6d 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 m megatest.confi
0a80: 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 63 6f g.(define *runco
0a90: 6e 66 69 67 64 61 74 2a 20 23 66 29 20 20 20 3b nfigdat* #f) ;
0aa0: 3b 20 72 75 6e 20 63 6f 6e 66 69 67 73 20 64 61 ; run configs da
0ab0: 74 61 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 ta.(define *conf
0ac0: 69 67 64 61 74 2a 20 20 20 20 23 66 29 20 20 20 igdat* #f)
0ad0: 3b 3b 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 ;; megatest.conf
0ae0: 69 67 20 64 61 74 61 0a 28 64 65 66 69 6e 65 20 ig data.(define
0af0: 2a 63 6f 6e 66 69 67 73 74 61 74 75 73 2a 20 23 *configstatus* #
0b00: 66 29 20 20 20 3b 3b 20 73 74 61 74 75 73 20 6f f) ;; status o
0b10: 66 20 64 61 74 61 3b 20 27 66 75 6c 6c 64 61 74 f data; 'fulldat
0b20: 61 20 3a 20 61 6c 6c 20 70 72 6f 63 65 73 73 69 a : all processi
0b30: 6e 67 20 64 6f 6e 65 2c 20 23 66 20 3a 20 6e 6f ng done, #f : no
0b40: 20 64 61 74 61 20 79 65 74 2c 20 27 70 61 72 74 data yet, 'part
0b50: 69 61 6c 64 61 74 61 20 3a 20 70 61 72 74 69 61 ialdata : partia
0b60: 6c 20 72 65 61 64 20 64 6f 6e 65 0a 28 64 65 66 l read done.(def
0b70: 69 6e 65 20 2a 74 6f 70 70 61 74 68 2a 20 20 20 ine *toppath*
0b80: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
0b90: 61 6c 72 65 61 64 79 2d 73 65 65 6e 2d 72 75 6e already-seen-run
0ba0: 63 6f 6e 66 69 67 2d 69 6e 66 6f 2a 20 23 66 29 config-info* #f)
0bb0: 0a 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d ..(define *test-
0bc0: 6d 65 74 61 2d 75 70 64 61 74 65 64 2a 20 28 6d meta-updated* (m
0bd0: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
0be0: 0a 28 64 65 66 69 6e 65 20 2a 67 6c 6f 62 61 6c .(define *global
0bf0: 65 78 69 74 73 74 61 74 75 73 2a 20 20 30 29 20 exitstatus* 0)
0c00: 3b 3b 20 61 74 74 65 6d 70 74 20 74 6f 20 77 6f ;; attempt to wo
0c10: 72 6b 20 61 72 6f 75 6e 64 20 70 6f 73 73 69 62 rk around possib
0c20: 6c 65 20 74 68 72 65 61 64 20 69 73 73 75 65 73 le thread issues
0c30: 0a 28 64 65 66 69 6e 65 20 2a 70 61 73 73 6e 75 .(define *passnu
0c40: 6d 2a 20 20 20 20 20 20 20 20 20 20 20 30 29 20 m* 0)
0c50: 3b 3b 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 ;; when running
0c60: 74 72 61 63 6b 20 63 61 6c 6c 73 20 74 6f 20 72 track calls to r
0c70: 75 6e 2d 74 65 73 74 73 20 6f 72 20 73 69 6d 69 un-tests or simi
0c80: 6c 61 72 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a lar.;; (define *
0c90: 61 6c 74 2d 6c 6f 67 2d 66 69 6c 65 2a 20 23 66 alt-log-file* #f
0ca0: 29 20 20 3b 3b 20 75 73 65 64 20 62 79 20 2d 6c ) ;; used by -l
0cb0: 6f 67 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d og.(define *comm
0cc0: 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 20 20 20 28 on:denoise* (
0cd0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
0ce0: 29 20 3b 3b 20 66 6f 72 20 6c 6f 77 20 6e 6f 69 ) ;; for low noi
0cf0: 73 65 20 70 72 69 6e 74 69 6e 67 0a 28 64 65 66 se printing.(def
0d00: 69 6e 65 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 ine *default-log
0d10: 2d 70 6f 72 74 2a 20 20 28 63 75 72 72 65 6e 74 -port* (current
0d20: 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 28 64 -error-port)).(d
0d30: 65 66 69 6e 65 20 2a 74 69 6d 65 2d 7a 65 72 6f efine *time-zero
0d40: 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e * (current-secon
0d50: 64 73 29 29 20 3b 3b 20 66 6f 72 20 74 68 65 20 ds)) ;; for the
0d60: 77 61 74 63 68 64 6f 67 0a 0a 3b 3b 20 44 41 54 watchdog..;; DAT
0d70: 41 42 41 53 45 0a 28 64 65 66 69 6e 65 20 2a 64 ABASE.(define *d
0d80: 62 73 74 72 75 63 74 2d 64 62 2a 20 20 20 20 20 bstruct-db*
0d90: 20 20 20 20 23 66 29 20 3b 3b 20 75 73 65 64 20 #f) ;; used
0da0: 74 6f 20 63 61 63 68 65 20 74 68 65 20 64 62 73 to cache the dbs
0db0: 74 72 75 63 74 20 69 6e 20 64 62 3a 73 65 74 75 truct in db:setu
0dc0: 70 2e 20 47 6f 61 6c 20 69 73 20 74 6f 20 72 65 p. Goal is to re
0dd0: 6d 6f 76 65 20 74 68 69 73 2e 0a 3b 3b 20 64 62 move this..;; db
0de0: 20 73 74 61 74 73 0a 28 64 65 66 69 6e 65 20 2a stats.(define *
0df0: 64 62 2d 73 74 61 74 73 2a 20 20 20 20 20 20 20 db-stats*
0e00: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
0e10: 74 61 62 6c 65 29 29 20 3b 3b 20 68 61 73 68 20 table)) ;; hash
0e20: 6f 66 20 76 65 63 74 6f 72 73 20 3c 20 63 6f 75 of vectors < cou
0e30: 6e 74 20 64 75 72 61 74 69 6f 6e 2d 74 6f 74 61 nt duration-tota
0e40: 6c 20 3e 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d l >.(define *db-
0e50: 73 74 61 74 73 2d 6d 75 74 65 78 2a 20 20 20 20 stats-mutex*
0e60: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a (make-mutex)).
0e70: 3b 3b 20 64 62 20 61 63 63 65 73 73 0a 28 64 65 ;; db access.(de
0e80: 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 2d 61 63 fine *db-last-ac
0e90: 63 65 73 73 2a 20 20 20 20 20 20 28 63 75 72 72 cess* (curr
0ea0: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b ent-seconds)) ;;
0eb0: 20 6c 61 73 74 20 64 62 20 61 63 63 65 73 73 2c last db access,
0ec0: 20 75 73 65 64 20 69 6e 20 73 65 72 76 65 72 0a used in server.
0ed0: 28 64 65 66 69 6e 65 20 2a 64 62 2d 77 72 69 74 (define *db-writ
0ee0: 65 2d 61 63 63 65 73 73 2a 20 20 20 20 20 23 74 e-access* #t
0ef0: 29 0a 3b 3b 20 64 62 20 73 79 6e 63 0a 28 64 65 ).;; db sync.(de
0f00: 66 69 6e 65 20 2a 64 62 2d 6c 61 73 74 2d 73 79 fine *db-last-sy
0f10: 6e 63 2a 20 20 20 20 20 20 20 20 30 29 20 20 20 nc* 0)
0f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
0f30: 20 6c 61 73 74 20 74 69 6d 65 20 74 68 65 20 73 last time the s
0f40: 79 6e 63 20 74 6f 20 6d 65 67 61 74 65 73 74 2e ync to megatest.
0f50: 64 62 20 68 61 70 70 65 6e 65 64 0a 28 64 65 66 db happened.(def
0f60: 69 6e 65 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d ine *db-sync-in-
0f70: 70 72 6f 67 72 65 73 73 2a 20 23 66 29 20 20 20 progress* #f)
0f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 ;;
0f90: 69 66 20 74 68 65 72 65 20 69 73 20 61 20 73 79 if there is a sy
0fa0: 6e 63 20 69 6e 20 70 72 6f 67 72 65 73 73 20 64 nc in progress d
0fb0: 6f 20 6e 6f 74 20 74 72 79 20 74 6f 20 73 74 61 o not try to sta
0fc0: 72 74 20 61 6e 6f 74 68 65 72 0a 28 64 65 66 69 rt another.(defi
0fd0: 6e 65 20 2a 64 62 2d 6d 75 6c 74 69 2d 73 79 6e ne *db-multi-syn
0fe0: 63 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d c-mutex* (make-m
0ff0: 75 74 65 78 29 29 20 20 20 20 20 20 3b 3b 20 70 utex)) ;; p
1000: 72 6f 74 65 63 74 20 61 63 63 65 73 73 20 74 6f rotect access to
1010: 20 2a 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f *db-sync-in-pro
1020: 67 72 65 73 73 2a 2c 20 2a 64 62 2d 6c 61 73 74 gress*, *db-last
1030: 2d 73 79 6e 63 2a 0a 3b 3b 20 74 61 73 6b 20 64 -sync*.;; task d
1040: 62 0a 28 64 65 66 69 6e 65 20 2a 74 61 73 6b 2d b.(define *task-
1050: 64 62 2a 20 20 20 20 20 20 20 20 20 20 20 20 20 db*
1060: 23 66 29 20 3b 3b 20 28 76 65 63 74 6f 72 20 64 #f) ;; (vector d
1070: 62 20 70 61 74 68 2d 74 6f 2d 64 62 29 0a 28 64 b path-to-db).(d
1080: 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 73 73 efine *db-access
1090: 2d 61 6c 6c 6f 77 65 64 2a 20 20 20 23 74 29 20 -allowed* #t)
10a0: 3b 3b 20 66 6c 61 67 20 74 6f 20 61 6c 6c 6f 77 ;; flag to allow
10b0: 20 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 20 access.(define
10c0: 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 *db-access-mutex
10d0: 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 * (make-mute
10e0: 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d x)).(define *db-
10f0: 74 72 61 6e 73 61 63 74 69 6f 6e 2d 6d 75 74 65 transaction-mute
1100: 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 x* (make-mutex))
1110: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 63 61 63 .(define *db-cac
1120: 68 65 2d 70 61 74 68 2a 20 20 20 20 20 20 20 23 he-path* #
1130: 66 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 77 f).(define *db-w
1140: 69 74 68 2d 64 62 2d 6d 75 74 65 78 2a 20 20 20 ith-db-mutex*
1150: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 (make-mutex)).(
1160: 64 65 66 69 6e 65 20 2a 64 62 2d 61 70 69 2d 63 define *db-api-c
1170: 61 6c 6c 2d 74 69 6d 65 2a 20 20 20 20 28 6d 61 all-time* (ma
1180: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1190: 3b 3b 20 68 61 73 68 20 6f 66 20 63 6f 6d 6d 61 ;; hash of comma
11a0: 6e 64 20 3d 3e 20 28 6c 69 73 74 20 6f 66 20 74 nd => (list of t
11b0: 69 6d 65 73 29 0a 3b 3b 20 6e 6f 20 73 79 6e 63 imes).;; no sync
11c0: 20 64 62 0a 28 64 65 66 69 6e 65 20 2a 6e 6f 2d db.(define *no-
11d0: 73 79 6e 63 2d 64 62 2a 20 20 20 20 20 20 20 20 sync-db*
11e0: 20 20 23 66 29 0a 0a 3b 3b 20 53 45 52 56 45 52 #f)..;; SERVER
11f0: 0a 28 64 65 66 69 6e 65 20 2a 6d 79 2d 63 6c 69 .(define *my-cli
1200: 65 6e 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 23 ent-signature* #
1210: 66 29 0a 28 64 65 66 69 6e 65 20 2a 74 72 61 6e f).(define *tran
1220: 73 70 6f 72 74 2d 74 79 70 65 2a 20 20 20 20 27 sport-type* '
1230: 68 74 74 70 29 20 20 20 20 20 20 20 20 20 20 20 http)
1240: 20 20 3b 3b 20 6f 76 65 72 72 69 64 65 20 77 69 ;; override wi
1250: 74 68 20 5b 73 65 72 76 65 72 5d 20 74 72 61 6e th [server] tran
1260: 73 70 6f 72 74 20 68 74 74 70 7c 72 70 63 7c 6e sport http|rpc|n
1270: 6d 73 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e msg.(define *run
1280: 72 65 6d 6f 74 65 2a 20 20 20 20 20 20 20 20 20 remote*
1290: 23 66 29 20 20 20 20 20 20 20 20 20 20 20 20 20 #f)
12a0: 20 20 20 3b 3b 20 69 66 20 73 65 74 20 75 70 20 ;; if set up
12b0: 66 6f 72 20 73 65 72 76 65 72 20 63 6f 6d 6d 75 for server commu
12c0: 6e 69 63 61 74 69 6f 6e 20 74 68 69 73 20 77 69 nication this wi
12d0: 6c 6c 20 68 6f 6c 64 20 3c 68 6f 73 74 20 70 6f ll hold <host po
12e0: 72 74 3e 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a rt>.;; (define *
12f0: 6d 61 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 max-cache-size*
1300: 20 20 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 6c 0).(define *l
1310: 6f 67 67 65 64 2d 69 6e 2d 63 6c 69 65 6e 74 73 ogged-in-clients
1320: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
1330: 6c 65 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 le)).;; (define
1340: 2a 73 65 72 76 65 72 2d 69 64 2a 20 20 20 20 20 *server-id*
1350: 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 #f).(define
1360: 2a 73 65 72 76 65 72 2d 69 6e 66 6f 2a 20 20 20 *server-info*
1370: 20 20 20 20 23 66 29 20 20 3b 3b 20 67 6f 6f 64 #f) ;; good
1380: 20 63 61 6e 64 69 64 61 74 65 20 66 6f 72 20 65 candidate for e
1390: 61 73 69 6c 79 20 63 6f 6e 76 65 72 74 20 74 6f asily convert to
13a0: 20 6e 6f 6e 2d 67 6c 6f 62 61 6c 0a 28 64 65 66 non-global.(def
13b0: 69 6e 65 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 ine *time-to-exi
13c0: 74 2a 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 t* #f).(def
13d0: 69 6e 65 20 2a 73 65 72 76 65 72 2d 72 75 6e 2a ine *server-run*
13e0: 20 20 20 20 20 20 20 20 23 74 29 0a 28 64 65 66 #t).(def
13f0: 69 6e 65 20 2a 72 75 6e 2d 69 64 2a 20 20 20 20 ine *run-id*
1400: 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 #f).(def
1410: 69 6e 65 20 2a 73 65 72 76 65 72 2d 6b 69 6e 64 ine *server-kind
1420: 2d 72 75 6e 2a 20 20 20 28 6d 61 6b 65 2d 68 61 -run* (make-ha
1430: 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 69 sh-table)).(defi
1440: 6e 65 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 20 ne *home-host*
1450: 20 20 20 20 20 20 20 23 66 29 0a 3b 3b 20 28 64 #f).;; (d
1460: 65 66 69 6e 65 20 2a 74 6f 74 61 6c 2d 6e 6f 6e efine *total-non
1470: 2d 77 72 69 74 65 2d 64 65 6c 61 79 2a 20 30 29 -write-delay* 0)
1480: 0a 28 64 65 66 69 6e 65 20 2a 68 65 61 72 74 62 .(define *heartb
1490: 65 61 74 2d 6d 75 74 65 78 2a 20 20 20 28 6d 61 eat-mutex* (ma
14a0: 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 ke-mutex)).(defi
14b0: 6e 65 20 2a 61 70 69 2d 70 72 6f 63 65 73 73 2d ne *api-process-
14c0: 72 65 71 75 65 73 74 2d 63 6f 75 6e 74 2a 20 30 request-count* 0
14d0: 29 0a 28 64 65 66 69 6e 65 20 2a 6d 61 78 2d 61 ).(define *max-a
14e0: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
14f0: 73 74 73 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 sts* 0).(define
1500: 2a 73 65 72 76 65 72 2d 6f 76 65 72 6c 6f 61 64 *server-overload
1510: 65 64 2a 20 20 23 66 29 0a 0a 3b 3b 20 63 6c 69 ed* #f)..;; cli
1520: 65 6e 74 0a 28 64 65 66 69 6e 65 20 2a 72 6d 74 ent.(define *rmt
1530: 2d 6d 75 74 65 78 2a 20 20 20 20 20 20 20 20 20 -mutex*
1540: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 20 20 (make-mutex))
1550: 20 20 3b 3b 20 72 65 6d 6f 74 65 20 61 63 63 65 ;; remote acce
1560: 73 73 20 63 61 6c 6c 73 20 6d 75 74 65 78 20 0a ss calls mutex .
1570: 0a 3b 3b 20 52 50 43 20 74 72 61 6e 73 70 6f 72 .;; RPC transpor
1580: 74 0a 28 64 65 66 69 6e 65 20 2a 72 70 63 3a 6c t.(define *rpc:l
1590: 69 73 74 65 6e 65 72 2a 20 20 20 20 20 20 23 66 istener* #f
15a0: 29 0a 0a 3b 3b 20 4b 45 59 20 69 6e 66 6f 0a 28 )..;; KEY info.(
15b0: 64 65 66 69 6e 65 20 2a 74 61 72 67 65 74 2a 20 define *target*
15c0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
15d0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
15e0: 20 63 61 63 68 65 20 74 68 65 20 74 61 72 67 65 cache the targe
15f0: 74 20 68 65 72 65 3b 20 74 61 72 67 65 74 20 69 t here; target i
1600: 73 20 6b 65 79 76 61 6c 31 2f 6b 65 79 76 61 6c s keyval1/keyval
1610: 32 2f 2e 2e 2e 2f 6b 65 79 76 61 6c 4e 0a 28 64 2/.../keyvalN.(d
1620: 65 66 69 6e 65 20 2a 6b 65 79 73 2a 20 20 20 20 efine *keys*
1630: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
1640: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1650: 63 61 63 68 65 20 74 68 65 20 6b 65 79 73 20 68 cache the keys h
1660: 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 6b 65 79 ere.(define *key
1670: 76 61 6c 73 2a 20 20 20 20 20 20 20 20 20 20 20 vals*
1680: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1690: 29 29 0a 28 64 65 66 69 6e 65 20 2a 74 6f 70 74 )).(define *topt
16a0: 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 20 28 est-paths* (
16b0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
16c0: 29 20 3b 3b 20 63 61 63 68 65 20 74 6f 70 74 65 ) ;; cache topte
16d0: 73 74 20 70 61 74 68 20 73 65 74 74 69 6e 67 73 st path settings
16e0: 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 74 here.(define *t
16f0: 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 20 20 est-paths*
1700: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
1710: 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 65 le)) ;; cache te
1720: 73 74 2d 69 64 20 74 6f 20 74 65 73 74 20 72 75 st-id to test ru
1730: 6e 20 70 61 74 68 73 20 68 65 72 65 0a 28 64 65 n paths here.(de
1740: 66 69 6e 65 20 2a 74 65 73 74 2d 69 64 73 2a 20 fine *test-ids*
1750: 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 (make-h
1760: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 ash-table)) ;; c
1770: 61 63 68 65 20 72 75 6e 2d 69 64 2c 20 74 65 73 ache run-id, tes
1780: 74 6e 61 6d 65 2c 20 61 6e 64 20 69 74 65 6d 2d tname, and item-
1790: 70 61 74 68 20 3d 3e 20 74 65 73 74 2d 69 64 0a path => test-id.
17a0: 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 69 6e (define *test-in
17b0: 66 6f 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b fo* (mak
17c0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
17d0: 3b 20 63 61 63 68 65 20 74 68 65 20 74 65 73 74 ; cache the test
17e0: 20 69 6e 66 6f 20 72 65 63 6f 72 64 73 2c 20 75 info records, u
17f0: 70 64 61 74 65 20 74 68 65 20 73 74 61 74 65 2c pdate the state,
1800: 20 73 74 61 74 75 73 2c 20 72 75 6e 5f 64 75 72 status, run_dur
1810: 61 74 69 6f 6e 20 65 74 63 2e 20 66 72 6f 6d 20 ation etc. from
1820: 74 65 73 74 64 61 74 2e 64 62 0a 0a 28 64 65 66 testdat.db..(def
1830: 69 6e 65 20 2a 72 75 6e 2d 69 6e 66 6f 2d 63 61 ine *run-info-ca
1840: 63 68 65 2a 20 20 20 20 20 28 6d 61 6b 65 2d 68 che* (make-h
1850: 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 72 ash-table)) ;; r
1860: 75 6e 20 69 6e 66 6f 20 69 73 20 73 74 61 62 6c un info is stabl
1870: 65 2c 20 6e 6f 20 6e 65 65 64 20 74 6f 20 72 65 e, no need to re
1880: 67 65 74 0a 28 64 65 66 69 6e 65 20 2a 6c 61 75 get.(define *lau
1890: 6e 63 68 2d 73 65 74 75 70 2d 6d 75 74 65 78 2a nch-setup-mutex*
18a0: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 20 (make-mutex))
18b0: 20 20 20 3b 3b 20 6e 65 65 64 20 74 6f 20 62 65 ;; need to be
18c0: 20 61 62 6c 65 20 74 6f 20 63 61 6c 6c 20 6c 61 able to call la
18d0: 75 6e 63 68 3a 73 65 74 75 70 20 6f 66 74 65 6e unch:setup often
18e0: 20 73 6f 20 6d 75 74 65 78 20 69 74 20 61 6e 64 so mutex it and
18f0: 20 72 65 2d 63 61 6c 6c 20 74 68 65 20 72 65 61 re-call the rea
1900: 6c 20 64 65 61 6c 20 6f 6e 6c 79 20 69 66 20 2a l deal only if *
1910: 74 6f 70 70 61 74 68 2a 20 6e 6f 74 20 73 65 74 toppath* not set
1920: 0a 28 64 65 66 69 6e 65 20 2a 68 6f 6d 65 68 6f .(define *homeho
1930: 73 74 2d 6d 75 74 65 78 2a 20 20 20 20 20 28 6d st-mutex* (m
1940: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 0a 3b 3b 20 ake-mutex))..;;
1950: 4d 69 73 63 65 6c 6c 61 6e 65 6f 75 73 0a 28 64 Miscellaneous.(d
1960: 65 66 69 6e 65 20 2a 74 72 69 67 67 65 72 73 2d efine *triggers-
1970: 6d 75 74 65 78 2a 20 20 20 20 20 28 6d 61 6b 65 mutex* (make
1980: 2d 6d 75 74 65 78 29 29 20 20 20 20 20 3b 3b 20 -mutex)) ;;
1990: 62 6c 6f 63 6b 20 6f 76 65 72 6c 61 70 70 69 6e block overlappin
19a0: 67 20 70 72 6f 63 65 73 73 69 6e 67 20 6f 66 20 g processing of
19b0: 74 72 69 67 67 65 72 73 0a 0a 28 64 65 66 73 74 triggers..(defst
19c0: 72 75 63 74 20 72 65 6d 6f 74 65 0a 20 20 28 68 ruct remote. (h
19d0: 68 2d 64 61 74 20 20 20 20 20 20 20 20 20 20 20 h-dat
19e0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d (common:get-hom
19f0: 65 68 6f 73 74 29 29 20 3b 3b 20 68 6f 6d 65 68 ehost)) ;; homeh
1a00: 6f 73 74 20 72 65 63 6f 72 64 20 28 20 61 64 64 ost record ( add
1a10: 72 20 2e 20 68 68 66 6c 61 67 20 29 0a 20 20 28 r . hhflag ). (
1a20: 73 65 72 76 65 72 2d 75 72 6c 20 20 20 20 20 20 server-url
1a30: 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 (if *toppath*
1a40: 28 73 65 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 (server:check-if
1a50: 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 -running *toppat
1a60: 68 2a 29 29 29 20 3b 3b 20 28 73 65 72 76 65 72 h*))) ;; (server
1a70: 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e 69 6e :check-if-runnin
1a80: 67 20 2a 74 6f 70 70 61 74 68 2a 29 20 23 66 29 g *toppath*) #f)
1a90: 29 0a 20 20 28 6c 61 73 74 2d 73 65 72 76 65 72 ). (last-server
1aa0: 2d 63 68 65 63 6b 20 30 29 20 20 3b 3b 20 6c 61 -check 0) ;; la
1ab0: 73 74 20 74 69 6d 65 20 77 65 20 63 68 65 63 6b st time we check
1ac0: 65 64 20 74 6f 20 73 65 65 20 69 66 20 74 68 65 ed to see if the
1ad0: 20 73 65 72 76 65 72 20 77 61 73 20 61 6c 69 76 server was aliv
1ae0: 65 0a 20 20 28 63 6f 6e 6e 64 61 74 20 20 20 20 e. (conndat
1af0: 20 20 20 20 20 20 20 23 66 29 0a 20 20 28 74 72 #f). (tr
1b00: 61 6e 73 70 6f 72 74 20 20 20 20 20 20 20 20 20 ansport
1b10: 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 65 2a *transport-type*
1b20: 29 0a 20 20 28 73 65 72 76 65 72 2d 74 69 6d 65 ). (server-time
1b30: 6f 75 74 20 20 20 20 28 73 65 72 76 65 72 3a 67 out (server:g
1b40: 65 74 2d 74 69 6d 65 6f 75 74 29 29 20 3b 3b 20 et-timeout)) ;;
1b50: 64 65 66 61 75 6c 74 20 66 72 6f 6d 20 73 65 72 default from ser
1b60: 76 65 72 3a 67 65 74 2d 74 69 6d 65 6f 75 74 0a ver:get-timeout.
1b70: 20 20 28 66 6f 72 63 65 2d 73 65 72 76 65 72 20 (force-server
1b80: 20 20 20 20 20 23 66 29 0a 20 20 28 72 6f 2d 6d #f). (ro-m
1b90: 6f 64 65 20 20 20 20 20 20 20 20 20 20 20 23 66 ode #f
1ba0: 29 20 20 0a 20 20 28 72 6f 2d 6d 6f 64 65 2d 63 ) . (ro-mode-c
1bb0: 68 65 63 6b 65 64 20 20 20 23 66 29 29 20 3b 3b hecked #f)) ;;
1bc0: 20 66 6c 61 67 20 74 68 61 74 20 69 6e 64 69 63 flag that indic
1bd0: 61 74 65 73 20 77 65 20 68 61 76 65 20 63 68 65 ates we have che
1be0: 63 6b 65 64 20 66 6f 72 20 72 6f 2d 6d 6f 64 65 cked for ro-mode
1bf0: 0a 0a 3b 3b 20 6c 61 75 6e 63 68 69 6e 67 20 61 ..;; launching a
1c00: 6e 64 20 68 6f 73 74 73 0a 28 64 65 66 73 74 72 nd hosts.(defstr
1c10: 75 63 74 20 68 6f 73 74 0a 20 20 28 72 65 61 63 uct host. (reac
1c20: 68 61 62 6c 65 20 20 20 20 23 66 29 0a 20 20 28 hable #f). (
1c30: 6c 61 73 74 2d 75 70 64 61 74 65 20 20 30 29 0a last-update 0).
1c40: 20 20 28 6c 61 73 74 2d 75 73 65 64 20 20 20 20 (last-used
1c50: 30 29 0a 20 20 28 6c 61 73 74 2d 63 70 75 6c 6f 0). (last-cpulo
1c60: 61 64 20 31 29 29 0a 0a 28 64 65 66 69 6e 65 20 ad 1))..(define
1c70: 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 20 20 20 *host-loads*
1c80: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1c90: 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 table))..;; cach
1ca0: 65 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 e environment va
1cb0: 72 73 20 66 6f 72 20 65 61 63 68 20 72 75 6e 20 rs for each run
1cc0: 68 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 65 6e here.(define *en
1cd0: 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 v-vars-by-run-id
1ce0: 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 * (make-hash-tab
1cf0: 6c 65 29 29 0a 0a 3b 3b 20 54 65 73 74 63 6f 6e le))..;; Testcon
1d00: 66 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e 66 69 fig and runconfi
1d10: 67 20 63 61 63 68 65 73 2e 20 0a 28 64 65 66 69 g caches. .(defi
1d20: 6e 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a ne *testconfigs*
1d30: 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 (make-ha
1d40: 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 65 sh-table)) ;; te
1d50: 73 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 63 st-name => testc
1d60: 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 2a 72 onfig.(define *r
1d70: 75 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 20 unconfigs*
1d80: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1d90: 62 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 74 20 ble)) ;; target
1da0: 20 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 0a => runconfig.
1db0: 0a 3b 3b 20 54 68 69 73 20 69 73 20 61 20 63 61 .;; This is a ca
1dc0: 63 68 65 20 6f 66 20 70 72 65 2d 72 65 71 73 20 che of pre-reqs
1dd0: 6d 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d 63 61 met, don't re-ca
1de0: 6c 63 20 69 6e 20 63 61 73 65 73 20 77 68 65 72 lc in cases wher
1df0: 65 20 63 61 6c 6c 65 64 20 77 69 74 68 20 73 61 e called with sa
1e00: 6d 65 20 70 61 72 61 6d 73 20 6c 65 73 73 20 74 me params less t
1e10: 68 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 63 6f han.;; five seco
1e20: 6e 64 73 20 61 67 6f 0a 28 64 65 66 69 6e 65 20 nds ago.(define
1e30: 2a 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 *pre-reqs-met-ca
1e40: 63 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d che* (make-hash-
1e50: 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 table))..;; cach
1e60: 65 20 6f 66 20 76 65 72 62 6f 73 69 74 79 20 67 e of verbosity g
1e70: 69 76 65 6e 20 73 74 72 69 6e 67 0a 3b 3b 0a 28 iven string.;;.(
1e80: 64 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 define *verbosit
1e90: 79 2d 63 61 63 68 65 2a 20 20 20 20 28 6d 61 6b y-cache* (mak
1ea0: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a e-hash-table))..
1eb0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
1ec0: 63 6c 65 61 72 2d 63 61 63 68 65 73 29 0a 20 20 clear-caches).
1ed0: 28 73 65 74 21 20 2a 74 61 72 67 65 74 2a 20 20 (set! *target*
1ee0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
1ef0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1f00: 28 73 65 74 21 20 2a 6b 65 79 73 2a 20 20 20 20 (set! *keys*
1f10: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
1f20: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1f30: 28 73 65 74 21 20 2a 6b 65 79 76 61 6c 73 2a 20 (set! *keyvals*
1f40: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
1f50: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1f60: 28 73 65 74 21 20 2a 74 6f 70 74 65 73 74 2d 70 (set! *toptest-p
1f70: 61 74 68 73 2a 20 20 20 20 20 20 28 6d 61 6b 65 aths* (make
1f80: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1f90: 28 73 65 74 21 20 2a 74 65 73 74 2d 70 61 74 68 (set! *test-path
1fa0: 73 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 s* (make
1fb0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1fc0: 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 73 2a (set! *test-ids*
1fd0: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
1fe0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
1ff0: 28 73 65 74 21 20 2a 74 65 73 74 2d 69 6e 66 6f (set! *test-info
2000: 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 * (make
2010: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
2020: 28 73 65 74 21 20 2a 72 75 6e 2d 69 6e 66 6f 2d (set! *run-info-
2030: 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 6b 65 cache* (make
2040: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
2050: 28 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d (set! *env-vars-
2060: 62 79 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 6b 65 by-run-id* (make
2070: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 -hash-table)).
2080: 28 73 65 74 21 20 2a 74 65 73 74 2d 69 64 2d 63 (set! *test-id-c
2090: 61 63 68 65 2a 20 20 20 20 20 20 28 6d 61 6b 65 ache* (make
20a0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 0a -hash-table)))..
20b0: 3b 3b 20 47 65 6e 65 72 69 63 20 73 74 72 69 6e ;; Generic strin
20c0: 67 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 g database.(defi
20d0: 6e 65 20 73 64 62 3a 71 72 79 20 23 66 29 20 3b ne sdb:qry #f) ;
20e0: 3b 20 28 6d 61 6b 65 2d 73 64 62 3a 71 72 79 29 ; (make-sdb:qry)
20f0: 29 20 3b 3b 20 20 27 69 6e 69 74 20 23 66 29 0a ) ;; 'init #f).
2100: 3b 3b 20 47 65 6e 65 72 69 63 20 70 61 74 68 20 ;; Generic path
2110: 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e 65 database.(define
2120: 20 2a 66 64 62 2a 20 23 66 29 0a 0a 28 64 65 66 *fdb* #f)..(def
2130: 69 6e 65 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 ine *last-launch
2140: 2a 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e * (current-secon
2150: 64 73 29 29 20 3b 3b 20 75 73 65 20 66 6f 72 20 ds)) ;; use for
2160: 74 68 72 6f 74 74 6c 69 6e 67 20 74 68 65 20 6c throttling the l
2170: 61 75 6e 63 68 20 72 61 74 65 2e 20 57 6f 75 6c aunch rate. Woul
2180: 64 20 62 65 20 62 65 74 74 65 72 20 74 6f 20 75 d be better to u
2190: 73 65 20 74 68 65 20 64 62 20 61 6e 64 20 6c 61 se the db and la
21a0: 73 74 20 74 69 6d 65 20 6f 66 20 61 20 74 65 73 st time of a tes
21b0: 74 20 69 6e 20 4c 41 55 4e 43 48 45 44 20 73 74 t in LAUNCHED st
21c0: 61 74 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ate...;;========
21d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
21f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
2210: 3b 20 56 20 45 20 52 20 53 20 49 20 4f 20 4e 0a ; V E R S I O N.
2220: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
2230: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2240: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2260: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
2270: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 e (common:get-fu
2280: 6c 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 63 ll-version). (c
2290: 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 72 onc megatest-ver
22a0: 73 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 sion "-" megates
22b0: 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a t-fossil-hash)).
22c0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
22d0: 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 :version-signatu
22e0: 72 65 29 0a 20 20 28 63 6f 6e 63 20 6d 65 67 61 re). (conc mega
22f0: 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 test-version "-"
2300: 20 28 73 75 62 73 74 72 69 6e 67 20 6d 65 67 61 (substring mega
2310: 74 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 test-fossil-hash
2320: 20 30 20 34 29 29 29 0a 0a 3b 3b 20 66 72 6f 6d 0 4)))..;; from
2330: 20 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 70 20 metadat lookup
2340: 4d 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e MEGATEST_VERSION
2350: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
2360: 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e mon:get-last-run
2370: 2d 76 65 72 73 69 6f 6e 29 20 3b 3b 20 52 41 44 -version) ;; RAD
2380: 54 20 3d 3e 20 48 6f 77 20 64 6f 65 73 20 74 68 T => How does th
2390: 69 73 20 77 6f 72 6b 20 69 6e 20 73 65 6e 64 2d is work in send-
23a0: 72 65 63 65 69 76 65 20 66 75 6e 63 74 69 6f 6e receive function
23b0: 3f 3f 3b 20 61 73 73 75 6d 65 20 69 74 20 69 73 ??; assume it is
23c0: 20 74 68 65 20 76 61 6c 75 65 20 73 61 76 65 64 the value saved
23d0: 20 69 6e 20 73 6f 6d 65 20 44 42 0a 20 20 28 72 in some DB. (r
23e0: 6d 74 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 41 mt:get-var "MEGA
23f0: 54 45 53 54 5f 56 45 52 53 49 4f 4e 22 29 29 0a TEST_VERSION")).
2400: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
2410: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
2420: 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 20 rsion-number).
2430: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
2440: 0a 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 28 . (substring (
2450: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d common:get-last-
2460: 72 75 6e 2d 76 65 72 73 69 6f 6e 29 20 30 20 36 run-version) 0 6
2470: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
2480: 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 mmon:set-last-ru
2490: 6e 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 72 6d n-version). (rm
24a0: 74 3a 73 65 74 2d 76 61 72 20 22 4d 45 47 41 54 t:set-var "MEGAT
24b0: 45 53 54 5f 56 45 52 53 49 4f 4e 22 20 28 63 6f EST_VERSION" (co
24c0: 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 mmon:version-sig
24d0: 6e 61 74 75 72 65 29 29 29 0a 0a 3b 3b 20 70 6f nature)))..;; po
24e0: 73 74 69 76 65 20 6e 75 6d 62 65 72 20 69 66 20 stive number if
24f0: 6d 65 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e megatest version
2500: 20 3e 20 64 62 20 76 65 72 73 69 6f 6e 0a 3b 3b > db version.;;
2510: 20 6e 65 67 61 74 69 76 65 20 6e 75 6d 62 65 72 negative number
2520: 20 69 66 20 6d 65 67 61 74 65 73 74 20 76 65 72 if megatest ver
2530: 73 69 6f 6e 20 3c 20 64 62 20 76 65 72 73 69 6f sion < db versio
2540: 6e 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f n.(define (commo
2550: 6e 3a 76 65 72 73 69 6f 6e 2d 64 62 2d 64 65 6c n:version-db-del
2560: 74 61 29 0a 20 20 20 20 20 20 20 20 20 28 2d 20 ta). (-
2570: 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e megatest-version
2580: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
2590: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 2d 6e 75 t-run-version-nu
25a0: 6d 62 65 72 29 29 29 0a 0a 28 64 65 66 69 6e 65 mber)))..(define
25b0: 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e (common:version
25c0: 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 28 6e 6f -changed?). (no
25d0: 74 20 28 65 71 75 61 6c 3f 20 28 63 6f 6d 6d 6f t (equal? (commo
25e0: 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 n:get-last-run-v
25f0: 65 72 73 69 6f 6e 29 0a 20 20 20 20 20 20 20 20 ersion).
2600: 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 (common:v
2610: 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 ersion-signature
2620: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
2630: 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e 67 65 ommon:api-change
2640: 64 3f 29 0a 20 20 28 6e 6f 74 20 28 65 71 75 61 d?). (not (equa
2650: 6c 3f 20 28 73 75 62 73 74 72 69 6e 67 20 28 2d l? (substring (-
2660: 3e 73 74 72 69 6e 67 20 6d 65 67 61 74 65 73 74 >string megatest
2670: 2d 76 65 72 73 69 6f 6e 29 20 30 20 34 29 0a 20 -version) 0 4).
2680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
2690: 75 62 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 ubstring (conc (
26a0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d common:get-last-
26b0: 72 75 6e 2d 76 65 72 73 69 6f 6e 29 29 20 30 20 run-version)) 0
26c0: 34 29 29 29 29 0a 20 20 0a 3b 3b 20 4d 6f 76 65 4)))). .;; Move
26d0: 20 6d 65 20 65 6c 73 65 77 68 65 72 65 20 2e 2e me elsewhere ..
26e0: 2e 0a 3b 3b 20 52 41 44 54 20 3d 3e 20 57 68 79 ..;; RADT => Why
26f0: 20 64 6f 20 77 65 20 6d 65 65 64 20 74 68 65 20 do we meed the
2700: 76 65 72 73 69 6f 6e 20 63 68 65 63 6b 20 68 65 version check he
2710: 72 65 2c 20 74 68 69 73 20 69 73 20 63 61 6c 6c re, this is call
2720: 65 64 20 6f 6e 6c 79 20 69 66 20 76 65 72 73 69 ed only if versi
2730: 6f 6e 20 6d 69 73 6d 61 0a 3b 3b 0a 28 64 65 66 on misma.;;.(def
2740: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 ine (common:clea
2750: 6e 75 70 2d 64 62 20 64 62 73 74 72 75 63 74 20 nup-db dbstruct
2760: 23 21 6b 65 79 20 28 66 75 6c 6c 20 23 66 29 29 #!key (full #f))
2770: 0a 20 20 28 61 70 70 6c 79 20 64 62 3a 6d 75 6c . (apply db:mul
2780: 74 69 2d 64 62 2d 73 79 6e 63 20 0a 20 20 20 64 ti-db-sync . d
2790: 62 73 74 72 75 63 74 0a 20 20 20 27 73 63 68 65 bstruct. 'sche
27a0: 6d 61 0a 20 20 20 3b 3b 20 27 6e 65 77 32 6f 6c ma. ;; 'new2ol
27b0: 64 0a 20 20 20 27 6b 69 6c 6c 73 65 72 76 65 72 d. 'killserver
27c0: 73 0a 20 20 20 27 61 64 6a 2d 74 61 72 67 65 74 s. 'adj-target
27d0: 0a 20 20 20 3b 3b 20 27 6f 6c 64 32 6e 65 77 0a . ;; 'old2new.
27e0: 20 20 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 28 'new2old. (
27f0: 69 66 20 66 75 6c 6c 0a 20 20 20 20 20 20 20 27 if full. '
2800: 28 64 65 6a 75 6e 6b 29 0a 20 20 20 20 20 20 20 (dejunk).
2810: 27 28 29 29 29 0a 20 20 28 69 66 20 28 63 6f 6d '())). (if (com
2820: 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e 67 65 64 3f mon:api-changed?
2830: 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ). (common:
2840: 73 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 set-last-run-ver
2850: 73 69 6f 6e 29 29 29 0a 0a 3b 3b 20 52 6f 74 61 sion)))..;; Rota
2860: 74 65 20 6c 6f 67 73 2c 20 6c 6f 67 69 63 3a 20 te logs, logic:
2870: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
2880: 20 20 20 20 69 66 20 3e 20 35 30 30 6b 20 61 6e if > 500k an
2890: 64 20 6f 6c 64 65 72 20 74 68 61 6e 20 31 20 77 d older than 1 w
28a0: 65 65 6b 3a 0a 3b 3b 20 20 20 20 20 20 20 20 20 eek:.;;
28b0: 20 20 20 20 20 20 20 20 20 20 20 20 72 65 6d 6f remo
28c0: 76 65 20 70 72 65 76 69 6f 75 73 20 63 6f 6d 70 ve previous comp
28d0: 72 65 73 73 65 64 20 6c 6f 67 20 61 6e 64 20 63 ressed log and c
28e0: 6f 6d 70 72 65 73 73 20 74 68 69 73 20 6c 6f 67 ompress this log
28f0: 0a 3b 3b 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 .;; WARNING: Thi
2900: 73 20 70 72 6f 63 20 6f 70 65 72 61 74 65 73 20 s proc operates
2910: 61 73 73 75 6d 69 6e 67 20 74 68 61 74 20 69 74 assuming that it
2920: 20 69 73 20 69 6e 20 74 68 65 20 64 69 72 65 63 is in the direc
2930: 74 6f 72 79 20 61 62 6f 76 65 20 74 68 65 0a 3b tory above the.;
2940: 3b 20 20 20 20 20 20 20 20 20 20 6c 6f 67 73 20 ; logs
2950: 64 69 72 65 63 74 6f 72 79 20 79 6f 75 20 77 69 directory you wi
2960: 73 68 20 74 6f 20 6c 6f 67 2d 72 6f 74 61 74 65 sh to log-rotate
2970: 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ..;;.(define (co
2980: 6d 6d 6f 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 mmon:rotate-logs
2990: 29 0a 20 20 28 69 66 20 28 6e 6f 74 20 28 64 69 ). (if (not (di
29a0: 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 rectory-exists?
29b0: 22 6c 6f 67 73 22 29 29 28 63 72 65 61 74 65 2d "logs"))(create-
29c0: 64 69 72 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 directory "logs"
29d0: 29 29 0a 20 20 28 64 69 72 65 63 74 6f 72 79 2d )). (directory-
29e0: 66 6f 6c 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 fold . (lambda
29f0: 20 28 66 69 6c 65 20 72 65 6d 29 0a 20 20 20 20 (file rem).
2a00: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
2a10: 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 ons. exn.
2a20: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
2a30: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
2a40: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 69 6c -log-port* "fail
2a50: 65 64 20 74 6f 20 72 6f 74 61 74 65 20 6c 6f 67 ed to rotate log
2a60: 20 22 20 66 69 6c 65 20 22 2c 20 70 72 6f 62 61 " file ", proba
2a70: 62 6c 79 20 68 61 6e 64 6c 65 64 20 62 79 20 61 bly handled by a
2a80: 6e 6f 74 68 65 72 20 70 72 6f 63 65 73 73 2e 22 nother process."
2a90: 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 ). (let* ((
2aa0: 66 75 6c 6c 6e 61 6d 65 20 28 63 6f 6e 63 20 22 fullname (conc "
2ab0: 6c 6f 67 73 2f 22 20 66 69 6c 65 29 29 0a 20 20 logs/" file)).
2ac0: 20 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 (file
2ad0: 2d 61 67 65 20 28 2d 20 28 63 75 72 72 65 6e 74 -age (- (current
2ae0: 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d -seconds)(file-m
2af0: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
2b00: 20 66 75 6c 6c 6e 61 6d 65 29 29 29 29 0a 20 20 fullname)))).
2b10: 20 20 20 20 20 20 28 69 66 20 28 6f 72 20 28 61 (if (or (a
2b20: 6e 64 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 nd (string-match
2b30: 20 22 5e 2e 2a 2e 6c 6f 67 22 20 66 69 6c 65 29 "^.*.log" file)
2b40: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2b50: 20 20 20 20 20 20 28 3e 20 28 66 69 6c 65 2d 73 (> (file-s
2b60: 69 7a 65 20 66 75 6c 6c 6e 61 6d 65 29 20 32 30 ize fullname) 20
2b70: 30 30 30 30 29 29 0a 20 20 20 20 20 20 20 20 20 0000)).
2b80: 20 20 20 20 20 20 20 28 61 6e 64 20 28 73 74 72 (and (str
2b90: 69 6e 67 2d 6d 61 74 63 68 20 22 5e 73 65 72 76 ing-match "^serv
2ba0: 65 72 2d 2e 2a 2e 6c 6f 67 22 20 66 69 6c 65 29 er-.*.log" file)
2bb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2bc0: 20 20 20 20 20 20 28 3e 20 28 2d 20 28 63 75 72 (> (- (cur
2bd0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 66 rent-seconds) (f
2be0: 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e ile-modification
2bf0: 2d 74 69 6d 65 20 66 75 6c 6c 6e 61 6d 65 29 29 -time fullname))
2c00: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2c10: 20 20 20 20 20 20 20 20 20 28 2a 20 38 20 36 30 (* 8 60
2c20: 20 36 30 29 29 29 29 0a 20 20 20 20 20 20 20 20 60)))).
2c30: 20 20 20 20 28 6c 65 74 20 28 28 67 7a 66 69 6c (let ((gzfil
2c40: 65 20 28 63 6f 6e 63 20 66 75 6c 6c 6e 61 6d 65 e (conc fullname
2c50: 20 22 2e 67 7a 22 29 29 29 0a 20 20 20 20 20 20 ".gz"))).
2c60: 20 20 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d (if (com
2c70: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
2c80: 20 67 7a 66 69 6c 65 29 0a 20 20 20 20 20 20 20 gzfile).
2c90: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
2ca0: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
2cb0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
2cc0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
2cd0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 lt-log-port* "re
2ce0: 6d 6f 76 69 6e 67 20 22 20 67 7a 66 69 6c 65 29 moving " gzfile)
2cf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2d00: 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c (delete-fil
2d10: 65 20 67 7a 66 69 6c 65 29 29 29 0a 20 20 20 20 e gzfile))).
2d20: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
2d30: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
2d40: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2d50: 20 22 63 6f 6d 70 72 65 73 73 69 6e 67 20 22 20 "compressing "
2d60: 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 file).
2d70: 20 20 20 20 28 73 79 73 74 65 6d 20 28 63 6f 6e (system (con
2d80: 63 20 22 67 7a 69 70 20 22 20 66 75 6c 6c 6e 61 c "gzip " fullna
2d90: 6d 65 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 me))).
2da0: 20 20 28 69 66 20 28 3e 20 66 69 6c 65 2d 61 67 (if (> file-ag
2db0: 65 20 28 2a 20 28 73 74 72 69 6e 67 2d 3e 6e 75 e (* (string->nu
2dc0: 6d 62 65 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 mber (or (config
2dd0: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
2de0: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 6c 6f dat* "setup" "lo
2df0: 67 2d 65 78 70 69 72 65 2d 64 61 79 73 22 29 20 g-expire-days")
2e00: 22 33 30 22 29 29 20 32 34 20 33 36 30 30 29 29 "30")) 24 3600))
2e10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
2e20: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
2e30: 6f 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 ons.
2e40: 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 20 exn.
2e50: 20 20 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 #f.
2e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
2e70: 65 6c 65 74 65 2d 66 69 6c 65 20 66 75 6c 6c 6e elete-file fulln
2e80: 61 6d 65 29 29 29 29 29 29 29 0a 20 20 20 27 28 ame))))))). '(
2e90: 29 0a 20 20 20 22 6c 6f 67 73 22 29 29 0a 0a 3b ). "logs"))..;
2ea0: 3b 20 46 6f 72 63 65 20 61 20 6d 65 67 61 74 65 ; Force a megate
2eb0: 73 74 20 63 6c 65 61 6e 75 70 2d 64 62 20 69 66 st cleanup-db if
2ec0: 20 76 65 72 73 69 6f 6e 20 69 73 20 63 68 61 6e version is chan
2ed0: 67 65 64 20 61 6e 64 20 73 6b 69 70 2d 76 65 72 ged and skip-ver
2ee0: 73 69 6f 6e 2d 63 68 65 63 6b 20 6e 6f 74 20 73 sion-check not s
2ef0: 70 65 63 69 66 69 65 64 0a 3b 3b 20 44 6f 20 4e pecified.;; Do N
2f00: 4f 54 20 63 68 65 63 6b 20 69 66 20 6e 6f 74 20 OT check if not
2f10: 6f 6e 20 68 6f 6d 65 68 6f 73 74 21 0a 3b 3b 0a on homehost!.;;.
2f20: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
2f30: 65 78 69 74 2d 6f 6e 2d 76 65 72 73 69 6f 6e 2d exit-on-version-
2f40: 63 68 61 6e 67 65 64 29 0a 20 20 28 69 66 20 28 changed). (if (
2f50: 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f common:on-homeho
2f60: 73 74 3f 29 0a 20 20 20 20 20 20 28 69 66 20 28 st?). (if (
2f70: 63 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e 67 common:api-chang
2f80: 65 64 3f 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 ed?).. (let* ((
2f90: 6d 74 63 6f 6e 66 20 28 63 6f 6e 63 20 28 67 65 mtconf (conc (ge
2fa0: 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
2fb0: 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 5f 41 riable "MT_RUN_A
2fc0: 52 45 41 5f 48 4f 4d 45 22 29 20 22 2f 6d 65 67 REA_HOME") "/meg
2fd0: 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a atest.config")).
2fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2ff0: 28 64 62 66 69 6c 65 20 28 63 6f 6e 63 20 28 67 (dbfile (conc (g
3000: 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
3010: 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e 5f ariable "MT_RUN_
3020: 41 52 45 41 5f 48 4f 4d 45 22 29 20 22 2f 6d 65 AREA_HOME") "/me
3030: 67 61 74 65 73 74 2e 64 62 22 29 29 0a 20 20 20 gatest.db")).
3040: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 (re
3050: 61 64 2d 6f 6e 6c 79 20 28 6e 6f 74 20 28 66 69 ad-only (not (fi
3060: 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 3f le-write-access?
3070: 20 64 62 66 69 6c 65 29 29 29 0a 20 20 20 20 20 dbfile))).
3080: 20 20 20 20 20 20 20 20 20 20 20 28 64 62 73 74 (dbst
3090: 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 20 23 ruct (db:setup #
30a0: 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 t))).. (debug
30b0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
30c0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 20 t-log-port*....
30d0: 22 57 41 52 4e 49 4e 47 3a 20 56 65 72 73 69 6f "WARNING: Versio
30e0: 6e 20 6d 69 73 6d 61 74 63 68 21 5c 6e 22 0a 09 n mismatch!\n"..
30f0: 09 09 20 22 20 20 20 65 78 70 65 63 74 65 64 3a .. " expected:
3100: 20 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 " (common:versi
3110: 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 20 22 5c on-signature) "\
3120: 6e 22 0a 09 09 09 20 22 20 20 20 67 6f 74 3a 20 n".... " got:
3130: 20 20 20 20 20 22 20 28 63 6f 6d 6d 6f 6e 3a 67 " (common:g
3140: 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 et-last-run-vers
3150: 69 6f 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 ion)).
3160: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
3170: 20 20 20 20 20 28 28 67 65 74 2d 65 6e 76 69 72 ((get-envir
3180: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
3190: 22 4d 54 5f 53 4b 49 50 5f 44 42 5f 4d 49 47 52 "MT_SKIP_DB_MIGR
31a0: 41 54 45 22 29 20 23 74 29 0a 20 20 20 20 20 20 ATE") #t).
31b0: 20 20 20 20 20 20 20 28 28 61 6e 64 20 28 63 6f ((and (co
31c0: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
31d0: 3f 20 6d 74 63 6f 6e 66 29 20 28 63 6f 6d 6d 6f ? mtconf) (commo
31e0: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 n:file-exists? d
31f0: 62 66 69 6c 65 29 20 28 6e 6f 74 20 72 65 61 64 bfile) (not read
3200: 2d 6f 6e 6c 79 29 0a 20 20 20 20 20 20 20 20 20 -only).
3210: 20 20 20 20 20 20 20 20 20 20 28 65 71 3f 20 28 (eq? (
3220: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 current-user-id)
3230: 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 6f (file-owner mtco
3240: 6e 66 29 29 29 20 3b 3b 20 73 61 66 65 20 74 6f nf))) ;; safe to
3250: 20 72 75 6e 20 2d 63 6c 65 61 6e 75 70 2d 64 62 run -cleanup-db
3260: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3270: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3280: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3290: 20 22 20 20 20 49 20 73 65 65 20 79 6f 75 20 61 " I see you a
32a0: 72 65 20 74 68 65 20 6f 77 6e 65 72 20 6f 66 20 re the owner of
32b0: 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 2c megatest.config,
32c0: 20 61 74 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 attempting to c
32d0: 6c 65 61 6e 75 70 20 61 6e 64 20 72 65 73 65 74 leanup and reset
32e0: 20 74 6f 20 6e 65 77 20 76 65 72 73 69 6f 6e 22 to new version"
32f0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3300: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
3310: 6e 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ns.
3320: 20 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 exn.
3330: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
3340: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 (de
3350: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
3360: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
3370: 46 61 69 6c 65 64 20 74 6f 20 73 77 69 74 63 68 Failed to switch
3380: 20 76 65 72 73 69 6f 6e 73 2e 22 29 0a 20 20 20 versions.").
3390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
33a0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
33b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
33c0: 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 " message: " ((c
33d0: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
33e0: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
33f0: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 'message) exn)).
3400: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3410: 20 28 70 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 (print-call-cha
3420: 69 6e 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f in (current-erro
3430: 72 2d 70 6f 72 74 29 29 0a 20 20 20 20 20 20 20 r-port)).
3440: 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 20 (exit
3450: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
3460: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e (common:clean
3470: 75 70 2d 64 62 20 64 62 73 74 72 75 63 74 29 29 up-db dbstruct))
3480: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ). (
3490: 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c (not (common:fil
34a0: 65 2d 65 78 69 73 74 73 3f 20 6d 74 63 6f 6e 66 e-exists? mtconf
34b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
34c0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
34d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
34e0: 74 2a 20 22 20 20 20 6d 65 67 61 74 65 73 74 2e t* " megatest.
34f0: 63 6f 6e 66 69 67 20 64 6f 65 73 20 6e 6f 74 20 config does not
3500: 65 78 69 73 74 20 69 6e 20 74 68 69 73 20 61 72 exist in this ar
3510: 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 6f 63 ea. Cannot proc
3520: 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 65 73 eed with megates
3530: 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 61 74 t version migrat
3540: 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 20 ion.").
3550: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 (exit 1)).
3560: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f ((no
3570: 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 t (common:file-e
3580: 78 69 73 74 73 3f 20 64 62 66 69 6c 65 29 29 0a xists? dbfile)).
3590: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
35a0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
35b0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
35c0: 22 20 20 20 6d 65 67 61 74 65 73 74 2e 64 62 20 " megatest.db
35d0: 64 6f 65 73 20 6e 6f 74 20 65 78 69 73 74 20 69 does not exist i
35e0: 6e 20 74 68 69 73 20 61 72 65 61 2e 20 20 43 61 n this area. Ca
35f0: 6e 6e 6f 74 20 70 72 6f 63 65 65 64 20 77 69 74 nnot proceed wit
3600: 68 20 6d 65 67 61 74 65 73 74 20 76 65 72 73 69 h megatest versi
3610: 6f 6e 20 6d 69 67 72 61 74 69 6f 6e 2e 22 29 0a on migration.").
3620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
3630: 78 69 74 20 31 29 29 0a 20 20 20 20 20 20 20 20 xit 1)).
3640: 20 20 20 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 ((not (eq?
3650: 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 (current-user-id
3660: 29 28 66 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 )(file-owner mtc
3670: 6f 6e 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 onf))).
3680: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3690: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
36a0: 2d 70 6f 72 74 2a 20 22 20 20 20 59 6f 75 20 64 -port* " You d
36b0: 6f 20 6e 6f 74 20 6f 77 6e 20 6d 65 67 61 74 65 o not own megate
36c0: 73 74 2e 64 62 20 69 6e 20 74 68 69 73 20 61 72 st.db in this ar
36d0: 65 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 6f 63 ea. Cannot proc
36e0: 65 65 64 20 77 69 74 68 20 6d 65 67 61 74 65 73 eed with megates
36f0: 74 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 61 74 t version migrat
3700: 69 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 20 ion.").
3710: 20 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 (exit 1)).
3720: 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 61 (rea
3730: 64 2d 6f 6e 6c 79 0a 20 20 20 20 20 20 20 20 20 d-only.
3740: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3750: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3760: 2d 70 6f 72 74 2a 20 22 20 20 20 59 6f 75 20 68 -port* " You h
3770: 61 76 65 20 72 65 61 64 2d 6f 6e 6c 79 20 61 63 ave read-only ac
3780: 63 65 73 73 20 74 6f 20 74 68 69 73 20 61 72 65 cess to this are
3790: 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 6f 63 65 a. Cannot proce
37a0: 65 64 20 77 69 74 68 20 6d 65 67 61 74 65 73 74 ed with megatest
37b0: 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 61 74 69 version migrati
37c0: 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 on.").
37d0: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 20 (exit 1)).
37e0: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
37f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
3800: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
3810: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
3820: 20 22 20 74 6f 20 73 77 69 74 63 68 20 76 65 72 " to switch ver
3830: 73 69 6f 6e 73 20 79 6f 75 20 63 61 6e 20 72 75 sions you can ru
3840: 6e 3a 20 5c 22 6d 65 67 61 74 65 73 74 20 2d 63 n: \"megatest -c
3850: 6c 65 61 6e 75 70 2d 64 62 5c 22 22 29 0a 20 20 leanup-db\"").
3860: 20 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 (exi
3870: 74 20 31 29 29 29 29 29 29 29 0a 3b 3b 20 20 20 t 1))))))).;;
3880: 20 20 20 28 62 65 67 69 6e 0a 3b 3b 09 28 64 65 (begin.;;.(de
3890: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
38a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
38b0: 45 52 52 4f 52 3a 20 63 61 6e 6e 6f 74 20 6d 69 ERROR: cannot mi
38c0: 67 72 61 74 65 20 76 65 72 73 69 6f 6e 20 75 6e grate version un
38d0: 6c 65 73 73 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 less on homehost
38e0: 2e 20 45 78 69 74 69 6e 67 2e 22 29 0a 3b 3b 09 . Exiting.").;;.
38f0: 28 65 78 69 74 20 31 29 29 29 29 0a 0a 3b 3b 3d (exit 1))))..;;=
3900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3940: 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 50 20 41 20 52 =====.;; S P A R
3950: 20 53 20 45 20 20 20 41 20 52 20 52 20 41 20 59 S E A R R A Y
3960: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
3970: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3980: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
39a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
39b0: 66 69 6e 65 20 28 6d 61 6b 65 2d 73 70 61 72 73 fine (make-spars
39c0: 65 2d 61 72 72 61 79 29 0a 20 20 28 6c 65 74 20 e-array). (let
39d0: 28 28 61 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 ((a (make-sparse
39e0: 2d 76 65 63 74 6f 72 29 29 29 0a 20 20 20 20 28 -vector))). (
39f0: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 sparse-vector-se
3a00: 74 21 20 61 20 30 20 28 6d 61 6b 65 2d 73 70 61 t! a 0 (make-spa
3a10: 72 73 65 2d 76 65 63 74 6f 72 29 29 0a 20 20 20 rse-vector)).
3a20: 20 61 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 a))..(define (s
3a30: 70 61 72 73 65 2d 61 72 72 61 79 3f 20 61 29 0a parse-array? a).
3a40: 20 20 28 61 6e 64 20 28 73 70 61 72 73 65 2d 76 (and (sparse-v
3a50: 65 63 74 6f 72 3f 20 61 29 0a 20 20 20 20 20 20 ector? a).
3a60: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 3f (sparse-vector?
3a70: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d (sparse-vector-
3a80: 72 65 66 20 61 20 30 29 29 29 29 0a 0a 28 64 65 ref a 0))))..(de
3a90: 66 69 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 fine (sparse-arr
3aa0: 61 79 2d 72 65 66 20 61 20 78 20 79 29 0a 20 20 ay-ref a x y).
3ab0: 28 6c 65 74 20 28 28 72 6f 77 20 28 73 70 61 72 (let ((row (spar
3ac0: 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 61 20 se-vector-ref a
3ad0: 78 29 29 29 0a 20 20 20 20 28 69 66 20 72 6f 77 x))). (if row
3ae0: 0a 09 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 ..(sparse-vector
3af0: 2d 72 65 66 20 72 6f 77 20 79 29 0a 09 23 66 29 -ref row y)..#f)
3b00: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 61 ))..(define (spa
3b10: 72 73 65 2d 61 72 72 61 79 2d 73 65 74 21 20 61 rse-array-set! a
3b20: 20 78 20 79 20 76 61 6c 29 0a 20 20 28 6c 65 74 x y val). (let
3b30: 20 28 28 72 6f 77 20 28 73 70 61 72 73 65 2d 76 ((row (sparse-v
3b40: 65 63 74 6f 72 2d 72 65 66 20 61 20 78 29 29 29 ector-ref a x)))
3b50: 0a 20 20 20 20 28 69 66 20 72 6f 77 0a 09 28 73 . (if row..(s
3b60: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 parse-vector-set
3b70: 21 20 72 6f 77 20 79 20 76 61 6c 29 0a 09 28 6c ! row y val)..(l
3b80: 65 74 20 28 28 6e 65 77 2d 72 6f 77 20 28 6d 61 et ((new-row (ma
3b90: 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 ke-sparse-vector
3ba0: 29 29 29 0a 09 20 20 28 73 70 61 72 73 65 2d 76 ))).. (sparse-v
3bb0: 65 63 74 6f 72 2d 73 65 74 21 20 61 20 78 20 6e ector-set! a x n
3bc0: 65 77 2d 72 6f 77 29 0a 09 20 20 28 73 70 61 72 ew-row).. (spar
3bd0: 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 6e se-vector-set! n
3be0: 65 77 2d 72 6f 77 20 79 20 76 61 6c 29 29 29 29 ew-row y val))))
3bf0: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
3c00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4c ===========.;; L
3c40: 20 4f 20 43 20 4b 20 45 20 52 20 53 20 20 20 41 O C K E R S A
3c50: 20 4e 20 44 20 20 20 42 20 4c 20 4f 20 43 20 4b N D B L O C K
3c60: 20 45 20 52 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d E R S .;;======
3c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3cb0: 0a 0a 3b 3b 20 62 6c 6f 63 6b 20 66 75 72 74 68 ..;; block furth
3cc0: 65 72 20 61 63 63 65 73 73 65 73 20 74 6f 20 64 er accesses to d
3cd0: 61 74 61 62 61 73 65 73 2e 20 43 61 6c 6c 20 74 atabases. Call t
3ce0: 68 69 73 20 62 65 66 6f 72 65 20 73 68 75 74 74 his before shutt
3cf0: 69 6e 67 20 64 62 20 64 6f 77 6e 0a 28 64 65 66 ing db down.(def
3d00: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 2d 62 ine (common:db-b
3d10: 6c 6f 63 6b 2d 66 75 72 74 68 65 72 2d 71 75 65 lock-further-que
3d20: 72 69 65 73 29 0a 20 20 28 6d 75 74 65 78 2d 6c ries). (mutex-l
3d30: 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 2d ock! *db-access-
3d40: 6d 75 74 65 78 2a 29 0a 20 20 28 73 65 74 21 20 mutex*). (set!
3d50: 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 *db-access-allow
3d60: 65 64 2a 20 23 66 29 0a 20 20 28 6d 75 74 65 78 ed* #f). (mutex
3d70: 2d 75 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 -unlock! *db-acc
3d80: 65 73 73 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 ess-mutex*))..(d
3d90: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 efine (common:db
3da0: 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 3f -access-allowed?
3db0: 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 ). (let ((val (
3dc0: 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 6d begin.. (m
3dd0: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 utex-lock! *db-a
3de0: 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a 09 20 ccess-mutex*)..
3df0: 20 20 20 20 20 20 2a 64 62 2d 61 63 63 65 73 73 *db-access
3e00: 2d 61 6c 6c 6f 77 65 64 2a 0a 09 20 20 20 20 20 -allowed*..
3e10: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
3e20: 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 *db-access-mute
3e30: 78 2a 29 29 29 29 0a 20 20 20 20 76 61 6c 29 29 x*)))). val))
3e40: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
3e50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 55 20 ==========.;; U
3e90: 53 20 45 20 46 20 55 20 4c 20 20 20 53 20 54 20 S E F U L S T
3ea0: 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d U F F.;;========
3eb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
3ef0: 3b 3b 20 63 6f 6e 76 65 72 74 20 74 68 69 6e 67 ;; convert thing
3f00: 73 20 74 6f 20 61 6e 20 61 6c 69 73 74 20 6f 72 s to an alist or
3f10: 20 61 73 73 6f 63 20 6c 69 73 74 2c 20 23 66 20 assoc list, #f
3f20: 67 65 74 73 20 63 6f 6e 76 65 72 74 65 64 20 74 gets converted t
3f30: 6f 20 22 22 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 o "".;;.(define
3f40: 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 (common:to-alist
3f50: 20 64 61 74 29 0a 20 20 28 63 6f 6e 64 0a 20 20 dat). (cond.
3f60: 20 28 28 6c 69 73 74 3f 20 64 61 74 29 20 20 20 ((list? dat)
3f70: 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 (map common:to-a
3f80: 6c 69 73 74 20 64 61 74 29 29 0a 20 20 20 28 28 list dat)). ((
3f90: 76 65 63 74 6f 72 3f 20 64 61 74 29 0a 20 20 20 vector? dat).
3fa0: 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d (map common:to-
3fb0: 61 6c 69 73 74 20 28 76 65 63 74 6f 72 2d 3e 6c alist (vector->l
3fc0: 69 73 74 20 64 61 74 29 29 29 0a 20 20 20 28 28 ist dat))). ((
3fd0: 70 61 69 72 3f 20 64 61 74 29 0a 20 20 20 20 28 pair? dat). (
3fe0: 63 6f 6e 73 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d cons (common:to-
3ff0: 61 6c 69 73 74 20 28 63 61 72 20 64 61 74 29 29 alist (car dat))
4000: 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 .. (common:to-a
4010: 6c 69 73 74 20 28 63 64 72 20 64 61 74 29 29 29 list (cdr dat)))
4020: 29 0a 20 20 20 28 28 68 61 73 68 2d 74 61 62 6c ). ((hash-tabl
4030: 65 3f 20 64 61 74 29 0a 20 20 20 20 28 6d 61 70 e? dat). (map
4040: 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 common:to-alist
4050: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c (hash-table->al
4060: 69 73 74 20 64 61 74 29 29 29 0a 20 20 20 28 65 ist dat))). (e
4070: 6c 73 65 0a 20 20 20 20 28 69 66 20 64 61 74 0a lse. (if dat.
4080: 09 64 61 74 0a 09 22 22 29 29 29 29 0a 0a 28 64 .dat..""))))..(d
4090: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f efine (common:lo
40a0: 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 77 61 w-noise-print wa
40b0: 69 74 76 61 6c 20 2e 20 6b 65 79 73 29 0a 20 20 itval . keys).
40c0: 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 20 20 20 (let* ((key
40d0: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
40e0: 65 72 73 65 20 28 6d 61 70 20 63 6f 6e 63 20 6b erse (map conc k
40f0: 65 79 73 29 20 22 2d 22 20 29 29 0a 09 20 28 6c eys) "-" )).. (l
4100: 61 73 74 74 69 6d 65 20 28 68 61 73 68 2d 74 61 asttime (hash-ta
4110: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
4120: 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a *common:denoise*
4130: 20 6b 65 79 20 30 29 29 0a 09 20 28 63 75 72 72 key 0)).. (curr
4140: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 time (current-se
4150: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 69 66 conds))). (if
4160: 20 28 3e 20 28 2d 20 63 75 72 72 74 69 6d 65 20 (> (- currtime
4170: 6c 61 73 74 74 69 6d 65 29 20 77 61 69 74 76 61 lasttime) waitva
4180: 6c 29 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 68 l)..(begin.. (h
4190: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
41a0: 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 common:denoise*
41b0: 6b 65 79 20 63 75 72 72 74 69 6d 65 29 0a 09 20 key currtime)..
41c0: 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 #t)..#f)))..(de
41d0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
41e0: 2d 6d 65 67 61 74 65 73 74 2d 65 78 65 29 0a 20 -megatest-exe).
41f0: 20 28 6f 72 20 28 67 65 74 65 6e 76 20 22 4d 54 (or (getenv "MT
4200: 5f 4d 45 47 41 54 45 53 54 22 29 20 22 6d 65 67 _MEGATEST") "meg
4210: 61 74 65 73 74 22 29 29 0a 0a 28 64 65 66 69 6e atest"))..(defin
4220: 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 65 e (common:read-e
4230: 6e 63 6f 64 65 64 2d 73 74 72 69 6e 67 20 69 6e ncoded-string in
4240: 73 74 72 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 str). (handle-e
4250: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e xceptions. exn
4260: 0a 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 . (handle-exce
4270: 70 74 69 6f 6e 73 0a 20 20 20 20 65 78 6e 0a 20 ptions. exn.
4280: 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 (begin.
4290: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 (debug:print-err
42a0: 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f or 0 *default-lo
42b0: 67 2d 70 6f 72 74 2a 20 22 72 65 63 65 69 76 65 g-port* "receive
42c0: 64 20 62 61 64 20 65 6e 63 6f 64 65 64 20 73 74 d bad encoded st
42d0: 72 69 6e 67 20 5c 22 22 20 69 6e 73 74 72 20 22 ring \"" instr "
42e0: 5c 22 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 28 \", message: " (
42f0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
4300: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
4310: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
4320: 29 0a 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 ). (print-c
4330: 61 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 all-chain (curre
4340: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a nt-error-port)).
4350: 20 20 20 20 20 20 23 66 29 0a 20 20 20 20 28 72 #f). (r
4360: 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d ead (open-input-
4370: 73 74 72 69 6e 67 20 28 62 61 73 65 36 34 3a 62 string (base64:b
4380: 61 73 65 36 34 2d 64 65 63 6f 64 65 20 69 6e 73 ase64-decode ins
4390: 74 72 29 29 29 29 0a 20 20 20 28 72 65 61 64 20 tr)))). (read
43a0: 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 (open-input-stri
43b0: 6e 67 20 28 7a 33 3a 64 65 63 6f 64 65 2d 62 75 ng (z3:decode-bu
43c0: 66 66 65 72 20 28 62 61 73 65 36 34 3a 62 61 73 ffer (base64:bas
43d0: 65 36 34 2d 64 65 63 6f 64 65 20 69 6e 73 74 72 e64-decode instr
43e0: 29 29 29 29 29 29 0a 0a 3b 3b 20 64 6f 74 2d 6c ))))))..;; dot-l
43f0: 6f 63 6b 69 6e 67 20 65 67 67 20 73 65 65 6d 73 ocking egg seems
4400: 20 6e 6f 74 20 74 6f 20 77 6f 72 6b 2c 20 75 73 not to work, us
4410: 69 6e 67 20 74 68 69 73 20 66 6f 72 20 6e 6f 77 ing this for now
4420: 0a 3b 3b 20 69 66 20 6c 6f 63 6b 20 69 73 20 6f .;; if lock is o
4430: 6c 64 65 72 20 74 68 61 6e 20 65 78 70 69 72 65 lder than expire
4440: 2d 74 69 6d 65 20 74 68 65 6e 20 72 65 6d 6f 76 -time then remov
4450: 65 20 69 74 20 61 6e 64 20 74 72 79 20 61 67 61 e it and try aga
4460: 69 6e 0a 3b 3b 20 74 6f 20 67 65 74 20 74 68 65 in.;; to get the
4470: 20 6c 6f 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e 65 lock.;;.(define
4480: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
4490: 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 file-lock fname
44a0: 23 21 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 #!key (expire-ti
44b0: 6d 65 20 33 30 30 29 29 0a 20 20 28 68 61 6e 64 me 300)). (hand
44c0: 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 le-exceptions.
44d0: 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 23 66 exn. #f
44e0: 20 3b 3b 20 64 6f 6e 27 74 20 72 65 61 6c 6c 79 ;; don't really
44f0: 20 63 61 72 65 20 77 68 61 74 20 77 65 6e 74 20 care what went
4500: 77 72 6f 6e 67 20 72 69 67 68 74 20 6e 6f 77 2e wrong right now.
4510: 20 4e 4f 54 45 3a 20 49 20 68 61 76 65 20 6e 6f NOTE: I have no
4520: 74 20 73 65 65 6e 20 74 68 69 73 20 6f 6e 65 20 t seen this one
4530: 61 63 74 75 61 6c 6c 79 20 66 61 69 6c 2e 0a 20 actually fail..
4540: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 (if (common:f
4550: 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d ile-exists? fnam
4560: 65 29 0a 09 28 69 66 20 28 3e 20 28 2d 20 28 63 e)..(if (> (- (c
4570: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
4580: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
4590: 6e 2d 74 69 6d 65 20 66 6e 61 6d 65 29 29 20 65 n-time fname)) e
45a0: 78 70 69 72 65 2d 74 69 6d 65 29 0a 09 20 20 20 xpire-time)..
45b0: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 28 (begin.. (
45c0: 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 delete-file* fna
45d0: 6d 65 29 0a 09 20 20 20 20 20 20 28 63 6f 6d 6d me).. (comm
45e0: 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c on:simple-file-l
45f0: 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 ock fname expire
4600: 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 -time: expire-ti
4610: 6d 65 29 29 0a 09 20 20 20 20 23 66 29 0a 09 28 me)).. #f)..(
4620: 6c 65 74 20 28 28 6b 65 79 2d 73 74 72 69 6e 67 let ((key-string
4630: 20 28 63 6f 6e 63 20 28 67 65 74 2d 68 6f 73 74 (conc (get-host
4640: 2d 6e 61 6d 65 29 20 22 2d 22 20 28 63 75 72 72 -name) "-" (curr
4650: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
4660: 29 29 0a 09 20 20 28 77 69 74 68 2d 6f 75 74 70 )).. (with-outp
4670: 75 74 2d 74 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 ut-to-file fname
4680: 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 .. (lambda ()
4690: 0a 09 20 20 20 20 20 20 28 70 72 69 6e 74 20 6b .. (print k
46a0: 65 79 2d 73 74 72 69 6e 67 29 29 29 0a 09 20 20 ey-string)))..
46b0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
46c0: 2e 32 35 29 0a 09 20 20 28 69 66 20 28 63 6f 6d .25).. (if (com
46d0: 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f mon:file-exists?
46e0: 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 20 28 fname).. (
46f0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
4700: 66 69 6c 65 20 66 6e 61 6d 65 0a 09 09 28 6c 61 file fname...(la
4710: 6d 62 64 61 20 28 29 0a 09 09 20 20 28 65 71 75 mbda ()... (equ
4720: 61 6c 3f 20 6b 65 79 2d 73 74 72 69 6e 67 20 28 al? key-string (
4730: 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 0a 09 20 read-line))))..
4740: 20 20 20 20 20 23 66 29 29 29 29 29 0a 0a 28 64 #f)))))..(d
4750: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 efine (common:si
4760: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 2d 61 mple-file-lock-a
4770: 6e 64 2d 77 61 69 74 20 66 6e 61 6d 65 20 23 21 nd-wait fname #!
4780: 6b 65 79 20 28 65 78 70 69 72 65 2d 74 69 6d 65 key (expire-time
4790: 20 33 30 30 29 29 0a 20 20 28 6c 65 74 20 28 28 300)). (let ((
47a0: 65 6e 64 2d 74 69 6d 65 20 28 2b 20 65 78 70 69 end-time (+ expi
47b0: 72 65 2d 74 69 6d 65 20 28 63 75 72 72 65 6e 74 re-time (current
47c0: 2d 73 65 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 -seconds)))).
47d0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 67 6f 74 (let loop ((got
47e0: 2d 6c 6f 63 6b 20 28 63 6f 6d 6d 6f 6e 3a 73 69 -lock (common:si
47f0: 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 mple-file-lock f
4800: 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d 65 name expire-time
4810: 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 29 : expire-time)))
4820: 0a 20 20 20 20 20 20 28 69 66 20 67 6f 74 2d 6c . (if got-l
4830: 6f 63 6b 0a 09 20 20 23 74 0a 09 20 20 28 69 66 ock.. #t.. (if
4840: 20 28 3e 20 65 6e 64 2d 74 69 6d 65 20 28 63 75 (> end-time (cu
4850: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a rrent-seconds)).
4860: 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 . (begin...
4870: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 33 (thread-sleep! 3
4880: 29 0a 09 09 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f )...(loop (commo
4890: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f n:simple-file-lo
48a0: 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d ck fname expire-
48b0: 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d time: expire-tim
48c0: 65 29 29 29 0a 09 20 20 20 20 20 20 23 66 29 29 e))).. #f))
48d0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
48e0: 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 mmon:simple-file
48f0: 2d 72 65 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e -release-lock fn
4900: 61 6d 65 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 ame). (handle-e
4910: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 xceptions.
4920: 65 78 6e 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 exn. #f ;;
4930: 49 20 64 6f 6e 27 74 20 72 65 61 6c 6c 79 20 63 I don't really c
4940: 61 72 65 20 77 68 79 20 74 68 69 73 20 66 61 69 are why this fai
4950: 6c 65 64 20 28 61 74 20 6c 65 61 73 74 20 66 6f led (at least fo
4960: 72 20 6e 6f 77 29 0a 20 20 20 20 28 64 65 6c 65 r now). (dele
4970: 74 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 te-file* fname))
4980: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
4990: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
49c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 ===========.;; S
49d0: 20 54 20 41 20 54 20 45 20 53 20 20 20 41 20 4e T A T E S A N
49e0: 20 44 20 20 20 53 20 54 20 41 20 54 20 55 20 53 D S T A T U S
49f0: 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d E S.;;=========
4a00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4a30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
4a40: 3b 20 42 42 6e 6f 74 65 3a 20 2a 63 6f 6d 6d 6f ; BBnote: *commo
4a50: 6e 3a 73 74 64 2d 73 74 61 74 65 73 2a 20 2d 20 n:std-states* -
4a60: 64 61 73 68 62 6f 61 72 64 20 66 69 6c 74 65 72 dashboard filter
4a70: 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 74 65 73 control and tes
4a80: 74 20 63 6f 6e 74 72 6f 6c 20 73 74 61 74 65 20 t control state
4a90: 62 75 74 74 6f 6e 73 20 64 65 66 69 6e 65 64 20 buttons defined
4aa0: 68 65 72 65 3b 20 75 73 65 64 20 69 6e 20 73 65 here; used in se
4ab0: 74 2d 66 69 65 6c 64 73 2d 70 61 6e 65 6c 20 61 t-fields-panel a
4ac0: 6e 64 20 64 62 6f 61 72 64 3a 6d 61 6b 65 2d 63 nd dboard:make-c
4ad0: 6f 6e 74 72 6f 6c 73 0a 28 64 65 66 69 6e 65 20 ontrols.(define
4ae0: 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 *common:std-stat
4af0: 65 73 2a 20 20 20 3b 3b 20 66 6f 72 20 74 6f 67 es* ;; for tog
4b00: 67 6c 65 20 62 75 74 74 6f 6e 73 20 69 6e 20 64 gle buttons in d
4b10: 61 73 68 62 6f 61 72 64 0a 20 20 27 28 28 30 20 ashboard. '((0
4b20: 22 41 52 43 48 49 56 45 44 22 29 0a 20 20 20 20 "ARCHIVED").
4b30: 28 31 20 22 53 54 55 43 4b 22 29 0a 20 20 20 20 (1 "STUCK").
4b40: 28 32 20 22 4b 49 4c 4c 52 45 51 22 29 0a 20 20 (2 "KILLREQ").
4b50: 20 20 28 33 20 22 4b 49 4c 4c 45 44 22 29 0a 20 (3 "KILLED").
4b60: 20 20 20 28 34 20 22 4e 4f 54 5f 53 54 41 52 54 (4 "NOT_START
4b70: 45 44 22 29 0a 20 20 20 20 28 35 20 22 43 4f 4d ED"). (5 "COM
4b80: 50 4c 45 54 45 44 22 29 0a 20 20 20 20 28 36 20 PLETED"). (6
4b90: 22 4c 41 55 4e 43 48 45 44 22 29 0a 20 20 20 20 "LAUNCHED").
4ba0: 28 37 20 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 (7 "REMOTEHOSTST
4bb0: 41 52 54 22 29 0a 20 20 20 20 28 38 20 22 52 55 ART"). (8 "RU
4bc0: 4e 4e 49 4e 47 22 29 0a 20 20 20 20 29 29 0a 0a NNING"). ))..
4bd0: 3b 3b 20 42 42 6e 6f 74 65 3a 20 2a 63 6f 6d 6d ;; BBnote: *comm
4be0: 6f 6e 3a 73 74 64 2d 73 74 61 74 75 73 65 73 2a on:std-statuses*
4bf0: 20 64 61 73 68 62 6f 61 72 64 20 66 69 6c 74 65 dashboard filte
4c00: 72 20 63 6f 6e 74 72 6f 6c 20 61 6e 64 20 74 65 r control and te
4c10: 73 74 20 63 6f 6e 74 72 6f 6c 20 73 74 61 74 75 st control statu
4c20: 73 20 62 75 74 74 6f 6e 73 20 64 65 66 69 6e 65 s buttons define
4c30: 64 20 68 65 72 65 3b 20 75 73 65 64 20 69 6e 20 d here; used in
4c40: 73 65 74 2d 66 69 65 6c 64 73 2d 70 61 6e 65 6c set-fields-panel
4c50: 20 61 6e 64 20 64 62 6f 61 72 64 3a 6d 61 6b 65 and dboard:make
4c60: 2d 63 6f 6e 74 72 6f 6c 73 0a 28 64 65 66 69 6e -controls.(defin
4c70: 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 e *common:std-st
4c80: 61 74 75 73 65 73 2a 0a 20 20 27 28 3b 3b 20 28 atuses*. '(;; (
4c90: 30 20 22 44 45 4c 45 54 45 44 22 29 0a 20 20 20 0 "DELETED").
4ca0: 20 28 31 20 22 6e 2f 61 22 29 0a 20 20 20 20 28 (1 "n/a"). (
4cb0: 32 20 22 50 41 53 53 22 29 0a 20 20 20 20 28 33 2 "PASS"). (3
4cc0: 20 22 53 4b 49 50 22 29 0a 20 20 20 20 28 34 20 "SKIP"). (4
4cd0: 22 57 41 52 4e 22 29 0a 20 20 20 20 28 35 20 22 "WARN"). (5 "
4ce0: 57 41 49 56 45 44 22 29 0a 20 20 20 20 28 36 20 WAIVED"). (6
4cf0: 22 43 48 45 43 4b 22 29 0a 20 20 20 20 28 37 20 "CHECK"). (7
4d00: 22 53 54 55 43 4b 2f 44 45 41 44 22 29 0a 20 20 "STUCK/DEAD").
4d10: 20 20 28 38 20 22 46 41 49 4c 22 29 0a 20 20 20 (8 "FAIL").
4d20: 20 28 39 20 22 41 42 4f 52 54 22 29 29 29 0a 0a (9 "ABORT")))..
4d30: 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a (define *common:
4d40: 65 6e 64 65 64 2d 73 74 61 74 65 73 2a 20 20 20 ended-states*
4d50: 20 20 20 20 3b 3b 20 73 74 61 74 65 73 20 77 68 ;; states wh
4d60: 69 63 68 20 69 6e 64 69 63 61 74 65 20 74 68 65 ich indicate the
4d70: 20 74 65 73 74 20 69 73 20 73 74 6f 70 70 65 64 test is stopped
4d80: 20 61 6e 64 20 77 69 6c 6c 20 6e 6f 74 20 70 72 and will not pr
4d90: 6f 63 65 65 64 0a 20 20 27 28 22 43 4f 4d 50 4c oceed. '("COMPL
4da0: 45 54 45 44 22 20 22 41 52 43 48 49 56 45 44 22 ETED" "ARCHIVED"
4db0: 20 22 4b 49 4c 4c 45 44 22 20 22 4b 49 4c 4c 52 "KILLED" "KILLR
4dc0: 45 51 22 20 22 53 54 55 43 4b 22 20 22 49 4e 43 EQ" "STUCK" "INC
4dd0: 4f 4d 50 4c 45 54 45 22 29 29 0a 0a 28 64 65 66 OMPLETE"))..(def
4de0: 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 62 61 64 6c ine *common:badl
4df0: 79 2d 65 6e 64 65 64 2d 73 74 61 74 65 73 2a 20 y-ended-states*
4e00: 3b 3b 20 74 68 65 73 65 20 72 6f 6c 6c 20 75 70 ;; these roll up
4e10: 20 61 73 20 43 48 45 43 4b 2c 20 69 2e 65 2e 20 as CHECK, i.e.
4e20: 72 65 73 75 6c 74 73 20 6e 65 65 64 20 74 6f 20 results need to
4e30: 62 65 20 63 68 65 63 6b 65 64 0a 20 20 27 28 22 be checked. '("
4e40: 4b 49 4c 4c 45 44 22 20 22 4b 49 4c 4c 52 45 51 KILLED" "KILLREQ
4e50: 22 20 22 53 54 55 43 4b 22 20 22 49 4e 43 4f 4d " "STUCK" "INCOM
4e60: 50 4c 45 54 45 22 20 22 44 45 41 44 22 29 29 0a PLETE" "DEAD")).
4e70: 0a 3b 3b 20 42 42 6e 6f 74 65 3a 20 2a 63 6f 6d .;; BBnote: *com
4e80: 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 61 74 mon:running-stat
4e90: 65 73 2a 20 75 73 65 64 20 66 72 6f 6d 20 64 62 es* used from db
4ea0: 3a 73 65 74 2d 73 74 61 74 65 2d 73 74 61 74 75 :set-state-statu
4eb0: 73 2d 61 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 s-and-roll-up-it
4ec0: 65 6d 73 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d ems.(define *com
4ed0: 6d 6f 6e 3a 72 75 6e 6e 69 6e 67 2d 73 74 61 74 mon:running-stat
4ee0: 65 73 2a 20 20 20 20 20 3b 3b 20 74 65 73 74 20 es* ;; test
4ef0: 69 73 20 65 69 74 68 65 72 20 72 75 6e 6e 69 6e is either runnin
4f00: 67 20 6f 72 20 63 61 6e 20 62 65 20 72 75 6e 0a g or can be run.
4f10: 20 20 27 28 22 52 55 4e 4e 49 4e 47 22 20 22 52 '("RUNNING" "R
4f20: 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 22 20 EMOTEHOSTSTART"
4f30: 22 4c 41 55 4e 43 48 45 44 22 20 22 53 54 41 52 "LAUNCHED" "STAR
4f40: 54 45 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 TED"))..(define
4f50: 2a 63 6f 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e *common:cant-run
4f60: 2d 73 74 61 74 65 73 2a 20 20 20 20 3b 3b 20 54 -states* ;; T
4f70: 68 65 73 65 20 61 72 65 20 73 74 6f 70 70 69 6e hese are stoppin
4f80: 67 20 63 6f 6e 64 69 74 69 6f 6e 73 20 74 68 61 g conditions tha
4f90: 74 20 70 72 65 76 65 6e 74 20 61 20 74 65 73 74 t prevent a test
4fa0: 20 66 72 6f 6d 20 62 65 69 6e 67 20 72 75 6e 0a from being run.
4fb0: 20 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 20 '("COMPLETED"
4fc0: 22 4b 49 4c 4c 45 44 22 20 22 55 4e 4b 4e 4f 57 "KILLED" "UNKNOW
4fd0: 4e 22 20 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 N" "INCOMPLETE"
4fe0: 22 41 52 43 48 49 56 45 44 22 29 29 0a 0a 28 64 "ARCHIVED"))..(d
4ff0: 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 6e 6f efine *common:no
5000: 74 2d 73 74 61 72 74 65 64 2d 6f 6b 2d 73 74 61 t-started-ok-sta
5010: 74 75 73 65 73 2a 20 3b 3b 20 69 66 20 6e 6f 74 tuses* ;; if not
5020: 20 6f 6e 65 20 6f 66 20 74 68 65 73 65 20 73 74 one of these st
5030: 61 74 75 73 65 73 20 77 68 65 6e 20 69 6e 20 6e atuses when in n
5040: 6f 74 5f 73 74 61 72 74 65 64 20 73 74 61 74 65 ot_started state
5050: 20 74 72 65 61 74 20 61 73 20 64 65 61 64 0a 20 treat as dead.
5060: 20 27 28 22 6e 2f 61 22 20 22 6e 61 22 20 22 50 '("n/a" "na" "P
5070: 41 53 53 22 20 22 46 41 49 4c 22 20 22 57 41 52 ASS" "FAIL" "WAR
5080: 4e 22 20 22 43 48 45 43 4b 22 20 22 57 41 49 56 N" "CHECK" "WAIV
5090: 45 44 22 20 22 44 45 41 44 22 20 22 53 4b 49 50 ED" "DEAD" "SKIP
50a0: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f "))..(define (co
50b0: 6d 6d 6f 6e 3a 73 70 65 63 69 61 6c 2d 73 6f 72 mmon:special-sor
50c0: 74 20 69 74 65 6d 73 20 6f 72 64 65 72 20 63 6f t items order co
50d0: 6d 70 29 0a 20 20 28 6c 65 74 20 28 28 69 74 65 mp). (let ((ite
50e0: 6d 73 2d 6f 72 64 65 72 20 28 6d 61 70 20 72 65 ms-order (map re
50f0: 76 65 72 73 65 20 6f 72 64 65 72 29 29 0a 20 20 verse order)).
5100: 20 20 20 20 20 20 28 61 63 6f 6d 70 20 20 20 20 (acomp
5110: 20 20 20 28 6f 72 20 63 6f 6d 70 20 3e 29 29 29 (or comp >)))
5120: 0a 20 20 20 20 28 73 6f 72 74 20 69 74 65 6d 73 . (sort items
5130: 0a 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 . (lambda
5140: 20 28 61 20 62 29 0a 20 20 20 20 20 20 20 20 20 (a b).
5150: 20 28 6c 65 74 20 28 28 61 2d 6e 75 6d 20 28 63 (let ((a-num (c
5160: 61 64 72 20 28 6f 72 20 28 61 73 73 6f 63 20 61 adr (or (assoc a
5170: 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 20 27 28 items-order) '(
5180: 30 20 30 29 29 29 29 0a 20 20 20 20 20 20 20 20 0 0)))).
5190: 20 20 20 20 20 20 20 20 28 62 2d 6e 75 6d 20 28 (b-num (
51a0: 63 61 64 72 20 28 6f 72 20 28 61 73 73 6f 63 20 cadr (or (assoc
51b0: 62 20 69 74 65 6d 73 2d 6f 72 64 65 72 29 20 27 b items-order) '
51c0: 28 30 20 30 29 29 29 29 29 0a 20 20 20 20 20 20 (0 0))))).
51d0: 20 20 20 20 20 20 28 61 63 6f 6d 70 20 61 2d 6e (acomp a-n
51e0: 75 6d 20 62 2d 6e 75 6d 29 29 29 29 29 29 0a 0a um b-num))))))..
51f0: 3b 3b 20 3b 3b 20 67 69 76 65 6e 20 61 20 74 6f ;; ;; given a to
5200: 70 6c 65 76 65 6c 20 77 69 74 68 20 63 75 72 72 plevel with curr
5210: 73 74 61 74 65 2c 20 63 75 72 72 73 74 61 74 75 state, currstatu
5220: 73 20 61 70 70 6c 79 20 73 74 61 74 65 20 61 6e s apply state an
5230: 64 20 73 74 61 74 75 73 0a 3b 3b 20 3b 3b 20 20 d status.;; ;;
5240: 3d 3e 20 28 6e 65 77 73 74 61 74 65 20 2e 20 6e => (newstate . n
5250: 65 77 73 74 61 74 75 73 29 0a 3b 3b 20 28 64 65 ewstatus).;; (de
5260: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 70 70 fine (common:app
5270: 6c 79 2d 73 74 61 74 65 2d 73 74 61 74 75 73 20 ly-state-status
5280: 63 75 72 72 73 74 61 74 65 20 63 75 72 72 73 74 currstate currst
5290: 61 74 75 73 20 73 74 61 74 65 20 73 74 61 74 75 atus state statu
52a0: 73 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 s).;; (let* ((
52b0: 63 73 74 61 74 65 20 20 28 73 74 72 69 6e 67 2d cstate (string-
52c0: 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d >symbol (string-
52d0: 64 6f 77 6e 63 61 73 65 20 63 75 72 72 73 74 61 downcase currsta
52e0: 74 65 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 te))).;;
52f0: 20 20 28 63 73 74 61 74 75 73 20 28 73 74 72 69 (cstatus (stri
5300: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 ng->symbol (stri
5310: 6e 67 2d 64 6f 77 6e 63 61 73 65 20 63 75 72 72 ng-downcase curr
5320: 73 74 61 74 75 73 29 29 29 0a 3b 3b 20 20 20 20 status))).;;
5330: 20 20 20 20 20 20 28 73 73 74 61 74 65 20 20 28 (sstate (
5340: 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 string->symbol (
5350: 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 string-downcase
5360: 73 74 61 74 65 29 29 29 0a 3b 3b 20 20 20 20 20 state))).;;
5370: 20 20 20 20 20 28 73 73 74 61 74 75 73 20 28 73 (sstatus (s
5380: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 tring->symbol (s
5390: 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 73 tring-downcase s
53a0: 74 61 74 75 73 29 29 29 0a 3b 3b 20 20 20 20 20 tatus))).;;
53b0: 20 20 20 20 20 28 6e 73 74 61 74 65 20 20 23 66 (nstate #f
53c0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6e ).;; (n
53d0: 73 74 61 74 75 73 20 23 66 29 29 0a 3b 3b 20 20 status #f)).;;
53e0: 20 20 20 28 73 65 74 21 20 6e 73 74 61 74 65 0a (set! nstate.
53f0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 63 61 ;; (ca
5400: 73 65 20 63 73 74 61 74 65 0a 3b 3b 20 20 20 20 se cstate.;;
5410: 20 20 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c ((compl
5420: 65 74 65 64 20 6e 6f 74 5f 73 74 61 72 74 65 64 eted not_started
5430: 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 71 20 killed killreq
5440: 73 74 75 63 6b 20 61 72 63 68 69 76 65 64 29 20 stuck archived)
5450: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
5460: 20 28 63 61 73 65 20 73 73 74 61 74 65 20 3b 3b (case sstate ;;
5470: 20 63 6f 6d 70 6c 65 74 65 64 20 2d 3e 20 73 73 completed -> ss
5480: 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 tate.;;
5490: 20 20 20 20 20 20 20 28 28 63 6f 6d 70 6c 65 74 ((complet
54a0: 65 64 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 ed killed killre
54b0: 71 20 73 74 75 63 6b 20 61 72 63 68 69 76 65 64 q stuck archived
54c0: 29 20 63 6f 6d 70 6c 65 74 65 64 29 0a 3b 3b 20 ) completed).;;
54d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
54e0: 28 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 (running remoteh
54f0: 6f 73 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 oststart launche
5500: 64 29 20 20 20 20 20 20 20 20 72 75 6e 6e 69 6e d) runnin
5510: 67 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 g).;;
5520: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
5530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5550: 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 31 29 unknown-error-1)
5560: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 )).;;
5570: 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 65 6d 6f ((running remo
5580: 74 65 68 6f 73 74 73 74 61 72 74 20 6c 61 75 6e tehoststart laun
5590: 63 68 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 ched).;;
55a0: 20 20 20 20 20 20 28 63 61 73 65 20 73 73 74 61 (case ssta
55b0: 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 te.;;
55c0: 20 20 20 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 ((completed
55d0: 20 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 71 20 killed killreq
55e0: 73 74 75 63 6b 20 61 72 63 68 69 76 65 64 29 20 stuck archived)
55f0: 23 66 29 20 3b 3b 20 6e 65 65 64 20 74 6f 20 6c #f) ;; need to l
5600: 6f 6f 6b 20 61 74 20 61 6c 6c 20 69 74 65 6d 73 ook at all items
5610: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
5620: 20 20 20 28 28 72 75 6e 6e 69 6e 67 20 72 65 6d ((running rem
5630: 6f 74 65 68 6f 73 74 73 74 61 72 74 20 6c 61 75 otehoststart lau
5640: 6e 63 68 65 64 29 20 20 20 20 20 20 20 20 72 75 nched) ru
5650: 6e 6e 69 6e 67 29 0a 3b 3b 20 20 20 20 20 20 20 nning).;;
5660: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 (else
5670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5690: 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f unknown-erro
56a0: 72 2d 32 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 r-2))).;;
56b0: 20 20 20 20 20 20 28 65 6c 73 65 20 75 6e 6b 6e (else unkn
56c0: 6f 77 6e 2d 65 72 72 6f 72 2d 33 29 29 29 0a 3b own-error-3))).;
56d0: 3b 20 20 20 20 20 28 73 65 74 21 20 6e 73 74 61 ; (set! nsta
56e0: 74 75 73 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 tus.;;
56f0: 20 28 63 61 73 65 20 73 73 74 61 74 75 73 0a 3b (case sstatus.;
5700: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ; ((
5710: 70 61 73 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 pass).;;
5720: 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 74 61 (case nsta
5730: 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 te.;;
5740: 20 20 20 20 20 28 28 70 61 73 73 20 6e 2f 61 20 ((pass n/a
5750: 64 65 6c 65 74 65 64 29 20 20 20 20 20 70 61 73 deleted) pas
5760: 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 s).;;
5770: 20 20 20 20 20 28 28 77 61 72 6e 29 20 20 20 20 ((warn)
5780: 20 20 20 20 20 20 20 20 20 20 20 20 20 77 61 72 war
5790: 6e 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 n).;;
57a0: 20 20 20 20 20 28 28 66 61 69 6c 29 20 20 20 20 ((fail)
57b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 66 61 69 fai
57c0: 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 l).;;
57d0: 20 20 20 20 20 28 28 63 68 65 63 6b 29 20 20 20 ((check)
57e0: 20 20 20 20 20 20 20 20 20 20 20 20 63 68 65 63 chec
57f0: 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 k).;;
5800: 20 20 20 20 20 28 28 77 61 69 76 65 64 29 20 20 ((waived)
5810: 20 20 20 20 20 20 20 20 20 20 20 77 61 69 76 65 waive
5820: 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 d).;;
5830: 20 20 20 20 20 28 28 73 6b 69 70 29 20 20 20 20 ((skip)
5840: 20 20 20 20 20 20 20 20 20 20 20 20 20 73 6b 69 ski
5850: 70 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 p).;;
5860: 20 20 20 20 20 28 28 73 74 75 63 6b 2f 64 65 61 ((stuck/dea
5870: 64 29 20 20 20 20 20 20 20 20 20 20 73 74 75 63 d) stuc
5880: 6b 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 k).;;
5890: 20 20 20 20 20 28 28 61 62 6f 72 74 29 20 20 20 ((abort)
58a0: 20 20 20 20 20 20 20 20 20 20 20 20 61 62 6f 72 abor
58b0: 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 t).;;
58c0: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
58d0: 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d unknown-error-
58e0: 34 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 4))).;;
58f0: 20 20 20 20 28 28 77 61 72 6e 29 0a 3b 3b 20 20 ((warn).;;
5900: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 (cas
5910: 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 e nstate.;;
5920: 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 73 ((pas
5930: 73 20 77 61 72 6e 20 6e 2f 61 20 73 6b 69 70 20 s warn n/a skip
5940: 64 65 6c 65 74 65 64 29 20 20 20 77 61 72 6e 29 deleted) warn)
5950: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
5960: 20 20 20 28 28 66 61 69 6c 29 20 20 20 20 20 20 ((fail)
5970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5980: 20 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 20 20 fail).;;
5990: 20 20 20 20 20 20 20 20 20 20 20 28 28 63 68 65 ((che
59a0: 63 6b 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ck)
59b0: 20 20 20 20 20 20 20 20 20 20 63 68 65 63 6b 29 check)
59c0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
59d0: 20 20 20 28 28 77 61 69 76 65 64 29 20 20 20 20 ((waived)
59e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
59f0: 20 77 61 69 76 65 64 29 0a 3b 3b 20 20 20 20 20 waived).;;
5a00: 20 20 20 20 20 20 20 20 20 20 20 28 28 73 74 75 ((stu
5a10: 63 6b 2f 64 65 61 64 29 20 20 20 20 20 20 20 20 ck/dead)
5a20: 20 20 20 20 20 20 20 20 20 20 73 74 75 63 6b 29 stuck)
5a30: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
5a40: 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 (else
5a50: 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d unknown-
5a60: 65 72 72 6f 72 2d 35 29 29 29 0a 3b 3b 20 20 20 error-5))).;;
5a70: 20 20 20 20 20 20 20 20 20 20 28 28 66 61 69 6c ((fail
5a80: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
5a90: 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 0a 3b (case nstate.;
5aa0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;
5ab0: 20 28 28 70 61 73 73 20 77 61 72 6e 20 66 61 69 ((pass warn fai
5ac0: 6c 20 63 68 65 63 6b 20 6e 2f 61 20 77 61 69 76 l check n/a waiv
5ad0: 65 64 20 73 6b 69 70 20 64 65 6c 65 74 65 64 20 ed skip deleted
5ae0: 73 74 75 63 6b 2f 64 65 61 64 20 73 74 75 63 6b stuck/dead stuck
5af0: 29 20 20 66 61 69 6c 29 0a 3b 3b 20 20 20 20 20 ) fail).;;
5b00: 20 20 20 20 20 20 20 20 20 20 20 28 28 61 62 6f ((abo
5b10: 72 74 29 20 20 20 20 20 20 20 20 20 20 20 20 20 rt)
5b20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b40: 20 20 20 20 20 20 20 20 20 20 20 20 61 62 6f 72 abor
5b50: 74 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 t).;;
5b60: 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
5b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b90: 20 20 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e unkn
5ba0: 6f 77 6e 2d 65 72 72 6f 72 2d 36 29 29 29 0a 3b own-error-6))).;
5bb0: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 ; (e
5bc0: 6c 73 65 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 lse unknown-e
5bd0: 72 72 6f 72 2d 37 29 29 29 0a 3b 3b 20 20 20 20 rror-7))).;;
5be0: 20 28 63 6f 6e 73 20 0a 3b 3b 20 20 20 20 20 20 (cons .;;
5bf0: 28 69 66 20 6e 73 74 61 74 65 20 20 28 73 79 6d (if nstate (sym
5c00: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 73 74 61 bol->string nsta
5c10: 74 65 29 20 20 6e 73 74 61 74 65 29 0a 3b 3b 20 te) nstate).;;
5c20: 20 20 20 20 20 28 69 66 20 6e 73 74 61 74 75 73 (if nstatus
5c30: 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 (symbol->string
5c40: 20 6e 73 74 61 74 75 73 29 20 6e 73 74 61 74 75 nstatus) nstatu
5c50: 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 s)))).
5c60: 20 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d .;;========
5c70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5c90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5ca0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
5cb0: 3b 20 44 20 45 20 42 20 55 20 47 20 47 20 49 20 ; D E B U G G I
5cc0: 4e 20 47 20 20 20 53 20 54 20 55 20 46 20 46 20 N G S T U F F
5cd0: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
5ce0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
5d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
5d20: 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 2a 20 20 ne *verbosity*
5d30: 20 20 20 20 20 20 20 31 29 0a 28 64 65 66 69 6e 1).(defin
5d40: 65 20 2a 6c 6f 67 67 69 6e 67 2a 20 20 20 20 20 e *logging*
5d50: 20 20 20 20 20 20 23 66 29 0a 0a 28 64 65 66 69 #f)..(defi
5d60: 6e 65 20 28 67 65 74 2d 77 69 74 68 2d 64 65 66 ne (get-with-def
5d70: 61 75 6c 74 20 76 61 6c 20 64 65 66 61 75 6c 74 ault val default
5d80: 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 ). (let ((val (
5d90: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 76 61 6c args:get-arg val
5da0: 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c 20 ))). (if val
5db0: 76 61 6c 20 64 65 66 61 75 6c 74 29 29 29 0a 0a val default)))..
5dc0: 28 64 65 66 69 6e 65 20 28 61 73 73 6f 63 2f 64 (define (assoc/d
5dd0: 65 66 61 75 6c 74 20 6b 65 79 20 6c 73 74 20 2e efault key lst .
5de0: 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 default). (let
5df0: 20 28 28 72 65 73 20 28 61 73 73 6f 63 20 6b 65 ((res (assoc ke
5e00: 79 20 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 y lst))). (if
5e10: 20 72 65 73 20 28 63 61 64 72 20 72 65 73 29 28 res (cadr res)(
5e20: 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 75 6c if (null? defaul
5e30: 74 29 20 23 66 20 28 63 61 72 20 64 65 66 61 75 t) #f (car defau
5e40: 6c 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 lt)))))..(define
5e50: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 (common:get-tes
5e60: 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a 20 20 28 tsuite-name). (
5e70: 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b or (configf:look
5e80: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
5e90: 73 65 74 75 70 22 20 22 61 72 65 61 2d 6e 61 6d setup" "area-nam
5ea0: 65 22 29 20 3b 3b 20 6d 65 67 61 74 65 73 74 20 e") ;; megatest
5eb0: 69 73 20 61 20 66 6c 65 78 69 62 6c 65 20 74 6f is a flexible to
5ec0: 6f 6c 2c 20 74 65 73 74 73 75 69 74 65 20 69 73 ol, testsuite is
5ed0: 20 74 6f 6f 20 6c 69 6d 69 74 69 6e 67 20 61 20 too limiting a
5ee0: 64 65 73 63 72 69 70 74 69 6f 6e 2e 0a 20 20 20 description..
5ef0: 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b (configf:look
5f00: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
5f10: 73 65 74 75 70 22 20 22 74 65 73 74 73 75 69 74 setup" "testsuit
5f20: 65 22 20 29 0a 20 20 20 20 20 20 28 67 65 74 65 e" ). (gete
5f30: 6e 76 20 22 4d 54 5f 54 45 53 54 53 55 49 54 45 nv "MT_TESTSUITE
5f40: 5f 4e 41 4d 45 22 29 0a 20 20 20 20 20 20 28 69 _NAME"). (i
5f50: 66 20 28 73 74 72 69 6e 67 3f 20 2a 74 6f 70 70 f (string? *topp
5f60: 61 74 68 2a 20 29 0a 20 20 20 20 20 20 20 20 20 ath* ).
5f70: 20 28 70 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 (pathname-file
5f80: 2a 74 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 20 *toppath*).
5f90: 20 20 20 20 20 23 66 29 29 29 20 3b 3b 20 28 70 #f))) ;; (p
5fa0: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 28 63 75 athname-file (cu
5fb0: 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 rrent-directory)
5fc0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 63 6f ))))..(define co
5fd0: 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 mmon:get-area-na
5fe0: 6d 65 20 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 me common:get-te
5ff0: 73 74 73 75 69 74 65 2d 6e 61 6d 65 29 0a 0a 28 stsuite-name)..(
6000: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
6010: 65 74 2d 64 62 2d 74 6d 70 2d 61 72 65 61 20 2e et-db-tmp-area .
6020: 20 6a 75 6e 6b 29 0a 20 20 28 69 66 20 2a 64 62 junk). (if *db
6030: 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 20 20 -cache-path*.
6040: 20 20 20 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 *db-cache-pat
6050: 68 2a 0a 20 20 20 20 20 20 28 69 66 20 2a 74 6f h*. (if *to
6060: 70 70 61 74 68 2a 20 3b 3b 20 63 6f 6d 6d 6f 6e ppath* ;; common
6070: 3a 67 65 74 2d 63 72 65 61 74 65 2d 77 72 69 74 :get-create-writ
6080: 65 61 62 6c 65 2d 64 69 72 0a 09 20 20 28 68 61 eable-dir.. (ha
6090: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
60a0: 09 20 20 20 20 20 20 65 78 6e 0a 09 20 20 20 20 . exn..
60b0: 20 20 28 62 65 67 69 6e 0a 09 09 28 64 65 62 75 (begin...(debu
60c0: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
60d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
60e0: 74 2a 20 22 43 6f 75 6c 64 6e 27 74 20 63 72 65 t* "Couldn't cre
60f0: 61 74 65 20 70 61 74 68 20 74 6f 20 22 20 64 62 ate path to " db
6100: 64 69 72 29 0a 09 09 28 65 78 69 74 20 31 29 29 dir)...(exit 1))
6110: 0a 09 20 20 20 20 28 6c 65 74 20 28 28 64 62 70 .. (let ((dbp
6120: 61 74 68 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ath (common:get-
6130: 63 72 65 61 74 65 2d 77 72 69 74 65 61 62 6c 65 create-writeable
6140: 2d 64 69 72 0a 09 09 09 20 20 20 28 6c 69 73 74 -dir.... (list
6150: 20 28 63 6f 6e 63 20 22 2f 74 6d 70 2f 22 20 28 (conc "/tmp/" (
6160: 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d current-user-nam
6170: 65 29 0a 09 09 09 09 20 20 20 20 20 20 20 22 2f e)..... "/
6180: 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c 64 62 megatest_localdb
6190: 2f 22 0a 09 09 09 09 20 20 20 20 20 20 20 28 63 /"..... (c
61a0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 ommon:get-testsu
61b0: 69 74 65 2d 6e 61 6d 65 29 20 22 2f 22 0a 09 09 ite-name) "/"...
61c0: 09 09 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 .. (string
61d0: 2d 74 72 61 6e 73 6c 61 74 65 20 2a 74 6f 70 70 -translate *topp
61e0: 61 74 68 2a 20 22 2f 22 20 22 2e 22 29 29 29 29 ath* "/" "."))))
61f0: 29 29 20 3b 3b 20 20 23 74 29 29 29 29 0a 09 20 )) ;; #t))))..
6200: 20 20 20 20 20 28 73 65 74 21 20 2a 64 62 2d 63 (set! *db-c
6210: 61 63 68 65 2d 70 61 74 68 2a 20 64 62 70 61 74 ache-path* dbpat
6220: 68 29 0a 09 20 20 20 20 20 20 64 62 70 61 74 68 h).. dbpath
6230: 29 29 0a 09 20 20 23 66 29 29 29 0a 0a 28 64 65 )).. #f)))..(de
6240: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
6250: 2d 61 72 65 61 2d 70 61 74 68 2d 73 69 67 6e 61 -area-path-signa
6260: 74 75 72 65 29 0a 20 20 28 6d 65 73 73 61 67 65 ture). (message
6270: 2d 64 69 67 65 73 74 2d 73 74 72 69 6e 67 20 28 -digest-string (
6280: 6d 64 35 2d 70 72 69 6d 69 74 69 76 65 29 20 2a md5-primitive) *
6290: 74 6f 70 70 61 74 68 2a 29 29 0a 0a 28 64 65 66 toppath*))..(def
62a0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
62b0: 73 69 67 6e 61 74 75 72 65 20 73 74 72 29 0a 20 signature str).
62c0: 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 (message-digest
62d0: 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 72 69 -string (md5-pri
62e0: 6d 69 74 69 76 65 29 20 73 74 72 29 29 0a 0a 3b mitive) str))..;
62f0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
6300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6330: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 58 20 49 =======.;; E X I
6340: 20 54 20 20 20 48 20 41 20 4e 20 44 20 4c 20 49 T H A N D L I
6350: 20 4e 20 47 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d N G.;;=========
6360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6380: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 =============..(
63a0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 define (common:r
63b0: 75 6e 2d 73 79 6e 63 3f 29 0a 20 20 20 20 28 61 un-sync?). (a
63c0: 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f nd (common:on-ho
63d0: 6d 65 68 6f 73 74 3f 29 0a 09 20 28 61 72 67 73 mehost?).. (args
63e0: 3a 67 65 74 2d 61 72 67 20 22 2d 73 65 72 76 65 :get-arg "-serve
63f0: 72 22 29 29 29 0a 0a 3b 3b 20 20 20 28 6c 65 74 r")))..;; (let
6400: 20 28 28 6f 68 68 20 28 63 6f 6d 6d 6f 6e 3a 6f ((ohh (common:o
6410: 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 29 0a 3b 3b n-homehost?)).;;
6420: 20 09 28 73 72 76 20 28 61 72 67 73 3a 67 65 74 .(srv (args:get
6430: 2d 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 -arg "-server"))
6440: 29 0a 3b 3b 20 20 20 20 20 28 61 6e 64 20 6f 68 ).;; (and oh
6450: 68 20 73 72 76 29 29 29 0a 20 20 20 20 3b 3b 20 h srv))). ;;
6460: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
6470: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
6480: 2d 70 6f 72 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 -port* "common:r
6490: 75 6e 2d 73 79 6e 63 3f 20 6f 68 68 3d 22 20 6f un-sync? ohh=" o
64a0: 68 68 20 22 2c 20 73 72 76 3d 22 20 73 72 76 29 hh ", srv=" srv)
64b0: 0a 0a 0a 0a 28 64 65 66 69 6e 65 20 2a 77 64 6e ....(define *wdn
64c0: 75 6d 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a um* 0).(define *
64d0: 77 64 6e 75 6d 2a 6d 75 74 65 78 20 28 6d 61 6b wdnum*mutex (mak
64e0: 65 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 63 75 72 e-mutex)).;; cur
64f0: 72 65 6e 74 6c 79 20 74 68 65 20 70 72 69 6d 61 rently the prima
6500: 72 79 20 6a 6f 62 20 6f 66 20 74 68 65 20 77 61 ry job of the wa
6510: 74 63 68 64 6f 67 20 69 73 20 74 6f 20 72 75 6e tchdog is to run
6520: 20 74 68 65 20 73 79 6e 63 20 62 61 63 6b 20 74 the sync back t
6530: 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 66 72 o megatest.db fr
6540: 6f 6d 20 74 68 65 20 64 62 20 69 6e 20 2f 74 6d om the db in /tm
6550: 70 0a 3b 3b 20 69 66 20 77 65 20 61 72 65 20 6f p.;; if we are o
6560: 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 61 n the homehost a
6570: 6e 64 20 77 65 20 61 72 65 20 61 20 73 65 72 76 nd we are a serv
6580: 65 72 20 28 62 79 20 64 65 66 69 6e 69 74 69 6f er (by definitio
6590: 6e 20 77 65 20 61 72 65 20 6f 6e 20 74 68 65 20 n we are on the
65a0: 68 6f 6d 65 68 6f 73 74 20 69 66 20 77 65 20 61 homehost if we a
65b0: 72 65 20 61 20 73 65 72 76 65 72 29 0a 3b 3b 0a re a server).;;.
65c0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
65d0: 6e 3a 72 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 n:readonly-watch
65e0: 64 6f 67 20 64 62 73 74 72 75 63 74 29 0a 20 20 dog dbstruct).
65f0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 30 (thread-sleep! 0
6600: 2e 30 35 29 20 3b 3b 20 64 65 6c 61 79 20 66 6f .05) ;; delay fo
6610: 72 20 73 74 61 72 74 75 70 0a 20 20 28 64 65 62 r startup. (deb
6620: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 ug:print-info 13
6630: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6640: 72 74 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 65 61 64 rt* "common:read
6650: 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 65 6e only-watchdog en
6660: 74 65 72 65 64 2e 22 29 0a 20 20 3b 3b 20 73 79 tered."). ;; sy
6670: 6e 63 20 6d 65 67 61 74 65 73 74 2e 64 62 20 74 nc megatest.db t
6680: 6f 20 2f 74 6d 70 2f 2e 2e 2e 2f 6d 65 67 61 74 o /tmp/.../megat
6690: 73 74 2e 64 62 0a 20 20 28 6c 65 74 2a 20 28 28 st.db. (let* ((
66a0: 73 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 sync-cool-off-du
66b0: 72 61 74 69 6f 6e 20 20 20 33 29 0a 20 20 20 20 ration 3).
66c0: 20 20 20 20 28 67 6f 6c 64 65 6e 2d 6d 74 64 62 (golden-mtdb
66d0: 20 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 (dbr:dbstru
66e0: 63 74 2d 6d 74 64 62 20 64 62 73 74 72 75 63 74 ct-mtdb dbstruct
66f0: 29 29 0a 20 20 20 20 20 20 20 20 28 67 6f 6c 64 )). (gold
6700: 65 6e 2d 6d 74 70 61 74 68 20 20 20 28 64 62 3a en-mtpath (db:
6710: 64 62 64 61 74 2d 67 65 74 2d 70 61 74 68 20 67 dbdat-get-path g
6720: 6f 6c 64 65 6e 2d 6d 74 64 62 29 29 0a 20 20 20 olden-mtdb)).
6730: 20 20 20 20 20 28 74 6d 70 2d 6d 74 64 62 20 20 (tmp-mtdb
6740: 20 20 20 20 20 20 28 64 62 72 3a 64 62 73 74 72 (dbr:dbstr
6750: 75 63 74 2d 74 6d 70 64 62 20 64 62 73 74 72 75 uct-tmpdb dbstru
6760: 63 74 29 29 0a 20 20 20 20 20 20 20 20 28 74 6d ct)). (tm
6770: 70 2d 6d 74 70 61 74 68 20 20 20 20 20 20 28 64 p-mtpath (d
6780: 62 3a 64 62 64 61 74 2d 67 65 74 2d 70 61 74 68 b:dbdat-get-path
6790: 20 74 6d 70 2d 6d 74 64 62 29 29 29 0a 20 20 20 tmp-mtdb))).
67a0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
67b0: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
67c0: 67 2d 70 6f 72 74 2a 20 22 52 65 61 64 2d 6f 6e g-port* "Read-on
67d0: 6c 79 20 70 65 72 69 6f 64 69 63 20 73 79 6e 63 ly periodic sync
67e0: 20 74 68 72 65 61 64 20 73 74 61 72 74 65 64 2e thread started.
67f0: 22 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 "). (let loop
6800: 20 28 28 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d ((last-sync-tim
6810: 65 20 30 29 29 0a 20 20 20 20 20 20 28 64 65 62 e 0)). (deb
6820: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 ug:print-info 13
6830: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6840: 72 74 2a 20 22 6c 6f 6f 70 20 74 6f 70 20 74 6d rt* "loop top tm
6850: 70 2d 6d 74 70 61 74 68 3d 22 74 6d 70 2d 6d 74 p-mtpath="tmp-mt
6860: 70 61 74 68 22 20 67 6f 6c 64 65 6e 2d 6d 74 70 path" golden-mtp
6870: 61 74 68 3d 22 67 6f 6c 64 65 6e 2d 6d 74 70 61 ath="golden-mtpa
6880: 74 68 29 0a 20 20 20 20 20 20 28 6c 65 74 2a 20 th). (let*
6890: 28 28 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 ((duration-since
68a0: 2d 6c 61 73 74 2d 73 79 6e 63 20 28 2d 20 28 63 -last-sync (- (c
68b0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 urrent-seconds)
68c0: 6c 61 73 74 2d 73 79 6e 63 2d 74 69 6d 65 29 29 last-sync-time))
68d0: 29 0a 20 20 20 20 20 20 20 20 28 64 65 62 75 67 ). (debug
68e0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a :print-info 13 *
68f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6900: 2a 20 22 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 * "duration-sinc
6910: 65 2d 6c 61 73 74 2d 73 79 6e 63 3d 22 64 75 72 e-last-sync="dur
6920: 61 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 ation-since-last
6930: 2d 73 79 6e 63 29 0a 20 20 20 20 20 20 20 20 28 -sync). (
6940: 69 66 20 28 61 6e 64 20 28 6e 6f 74 20 2a 74 69 if (and (not *ti
6950: 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a 20 20 20 me-to-exit*).
6960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 3c (<
6970: 20 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 65 2d duration-since-
6980: 6c 61 73 74 2d 73 79 6e 63 20 73 79 6e 63 2d 63 last-sync sync-c
6990: 6f 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 6f 6e ool-off-duration
69a0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
69b0: 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 28 2d thread-sleep! (-
69c0: 20 73 79 6e 63 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 sync-cool-off-d
69d0: 75 72 61 74 69 6f 6e 20 64 75 72 61 74 69 6f 6e uration duration
69e0: 2d 73 69 6e 63 65 2d 6c 61 73 74 2d 73 79 6e 63 -since-last-sync
69f0: 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 ))). (if
6a00: 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 (not *time-to-ex
6a10: 69 74 2a 29 0a 20 20 20 20 20 20 20 20 20 20 20 it*).
6a20: 20 28 6c 65 74 20 28 28 67 6f 6c 64 65 6e 2d 6d (let ((golden-m
6a30: 74 64 62 2d 6d 74 69 6d 65 20 28 66 69 6c 65 2d tdb-mtime (file-
6a40: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
6a50: 65 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 29 e golden-mtpath)
6a60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
6a70: 20 20 20 20 28 74 6d 70 2d 6d 74 64 62 2d 6d 74 (tmp-mtdb-mt
6a80: 69 6d 65 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 ime (file-mod
6a90: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 74 ification-time t
6aa0: 6d 70 2d 6d 74 70 61 74 68 29 29 29 0a 09 20 20 mp-mtpath)))..
6ab0: 20 20 20 20 28 69 66 20 28 3e 20 67 6f 6c 64 65 (if (> golde
6ac0: 6e 2d 6d 74 64 62 2d 6d 74 69 6d 65 20 74 6d 70 n-mtdb-mtime tmp
6ad0: 2d 6d 74 64 62 2d 6d 74 69 6d 65 29 0a 09 09 20 -mtdb-mtime)...
6ae0: 20 28 69 66 20 28 3c 20 67 6f 6c 64 65 6e 2d 6d (if (< golden-m
6af0: 74 64 62 2d 6d 74 69 6d 65 20 28 2d 20 28 63 75 tdb-mtime (- (cu
6b00: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 33 rrent-seconds) 3
6b10: 29 29 20 3b 3b 20 66 69 6c 65 20 68 61 73 20 4e )) ;; file has N
6b20: 4f 54 20 62 65 65 6e 20 74 6f 75 63 68 65 64 20 OT been touched
6b30: 69 6e 20 70 61 73 74 20 74 68 72 65 65 20 73 65 in past three se
6b40: 63 6f 6e 64 73 2c 20 74 68 69 73 20 77 61 79 20 conds, this way
6b50: 6d 75 6c 74 69 70 6c 65 20 73 65 72 76 65 72 73 multiple servers
6b60: 20 77 6f 6e 27 74 20 66 69 67 68 74 20 74 6f 20 won't fight to
6b70: 73 79 6e 63 20 62 61 63 6b 0a 09 09 20 20 20 20 sync back...
6b80: 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 64 62 (let ((res (db
6b90: 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 6e 63 20 64 :multi-db-sync d
6ba0: 62 73 74 72 75 63 74 20 27 6f 6c 64 32 6e 65 77 bstruct 'old2new
6bb0: 29 29 29 0a 09 09 09 28 64 65 62 75 67 3a 70 72 )))....(debug:pr
6bc0: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
6bd0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6be0: 72 6f 73 79 6e 63 20 63 61 6c 6c 65 64 2c 20 22 rosync called, "
6bf0: 20 72 65 73 20 22 20 72 65 63 6f 72 64 73 20 74 res " records t
6c00: 72 61 6e 73 66 65 72 72 65 64 2e 22 29 29 29 29 ransferred."))))
6c10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
6c20: 6c 6f 6f 70 20 28 63 75 72 72 65 6e 74 2d 73 65 loop (current-se
6c30: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 20 conds))).
6c40: 20 20 20 20 20 23 74 29 29 29 0a 20 20 20 20 28 #t))). (
6c50: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
6c60: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
6c70: 70 6f 72 74 2a 20 22 45 78 69 74 69 6e 67 20 72 port* "Exiting r
6c80: 65 61 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 eadonly-watchdog
6c90: 20 74 69 6d 65 72 2c 20 2a 74 69 6d 65 2d 74 6f timer, *time-to
6ca0: 2d 65 78 69 74 2a 20 3d 20 22 20 2a 74 69 6d 65 -exit* = " *time
6cb0: 2d 74 6f 2d 65 78 69 74 2a 22 20 70 69 64 3d 22 -to-exit*" pid="
6cc0: 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 (current-process
6cd0: 2d 69 64 29 22 20 6d 74 70 61 74 68 3d 22 67 6f -id)" mtpath="go
6ce0: 6c 64 65 6e 2d 6d 74 70 61 74 68 29 29 29 0a 0a lden-mtpath)))..
6cf0: 3b 3b 20 54 4f 44 4f 3a 20 66 6f 72 20 6d 75 6c ;; TODO: for mul
6d00: 74 69 70 6c 65 20 61 72 65 61 73 2c 20 77 65 20 tiple areas, we
6d10: 77 69 6c 6c 20 68 61 76 65 20 6d 75 6c 74 69 70 will have multip
6d20: 6c 65 20 77 61 74 63 68 64 6f 67 73 3b 20 61 6e le watchdogs; an
6d30: 64 20 6d 75 6c 74 69 70 6c 65 20 74 68 72 65 61 d multiple threa
6d40: 64 73 20 74 6f 20 6d 61 6e 61 67 65 0a 28 64 65 ds to manage.(de
6d50: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 74 fine (common:wat
6d60: 63 68 64 6f 67 29 0a 20 20 28 64 65 62 75 67 3a chdog). (debug:
6d70: 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 print-info 13 *d
6d80: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
6d90: 20 22 63 6f 6d 6d 6f 6e 3a 77 61 74 63 68 64 6f "common:watchdo
6da0: 67 20 65 6e 74 65 72 65 64 2e 22 29 0a 20 20 28 g entered."). (
6db0: 69 66 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 if (launch:setup
6dc0: 29 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d ). (if (com
6dd0: 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f mon:on-homehost?
6de0: 29 0a 09 20 20 28 6c 65 74 20 28 28 64 62 73 74 ).. (let ((dbst
6df0: 72 75 63 74 20 28 64 62 3a 73 65 74 75 70 20 23 ruct (db:setup #
6e00: 74 29 29 29 0a 09 20 20 20 20 28 64 65 62 75 67 t))).. (debug
6e10: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a :print-info 13 *
6e20: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6e30: 2a 20 22 61 66 74 65 72 20 64 62 3a 73 65 74 75 * "after db:setu
6e40: 70 20 77 69 74 68 20 64 62 73 74 72 75 63 74 3d p with dbstruct=
6e50: 22 20 64 62 73 74 72 75 63 74 29 0a 09 20 20 20 " dbstruct)..
6e60: 20 28 63 6f 6e 64 0a 09 20 20 20 20 20 28 28 64 (cond.. ((d
6e70: 62 72 3a 64 62 73 74 72 75 63 74 2d 72 65 61 64 br:dbstruct-read
6e80: 2d 6f 6e 6c 79 20 64 62 73 74 72 75 63 74 29 0a -only dbstruct).
6e90: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
6ea0: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
6eb0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6ec0: 6c 6f 61 64 69 6e 67 20 72 65 61 64 2d 6f 6e 6c loading read-onl
6ed0: 79 20 77 61 74 63 68 64 6f 67 22 29 0a 09 20 20 y watchdog")..
6ee0: 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 (common:read
6ef0: 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 64 62 only-watchdog db
6f00: 73 74 72 75 63 74 29 29 0a 09 20 20 20 20 20 28 struct)).. (
6f10: 65 6c 73 65 0a 09 20 20 20 20 20 20 28 64 65 62 else.. (deb
6f20: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 33 ug:print-info 13
6f30: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
6f40: 72 74 2a 20 22 6c 6f 61 64 69 6e 67 20 77 72 69 rt* "loading wri
6f50: 74 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 2e 22 table-watchdog."
6f60: 29 0a 09 20 20 20 20 20 20 28 73 65 72 76 65 72 ).. (server
6f70: 3a 77 72 69 74 61 62 6c 65 2d 77 61 74 63 68 64 :writable-watchd
6f80: 6f 67 20 64 62 73 74 72 75 63 74 29 29 29 0a 09 og dbstruct)))..
6f90: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
6fa0: 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c -info 13 *defaul
6fb0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 74 t-log-port* "wat
6fc0: 63 68 64 6f 67 20 64 6f 6e 65 2e 22 29 29 0a 09 chdog done."))..
6fd0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
6fe0: 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d nfo 13 *default-
6ff0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 6e 6f 20 6e 65 log-port* "no ne
7000: 65 64 20 66 6f 72 20 77 61 74 63 68 64 6f 67 20 ed for watchdog
7010: 6f 6e 20 6e 6f 6e 2d 68 6f 6d 65 68 6f 73 74 22 on non-homehost"
7020: 29 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 20 28 ))))...(define (
7030: 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 std-exit-procedu
7040: 72 65 29 0a 20 20 28 6f 6e 2d 65 78 69 74 20 28 re). (on-exit (
7050: 6c 61 6d 62 64 61 20 28 29 20 30 29 29 0a 20 20 lambda () 0)).
7060: 3b 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ;;(debug:print-i
7070: 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d nfo 13 *default-
7080: 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 64 2d 65 log-port* "std-e
7090: 78 69 74 2d 70 72 6f 63 65 64 75 72 65 20 63 61 xit-procedure ca
70a0: 6c 6c 65 64 3b 20 2a 74 69 6d 65 2d 74 6f 2d 65 lled; *time-to-e
70b0: 78 69 74 2a 3d 22 2a 74 69 6d 65 2d 74 6f 2d 65 xit*="*time-to-e
70c0: 78 69 74 2a 29 0a 20 20 28 6c 65 74 20 28 28 6e xit*). (let ((n
70d0: 6f 2d 68 75 72 72 79 20 20 28 69 66 20 2a 74 69 o-hurry (if *ti
70e0: 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 3b 3b 20 68 me-to-exit* ;; h
70f0: 75 72 72 79 20 75 70 0a 09 09 20 20 20 20 20 20 urry up...
7100: 20 23 66 0a 09 09 20 20 20 20 20 20 20 28 62 65 #f... (be
7110: 67 69 6e 0a 09 09 09 20 28 73 65 74 21 20 2a 74 gin.... (set! *t
7120: 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 ime-to-exit* #t)
7130: 0a 09 09 09 20 23 74 29 29 29 29 0a 20 20 20 20 .... #t)))).
7140: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7150: 6f 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 4 *default-log
7160: 2d 70 6f 72 74 2a 20 22 73 74 61 72 74 69 6e 67 -port* "starting
7170: 20 65 78 69 74 20 70 72 6f 63 65 73 73 2c 20 66 exit process, f
7180: 69 6e 61 6c 69 7a 69 6e 67 20 64 61 74 61 62 61 inalizing databa
7190: 73 65 73 2e 22 29 0a 20 20 20 20 28 69 66 20 28 ses."). (if (
71a0: 61 6e 64 20 6e 6f 2d 68 75 72 72 79 20 28 64 65 and no-hurry (de
71b0: 62 75 67 3a 64 65 62 75 67 2d 6d 6f 64 65 20 31 bug:debug-mode 1
71c0: 38 29 29 0a 09 28 72 6d 74 3a 70 72 69 6e 74 2d 8))..(rmt:print-
71d0: 64 62 2d 73 74 61 74 73 29 29 0a 20 20 20 20 28 db-stats)). (
71e0: 6c 65 74 20 28 28 74 68 31 20 28 6d 61 6b 65 2d let ((th1 (make-
71f0: 74 68 72 65 61 64 20 28 6c 61 6d 62 64 61 20 28 thread (lambda (
7200: 29 20 3b 3b 20 74 68 72 65 61 64 20 66 6f 72 20 ) ;; thread for
7210: 63 6c 65 61 6e 69 6e 67 20 75 70 2c 20 67 69 76 cleaning up, giv
7220: 65 20 69 74 20 66 69 76 65 20 73 65 63 6f 6e 64 e it five second
7230: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
7240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7250: 28 69 66 20 2a 64 62 73 74 72 75 63 74 2d 64 62 (if *dbstruct-db
7260: 2a 20 28 64 62 3a 63 6c 6f 73 65 2d 61 6c 6c 20 * (db:close-all
7270: 2a 64 62 73 74 72 75 63 74 2d 64 62 2a 29 29 20 *dbstruct-db*))
7280: 3b 3b 20 6f 6e 65 20 73 65 63 6f 6e 64 20 61 6c ;; one second al
7290: 6c 6f 63 61 74 65 64 0a 09 09 09 20 20 20 20 20 located....
72a0: 20 28 69 66 20 2a 74 61 73 6b 2d 64 62 2a 20 20 (if *task-db*
72b0: 20 20 0a 09 09 09 09 20 20 28 6c 65 74 20 28 28 ..... (let ((
72c0: 64 62 20 28 63 64 72 20 2a 74 61 73 6b 2d 64 62 db (cdr *task-db
72d0: 2a 29 29 29 0a 09 09 09 09 20 20 20 20 28 69 66 *)))..... (if
72e0: 20 28 73 71 6c 69 74 65 33 3a 64 61 74 61 62 61 (sqlite3:databa
72f0: 73 65 3f 20 64 62 29 0a 09 09 09 09 09 28 62 65 se? db)......(be
7300: 67 69 6e 0a 09 09 09 09 09 20 20 28 73 71 6c 69 gin...... (sqli
7310: 74 65 33 3a 69 6e 74 65 72 72 75 70 74 21 20 64 te3:interrupt! d
7320: 62 29 0a 09 09 09 09 09 20 20 28 73 71 6c 69 74 b)...... (sqlit
7330: 65 33 3a 66 69 6e 61 6c 69 7a 65 21 20 64 62 20 e3:finalize! db
7340: 23 74 29 0a 09 09 09 09 09 20 20 3b 3b 20 28 76 #t)...... ;; (v
7350: 65 63 74 6f 72 2d 73 65 74 21 20 2a 74 61 73 6b ector-set! *task
7360: 2d 64 62 2a 20 30 20 23 66 29 0a 09 09 09 09 09 -db* 0 #f)......
7370: 20 20 28 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 (set! *task-db
7380: 2a 20 23 66 29 29 29 29 29 0a 20 20 20 20 20 20 * #f))))).
7390: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73a0: 20 20 20 20 20 20 20 20 28 68 74 74 70 2d 63 6c (http-cl
73b0: 69 65 6e 74 23 63 6c 6f 73 65 2d 61 6c 6c 2d 63 ient#close-all-c
73c0: 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 0a 20 20 20 onnections!).
73d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
73e0: 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 69 ;; (i
73f0: 66 20 28 61 6e 64 20 2a 72 75 6e 72 65 6d 6f 74 f (and *runremot
7400: 65 2a 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e*.
7410: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7420: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 72 65 ;; (re
7430: 6d 6f 74 65 2d 63 6f 6e 6e 64 61 74 20 2a 72 75 mote-conndat *ru
7440: 6e 72 65 6d 6f 74 65 2a 29 29 0a 20 20 20 20 20 nremote*)).
7450: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7460: 20 20 20 20 20 20 20 20 20 3b 3b 20 20 20 20 20 ;;
7470: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
7480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7490: 20 20 20 20 20 3b 3b 20 20 20 20 20 20 20 28 68 ;; (h
74a0: 74 74 70 2d 63 6c 69 65 6e 74 23 63 6c 6f 73 65 ttp-client#close
74b0: 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 74 69 6f 6e 73 -all-connections
74c0: 21 29 29 29 20 3b 3b 20 66 6f 72 20 68 74 74 70 !))) ;; for http
74d0: 2d 63 6c 69 65 6e 74 0a 20 20 20 20 20 20 20 20 -client.
74e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
74f0: 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 (if (not (
7500: 65 71 3f 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 eq? *default-log
7510: 2d 70 6f 72 74 2a 20 28 63 75 72 72 65 6e 74 2d -port* (current-
7520: 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 0a 20 20 error-port))).
7530: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7550: 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
7560: 72 74 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d rt *default-log-
7570: 70 6f 72 74 2a 29 29 0a 09 09 09 20 20 20 20 20 port*))....
7580: 20 28 73 65 74 21 20 2a 64 65 66 61 75 6c 74 2d (set! *default-
7590: 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 75 72 72 65 log-port* (curre
75a0: 6e 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 29 nt-error-port)))
75b0: 20 22 43 6c 65 61 6e 75 70 20 64 62 20 65 78 69 "Cleanup db exi
75c0: 74 20 74 68 72 65 61 64 22 29 29 0a 09 20 20 28 t thread")).. (
75d0: 74 68 32 20 28 6d 61 6b 65 2d 74 68 72 65 61 64 th2 (make-thread
75e0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 20 (lambda ()....
75f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
7600: 74 20 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 4 *default-log
7610: 2d 70 6f 72 74 2a 20 22 41 74 74 65 6d 70 74 69 -port* "Attempti
7620: 6e 67 20 63 6c 65 61 6e 20 65 78 69 74 2e 20 50 ng clean exit. P
7630: 6c 65 61 73 65 20 62 65 20 70 61 74 69 65 6e 74 lease be patient
7640: 20 61 6e 64 20 77 61 69 74 20 61 20 66 65 77 20 and wait a few
7650: 73 65 63 6f 6e 64 73 2e 2e 2e 22 29 0a 09 09 09 seconds...")....
7660: 20 20 20 20 20 20 28 69 66 20 6e 6f 2d 68 75 72 (if no-hur
7670: 72 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ry.
7680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7690: 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 (begin.
76a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
76c0: 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 35 (thread-sleep! 5
76d0: 29 29 20 3b 3b 20 67 69 76 65 20 74 68 65 20 63 )) ;; give the c
76e0: 6c 65 61 6e 20 75 70 20 66 65 77 20 73 65 63 6f lean up few seco
76f0: 6e 64 73 20 74 6f 20 64 6f 20 69 74 27 73 20 73 nds to do it's s
7700: 74 75 66 66 0a 20 20 20 20 20 20 20 20 20 20 20 tuff.
7710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7720: 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 20 (begin.
7730: 20 20 20 20 09 09 09 09 20 20 28 74 68 72 65 61 .... (threa
7740: 64 2d 73 6c 65 65 70 21 20 32 29 29 29 0a 20 20 d-sleep! 2))).
7750: 20 20 20 20 09 09 09 20 20 20 20 20 20 28 64 65 ... (de
7760: 62 75 67 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 bug:print 4 *def
7770: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7780: 20 2e 2e 2e 20 64 6f 6e 65 22 29 0a 20 20 20 20 ... done").
7790: 20 20 09 09 09 20 20 20 20 20 20 29 0a 09 09 09 ... )....
77a0: 20 20 20 20 22 63 6c 65 61 6e 20 65 78 69 74 22 "clean exit"
77b0: 29 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 ))). (threa
77c0: 64 2d 73 74 61 72 74 21 20 74 68 31 29 0a 20 20 d-start! th1).
77d0: 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 72 (thread-star
77e0: 74 21 20 74 68 32 29 0a 20 20 20 20 20 20 28 74 t! th2). (t
77f0: 68 72 65 61 64 2d 6a 6f 69 6e 21 20 74 68 31 29 hread-join! th1)
7800: 0a 20 20 20 20 20 20 29 0a 20 20 20 20 29 0a 0a . ). )..
7810: 20 20 30 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 0)..(define (s
7820: 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 td-signal-handle
7830: 72 20 73 69 67 6e 75 6d 29 0a 20 20 3b 3b 20 28 r signum). ;; (
7840: 73 69 67 6e 61 6c 2d 6d 61 73 6b 21 20 73 69 67 signal-mask! sig
7850: 6e 75 6d 29 0a 20 20 28 73 65 74 21 20 2a 74 69 num). (set! *ti
7860: 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 23 74 29 0a me-to-exit* #t).
7870: 20 20 3b 3b 28 64 65 62 75 67 3a 70 72 69 6e 74 ;;(debug:print
7880: 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c -info 13 *defaul
7890: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 67 6f 74 t-log-port* "got
78a0: 20 73 69 67 6e 61 6c 20 22 73 69 67 6e 75 6d 29 signal "signum)
78b0: 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
78c0: 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 error 0 *default
78d0: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 65 63 65 -log-port* "Rece
78e0: 69 76 65 64 20 73 69 67 6e 61 6c 20 22 20 73 69 ived signal " si
78f0: 67 6e 75 6d 20 22 20 65 78 69 74 69 6e 67 20 70 gnum " exiting p
7900: 72 6f 6d 70 74 6c 79 22 29 0a 20 20 3b 3b 20 28 romptly"). ;; (
7910: 73 74 64 2d 65 78 69 74 2d 70 72 6f 63 65 64 75 std-exit-procedu
7920: 72 65 29 20 3b 3b 20 73 68 6f 75 6c 64 6e 27 74 re) ;; shouldn't
7930: 20 6e 65 65 64 20 74 68 69 73 20 73 69 6e 63 65 need this since
7940: 20 77 65 20 61 72 65 20 65 78 69 74 69 6e 67 20 we are exiting
7950: 61 6e 64 20 69 74 20 77 69 6c 6c 20 62 65 20 63 and it will be c
7960: 61 6c 6c 65 64 20 61 6e 79 77 61 79 0a 20 20 28 alled anyway. (
7970: 65 78 69 74 29 29 0a 0a 28 73 65 74 2d 73 69 67 exit))..(set-sig
7980: 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 nal-handler! sig
7990: 6e 61 6c 2f 69 6e 74 20 20 73 74 64 2d 73 69 67 nal/int std-sig
79a0: 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b nal-handler) ;;
79b0: 20 5e 43 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d ^C.(set-signal-
79c0: 68 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f handler! signal/
79d0: 74 65 72 6d 20 73 74 64 2d 73 69 67 6e 61 6c 2d term std-signal-
79e0: 68 61 6e 64 6c 65 72 29 0a 3b 3b 20 28 73 65 74 handler).;; (set
79f0: 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 21 -signal-handler!
7a00: 20 73 69 67 6e 61 6c 2f 73 74 6f 70 20 73 74 64 signal/stop std
7a10: 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 29 -signal-handler)
7a20: 20 20 3b 3b 20 5e 5a 20 4e 4f 2c 20 64 6f 20 4e ;; ^Z NO, do N
7a30: 4f 54 20 68 61 6e 64 6c 65 20 5e 5a 21 0a 0a 3b OT handle ^Z!..;
7a40: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7a50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7a80: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 =======.;; M I S
7a90: 20 43 20 20 20 55 20 54 20 49 20 4c 20 53 0a 3b C U T I L S.;
7aa0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
7ab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ae0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 =======..;; conv
7af0: 65 72 74 20 73 74 75 66 66 20 74 6f 20 61 20 6e ert stuff to a n
7b00: 75 6d 62 65 72 20 69 66 20 70 6f 73 73 69 62 6c umber if possibl
7b10: 65 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 2d 3e e.(define (any->
7b20: 6e 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 63 number val). (c
7b30: 6f 6e 64 20 0a 20 20 20 28 28 6e 75 6d 62 65 72 ond . ((number
7b40: 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 ? val) val). (
7b50: 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 28 73 (string? val) (s
7b60: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 tring->number va
7b70: 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f l)). ((symbol?
7b80: 20 76 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 6d 62 val) (any->numb
7b90: 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 er (symbol->stri
7ba0: 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 28 65 6c ng val))). (el
7bb0: 73 65 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e se #f)))..(defin
7bc0: 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 2d 69 e (any->number-i
7bd0: 66 2d 70 6f 73 73 69 62 6c 65 20 76 61 6c 29 0a f-possible val).
7be0: 20 20 28 6c 65 74 20 28 28 6e 75 6d 20 28 61 6e (let ((num (an
7bf0: 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 29 y->number val)))
7c00: 0a 20 20 20 20 28 69 66 20 6e 75 6d 20 6e 75 6d . (if num num
7c10: 20 76 61 6c 29 29 29 0a 0a 28 64 65 66 69 6e 65 val)))..(define
7c20: 20 28 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 63 (patt-list-matc
7c30: 68 20 69 74 65 6d 20 70 61 74 74 73 29 0a 20 20 h item patts).
7c40: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
7c50: 6f 20 38 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 8 *default-log
7c60: 2d 70 6f 72 74 2a 20 22 70 61 74 74 2d 6c 69 73 -port* "patt-lis
7c70: 74 2d 6d 61 74 63 68 20 69 74 65 6d 3d 22 20 69 t-match item=" i
7c80: 74 65 6d 20 22 20 70 61 74 74 73 3d 22 20 70 61 tem " patts=" pa
7c90: 74 74 73 29 0a 20 20 28 69 66 20 28 61 6e 64 20 tts). (if (and
7ca0: 69 74 65 6d 20 70 61 74 74 73 29 20 20 3b 3b 20 item patts) ;;
7cb0: 68 65 72 65 20 77 65 20 61 72 65 20 66 69 6c 74 here we are filt
7cc0: 65 72 69 6e 67 20 66 6f 72 20 6d 61 74 63 68 65 ering for matche
7cd0: 73 20 77 69 74 68 20 69 74 65 6d 20 70 61 74 74 s with item patt
7ce0: 65 72 6e 73 0a 20 20 20 20 20 20 28 6c 65 74 20 erns. (let
7cf0: 28 28 72 65 73 20 23 66 29 29 20 20 20 3b 3b 20 ((res #f)) ;;
7d00: 6c 6f 6f 6b 20 74 68 72 6f 75 67 68 20 61 6c 6c look through all
7d10: 20 74 68 65 20 69 74 65 6d 2d 70 61 74 74 73 20 the item-patts
7d20: 69 66 20 64 65 66 69 6e 65 64 2c 20 66 6f 72 6d if defined, form
7d30: 61 74 20 69 73 20 70 61 74 74 31 2c 70 61 74 74 at is patt1,patt
7d40: 32 2c 70 61 74 74 33 20 2e 2e 2e 20 77 69 6c 64 2,patt3 ... wild
7d50: 63 61 72 64 20 69 73 20 25 0a 09 28 66 6f 72 2d card is %..(for-
7d60: 65 61 63 68 20 0a 09 20 28 6c 61 6d 62 64 61 20 each .. (lambda
7d70: 28 70 61 74 74 29 0a 09 20 20 20 28 6c 65 74 20 (patt).. (let
7d80: 28 28 6d 6f 64 70 61 74 74 20 28 73 74 72 69 6e ((modpatt (strin
7d90: 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 25 22 g-substitute "%"
7da0: 20 22 2e 2a 22 20 70 61 74 74 20 23 74 29 29 29 ".*" patt #t)))
7db0: 0a 09 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 .. (debug:pr
7dc0: 69 6e 74 2d 69 6e 66 6f 20 31 30 20 2a 64 65 66 int-info 10 *def
7dd0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7de0: 70 61 74 74 20 22 20 70 61 74 74 20 22 20 6d 6f patt " patt " mo
7df0: 64 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 29 dpatt " modpatt)
7e00: 0a 09 20 20 20 20 20 28 69 66 20 28 73 74 72 69 .. (if (stri
7e10: 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 ng-match (regexp
7e20: 20 6d 6f 64 70 61 74 74 29 20 69 74 65 6d 29 0a modpatt) item).
7e30: 09 09 20 28 73 65 74 21 20 72 65 73 20 23 74 29 .. (set! res #t)
7e40: 29 29 29 0a 09 20 28 73 74 72 69 6e 67 2d 73 70 ))).. (string-sp
7e50: 6c 69 74 20 70 61 74 74 73 20 22 2c 22 29 29 0a lit patts ",")).
7e60: 09 72 65 73 29 0a 20 20 20 20 20 20 23 74 29 29 .res). #t))
7e70: 0a 0a 3b 3b 20 27 28 70 72 69 6e 74 20 28 73 74 ..;; '(print (st
7e80: 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
7e90: 20 28 6d 61 70 20 63 61 64 72 20 28 68 61 73 68 (map cadr (hash
7ea0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
7eb0: 6c 74 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 lt (read-config
7ec0: 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 "megatest.config
7ed0: 22 20 5c 23 66 20 5c 23 74 29 20 22 64 69 73 6b " \#f \#t) "disk
7ee0: 73 22 20 27 22 27 22 27 28 22 6e 6f 6e 65 22 20 s" '"'"'("none"
7ef0: 22 22 29 29 29 20 22 5c 6e 22 29 29 27 0a 28 64 ""))) "\n"))'.(d
7f00: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
7f10: 74 2d 64 69 73 6b 73 20 23 21 6b 65 79 20 28 63 t-disks #!key (c
7f20: 6f 6e 66 69 67 66 20 23 66 29 29 0a 20 20 28 68 onfigf #f)). (h
7f30: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
7f40: 66 61 75 6c 74 20 0a 20 20 20 28 6f 72 20 63 6f fault . (or co
7f50: 6e 66 69 67 66 20 28 72 65 61 64 2d 63 6f 6e 66 nfigf (read-conf
7f60: 69 67 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e ig "megatest.con
7f70: 66 69 67 22 20 23 66 20 23 74 29 29 0a 20 20 20 fig" #f #t)).
7f80: 22 64 69 73 6b 73 22 20 27 28 22 6e 6f 6e 65 22 "disks" '("none"
7f90: 20 22 22 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 "")))..;; retur
7fa0: 6e 20 66 69 72 73 74 20 63 6f 6d 6d 61 6e 64 20 n first command
7fb0: 74 68 61 74 20 65 78 69 73 74 73 2c 20 65 6c 73 that exists, els
7fc0: 65 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 e #f.;;.(define
7fd0: 28 63 6f 6d 6d 6f 6e 3a 77 68 69 63 68 20 63 6d (common:which cm
7fe0: 64 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f ds). (if (null?
7ff0: 20 63 6d 64 73 29 0a 20 20 20 20 20 20 23 66 0a cmds). #f.
8000: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
8010: 28 28 68 65 64 20 28 63 61 72 20 63 6d 64 73 29 ((hed (car cmds)
8020: 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 63 )... (tal (cdr c
8030: 6d 64 73 29 29 29 0a 09 28 6c 65 74 20 28 28 72 mds)))..(let ((r
8040: 65 73 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 es (with-input-f
8050: 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 rom-pipe (conc "
8060: 77 68 69 63 68 20 22 20 68 65 64 29 20 72 65 61 which " hed) rea
8070: 64 2d 6c 69 6e 65 29 29 29 0a 09 20 20 28 69 66 d-line))).. (if
8080: 20 28 61 6e 64 20 28 73 74 72 69 6e 67 3f 20 72 (and (string? r
8090: 65 73 29 0a 09 09 20 20 20 28 63 6f 6d 6d 6f 6e es)... (common
80a0: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 72 65 :file-exists? re
80b0: 73 29 29 0a 09 20 20 20 20 20 20 72 65 73 0a 09 s)).. res..
80c0: 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
80d0: 20 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 tal)... #f...
80e0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
80f0: 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 (cdr tal))))))))
8100: 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d . .(define (com
8110: 6d 6f 6e 3a 67 65 74 2d 69 6e 73 74 61 6c 6c 2d mon:get-install-
8120: 61 72 65 61 29 0a 20 20 28 6c 65 74 20 28 28 65 area). (let ((e
8130: 78 65 2d 70 61 74 68 20 28 63 61 72 20 28 61 72 xe-path (car (ar
8140: 67 76 29 29 29 29 0a 20 20 20 20 28 69 66 20 28 gv)))). (if (
8150: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
8160: 74 73 3f 20 65 78 65 2d 70 61 74 68 29 0a 09 28 ts? exe-path)..(
8170: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
8180: 73 0a 09 20 65 78 6e 0a 09 20 23 66 0a 09 20 28 s.. exn.. #f.. (
8190: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
81a0: 72 79 0a 09 20 20 28 70 61 74 68 6e 61 6d 65 2d ry.. (pathname-
81b0: 64 69 72 65 63 74 6f 72 79 20 0a 09 20 20 20 28 directory .. (
81c0: 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 74 6f pathname-directo
81d0: 72 79 20 65 78 65 2d 70 61 74 68 29 29 29 29 0a ry exe-path)))).
81e0: 09 23 66 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 .#f)))..;; retur
81f0: 6e 20 66 69 72 73 74 20 70 61 74 68 20 74 68 61 n first path tha
8200: 74 20 63 61 6e 20 62 65 20 63 72 65 61 74 65 64 t can be created
8210: 20 6f 72 20 61 6c 72 65 61 64 79 20 65 78 69 73 or already exis
8220: 74 73 20 61 6e 64 20 69 73 20 77 72 69 74 61 62 ts and is writab
8230: 6c 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 le.;;.(define (c
8240: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 74 65 ommon:get-create
8250: 2d 77 72 69 74 65 61 62 6c 65 2d 64 69 72 20 64 -writeable-dir d
8260: 69 72 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c irs). (if (null
8270: 3f 20 64 69 72 73 29 0a 20 20 20 20 20 20 23 66 ? dirs). #f
8280: 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 . (let loop
8290: 20 28 28 68 65 64 20 28 63 61 72 20 64 69 72 73 ((hed (car dirs
82a0: 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 20 ))... (tal (cdr
82b0: 64 69 72 73 29 29 29 0a 09 28 6c 65 74 20 28 28 dirs)))..(let ((
82c0: 72 65 73 20 28 6f 72 20 28 61 6e 64 20 28 64 69 res (or (and (di
82d0: 72 65 63 74 6f 72 79 3f 20 68 65 64 29 0a 09 09 rectory? hed)...
82e0: 09 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 . (file-write
82f0: 2d 61 63 63 65 73 73 3f 20 68 65 64 29 0a 09 09 -access? hed)...
8300: 09 20 20 20 20 68 65 64 29 0a 09 09 20 20 20 20 . hed)...
8310: 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 (handle-excep
8320: 74 69 6f 6e 73 0a 09 09 09 65 78 6e 0a 09 09 09 tions....exn....
8330: 23 66 0a 09 09 09 28 63 72 65 61 74 65 2d 64 69 #f....(create-di
8340: 72 65 63 74 6f 72 79 20 68 65 64 20 23 74 29 29 rectory hed #t))
8350: 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 20 ))).. (if (and
8360: 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 09 (string? res)...
8370: 20 20 20 28 64 69 72 65 63 74 6f 72 79 3f 20 72 (directory? r
8380: 65 73 29 29 0a 09 20 20 20 20 20 20 72 65 73 0a es)).. res.
8390: 09 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c . (if (null
83a0: 3f 20 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 ? tal)... #f...
83b0: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
83c0: 29 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 )(cdr tal)))))))
83d0: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 )..;; return the
83e0: 20 79 6f 75 6e 67 65 73 74 20 74 69 6d 65 73 74 youngest timest
83f0: 61 6d 70 20 2e 20 66 69 6c 65 6e 61 6d 65 0a 3b amp . filename.;
8400: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
8410: 6e 3a 67 65 74 2d 79 6f 75 6e 67 65 73 74 20 67 n:get-youngest g
8420: 6c 6f 62 2d 6c 69 73 74 29 0a 20 20 28 6c 65 74 lob-list). (let
8430: 20 28 28 61 6c 6c 2d 66 69 6c 65 73 20 28 61 70 ((all-files (ap
8440: 70 6c 79 20 61 70 70 65 6e 64 0a 09 09 09 20 20 ply append....
8450: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 70 61 (map (lambda (pa
8460: 74 74 29 0a 09 09 09 09 20 28 68 61 6e 64 6c 65 tt)..... (handle
8470: 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 09 -exceptions.....
8480: 20 20 20 20 20 65 78 6e 0a 09 09 09 09 20 20 20 exn.....
8490: 20 20 27 28 29 0a 09 09 09 09 20 20 20 28 67 6c '()..... (gl
84a0: 6f 62 20 70 61 74 74 29 29 29 0a 09 09 09 20 20 ob patt)))....
84b0: 20 20 20 20 20 67 6c 6f 62 2d 6c 69 73 74 29 29 glob-list))
84c0: 29 29 0a 20 20 20 20 28 66 6f 6c 64 20 28 6c 61 )). (fold (la
84d0: 6d 62 64 61 20 28 66 6e 61 6d 65 20 72 65 73 29 mbda (fname res)
84e0: 0a 09 20 20 20 20 28 6c 65 74 20 28 28 6c 61 73 .. (let ((las
84f0: 74 2d 6d 6f 64 20 28 63 61 72 20 72 65 73 29 29 t-mod (car res))
8500: 0a 09 09 20 20 28 63 75 72 6d 6f 64 20 20 20 28 ... (curmod (
8510: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
8520: 73 0a 09 09 09 09 65 78 6e 0a 09 09 09 09 30 0a s.....exn.....0.
8530: 09 09 09 20 20 20 20 20 20 28 66 69 6c 65 2d 6d ... (file-m
8540: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
8550: 20 66 6e 61 6d 65 29 29 29 29 0a 09 20 20 20 20 fname))))..
8560: 20 20 28 69 66 20 28 3e 20 63 75 72 6d 6f 64 20 (if (> curmod
8570: 6c 61 73 74 2d 6d 6f 64 29 0a 09 09 20 20 28 6c last-mod)... (l
8580: 69 73 74 20 63 75 72 6d 6f 64 20 66 6e 61 6d 65 ist curmod fname
8590: 29 0a 09 09 20 20 72 65 73 29 29 29 0a 09 20 20 )... res)))..
85a0: 27 28 30 20 22 6e 2f 61 22 29 0a 09 20 20 61 6c '(0 "n/a").. al
85b0: 6c 2d 66 69 6c 65 73 29 29 29 0a 0a 3b 3b 20 75 l-files)))..;; u
85c0: 73 65 20 62 61 73 68 20 74 6f 20 65 78 70 61 6e se bash to expan
85d0: 64 20 61 20 67 6c 6f 62 2e 20 44 6f 65 73 20 4e d a glob. Does N
85e0: 4f 54 20 68 61 6e 64 6c 65 20 70 61 74 68 73 20 OT handle paths
85f0: 77 69 74 68 20 73 70 61 63 65 73 21 0a 3b 3b 0a with spaces!.;;.
8600: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
8610: 62 61 73 68 2d 67 6c 6f 62 20 69 6e 73 74 72 29 bash-glob instr)
8620: 0a 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 . (string-split
8630: 0a 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d . (with-input-
8640: 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 20 20 20 from-pipe.
8650: 20 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 62 61 73 (conc "/bin/bas
8660: 68 20 2d 63 20 5c 22 65 63 68 6f 20 22 20 69 6e h -c \"echo " in
8670: 73 74 72 20 22 5c 22 22 29 0a 20 20 20 20 20 72 str "\""). r
8680: 65 61 64 2d 6c 69 6e 65 29 29 29 0a 20 20 0a 3b ead-line))). .;
8690: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
86a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
86d0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 41 20 52 =======.;; T A R
86e0: 20 47 20 45 20 54 20 53 20 20 2c 20 20 20 53 20 G E T S , S
86f0: 54 20 41 20 54 20 45 20 2c 20 20 20 53 20 54 20 T A T E , S T
8700: 41 20 54 20 55 20 53 20 2c 20 20 20 0a 3b 3b 20 A T U S , .;;
8710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
8720: 20 20 20 52 20 55 20 4e 20 4e 20 41 20 4d 20 45 R U N N A M E
8730: 20 20 20 20 41 20 4e 20 44 20 20 20 54 20 45 20 A N D T E
8740: 53 20 54 20 50 20 41 20 54 20 54 0a 3b 3b 3d 3d S T P A T T.;;==
8750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8790: 3d 3d 3d 3d 0a 0a 3b 3b 20 28 6d 61 70 20 70 72 ====..;; (map pr
87a0: 69 6e 74 20 28 6d 61 70 20 63 61 72 20 28 68 61 int (map car (ha
87b0: 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 sh-table->alist
87c0: 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 72 75 (read-config "ru
87d0: 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 nconfigs.config"
87e0: 20 23 66 20 23 74 29 29 29 29 0a 3b 3b 0a 28 64 #f #t)))).;;.(d
87f0: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
8800: 74 2d 72 75 6e 63 6f 6e 66 69 67 2d 74 61 72 67 t-runconfig-targ
8810: 65 74 73 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 ets #!key (confi
8820: 67 66 20 23 66 29 29 0a 20 20 28 6c 65 74 20 28 gf #f)). (let (
8830: 28 74 61 72 67 73 20 20 20 20 20 20 20 28 73 6f (targs (so
8840: 72 74 20 28 6d 61 70 20 63 61 72 20 28 68 61 73 rt (map car (has
8850: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 0a 09 h-table->alist..
8860: 09 09 09 20 20 20 20 20 28 6f 72 20 63 6f 6e 66 ... (or conf
8870: 69 67 66 20 3b 3b 20 4e 4f 54 45 3a 20 54 68 65 igf ;; NOTE: The
8880: 72 65 20 69 73 20 6e 6f 20 76 61 6c 75 65 20 69 re is no value i
8890: 6e 20 75 73 69 6e 67 20 72 75 6e 63 6f 6e 66 69 n using runconfi
88a0: 67 3a 72 65 61 64 20 68 65 72 65 2e 0a 09 09 09 g:read here.....
88b0: 09 09 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 .. (read-config
88c0: 28 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 (conc *toppath*
88d0: 22 2f 72 75 6e 63 6f 6e 66 69 67 73 2e 63 6f 6e "/runconfigs.con
88e0: 66 69 67 22 29 0a 09 09 09 09 09 09 20 20 20 20 fig").......
88f0: 20 20 23 66 20 23 74 29 0a 09 09 09 09 09 20 28 #f #t)...... (
8900: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
8910: 29 29 29 0a 09 09 09 20 20 20 73 74 72 69 6e 67 ))).... string
8920: 3c 3f 29 29 0a 09 28 74 61 72 67 65 74 2d 70 61 <?))..(target-pa
8930: 74 74 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 tt (args:get-arg
8940: 20 22 2d 74 61 72 67 65 74 22 29 29 29 0a 20 20 "-target"))).
8950: 20 20 28 69 66 20 74 61 72 67 65 74 2d 70 61 74 (if target-pat
8960: 74 0a 09 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 t..(filter (lamb
8970: 64 61 20 28 78 29 0a 09 09 20 20 28 70 61 74 74 da (x)... (patt
8980: 2d 6c 69 73 74 2d 6d 61 74 63 68 20 78 20 74 61 -list-match x ta
8990: 72 67 65 74 2d 70 61 74 74 29 29 0a 09 09 74 61 rget-patt))...ta
89a0: 72 67 73 29 0a 09 74 61 72 67 73 29 29 29 0a 0a rgs)..targs)))..
89b0: 3b 3b 20 4c 6f 6f 6b 75 70 20 61 20 76 61 6c 75 ;; Lookup a valu
89c0: 65 20 69 6e 20 72 75 6e 63 6f 6e 66 69 67 73 20 e in runconfigs
89d0: 62 61 73 65 64 20 6f 6e 20 2d 72 65 71 74 61 72 based on -reqtar
89e0: 67 20 6f 72 20 2d 74 61 72 67 65 74 0a 3b 3b 20 g or -target.;;
89f0: 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 63 6f 6e .(define (runcon
8a00: 66 69 67 73 2d 67 65 74 20 63 6f 6e 66 69 67 20 figs-get config
8a10: 76 61 72 29 0a 20 20 28 6c 65 74 20 28 28 74 61 var). (let ((ta
8a20: 72 67 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d rg (common:args-
8a30: 67 65 74 2d 74 61 72 67 65 74 29 29 29 20 3b 3b get-target))) ;;
8a40: 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 (or (args:get-a
8a50: 72 67 20 22 2d 72 65 71 74 61 72 67 22 29 28 61 rg "-reqtarg")(a
8a60: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
8a70: 72 67 65 74 22 29 28 67 65 74 65 6e 76 20 22 4d rget")(getenv "M
8a80: 54 5f 54 41 52 47 45 54 22 29 29 29 29 0a 20 20 T_TARGET")))).
8a90: 20 20 28 69 66 20 74 61 72 67 0a 09 28 6f 72 20 (if targ..(or
8aa0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
8ab0: 63 6f 6e 66 69 67 20 74 61 72 67 20 76 61 72 29 config targ var)
8ac0: 0a 09 20 20 20 20 28 63 6f 6e 66 69 67 66 3a 6c .. (configf:l
8ad0: 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 22 64 65 ookup config "de
8ae0: 66 61 75 6c 74 22 20 76 61 72 29 29 0a 09 28 63 fault" var))..(c
8af0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f onfigf:lookup co
8b00: 6e 66 69 67 20 22 64 65 66 61 75 6c 74 22 20 76 nfig "default" v
8b10: 61 72 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ar))))..(define
8b20: 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 (common:args-get
8b30: 2d 73 74 61 74 65 29 0a 20 20 28 6f 72 20 28 61 -state). (or (a
8b40: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 73 74 rgs:get-arg "-st
8b50: 61 74 65 22 29 28 61 72 67 73 3a 67 65 74 2d 61 ate")(args:get-a
8b60: 72 67 20 22 3a 73 74 61 74 65 22 29 29 29 0a 0a rg ":state")))..
8b70: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
8b80: 61 72 67 73 2d 67 65 74 2d 73 74 61 74 75 73 29 args-get-status)
8b90: 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 . (or (args:get
8ba0: 2d 61 72 67 20 22 2d 73 74 61 74 75 73 22 29 28 -arg "-status")(
8bb0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 73 args:get-arg ":s
8bc0: 74 61 74 75 73 22 29 29 29 0a 0a 28 64 65 66 69 tatus")))..(defi
8bd0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d ne (common:args-
8be0: 67 65 74 2d 74 65 73 74 70 61 74 74 20 72 63 6f get-testpatt rco
8bf0: 6e 66 29 0a 20 20 28 6c 65 74 2a 20 28 3b 3b 20 nf). (let* (;;
8c00: 28 74 61 67 65 78 70 72 20 20 20 20 20 20 20 28 (tagexpr (
8c10: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 args:get-arg "-t
8c20: 61 67 65 78 70 72 22 29 29 0a 20 20 20 20 20 20 agexpr")).
8c30: 20 20 20 3b 3b 20 28 74 61 67 73 2d 74 65 73 74 ;; (tags-test
8c40: 70 61 74 74 20 28 69 66 20 74 61 67 65 78 70 72 patt (if tagexpr
8c50: 20 28 73 74 72 69 6e 67 2d 6a 6f 69 6e 20 28 72 (string-join (r
8c60: 75 6e 73 3a 67 65 74 2d 74 65 73 74 73 2d 6d 61 uns:get-tests-ma
8c70: 74 63 68 69 6e 67 2d 74 61 67 73 20 74 61 67 65 tching-tags tage
8c80: 78 70 72 29 20 22 2c 22 29 20 23 66 29 29 0a 20 xpr) ",") #f)).
8c90: 20 20 20 20 20 20 20 20 28 74 65 73 74 70 61 74 (testpat
8ca0: 74 2d 6b 65 79 20 20 28 69 66 20 28 61 72 67 73 t-key (if (args
8cb0: 3a 67 65 74 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 :get-arg "--mode
8cc0: 70 61 74 74 22 29 20 28 61 72 67 73 3a 67 65 74 patt") (args:get
8cd0: 2d 61 72 67 20 22 2d 2d 6d 6f 64 65 70 61 74 74 -arg "--modepatt
8ce0: 22 29 20 22 54 45 53 54 50 41 54 54 22 29 29 0a ") "TESTPATT")).
8cf0: 20 20 20 20 20 20 20 20 20 28 61 72 67 73 2d 74 (args-t
8d00: 65 73 74 70 61 74 74 20 28 6f 72 20 28 61 72 67 estpatt (or (arg
8d10: 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 65 73 74 s:get-arg "-test
8d20: 70 61 74 74 22 29 20 28 61 72 67 73 3a 67 65 74 patt") (args:get
8d30: 2d 61 72 67 20 22 2d 72 75 6e 74 65 73 74 73 22 -arg "-runtests"
8d40: 29 20 22 25 22 29 29 0a 20 20 20 20 20 20 20 20 ) "%")).
8d50: 20 28 72 74 65 73 74 70 61 74 74 20 20 20 20 20 (rtestpatt
8d60: 28 69 66 20 72 63 6f 6e 66 20 28 72 75 6e 63 6f (if rconf (runco
8d70: 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 20 nfigs-get rconf
8d80: 74 65 73 74 70 61 74 74 2d 6b 65 79 29 20 23 66 testpatt-key) #f
8d90: 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 20 ))). (cond.
8da0: 20 20 20 28 28 61 72 67 73 3a 67 65 74 2d 61 72 ((args:get-ar
8db0: 67 20 22 2d 2d 6d 6f 64 65 70 61 74 74 22 29 20 g "--modepatt")
8dc0: 3b 3b 20 6d 6f 64 65 70 61 74 74 20 69 73 20 61 ;; modepatt is a
8dd0: 20 66 6f 72 63 65 64 20 73 65 74 74 69 6e 67 2c forced setting,
8de0: 20 77 68 65 6e 20 73 65 74 20 69 74 20 4d 55 53 when set it MUS
8df0: 54 20 72 65 66 65 72 20 74 6f 20 61 6e 20 65 78 T refer to an ex
8e00: 69 73 74 69 6e 67 20 50 41 54 54 20 69 6e 20 74 isting PATT in t
8e10: 68 65 20 72 75 6e 63 6f 6e 66 69 67 0a 20 20 20 he runconfig.
8e20: 20 20 20 28 69 66 20 72 63 6f 6e 66 0a 09 20 20 (if rconf..
8e30: 28 72 75 6e 63 6f 6e 66 69 67 73 2d 67 65 74 20 (runconfigs-get
8e40: 72 63 6f 6e 66 20 74 65 73 74 70 61 74 74 2d 6b rconf testpatt-k
8e50: 65 79 29 0a 09 20 20 23 66 29 29 20 20 20 20 20 ey).. #f))
8e60: 3b 3b 20 57 65 20 64 6f 20 4e 4f 54 20 66 61 6c ;; We do NOT fal
8e70: 6c 20 62 61 63 6b 20 74 6f 20 22 25 22 0a 20 20 l back to "%".
8e80: 20 20 20 3b 3b 20 28 74 61 67 73 2d 74 65 73 74 ;; (tags-test
8e90: 70 61 74 74 0a 20 20 20 20 20 3b 3b 20 20 28 64 patt. ;; (d
8ea0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
8eb0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
8ec0: 6f 72 74 2a 20 22 2d 74 61 67 65 78 70 72 20 22 ort* "-tagexpr "
8ed0: 74 61 67 65 78 70 72 22 20 73 65 6c 65 63 74 73 tagexpr" selects
8ee0: 20 74 65 73 74 70 61 74 74 20 22 74 61 67 73 2d testpatt "tags-
8ef0: 74 65 73 74 70 61 74 74 29 0a 20 20 20 20 20 3b testpatt). ;
8f00: 3b 20 20 74 61 67 73 2d 74 65 73 74 70 61 74 74 ; tags-testpatt
8f10: 29 0a 20 20 20 20 20 28 28 61 6e 64 20 28 65 71 ). ((and (eq
8f20: 75 61 6c 3f 20 61 72 67 73 2d 74 65 73 74 70 61 ual? args-testpa
8f30: 74 74 20 22 25 22 29 20 72 74 65 73 74 70 61 74 tt "%") rtestpat
8f40: 74 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a t). (debug:
8f50: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
8f60: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
8f70: 22 74 65 73 74 70 61 74 74 20 64 65 66 69 6e 65 "testpatt define
8f80: 64 20 69 6e 20 22 74 65 73 74 70 61 74 74 2d 6b d in "testpatt-k
8f90: 65 79 22 20 66 72 6f 6d 20 72 75 6e 63 6f 6e 66 ey" from runconf
8fa0: 69 67 73 3a 20 22 20 72 74 65 73 74 70 61 74 74 igs: " rtestpatt
8fb0: 29 0a 20 20 20 20 20 20 72 74 65 73 74 70 61 74 ). rtestpat
8fc0: 74 29 0a 20 20 20 20 20 28 65 6c 73 65 20 61 72 t). (else ar
8fd0: 67 73 2d 74 65 73 74 70 61 74 74 29 29 29 29 0a gs-testpatt)))).
8fe0: 0a 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ...(define (comm
8ff0: 6f 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 78 63 65 on:false-on-exce
9000: 70 74 69 6f 6e 20 74 68 75 6e 6b 20 23 21 6b 65 ption thunk #!ke
9010: 79 20 28 6d 65 73 73 61 67 65 20 23 66 29 29 0a y (message #f)).
9020: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
9030: 69 6f 6e 73 20 65 78 6e 0a 20 20 20 20 20 20 20 ions exn.
9040: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 62 (b
9050: 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 20 egin.
9060: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if
9070: 6d 65 73 73 61 67 65 0a 20 20 20 20 20 20 20 20 message.
9080: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9090: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
90a0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
90b0: 6c 6f 67 2d 70 6f 72 74 2a 20 6d 65 73 73 61 67 log-port* messag
90c0: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
90d0: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 28 #f) (
90e0: 74 68 75 6e 6b 29 20 29 29 0a 0a 28 64 65 66 69 thunk) ))..(defi
90f0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d ne (common:file-
9100: 65 78 69 73 74 73 3f 20 70 61 74 68 2d 73 74 72 exists? path-str
9110: 69 6e 67 29 0a 20 20 3b 3b 20 74 68 69 73 20 61 ing). ;; this a
9120: 76 6f 69 64 73 20 73 74 61 63 6b 20 64 75 6d 70 voids stack dump
9130: 73 20 69 6e 20 74 68 65 20 63 61 73 65 20 77 68 s in the case wh
9140: 65 72 65 20 0a 0a 20 20 3b 3b 3b 3b 20 54 4f 44 ere .. ;;;; TOD
9150: 4f 3a 20 63 61 74 63 68 20 70 65 72 6d 69 73 73 O: catch permiss
9160: 69 6f 6e 20 64 65 6e 69 65 64 20 65 78 63 65 70 ion denied excep
9170: 74 69 6f 6e 73 20 61 6e 64 20 65 6d 69 74 20 61 tions and emit a
9180: 70 70 72 6f 70 72 69 61 74 65 20 77 61 72 6e 69 ppropriate warni
9190: 6e 67 73 2c 20 65 67 3a 20 20 73 79 73 74 65 6d ngs, eg: system
91a0: 20 65 72 72 6f 72 20 77 68 69 6c 65 20 74 72 79 error while try
91b0: 69 6e 67 20 74 6f 20 61 63 63 65 73 73 20 66 69 ing to access fi
91c0: 6c 65 3a 20 22 2f 6e 66 73 2f 70 64 78 2f 64 69 le: "/nfs/pdx/di
91d0: 73 6b 73 2f 69 63 66 5f 65 6e 76 5f 64 69 73 6b sks/icf_env_disk
91e0: 30 30 31 2f 62 6a 62 61 72 63 6c 61 2f 67 77 61 001/bjbarcla/gwa
91f0: 2f 69 73 73 75 65 73 2f 6d 74 64 65 76 2f 72 61 /issues/mtdev/ra
9200: 6e 64 79 2d 73 6c 6f 77 2f 72 65 70 72 6f 64 75 ndy-slow/reprodu
9210: 63 65 2f 71 2e 2e 2e 0a 20 20 28 63 6f 6d 6d 6f ce/q.... (commo
9220: 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 78 63 65 70 n:false-on-excep
9230: 74 69 6f 6e 20 28 6c 61 6d 62 64 61 20 28 29 20 tion (lambda ()
9240: 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 61 (file-exists? pa
9250: 74 68 2d 73 74 72 69 6e 67 29 29 0a 20 20 20 20 th-string)).
9260: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9270: 20 20 20 20 20 20 20 20 20 6d 65 73 73 61 67 65 message
9280: 3a 20 28 63 6f 6e 63 20 22 55 6e 61 62 6c 65 20 : (conc "Unable
9290: 74 6f 20 61 63 63 65 73 73 20 70 61 74 68 3a 20 to access path:
92a0: 22 20 70 61 74 68 2d 73 74 72 69 6e 67 29 0a 20 " path-string).
92b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
92c0: 20 20 20 20 20 20 20 20 20 20 20 20 29 29 0a 0a ))..
92d0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
92e0: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
92f0: 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 29 0a 20 ? path-string).
9300: 20 3b 3b 3b 3b 20 54 4f 44 4f 3a 20 63 61 74 63 ;;;; TODO: catc
9310: 68 20 70 65 72 6d 69 73 73 69 6f 6e 20 64 65 6e h permission den
9320: 69 65 64 20 65 78 63 65 70 74 69 6f 6e 73 20 61 ied exceptions a
9330: 6e 64 20 65 6d 69 74 20 61 70 70 72 6f 70 72 69 nd emit appropri
9340: 61 74 65 20 77 61 72 6e 69 6e 67 73 2c 20 65 67 ate warnings, eg
9350: 3a 20 20 73 79 73 74 65 6d 20 65 72 72 6f 72 20 : system error
9360: 77 68 69 6c 65 20 74 72 79 69 6e 67 20 74 6f 20 while trying to
9370: 61 63 63 65 73 73 20 66 69 6c 65 3a 20 22 2f 6e access file: "/n
9380: 66 73 2f 70 64 78 2f 64 69 73 6b 73 2f 69 63 66 fs/pdx/disks/icf
9390: 5f 65 6e 76 5f 64 69 73 6b 30 30 31 2f 62 6a 62 _env_disk001/bjb
93a0: 61 72 63 6c 61 2f 67 77 61 2f 69 73 73 75 65 73 arcla/gwa/issues
93b0: 2f 6d 74 64 65 76 2f 72 61 6e 64 79 2d 73 6c 6f /mtdev/randy-slo
93c0: 77 2f 72 65 70 72 6f 64 75 63 65 2f 71 2e 2e 2e w/reproduce/q...
93d0: 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 66 61 6c 73 65 . (common:false
93e0: 2d 6f 6e 2d 65 78 63 65 70 74 69 6f 6e 20 28 6c -on-exception (l
93f0: 61 6d 62 64 61 20 28 29 20 28 64 69 72 65 63 74 ambda () (direct
9400: 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 61 74 68 ory-exists? path
9410: 2d 73 74 72 69 6e 67 29 29 0a 20 20 20 20 20 20 -string)).
9420: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9430: 20 20 20 20 20 20 20 6d 65 73 73 61 67 65 3a 20 message:
9440: 28 63 6f 6e 63 20 22 55 6e 61 62 6c 65 20 74 6f (conc "Unable to
9450: 20 61 63 63 65 73 73 20 70 61 74 68 3a 20 22 20 access path: "
9460: 70 61 74 68 2d 73 74 72 69 6e 67 29 0a 20 20 20 path-string).
9470: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9480: 20 20 20 20 20 20 20 20 20 20 29 29 0a 0a 3b 3b ))..;;
9490: 20 64 6f 65 73 20 74 68 65 20 64 69 72 65 63 74 does the direct
94a0: 6f 72 79 20 65 78 69 73 74 20 61 6e 64 20 64 6f ory exist and do
94b0: 20 77 65 20 68 61 76 65 20 77 72 69 74 65 20 61 we have write a
94c0: 63 63 65 73 73 3f 0a 3b 3b 0a 3b 3b 20 20 20 20 ccess?.;;.;;
94d0: 72 65 74 75 72 6e 73 20 74 68 65 20 64 69 72 65 returns the dire
94e0: 63 74 6f 72 79 20 6f 72 20 23 66 0a 3b 3b 0a 28 ctory or #f.;;.(
94f0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 define (common:d
9500: 69 72 65 63 74 6f 72 79 2d 77 72 69 74 61 62 6c irectory-writabl
9510: 65 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 29 0a e? path-string).
9520: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
9530: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 23 ions. exn. #
9540: 66 0a 20 20 20 28 69 66 20 28 61 6e 64 20 28 64 f. (if (and (d
9550: 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 3f irectory-exists?
9560: 20 70 61 74 68 2d 73 74 72 69 6e 67 29 0a 20 20 path-string).
9570: 20 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d (file-
9580: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 70 61 write-access? pa
9590: 74 68 2d 73 74 72 69 6e 67 29 29 0a 20 20 20 20 th-string)).
95a0: 20 20 20 70 61 74 68 2d 73 74 72 69 6e 67 0a 20 path-string.
95b0: 20 20 20 20 20 20 23 66 29 29 29 0a 0a 28 64 65 #f)))..(de
95c0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
95d0: 2d 6c 69 6e 6b 74 72 65 65 29 0a 20 20 28 6f 72 -linktree). (or
95e0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4c 49 4e (getenv "MT_LIN
95f0: 4b 54 52 45 45 22 29 0a 20 20 20 20 20 20 28 69 KTREE"). (i
9600: 66 20 2a 63 6f 6e 66 69 67 64 61 74 2a 0a 09 20 f *configdat*..
9610: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
9620: 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 *configdat* "se
9630: 74 75 70 22 20 22 6c 69 6e 6b 74 72 65 65 22 29 tup" "linktree")
9640: 0a 09 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 .. (if *toppath
9650: 2a 0a 09 20 20 20 20 20 20 28 63 6f 6e 63 20 2a *.. (conc *
9660: 74 6f 70 70 61 74 68 2a 20 22 2f 6c 74 22 29 0a toppath* "/lt").
9670: 09 20 20 20 20 20 20 23 66 29 29 29 29 0a 0a 28 . #f))))..(
9680: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 define (common:a
9690: 72 67 73 2d 67 65 74 2d 72 75 6e 6e 61 6d 65 29 rgs-get-runname)
96a0: 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 28 6f . (let ((res (o
96b0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
96c0: 22 2d 72 75 6e 6e 61 6d 65 22 29 0a 09 09 20 28 "-runname")... (
96d0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a 72 args:get-arg ":r
96e0: 75 6e 6e 61 6d 65 22 29 0a 09 09 20 28 67 65 74 unname")... (get
96f0: 65 6e 76 20 22 4d 54 5f 52 55 4e 4e 41 4d 45 22 env "MT_RUNNAME"
9700: 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 69 66 20 )))). ;; (if
9710: 72 65 73 20 28 73 65 74 2d 65 6e 76 69 72 6f 6e res (set-environ
9720: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
9730: 54 5f 52 55 4e 4e 41 4d 45 22 20 72 65 73 29 29 T_RUNNAME" res))
9740: 20 3b 3b 20 6e 6f 74 20 73 75 72 65 20 69 66 20 ;; not sure if
9750: 74 68 69 73 20 69 73 20 61 20 67 6f 6f 64 20 69 this is a good i
9760: 64 65 61 2e 20 73 69 64 65 20 65 66 66 65 63 74 dea. side effect
9770: 20 61 6e 64 20 61 6c 6c 20 2e 2e 2e 0a 20 20 20 and all ....
9780: 20 72 65 73 29 29 0a 0a 28 64 65 66 69 6e 65 20 res))..(define
9790: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 69 65 6c (common:get-fiel
97a0: 64 73 20 63 66 67 64 61 74 29 0a 20 20 28 6c 65 ds cfgdat). (le
97b0: 74 20 28 28 66 69 65 6c 64 73 20 28 68 61 73 68 t ((fields (hash
97c0: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
97d0: 6c 74 20 63 66 67 64 61 74 20 22 66 69 65 6c 64 lt cfgdat "field
97e0: 73 22 20 27 28 29 29 29 29 0a 20 20 20 20 28 6d s" '()))). (m
97f0: 61 70 20 63 61 72 20 66 69 65 6c 64 73 29 29 29 ap car fields)))
9800: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
9810: 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 65 n:args-get-targe
9820: 74 20 23 21 6b 65 79 20 28 73 70 6c 69 74 20 23 t #!key (split #
9830: 66 29 28 65 78 69 74 2d 69 66 2d 62 61 64 20 23 f)(exit-if-bad #
9840: 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 f)). (let* ((ke
9850: 79 73 20 20 20 20 28 69 66 20 28 68 61 73 68 2d ys (if (hash-
9860: 74 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 61 table? *configda
9870: 74 2a 29 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d t*) (common:get-
9880: 66 69 65 6c 64 73 20 2a 63 6f 6e 66 69 67 64 61 fields *configda
9890: 74 2a 29 20 27 28 29 29 29 0a 09 20 28 6e 75 6d t*) '())).. (num
98a0: 6b 65 79 73 20 28 6c 65 6e 67 74 68 20 6b 65 79 keys (length key
98b0: 73 29 29 0a 09 20 28 74 61 72 67 65 74 20 20 28 s)).. (target (
98c0: 6f 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 or (args:get-arg
98d0: 20 22 2d 72 65 71 74 61 72 67 22 29 0a 09 09 20 "-reqtarg")...
98e0: 20 20 20 20 20 28 61 72 67 73 3a 67 65 74 2d 61 (args:get-a
98f0: 72 67 20 22 2d 74 61 72 67 65 74 22 29 0a 09 09 rg "-target")...
9900: 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d (getenv "M
9910: 54 5f 54 41 52 47 45 54 22 29 29 29 0a 09 20 28 T_TARGET"))).. (
9920: 74 6c 69 73 74 20 20 20 28 69 66 20 74 61 72 67 tlist (if targ
9930: 65 74 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 et (string-split
9940: 20 74 61 72 67 65 74 20 22 2f 22 20 23 74 29 20 target "/" #t)
9950: 27 28 29 29 29 0a 09 20 28 76 61 6c 69 64 20 20 '())).. (valid
9960: 20 28 69 66 20 74 61 72 67 65 74 0a 09 09 20 20 (if target...
9970: 20 20 20 20 28 6f 72 20 28 6e 75 6c 6c 3f 20 6b (or (null? k
9980: 65 79 73 29 20 3b 3b 20 70 72 6f 62 61 62 6c 79 eys) ;; probably
9990: 20 64 6f 6e 27 74 20 6b 6e 6f 77 20 6f 75 72 20 don't know our
99a0: 6b 65 79 73 20 79 65 74 0a 09 09 09 20 20 28 61 keys yet.... (a
99b0: 6e 64 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 nd (not (null? t
99c0: 6c 69 73 74 29 29 0a 09 09 09 20 20 20 20 20 20 list))....
99d0: 20 28 65 71 3f 20 6e 75 6d 6b 65 79 73 20 28 6c (eq? numkeys (l
99e0: 65 6e 67 74 68 20 74 6c 69 73 74 29 29 0a 09 09 ength tlist))...
99f0: 09 20 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 28 . (null? (
9a00: 66 69 6c 74 65 72 20 73 74 72 69 6e 67 2d 6e 75 filter string-nu
9a10: 6c 6c 3f 20 74 6c 69 73 74 29 29 29 29 0a 09 09 ll? tlist))))...
9a20: 20 20 20 20 20 20 23 66 29 29 29 0a 20 20 20 20 #f))).
9a30: 28 69 66 20 76 61 6c 69 64 0a 09 28 69 66 20 73 (if valid..(if s
9a40: 70 6c 69 74 0a 09 20 20 20 20 74 6c 69 73 74 0a plit.. tlist.
9a50: 09 20 20 20 20 74 61 72 67 65 74 29 0a 09 28 69 . target)..(i
9a60: 66 20 74 61 72 67 65 74 0a 09 20 20 20 20 28 62 f target.. (b
9a70: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 62 egin.. (deb
9a80: 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 ug:print-error 0
9a90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
9aa0: 72 74 2a 20 22 49 6e 76 61 6c 69 64 20 74 61 72 rt* "Invalid tar
9ab0: 67 65 74 2c 20 73 70 61 63 65 73 20 6f 72 20 62 get, spaces or b
9ac0: 6c 61 6e 6b 73 20 6e 6f 74 20 61 6c 6c 6f 77 65 lanks not allowe
9ad0: 64 20 5c 22 22 20 74 61 72 67 65 74 20 22 5c 22 d \"" target "\"
9ae0: 2c 20 74 61 72 67 65 74 20 73 68 6f 75 6c 64 20 , target should
9af0: 62 65 3a 20 22 20 28 73 74 72 69 6e 67 2d 69 6e be: " (string-in
9b00: 74 65 72 73 70 65 72 73 65 20 6b 65 79 73 20 22 tersperse keys "
9b10: 2f 22 29 20 22 2c 20 68 61 76 65 20 22 20 74 6c /") ", have " tl
9b20: 69 73 74 20 22 20 66 6f 72 20 65 6c 65 6d 65 6e ist " for elemen
9b30: 74 73 22 29 0a 09 20 20 20 20 20 20 28 69 66 20 ts").. (if
9b40: 65 78 69 74 2d 69 66 2d 62 61 64 20 28 65 78 69 exit-if-bad (exi
9b50: 74 20 31 29 29 0a 09 20 20 20 20 20 20 23 66 29 t 1)).. #f)
9b60: 0a 09 20 20 20 20 23 66 29 29 29 29 0a 0a 3b 3b .. #f))))..;;
9b70: 20 6c 6f 6f 6b 69 6e 67 20 6f 6e 6c 79 20 28 61 looking only (a
9b80: 74 20 6c 65 61 73 74 20 66 6f 72 20 6e 6f 77 29 t least for now)
9b90: 20 61 74 20 74 68 65 20 4d 54 5f 20 76 61 72 69 at the MT_ vari
9ba0: 61 62 6c 65 73 20 63 72 61 66 74 20 74 68 65 20 ables craft the
9bb0: 66 75 6c 6c 20 74 65 73 74 6e 61 6d 65 0a 3b 3b full testname.;;
9bc0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
9bd0: 3a 67 65 74 2d 66 75 6c 6c 2d 74 65 73 74 2d 6e :get-full-test-n
9be0: 61 6d 65 29 0a 20 20 28 69 66 20 28 67 65 74 65 ame). (if (gete
9bf0: 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 nv "MT_TEST_NAME
9c00: 22 29 0a 20 20 20 20 20 20 28 69 66 20 28 61 6e "). (if (an
9c10: 64 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 d (getenv "MT_IT
9c20: 45 4d 50 41 54 48 22 29 0a 20 20 20 20 20 20 20 EMPATH").
9c30: 20 20 20 20 20 20 20 20 28 6e 6f 74 20 28 65 71 (not (eq
9c40: 75 61 6c 3f 20 28 67 65 74 65 6e 76 20 22 4d 54 ual? (getenv "MT
9c50: 5f 49 54 45 4d 50 41 54 48 22 29 20 22 22 29 29 _ITEMPATH") ""))
9c60: 29 0a 20 20 20 20 20 20 20 20 20 20 28 67 65 74 ). (get
9c70: 65 6e 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d env "MT_TEST_NAM
9c80: 45 22 29 0a 20 20 20 20 20 20 20 20 20 20 28 63 E"). (c
9c90: 6f 6e 63 20 28 67 65 74 65 6e 76 20 22 4d 54 5f onc (getenv "MT_
9ca0: 54 45 53 54 5f 4e 41 4d 45 22 29 20 22 2f 22 20 TEST_NAME") "/"
9cb0: 28 67 65 74 65 6e 76 20 22 4d 54 5f 49 54 45 4d (getenv "MT_ITEM
9cc0: 50 41 54 48 22 29 29 29 0a 20 20 20 20 20 20 23 PATH"))). #
9cd0: 66 29 29 0a 0a 3b 3b 20 6c 6f 67 69 63 20 66 6f f))..;; logic fo
9ce0: 72 20 67 65 74 74 69 6e 67 20 68 6f 6d 65 68 6f r getting homeho
9cf0: 73 74 2e 20 52 65 74 75 72 6e 73 20 28 68 6f 73 st. Returns (hos
9d00: 74 20 2e 20 61 74 2d 68 6f 6d 65 29 0a 3b 3b 20 t . at-home).;;
9d10: 49 46 20 2a 74 6f 70 70 61 74 68 2a 20 69 73 20 IF *toppath* is
9d20: 6e 6f 74 20 73 65 74 2c 20 77 61 69 74 20 75 70 not set, wait up
9d30: 20 74 6f 20 66 69 76 65 20 73 65 63 6f 6e 64 73 to five seconds
9d40: 20 74 72 79 69 6e 67 20 65 76 65 72 79 20 74 77 trying every tw
9d50: 6f 20 73 65 63 6f 6e 64 73 0a 3b 3b 20 28 74 68 o seconds.;; (th
9d60: 69 73 20 69 73 20 74 6f 20 61 63 63 6f 6d 6f 64 is is to accomod
9d70: 61 74 65 20 74 68 65 20 77 61 74 63 68 64 6f 67 ate the watchdog
9d80: 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ).;;.(define (co
9d90: 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 mmon:get-homehos
9da0: 74 20 23 21 6b 65 79 20 28 74 72 79 6e 75 6d 20 t #!key (trynum
9db0: 35 29 29 0a 20 20 3b 3b 20 63 61 6c 6c 65 64 20 5)). ;; called
9dc0: 6f 66 74 65 6e 20 65 73 70 65 63 69 61 6c 6c 79 often especially
9dd0: 20 61 74 20 73 74 61 72 74 20 75 70 2e 20 75 73 at start up. us
9de0: 65 20 6d 75 74 65 78 20 74 6f 20 65 6c 69 6d 69 e mutex to elimi
9df0: 6e 61 74 65 20 63 6f 6c 6c 69 73 69 6f 6e 73 0a nate collisions.
9e00: 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 20 2a (mutex-lock! *
9e10: 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 homehost-mutex*)
9e20: 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 2a 68 6f . (cond. (*ho
9e30: 6d 65 2d 68 6f 73 74 2a 0a 20 20 20 20 28 6d 75 me-host*. (mu
9e40: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d tex-unlock! *hom
9e50: 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 ehost-mutex*).
9e60: 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 29 0a 20 *home-host*).
9e70: 20 20 28 28 6e 6f 74 20 2a 74 6f 70 70 61 74 68 ((not *toppath
9e80: 2a 29 0a 20 20 20 20 28 6d 75 74 65 78 2d 75 6e *). (mutex-un
9e90: 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d lock! *homehost-
9ea0: 6d 75 74 65 78 2a 29 0a 20 20 20 20 28 6c 61 75 mutex*). (lau
9eb0: 6e 63 68 3a 73 65 74 75 70 29 20 3b 3b 20 73 61 nch:setup) ;; sa
9ec0: 66 65 6c 79 20 6d 75 74 65 78 65 64 20 6e 6f 77 fely mutexed now
9ed0: 0a 20 20 20 20 28 69 66 20 28 3e 20 74 72 79 6e . (if (> tryn
9ee0: 75 6d 20 30 29 0a 09 28 62 65 67 69 6e 0a 09 20 um 0)..(begin..
9ef0: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
9f00: 32 29 0a 09 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 2).. (common:ge
9f10: 74 2d 68 6f 6d 65 68 6f 73 74 20 74 72 79 6e 75 t-homehost trynu
9f20: 6d 3a 20 28 2d 20 74 72 79 6e 75 6d 20 31 29 29 m: (- trynum 1))
9f30: 29 0a 09 23 66 29 29 0a 20 20 20 28 65 6c 73 65 )..#f)). (else
9f40: 0a 20 20 20 20 28 6c 65 74 2a 20 28 28 63 75 72 . (let* ((cur
9f50: 72 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 74 2d rhost (get-host-
9f60: 6e 61 6d 65 29 29 0a 09 20 20 20 28 62 65 73 74 name)).. (best
9f70: 61 64 72 73 20 28 73 65 72 76 65 72 3a 67 65 74 adrs (server:get
9f80: 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 72 -best-guess-addr
9f90: 65 73 73 20 63 75 72 72 68 6f 73 74 29 29 0a 09 ess currhost))..
9fa0: 20 20 20 3b 3b 20 66 69 72 73 74 20 6c 6f 6f 6b ;; first look
9fb0: 20 69 6e 20 63 6f 6e 66 69 67 2c 20 74 68 65 6e in config, then
9fc0: 20 6c 6f 6f 6b 20 69 6e 20 66 69 6c 65 20 2e 68 look in file .h
9fd0: 6f 6d 65 68 6f 73 74 2c 20 63 72 65 61 74 65 20 omehost, create
9fe0: 69 74 20 69 66 20 6e 6f 74 20 66 6f 75 6e 64 0a it if not found.
9ff0: 09 20 20 20 28 68 6f 6d 65 68 6f 73 74 20 28 6f . (homehost (o
a000: 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
a010: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
a020: 65 72 76 65 72 22 20 22 68 6f 6d 65 68 6f 73 74 erver" "homehost
a030: 22 20 29 0a 09 09 09 20 28 68 61 6e 64 6c 65 2d " ).... (handle-
a040: 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 20 20 exceptions....
a050: 20 20 20 65 78 6e 0a 09 09 09 20 20 20 20 20 28 exn.... (
a060: 69 66 20 28 3e 20 74 72 79 6e 75 6d 20 30 29 0a if (> trynum 0).
a070: 09 09 09 09 20 28 6c 65 74 20 28 28 64 65 6c 61 .... (let ((dela
a080: 79 2d 74 69 6d 65 20 28 2a 20 28 2d 20 35 20 74 y-time (* (- 5 t
a090: 72 79 6e 75 6d 29 20 35 29 29 29 0a 09 09 09 09 rynum) 5))).....
a0a0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
a0b0: 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 ! *homehost-mute
a0c0: 78 2a 29 0a 09 09 09 09 20 20 20 28 64 65 62 75 x*)..... (debu
a0d0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
a0e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
a0f0: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 72 ROR: Failed to r
a100: 65 61 64 20 2e 68 6f 6d 65 68 6f 73 74 20 66 69 ead .homehost fi
a110: 6c 65 2c 20 64 65 6c 61 79 69 6e 67 20 22 20 64 le, delaying " d
a120: 65 6c 61 79 2d 74 69 6d 65 20 22 20 73 65 63 6f elay-time " seco
a130: 6e 64 73 20 61 6e 64 20 74 72 79 69 6e 67 20 61 nds and trying a
a140: 67 61 69 6e 2c 20 6d 65 73 73 61 67 65 3a 20 22 gain, message: "
a150: 20 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 ((condition-pr
a160: 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 operty-accessor
a170: 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 'exn 'message) e
a180: 78 6e 29 29 0a 09 09 09 09 20 20 20 28 74 68 72 xn))..... (thr
a190: 65 61 64 2d 73 6c 65 65 70 21 20 64 65 6c 61 79 ead-sleep! delay
a1a0: 2d 74 69 6d 65 29 0a 09 09 09 09 20 20 20 28 63 -time)..... (c
a1b0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f ommon:get-homeho
a1c0: 73 74 20 74 72 79 6e 75 6d 3a 20 28 2d 20 74 72 st trynum: (- tr
a1d0: 79 6e 75 6d 20 31 29 29 29 0a 09 09 09 09 20 28 ynum 1)))..... (
a1e0: 62 65 67 69 6e 0a 09 09 09 09 20 20 20 28 6d 75 begin..... (mu
a1f0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d tex-unlock! *hom
a200: 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 09 09 ehost-mutex*)...
a210: 09 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e .. (debug:prin
a220: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
a230: 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 46 -port* "ERROR: F
a240: 61 69 6c 65 64 20 74 6f 20 72 65 61 64 20 2e 68 ailed to read .h
a250: 6f 6d 65 68 6f 73 74 20 66 69 6c 65 20 61 66 74 omehost file aft
a260: 65 72 20 74 72 79 69 6e 67 20 66 69 76 65 20 74 er trying five t
a270: 69 6d 65 73 2e 20 47 69 76 69 6e 67 20 75 70 20 imes. Giving up
a280: 61 6e 64 20 65 78 69 74 69 6e 67 2c 20 6d 65 73 and exiting, mes
a290: 73 61 67 65 3a 20 22 20 20 28 28 63 6f 6e 64 69 sage: " ((condi
a2a0: 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 tion-property-ac
a2b0: 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 cessor 'exn 'mes
a2c0: 73 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 09 sage) exn)).....
a2d0: 20 20 20 28 65 78 69 74 20 31 29 29 29 0a 09 09 (exit 1)))...
a2e0: 09 20 20 20 28 6c 65 74 20 28 28 68 68 66 20 28 . (let ((hhf (
a2f0: 63 6f 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 conc *toppath* "
a300: 2f 2e 68 6f 6d 65 68 6f 73 74 22 29 29 29 0a 09 /.homehost")))..
a310: 09 09 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d .. (if (comm
a320: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
a330: 68 68 66 29 0a 09 09 09 09 20 28 77 69 74 68 2d hhf)..... (with-
a340: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
a350: 68 68 66 20 72 65 61 64 2d 6c 69 6e 65 29 0a 09 hhf read-line)..
a360: 09 09 09 20 28 69 66 20 28 66 69 6c 65 2d 77 72 ... (if (file-wr
a370: 69 74 65 2d 61 63 63 65 73 73 3f 20 2a 74 6f 70 ite-access? *top
a380: 70 61 74 68 2a 29 0a 09 09 09 09 20 20 20 20 20 path*).....
a390: 28 62 65 67 69 6e 0a 09 09 09 09 20 20 20 20 20 (begin.....
a3a0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
a3b0: 6f 2d 66 69 6c 65 20 68 68 66 0a 09 09 09 09 09 o-file hhf......
a3c0: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 09 09 (lambda ().....
a3d0: 09 20 20 20 28 70 72 69 6e 74 20 62 65 73 74 61 . (print besta
a3e0: 64 72 73 29 29 29 0a 09 09 09 09 20 20 20 20 20 drs))).....
a3f0: 20 20 28 62 65 67 69 6e 0a 09 09 09 09 09 20 28 (begin...... (
a400: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 mutex-unlock! *h
a410: 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a omehost-mutex*).
a420: 09 09 09 09 09 20 28 63 61 72 20 28 63 6f 6d 6d ..... (car (comm
a430: 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 on:get-homehost)
a440: 29 29 29 0a 09 09 09 09 20 20 20 20 20 23 66 29 )))..... #f)
a450: 29 29 29 29 29 0a 09 20 20 20 28 61 74 2d 68 6f ))))).. (at-ho
a460: 6d 65 20 20 28 6f 72 20 28 65 71 75 61 6c 3f 20 me (or (equal?
a470: 68 6f 6d 65 68 6f 73 74 20 63 75 72 72 68 6f 73 homehost currhos
a480: 74 29 0a 09 09 09 20 28 65 71 75 61 6c 3f 20 68 t).... (equal? h
a490: 6f 6d 65 68 6f 73 74 20 62 65 73 74 61 64 72 73 omehost bestadrs
a4a0: 29 29 29 29 0a 20 20 20 20 20 20 28 73 65 74 21 )))). (set!
a4b0: 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 20 28 63 6f *home-host* (co
a4c0: 6e 73 20 68 6f 6d 65 68 6f 73 74 20 61 74 2d 68 ns homehost at-h
a4d0: 6f 6d 65 29 29 0a 20 20 20 20 20 20 28 6d 75 74 ome)). (mut
a4e0: 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 ex-unlock! *home
a4f0: 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 20 host-mutex*).
a500: 20 20 20 2a 68 6f 6d 65 2d 68 6f 73 74 2a 29 29 *home-host*))
a510: 29 29 0a 0a 3b 3b 20 61 6d 20 49 20 6f 6e 20 74 ))..;; am I on t
a520: 68 65 20 68 6f 6d 65 68 6f 73 74 3f 0a 3b 3b 0a he homehost?.;;.
a530: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
a540: 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 20 20 on-homehost?).
a550: 28 6c 65 74 20 28 28 68 68 20 28 63 6f 6d 6d 6f (let ((hh (commo
a560: 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 n:get-homehost))
a570: 29 0a 20 20 20 20 28 69 66 20 68 68 0a 09 28 63 ). (if hh..(c
a580: 64 72 20 68 68 29 0a 09 23 66 29 29 29 0a 0a 3b dr hh)..#f)))..;
a590: 3b 20 64 6f 20 77 65 20 68 6f 6e 6f 72 20 74 68 ; do we honor th
a5a0: 65 20 63 61 63 68 65 73 20 6f 66 20 74 68 65 20 e caches of the
a5b0: 63 6f 6e 66 69 67 20 66 69 6c 65 73 3f 0a 3b 3b config files?.;;
a5c0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
a5d0: 3a 75 73 65 2d 63 61 63 68 65 3f 29 0a 20 20 28 :use-cache?). (
a5e0: 6c 65 74 20 28 28 72 65 73 20 23 74 29 29 20 3b let ((res #t)) ;
a5f0: 3b 20 70 72 69 6f 72 69 74 79 20 62 79 20 6f 72 ; priority by or
a600: 64 65 72 20 6f 66 20 65 76 61 6c 75 61 74 69 6f der of evaluatio
a610: 6e 0a 20 20 20 20 28 69 66 20 2a 63 6f 6e 66 69 n. (if *confi
a620: 67 64 61 74 2a 20 3b 3b 20 73 69 6c 6c 79 6e 65 gdat* ;; sillyne
a630: 73 73 20 68 65 72 65 2e 20 63 61 6e 27 74 20 75 ss here. can't u
a640: 73 65 20 73 65 74 75 70 2f 75 73 65 2d 63 61 63 se setup/use-cac
a650: 68 65 20 74 6f 20 6b 6e 6f 77 20 69 66 20 77 65 he to know if we
a660: 20 63 61 6e 20 75 73 65 20 74 68 65 20 63 61 63 can use the cac
a670: 68 65 64 20 66 69 6c 65 73 21 0a 09 28 69 66 20 hed files!..(if
a680: 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 (equal? (configf
a690: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
a6a0: 61 74 2a 20 22 73 65 74 75 70 22 20 22 75 73 65 at* "setup" "use
a6b0: 2d 63 61 63 68 65 22 29 20 22 6e 6f 22 29 0a 09 -cache") "no")..
a6c0: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 23 66 (set! res #f
a6d0: 29 0a 09 20 20 20 20 28 69 66 20 28 65 71 75 61 ).. (if (equa
a6e0: 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b l? (configf:look
a6f0: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
a700: 73 65 74 75 70 22 20 22 75 73 65 2d 63 61 63 68 setup" "use-cach
a710: 65 22 29 20 22 79 65 73 22 29 0a 09 09 28 73 65 e") "yes")...(se
a720: 74 21 20 72 65 73 20 23 74 29 29 29 29 0a 20 20 t! res #t)))).
a730: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
a740: 61 72 67 20 22 2d 6e 6f 2d 63 61 63 68 65 22 29 arg "-no-cache")
a750: 28 73 65 74 21 20 72 65 73 20 23 66 29 29 20 3b (set! res #f)) ;
a760: 3b 20 6f 76 65 72 72 69 64 65 73 20 73 65 74 74 ; overrides sett
a770: 69 6e 67 20 69 6e 20 22 73 65 74 75 70 22 0a 20 ing in "setup".
a780: 20 20 20 28 69 66 20 28 67 65 74 65 6e 76 20 22 (if (getenv "
a790: 4d 54 5f 55 53 45 5f 43 41 43 48 45 22 29 0a 09 MT_USE_CACHE")..
a7a0: 28 69 66 20 28 65 71 75 61 6c 3f 20 28 67 65 74 (if (equal? (get
a7b0: 65 6e 76 20 22 4d 54 5f 55 53 45 5f 43 41 43 48 env "MT_USE_CACH
a7c0: 45 22 29 20 22 79 65 73 22 29 0a 09 20 20 20 20 E") "yes")..
a7d0: 28 73 65 74 21 20 72 65 73 20 23 74 29 0a 09 20 (set! res #t)..
a7e0: 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 28 (if (equal? (
a7f0: 67 65 74 65 6e 76 20 22 4d 54 5f 55 53 45 5f 43 getenv "MT_USE_C
a800: 41 43 48 45 22 29 20 22 6e 6f 22 29 0a 09 09 28 ACHE") "no")...(
a810: 73 65 74 21 20 72 65 73 20 23 66 29 29 29 29 20 set! res #f))))
a820: 20 20 20 3b 3b 20 6f 76 65 72 72 69 64 65 73 20 ;; overrides
a830: 2d 6e 6f 2d 63 61 63 68 65 20 73 77 69 74 63 68 -no-cache switch
a840: 0a 20 20 20 20 72 65 73 29 29 0a 20 20 0a 3b 3b . res)). .;;
a850: 20 66 6f 72 63 65 20 75 73 65 20 6f 66 20 73 65 force use of se
a860: 72 76 65 72 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 rver?.;;.(define
a870: 20 28 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 2d 73 (common:force-s
a880: 65 72 76 65 72 3f 29 0a 20 20 28 6c 65 74 2a 20 erver?). (let*
a890: 28 28 66 6f 72 63 65 2d 73 65 74 74 69 6e 67 20 ((force-setting
a8a0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
a8b0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 72 *configdat* "ser
a8c0: 76 65 72 22 20 22 66 6f 72 63 65 22 29 29 0a 09 ver" "force"))..
a8d0: 20 28 66 6f 72 63 65 2d 74 79 70 65 20 20 20 20 (force-type
a8e0: 28 69 66 20 66 6f 72 63 65 2d 73 65 74 74 69 6e (if force-settin
a8f0: 67 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f g (string->symbo
a900: 6c 20 66 6f 72 63 65 2d 73 65 74 74 69 6e 67 29 l force-setting)
a910: 20 23 66 29 29 0a 09 20 28 66 6f 72 63 65 2d 72 #f)).. (force-r
a920: 65 73 75 6c 74 20 20 28 63 61 73 65 20 66 6f 72 esult (case for
a930: 63 65 2d 74 79 70 65 0a 09 09 09 20 20 28 28 23 ce-type.... ((#
a940: 66 29 20 20 20 20 20 23 66 29 0a 09 09 09 20 20 f) #f)....
a950: 28 28 61 6c 77 61 79 73 29 20 23 74 29 0a 09 09 ((always) #t)...
a960: 09 20 20 28 28 74 65 73 74 29 20 20 20 28 69 66 . ((test) (if
a970: 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 (args:get-arg "
a980: 2d 65 78 65 63 75 74 65 22 29 20 3b 3b 20 77 65 -execute") ;; we
a990: 20 61 72 65 20 69 6e 20 61 20 74 65 73 74 0a 09 are in a test..
a9a0: 09 09 09 09 23 74 0a 09 09 09 09 09 23 66 29 29 ....#t......#f))
a9b0: 0a 09 09 09 20 20 28 65 6c 73 65 0a 09 09 09 20 .... (else....
a9c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
a9d0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
a9e0: 72 74 2a 20 22 45 52 52 4f 52 3a 20 42 61 64 20 rt* "ERROR: Bad
a9f0: 73 65 72 76 65 72 20 66 6f 72 63 65 20 73 65 74 server force set
aa00: 74 69 6e 67 20 22 20 66 6f 72 63 65 2d 73 65 74 ting " force-set
aa10: 74 69 6e 67 20 22 2c 20 66 6f 72 63 69 6e 67 20 ting ", forcing
aa20: 73 65 72 76 65 72 2e 22 29 0a 09 09 09 20 20 20 server.")....
aa30: 23 74 29 29 29 29 20 3b 3b 20 64 65 66 61 75 6c #t)))) ;; defaul
aa40: 74 20 74 6f 20 72 65 71 75 69 72 69 6e 67 20 73 t to requiring s
aa50: 65 72 76 65 72 0a 20 20 20 20 28 69 66 20 66 6f erver. (if fo
aa60: 72 63 65 2d 72 65 73 75 6c 74 0a 09 28 62 65 67 rce-result..(beg
aa70: 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 in.. (debug:pri
aa80: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
aa90: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 6f lt-log-port* "fo
aaa0: 72 63 69 6e 67 20 75 73 65 20 6f 66 20 73 65 72 rcing use of ser
aab0: 76 65 72 2c 20 66 6f 72 63 65 20 73 65 74 74 69 ver, force setti
aac0: 6e 67 20 69 73 20 5c 22 22 20 66 6f 72 63 65 2d ng is \"" force-
aad0: 73 65 74 74 69 6e 67 20 22 5c 22 2e 22 29 0a 09 setting "\".")..
aae0: 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a 3b 3b #t)..#f)))..;;
aaf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab30: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 ======.;; M I S
ab40: 43 20 20 20 4c 20 49 20 53 20 54 20 53 0a 3b 3b C L I S T S.;;
ab50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ab90: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 74 65 6d 73 ======..;; items
aba0: 20 69 6e 20 6c 69 73 74 61 20 61 72 65 20 6d 61 in lista are ma
abb0: 74 63 68 65 64 20 76 61 6c 75 65 20 61 6e 64 20 tched value and
abc0: 70 6f 73 69 74 69 6f 6e 20 69 6e 20 6c 69 73 74 position in list
abd0: 62 0a 3b 3b 20 72 65 74 75 72 6e 20 74 68 65 20 b.;; return the
abe0: 72 65 6d 61 69 6e 69 6e 67 20 69 74 65 6d 73 20 remaining items
abf0: 69 6e 20 6c 69 73 74 62 20 6f 72 20 23 66 0a 3b in listb or #f.;
ac00: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
ac10: 6e 3a 6c 69 73 74 2d 69 73 2d 73 75 62 6c 69 73 n:list-is-sublis
ac20: 74 20 6c 69 73 74 61 20 6c 69 73 74 62 29 0a 20 t lista listb).
ac30: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 69 73 74 (if (null? list
ac40: 61 29 0a 20 20 20 20 20 20 6c 69 73 74 62 20 3b a). listb ;
ac50: 3b 20 61 6c 6c 20 69 74 65 6d 73 20 69 6e 20 6c ; all items in l
ac60: 69 73 74 62 20 61 72 65 20 22 72 65 6d 61 69 6e istb are "remain
ac70: 69 6e 67 22 0a 20 20 20 20 20 20 28 69 66 20 28 ing". (if (
ac80: 3e 20 28 6c 65 6e 67 74 68 20 6c 69 73 74 61 29 > (length lista)
ac90: 28 6c 65 6e 67 74 68 20 6c 69 73 74 62 29 29 20 (length listb))
aca0: 0a 09 20 20 23 66 0a 09 20 20 28 6c 65 74 20 6c .. #f.. (let l
acb0: 6f 6f 70 20 28 28 68 65 64 61 20 28 63 61 72 20 oop ((heda (car
acc0: 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 20 28 lista))... (
acd0: 74 61 6c 61 20 28 63 64 72 20 6c 69 73 74 61 29 tala (cdr lista)
ace0: 29 0a 09 09 20 20 20 20 20 28 68 65 64 62 20 28 )... (hedb (
acf0: 63 61 72 20 6c 69 73 74 62 29 29 0a 09 09 20 20 car listb))...
ad00: 20 20 20 28 74 61 6c 62 20 28 63 64 72 20 6c 69 (talb (cdr li
ad10: 73 74 62 29 29 29 0a 09 20 20 20 20 28 69 66 20 stb))).. (if
ad20: 28 65 71 75 61 6c 3f 20 68 65 64 61 20 68 65 64 (equal? heda hed
ad30: 62 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c 3f 20 b)...(if (null?
ad40: 74 61 6c 61 29 20 3b 3b 20 77 65 20 61 72 65 20 tala) ;; we are
ad50: 64 6f 6e 65 0a 09 09 20 20 20 20 74 61 6c 62 0a done... talb.
ad60: 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 .. (loop (car
ad70: 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 64 72 tala).... (cdr
ad80: 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 61 72 tala).... (car
ad90: 20 74 61 6c 62 29 0a 09 09 09 20 20 0a 09 09 09 talb).... ....
ada0: 20 20 28 63 64 72 20 74 61 6c 62 29 29 29 0a 09 (cdr talb)))..
adb0: 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 4e 65 65 .#f)))))..;; Nee
adc0: 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 6c 69 73 ded for long lis
add0: 74 73 20 74 6f 20 62 65 20 73 6f 72 74 65 64 20 ts to be sorted
ade0: 77 68 65 72 65 20 28 61 70 70 6c 79 20 6d 61 78 where (apply max
adf0: 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b 3b 0a 28 ... ) dies.;;.(
ae00: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d define (common:m
ae10: 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 6c 65 74 ax inlst). (let
ae20: 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 61 6c 20 loop ((max-val
ae30: 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 (car inlst))..
ae40: 20 20 20 28 68 65 64 20 20 20 20 20 28 63 61 72 (hed (car
ae50: 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 20 20 28 inlst)).. (
ae60: 74 61 6c 20 20 20 20 20 28 63 64 72 20 69 6e 6c tal (cdr inl
ae70: 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e st))). (if (n
ae80: 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a ot (null? tal)).
ae90: 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 65 64 20 .(loop (max hed
aea0: 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 20 20 20 max-val)..
aeb0: 28 63 61 72 20 74 61 6c 29 0a 09 20 20 20 20 20 (car tal)..
aec0: 20 28 63 64 72 20 74 61 6c 29 29 0a 09 28 6d 61 (cdr tal))..(ma
aed0: 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 29 29 x hed max-val)))
aee0: 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e 20 6f 72 )..;; get min or
aef0: 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 6f 72 20 max, use > for
af00: 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 20 6d 69 max and < for mi
af10: 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 20 61 72 n, this works ar
af20: 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 74 73 20 ound the limits
af30: 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 64 65 66 on apply.;;.(def
af40: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d 69 6e 2d ine (common:min-
af50: 6d 61 78 20 63 6f 6d 70 20 6c 73 74 29 0a 20 20 max comp lst).
af60: 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 29 0a (if (null? lst).
af70: 20 20 20 20 20 20 23 66 20 3b 3b 20 62 65 74 74 #f ;; bett
af80: 65 72 20 74 68 61 6e 20 61 6e 20 65 78 63 65 70 er than an excep
af90: 74 69 6f 6e 20 66 6f 72 20 6d 79 20 6e 65 65 64 tion for my need
afa0: 73 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c s. (fold (l
afb0: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 20 20 ambda (a b)..
afc0: 20 20 20 28 69 66 20 28 63 6f 6d 70 20 61 20 62 (if (comp a b
afd0: 29 20 61 20 62 29 29 0a 09 20 20 20 20 28 63 61 ) a b)).. (ca
afe0: 72 20 6c 73 74 29 0a 09 20 20 20 20 6c 73 74 29 r lst).. lst)
aff0: 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e 20 6f ))..;; get min o
b000: 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 6f 72 r max, use > for
b010: 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 20 6d max and < for m
b020: 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 20 61 in, this works a
b030: 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 74 73 round the limits
b040: 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 64 65 on apply.;;.(de
b050: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 75 6d fine (common:sum
b060: 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6e 75 6c lst). (if (nul
b070: 6c 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 30 0a l? lst). 0.
b080: 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c 61 6d (fold (lam
b090: 62 64 61 20 28 61 20 62 29 0a 09 20 20 20 20 20 bda (a b)..
b0a0: 20 28 2b 20 61 20 62 29 29 0a 09 20 20 20 20 28 (+ a b)).. (
b0b0: 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 6c 73 car lst).. ls
b0c0: 74 29 29 29 0a 0a 3b 3b 20 70 61 74 68 20 6c 69 t)))..;; path li
b0d0: 73 74 20 74 6f 20 68 61 73 68 2d 74 61 62 6c 65 st to hash-table
b0e0: 20 74 72 65 65 0a 3b 3b 20 20 20 28 28 61 20 62 tree.;; ((a b
b0f0: 20 63 29 28 61 20 62 20 64 29 28 65 20 62 20 63 c)(a b d)(e b c
b100: 29 29 20 3d 3e 20 28 28 61 20 28 62 20 28 64 29 )) => ((a (b (d)
b110: 20 28 63 29 29 29 20 28 65 20 28 62 20 28 63 29 (c))) (e (b (c)
b120: 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ))).;;.(define (
b130: 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 74 72 common:list->htr
b140: 65 65 20 6c 73 74 29 0a 20 20 28 6c 65 74 20 28 ee lst). (let (
b150: 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 73 68 (resh (make-hash
b160: 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 28 66 -table))). (f
b170: 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 or-each. (la
b180: 6d 62 64 61 20 28 69 6e 6c 73 74 29 0a 20 20 20 mbda (inlst).
b190: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
b1a0: 68 74 20 20 72 65 73 68 29 0a 09 09 20 20 28 68 ht resh)... (h
b1b0: 65 64 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a ed (car inlst)).
b1c0: 09 09 20 20 28 74 61 6c 20 28 63 64 72 20 69 6e .. (tal (cdr in
b1d0: 6c 73 74 29 29 29 0a 09 20 28 69 66 20 28 68 61 lst))).. (if (ha
b1e0: 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 sh-table-ref/def
b1f0: 61 75 6c 74 20 68 74 20 68 65 64 20 23 66 29 0a ault ht hed #f).
b200: 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 . (if (not (
b210: 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 20 28 null? tal))... (
b220: 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 6c 65 loop (hash-table
b230: 2d 72 65 66 20 68 74 20 68 65 64 29 0a 09 09 20 -ref ht hed)...
b240: 20 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 0a (car tal).
b250: 09 09 20 20 20 20 20 20 20 28 63 64 72 20 74 61 .. (cdr ta
b260: 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 69 l))).. (begi
b270: 6e 0a 09 20 20 20 20 20 20 20 28 68 61 73 68 2d n.. (hash-
b280: 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 68 65 table-set! ht he
b290: 64 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 d (make-hash-tab
b2a0: 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 6c 6f le)).. (lo
b2b0: 6f 70 20 68 74 20 68 65 64 20 74 61 6c 29 29 29 op ht hed tal)))
b2c0: 29 29 0a 20 20 20 20 20 6c 73 74 29 0a 20 20 20 )). lst).
b2d0: 20 72 65 73 68 29 29 0a 0a 3b 3b 20 68 61 73 68 resh))..;; hash
b2e0: 2d 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 68 -table tree to h
b2f0: 74 6d 6c 20 6c 69 73 74 20 74 72 65 65 0a 3b 3b tml list tree.;;
b300: 0a 3b 3b 20 20 20 74 69 70 66 75 6e 63 20 74 61 .;; tipfunc ta
b310: 6b 65 73 20 74 77 6f 20 70 61 72 61 6d 65 74 65 kes two paramete
b320: 72 73 3a 20 79 20 74 68 65 20 74 69 70 20 76 61 rs: y the tip va
b330: 6c 75 65 20 61 6e 64 20 70 61 74 68 20 74 68 65 lue and path the
b340: 20 70 61 74 68 20 74 6f 20 74 68 61 74 20 70 6f path to that po
b350: 69 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 int.;;.(define (
b360: 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 common:htree->ht
b370: 6d 6c 20 68 74 20 70 61 74 68 20 74 69 70 66 75 ml ht path tipfu
b380: 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 nc). (let ((dat
b390: 6c 69 73 74 20 09 28 73 6f 72 74 20 28 68 61 73 list .(sort (has
b3a0: 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 h-table->alist h
b3b0: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
b3c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3d0: 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 20 (lambda (a b).
b3e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b3f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
b400: 73 74 72 69 6e 67 3c 20 28 63 61 72 20 61 29 28 string< (car a)(
b410: 63 61 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 car b)))))).
b420: 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 6c 69 (if (null? datli
b430: 73 74 29 0a 20 20 20 20 09 28 74 69 70 66 75 6e st). .(tipfun
b440: 63 20 23 66 20 70 61 74 68 29 20 3b 3b 20 72 65 c #f path) ;; re
b450: 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 20 67 ally shouldn't g
b460: 65 74 20 68 65 72 65 0a 09 28 73 3a 75 6c 0a 09 et here..(s:ul..
b470: 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 (map (lambda (x
b480: 29 0a 09 09 28 6c 65 74 2a 20 28 28 6c 65 76 65 )...(let* ((leve
b490: 6c 6e 61 6d 65 20 28 63 61 72 20 78 29 29 0a 09 lname (car x))..
b4a0: 09 20 20 20 20 20 20 20 28 79 20 20 20 20 20 20 . (y
b4b0: 20 20 20 28 63 64 72 20 78 29 29 0a 09 09 20 20 (cdr x))...
b4c0: 20 20 20 20 20 28 6e 65 77 70 61 74 68 20 20 20 (newpath
b4d0: 28 61 70 70 65 6e 64 20 70 61 74 68 20 28 6c 69 (append path (li
b4e0: 73 74 20 6c 65 76 65 6c 6e 61 6d 65 29 29 29 0a st levelname))).
b4f0: 09 09 20 20 20 20 20 20 20 28 6c 65 61 66 20 20 .. (leaf
b500: 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 68 61 (or (not (ha
b510: 73 68 2d 74 61 62 6c 65 3f 20 79 29 29 0a 09 09 sh-table? y))...
b520: 09 09 20 20 20 20 20 20 28 6e 75 6c 6c 3f 20 28 .. (null? (
b530: 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 20 hash-table-keys
b540: 79 29 29 29 29 29 0a 09 09 20 20 28 69 66 20 6c y)))))... (if l
b550: 65 61 66 0a 09 09 20 20 20 20 20 20 28 73 3a 6c eaf... (s:l
b560: 69 20 28 74 69 70 66 75 6e 63 20 79 20 6e 65 77 i (tipfunc y new
b570: 70 61 74 68 29 29 0a 09 09 20 20 20 20 20 20 28 path))... (
b580: 73 3a 6c 69 0a 09 09 20 20 20 20 20 20 20 28 6c s:li... (l
b590: 69 73 74 20 0a 09 09 09 6c 65 76 65 6c 6e 61 6d ist ....levelnam
b5a0: 65 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a 68 74 72 e....(common:htr
b5b0: 65 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 77 70 61 ee->html y newpa
b5c0: 74 68 20 74 69 70 66 75 6e 63 29 29 29 29 29 29 th tipfunc))))))
b5d0: 0a 09 20 20 20 20 20 20 64 61 74 6c 69 73 74 29 .. datlist)
b5e0: 29 29 29 29 0a 0a 3b 3b 20 68 61 73 68 2d 74 61 ))))..;; hash-ta
b5f0: 62 6c 65 20 74 72 65 65 20 74 6f 20 61 6c 69 73 ble tree to alis
b600: 74 20 74 72 65 65 0a 3b 3b 0a 28 64 65 66 69 6e t tree.;;.(defin
b610: 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d e (common:htree-
b620: 3e 61 74 72 65 65 20 68 74 29 0a 20 20 28 6d 61 >atree ht). (ma
b630: 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 09 20 p (lambda (x)..
b640: 28 63 6f 6e 73 20 28 63 61 72 20 78 29 0a 09 20 (cons (car x)..
b650: 20 20 20 20 20 20 28 6c 65 74 20 28 28 79 20 28 (let ((y (
b660: 63 64 72 20 78 29 29 29 0a 09 09 20 28 69 66 20 cdr x)))... (if
b670: 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 0a (hash-table? y).
b680: 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 68 .. (common:h
b690: 74 72 65 65 2d 3e 61 74 72 65 65 20 79 29 0a 09 tree->atree y)..
b6a0: 09 20 20 20 20 20 79 29 29 29 29 0a 20 20 20 20 . y)))).
b6b0: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e (hash-table->
b6c0: 61 6c 69 73 74 20 68 74 29 29 29 0a 0a 3b 3b 3d alist ht)))..;;=
b6d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b6e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b6f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b710: 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4e 20 47 =====.;; M U N G
b720: 20 45 20 20 20 44 20 41 20 54 20 41 20 20 20 49 E D A T A I
b730: 20 4e 20 54 20 4f 20 20 20 4e 20 49 20 43 20 45 N T O N I C E
b740: 20 20 20 46 20 4f 20 52 20 4d 20 53 0a 3b 3b 3d F O R M S.;;=
b750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b760: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b780: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b790: 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 72 61 =====..;; Genera
b7a0: 74 65 20 61 6e 20 69 6e 64 65 78 20 66 6f 72 20 te an index for
b7b0: 61 20 73 70 61 72 73 65 20 6c 69 73 74 20 6f 66 a sparse list of
b7c0: 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b 3b 20 20 key values.;;
b7d0: 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 63 6f 6c ( (rowname1 col
b7e0: 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 6f 77 6e name1 val1)(rown
b7f0: 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 20 76 61 ame2 colname2 va
b800: 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e 20 0a l2) ).;;.;; => .
b810: 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e 61 ;;.;; ( (rowna
b820: 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d 65 32 20 me1 0)(rowname2
b830: 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 6e 61 6d 1)) ;; rownam
b840: 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 20 20 es -> num.;;
b850: 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 28 63 6f (colname1 0)(co
b860: 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 20 3b 3b lname2 1)) ) ;;
b870: 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d colnames -> num
b880: 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e 61 6c .;; .;; optional
b890: 20 61 70 70 6c 79 20 70 72 6f 63 20 74 6f 20 72 apply proc to r
b8a0: 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 61 6c ownum colnum val
b8b0: 75 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ue.(define (comm
b8c0: 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 74 2d 67 on:sparse-list-g
b8d0: 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 20 64 61 enerate-index da
b8e0: 74 61 20 23 21 6b 65 79 20 28 70 72 6f 63 20 23 ta #!key (proc #
b8f0: 66 29 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f f)). (if (null?
b900: 20 64 61 74 61 29 0a 20 20 20 20 20 20 28 6c 69 data). (li
b910: 73 74 20 27 28 29 20 27 28 29 29 0a 20 20 20 20 st '() '()).
b920: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
b930: 64 20 28 63 61 72 20 64 61 74 61 29 29 0a 09 09 d (car data))...
b940: 20 28 74 61 6c 20 28 63 64 72 20 64 61 74 61 29 (tal (cdr data)
b950: 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 73 20 27 )... (rownames '
b960: 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 6d 65 73 ())... (colnames
b970: 20 27 28 29 29 0a 09 09 20 28 72 6f 77 6e 75 6d '())... (rownum
b980: 20 20 20 30 29 0a 09 09 20 28 63 6f 6c 6e 75 6d 0)... (colnum
b990: 20 20 20 30 29 29 0a 09 28 6c 65 74 2a 20 28 28 0))..(let* ((
b9a0: 72 6f 77 6b 65 79 20 20 20 20 20 20 20 20 20 20 rowkey
b9b0: 28 63 61 72 20 20 20 68 65 64 29 29 0a 09 20 20 (car hed))..
b9c0: 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 20 20 20 (colkey
b9d0: 20 20 20 20 20 20 28 63 61 64 72 20 20 68 65 64 (cadr hed
b9e0: 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 6c 75 )).. (valu
b9f0: 65 20 20 20 20 20 20 20 20 20 20 20 28 63 61 64 e (cad
ba00: 64 72 20 68 65 64 29 29 0a 09 20 20 20 20 20 20 dr hed))..
ba10: 20 28 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 (existing-rowda
ba20: 74 20 28 61 73 73 6f 63 20 72 6f 77 6b 65 79 20 t (assoc rowkey
ba30: 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 20 20 20 rownames))..
ba40: 20 20 20 28 65 78 69 73 74 69 6e 67 2d 63 6f 6c (existing-col
ba50: 64 61 74 20 28 61 73 73 6f 63 20 63 6f 6c 6b 65 dat (assoc colke
ba60: 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 20 20 y colnames))..
ba70: 20 20 20 20 20 28 63 75 72 72 2d 72 6f 77 6e 75 (curr-rownu
ba80: 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 74 69 m (if existi
ba90: 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e 75 6d ng-rowdat rownum
baa0: 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 29 29 0a (+ rownum 1))).
bab0: 09 20 20 20 20 20 20 20 28 63 75 72 72 2d 63 6f . (curr-co
bac0: 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 lnum (if exi
bad0: 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 63 6f 6c sting-coldat col
bae0: 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 31 29 num (+ colnum 1)
baf0: 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 77 2d )).. (new-
bb00: 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 69 66 20 rownames (if
bb10: 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 20 existing-rowdat
bb20: 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e 73 20 28 rownames (cons (
bb30: 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 75 72 72 list rowkey curr
bb40: 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 6d 65 -rownum) rowname
bb50: 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 s))).. (ne
bb60: 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 20 28 69 w-colnames (i
bb70: 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 f existing-colda
bb80: 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 6f 6e 73 t colnames (cons
bb90: 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 20 63 75 (list colkey cu
bba0: 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c 6e 61 rr-colnum) colna
bbb0: 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b 20 28 64 mes)))).. ;; (d
bbc0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
bbd0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
bbe0: 6f 72 74 2a 20 22 50 72 6f 63 65 73 73 69 6e 67 ort* "Processing
bbf0: 20 72 65 63 6f 72 64 3a 20 22 20 68 65 64 20 29 record: " hed )
bc00: 0a 09 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 .. (if proc (pr
bc10: 6f 63 20 63 75 72 72 2d 72 6f 77 6e 75 6d 20 63 oc curr-rownum c
bc20: 75 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 6b 65 urr-colnum rowke
bc30: 79 20 63 6f 6c 6b 65 79 20 76 61 6c 75 65 29 29 y colkey value))
bc40: 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 .. (if (null? t
bc50: 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 69 73 74 al).. (list
bc60: 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 6e 65 new-rownames ne
bc70: 77 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 20 20 w-colnames)..
bc80: 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 (loop (car ta
bc90: 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 74 61 l)... (cdr ta
bca0: 6c 29 0a 09 09 20 20 20 20 6e 65 77 2d 72 6f 77 l)... new-row
bcb0: 6e 61 6d 65 73 0a 09 09 20 20 20 20 6e 65 77 2d names... new-
bcc0: 63 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 20 20 28 colnames... (
bcd0: 69 66 20 28 3e 20 63 75 72 72 2d 72 6f 77 6e 75 if (> curr-rownu
bce0: 6d 20 72 6f 77 6e 75 6d 29 20 63 75 72 72 2d 72 m rownum) curr-r
bcf0: 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a 09 09 ownum rownum)...
bd00: 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 72 2d (if (> curr-
bd10: 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 20 63 colnum colnum) c
bd20: 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 urr-colnum colnu
bd30: 6d 29 0a 09 09 20 20 20 20 29 29 29 29 29 29 0a m)... )))))).
bd40: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
bd50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bd80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 20 59 =========.;; S Y
bd90: 20 53 20 54 20 45 20 4d 20 20 20 53 20 54 20 55 S T E M S T U
bda0: 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d F F.;;=========
bdb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bdc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bdd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bde0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b =============..;
bdf0: 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 74 20 ; lazy-safe get
be00: 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e 20 6f file mod time. o
be10: 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 66 69 6c n any error (fil
be20: 65 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 20 65 e not existing e
be30: 74 63 2e 29 20 72 65 74 75 72 6e 20 30 0a 3b 3b tc.) return 0.;;
be40: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
be50: 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 :lazy-modificati
be60: 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 0a 20 on-time fpath).
be70: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
be80: 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 ons. exn.
be90: 20 20 20 20 30 0a 20 20 20 20 28 66 69 6c 65 2d 0. (file-
bea0: 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d modification-tim
beb0: 65 20 66 70 61 74 68 29 29 29 0a 0a 3b 3b 20 66 e fpath)))..;; f
bec0: 69 6e 64 20 74 69 6d 65 73 74 61 6d 70 20 6f 66 ind timestamp of
bed0: 20 6e 65 77 65 73 74 20 66 69 6c 65 20 61 73 73 newest file ass
bee0: 6f 63 69 61 74 65 64 20 77 69 74 68 20 61 20 73 ociated with a s
bef0: 71 6c 69 74 65 20 64 62 20 66 69 6c 65 0a 28 64 qlite db file.(d
bf00: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 61 efine (common:la
bf10: 7a 79 2d 73 71 6c 69 74 65 2d 64 62 2d 6d 6f 64 zy-sqlite-db-mod
bf20: 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 ification-time f
bf30: 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 path). (let* ((
bf40: 67 6c 6f 62 2d 6c 69 73 74 20 28 68 61 6e 64 6c glob-list (handl
bf50: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
bf60: 65 78 6e 0a 09 09 09 60 28 2c 28 63 6f 6e 63 20 exn....`(,(conc
bf70: 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 2c 20 "/no/such/file,
bf80: 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e message: " ((con
bf90: 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d dition-property-
bfa0: 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d accessor 'exn 'm
bfb0: 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 0a 09 essage) exn)))..
bfc0: 09 20 20 20 20 20 20 28 67 6c 6f 62 20 28 63 6f . (glob (co
bfd0: 6e 63 20 66 70 61 74 68 20 22 2a 22 29 29 29 29 nc fpath "*"))))
bfe0: 0a 20 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d . (file-
bff0: 6c 69 73 74 20 28 69 66 20 28 65 71 3f 20 30 20 list (if (eq? 0
c000: 28 6c 65 6e 67 74 68 20 67 6c 6f 62 2d 6c 69 73 (length glob-lis
c010: 74 29 29 0a 09 09 09 27 28 22 2f 6e 6f 2f 73 75 t))....'("/no/su
c020: 63 68 2f 66 69 6c 65 22 29 0a 09 09 09 67 6c 6f ch/file")....glo
c030: 62 2d 6c 69 73 74 29 29 29 0a 20 20 28 61 70 70 b-list))). (app
c040: 6c 79 20 6d 61 78 0a 20 20 20 28 6d 61 70 0a 20 ly max. (map.
c050: 20 20 20 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d common:lazy-m
c060: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
c070: 20 0a 20 20 20 20 66 69 6c 65 2d 6c 69 73 74 29 . file-list)
c080: 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 61 )))..;; return a
c090: 20 6e 69 63 65 20 63 6c 65 61 6e 20 70 61 74 68 nice clean path
c0a0: 6e 61 6d 65 20 6d 61 64 65 20 61 62 73 6f 6c 75 name made absolu
c0b0: 74 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d te.(define (comm
c0c0: 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 64 69 72 on:nice-path dir
c0d0: 29 0a 20 20 28 6c 65 74 20 28 28 6d 61 74 63 68 ). (let ((match
c0e0: 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 (string-match "
c0f0: 5e 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c 2f 2e ^(~[^\\/]*)(\\/.
c100: 2a 7c 29 24 22 20 64 69 72 29 29 29 0a 20 20 20 *|)$" dir))).
c110: 20 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 75 73 (if match ;; us
c120: 69 6e 67 20 7e 20 66 6f 72 20 68 6f 6d 65 3f 0a ing ~ for home?.
c130: 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 .(common:nice-pa
c140: 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e th (conc (common
c150: 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 28 63 61 :read-link-f (ca
c160: 64 72 20 6d 61 74 63 68 29 29 20 22 2f 22 20 28 dr match)) "/" (
c170: 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 0a 09 caddr match)))..
c180: 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 68 6e (normalize-pathn
c190: 61 6d 65 20 28 69 66 20 28 61 62 73 6f 6c 75 74 ame (if (absolut
c1a0: 65 2d 70 61 74 68 6e 61 6d 65 3f 20 64 69 72 29 e-pathname? dir)
c1b0: 0a 09 09 09 09 64 69 72 0a 09 09 09 09 28 63 6f .....dir.....(co
c1c0: 6e 63 20 28 63 75 72 72 65 6e 74 2d 64 69 72 65 nc (current-dire
c1d0: 63 74 6f 72 79 29 20 22 2f 22 20 64 69 72 29 29 ctory) "/" dir))
c1e0: 29 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 22 6e ))))..;; make "n
c1f0: 69 63 65 2d 70 61 74 68 22 20 61 76 61 69 6c 61 ice-path" availa
c200: 62 6c 65 20 69 6e 20 63 6f 6e 66 69 67 20 66 69 ble in config fi
c210: 6c 65 73 20 61 6e 64 20 74 68 65 20 72 65 70 6c les and the repl
c220: 0a 28 64 65 66 69 6e 65 20 6e 69 63 65 2d 70 61 .(define nice-pa
c230: 74 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 th common:nice-p
c240: 61 74 68 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ath)..(define (c
c250: 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d ommon:read-link-
c260: 66 20 70 61 74 68 29 0a 20 20 28 68 61 6e 64 6c f path). (handl
c270: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
c280: 20 20 20 65 78 6e 0a 20 20 20 20 20 20 28 62 65 exn. (be
c290: 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 69 6e gin..(debug:prin
c2a0: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
c2b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f lt-log-port* "co
c2c0: 6d 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f 72 65 61 mmand \"/bin/rea
c2d0: 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 20 dlink -f " path
c2e0: 22 5c 22 20 66 61 69 6c 65 64 2e 22 29 0a 09 70 "\" failed.")..p
c2f0: 61 74 68 29 20 3b 3b 20 6a 75 73 74 20 67 69 76 ath) ;; just giv
c300: 65 20 75 70 0a 20 20 20 20 28 77 69 74 68 2d 69 e up. (with-i
c310: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 09 nput-from-pipe..
c320: 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 65 61 64 (conc "/bin/read
c330: 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 29 0a link -f " path).
c340: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
c350: 0a 09 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 ..(read-line))))
c360: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get-
c370: 63 70 75 2d 6c 6f 61 64 20 23 21 6b 65 79 20 28 cpu-load #!key (
c380: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 remote-host #f))
c390: 0a 20 20 28 63 61 72 20 28 63 6f 6d 6d 6f 6e 3a . (car (common:
c3a0: 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d get-cpu-load rem
c3b0: 6f 74 65 2d 68 6f 73 74 29 29 29 0a 3b 3b 20 20 ote-host))).;;
c3c0: 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d 72 65 (let* ((load-re
c3d0: 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 s (process:cmd-r
c3e0: 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 69 6d 65 un->list "uptime
c3f0: 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 2d 72 ")).;; . (load-r
c400: 78 20 20 28 72 65 67 65 78 70 20 22 6c 6f 61 64 x (regexp "load
c410: 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 5c 5c average:\\s+(\\
c420: 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 63 70 75 d+)")).;; . (cpu
c430: 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b 20 20 20 -load #f)).;;
c440: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
c450: 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 28 6c 65 bda (l).;; ..(le
c460: 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 6e t ((match (strin
c470: 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 2d 72 78 g-search load-rx
c480: 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 28 69 66 l))).;; .. (if
c490: 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 20 20 20 match.;; ..
c4a0: 20 20 28 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 (let ((newval
c4b0: 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
c4c0: 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 29 0a (cadr match)))).
c4d0: 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 6d 62 65 ;; ...(if (numbe
c4e0: 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 09 09 r? newval).;; ..
c4f0: 09 20 20 20 20 28 73 65 74 21 20 63 70 75 2d 6c . (set! cpu-l
c500: 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 29 29 29 oad newval))))))
c510: 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 61 72 20 .;; . (car
c520: 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b 20 20 20 load-res)).;;
c530: 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a 0a 3b 3b cpu-load))..;;
c540: 20 67 65 74 20 63 70 75 20 6c 6f 61 64 20 62 79 get cpu load by
c550: 20 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 2f 70 reading from /p
c560: 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 72 65 74 roc/loadavg, ret
c570: 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 76 61 urn all three va
c580: 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 lues.;;.(define
c590: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d (common:get-cpu-
c5a0: 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 load remote-host
c5b0: 29 0a 20 20 28 69 66 20 72 65 6d 6f 74 65 2d 68 ). (if remote-h
c5c0: 6f 73 74 0a 20 20 20 20 20 20 28 6d 61 70 20 28 ost. (map (
c5d0: 6c 61 6d 62 64 61 20 28 72 65 73 29 0a 09 20 20 lambda (res)..
c5e0: 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 (if (eof-obje
c5f0: 63 74 3f 20 72 65 73 29 20 39 65 39 39 20 72 65 ct? res) 9e99 re
c600: 73 29 29 0a 09 20 20 20 28 77 69 74 68 2d 69 6e s)).. (with-in
c610: 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 put-from-pipe ..
c620: 20 20 20 20 28 63 6f 6e 63 20 22 73 73 68 20 22 (conc "ssh "
c630: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 remote-host " c
c640: 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 at /proc/loadavg
c650: 22 29 0a 09 20 20 20 20 28 6c 61 6d 62 64 61 20 ").. (lambda
c660: 28 29 28 6c 69 73 74 20 28 72 65 61 64 29 28 72 ()(list (read)(r
c670: 65 61 64 29 28 72 65 61 64 29 29 29 29 29 0a 20 ead)(read))))).
c680: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
c690: 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f -from-file "/pro
c6a0: 63 2f 6c 6f 61 64 61 76 67 22 20 0a 09 28 6c 61 c/loadavg" ..(la
c6b0: 6d 62 64 61 20 28 29 28 6c 69 73 74 20 28 72 65 mbda ()(list (re
c6c0: 61 64 29 28 72 65 61 64 29 28 72 65 61 64 29 29 ad)(read)(read))
c6d0: 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6e 6f 72 ))))..;; get nor
c6e0: 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f 61 64 malized cpu load
c6f0: 20 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d by reading from
c700: 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 20 61 /proc/loadavg a
c710: 6e 64 20 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f nd /proc/cpuinfo
c720: 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 return all thre
c730: 65 20 76 61 6c 75 65 73 20 61 6e 64 20 74 68 65 e values and the
c740: 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 61 6c 20 number of real
c750: 63 70 75 73 20 61 6e 64 20 74 68 65 20 6e 75 6d cpus and the num
c760: 62 65 72 20 6f 66 20 74 68 72 65 61 64 73 0a 3b ber of threads.;
c770: 3b 20 72 65 74 75 72 6e 73 20 61 6c 69 73 74 20 ; returns alist
c780: 27 28 28 61 64 6a 2d 63 70 75 2d 6c 6f 61 64 20 '((adj-cpu-load
c790: 2e 20 6e 6f 72 6d 61 6c 69 7a 65 64 2d 70 72 6f . normalized-pro
c7a0: 63 2d 6c 6f 61 64 29 20 2e 2e 2e 20 65 74 63 2e c-load) ... etc.
c7b0: 0a 3b 3b 20 20 6b 65 79 73 3a 20 61 64 6a 2d 70 .;; keys: adj-p
c7c0: 72 6f 63 2d 6c 6f 61 64 2c 20 61 64 6a 2d 63 6f roc-load, adj-co
c7d0: 72 65 2d 6c 6f 61 64 2c 20 31 6d 2d 6c 6f 61 64 re-load, 1m-load
c7e0: 2c 20 35 6d 2d 6c 6f 61 64 2c 20 31 35 6d 2d 6c , 5m-load, 15m-l
c7f0: 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 oad.;;.(define (
c800: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 6d 61 common:get-norma
c810: 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 20 72 lized-cpu-load r
c820: 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 20 28 6c emote-host). (l
c830: 65 74 20 28 28 64 61 74 61 20 28 69 66 20 72 65 et ((data (if re
c840: 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 20 20 20 mote-host.
c850: 20 20 20 20 20 20 20 20 20 20 20 20 28 77 69 74 (wit
c860: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 h-input-from-pip
c870: 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e .
c880: 20 20 20 20 20 20 28 63 6f 6e 63 20 22 73 73 68 (conc "ssh
c890: 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 " remote-host "
c8a0: 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 cat /proc/loada
c8b0: 76 67 3b 63 61 74 20 2f 70 72 6f 63 2f 63 70 75 vg;cat /proc/cpu
c8c0: 69 6e 66 6f 3b 65 63 68 6f 20 65 6e 64 22 29 0a info;echo end").
c8d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c8e0: 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 20 read-lines).
c8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c900: 20 28 61 70 70 65 6e 64 20 0a 20 20 20 20 20 20 (append .
c910: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 69 (wi
c920: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 th-input-from-fi
c930: 6c 65 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 le "/proc/loadav
c940: 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 g" .
c950: 20 20 20 20 20 20 20 20 20 72 65 61 64 2d 6c 69 read-li
c960: 6e 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 nes).
c970: 20 20 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e (with-in
c980: 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f put-from-file "/
c990: 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 0a 20 20 proc/cpuinfo".
c9a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9b0: 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 0a 20 read-lines).
c9c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
c9d0: 20 20 28 6c 69 73 74 20 22 65 6e 64 22 29 29 29 (list "end")))
c9e0: 29 0a 20 20 20 20 20 20 20 20 28 6c 6f 61 64 2d ). (load-
c9f0: 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 28 5b rx (regexp "^([
ca00: 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b 5c \\d\\.]+)\\s+([\
ca10: 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b 5c 5c \d\\.]+)\\s+([\\
ca20: 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e 2a 24 22 29 d\\.]+)\\s+.*$")
ca30: 29 0a 20 20 20 20 20 20 20 20 28 70 72 6f 63 2d ). (proc-
ca40: 72 78 20 20 28 72 65 67 65 78 70 20 22 5e 70 72 rx (regexp "^pr
ca50: 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b ocessor\\s+:\\s+
ca60: 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 (\\d+)\\s*$")).
ca70: 20 20 20 20 20 20 20 28 63 6f 72 65 2d 72 78 20 (core-rx
ca80: 20 28 72 65 67 65 78 70 20 22 5e 63 6f 72 65 20 (regexp "^core
ca90: 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b id\\s+:\\s+(\\d+
caa0: 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 20 )\\s*$")).
cab0: 20 20 28 70 68 79 73 2d 72 78 20 20 28 72 65 67 (phys-rx (reg
cac0: 65 78 70 20 22 5e 70 68 79 73 69 63 61 6c 20 69 exp "^physical i
cad0: 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 d\\s+:\\s+(\\d+)
cae0: 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 20 20 \\s*$")).
caf0: 20 28 6d 61 78 2d 6e 75 6d 20 20 28 6c 61 6d 62 (max-num (lamb
cb00: 64 61 20 28 70 20 6e 29 28 6d 61 78 20 28 73 74 da (p n)(max (st
cb10: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 29 20 ring->number p)
cb20: 6e 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 n)))). ;; (pr
cb30: 69 6e 74 20 22 64 61 74 61 3d 22 20 64 61 74 61 int "data=" data
cb40: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
cb50: 20 64 61 74 61 29 20 3b 3b 20 73 6f 6d 65 74 68 data) ;; someth
cb60: 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 0a 20 ing went wrong.
cb70: 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 #f.
cb80: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
cb90: 64 20 20 20 20 20 20 28 63 61 72 20 64 61 74 61 d (car data
cba0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
cbb0: 20 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 20 (tal
cbc0: 28 63 64 72 20 64 61 74 61 29 29 0a 20 20 20 20 (cdr data)).
cbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
cbe0: 6c 6f 61 64 73 20 20 20 20 23 66 29 0a 20 20 20 loads #f).
cbf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc00: 28 70 72 6f 63 2d 6e 75 6d 20 30 29 20 20 3b 3b (proc-num 0) ;;
cc10: 20 70 72 6f 63 65 73 73 6f 72 20 69 6e 63 6c 75 processor inclu
cc20: 64 65 73 20 74 68 72 65 61 64 73 0a 20 20 20 20 des threads.
cc30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
cc40: 70 68 79 73 2d 6e 75 6d 20 30 29 20 20 3b 3b 20 phys-num 0) ;;
cc50: 70 68 79 73 69 63 61 6c 20 63 68 69 70 20 6f 6e physical chip on
cc60: 20 6d 6f 74 68 65 72 62 6f 61 72 64 0a 20 20 20 motherboard.
cc70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc80: 28 63 6f 72 65 2d 6e 75 6d 20 30 29 29 20 3b 3b (core-num 0)) ;;
cc90: 20 63 6f 72 65 0a 20 20 20 20 20 20 20 20 20 20 core.
cca0: 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 20 22 2c ;; (print hed ",
ccb0: 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 20 70 72 " loads ", " pr
ccc0: 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 68 79 73 oc-num ", " phys
ccd0: 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 65 2d 6e -num ", " core-n
cce0: 75 6d 29 0a 20 20 20 20 20 20 20 20 20 20 28 69 um). (i
ccf0: 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 3b 3b f (null? tal) ;;
cd00: 20 68 61 76 65 20 61 6c 6c 20 6f 75 72 20 64 61 have all our da
cd10: 74 61 2c 20 63 61 6c 63 75 6c 61 74 65 20 6e 6f ta, calculate no
cd20: 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 61 6e rmalized load an
cd30: 64 20 72 65 74 75 72 6e 20 72 65 73 75 6c 74 0a d return result.
cd40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
cd50: 65 74 2a 20 28 28 61 63 74 2d 70 72 6f 63 20 28 et* ((act-proc (
cd60: 2b 20 70 72 6f 63 2d 6e 75 6d 20 31 29 29 0a 20 + proc-num 1)).
cd70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cd80: 20 20 20 20 28 61 63 74 2d 70 68 79 73 20 28 2b (act-phys (+
cd90: 20 70 68 79 73 2d 6e 75 6d 20 31 29 29 0a 20 20 phys-num 1)).
cda0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cdb0: 20 20 20 28 61 63 74 2d 63 6f 72 65 20 28 2b 20 (act-core (+
cdc0: 63 6f 72 65 2d 6e 75 6d 20 31 29 29 0a 20 20 20 core-num 1)).
cdd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cde0: 20 20 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 (adj-proc-load
cdf0: 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 20 (/ (car loads)
ce00: 61 63 74 2d 70 72 6f 63 29 29 0a 20 20 20 20 20 act-proc)).
ce10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ce20: 28 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 28 (adj-core-load (
ce30: 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 20 61 63 / (car loads) ac
ce40: 74 2d 63 6f 72 65 29 29 29 0a 20 20 20 20 20 20 t-core))).
ce50: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 65 6e (appen
ce60: 64 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 61 d (list (cons 'a
ce70: 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 61 64 6a dj-proc-load adj
ce80: 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a 20 20 20 20 -proc-load).
ce90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cea0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
ceb0: 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 20 61 'adj-core-load a
cec0: 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 29 29 0a 20 dj-core-load)).
ced0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cee0: 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 63 6f (list (co
cef0: 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 28 63 61 72 ns '1m-load (car
cf00: 20 6c 6f 61 64 73 29 29 0a 20 20 20 20 20 20 20 loads)).
cf10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf20: 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 35 6d (cons '5m
cf30: 2d 6c 6f 61 64 20 28 63 61 64 72 20 6c 6f 61 64 -load (cadr load
cf40: 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 s)).
cf50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cf60: 20 20 28 63 6f 6e 73 20 27 31 35 6d 2d 6c 6f 61 (cons '15m-loa
cf70: 64 20 28 63 61 64 64 72 20 6c 6f 61 64 73 29 29 d (caddr loads))
cf80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
cf90: 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 (list
cfa0: 28 63 6f 6e 73 20 27 70 72 6f 63 20 61 63 74 2d (cons 'proc act-
cfb0: 70 72 6f 63 29 0a 20 20 20 20 20 20 20 20 20 20 proc).
cfc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cfd0: 20 20 20 20 28 63 6f 6e 73 20 27 63 6f 72 65 20 (cons 'core
cfe0: 61 63 74 2d 63 6f 72 65 29 0a 20 20 20 20 20 20 act-core).
cff0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d000: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 70 (cons 'p
d010: 68 79 73 20 61 63 74 2d 70 68 79 73 29 29 29 29 hys act-phys))))
d020: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
d030: 72 65 67 65 78 2d 63 61 73 65 0a 20 20 20 20 20 regex-case.
d040: 20 20 20 20 20 20 20 20 20 20 68 65 64 0a 20 20 hed.
d050: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f (lo
d060: 61 64 2d 72 78 20 20 28 20 78 20 6c 31 20 6c 35 ad-rx ( x l1 l5
d070: 20 6c 31 35 20 29 20 28 6c 6f 6f 70 20 28 63 61 l15 ) (loop (ca
d080: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 28 r tal)(cdr tal)(
d090: 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 map string->numb
d0a0: 65 72 20 28 6c 69 73 74 20 6c 31 20 6c 35 20 6c er (list l1 l5 l
d0b0: 31 35 29 29 20 70 72 6f 63 2d 6e 75 6d 20 70 68 15)) proc-num ph
d0c0: 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 ys-num core-num)
d0d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d0e0: 20 28 70 72 6f 63 2d 72 78 20 20 28 20 78 20 70 (proc-rx ( x p
d0f0: 20 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 ) (loop
d100: 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
d110: 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 20 al) loads
d120: 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 70 20 70 (max-num p p
d130: 72 6f 63 2d 6e 75 6d 29 20 70 68 79 73 2d 6e 75 roc-num) phys-nu
d140: 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 m core-num)).
d150: 20 20 20 20 20 20 20 20 20 20 20 20 28 70 68 79 (phy
d160: 73 2d 72 78 20 20 28 20 78 20 70 20 20 20 20 20 s-rx ( x p
d170: 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 ) (loop (car
d180: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c tal)(cdr tal) l
d190: 6f 61 64 73 20 20 20 20 20 20 20 20 20 20 20 70 oads p
d1a0: 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d 6e 75 6d roc-num (max-num
d1b0: 20 70 20 70 68 79 73 2d 6e 75 6d 29 20 63 6f 72 p phys-num) cor
d1c0: 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 20 20 20 e-num)).
d1d0: 20 20 20 20 20 20 20 28 63 6f 72 65 2d 72 78 20 (core-rx
d1e0: 20 28 20 78 20 63 20 20 20 20 20 20 20 20 20 29 ( x c )
d1f0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
d200: 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 (cdr tal) loads
d210: 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 2d 6e proc-n
d220: 75 6d 20 70 68 79 73 2d 6e 75 6d 20 28 6d 61 78 um phys-num (max
d230: 2d 6e 75 6d 20 63 20 63 6f 72 65 2d 6e 75 6d 29 -num c core-num)
d240: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d250: 20 20 28 65 6c 73 65 20 0a 20 20 20 20 20 20 20 (else .
d260: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
d270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d280: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4e 4f 20 ;; (print "NO
d290: 4d 41 54 43 48 3a 20 22 20 68 65 64 29 0a 20 20 MATCH: " hed).
d2a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d2b0: 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
d2c0: 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 70 cdr tal) loads p
d2d0: 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d roc-num phys-num
d2e0: 20 63 6f 72 65 2d 6e 75 6d 29 29 29 29 29 29 29 core-num)))))))
d2f0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
d300: 6d 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 20 68 6f mon:unix-ping ho
d310: 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 28 stname). (let (
d320: 28 72 65 73 20 28 73 79 73 74 65 6d 20 28 63 6f (res (system (co
d330: 6e 63 20 22 70 69 6e 67 20 2d 63 20 31 20 22 20 nc "ping -c 1 "
d340: 68 6f 73 74 6e 61 6d 65 20 22 20 3e 20 2f 64 65 hostname " > /de
d350: 76 2f 6e 75 6c 6c 22 29 29 29 29 0a 20 20 20 20 v/null")))).
d360: 28 65 71 3f 20 72 65 73 20 30 29 29 29 0a 0a 3b (eq? res 0)))..;
d370: 3b 20 69 64 65 61 6c 6c 79 20 70 75 74 20 61 6c ; ideally put al
d380: 6c 20 74 68 69 73 20 69 6e 66 6f 20 69 6e 74 6f l this info into
d390: 20 74 68 65 20 64 62 2c 20 6e 6f 20 6e 65 65 64 the db, no need
d3a0: 20 74 6f 20 70 72 65 73 65 72 76 65 20 69 74 20 to preserve it
d3b0: 61 63 72 6f 73 73 20 6d 6f 76 69 6e 67 20 68 6f across moving ho
d3c0: 6d 65 68 6f 73 74 0a 3b 3b 0a 3b 3b 20 72 65 74 mehost.;;.;; ret
d3d0: 75 72 6e 20 6c 69 73 74 20 6f 66 0a 3b 3b 20 20 urn list of.;;
d3e0: 28 20 72 65 61 63 68 61 62 6c 65 3f 20 63 70 75 ( reachable? cpu
d3f0: 6c 6f 61 64 20 75 70 64 61 74 65 2d 74 69 6d 65 load update-time
d400: 20 29 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ).(define (comm
d410: 6f 6e 3a 67 65 74 2d 68 6f 73 74 2d 69 6e 66 6f on:get-host-info
d420: 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 hostname). (le
d430: 74 2a 20 28 28 6c 6f 61 64 69 6e 66 6f 20 28 72 t* ((loadinfo (r
d440: 6d 74 3a 67 65 74 2d 6c 61 74 65 73 74 2d 68 6f mt:get-latest-ho
d450: 73 74 2d 6c 6f 61 64 20 68 6f 73 74 6e 61 6d 65 st-load hostname
d460: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 )). (loa
d470: 64 20 28 63 61 72 20 6c 6f 61 64 69 6e 66 6f 29 d (car loadinfo)
d480: 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 ). (load
d490: 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 20 28 63 64 -sample-time (cd
d4a0: 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a 20 20 20 r loadinfo)).
d4b0: 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 61 6d 70 (load-samp
d4c0: 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 72 72 65 le-age (- (curre
d4d0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 6f 61 64 nt-seconds) load
d4e0: 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 29 29 0a 20 -sample-time)).
d4f0: 20 20 20 20 20 20 20 20 28 6c 6f 61 64 69 6e 66 (loadinf
d500: 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 o-timeout-second
d510: 73 20 32 30 29 0a 20 20 20 20 20 20 20 20 20 28 s 20). (
d520: 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 host-last-update
d530: 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 73 -timeout-seconds
d540: 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 28 68 10). (h
d550: 6f 73 74 2d 72 65 63 20 28 68 61 73 68 2d 74 61 ost-rec (hash-ta
d560: 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
d570: 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 *host-loads* hos
d580: 74 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 20 20 tname #f)).
d590: 20 20 20 20 29 0a 20 20 20 20 28 63 6f 6e 64 0a ). (cond.
d5a0: 20 20 20 20 20 28 28 3c 20 6c 6f 61 64 2d 73 61 ((< load-sa
d5b0: 6d 70 6c 65 2d 61 67 65 20 6c 6f 61 64 69 6e 66 mple-age loadinf
d5c0: 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e 64 o-timeout-second
d5d0: 73 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 23 s). (list #
d5e0: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f t. lo
d5f0: 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 0a 20 ad-sample-time.
d600: 20 20 20 20 20 20 20 20 20 20 20 6c 6f 61 64 29 load)
d610: 29 0a 20 20 20 20 20 28 28 61 6e 64 20 68 6f 73 ). ((and hos
d620: 74 2d 72 65 63 0a 20 20 20 20 20 20 20 20 20 20 t-rec.
d630: 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (< (current-sec
d640: 6f 6e 64 73 29 20 28 2b 20 28 68 6f 73 74 2d 6c onds) (+ (host-l
d650: 61 73 74 2d 75 70 64 61 74 65 20 68 6f 73 74 2d ast-update host-
d660: 72 65 63 29 20 68 6f 73 74 2d 6c 61 73 74 2d 75 rec) host-last-u
d670: 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 2d 73 65 pdate-timeout-se
d680: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 20 28 conds))). (
d690: 6c 69 73 74 20 23 74 0a 20 20 20 20 20 20 20 20 list #t.
d6a0: 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 (host-last-u
d6b0: 70 64 61 74 65 20 68 6f 73 74 2d 72 65 63 29 0a pdate host-rec).
d6c0: 20 20 20 20 20 20 20 20 20 20 20 20 28 68 6f 73 (hos
d6d0: 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 64 20 68 t-last-cpuload h
d6e0: 6f 73 74 2d 72 65 63 20 29 29 29 0a 20 20 20 20 ost-rec ))).
d6f0: 20 28 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 ((common:unix-p
d700: 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 ing hostname).
d710: 20 20 20 20 28 6c 69 73 74 20 23 74 0a 20 20 20 (list #t.
d720: 20 20 20 20 20 20 20 20 20 28 63 75 72 72 65 6e (curren
d730: 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 20 20 t-seconds).
d740: 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d 72 65 (alist-re
d750: 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 f 'adj-core-load
d760: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 (common:get-nor
d770: 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
d780: 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a 20 20 hostname)))).
d790: 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 20 28 (else. (
d7a0: 6c 69 73 74 20 23 66 20 30 20 2d 31 29 29 29 29 list #f 0 -1))))
d7b0: 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 ). .(define (
d7c0: 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f common:update-ho
d7d0: 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 st-loads-table h
d7e0: 6f 73 74 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 osts-raw). (let
d7f0: 2a 20 28 28 68 6f 73 74 73 20 28 66 69 6c 74 65 * ((hosts (filte
d800: 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 r (lambda (x).
d810: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d820: 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d (string-
d830: 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 22 5e match (regexp "^
d840: 5c 5c 53 2b 24 22 29 20 78 29 29 0a 20 20 20 20 \\S+$") x)).
d850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d860: 20 20 20 20 68 6f 73 74 73 2d 72 61 77 29 29 29 hosts-raw)))
d870: 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 . (for-each.
d880: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 6f 73 (lambda (hos
d890: 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 6c tname). (l
d8a0: 65 74 2a 20 28 28 72 65 63 20 20 20 20 20 20 20 et* ((rec
d8b0: 28 6c 65 74 20 28 28 68 20 28 68 61 73 68 2d 74 (let ((h (hash-t
d8c0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
d8d0: 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f *host-loads* ho
d8e0: 73 74 6e 61 6d 65 20 23 66 29 29 29 0a 20 20 20 stname #f))).
d8f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d900: 20 20 20 20 20 20 20 28 69 66 20 68 0a 20 20 20 (if h.
d910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d920: 20 20 20 20 20 20 20 20 20 20 20 68 0a 20 20 20 h.
d930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d940: 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 (let
d950: 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 29 29 ((h (make-host))
d960: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d980: 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
d990: 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 t! *host-loads*
d9a0: 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 20 20 20 hostname h).
d9b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d9c0: 20 20 20 20 20 20 20 20 20 20 20 20 68 29 29 29 h)))
d9d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d9e0: 28 68 6f 73 74 2d 69 6e 66 6f 20 20 20 20 20 20 (host-info
d9f0: 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 (common:get-h
da00: 6f 73 74 2d 69 6e 66 6f 20 68 6f 73 74 6e 61 6d ost-info hostnam
da10: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
da20: 20 20 28 69 73 2d 72 65 61 63 68 61 62 6c 65 20 (is-reachable
da30: 20 20 20 20 20 28 63 61 72 20 68 6f 73 74 2d 69 (car host-i
da40: 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 20 20 nfo)).
da50: 20 20 20 20 28 6c 61 73 74 2d 72 65 61 63 68 65 (last-reache
da60: 64 2d 74 69 6d 65 20 28 63 61 64 72 20 68 6f 73 d-time (cadr hos
da70: 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 t-info)).
da80: 20 20 20 20 20 20 20 28 6c 6f 61 64 20 20 20 20 (load
da90: 20 20 20 20 20 20 20 20 20 20 28 63 61 64 64 72 (caddr
daa0: 20 68 6f 73 74 2d 69 6e 66 6f 29 29 29 0a 20 20 host-info))).
dab0: 20 20 20 20 20 20 20 28 68 6f 73 74 2d 72 65 61 (host-rea
dac0: 63 68 61 62 6c 65 2d 73 65 74 21 20 20 20 20 72 chable-set! r
dad0: 65 63 20 69 73 2d 72 65 61 63 68 61 62 6c 65 29 ec is-reachable)
dae0: 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d . (host-
daf0: 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 65 74 21 last-update-set!
db00: 20 20 72 65 63 20 6c 61 73 74 2d 72 65 61 63 68 rec last-reach
db10: 65 64 2d 74 69 6d 65 29 0a 20 20 20 20 20 20 20 ed-time).
db20: 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 (host-last-cpu
db30: 6c 6f 61 64 2d 73 65 74 21 20 72 65 63 20 6c 6f load-set! rec lo
db40: 61 64 29 29 29 0a 20 20 20 20 20 68 6f 73 74 73 ad))). hosts
db50: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
db60: 6d 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 74 2d 6c mmon:get-least-l
db70: 6f 61 64 65 64 2d 68 6f 73 74 20 68 6f 73 74 73 oaded-host hosts
db80: 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a 20 28 28 -raw). (let* ((
db90: 68 6f 73 74 73 20 28 66 69 6c 74 65 72 20 28 6c hosts (filter (l
dba0: 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 20 20 ambda (x).
dbb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dbc0: 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 (string-matc
dbd0: 68 20 28 72 65 67 65 78 70 20 22 5e 5c 5c 53 2b h (regexp "^\\S+
dbe0: 24 22 29 20 78 29 29 0a 20 20 20 20 20 20 20 20 $") x)).
dbf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dc00: 68 6f 73 74 73 2d 72 61 77 29 29 0a 20 20 20 20 hosts-raw)).
dc10: 20 20 20 20 20 28 62 65 73 74 2d 68 6f 73 74 20 (best-host
dc20: 23 66 29 0a 20 20 20 20 20 20 20 20 20 28 62 65 #f). (be
dc30: 73 74 2d 6c 6f 61 64 20 39 39 39 39 39 29 0a 20 st-load 99999).
dc40: 20 20 20 20 20 20 20 20 28 63 75 72 72 2d 74 69 (curr-ti
dc50: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
dc60: 6e 64 73 29 29 29 0a 20 20 20 20 28 63 6f 6d 6d nds))). (comm
dc70: 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 74 2d 6c on:update-host-l
dc80: 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f 73 74 73 oads-table hosts
dc90: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a ). (for-each.
dca0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 6f (lambda (ho
dcb0: 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 28 stname). (
dcc0: 6c 65 74 2a 20 28 28 72 65 63 0a 20 20 20 20 20 let* ((rec.
dcd0: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
dce0: 28 68 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 (h (hash-table-r
dcf0: 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 6f 73 74 ef/default *host
dd00: 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 -loads* hostname
dd10: 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 20 20 #f))).
dd20: 20 20 20 20 20 20 20 20 28 69 66 20 68 0a 20 20 (if h.
dd30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd40: 20 20 20 68 0a 20 20 20 20 20 20 20 20 20 20 20 h.
dd50: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
dd60: 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 29 29 29 (h (make-host)))
dd70: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
dd80: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
dd90: 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 74 2d 6c ble-set! *host-l
dda0: 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 68 oads* hostname h
ddb0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
ddc0: 20 20 20 20 20 20 20 20 20 68 29 29 29 29 0a 20 h)))).
ddd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 65 (re
dde0: 61 63 68 61 62 6c 65 20 28 68 6f 73 74 2d 72 65 achable (host-re
ddf0: 61 63 68 61 62 6c 65 20 72 65 63 29 29 0a 20 20 achable rec)).
de00: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f 61 (loa
de10: 64 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 d (host-las
de20: 74 2d 63 70 75 6c 6f 61 64 20 20 20 72 65 63 29 t-cpuload rec)
de30: 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 6f 6e )). (con
de40: 64 0a 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f d. ((no
de50: 74 20 72 65 61 63 68 61 62 6c 65 29 20 23 66 29 t reachable) #f)
de60: 0a 20 20 20 20 20 20 20 20 20 20 28 28 3c 20 28 . ((< (
de70: 2b 20 6c 6f 61 64 20 28 2f 20 28 72 61 6e 64 6f + load (/ (rando
de80: 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 20 20 m 250) 1000))
de90: 20 20 20 20 20 20 3b 3b 20 61 64 64 20 61 20 72 ;; add a r
dea0: 61 6e 64 6f 6d 20 66 61 63 74 6f 72 20 74 6f 20 andom factor to
deb0: 6b 65 65 70 20 66 72 6f 6d 20 67 65 74 74 69 6e keep from gettin
dec0: 67 20 69 6e 20 61 20 72 75 74 0a 20 20 20 20 20 g in a rut.
ded0: 20 20 20 20 20 20 20 20 20 28 2b 20 62 65 73 74 (+ best
dee0: 2d 6c 6f 61 64 20 28 2f 20 28 72 61 6e 64 6f 6d -load (/ (random
def0: 20 32 35 30 29 20 31 30 30 30 29 29 20 20 29 0a 250) 1000)) ).
df00: 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 21 (set!
df10: 20 62 65 73 74 2d 6c 6f 61 64 20 6c 6f 61 64 29 best-load load)
df20: 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 74 . (set
df30: 21 20 62 65 73 74 2d 68 6f 73 74 20 68 6f 73 74 ! best-host host
df40: 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 20 68 name))))). h
df50: 6f 73 74 73 29 0a 20 20 20 20 62 65 73 74 2d 68 osts). best-h
df60: 6f 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ost))..(define (
df70: 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d common:wait-for-
df80: 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 cpuload maxload
df90: 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 6c 61 numcpus waitdela
dfa0: 79 20 23 21 6b 65 79 20 28 63 6f 75 6e 74 20 31 y #!key (count 1
dfb0: 30 30 30 29 20 28 6d 73 67 20 23 66 29 28 72 65 000) (msg #f)(re
dfc0: 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 0a 20 mote-host #f)).
dfd0: 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 61 76 67 (let* ((loadavg
dfe0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 (common:get-cpu
dff0: 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 -load remote-hos
e000: 74 29 29 0a 09 20 28 66 69 72 73 74 20 20 20 28 t)).. (first (
e010: 63 61 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 car loadavg))..
e020: 28 6e 65 78 74 20 20 20 20 28 63 61 64 72 20 6c (next (cadr l
e030: 6f 61 64 61 76 67 29 29 0a 09 20 28 61 64 6a 6c oadavg)).. (adjl
e040: 6f 61 64 20 28 2a 20 6d 61 78 6c 6f 61 64 20 6e oad (* maxload n
e050: 75 6d 63 70 75 73 29 29 0a 09 20 28 6c 6f 61 64 umcpus)).. (load
e060: 6a 6d 70 20 28 2d 20 66 69 72 73 74 20 6e 65 78 jmp (- first nex
e070: 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 0a 20 t))). (cond.
e080: 20 20 20 20 28 28 61 6e 64 20 28 3e 20 66 69 72 ((and (> fir
e090: 73 74 20 61 64 6a 6c 6f 61 64 29 0a 09 20 20 20 st adjload)..
e0a0: 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 (> count 0)).
e0b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
e0c0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
e0d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 log-port* "waiti
e0e0: 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 20 22 ng " waitdelay "
e0f0: 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 seconds due to
e100: 6c 6f 61 64 20 22 20 66 69 72 73 74 20 22 20 65 load " first " e
e110: 78 63 65 65 64 69 6e 67 20 6d 61 78 20 6f 66 20 xceeding max of
e120: 22 20 61 64 6a 6c 6f 61 64 20 22 20 22 20 28 69 " adjload " " (i
e130: 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 0a 20 f msg msg "")).
e140: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c 65 (thread-sle
e150: 65 70 21 20 77 61 69 74 64 65 6c 61 79 29 0a 20 ep! waitdelay).
e160: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 (common:wai
e170: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
e180: 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 xload numcpus wa
e190: 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 3a 20 28 itdelay count: (
e1a0: 2d 20 63 6f 75 6e 74 20 31 29 29 29 0a 20 20 20 - count 1))).
e1b0: 20 20 28 28 61 6e 64 20 28 3e 20 6c 6f 61 64 6a ((and (> loadj
e1c0: 6d 70 20 6e 75 6d 63 70 75 73 29 0a 09 20 20 20 mp numcpus)..
e1d0: 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 20 20 (> count 0)).
e1e0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
e1f0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
e200: 6c 6f 67 2d 70 6f 72 74 2a 20 22 77 61 69 74 69 log-port* "waiti
e210: 6e 67 20 22 20 77 61 69 74 64 65 6c 61 79 20 22 ng " waitdelay "
e220: 20 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 seconds due to
e230: 6c 6f 61 64 20 6a 75 6d 70 20 22 20 6c 6f 61 64 load jump " load
e240: 6a 6d 70 20 22 20 3e 20 6e 75 6d 63 70 75 73 20 jmp " > numcpus
e250: 22 20 6e 75 6d 63 70 75 73 20 28 69 66 20 6d 73 " numcpus (if ms
e260: 67 20 6d 73 67 20 22 22 29 29 0a 20 20 20 20 20 g msg "")).
e270: 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
e280: 77 61 69 74 64 65 6c 61 79 29 0a 20 20 20 20 20 waitdelay).
e290: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
e2a0: 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 r-cpuload maxloa
e2b0: 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 d numcpus waitde
e2c0: 6c 61 79 20 63 6f 75 6e 74 3a 20 28 2d 20 63 6f lay count: (- co
e2d0: 75 6e 74 20 31 29 29 29 29 29 29 0a 0a 28 64 65 unt 1))))))..(de
e2e0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 fine (common:wai
e2f0: 74 2d 66 6f 72 2d 68 6f 6d 65 68 6f 73 74 2d 6c t-for-homehost-l
e300: 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6d 73 67 29 oad maxload msg)
e310: 0a 20 20 28 6c 65 74 2a 20 28 28 68 68 2d 64 61 . (let* ((hh-da
e320: 74 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e t (if (common:on
e330: 2d 68 6f 6d 65 68 6f 73 74 3f 29 20 3b 3b 20 69 -homehost?) ;; i
e340: 66 20 77 65 20 61 72 65 20 6f 6e 20 74 68 65 20 f we are on the
e350: 68 6f 6d 65 68 6f 73 74 20 74 68 65 6e 20 70 61 homehost then pa
e360: 73 73 20 69 6e 20 23 66 20 73 6f 20 74 68 65 20 ss in #f so the
e370: 63 61 6c 6c 73 20 61 72 65 20 6c 6f 63 61 6c 2e calls are local.
e380: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
e390: 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 20 #f.
e3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
e3b0: 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f ommon:get-homeho
e3c0: 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 st))). (
e3d0: 68 68 20 20 20 20 20 28 69 66 20 68 68 2d 64 61 hh (if hh-da
e3e0: 74 20 28 63 61 72 20 68 68 2d 64 61 74 29 20 23 t (car hh-dat) #
e3f0: 66 29 29 0a 20 20 20 20 20 20 20 20 20 28 6e 75 f)). (nu
e400: 6d 63 70 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 mcpus (common:ge
e410: 74 2d 6e 75 6d 2d 63 70 75 73 20 68 68 29 29 29 t-num-cpus hh)))
e420: 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 . (common:wai
e430: 74 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 t-for-normalized
e440: 2d 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6d 73 -load maxload ms
e450: 67 3a 20 6d 73 67 20 72 65 6d 6f 74 65 2d 68 6f g: msg remote-ho
e460: 73 74 3a 20 68 68 29 29 29 0a 0a 28 64 65 66 69 st: hh)))..(defi
e470: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e ne (common:get-n
e480: 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 um-cpus remote-h
e490: 6f 73 74 29 0a 20 20 28 6c 65 74 20 28 28 70 72 ost). (let ((pr
e4a0: 6f 63 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 oc (lambda ()...
e4b0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6e 75 6d 63 (let loop ((numc
e4c0: 70 75 20 30 29 0a 09 09 09 20 20 20 28 69 6e 6c pu 0).... (inl
e4d0: 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 (read-line))
e4e0: 29 0a 09 09 20 20 28 69 66 20 28 65 6f 66 2d 6f )... (if (eof-o
e4f0: 62 6a 65 63 74 3f 20 69 6e 6c 29 0a 09 09 20 20 bject? inl)...
e500: 20 20 20 20 6e 75 6d 63 70 75 0a 09 09 20 20 20 numcpu...
e510: 20 20 20 28 6c 6f 6f 70 20 28 69 66 20 28 73 74 (loop (if (st
e520: 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e 70 72 6f ring-match "^pro
e530: 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c 73 2b 5c cessor\\s+:\\s+\
e540: 5c 64 2b 24 22 20 69 6e 6c 29 0a 09 09 09 09 28 \d+$" inl).....(
e550: 2b 20 6e 75 6d 63 70 75 20 31 29 0a 09 09 09 09 + numcpu 1).....
e560: 6e 75 6d 63 70 75 29 0a 09 09 09 20 20 20 20 28 numcpu).... (
e570: 72 65 61 64 2d 6c 69 6e 65 29 29 29 29 29 29 29 read-line)))))))
e580: 0a 20 20 20 20 28 69 66 20 72 65 6d 6f 74 65 2d . (if remote-
e590: 68 6f 73 74 0a 09 28 77 69 74 68 2d 69 6e 70 75 host..(with-inpu
e5a0: 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 09 20 28 t-from-pipe .. (
e5b0: 63 6f 6e 63 20 22 73 73 68 20 22 20 72 65 6d 6f conc "ssh " remo
e5c0: 74 65 2d 68 6f 73 74 20 22 20 63 61 74 20 2f 70 te-host " cat /p
e5d0: 72 6f 63 2f 63 70 75 69 6e 66 6f 22 29 0a 09 20 roc/cpuinfo")..
e5e0: 70 72 6f 63 29 0a 09 28 77 69 74 68 2d 69 6e 70 proc)..(with-inp
e5f0: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 ut-from-file "/p
e600: 72 6f 63 2f 63 70 75 69 6e 66 6f 22 20 70 72 6f roc/cpuinfo" pro
e610: 63 29 29 29 29 0a 0a 3b 3b 20 77 61 69 74 20 66 c))))..;; wait f
e620: 6f 72 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 or normalized cp
e630: 75 20 6c 6f 61 64 20 74 6f 20 64 72 6f 70 20 62 u load to drop b
e640: 65 6c 6f 77 20 6d 61 78 6c 6f 61 64 0a 3b 3b 0a elow maxload.;;.
e650: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
e660: 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 6d 61 6c 69 wait-for-normali
e670: 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 zed-load maxload
e680: 20 23 21 6b 65 79 20 28 6d 73 67 20 23 66 29 28 #!key (msg #f)(
e690: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 remote-host #f))
e6a0: 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 2d 63 70 . (let ((num-cp
e6b0: 75 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e us (common:get-n
e6c0: 75 6d 2d 63 70 75 73 20 72 65 6d 6f 74 65 2d 68 um-cpus remote-h
e6d0: 6f 73 74 29 29 29 0a 20 20 20 20 28 63 6f 6d 6d ost))). (comm
e6e0: 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c on:wait-for-cpul
e6f0: 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 2d oad maxload num-
e700: 63 70 75 73 20 31 35 20 6d 73 67 3a 20 6d 73 67 cpus 15 msg: msg
e710: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 3a 20 72 65 remote-host: re
e720: 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 0a 28 64 mote-host)))..(d
e730: 65 66 69 6e 65 20 28 67 65 74 2d 75 6e 61 6d 65 efine (get-uname
e740: 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 28 6c 65 . params). (le
e750: 74 2a 20 28 28 75 6e 61 6d 65 2d 72 65 73 20 28 t* ((uname-res (
e760: 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d process:cmd-run-
e770: 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 6e 61 >list (conc "una
e780: 6d 65 20 22 20 28 69 66 20 28 6e 75 6c 6c 3f 20 me " (if (null?
e790: 70 61 72 61 6d 73 29 20 22 2d 61 22 20 28 63 61 params) "-a" (ca
e7a0: 72 20 70 61 72 61 6d 73 29 29 29 29 29 0a 09 20 r params)))))..
e7b0: 28 75 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 20 (uname #f)).
e7c0: 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 61 72 20 (if (null? (car
e7d0: 75 6e 61 6d 65 2d 72 65 73 29 29 0a 09 22 75 6e uname-res)).."un
e7e0: 6b 6e 6f 77 6e 22 0a 09 28 63 61 61 72 20 75 6e known"..(caar un
e7f0: 61 6d 65 2d 72 65 73 29 29 29 29 0a 0a 3b 3b 20 ame-res))))..;;
e800: 66 6f 72 20 72 65 61 73 6f 6e 73 20 49 20 64 6f for reasons I do
e810: 6e 27 74 20 75 6e 64 65 72 73 74 61 6e 64 20 6d n't understand m
e820: 75 6c 74 69 70 6c 65 20 63 61 6c 6c 73 20 74 6f ultiple calls to
e830: 20 72 65 61 6c 2d 70 61 74 68 20 69 6e 20 70 61 real-path in pa
e840: 72 61 6c 6c 65 6c 20 74 68 72 65 61 64 73 0a 3b rallel threads.;
e850: 3b 20 6d 75 73 74 20 62 65 20 70 72 6f 74 65 63 ; must be protec
e860: 74 65 64 20 62 79 20 6d 75 74 65 78 65 73 0a 3b ted by mutexes.;
e870: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
e880: 6e 3a 72 65 61 6c 2d 70 61 74 68 20 69 6e 70 61 n:real-path inpa
e890: 74 68 29 0a 20 20 3b 3b 20 28 70 72 6f 63 65 73 th). ;; (proces
e8a0: 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 68 2d 73 s:cmd-run-with-s
e8b0: 74 64 65 72 72 2d 3e 6c 69 73 74 20 22 72 65 61 tderr->list "rea
e8c0: 64 6c 69 6e 6b 22 20 22 2d 66 22 20 69 6e 70 61 dlink" "-f" inpa
e8d0: 74 68 29 29 20 3b 3b 20 63 6d 64 20 2e 20 70 61 th)) ;; cmd . pa
e8e0: 72 61 6d 73 29 0a 20 20 3b 3b 20 28 6c 65 74 2d rams). ;; (let-
e8f0: 76 61 6c 75 65 73 20 0a 20 20 3b 3b 20 20 28 28 values . ;; ((
e900: 28 69 6e 70 20 6f 75 70 20 70 69 64 29 20 28 70 (inp oup pid) (p
e910: 72 6f 63 65 73 73 20 22 72 65 61 64 6c 69 6e 6b rocess "readlink
e920: 22 20 28 6c 69 73 74 20 22 2d 66 22 20 69 6e 70 " (list "-f" inp
e930: 61 74 68 29 29 29 29 0a 20 20 3b 3b 20 20 28 77 ath)))). ;; (w
e940: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
e950: 6f 72 74 20 69 6e 70 0a 20 20 3b 3b 20 20 20 20 ort inp. ;;
e960: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 (let loop ((inl
e970: 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 20 20 3b (read-line)). ;
e980: 3b 20 20 20 20 20 20 20 09 28 72 65 73 20 23 66 ; .(res #f
e990: 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 28 70 72 )). ;; (pr
e9a0: 69 6e 74 20 22 69 6e 6c 3d 22 20 69 6e 6c 29 0a int "inl=" inl).
e9b0: 20 20 3b 3b 20 20 20 20 20 20 28 69 66 20 28 65 ;; (if (e
e9c0: 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a of-object? inl).
e9d0: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 62 ;; (b
e9e0: 65 67 69 6e 0a 20 20 3b 3b 20 20 20 20 20 20 20 egin. ;;
e9f0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 (close-inpu
ea00: 74 2d 70 6f 72 74 20 69 6e 70 29 0a 20 20 3b 3b t-port inp). ;;
ea10: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f (clo
ea20: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 6f se-output-port o
ea30: 75 70 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 up). ;;
ea40: 20 20 20 20 3b 3b 20 28 70 72 6f 63 65 73 73 2d ;; (process-
ea50: 77 61 69 74 20 70 69 64 29 0a 20 20 3b 3b 20 20 wait pid). ;;
ea60: 20 20 20 20 20 20 20 20 20 20 72 65 73 29 0a 20 res).
ea70: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 28 6c 6f ;; (lo
ea80: 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 20 69 op (read-line) i
ea90: 6e 6c 29 29 29 29 29 29 0a 20 20 28 77 69 74 68 nl)))))). (with
eaa0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
eab0: 20 28 63 6f 6e 63 20 22 72 65 61 64 6c 69 6e 6b (conc "readlink
eac0: 20 2d 66 20 22 20 69 6e 70 61 74 68 29 20 72 65 -f " inpath) re
ead0: 61 64 2d 6c 69 6e 65 29 29 0a 0a 3b 3b 3d 3d 3d ad-line))..;;===
eae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eaf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb20: 3d 3d 3d 0a 3b 3b 20 44 20 49 20 53 20 4b 20 20 ===.;; D I S K
eb30: 20 53 20 50 20 41 20 43 20 45 20 0a 3b 3b 3d 3d S P A C E .;;==
eb40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
eb80: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 63 ====..(define (c
eb90: 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 6b 2d 73 ommon:get-disk-s
eba0: 70 61 63 65 2d 75 73 65 64 20 66 70 61 74 68 29 pace-used fpath)
ebb0: 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 . (with-input-f
ebc0: 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 rom-pipe (conc "
ebd0: 2f 75 73 72 2f 62 69 6e 2f 64 75 20 2d 73 20 22 /usr/bin/du -s "
ebe0: 20 66 70 61 74 68 29 20 72 65 61 64 29 29 0a 0a fpath) read))..
ebf0: 3b 3b 20 67 69 76 65 6e 20 70 61 74 68 20 67 65 ;; given path ge
ec00: 74 20 66 72 65 65 20 73 70 61 63 65 2c 20 61 6c t free space, al
ec10: 6c 6f 77 73 20 6f 76 65 72 72 69 64 65 20 69 6e lows override in
ec20: 20 5b 73 65 74 75 70 5d 0a 3b 3b 20 77 69 74 68 [setup].;; with
ec30: 20 66 72 65 65 2d 73 70 61 63 65 2d 73 63 72 69 free-space-scri
ec40: 70 74 20 2f 70 61 74 68 2f 74 6f 2f 73 6f 6d 65 pt /path/to/some
ec50: 2f 73 63 72 69 70 74 2e 73 68 0a 3b 3b 0a 28 64 /script.sh.;;.(d
ec60: 65 66 69 6e 65 20 28 67 65 74 2d 64 66 20 70 61 efine (get-df pa
ec70: 74 68 29 0a 20 20 28 69 66 20 28 63 6f 6e 66 69 th). (if (confi
ec80: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
ec90: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 66 gdat* "setup" "f
eca0: 72 65 65 2d 73 70 61 63 65 2d 73 63 72 69 70 74 ree-space-script
ecb0: 22 29 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 "). (with-i
ecc0: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a nput-from-pipe .
ecd0: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 28 63 6f (conc (co
ece0: 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f nfigf:lookup *co
ecf0: 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 nfigdat* "setup"
ed00: 20 22 66 72 65 65 2d 73 70 61 63 65 2d 73 63 72 "free-space-scr
ed10: 69 70 74 22 29 20 22 20 22 20 70 61 74 68 29 0a ipt") " " path).
ed20: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
ed30: 29 0a 09 20 28 6c 65 74 20 28 28 72 65 73 20 28 ).. (let ((res (
ed40: 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 20 20 read-line)))..
ed50: 20 28 69 66 20 28 73 74 72 69 6e 67 3f 20 72 65 (if (string? re
ed60: 73 29 0a 09 20 20 20 20 20 20 20 28 73 74 72 69 s).. (stri
ed70: 6e 67 2d 3e 6e 75 6d 62 65 72 20 72 65 73 29 29 ng->number res))
ed80: 29 29 29 0a 20 20 20 20 20 20 28 67 65 74 2d 75 ))). (get-u
ed90: 6e 69 78 2d 64 66 20 70 61 74 68 29 29 29 0a 0a nix-df path)))..
eda0: 28 64 65 66 69 6e 65 20 28 67 65 74 2d 75 6e 69 (define (get-uni
edb0: 78 2d 64 66 20 70 61 74 68 29 0a 20 20 28 6c 65 x-df path). (le
edc0: 74 2a 20 28 28 64 66 2d 72 65 73 75 6c 74 73 20 t* ((df-results
edd0: 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e (process:cmd-run
ede0: 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 64 66 ->list (conc "df
edf0: 20 22 20 70 61 74 68 29 29 29 0a 09 20 28 73 70 " path))).. (sp
ee00: 61 63 65 2d 72 78 20 20 20 28 72 65 67 65 78 70 ace-rx (regexp
ee10: 20 22 28 5b 30 2d 39 5d 2b 29 5c 5c 73 2b 28 5b "([0-9]+)\\s+([
ee20: 30 2d 39 5d 2b 29 25 22 29 29 0a 09 20 28 66 72 0-9]+)%")).. (fr
ee30: 65 65 73 70 63 20 20 20 20 23 66 29 29 0a 20 20 eespc #f)).
ee40: 20 20 3b 3b 20 28 77 72 69 74 65 20 64 66 2d 72 ;; (write df-r
ee50: 65 73 75 6c 74 73 29 0a 20 20 20 20 28 66 6f 72 esults). (for
ee60: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6c -each (lambda (l
ee70: 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 74 63 68 )...(let ((match
ee80: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
ee90: 73 70 61 63 65 2d 72 78 20 6c 29 29 29 0a 09 09 space-rx l)))...
eea0: 20 20 28 69 66 20 6d 61 74 63 68 20 0a 09 09 20 (if match ...
eeb0: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 (let ((newv
eec0: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 al (string->numb
eed0: 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 er (cadr match))
eee0: 29 29 0a 09 09 09 28 69 66 20 28 6e 75 6d 62 65 ))....(if (numbe
eef0: 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 09 20 20 r? newval)....
ef00: 20 20 28 73 65 74 21 20 66 72 65 65 73 70 63 20 (set! freespc
ef10: 6e 65 77 76 61 6c 29 29 29 29 29 29 0a 09 20 20 newval))))))..
ef20: 20 20 20 20 28 63 61 72 20 64 66 2d 72 65 73 75 (car df-resu
ef30: 6c 74 73 29 29 0a 20 20 20 20 66 72 65 65 73 70 lts)). freesp
ef40: 63 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f c))..(define (co
ef50: 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 63 65 mmon:check-space
ef60: 2d 69 6e 2d 64 69 72 20 64 69 72 70 61 74 68 20 -in-dir dirpath
ef70: 72 65 71 75 69 72 65 64 29 0a 20 20 28 6c 65 74 required). (let
ef80: 2a 20 28 28 64 62 73 70 61 63 65 20 20 28 69 66 * ((dbspace (if
ef90: 20 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 72 (directory? dir
efa0: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 28 path)... (
efb0: 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 29 0a get-df dirpath).
efc0: 09 09 20 20 20 20 20 20 20 30 29 29 29 0a 20 20 .. 0))).
efd0: 20 20 28 6c 69 73 74 20 28 3e 20 64 62 73 70 61 (list (> dbspa
efe0: 63 65 20 72 65 71 75 69 72 65 64 29 0a 09 20 20 ce required)..
eff0: 64 62 73 70 61 63 65 0a 09 20 20 72 65 71 75 69 dbspace.. requi
f000: 72 65 64 0a 09 20 20 64 69 72 70 61 74 68 29 29 red.. dirpath))
f010: 29 0a 0a 3b 3b 20 63 68 65 63 6b 20 73 70 61 63 )..;; check spac
f020: 65 20 69 6e 20 64 62 64 69 72 20 61 6e 64 20 69 e in dbdir and i
f030: 6e 20 6d 65 67 61 74 65 73 74 20 64 69 72 0a 3b n megatest dir.;
f040: 3b 20 72 65 74 75 72 6e 73 3a 20 6f 6b 2f 6e 6f ; returns: ok/no
f050: 74 20 64 62 73 70 61 63 65 20 72 65 71 75 69 72 t dbspace requir
f060: 65 64 2d 73 70 61 63 65 0a 3b 3b 0a 28 64 65 66 ed-space.;;.(def
f070: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 ine (common:chec
f080: 6b 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 29 0a k-db-dir-space).
f090: 20 20 28 6c 65 74 2a 20 28 28 72 65 71 75 69 72 (let* ((requir
f0a0: 65 64 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 ed (string->numb
f0b0: 65 72 20 0a 09 09 20 20 20 20 28 6f 72 20 28 63 er ... (or (c
f0c0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
f0d0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
f0e0: 22 20 22 64 62 64 69 72 2d 73 70 61 63 65 2d 72 " "dbdir-space-r
f0f0: 65 71 75 69 72 65 64 22 29 0a 09 09 09 22 31 30 equired")...."10
f100: 30 30 30 30 22 29 29 29 0a 09 20 28 64 62 64 69 0000"))).. (dbdi
f110: 72 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 r (common:get
f120: 2d 64 62 2d 74 6d 70 2d 61 72 65 61 29 29 20 3b -db-tmp-area)) ;
f130: 3b 20 28 64 62 3a 67 65 74 2d 64 62 64 69 72 29 ; (db:get-dbdir)
f140: 29 0a 09 20 28 74 64 62 73 70 61 63 65 20 28 63 ).. (tdbspace (c
f150: 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 63 ommon:check-spac
f160: 65 2d 69 6e 2d 64 69 72 20 64 62 64 69 72 20 72 e-in-dir dbdir r
f170: 65 71 75 69 72 65 64 29 29 0a 09 20 28 6d 64 62 equired)).. (mdb
f180: 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 space (common:ch
f190: 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 72 eck-space-in-dir
f1a0: 20 2a 74 6f 70 70 61 74 68 2a 20 72 65 71 75 69 *toppath* requi
f1b0: 72 65 64 29 29 29 0a 20 20 20 20 28 73 6f 72 74 red))). (sort
f1c0: 20 28 6c 69 73 74 20 74 64 62 73 70 61 63 65 20 (list tdbspace
f1d0: 6d 64 62 73 70 61 63 65 29 20 28 6c 61 6d 62 64 mdbspace) (lambd
f1e0: 61 20 28 61 20 62 29 0a 09 09 09 09 20 20 20 20 a (a b).....
f1f0: 20 28 3c 20 28 63 61 64 72 20 61 29 28 63 61 64 (< (cadr a)(cad
f200: 72 20 62 29 29 29 29 29 29 0a 20 20 20 20 0a 3b r b)))))). .;
f210: 3b 20 63 68 65 63 6b 20 61 76 61 69 6c 61 62 6c ; check availabl
f220: 65 20 73 70 61 63 65 20 69 6e 20 64 62 64 69 72 e space in dbdir
f230: 2c 20 65 78 69 74 20 69 66 20 69 6e 73 75 66 66 , exit if insuff
f240: 69 63 69 65 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e icient.;;.(defin
f250: 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d e (common:check-
f260: 64 62 2d 64 69 72 2d 61 6e 64 2d 65 78 69 74 2d db-dir-and-exit-
f270: 69 66 2d 69 6e 73 75 66 66 69 63 69 65 6e 74 29 if-insufficient)
f280: 0a 20 20 28 6c 65 74 2a 20 28 28 73 70 61 63 65 . (let* ((space
f290: 64 61 74 20 28 63 61 72 20 28 63 6f 6d 6d 6f 6e dat (car (common
f2a0: 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 73 70 :check-db-dir-sp
f2b0: 61 63 65 29 29 29 20 3b 3b 20 6c 6f 6f 6b 20 6f ace))) ;; look o
f2c0: 6e 6c 79 20 61 74 20 77 6f 72 73 74 20 66 6f 72 nly at worst for
f2d0: 20 6e 6f 77 0a 09 20 28 69 73 2d 6f 6b 20 20 20 now.. (is-ok
f2e0: 20 28 63 61 72 20 73 70 61 63 65 64 61 74 29 29 (car spacedat))
f2f0: 0a 09 20 28 64 62 73 70 61 63 65 20 20 28 63 61 .. (dbspace (ca
f300: 64 72 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 dr spacedat))..
f310: 28 72 65 71 75 69 72 65 64 20 28 63 61 64 64 72 (required (caddr
f320: 20 73 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 spacedat)).. (d
f330: 62 64 69 72 20 20 20 20 28 63 61 64 64 64 72 20 bdir (cadddr
f340: 73 70 61 63 65 64 61 74 29 29 29 0a 20 20 20 20 spacedat))).
f350: 28 69 66 20 28 6e 6f 74 20 69 73 2d 6f 6b 29 0a (if (not is-ok).
f360: 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 75 .(begin.. (debu
f370: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
f380: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
f390: 74 2a 20 22 49 6e 73 75 66 66 69 63 69 65 6e 74 t* "Insufficient
f3a0: 20 73 70 61 63 65 20 69 6e 20 22 20 64 62 64 69 space in " dbdi
f3b0: 72 20 22 2c 20 72 65 71 75 69 72 65 20 22 20 72 r ", require " r
f3c0: 65 71 75 69 72 65 64 20 22 2c 20 68 61 76 65 20 equired ", have
f3d0: 22 20 64 62 73 70 61 63 65 20 20 22 2c 20 65 78 " dbspace ", ex
f3e0: 69 74 69 6e 67 20 6e 6f 77 2e 22 29 0a 09 20 20 iting now.")..
f3f0: 28 65 78 69 74 20 31 29 29 29 29 29 0a 20 20 0a (exit 1))))). .
f400: 3b 3b 20 70 61 74 68 73 20 69 73 20 6c 69 73 74 ;; paths is list
f410: 20 6f 66 20 6c 69 73 74 73 20 28 28 6e 61 6d 65 of lists ((name
f420: 20 70 61 74 68 29 20 2e 2e 2e 20 29 0a 3b 3b 0a path) ... ).;;.
f430: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
f440: 67 65 74 2d 64 69 73 6b 2d 77 69 74 68 2d 6d 6f get-disk-with-mo
f450: 73 74 2d 66 72 65 65 2d 73 70 61 63 65 20 64 69 st-free-space di
f460: 73 6b 73 20 6d 69 6e 73 69 7a 65 29 0a 20 20 28 sks minsize). (
f470: 6c 65 74 20 28 28 62 65 73 74 20 20 20 20 20 23 let ((best #
f480: 66 29 0a 09 28 62 65 73 74 73 69 7a 65 20 30 29 f)..(bestsize 0)
f490: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
f4a0: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 64 . (lambda (d
f4b0: 69 73 6b 2d 6e 75 6d 29 0a 20 20 20 20 20 20 20 isk-num).
f4c0: 28 6c 65 74 2a 20 28 28 64 69 72 70 61 74 68 20 (let* ((dirpath
f4d0: 20 20 20 28 63 61 64 72 20 28 61 73 73 6f 63 20 (cadr (assoc
f4e0: 64 69 73 6b 2d 6e 75 6d 20 64 69 73 6b 73 29 29 disk-num disks))
f4f0: 29 0a 09 20 20 20 20 20 20 28 66 72 65 65 73 70 ).. (freesp
f500: 63 20 20 20 20 28 63 6f 6e 64 0a 09 09 09 20 20 c (cond....
f510: 20 28 28 6e 6f 74 20 28 64 69 72 65 63 74 6f 72 ((not (director
f520: 79 3f 20 64 69 72 70 61 74 68 29 29 0a 09 09 09 y? dirpath))....
f530: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
f540: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
f550: 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 61 300 "disks not a
f560: 20 64 69 72 20 22 20 64 69 73 6b 2d 6e 75 6d 29 dir " disk-num)
f570: 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e .....(debug:prin
f580: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
f590: 2d 70 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a -port* "WARNING:
f5a0: 20 64 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d disk " disk-num
f5b0: 20 22 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 " at path \"" d
f5c0: 69 72 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f irpath "\" is no
f5d0: 74 20 61 20 64 69 72 65 63 74 6f 72 79 20 2d 20 t a directory -
f5e0: 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 29 0a ignoring it.")).
f5f0: 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 20 20 ... -1)....
f600: 20 28 28 6e 6f 74 20 28 66 69 6c 65 2d 77 72 69 ((not (file-wri
f610: 74 65 2d 61 63 63 65 73 73 3f 20 64 69 72 70 61 te-access? dirpa
f620: 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 th)).... (if
f630: 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 (common:low-nois
f640: 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 73 e-print 300 "dis
f650: 6b 73 20 6e 6f 74 20 77 72 69 74 65 61 62 6c 65 ks not writeable
f660: 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 " disk-num)....
f670: 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 .(debug:print 0
f680: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
f690: 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 t* "WARNING: dis
f6a0: 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 k " disk-num " a
f6b0: 74 20 70 61 74 68 20 5c 22 22 20 64 69 72 70 61 t path \"" dirpa
f6c0: 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 77 72 th "\" is not wr
f6d0: 69 74 65 61 62 6c 65 20 2d 20 69 67 6e 6f 72 69 iteable - ignori
f6e0: 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 ng it."))....
f6f0: 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 -1).... ((not
f700: 20 28 65 71 3f 20 28 73 74 72 69 6e 67 2d 72 65 (eq? (string-re
f710: 66 20 64 69 72 70 61 74 68 20 30 29 20 23 5c 2f f dirpath 0) #\/
f720: 29 29 0a 09 09 09 20 20 20 20 28 69 66 20 28 63 )).... (if (c
f730: 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d ommon:low-noise-
f740: 70 72 69 6e 74 20 33 30 30 20 22 64 69 73 6b 73 print 300 "disks
f750: 20 6e 6f 74 20 61 20 70 72 6f 70 65 72 20 70 61 not a proper pa
f760: 74 68 20 22 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 th " disk-num)..
f770: 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ...(debug:print
f780: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
f790: 6f 72 74 2a 20 22 57 41 52 4e 49 4e 47 3a 20 64 ort* "WARNING: d
f7a0: 69 73 6b 20 22 20 64 69 73 6b 2d 6e 75 6d 20 22 isk " disk-num "
f7b0: 20 61 74 20 70 61 74 68 20 5c 22 22 20 64 69 72 at path \"" dir
f7c0: 70 61 74 68 20 22 5c 22 20 69 73 20 6e 6f 74 20 path "\" is not
f7d0: 61 20 66 75 6c 6c 79 20 71 75 61 6c 69 66 69 65 a fully qualifie
f7e0: 64 20 70 61 74 68 20 2d 20 69 67 6e 6f 72 69 6e d path - ignorin
f7f0: 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 20 g it."))....
f800: 2d 31 29 0a 09 09 09 20 20 20 28 65 6c 73 65 0a -1).... (else.
f810: 09 09 09 20 20 20 20 28 67 65 74 2d 64 66 20 64 ... (get-df d
f820: 69 72 70 61 74 68 29 29 29 29 29 0a 09 20 28 69 irpath))))).. (i
f830: 66 20 28 3e 20 66 72 65 65 73 70 63 20 62 65 73 f (> freespc bes
f840: 74 73 69 7a 65 29 0a 09 20 20 20 20 20 28 62 65 tsize).. (be
f850: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 73 65 74 gin.. (set
f860: 21 20 62 65 73 74 20 20 20 20 20 28 63 6f 6e 73 ! best (cons
f870: 20 64 69 73 6b 2d 6e 75 6d 20 64 69 72 70 61 74 disk-num dirpat
f880: 68 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 h)).. (set
f890: 21 20 62 65 73 74 73 69 7a 65 20 66 72 65 65 73 ! bestsize frees
f8a0: 70 63 29 29 29 29 29 0a 20 20 20 20 20 28 6d 61 pc))))). (ma
f8b0: 70 20 63 61 72 20 64 69 73 6b 73 29 29 0a 20 20 p car disks)).
f8c0: 20 20 28 69 66 20 28 61 6e 64 20 62 65 73 74 20 (if (and best
f8d0: 28 3e 20 62 65 73 74 73 69 7a 65 20 6d 69 6e 73 (> bestsize mins
f8e0: 69 7a 65 29 29 0a 09 62 65 73 74 0a 09 23 66 29 ize))..best..#f)
f8f0: 29 29 20 3b 3b 20 23 66 20 6d 65 61 6e 73 20 6e )) ;; #f means n
f900: 6f 20 64 69 73 6b 20 63 61 6e 64 69 64 61 74 65 o disk candidate
f910: 20 66 6f 75 6e 64 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d found..;;======
f920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f930: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f940: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f950: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f960: 0a 3b 3b 20 45 20 4e 20 56 20 49 20 52 20 4f 20 .;; E N V I R O
f970: 4e 20 4d 20 45 20 4e 20 54 20 20 20 56 20 41 20 N M E N T V A
f980: 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d R S.;;==========
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f9c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 28 64 65 ============.(de
f9d0: 66 69 6e 65 20 28 62 62 2d 63 68 65 63 6b 2d 70 fine (bb-check-p
f9e0: 61 74 68 20 23 21 6b 65 79 20 28 6d 73 67 20 22 ath #!key (msg "
f9f0: 63 68 65 63 6b 2d 70 61 74 68 3a 20 22 29 29 0a check-path: ")).
fa00: 20 20 28 6c 65 74 20 28 28 70 61 74 68 20 28 6f (let ((path (o
fa10: 72 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 r (get-environme
fa20: 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 50 41 54 nt-variable "PAT
fa30: 48 22 29 20 22 6e 6f 6e 65 22 29 29 29 0a 20 20 H") "none"))).
fa40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
fa50: 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
fa60: 6f 67 2d 70 6f 72 74 2a 20 28 63 6f 6e 63 20 6d og-port* (conc m
fa70: 73 67 22 20 3a 20 24 50 41 54 48 3d 22 70 61 74 sg" : $PATH="pat
fa80: 68 29 29 0a 20 20 20 20 28 69 66 20 28 73 74 72 h)). (if (str
fa90: 69 6e 67 2d 6d 61 74 63 68 20 22 5e 2e 2a 2f 69 ing-match "^.*/i
faa0: 73 6f 65 6e 76 2d 63 6f 72 65 2f 2e 2a 22 20 70 soenv-core/.*" p
fab0: 61 74 68 29 0a 20 20 20 20 20 20 20 20 28 64 65 ath). (de
fac0: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
fad0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
fae0: 6f 72 74 2a 20 28 63 6f 6e 63 20 6d 73 67 22 20 ort* (conc msg"
faf0: 3a 20 21 21 49 53 4f 45 4e 56 20 50 52 45 53 45 : !!ISOENV PRESE
fb00: 4e 54 21 21 22 29 29 20 3b 3b 20 72 65 6d 6f 76 NT!!")) ;; remov
fb10: 65 20 66 6f 72 20 70 72 6f 64 0a 20 20 20 20 20 e for prod.
fb20: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
fb30: 69 6e 66 6f 20 31 20 2a 64 65 66 61 75 6c 74 2d info 1 *default-
fb40: 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 6f 6e 63 20 log-port* (conc
fb50: 6d 73 67 22 20 3a 20 2a 2a 6e 6f 20 69 73 6f 65 msg" : **no isoe
fb60: 6e 76 20 70 72 65 73 65 6e 74 2a 2a 22 29 29 29 nv present**")))
fb70: 29 29 0a 0a 09 20 20 20 20 20 20 0a 28 64 65 66 ))... .(def
fb80: 69 6e 65 20 28 73 61 76 65 2d 65 6e 76 69 72 6f ine (save-enviro
fb90: 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 73 20 66 nment-as-files f
fba0: 6e 61 6d 65 20 23 21 6b 65 79 20 28 69 67 6e 6f name #!key (igno
fbb0: 72 65 76 61 72 73 20 28 6c 69 73 74 20 22 55 53 revars (list "US
fbc0: 45 52 22 20 22 48 4f 4d 45 22 20 22 44 49 53 50 ER" "HOME" "DISP
fbd0: 4c 41 59 22 20 22 4c 53 5f 43 4f 4c 4f 52 53 22 LAY" "LS_COLORS"
fbe0: 20 22 58 4b 45 59 53 59 4d 44 42 22 20 22 45 44 "XKEYSYMDB" "ED
fbf0: 49 54 4f 52 22 20 22 4d 41 4b 45 46 4c 41 47 53 ITOR" "MAKEFLAGS
fc00: 22 20 22 4d 41 4b 45 46 22 20 22 4d 41 4b 45 4f " "MAKEF" "MAKEO
fc10: 56 45 52 52 49 44 45 53 22 29 29 29 0a 20 20 3b VERRIDES"))). ;
fc20: 3b 28 62 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 ;(bb-check-path
fc30: 6d 73 67 3a 20 22 73 61 76 65 2d 65 6e 76 69 72 msg: "save-envir
fc40: 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 6c 65 73 20 onment-as-files
fc50: 65 6e 74 72 79 22 29 0a 20 20 28 6c 65 74 20 28 entry"). (let (
fc60: 28 65 6e 76 76 61 72 73 20 28 67 65 74 2d 65 6e (envvars (get-en
fc70: 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 vironment-variab
fc80: 6c 65 73 29 29 0a 20 20 20 20 20 20 20 20 28 77 les)). (w
fc90: 68 69 74 65 73 70 20 28 72 65 67 65 78 70 20 22 hitesp (regexp "
fca0: 5b 5e 61 2d 7a 41 2d 5a 30 2d 39 5f 5c 5c 2d 3a [^a-zA-Z0-9_\\-:
fcb0: 2c 2e 5c 5c 2f 25 24 5d 22 29 29 0a 09 28 6d 75 ,.\\/%$]"))..(mu
fcc0: 6e 67 65 76 61 6c 20 28 6c 61 6d 62 64 61 20 28 ngeval (lambda (
fcd0: 76 61 6c 29 0a 09 09 20 20 20 20 28 63 6f 6e 64 val)... (cond
fce0: 0a 09 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 ... ((eq? va
fcf0: 6c 20 23 74 29 20 22 22 29 20 3b 3b 20 63 6f 6e l #t) "") ;; con
fd00: 76 65 72 74 20 23 74 20 74 6f 20 65 6d 70 74 79 vert #t to empty
fd10: 20 73 74 72 69 6e 67 0a 09 09 20 20 20 20 20 28 string... (
fd20: 28 65 71 3f 20 76 61 6c 20 23 66 29 20 23 66 29 (eq? val #f) #f)
fd30: 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 66 20 74 ;; convert #f t
fd40: 6f 20 69 74 73 65 6c 66 20 28 73 74 69 6c 6c 20 o itself (still
fd50: 74 68 69 6e 6b 69 6e 67 20 61 62 6f 75 74 20 74 thinking about t
fd60: 68 69 73 20 6f 6e 65 0a 09 09 20 20 20 20 20 28 his one... (
fd70: 65 6c 73 65 20 76 61 6c 29 29 29 29 29 0a 20 20 else val))))).
fd80: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
fd90: 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e 61 o-file (conc fna
fda0: 6d 65 20 22 2e 63 73 68 22 29 0a 20 20 20 20 20 me ".csh").
fdb0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
fdc0: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
fdd0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 61 6c (lambda (keyval
fde0: 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 2a 20 )... (let*
fdf0: 28 28 6b 65 79 20 20 20 28 63 61 72 20 6b 65 79 ((key (car key
fe00: 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 76 val)).... (v
fe10: 61 6c 20 20 20 28 63 64 72 20 6b 65 79 76 61 6c al (cdr keyval
fe20: 29 29 0a 09 09 09 20 20 20 20 20 28 64 65 6c 69 )).... (deli
fe30: 6d 20 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 m (if (string-se
fe40: 61 72 63 68 20 77 68 69 74 65 73 70 20 76 61 6c arch whitesp val
fe50: 29 20 0a 09 09 09 09 09 22 5c 22 22 0a 09 09 09 ) ......"\""....
fe60: 09 09 22 22 29 29 29 0a 09 09 09 28 70 72 69 6e .."")))....(prin
fe70: 74 20 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 65 t (if (or (membe
fe80: 72 20 6b 65 79 20 69 67 6e 6f 72 65 76 61 72 73 r key ignorevars
fe90: 29 0a 09 09 09 09 20 20 20 20 20 20 20 28 73 74 )..... (st
fea0: 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 ring-search whit
feb0: 65 73 70 20 6b 65 79 29 29 0a 09 09 09 09 20 20 esp key)).....
fec0: 20 22 23 20 73 65 74 65 6e 76 20 22 0a 09 09 09 "# setenv "....
fed0: 09 20 20 20 22 73 65 74 65 6e 76 20 22 29 0a 09 . "setenv ")..
fee0: 09 09 20 20 20 20 20 20 20 6b 65 79 20 22 20 22 .. key " "
fef0: 20 64 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 6c delim (mungeval
ff00: 20 76 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a 09 val) delim)))..
ff10: 09 20 20 20 20 65 6e 76 76 61 72 73 29 29 29 0a . envvars))).
ff20: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
ff30: 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 t-to-file (conc
ff40: 66 6e 61 6d 65 20 22 2e 73 68 22 29 0a 20 20 20 fname ".sh").
ff50: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 (lambda ().
ff60: 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 (for-ea
ff70: 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 76 ch (lambda (keyv
ff80: 61 6c 29 0a 09 09 20 20 20 20 20 20 28 6c 65 74 al)... (let
ff90: 2a 20 28 28 6b 65 79 20 28 63 61 72 20 6b 65 79 * ((key (car key
ffa0: 76 61 6c 29 29 0a 09 09 09 20 20 20 20 20 28 76 val)).... (v
ffb0: 61 6c 20 28 63 64 72 20 6b 65 79 76 61 6c 29 29 al (cdr keyval))
ffc0: 0a 09 09 09 20 20 20 20 20 28 64 65 6c 69 6d 20 .... (delim
ffd0: 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 (if (string-sear
ffe0: 63 68 20 77 68 69 74 65 73 70 20 76 61 6c 29 20 ch whitesp val)
fff0: 0a 09 09 09 09 09 22 5c 22 22 0a 09 09 09 09 09 ......"\""......
10000 22 22 29 29 29 0a 09 09 09 28 70 72 69 6e 74 20 "")))....(print
10010 28 69 66 20 28 6f 72 20 28 6d 65 6d 62 65 72 20 (if (or (member
10020 6b 65 79 20 69 67 6e 6f 72 65 76 61 72 73 29 0a key ignorevars).
10030 09 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 .... (stri
10040 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 73 ng-search whites
10050 70 20 6b 65 79 29 0a 09 09 09 09 20 20 20 20 20 p key).....
10060 20 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 (string-search
10070 20 22 3a 22 20 6b 65 79 29 29 20 3b 3b 20 69 6e ":" key)) ;; in
10080 74 65 72 6e 61 6c 20 6f 6e 6c 79 20 76 61 6c 75 ternal only valu
10090 65 73 20 74 6f 20 62 65 20 73 6b 69 70 70 65 64 es to be skipped
100a0 2e 0a 09 09 09 09 20 20 20 22 23 20 65 78 70 6f ...... "# expo
100b0 72 74 20 22 0a 09 09 09 09 20 20 20 22 65 78 70 rt "..... "exp
100c0 6f 72 74 20 22 29 0a 09 09 09 20 20 20 20 20 20 ort ")....
100d0 20 6b 65 79 20 22 3d 22 20 64 65 6c 69 6d 20 28 key "=" delim (
100e0 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 64 65 mungeval val) de
100f0 6c 69 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 lim))).
10100 20 20 20 20 20 20 20 20 20 20 20 65 6e 76 76 61 envva
10110 72 73 29 29 29 29 29 0a 0a 3b 3b 20 73 65 74 20 rs)))))..;; set
10120 73 6f 6d 65 20 65 6e 76 20 76 61 72 73 20 66 72 some env vars fr
10130 6f 6d 20 61 6e 20 61 6c 69 73 74 2c 20 72 65 74 om an alist, ret
10140 75 72 6e 20 61 6e 20 61 6c 69 73 74 20 77 69 74 urn an alist wit
10150 68 20 6f 72 69 67 69 6e 61 6c 20 76 61 6c 75 65 h original value
10160 73 0a 3b 3b 20 28 28 22 56 41 52 22 20 22 76 61 s.;; (("VAR" "va
10170 6c 75 65 22 29 20 2e 2e 2e 29 0a 28 64 65 66 69 lue") ...).(defi
10180 6e 65 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d 76 ne (alist->env-v
10190 61 72 73 20 6c 73 74 29 0a 20 20 28 69 66 20 28 ars lst). (if (
101a0 6c 69 73 74 3f 20 6c 73 74 29 0a 20 20 20 20 20 list? lst).
101b0 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 29 (let ((res '())
101c0 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 )..(for-each (la
101d0 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 20 28 mbda (p)... (
101e0 6c 65 74 2a 20 28 28 76 61 72 20 28 63 61 72 20 let* ((var (car
101f0 20 70 29 29 0a 09 09 09 20 20 20 28 76 61 6c 20 p)).... (val
10200 28 63 61 64 72 20 70 29 29 0a 09 09 09 20 20 20 (cadr p))....
10210 28 70 72 76 20 28 67 65 74 2d 65 6e 76 69 72 6f (prv (get-enviro
10220 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 76 nment-variable v
10230 61 72 29 29 29 0a 09 09 20 20 20 20 20 20 28 73 ar)))... (s
10240 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 6c et! res (cons (l
10250 69 73 74 20 76 61 72 20 70 72 76 29 20 72 65 73 ist var prv) res
10260 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 76 ))... (if v
10270 61 6c 20 0a 09 09 09 20 20 28 73 61 66 65 2d 73 al .... (safe-s
10280 65 74 65 6e 76 20 76 61 72 20 28 2d 3e 73 74 72 etenv var (->str
10290 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 28 ing val)).... (
102a0 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 29 29 unsetenv var))))
102b0 0a 09 09 20 20 6c 73 74 29 0a 09 72 65 73 29 0a ... lst)..res).
102c0 20 20 20 20 20 20 27 28 29 29 29 0a 0a 3b 3b 20 '()))..;;
102d0 63 6c 65 61 72 20 76 61 72 73 20 6d 61 74 63 68 clear vars match
102e0 69 6e 67 20 70 61 74 74 65 72 6e 2c 20 72 75 6e ing pattern, run
102f0 20 70 72 6f 63 2c 20 73 65 74 20 76 61 72 73 20 proc, set vars
10300 62 61 63 6b 0a 3b 3b 20 69 66 20 70 72 6f 63 20 back.;; if proc
10310 69 73 20 61 20 73 74 72 69 6e 67 20 72 75 6e 20 is a string run
10320 74 68 61 74 20 73 74 72 69 6e 67 20 61 73 20 61 that string as a
10330 20 63 6f 6d 6d 61 6e 64 20 77 69 74 68 0a 3b 3b command with.;;
10340 20 73 79 73 74 65 6d 2e 0a 3b 3b 0a 28 64 65 66 system..;;.(def
10350 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 ine (common:with
10360 6f 75 74 2d 76 61 72 73 20 70 72 6f 63 20 2e 20 out-vars proc .
10370 76 61 72 2d 70 61 74 74 73 29 0a 20 20 28 6c 65 var-patts). (le
10380 74 20 28 28 76 61 72 73 20 28 6d 61 6b 65 2d 68 t ((vars (make-h
10390 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 ash-table))).
103a0 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 (for-each.
103b0 28 6c 61 6d 62 64 61 20 28 76 61 72 64 61 74 29 (lambda (vardat)
103c0 20 3b 3b 20 65 61 63 68 20 65 6e 76 20 76 61 72 ;; each env var
103d0 0a 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 . (for-eac
103e0 68 0a 09 28 6c 61 6d 62 64 61 20 28 76 61 72 2d h..(lambda (var-
103f0 70 61 74 74 29 0a 09 20 20 28 69 66 20 28 73 74 patt).. (if (st
10400 72 69 6e 67 2d 6d 61 74 63 68 20 76 61 72 2d 70 ring-match var-p
10410 61 74 74 20 28 63 61 72 20 76 61 72 64 61 74 29 att (car vardat)
10420 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 ).. (let ((
10430 76 61 72 20 28 63 61 72 20 76 61 72 64 61 74 29 var (car vardat)
10440 29 0a 09 09 20 20 20 20 28 76 61 6c 20 28 63 64 )... (val (cd
10450 72 20 76 61 72 64 61 74 29 29 29 0a 09 09 28 68 r vardat)))...(h
10460 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 76 ash-table-set! v
10470 61 72 73 20 76 61 72 20 76 61 6c 29 0a 09 09 28 ars var val)...(
10480 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 29 29 unsetenv var))))
10490 0a 09 76 61 72 2d 70 61 74 74 73 29 29 0a 20 20 ..var-patts)).
104a0 20 20 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d (get-environm
104b0 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a ent-variables)).
104c0 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 (cond. (
104d0 28 73 74 72 69 6e 67 3f 20 70 72 6f 63 29 28 73 (string? proc)(s
104e0 79 73 74 65 6d 20 70 72 6f 63 29 29 0a 20 20 20 ystem proc)).
104f0 20 20 28 70 72 6f 63 20 20 20 20 20 20 20 20 20 (proc
10500 20 28 70 72 6f 63 29 29 29 0a 20 20 20 20 28 68 (proc))). (h
10510 61 73 68 2d 74 61 62 6c 65 2d 66 6f 72 2d 65 61 ash-table-for-ea
10520 63 68 0a 20 20 20 20 20 76 61 72 73 0a 20 20 20 ch. vars.
10530 20 20 28 6c 61 6d 62 64 61 20 28 76 61 72 20 76 (lambda (var v
10540 61 6c 29 0a 20 20 20 20 20 20 20 28 73 65 74 65 al). (sete
10550 6e 76 20 76 61 72 20 76 61 6c 29 29 29 0a 20 20 nv var val))).
10560 20 20 76 61 72 73 29 29 0a 0a 28 64 65 66 69 6e vars))..(defin
10570 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 61 2d e (common:run-a-
10580 63 6f 6d 6d 61 6e 64 20 63 6d 64 20 23 21 6b 65 command cmd #!ke
10590 79 20 28 77 69 74 68 2d 76 61 72 73 20 23 66 29 y (with-vars #f)
105a0 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 72 65 2d ). (let* ((pre-
105b0 63 6d 64 20 20 28 64 74 65 73 74 73 3a 67 65 74 cmd (dtests:get
105c0 2d 70 72 65 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 -pre-command)).
105d0 20 20 20 20 20 20 20 20 28 70 6f 73 74 2d 63 6d (post-cm
105e0 64 20 28 64 74 65 73 74 73 3a 67 65 74 2d 70 6f d (dtests:get-po
105f0 73 74 2d 63 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 st-command)).
10600 20 20 20 20 20 20 28 66 75 6c 6c 63 6d 64 20 20 (fullcmd
10610 28 69 66 20 28 6f 72 20 70 72 65 2d 63 6d 64 20 (if (or pre-cmd
10620 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 20 20 20 post-cmd).
10630 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10640 20 28 63 6f 6e 63 20 70 72 65 2d 63 6d 64 20 63 (conc pre-cmd c
10650 6d 64 20 70 6f 73 74 2d 63 6d 64 29 0a 20 20 20 md post-cmd).
10660 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10670 20 20 20 20 28 63 6f 6e 63 20 22 76 69 65 77 73 (conc "views
10680 63 72 65 65 6e 20 22 20 63 6d 64 29 29 29 29 0a creen " cmd)))).
10690 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
106a0 2d 69 6e 66 6f 20 30 32 20 2a 64 65 66 61 75 6c -info 02 *defaul
106b0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 52 75 6e t-log-port* "Run
106c0 6e 69 6e 67 20 63 6f 6d 6d 61 6e 64 3a 20 22 20 ning command: "
106d0 66 75 6c 6c 63 6d 64 29 0a 20 20 20 20 28 69 66 fullcmd). (if
106e0 20 77 69 74 68 2d 76 61 72 73 0a 20 20 20 20 20 with-vars.
106f0 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f (common:witho
10700 75 74 2d 76 61 72 73 20 63 6d 64 29 0a 20 20 20 ut-vars cmd).
10710 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 (common:wit
10720 68 6f 75 74 2d 76 61 72 73 20 66 75 6c 6c 63 6d hout-vars fullcm
10730 64 20 22 4d 54 5f 2e 2a 22 29 29 29 29 0a 09 09 d "MT_.*"))))...
10740 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;===========
10750 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10760 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10770 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10780 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 54 ===========.;; T
10790 20 49 20 4d 20 45 20 20 20 41 20 4e 20 44 20 20 I M E A N D
107a0 20 44 20 41 20 54 20 45 0a 3b 3b 3d 3d 3d 3d 3d D A T E.;;=====
107b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
107f0 3d 0a 0a 3b 3b 20 43 6f 6e 76 65 72 74 20 73 74 =..;; Convert st
10800 72 69 6e 67 73 20 6c 69 6b 65 20 22 35 73 20 32 rings like "5s 2
10810 68 20 33 6d 22 20 3d 3e 20 36 30 78 36 30 78 32 h 3m" => 60x60x2
10820 20 2b 20 33 78 36 30 20 2b 20 35 0a 28 64 65 66 + 3x60 + 5.(def
10830 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 6d 73 2d ine (common:hms-
10840 73 74 72 69 6e 67 2d 3e 73 65 63 6f 6e 64 73 20 string->seconds
10850 74 73 74 72 29 0a 20 20 28 6c 65 74 20 28 28 70 tstr). (let ((p
10860 61 72 74 73 20 20 20 20 20 28 73 74 72 69 6e 67 arts (string
10870 2d 73 70 6c 69 74 20 74 73 74 72 29 29 0a 09 28 -split tstr))..(
10880 74 69 6d 65 2d 73 65 63 73 20 30 29 0a 09 3b 3b time-secs 0)..;;
10890 20 73 3d 73 65 63 6f 6e 64 73 2c 20 6d 3d 6d 69 s=seconds, m=mi
108a0 6e 75 74 65 73 2c 20 68 3d 68 6f 75 72 73 2c 20 nutes, h=hours,
108b0 64 3d 64 61 79 73 0a 09 28 74 72 78 20 20 20 20 d=days..(trx
108c0 20 20 20 28 72 65 67 65 78 70 20 22 28 5c 5c 64 (regexp "(\\d
108d0 2b 29 28 5b 73 6d 68 64 5d 29 22 29 29 29 0a 20 +)([smhd])"))).
108e0 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
108f0 6d 62 64 61 20 28 70 61 72 74 29 0a 09 09 28 6c mbda (part)...(l
10900 65 74 20 28 28 6d 61 74 63 68 20 20 28 73 74 72 et ((match (str
10910 69 6e 67 2d 6d 61 74 63 68 20 74 72 78 20 70 61 ing-match trx pa
10920 72 74 29 29 29 0a 09 09 20 20 28 69 66 20 6d 61 rt)))... (if ma
10930 74 63 68 0a 09 09 20 20 20 20 20 20 28 6c 65 74 tch... (let
10940 20 28 28 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e ((val (string->
10950 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 number (cadr mat
10960 63 68 29 29 29 0a 09 09 09 20 20 20 20 28 75 6e ch))).... (un
10970 74 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 t (caddr match))
10980 29 0a 09 09 09 28 69 66 20 76 61 6c 20 0a 09 09 )....(if val ...
10990 09 20 20 20 20 28 73 65 74 21 20 74 69 6d 65 2d . (set! time-
109a0 73 65 63 73 20 28 2b 20 74 69 6d 65 2d 73 65 63 secs (+ time-sec
109b0 73 20 28 2a 20 76 61 6c 0a 09 09 09 09 09 09 09 s (* val........
109c0 20 20 20 20 28 63 61 73 65 20 28 73 74 72 69 6e (case (strin
109d0 67 2d 3e 73 79 6d 62 6f 6c 20 75 6e 74 29 0a 09 g->symbol unt)..
109e0 09 09 09 09 09 09 20 20 20 20 20 20 28 28 73 29 ...... ((s)
109f0 20 31 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 1)........
10a00 20 28 28 6d 29 20 36 30 29 0a 09 09 09 09 09 09 ((m) 60).......
10a10 09 20 20 20 20 20 20 28 28 68 29 20 28 2a 20 36 . ((h) (* 6
10a20 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 20 20 0 60))........
10a30 20 20 20 20 28 28 64 29 20 28 2a 20 32 34 20 36 ((d) (* 24 6
10a40 30 20 36 30 29 29 0a 09 09 09 09 09 09 09 20 20 0 60))........
10a50 20 20 20 20 28 65 6c 73 65 20 30 29 29 29 29 29 (else 0)))))
10a60 29 29 29 29 29 0a 09 20 20 20 20 20 20 70 61 72 ))))).. par
10a70 74 73 29 0a 20 20 20 20 74 69 6d 65 2d 73 65 63 ts). time-sec
10a80 73 29 29 0a 09 09 20 20 20 20 20 20 20 0a 28 64 s))... .(d
10a90 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e efine (seconds->
10aa0 68 72 2d 6d 69 6e 2d 73 65 63 20 73 65 63 73 29 hr-min-sec secs)
10ab0 0a 20 20 28 6c 65 74 2a 20 28 28 68 72 73 20 28 . (let* ((hrs (
10ac0 71 75 6f 74 69 65 6e 74 20 73 65 63 73 20 33 36 quotient secs 36
10ad0 30 30 29 29 0a 09 20 28 6d 69 6e 20 28 71 75 6f 00)).. (min (quo
10ae0 74 69 65 6e 74 20 28 2d 20 73 65 63 73 20 28 2a tient (- secs (*
10af0 20 68 72 73 20 33 36 30 30 29 29 20 36 30 29 29 hrs 3600)) 60))
10b00 0a 09 20 28 73 65 63 20 28 2d 20 73 65 63 73 20 .. (sec (- secs
10b10 28 2a 20 68 72 73 20 33 36 30 30 29 28 2a 20 6d (* hrs 3600)(* m
10b20 69 6e 20 36 30 29 29 29 29 0a 20 20 20 20 28 63 in 60)))). (c
10b30 6f 6e 63 20 28 69 66 20 28 3e 20 68 72 73 20 30 onc (if (> hrs 0
10b40 29 28 63 6f 6e 63 20 68 72 73 20 22 68 72 20 22 )(conc hrs "hr "
10b50 29 20 22 22 29 0a 09 20 20 28 69 66 20 28 3e 20 ) "").. (if (>
10b60 6d 69 6e 20 30 29 28 63 6f 6e 63 20 6d 69 6e 20 min 0)(conc min
10b70 22 6d 20 22 29 20 20 22 22 29 0a 09 20 20 73 65 "m ") "").. se
10b80 63 20 22 73 22 29 29 29 0a 0a 28 64 65 66 69 6e c "s")))..(defin
10b90 65 20 28 73 65 63 6f 6e 64 73 2d 3e 74 69 6d 65 e (seconds->time
10ba0 2d 73 74 72 69 6e 67 20 73 65 63 29 0a 20 20 28 -string sec). (
10bb0 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 20 20 time->string .
10bc0 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
10bd0 2d 74 69 6d 65 20 73 65 63 29 20 22 25 48 3a 25 -time sec) "%H:%
10be0 4d 3a 25 53 22 29 29 0a 0a 28 64 65 66 69 6e 65 M:%S"))..(define
10bf0 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f 72 6b 2d (seconds->work-
10c00 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 week/day-time se
10c10 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 c). (time->stri
10c20 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e ng. (seconds->
10c30 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 local-time sec)
10c40 22 77 77 25 56 2e 25 75 20 25 48 3a 25 4d 22 29 "ww%V.%u %H:%M")
10c50 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
10c60 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 nds->work-week/d
10c70 61 79 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d ay sec). (time-
10c80 3e 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f >string. (seco
10c90 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 nds->local-time
10ca0 73 65 63 29 20 22 77 77 25 56 2e 25 75 22 29 29 sec) "ww%V.%u"))
10cb0 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e ..(define (secon
10cc0 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 ds->year-work-we
10cd0 65 6b 2f 64 61 79 20 73 65 63 29 0a 20 20 28 74 ek/day sec). (t
10ce0 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 ime->string. (
10cf0 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
10d00 69 6d 65 20 73 65 63 29 20 22 25 79 77 77 25 56 ime sec) "%yww%V
10d10 2e 25 77 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 .%w"))..(define
10d20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d 77 (seconds->year-w
10d30 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 2d 74 69 6d ork-week/day-tim
10d40 65 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e e sec). (time->
10d50 73 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e string. (secon
10d60 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 ds->local-time s
10d70 65 63 29 20 22 25 59 77 77 25 56 2e 25 77 20 25 ec) "%Yww%V.%w %
10d80 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 69 6e 65 H:%M"))..(define
10d90 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 72 2d (seconds->year-
10da0 77 65 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 week/day-time se
10db0 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 c). (time->stri
10dc0 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e ng. (seconds->
10dd0 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 local-time sec)
10de0 22 25 59 77 25 56 2e 25 77 20 25 48 3a 25 4d 22 "%Yw%V.%w %H:%M"
10df0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ))..(define (sec
10e00 6f 6e 64 73 2d 3e 71 75 61 72 74 65 72 20 73 65 onds->quarter se
10e10 63 29 0a 20 20 28 63 61 73 65 20 28 73 74 72 69 c). (case (stri
10e20 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 20 28 74 69 ng->number.. (ti
10e30 6d 65 2d 3e 73 74 72 69 6e 67 20 0a 09 20 20 28 me->string .. (
10e40 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
10e50 69 6d 65 20 73 65 63 29 0a 09 20 20 22 25 6d 22 ime sec).. "%m"
10e60 29 29 0a 20 20 20 20 28 28 31 20 32 20 33 29 20 )). ((1 2 3)
10e70 31 29 0a 20 20 20 20 28 28 34 20 35 20 36 29 20 1). ((4 5 6)
10e80 32 29 0a 20 20 20 20 28 28 37 20 38 20 39 29 20 2). ((7 8 9)
10e90 33 29 0a 20 20 20 20 28 28 31 30 20 31 31 20 31 3). ((10 11 1
10ea0 32 29 20 34 29 0a 20 20 20 20 28 65 6c 73 65 20 2) 4). (else
10eb0 23 66 29 29 29 0a 0a 3b 3b 20 62 61 73 69 63 20 #f)))..;; basic
10ec0 49 53 4f 38 36 30 31 20 66 6f 72 6d 61 74 20 28 ISO8601 format (
10ed0 65 2e 67 2e 20 22 32 30 31 37 2d 30 32 2d 32 38 e.g. "2017-02-28
10ee0 20 30 36 3a 30 32 3a 35 34 22 29 20 64 61 74 65 06:02:54") date
10ef0 20 74 69 6d 65 20 3d 3e 20 55 6e 69 78 20 65 70 time => Unix ep
10f00 6f 63 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 och.;;.(define (
10f10 63 6f 6d 6d 6f 6e 3a 64 61 74 65 2d 74 69 6d 65 common:date-time
10f20 2d 3e 73 65 63 6f 6e 64 73 20 64 61 74 65 74 69 ->seconds dateti
10f30 6d 65 29 0a 20 20 28 6c 6f 63 61 6c 2d 74 69 6d me). (local-tim
10f40 65 2d 3e 73 65 63 6f 6e 64 73 20 28 73 74 72 69 e->seconds (stri
10f50 6e 67 2d 3e 74 69 6d 65 20 64 61 74 65 74 69 6d ng->time datetim
10f60 65 20 22 25 59 2d 25 6d 2d 25 64 20 25 48 3a 25 e "%Y-%m-%d %H:%
10f70 4d 3a 25 53 22 29 29 29 0a 0a 3b 3b 20 67 69 76 M:%S")))..;; giv
10f80 65 6e 20 73 70 61 6e 20 6f 66 20 73 65 63 6f 6e en span of secon
10f90 64 73 20 74 73 74 61 72 74 20 74 6f 20 74 65 6e ds tstart to ten
10fa0 64 0a 3b 3b 20 66 69 6e 64 20 73 74 61 72 74 20 d.;; find start
10fb0 74 69 6d 65 20 74 6f 20 6d 61 72 6b 20 61 6e 64 time to mark and
10fc0 20 6d 61 72 6b 20 64 65 6c 74 61 0a 3b 3b 0a 28 mark delta.;;.(
10fd0 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 define (common:f
10fe0 69 6e 64 2d 73 74 61 72 74 2d 6d 61 72 6b 2d 61 ind-start-mark-a
10ff0 6e 64 2d 6d 61 72 6b 2d 64 65 6c 74 61 20 74 73 nd-mark-delta ts
11000 74 61 72 74 20 74 65 6e 64 29 0a 20 20 28 6c 65 tart tend). (le
11010 74 2a 20 28 28 64 65 6c 74 61 74 20 20 20 28 2d t* ((deltat (-
11020 20 28 6d 61 78 20 74 65 6e 64 20 28 2b 20 74 65 (max tend (+ te
11030 6e 64 20 31 30 29 29 20 74 73 74 61 72 74 29 29 nd 10)) tstart))
11040 20 3b 3b 20 63 61 6e 27 74 20 68 61 6e 64 6c 65 ;; can't handle
11050 20 72 75 6e 73 20 6f 66 20 6c 65 73 73 20 74 68 runs of less th
11060 61 6e 20 34 20 73 65 63 6f 6e 64 73 2e 20 50 61 an 4 seconds. Pa
11070 64 20 69 74 20 74 6f 20 31 30 20 73 65 63 6f 6e d it to 10 secon
11080 64 73 20 2e 2e 2e 0a 09 20 28 72 65 73 75 6c 74 ds ..... (result
11090 20 20 20 23 66 29 0a 09 20 28 6d 69 6e 20 20 20 #f).. (min
110a0 20 20 20 36 30 29 0a 09 20 28 68 72 20 20 20 20 60).. (hr
110b0 20 20 20 28 2a 20 36 30 20 36 30 29 29 0a 09 20 (* 60 60))..
110c0 28 64 61 79 20 20 20 20 20 20 28 2a 20 32 34 20 (day (* 24
110d0 68 72 29 29 0a 09 20 28 79 72 20 20 20 20 20 20 hr)).. (yr
110e0 20 28 2a 20 33 36 35 20 64 61 79 29 29 20 3b 3b (* 365 day)) ;;
110f0 20 79 65 61 72 0a 09 20 28 6d 6f 20 20 20 20 20 year.. (mo
11100 20 20 28 2f 20 79 72 20 31 32 29 29 0a 09 20 28 (/ yr 12)).. (
11110 77 6b 20 20 20 20 20 20 20 28 2a 20 64 61 79 20 wk (* day
11120 37 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 7))). (for-ea
11130 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ch. (lambda
11140 28 6d 61 78 2d 62 6c 6b 73 29 0a 20 20 20 20 20 (max-blks).
11150 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 (for-each..(la
11160 6d 62 64 61 20 28 73 70 61 6e 29 20 3b 3b 20 35 mbda (span) ;; 5
11170 20 32 20 31 0a 09 20 20 28 69 66 20 28 6e 6f 74 2 1.. (if (not
11180 20 72 65 73 75 6c 74 29 0a 09 20 20 20 20 20 20 result)..
11190 28 66 6f 72 2d 65 61 63 68 20 0a 09 20 20 20 20 (for-each ..
111a0 20 20 20 28 6c 61 6d 62 64 61 20 28 74 69 6d 65 (lambda (time
111b0 75 6e 69 74 20 74 69 6d 65 73 79 6d 29 20 3b 3b unit timesym) ;;
111c0 20 79 65 61 72 20 6d 6f 6e 74 68 20 64 61 79 20 year month day
111d0 68 72 20 6d 69 6e 20 73 65 63 0a 09 09 20 28 69 hr min sec... (i
111e0 66 20 28 6e 6f 74 20 72 65 73 75 6c 74 29 0a 09 f (not result)..
111f0 09 20 20 20 20 20 28 6c 65 74 2a 20 28 28 74 69 . (let* ((ti
11200 6d 65 2d 62 6c 6b 20 28 2a 20 73 70 61 6e 20 74 me-blk (* span t
11210 69 6d 65 75 6e 69 74 29 29 0a 09 09 09 20 20 20 imeunit))....
11220 20 28 6e 75 6d 2d 62 6c 6b 73 20 28 71 75 6f 74 (num-blks (quot
11230 69 65 6e 74 20 64 65 6c 74 61 74 20 74 69 6d 65 ient deltat time
11240 2d 62 6c 6b 29 29 29 0a 09 09 20 20 20 20 20 20 -blk)))...
11250 20 28 69 66 20 28 61 6e 64 20 28 3e 20 6e 75 6d (if (and (> num
11260 2d 62 6c 6b 73 20 34 29 28 3c 20 6e 75 6d 2d 62 -blks 4)(< num-b
11270 6c 6b 73 20 6d 61 78 2d 62 6c 6b 73 29 29 0a 09 lks max-blks))..
11280 09 09 20 20 20 28 6c 65 74 20 28 28 66 69 72 73 .. (let ((firs
11290 74 20 28 2a 20 28 71 75 6f 74 69 65 6e 74 20 74 t (* (quotient t
112a0 73 74 61 72 74 20 74 69 6d 65 2d 62 6c 6b 29 20 start time-blk)
112b0 74 69 6d 65 2d 62 6c 6b 29 29 29 0a 09 09 09 20 time-blk)))....
112c0 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c 74 (set! result
112d0 20 28 6c 69 73 74 20 73 70 61 6e 20 74 69 6d 65 (list span time
112e0 75 6e 69 74 20 74 69 6d 65 2d 62 6c 6b 20 66 69 unit time-blk fi
112f0 72 73 74 20 74 69 6d 65 73 79 6d 29 29 0a 09 09 rst timesym))...
11300 09 20 20 20 20 20 29 29 29 29 29 0a 09 20 20 20 . )))))..
11310 20 20 20 20 28 6c 69 73 74 20 79 72 20 6d 6f 20 (list yr mo
11320 77 6b 20 64 61 79 20 68 72 20 6d 69 6e 20 31 29 wk day hr min 1)
11330 0a 09 20 20 20 20 20 20 20 27 28 20 20 20 20 20 .. '(
11340 79 20 20 6d 6f 20 77 20 20 64 20 20 20 68 20 20 y mo w d h
11350 6d 20 20 20 73 29 29 29 29 0a 09 28 6c 69 73 74 m s))))..(list
11360 20 38 20 36 20 35 20 32 20 31 29 29 29 0a 20 20 8 6 5 2 1))).
11370 20 20 20 27 28 35 20 31 30 20 31 35 20 32 30 20 '(5 10 15 20
11380 33 30 20 34 30 20 35 30 20 35 30 30 29 29 0a 20 30 40 50 500)).
11390 20 20 20 28 69 66 20 76 61 6c 75 65 73 0a 09 28 (if values..(
113a0 61 70 70 6c 79 20 76 61 6c 75 65 73 20 72 65 73 apply values res
113b0 75 6c 74 29 0a 09 28 76 61 6c 75 65 73 20 30 20 ult)..(values 0
113c0 64 61 79 20 31 20 30 20 27 64 29 29 29 29 0a 0a day 1 0 'd))))..
113d0 3b 3b 20 67 69 76 65 6e 20 78 20 79 20 6c 69 6d ;; given x y lim
113e0 20 72 65 74 75 72 6e 20 74 68 65 20 63 72 6f 6e return the cron
113f0 20 65 78 70 61 6e 73 69 6f 6e 0a 3b 3b 0a 28 64 expansion.;;.(d
11400 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 65 78 efine (common:ex
11410 70 61 6e 64 2d 63 72 6f 6e 2d 73 6c 61 73 68 20 pand-cron-slash
11420 78 20 79 20 6c 69 6d 29 0a 20 20 28 6c 65 74 20 x y lim). (let
11430 6c 6f 6f 70 20 28 28 63 75 72 72 20 78 29 0a 09 loop ((curr x)..
11440 20 20 20 20 20 28 72 65 73 20 20 60 28 29 29 29 (res `()))
11450 0a 20 20 20 20 28 69 66 20 28 3c 20 63 75 72 72 . (if (< curr
11460 20 6c 69 6d 29 0a 09 28 6c 6f 6f 70 20 28 2b 20 lim)..(loop (+
11470 63 75 72 72 20 79 29 20 28 63 6f 6e 73 20 63 75 curr y) (cons cu
11480 72 72 20 72 65 73 29 29 0a 09 28 72 65 76 65 72 rr res))..(rever
11490 73 65 20 72 65 73 29 29 29 29 0a 0a 3b 3b 20 65 se res))))..;; e
114a0 78 70 61 6e 64 20 61 20 63 6f 6d 70 6c 65 78 20 xpand a complex
114b0 63 72 6f 6e 20 73 74 72 69 6e 67 20 74 6f 20 61 cron string to a
114c0 20 6c 69 73 74 20 6f 66 20 63 72 6f 6e 20 73 74 list of cron st
114d0 72 69 6e 67 73 0a 3b 3b 0a 3b 3b 20 20 78 2f 79 rings.;;.;; x/y
114e0 20 20 20 3d 3e 20 78 2c 20 78 2b 79 2c 20 78 2b => x, x+y, x+
114f0 32 79 2c 20 78 2b 33 79 20 77 68 69 6c 65 20 78 2y, x+3y while x
11500 2b 4e 79 3c 6d 61 78 5f 66 6f 72 5f 66 69 65 6c +Ny<max_for_fiel
11510 64 0a 3b 3b 20 20 61 2c 62 2c 63 20 3d 3e 20 61 d.;; a,b,c => a
11520 2c 20 62 20 2c 63 0a 3b 3b 0a 3b 3b 20 20 20 4e , b ,c.;;.;; N
11530 4f 54 45 3a 20 77 69 74 68 20 66 6c 61 74 74 65 OTE: with flatte
11540 6e 20 61 20 6c 6f 74 20 6f 66 20 74 68 65 20 63 n a lot of the c
11550 72 75 64 20 62 65 6c 6f 77 20 63 61 6e 20 62 65 rud below can be
11560 20 66 61 63 74 6f 72 65 64 20 64 6f 77 6e 2e 0a factored down..
11570 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
11580 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 63 on:cron-expand c
11590 72 6f 6e 2d 73 74 72 29 0a 20 20 28 69 66 20 28 ron-str). (if (
115a0 6c 69 73 74 3f 20 63 72 6f 6e 2d 73 74 72 29 0a list? cron-str).
115b0 20 20 20 20 20 20 28 66 6c 61 74 74 65 6e 0a 20 (flatten.
115c0 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c 61 6d (fold (lam
115d0 62 64 61 20 28 78 20 72 65 73 29 0a 09 20 20 20 bda (x res)..
115e0 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 78 (if (list? x
115f0 29 0a 09 09 20 20 20 28 6c 65 74 20 28 28 6e 65 )... (let ((ne
11600 77 72 65 73 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e wres (map common
11610 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 78 29 29 :cron-expand x))
11620 29 0a 09 09 20 20 20 20 20 28 61 70 70 65 6e 64 )... (append
11630 20 78 20 6e 65 77 72 65 73 29 29 0a 09 09 20 20 x newres))...
11640 20 28 63 6f 6e 73 20 78 20 72 65 73 29 29 29 0a (cons x res))).
11650 09 20 20 20 20 20 27 28 29 0a 09 20 20 20 20 20 . '()..
11660 63 72 6f 6e 2d 73 74 72 29 29 20 3b 3b 20 28 6d cron-str)) ;; (m
11670 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 ap common:cron-e
11680 78 70 61 6e 64 20 63 72 6f 6e 2d 73 74 72 29 29 xpand cron-str))
11690 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 72 . (let ((cr
116a0 6f 6e 2d 69 74 65 6d 73 20 28 73 74 72 69 6e 67 on-items (string
116b0 2d 73 70 6c 69 74 20 63 72 6f 6e 2d 73 74 72 29 -split cron-str)
116c0 29 0a 09 20 20 20 20 28 73 6c 61 73 68 2d 72 78 ).. (slash-rx
116d0 20 20 20 28 72 65 67 65 78 70 20 22 28 5c 5c 64 (regexp "(\\d
116e0 2b 29 2f 28 5c 5c 64 2b 29 22 29 29 0a 09 20 20 +)/(\\d+)"))..
116f0 20 20 28 63 6f 6d 6d 61 2d 72 78 20 20 20 28 72 (comma-rx (r
11700 65 67 65 78 70 20 22 2e 2a 2c 2e 2a 22 29 29 0a egexp ".*,.*")).
11710 09 20 20 20 20 28 6d 61 78 2d 76 61 6c 73 20 20 . (max-vals
11720 20 27 28 28 6d 69 6e 20 20 20 20 20 20 20 20 2e '((min .
11730 20 36 30 29 0a 09 09 09 20 20 28 68 6f 75 72 20 60).... (hour
11740 20 20 20 20 20 20 2e 20 32 34 29 0a 09 09 09 20 . 24)....
11750 20 28 64 61 79 6f 66 6d 6f 6e 74 68 20 2e 20 32 (dayofmonth . 2
11760 38 29 20 3b 3b 3b 20 42 55 47 21 21 21 21 20 54 8) ;;; BUG!!!! T
11770 68 69 73 20 77 69 6c 6c 20 62 65 20 61 20 62 75 his will be a bu
11780 67 20 66 6f 72 20 73 6f 6d 65 20 63 6f 6d 62 69 g for some combi
11790 6e 61 74 69 6f 6e 73 0a 09 09 09 20 20 28 6d 6f nations.... (mo
117a0 6e 74 68 20 20 20 20 20 20 2e 20 31 32 29 0a 09 nth . 12)..
117b0 09 09 20 20 28 64 61 79 6f 66 77 65 65 6b 20 20 .. (dayofweek
117c0 2e 20 37 29 29 29 29 0a 09 28 69 66 20 28 3c 20 . 7))))..(if (<
117d0 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 74 65 (length cron-ite
117e0 6d 73 29 20 35 29 20 3b 3b 20 62 61 64 20 73 70 ms) 5) ;; bad sp
117f0 65 63 0a 09 20 20 20 20 63 72 6f 6e 2d 73 74 72 ec.. cron-str
11800 20 3b 3b 20 60 28 2c 63 72 6f 6e 2d 73 74 72 29 ;; `(,cron-str)
11810 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;;
11820 20 6a 75 73 74 20 72 65 74 75 72 6e 20 74 68 65 just return the
11830 20 73 74 72 69 6e 67 2c 20 73 6f 6d 65 74 68 69 string, somethi
11840 6e 67 20 64 6f 77 6e 73 74 72 65 61 6d 20 77 69 ng downstream wi
11850 6c 6c 20 66 69 78 20 69 74 0a 09 20 20 20 20 28 ll fix it.. (
11860 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 20 let loop ((hed
11870 28 63 61 72 20 63 72 6f 6e 2d 69 74 65 6d 73 29 (car cron-items)
11880 29 0a 09 09 20 20 20 20 20 20 20 28 74 61 6c 20 )... (tal
11890 20 28 63 64 72 20 63 72 6f 6e 2d 69 74 65 6d 73 (cdr cron-items
118a0 29 29 0a 09 09 20 20 20 20 20 20 20 28 74 79 70 ))... (typ
118b0 65 20 27 6d 69 6e 29 0a 09 09 20 20 20 20 20 20 e 'min)...
118c0 20 28 74 79 70 65 2d 74 61 6c 20 27 28 68 6f 75 (type-tal '(hou
118d0 72 20 64 61 79 6f 66 6d 6f 6e 74 68 20 6d 6f 6e r dayofmonth mon
118e0 74 68 20 64 61 79 6f 66 77 65 65 6b 29 29 0a 09 th dayofweek))..
118f0 09 20 20 20 20 20 20 20 28 72 65 73 20 20 27 28 . (res '(
11900 29 29 29 0a 09 20 20 20 20 20 20 28 72 65 67 65 ))).. (rege
11910 78 2d 63 61 73 65 0a 09 09 20 20 68 65 64 0a 09 x-case... hed..
11920 09 28 73 6c 61 73 68 2d 72 78 20 28 20 5f 20 62 .(slash-rx ( _ b
11930 61 73 65 20 69 6e 63 72 20 29 20 28 6c 65 74 2a ase incr ) (let*
11940 20 28 28 62 61 73 65 6e 20 20 20 20 20 20 20 20 ((basen
11950 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 (string->numbe
11960 72 20 62 61 73 65 29 29 0a 09 09 09 09 09 09 20 r base)).......
11970 28 69 6e 63 72 6e 20 20 20 20 20 20 20 20 20 20 (incrn
11980 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
11990 69 6e 63 72 29 29 0a 09 09 09 09 09 09 20 28 65 incr))....... (e
119a0 78 70 61 6e 64 65 64 2d 76 61 6c 73 20 20 28 63 xpanded-vals (c
119b0 6f 6d 6d 6f 6e 3a 65 78 70 61 6e 64 2d 63 72 6f ommon:expand-cro
119c0 6e 2d 73 6c 61 73 68 20 62 61 73 65 6e 20 69 6e n-slash basen in
119d0 63 72 6e 20 28 61 6c 69 73 74 2d 72 65 66 20 74 crn (alist-ref t
119e0 79 70 65 20 6d 61 78 2d 76 61 6c 73 29 29 29 0a ype max-vals))).
119f0 09 09 09 09 09 09 20 28 6e 65 77 2d 6c 69 73 74 ...... (new-list
11a00 2d 63 72 6f 6e 73 20 28 66 6f 6c 64 20 28 6c 61 -crons (fold (la
11a10 6d 62 64 61 20 28 78 20 6d 79 72 65 73 29 0a 09 mbda (x myres)..
11a20 09 09 09 09 09 09 09 09 20 28 63 6f 6e 73 20 28 ........ (cons (
11a30 63 6f 6e 63 20 28 69 66 20 28 6e 75 6c 6c 3f 20 conc (if (null?
11a40 72 65 73 29 0a 09 09 09 09 09 09 09 09 09 09 09 res)............
11a50 20 22 22 0a 09 09 09 09 09 09 09 09 09 09 09 20 ""............
11a60 28 63 6f 6e 63 20 28 73 74 72 69 6e 67 2d 69 6e (conc (string-in
11a70 74 65 72 73 70 65 72 73 65 20 72 65 73 20 22 20 tersperse res "
11a80 22 29 20 22 20 22 29 29 0a 09 09 09 09 09 09 09 ") " "))........
11a90 09 09 09 20 20 20 20 20 78 20 22 20 22 20 28 73 ... x " " (s
11aa0 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
11ab0 65 20 74 61 6c 20 22 20 22 29 29 0a 09 09 09 09 e tal " ")).....
11ac0 09 09 09 09 09 20 20 20 20 20 20 20 6d 79 72 65 ..... myre
11ad0 73 29 29 0a 09 09 09 09 09 09 09 09 20 20 20 20 s)).........
11ae0 20 20 20 27 28 29 20 65 78 70 61 6e 64 65 64 2d '() expanded-
11af0 76 61 6c 73 29 29 29 0a 09 09 09 09 09 20 20 20 vals)))......
11b00 20 3b 3b 20 28 70 72 69 6e 74 20 22 6e 65 77 2d ;; (print "new-
11b10 6c 69 73 74 2d 63 72 6f 6e 73 3a 20 22 20 6e 65 list-crons: " ne
11b20 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 29 0a 09 09 w-list-crons)...
11b30 09 09 09 20 20 20 20 3b 3b 20 28 66 6f 6c 64 20 ... ;; (fold
11b40 28 6c 61 6d 62 64 61 20 28 78 20 72 65 73 29 0a (lambda (x res).
11b50 09 09 09 09 09 20 20 20 20 3b 3b 20 09 20 20 20 ..... ;; .
11b60 20 28 69 66 20 28 6c 69 73 74 3f 20 78 29 0a 09 (if (list? x)..
11b70 09 09 09 09 20 20 20 20 3b 3b 20 09 09 28 6c 65 .... ;; ..(le
11b80 74 20 28 28 6e 65 77 72 65 73 20 28 6d 61 70 20 t ((newres (map
11b90 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 common:cron-expa
11ba0 6e 64 20 78 29 29 29 0a 09 09 09 09 09 20 20 20 nd x)))......
11bb0 20 3b 3b 20 09 09 20 20 28 61 70 70 65 6e 64 20 ;; .. (append
11bc0 78 20 6e 65 77 72 65 73 29 29 0a 09 09 09 09 09 x newres))......
11bd0 20 20 20 20 3b 3b 20 09 09 28 63 6f 6e 73 20 78 ;; ..(cons x
11be0 20 72 65 73 29 29 29 0a 09 09 09 09 09 20 20 20 res)))......
11bf0 20 3b 3b 20 09 20 20 27 28 29 0a 09 09 09 09 09 ;; . '()......
11c00 20 20 20 20 28 66 6c 61 74 74 65 6e 20 28 6d 61 (flatten (ma
11c10 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 p common:cron-ex
11c20 70 61 6e 64 20 6e 65 77 2d 6c 69 73 74 2d 63 72 pand new-list-cr
11c30 6f 6e 73 29 29 29 29 0a 09 09 3b 3b 09 09 09 09 ons))))...;;....
11c40 09 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e . (map common
11c50 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 28 6d 61 :cron-expand (ma
11c60 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 p common:cron-ex
11c70 70 61 6e 64 20 6e 65 77 2d 6c 69 73 74 2d 63 72 pand new-list-cr
11c80 6f 6e 73 29 29 29 29 0a 09 09 28 65 6c 73 65 20 ons))))...(else
11c90 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
11ca0 09 09 09 20 20 63 72 6f 6e 2d 73 74 72 0a 09 09 ... cron-str...
11cb0 09 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 . (loop (car ta
11cc0 6c 29 28 63 64 72 20 74 61 6c 29 28 63 61 72 20 l)(cdr tal)(car
11cd0 74 79 70 65 2d 74 61 6c 29 28 63 64 72 20 74 79 type-tal)(cdr ty
11ce0 70 65 2d 74 61 6c 29 28 61 70 70 65 6e 64 20 72 pe-tal)(append r
11cf0 65 73 20 28 6c 69 73 74 20 68 65 64 29 29 29 29 es (list hed))))
11d00 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 20 )))))))...
11d10 0a 09 20 20 20 20 0a 3b 3b 20 67 69 76 65 6e 20 .. .;; given
11d20 61 20 63 72 6f 6e 20 73 74 72 69 6e 67 20 61 6e a cron string an
11d30 64 20 74 68 65 20 6c 61 73 74 20 74 69 6d 65 20 d the last time
11d40 65 76 65 6e 74 20 77 61 73 20 70 72 6f 63 65 73 event was proces
11d50 73 65 64 20 72 65 74 75 72 6e 20 23 74 20 74 6f sed return #t to
11d60 20 72 75 6e 20 6f 72 20 23 66 20 74 6f 20 6e 6f run or #f to no
11d70 74 20 72 75 6e 0a 3b 3b 0a 3b 3b 20 20 6d 69 6e t run.;;.;; min
11d80 20 20 20 20 68 6f 75 72 20 20 20 64 61 79 6f 66 hour dayof
11d90 6d 6f 6e 74 68 20 6d 6f 6e 74 68 20 20 64 61 79 month month day
11da0 6f 66 77 65 65 6b 0a 3b 3b 20 30 2d 35 39 20 20 ofweek.;; 0-59
11db0 20 20 30 2d 32 33 20 20 20 31 2d 33 31 20 20 20 0-23 1-31
11dc0 20 20 20 20 31 2d 31 32 20 20 20 30 2d 36 20 20 1-12 0-6
11dd0 20 20 20 20 20 20 20 20 23 23 23 20 4e 4f 54 45 ### NOTE
11de0 3a 20 64 61 79 6f 66 77 65 65 6b 20 64 6f 65 73 : dayofweek does
11df0 20 6e 6f 74 20 69 6e 63 6c 75 64 65 20 37 0a 3b not include 7.;
11e00 3b 0a 3b 3b 20 20 23 74 20 3d 3e 20 79 65 73 2c ;.;; #t => yes,
11e10 20 72 75 6e 20 74 68 65 20 6a 6f 62 0a 3b 3b 20 run the job.;;
11e20 20 23 66 20 3d 3e 20 6e 6f 2c 20 64 6f 20 6e 6f #f => no, do no
11e30 74 20 72 75 6e 20 74 68 65 20 6a 6f 62 0a 3b 3b t run the job.;;
11e40 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
11e50 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 63 72 6f 6e :cron-event cron
11e60 2d 73 74 72 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 -str now-seconds
11e70 2d 69 6e 20 6c 61 73 74 2d 64 6f 6e 65 29 20 3b -in last-done) ;
11e80 3b 20 72 65 66 2d 73 65 63 6f 6e 64 73 20 3d 20 ; ref-seconds =
11e90 23 66 20 69 73 20 4e 4f 57 2e 0a 20 20 28 6c 65 #f is NOW.. (le
11ea0 74 2a 20 28 28 63 72 6f 6e 2d 69 74 65 6d 73 20 t* ((cron-items
11eb0 20 20 20 20 28 6d 61 70 20 73 74 72 69 6e 67 2d (map string-
11ec0 3e 6e 75 6d 62 65 72 20 28 73 74 72 69 6e 67 2d >number (string-
11ed0 73 70 6c 69 74 20 63 72 6f 6e 2d 73 74 72 29 29 split cron-str))
11ee0 29 0a 09 20 28 6e 6f 77 2d 73 65 63 6f 6e 64 73 ).. (now-seconds
11ef0 20 20 20 20 28 6f 72 20 6e 6f 77 2d 73 65 63 6f (or now-seco
11f00 6e 64 73 2d 69 6e 20 28 63 75 72 72 65 6e 74 2d nds-in (current-
11f10 73 65 63 6f 6e 64 73 29 29 29 0a 09 20 28 6e 6f seconds))).. (no
11f20 77 2d 74 69 6d 65 20 20 20 20 20 20 20 28 73 65 w-time (se
11f30 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
11f40 65 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 29 29 0a e now-seconds)).
11f50 09 20 28 6c 61 73 74 2d 64 6f 6e 65 2d 74 69 6d . (last-done-tim
11f60 65 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 e (seconds->loca
11f70 6c 2d 74 69 6d 65 20 6c 61 73 74 2d 64 6f 6e 65 l-time last-done
11f80 29 29 0a 09 20 28 61 6c 6c 2d 74 69 6d 65 73 20 )).. (all-times
11f90 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
11fa0 74 61 62 6c 65 29 29 29 0a 20 20 20 20 3b 3b 20 table))). ;;
11fb0 28 70 72 69 6e 74 20 22 63 72 6f 6e 2d 69 74 65 (print "cron-ite
11fc0 6d 73 3a 20 22 20 63 72 6f 6e 2d 69 74 65 6d 73 ms: " cron-items
11fd0 20 22 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 "(length cron-i
11fe0 74 65 6d 73 29 3a 20 22 20 28 6c 65 6e 67 74 68 tems): " (length
11ff0 20 63 72 6f 6e 2d 69 74 65 6d 73 29 29 0a 20 20 cron-items)).
12000 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 (if (not (eq?
12010 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 74 65 (length cron-ite
12020 6d 73 29 20 35 29 29 20 3b 3b 20 64 6f 6e 27 74 ms) 5)) ;; don't
12030 20 65 76 65 6e 20 74 72 79 20 74 6f 20 66 69 67 even try to fig
12040 75 72 65 20 6f 75 74 20 6a 75 6e 6b 20 73 74 72 ure out junk str
12050 69 6e 67 73 0a 09 23 66 0a 09 28 6d 61 74 63 68 ings..#f..(match
12060 2d 6c 65 74 20 28 28 28 20 20 20 20 20 63 6d 69 -let ((( cmi
12070 6e 20 63 68 6f 75 72 20 63 64 61 79 6f 66 6d 6f n chour cdayofmo
12080 6e 74 68 20 63 6d 6f 6e 74 68 20 20 20 20 63 64 nth cmonth cd
12090 61 79 6f 66 77 65 65 6b 29 0a 09 09 20 20 20 20 ayofweek)...
120a0 20 63 72 6f 6e 2d 69 74 65 6d 73 29 0a 09 09 20 cron-items)...
120b0 20 20 20 3b 3b 20 30 20 20 20 20 20 31 20 20 20 ;; 0 1
120c0 20 32 20 20 20 20 20 20 20 20 33 20 20 20 20 20 2 3
120d0 20 20 20 20 34 20 20 20 20 35 20 20 20 20 20 20 4 5
120e0 36 0a 09 09 20 20 20 20 28 28 6e 73 65 63 20 6e 6... ((nsec n
120f0 6d 69 6e 20 6e 68 6f 75 72 20 6e 64 61 79 6f 66 min nhour ndayof
12100 6d 6f 6e 74 68 20 6e 6d 6f 6e 74 68 20 6e 79 72 month nmonth nyr
12110 20 6e 64 61 79 6f 66 77 65 65 6b 20 6e 37 20 6e ndayofweek n7 n
12120 38 20 6e 39 29 0a 09 09 20 20 20 20 20 28 76 65 8 n9)... (ve
12130 63 74 6f 72 2d 3e 6c 69 73 74 20 6e 6f 77 2d 74 ctor->list now-t
12140 69 6d 65 29 29 0a 09 09 20 20 20 20 28 28 6c 73 ime))... ((ls
12150 65 63 20 6c 6d 69 6e 20 6c 68 6f 75 72 20 6c 64 ec lmin lhour ld
12160 61 79 6f 66 6d 6f 6e 74 68 20 6c 6d 6f 6e 74 68 ayofmonth lmonth
12170 20 6c 79 72 20 6c 64 61 79 6f 66 77 65 65 6b 20 lyr ldayofweek
12180 6c 37 20 6c 38 20 6c 39 29 0a 09 09 20 20 20 20 l7 l8 l9)...
12190 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 20 6c (vector->list l
121a0 61 73 74 2d 64 6f 6e 65 2d 74 69 6d 65 29 29 29 ast-done-time)))
121b0 0a 09 20 20 3b 3b 20 63 72 65 61 74 65 20 61 6c .. ;; create al
121c0 6c 20 70 6f 73 73 69 62 6c 65 20 74 69 6d 65 20 l possible time
121d0 73 6c 6f 74 73 0a 09 20 20 3b 3b 20 72 65 6d 6f slots.. ;; remo
121e0 76 65 20 69 6e 76 61 6c 69 64 20 73 6c 6f 74 73 ve invalid slots
121f0 20 64 75 65 20 74 6f 20 28 66 6f 72 20 65 78 61 due to (for exa
12200 6d 70 6c 65 29 20 64 61 79 20 6f 66 20 77 65 65 mple) day of wee
12210 6b 0a 09 20 20 3b 3b 20 67 65 74 20 74 68 65 20 k.. ;; get the
12220 73 74 61 72 74 20 61 6e 64 20 65 6e 64 20 65 6e start and end en
12230 74 72 69 65 73 20 66 6f 72 20 74 68 65 20 72 65 tries for the re
12240 66 2d 73 65 63 6f 6e 64 73 20 28 63 75 72 72 65 f-seconds (curre
12250 6e 74 29 20 74 69 6d 65 0a 09 20 20 3b 3b 20 69 nt) time.. ;; i
12260 66 20 6c 61 73 74 2d 64 6f 6e 65 20 3e 20 72 65 f last-done > re
12270 66 2d 73 65 63 6f 6e 64 73 20 3d 3e 20 74 68 69 f-seconds => thi
12280 73 20 69 73 20 61 6e 20 45 52 52 4f 52 21 0a 09 s is an ERROR!..
12290 20 20 3b 3b 20 64 6f 65 73 20 74 68 65 20 6c 61 ;; does the la
122a0 73 74 2d 64 6f 6e 65 20 74 69 6d 65 20 66 61 6c st-done time fal
122b0 6c 20 69 6e 20 74 68 65 20 6c 65 67 69 74 20 72 l in the legit r
122c0 65 67 69 6f 6e 3f 0a 09 20 20 3b 3b 20 20 20 20 egion?.. ;;
122d0 79 65 73 20 3d 3e 20 23 66 20 20 64 6f 20 6e 6f yes => #f do no
122e0 74 20 72 75 6e 20 61 67 61 69 6e 20 74 68 69 73 t run again this
122f0 20 63 6f 6d 6d 61 6e 64 0a 09 20 20 3b 3b 20 20 command.. ;;
12300 20 20 6e 6f 20 20 3d 3e 20 23 74 20 20 6f 6b 20 no => #t ok
12310 74 6f 20 72 75 6e 20 74 68 65 20 63 6f 6d 6d 61 to run the comma
12320 6e 64 0a 09 20 20 28 66 6f 72 2d 65 61 63 68 20 nd.. (for-each
12330 3b 3b 20 6d 6f 6e 74 68 0a 09 20 20 20 28 6c 61 ;; month.. (la
12340 6d 62 64 61 20 28 6d 6f 6e 74 68 29 0a 09 20 20 mbda (month)..
12350 20 20 20 28 66 6f 72 2d 65 61 63 68 20 3b 3b 20 (for-each ;;
12360 64 61 79 6f 66 6d 6f 6e 74 68 0a 09 20 20 20 20 dayofmonth..
12370 20 20 28 6c 61 6d 62 64 61 20 28 64 6f 6d 29 0a (lambda (dom).
12380 09 09 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 28 ..(for-each... (
12390 6c 61 6d 62 64 61 20 28 68 72 29 20 3b 3b 20 68 lambda (hr) ;; h
123a0 6f 75 72 0a 09 09 20 20 20 28 66 6f 72 2d 65 61 our... (for-ea
123b0 63 68 0a 09 09 20 20 20 20 28 6c 61 6d 62 64 61 ch... (lambda
123c0 20 28 6d 69 6e 75 74 65 29 20 3b 3b 20 6d 69 6e (minute) ;; min
123d0 75 74 65 0a 09 09 20 20 20 20 20 20 28 6c 65 74 ute... (let
123e0 20 28 28 63 6f 70 79 2d 6e 6f 77 20 28 61 70 70 ((copy-now (app
123f0 6c 79 20 76 65 63 74 6f 72 20 28 76 65 63 74 6f ly vector (vecto
12400 72 2d 3e 6c 69 73 74 20 6e 6f 77 2d 74 69 6d 65 r->list now-time
12410 29 29 29 29 0a 09 09 09 28 76 65 63 74 6f 72 2d ))))....(vector-
12420 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 20 30 20 set! copy-now 0
12430 30 29 20 3b 3b 20 66 6f 72 63 65 20 73 65 63 6f 0) ;; force seco
12440 6e 64 73 20 74 6f 20 7a 65 72 6f 0a 09 09 09 28 nds to zero....(
12450 76 65 63 74 6f 72 2d 73 65 74 21 20 63 6f 70 79 vector-set! copy
12460 2d 6e 6f 77 20 31 20 6d 69 6e 75 74 65 29 0a 09 -now 1 minute)..
12470 09 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 ..(vector-set! c
12480 6f 70 79 2d 6e 6f 77 20 32 20 68 72 29 0a 09 09 opy-now 2 hr)...
12490 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 6f .(vector-set! co
124a0 70 79 2d 6e 6f 77 20 33 20 64 6f 6d 29 20 20 3b py-now 3 dom) ;
124b0 3b 20 64 6f 6d 20 69 73 20 61 6c 72 65 61 64 79 ; dom is already
124c0 20 63 6f 72 72 65 63 74 65 64 20 66 6f 72 20 7a corrected for z
124d0 65 72 6f 20 72 65 66 65 72 65 6e 63 65 64 0a 09 ero referenced..
124e0 09 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 ..(vector-set! c
124f0 6f 70 79 2d 6e 6f 77 20 34 20 6d 6f 6e 74 68 29 opy-now 4 month)
12500 0a 09 09 09 28 6c 65 74 2a 20 28 28 63 6f 70 79 ....(let* ((copy
12510 2d 6e 6f 77 2d 73 65 63 73 20 28 6c 6f 63 61 6c -now-secs (local
12520 2d 74 69 6d 65 2d 3e 73 65 63 6f 6e 64 73 20 63 -time->seconds c
12530 6f 70 79 2d 6e 6f 77 29 29 0a 09 09 09 20 20 20 opy-now))....
12540 20 20 20 20 28 6e 65 77 2d 63 6f 70 79 20 20 20 (new-copy
12550 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
12560 61 6c 2d 74 69 6d 65 20 63 6f 70 79 2d 6e 6f 77 al-time copy-now
12570 2d 73 65 63 73 29 29 29 20 3b 3b 20 72 65 6d 61 -secs))) ;; rema
12580 6b 65 20 74 68 65 20 74 69 6d 65 20 76 65 63 74 ke the time vect
12590 6f 72 0a 09 09 09 20 20 28 69 66 20 28 6f 72 20 or.... (if (or
125a0 28 6e 6f 74 20 63 64 61 79 6f 66 77 65 65 6b 29 (not cdayofweek)
125b0 0a 09 09 09 09 20 20 28 65 71 75 61 6c 3f 20 28 ..... (equal? (
125c0 76 65 63 74 6f 72 2d 72 65 66 20 6e 65 77 2d 63 vector-ref new-c
125d0 6f 70 79 20 36 29 0a 09 09 09 09 09 20 20 63 64 opy 6)...... cd
125e0 61 79 6f 66 77 65 65 6b 29 29 20 3b 3b 20 69 66 ayofweek)) ;; if
125f0 20 74 68 65 20 64 61 79 20 69 73 20 73 70 65 63 the day is spec
12600 69 66 69 65 64 20 61 6e 64 20 61 20 6d 61 74 63 ified and a matc
12610 68 20 4f 52 20 69 66 20 74 68 65 20 64 61 79 20 h OR if the day
12620 69 73 20 4e 4f 54 20 73 70 65 63 69 66 69 65 64 is NOT specified
12630 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 28 6f .... (if (o
12640 72 20 28 6e 6f 74 20 63 64 61 79 6f 66 6d 6f 6e r (not cdayofmon
12650 74 68 29 0a 09 09 09 09 20 20 20 20 20 20 28 65 th)..... (e
12660 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d 72 65 qual? (vector-re
12670 66 20 6e 65 77 2d 63 6f 70 79 20 33 29 0a 09 09 f new-copy 3)...
12680 09 09 09 20 20 20 20 20 20 28 2b 20 31 20 63 64 ... (+ 1 cd
12690 61 79 6f 66 6d 6f 6e 74 68 29 29 29 20 3b 3b 20 ayofmonth))) ;;
126a0 69 66 20 74 68 65 20 6d 6f 6e 74 68 20 69 73 20 if the month is
126b0 73 70 65 63 69 66 69 65 64 20 61 6e 64 20 61 20 specified and a
126c0 6d 61 74 63 68 20 4f 52 20 69 66 20 74 68 65 20 match OR if the
126d0 6d 6f 6e 74 68 20 69 73 20 4e 4f 54 20 73 70 65 month is NOT spe
126e0 63 69 66 69 65 64 0a 09 09 09 09 20 20 28 68 61 cified..... (ha
126f0 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 61 6c sh-table-set! al
12700 6c 2d 74 69 6d 65 73 20 63 6f 70 79 2d 6e 6f 77 l-times copy-now
12710 2d 73 65 63 73 20 6e 65 77 2d 63 6f 70 79 29 29 -secs new-copy))
12720 29 29 29 29 0a 09 09 20 20 20 20 28 69 66 20 63 ))))... (if c
12730 6d 69 6e 0a 09 09 09 60 28 2c 63 6d 69 6e 29 20 min....`(,cmin)
12740 20 3b 3b 20 69 66 20 67 69 76 65 6e 20 63 6d 69 ;; if given cmi
12750 6e 2c 20 68 61 76 65 20 74 6f 20 75 73 65 20 69 n, have to use i
12760 74 0a 09 09 09 28 6c 69 73 74 20 28 2d 20 6e 6d t....(list (- nm
12770 69 6e 20 31 29 20 6e 6d 69 6e 20 28 2b 20 6e 6d in 1) nmin (+ nm
12780 69 6e 20 31 29 29 29 29 29 20 3b 3b 20 6d 69 6e in 1))))) ;; min
12790 75 74 65 0a 09 09 20 28 69 66 20 63 68 6f 75 72 ute... (if chour
127a0 0a 09 09 20 20 20 20 20 60 28 2c 63 68 6f 75 72 ... `(,chour
127b0 29 0a 09 09 20 20 20 20 20 28 6c 69 73 74 20 28 )... (list (
127c0 2d 20 6e 68 6f 75 72 20 31 29 20 6e 68 6f 75 72 - nhour 1) nhour
127d0 20 28 2b 20 6e 68 6f 75 72 20 31 29 29 29 29 29 (+ nhour 1)))))
127e0 20 3b 3b 20 68 6f 75 72 0a 09 20 20 20 20 20 20 ;; hour..
127f0 28 69 66 20 63 64 61 79 6f 66 6d 6f 6e 74 68 0a (if cdayofmonth.
12800 09 09 20 20 60 28 2c 63 64 61 79 6f 66 6d 6f 6e .. `(,cdayofmon
12810 74 68 29 0a 09 09 20 20 28 6c 69 73 74 20 28 2d th)... (list (-
12820 20 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 31 29 20 ndayofmonth 1)
12830 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 28 2b 20 6e ndayofmonth (+ n
12840 64 61 79 6f 66 6d 6f 6e 74 68 20 31 29 29 29 29 dayofmonth 1))))
12850 29 0a 09 20 20 20 28 69 66 20 63 6d 6f 6e 74 68 ).. (if cmonth
12860 0a 09 20 20 20 20 20 20 20 60 28 2c 63 6d 6f 6e .. `(,cmon
12870 74 68 29 0a 09 20 20 20 20 20 20 20 28 6c 69 73 th).. (lis
12880 74 20 28 2d 20 6e 6d 6f 6e 74 68 20 31 29 20 6e t (- nmonth 1) n
12890 6d 6f 6e 74 68 20 28 2b 20 6e 6d 6f 6e 74 68 20 month (+ nmonth
128a0 31 29 29 29 29 0a 09 20 20 28 6c 65 74 20 28 28 1)))).. (let ((
128b0 62 65 66 6f 72 65 20 23 66 29 0a 09 09 28 69 73 before #f)...(is
128c0 2d 69 6e 20 20 23 66 29 29 0a 09 20 20 20 20 28 -in #f)).. (
128d0 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 20 28 for-each.. (
128e0 6c 61 6d 62 64 61 20 28 6d 6f 6d 65 6e 74 29 0a lambda (moment).
128f0 09 20 20 20 20 20 20 20 28 69 66 20 28 61 6e 64 . (if (and
12900 20 62 65 66 6f 72 65 0a 09 09 09 28 3c 3d 20 62 before....(<= b
12910 65 66 6f 72 65 20 6e 6f 77 2d 73 65 63 6f 6e 64 efore now-second
12920 73 29 0a 09 09 09 28 3e 3d 20 6d 6f 6d 65 6e 74 s)....(>= moment
12930 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 29 29 0a 09 now-seconds))..
12940 09 20 20 20 28 62 65 67 69 6e 0a 09 09 20 20 20 . (begin...
12950 20 20 3b 3b 20 28 70 72 69 6e 74 29 0a 09 09 20 ;; (print)...
12960 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 42 ;; (print "B
12970 65 66 6f 72 65 3a 20 22 20 28 74 69 6d 65 2d 3e efore: " (time->
12980 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d string (seconds-
12990 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 62 65 66 6f >local-time befo
129a0 72 65 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 re)))... ;;
129b0 28 70 72 69 6e 74 20 22 4e 6f 77 3a 20 20 20 20 (print "Now:
129c0 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
129d0 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
129e0 74 69 6d 65 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 time now-seconds
129f0 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 28 70 )))... ;; (p
12a00 72 69 6e 74 20 22 41 66 74 65 72 3a 20 20 22 20 rint "After: "
12a10 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 28 73 (time->string (s
12a20 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 econds->local-ti
12a30 6d 65 20 6d 6f 6d 65 6e 74 29 29 29 0a 09 09 20 me moment)))...
12a40 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4c ;; (print "L
12a50 61 73 74 3a 20 20 20 22 20 28 74 69 6d 65 2d 3e ast: " (time->
12a60 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d string (seconds-
12a70 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6c 61 73 74 >local-time last
12a80 2d 64 6f 6e 65 29 29 29 0a 09 09 20 20 20 20 20 -done)))...
12a90 28 69 66 20 28 3c 20 20 6c 61 73 74 2d 64 6f 6e (if (< last-don
12aa0 65 20 62 65 66 6f 72 65 29 0a 09 09 09 20 28 73 e before).... (s
12ab0 65 74 21 20 69 73 2d 69 6e 20 62 65 66 6f 72 65 et! is-in before
12ac0 29 29 0a 09 09 20 20 20 20 20 29 29 0a 09 20 20 ))... ))..
12ad0 20 20 20 20 20 28 73 65 74 21 20 62 65 66 6f 72 (set! befor
12ae0 65 20 6d 6f 6d 65 6e 74 29 29 0a 09 20 20 20 20 e moment))..
12af0 20 28 73 6f 72 74 20 28 68 61 73 68 2d 74 61 62 (sort (hash-tab
12b00 6c 65 2d 6b 65 79 73 20 61 6c 6c 2d 74 69 6d 65 le-keys all-time
12b10 73 29 20 3c 29 29 0a 09 20 20 20 20 69 73 2d 69 s) <)).. is-i
12b20 6e 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 n)))))..(define
12b30 28 63 6f 6d 6d 6f 6e 3a 65 78 74 65 6e 64 65 64 (common:extended
12b40 2d 63 72 6f 6e 20 20 63 72 6f 6e 2d 73 74 72 20 -cron cron-str
12b50 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 6c now-seconds-in l
12b60 61 73 74 2d 64 6f 6e 65 29 0a 20 20 28 6c 65 74 ast-done). (let
12b70 20 28 28 65 78 70 61 6e 64 65 64 2d 63 72 6f 6e ((expanded-cron
12b80 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 (common:cron-ex
12b90 70 61 6e 64 20 63 72 6f 6e 2d 73 74 72 29 29 29 pand cron-str)))
12ba0 0a 20 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 . (if (string
12bb0 3f 20 65 78 70 61 6e 64 65 64 2d 63 72 6f 6e 29 ? expanded-cron)
12bc0 0a 09 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 ..(common:cron-e
12bd0 76 65 6e 74 20 65 78 70 61 6e 64 65 64 2d 63 72 vent expanded-cr
12be0 6f 6e 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 on now-seconds-i
12bf0 6e 20 6c 61 73 74 2d 64 6f 6e 65 29 0a 09 28 6c n last-done)..(l
12c00 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 20 28 63 et loop ((hed (c
12c10 61 72 20 65 78 70 61 6e 64 65 64 2d 63 72 6f 6e ar expanded-cron
12c20 29 29 0a 09 09 20 20 20 28 74 61 6c 20 28 63 64 ))... (tal (cd
12c30 72 20 65 78 70 61 6e 64 65 64 2d 63 72 6f 6e 29 r expanded-cron)
12c40 29 29 0a 09 20 20 28 69 66 20 28 63 6f 6d 6d 6f )).. (if (commo
12c50 6e 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 68 65 64 n:cron-event hed
12c60 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 now-seconds-in
12c70 6c 61 73 74 2d 64 6f 6e 65 29 0a 09 20 20 20 20 last-done)..
12c80 20 20 23 74 0a 09 20 20 20 20 20 20 28 69 66 20 #t.. (if
12c90 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 20 20 (null? tal)...
12ca0 23 66 0a 09 09 20 20 28 6c 6f 6f 70 20 28 63 61 #f... (loop (ca
12cb0 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 29 r tal)(cdr tal))
12cc0 29 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d ))))))..;;======
12cd0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12ce0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12cf0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d10 0a 3b 3b 20 43 20 4f 20 4c 20 4f 20 52 20 53 0a .;; C O L O R S.
12d20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
12d30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
12d60 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 20 0a ========. .
12d70 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
12d80 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f 72 20 name->iup-color
12d90 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 28 73 name). (case (s
12da0 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 tring->symbol (s
12db0 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 6e tring-downcase n
12dc0 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 64 29 ame)). ((red)
12dd0 20 20 20 20 22 32 32 33 20 33 33 20 34 39 22 29 "223 33 49")
12de0 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 20 22 . ((grey) "
12df0 31 39 32 20 31 39 32 20 31 39 32 22 29 0a 20 20 192 192 192").
12e00 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 35 35 ((orange) "255
12e10 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 28 28 172 13"). ((
12e20 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 69 73 purple) "This is
12e30 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e 2e 22 unfinished ..."
12e40 29 29 29 0a 0a 3b 3b 20 28 64 65 66 69 6e 65 20 )))..;; (define
12e50 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
12e60 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 61 74 r-for-state-stat
12e70 75 73 20 73 74 61 74 65 20 73 74 61 74 75 73 29 us state status)
12e80 0a 3b 3b 20 20 20 28 63 61 73 65 20 28 73 74 72 .;; (case (str
12e90 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 74 ing->symbol stat
12ea0 65 29 0a 3b 3b 20 20 20 20 20 28 28 43 4f 4d 50 e).;; ((COMP
12eb0 4c 45 54 45 44 29 0a 3b 3b 20 20 20 20 20 20 28 LETED).;; (
12ec0 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
12ed0 6d 62 6f 6c 20 73 74 61 74 75 73 29 0a 3b 3b 20 mbol status).;;
12ee0 20 20 20 20 20 20 20 28 28 50 41 53 53 29 20 20 ((PASS)
12ef0 20 20 20 20 20 20 22 37 30 20 20 32 34 39 20 37 "70 249 7
12f00 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 3").;; ((
12f10 57 41 52 4e 20 57 41 49 56 45 44 29 20 22 32 35 WARN WAIVED) "25
12f20 35 20 31 37 32 20 31 33 22 29 0a 3b 3b 20 20 20 5 172 13").;;
12f30 20 20 20 20 20 28 28 53 4b 49 50 29 20 20 20 20 ((SKIP)
12f40 20 20 20 20 22 32 33 30 20 32 33 30 20 30 22 29 "230 230 0")
12f50 0a 3b 3b 20 20 20 20 20 20 20 20 28 65 6c 73 65 .;; (else
12f60 20 22 32 32 33 20 33 33 20 34 39 22 29 29 29 0a "223 33 49"))).
12f70 3b 3b 20 20 20 20 20 28 28 4c 41 55 4e 43 48 45 ;; ((LAUNCHE
12f80 44 29 20 20 20 20 20 20 20 20 20 22 31 30 31 20 D) "101
12f90 31 32 33 20 31 34 32 22 29 0a 3b 3b 20 20 20 20 123 142").;;
12fa0 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 20 20 ((CHECK)
12fb0 20 20 20 20 20 22 32 35 35 20 31 30 30 20 35 30 "255 100 50
12fc0 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 45 4d 4f ").;; ((REMO
12fd0 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 22 35 TEHOSTSTART) "5
12fe0 30 20 20 31 33 30 20 31 39 35 22 29 0a 3b 3b 20 0 130 195").;;
12ff0 20 20 20 20 28 28 52 55 4e 4e 49 4e 47 29 20 20 ((RUNNING)
13000 20 20 20 20 20 20 20 20 22 39 20 20 20 31 33 31 "9 131
13010 20 32 33 32 22 29 0a 3b 3b 20 20 20 20 20 28 28 232").;; ((
13020 4b 49 4c 4c 52 45 51 29 20 20 20 20 20 20 20 20 KILLREQ)
13030 20 20 22 33 39 20 20 38 32 20 20 32 30 36 22 29 "39 82 206")
13040 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c 45 44 .;; ((KILLED
13050 29 20 20 20 20 20 20 20 20 20 20 20 22 32 33 34 ) "234
13060 20 31 30 31 20 31 37 22 29 0a 3b 3b 20 20 20 20 101 17").;;
13070 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 29 20 ((NOT_STARTED)
13080 20 20 20 20 20 22 32 34 30 20 32 34 30 20 32 34 "240 240 24
13090 30 22 29 0a 3b 3b 20 20 20 20 20 28 65 6c 73 65 0").;; (else
130a0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 22 "
130b0 31 39 32 20 31 39 32 20 31 39 32 22 29 29 29 0a 192 192 192"))).
130c0 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
130d0 3a 69 75 70 2d 63 6f 6c 6f 72 2d 3e 72 67 62 2d :iup-color->rgb-
130e0 68 65 78 20 69 6e 73 74 72 29 0a 20 20 28 73 74 hex instr). (st
130f0 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 ring-intersperse
13100 20 0a 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 . (map (lambd
13110 61 20 28 78 29 0a 20 20 20 20 20 20 20 20 20 20 a (x).
13120 28 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e 67 20 (number->string
13130 78 20 31 36 29 29 0a 20 20 20 20 20 20 20 20 28 x 16)). (
13140 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 map string->numb
13150 65 72 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 er.
13160 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 69 6e (string-split in
13170 73 74 72 29 29 29 0a 20 20 20 22 2f 22 29 29 0a str))). "/")).
13180 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
13190 3a 66 61 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e 61 :faux-lock keyna
131a0 6d 65 20 23 21 6b 65 79 20 28 77 61 69 74 2d 74 me #!key (wait-t
131b0 69 6d 65 20 38 29 29 0a 20 20 28 69 66 20 28 72 ime 8)). (if (r
131c0 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 mt:no-sync-get/d
131d0 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 23 efault keyname #
131e0 66 29 20 3b 3b 20 64 6f 20 6e 6f 74 20 62 65 20 f) ;; do not be
131f0 74 65 6d 70 74 65 64 20 74 6f 20 63 6f 6d 70 61 tempted to compa
13200 72 65 20 74 6f 20 70 69 64 2e 20 6c 6f 63 6b 69 re to pid. locki
13210 6e 67 20 69 73 20 61 20 6f 6e 65 2d 73 68 6f 74 ng is a one-shot
13220 20 61 63 74 69 6f 6e 2c 20 69 66 20 61 6c 72 65 action, if alre
13230 61 64 79 20 6c 6f 63 6b 65 64 20 66 6f 72 20 74 ady locked for t
13240 68 69 73 20 70 69 64 20 69 74 20 64 6f 65 73 6e his pid it doesn
13250 27 74 20 61 63 74 75 61 6c 6c 79 20 63 6f 75 6e 't actually coun
13260 74 0a 20 20 20 20 20 20 28 69 66 20 28 3e 20 77 t. (if (> w
13270 61 69 74 2d 74 69 6d 65 20 30 29 0a 09 20 20 28 ait-time 0).. (
13280 62 65 67 69 6e 0a 09 20 20 20 20 28 74 68 72 65 begin.. (thre
13290 61 64 2d 73 6c 65 65 70 21 20 31 29 0a 09 20 20 ad-sleep! 1)..
132a0 20 20 28 69 66 20 28 65 71 3f 20 77 61 69 74 2d (if (eq? wait-
132b0 74 69 6d 65 20 31 29 20 3b 3b 20 6f 6e 6c 79 20 time 1) ;; only
132c0 6f 6e 65 20 73 65 63 6f 6e 64 20 6c 65 66 74 2c one second left,
132d0 20 73 74 65 61 6c 20 74 68 65 20 6c 6f 63 6b 0a steal the lock.
132e0 09 09 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 ..(begin... (de
132f0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
13300 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
13310 72 74 2a 20 22 73 74 65 61 6c 69 6e 67 20 6c 6f rt* "stealing lo
13320 63 6b 20 66 6f 72 20 22 20 6b 65 79 6e 61 6d 65 ck for " keyname
13330 29 0a 09 09 20 20 28 63 6f 6d 6d 6f 6e 3a 66 61 )... (common:fa
13340 75 78 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e 61 6d ux-unlock keynam
13350 65 20 66 6f 72 63 65 3a 20 23 74 29 29 29 0a 09 e force: #t)))..
13360 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 61 75 78 (common:faux
13370 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 20 77 61 -lock keyname wa
13380 69 74 2d 74 69 6d 65 3a 20 28 2d 20 77 61 69 74 it-time: (- wait
13390 2d 74 69 6d 65 20 31 29 29 29 0a 09 20 20 23 66 -time 1))).. #f
133a0 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ). (begin.
133b0 20 20 20 20 20 20 20 28 72 6d 74 3a 6e 6f 2d 73 (rmt:no-s
133c0 79 6e 63 2d 73 65 74 20 6b 65 79 6e 61 6d 65 20 ync-set keyname
133d0 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 (conc (current-p
133e0 72 6f 63 65 73 73 2d 69 64 29 29 29 0a 20 20 20 rocess-id))).
133f0 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 63 6f (equal? (co
13400 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 nc (current-proc
13410 65 73 73 2d 69 64 29 29 20 28 63 6f 6e 63 20 28 ess-id)) (conc (
13420 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f rmt:no-sync-get/
13430 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 default keyname
13440 23 66 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e #f))))))..(defin
13450 65 20 28 63 6f 6d 6d 6f 6e 3a 66 61 75 78 2d 75 e (common:faux-u
13460 6e 6c 6f 63 6b 20 6b 65 79 6e 61 6d 65 20 23 21 nlock keyname #!
13470 6b 65 79 20 28 66 6f 72 63 65 20 23 66 29 29 0a key (force #f)).
13480 20 20 28 69 66 20 28 6f 72 20 66 6f 72 63 65 20 (if (or force
13490 28 65 71 75 61 6c 3f 20 28 63 6f 6e 63 20 28 63 (equal? (conc (c
134a0 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
134b0 64 29 29 20 28 63 6f 6e 63 20 28 72 6d 74 3a 6e d)) (conc (rmt:n
134c0 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 61 75 o-sync-get/defau
134d0 6c 74 20 6b 65 79 6e 61 6d 65 20 23 66 29 29 29 lt keyname #f)))
134e0 29 0a 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 ). (begin.
134f0 20 20 20 20 20 20 20 28 69 66 20 28 72 6d 74 3a (if (rmt:
13500 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f 64 65 66 61 no-sync-get/defa
13510 75 6c 74 20 6b 65 79 6e 61 6d 65 20 23 66 29 20 ult keyname #f)
13520 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 64 65 6c (rmt:no-sync-del
13530 21 20 6b 65 79 6e 61 6d 65 29 29 0a 20 20 20 20 ! keyname)).
13540 20 20 20 20 23 74 29 0a 20 20 20 20 20 20 23 66 #t). #f
13550 29 29 0a 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 )).. .(define (
13560 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 75 6e 6e 69 6e common:in-runnin
13570 67 2d 74 65 73 74 3f 29 0a 20 20 28 61 6e 64 20 g-test?). (and
13580 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
13590 65 78 65 63 75 74 65 22 29 20 28 67 65 74 2d 65 execute") (get-e
135a0 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
135b0 62 6c 65 20 22 4d 54 5f 43 4d 44 49 4e 46 4f 22 ble "MT_CMDINFO"
135c0 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
135d0 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 mmon:get-color-f
135e0 72 6f 6d 2d 73 74 61 74 75 73 20 73 74 61 74 75 rom-status statu
135f0 73 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 s). (cond. ((
13600 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 equal? status "P
13610 41 53 53 22 29 20 20 20 20 22 67 72 65 65 6e 22 ASS") "green"
13620 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 ). ((equal? st
13630 61 74 75 73 20 22 46 41 49 4c 22 29 20 20 20 20 atus "FAIL")
13640 22 72 65 64 22 29 0a 20 20 20 28 28 65 71 75 61 "red"). ((equa
13650 6c 3f 20 73 74 61 74 75 73 20 22 57 41 52 4e 22 l? status "WARN"
13660 29 20 20 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 ) "orange").
13670 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 ((equal? statu
13680 73 20 22 4b 49 4c 4c 45 44 22 29 20 20 22 6f 72 s "KILLED") "or
13690 61 6e 67 65 22 29 0a 20 20 20 28 28 65 71 75 61 ange"). ((equa
136a0 6c 3f 20 73 74 61 74 75 73 20 22 4b 49 4c 4c 52 l? status "KILLR
136b0 45 51 22 29 20 22 70 75 72 70 6c 65 22 29 0a 20 EQ") "purple").
136c0 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 ((equal? statu
136d0 73 20 22 52 55 4e 4e 49 4e 47 22 29 20 22 62 6c s "RUNNING") "bl
136e0 75 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ue"). ((equal?
136f0 20 73 74 61 74 75 73 20 22 41 42 4f 52 54 22 29 status "ABORT")
13700 20 20 20 22 62 72 6f 77 6e 22 29 0a 20 20 20 28 "brown"). (
13710 65 6c 73 65 20 22 62 6c 61 63 6b 22 29 29 29 0a else "black"))).
13720 0a 3b 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;; ;;==========
13730 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13740 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13750 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13760 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
13770 3b 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 53 20 47 ;; N A N O M S G
13780 20 20 20 43 20 4c 20 49 20 45 20 4e 20 54 0a 3b C L I E N T.;
13790 3b 20 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ; ;;============
137a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
137b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
137c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
137d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 0a 3b ==========.;; .;
137e0 3b 20 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e ; .;; .;; (defin
137f0 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e 64 2d 64 e (common:send-d
13800 62 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 61 6e 67 board-main-chang
13810 65 64 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 ed).;; (let* (
13820 28 64 61 73 68 62 6f 61 72 64 2d 69 70 73 20 28 (dashboard-ips (
13830 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 62 6f 61 mddb:get-dashboa
13840 72 64 73 29 29 29 0a 3b 3b 20 20 20 20 20 28 66 rds))).;; (f
13850 6f 72 2d 65 61 63 68 0a 3b 3b 20 20 20 20 20 20 or-each.;;
13860 28 6c 61 6d 62 64 61 20 28 69 70 61 64 72 29 0a (lambda (ipadr).
13870 3b 3b 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 ;; (let*
13880 28 28 73 6f 63 20 28 63 6f 6d 6d 6f 6e 3a 6f 70 ((soc (common:op
13890 65 6e 2d 6e 6d 2d 72 65 71 20 28 63 6f 6e 63 20 en-nm-req (conc
138a0 22 74 63 70 3a 2f 2f 22 20 69 70 61 64 72 29 29 "tcp://" ipadr))
138b0 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 6d 73 67 ).;; . (msg
138c0 20 28 63 6f 6e 63 20 22 6d 61 69 6e 20 22 20 2a (conc "main " *
138d0 74 6f 70 70 61 74 68 2a 29 29 0a 3b 3b 20 09 20 toppath*)).;; .
138e0 20 20 20 20 20 28 72 65 73 20 28 63 6f 6d 6d 6f (res (commo
138f0 6e 3a 6e 6d 2d 73 65 6e 64 2d 72 65 63 65 69 76 n:nm-send-receiv
13900 65 2d 74 69 6d 65 6f 75 74 20 73 6f 63 20 6d 73 e-timeout soc ms
13910 67 29 29 29 0a 3b 3b 20 09 20 28 69 66 20 28 6e g))).;; . (if (n
13920 6f 74 20 72 65 73 29 20 3b 3b 20 63 6f 75 6c 64 ot res) ;; could
13930 6e 27 74 20 72 65 61 63 68 20 74 68 61 74 20 64 n't reach that d
13940 61 73 68 62 6f 61 72 64 20 2d 20 72 65 6d 6f 76 ashboard - remov
13950 65 20 69 74 20 66 72 6f 6d 20 64 62 0a 3b 3b 20 e it from db.;;
13960 09 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 . (print "ER
13970 52 4f 52 3a 20 63 6f 75 6c 64 6e 27 74 20 72 65 ROR: couldn't re
13980 61 63 68 20 64 61 73 68 62 6f 61 72 64 20 22 20 ach dashboard "
13990 69 70 61 64 72 29 29 0a 3b 3b 20 09 20 72 65 73 ipadr)).;; . res
139a0 29 29 0a 3b 3b 20 20 20 20 20 20 64 61 73 68 62 )).;; dashb
139b0 6f 61 72 64 2d 69 70 73 29 29 29 0a 3b 3b 20 20 oard-ips))).;;
139c0 20 20 20 0a 3b 3b 20 20 20 20 20 0a 3b 3b 20 3b .;; .;; ;
139d0 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
139e0 3d 3d 3d 3d 3d 3d 3d 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 0a 3b 3b 20 3b 3b 20 44 20 =======.;; ;; D
13a20 41 20 53 20 48 20 42 20 4f 20 41 20 52 20 44 20 A S H B O A R D
13a30 20 20 44 20 42 20 0a 3b 3b 20 3b 3b 3d 3d 3d 3d D B .;; ;;====
13a40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 3b 3b 20 0a 3b 3b 20 28 64 65 66 69 6e ==.;; .;; (defin
13a90 65 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 e (mddb:open-db)
13aa0 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 64 62 .;; (let* ((db
13ab0 20 28 6f 70 65 6e 2d 64 61 74 61 62 61 73 65 20 (open-database
13ac0 28 63 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 (conc (get-envir
13ad0 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
13ae0 22 48 4f 4d 45 22 29 20 22 2f 2e 64 61 73 68 62 "HOME") "/.dashb
13af0 6f 61 72 64 2e 64 62 22 29 29 29 29 0a 3b 3b 20 oard.db")))).;;
13b00 20 20 20 20 28 73 65 74 2d 62 75 73 79 2d 68 61 (set-busy-ha
13b10 6e 64 6c 65 72 21 20 64 62 20 28 62 75 73 79 2d ndler! db (busy-
13b20 74 69 6d 65 6f 75 74 20 31 30 30 30 30 29 29 0a timeout 10000)).
13b30 3b 3b 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 ;; (for-each
13b40 0a 3b 3b 20 20 20 20 20 20 28 6c 61 6d 62 64 61 .;; (lambda
13b50 20 28 71 72 79 29 0a 3b 3b 20 20 20 20 20 20 20 (qry).;;
13b60 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 71 (exec (sql db q
13b70 72 79 29 29 29 0a 3b 3b 20 20 20 20 20 20 28 6c ry))).;; (l
13b80 69 73 74 20 0a 3b 3b 20 20 20 20 20 20 20 22 43 ist .;; "C
13b90 52 45 41 54 45 20 54 41 42 4c 45 20 49 46 20 4e REATE TABLE IF N
13ba0 4f 54 20 45 58 49 53 54 53 20 76 61 72 73 20 20 OT EXISTS vars
13bb0 20 20 20 20 20 28 69 64 20 49 4e 54 45 47 45 52 (id INTEGER
13bc0 20 50 52 49 4d 41 52 59 20 4b 45 59 2c 6b 65 79 PRIMARY KEY,key
13bd0 20 54 45 58 54 2c 20 76 61 6c 20 54 45 58 54 2c TEXT, val TEXT,
13be0 20 43 4f 4e 53 54 52 41 49 4e 54 20 76 61 72 73 CONSTRAINT vars
13bf0 63 6f 6e 73 74 72 61 69 6e 74 20 55 4e 49 51 55 constraint UNIQU
13c00 45 20 28 6b 65 79 29 29 3b 22 0a 3b 3b 20 20 20 E (key));".;;
13c10 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 4c "CREATE TABL
13c20 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 20 E IF NOT EXISTS
13c30 64 61 73 68 62 6f 61 72 64 73 20 28 0a 3b 3b 20 dashboards (.;;
13c40 20 20 20 20 20 20 20 20 20 20 69 64 20 20 20 20 id
13c50 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 52 49 INTEGER PRI
13c60 4d 41 52 59 20 4b 45 59 2c 0a 3b 3b 20 20 20 20 MARY KEY,.;;
13c70 20 20 20 20 20 20 20 70 69 64 20 20 20 20 20 20 pid
13c80 20 20 49 4e 54 45 47 45 52 2c 0a 3b 3b 20 20 20 INTEGER,.;;
13c90 20 20 20 20 20 20 20 20 75 73 65 72 6e 61 6d 65 username
13ca0 20 20 20 54 45 58 54 2c 0a 3b 3b 20 20 20 20 20 TEXT,.;;
13cb0 20 20 20 20 20 20 68 6f 73 74 6e 61 6d 65 20 20 hostname
13cc0 20 54 45 58 54 2c 0a 3b 3b 20 20 20 20 20 20 20 TEXT,.;;
13cd0 20 20 20 20 69 70 61 64 64 72 20 20 20 20 20 54 ipaddr T
13ce0 45 58 54 2c 0a 3b 3b 20 20 20 20 20 20 20 20 20 EXT,.;;
13cf0 20 20 70 6f 72 74 6e 75 6d 20 20 20 20 49 4e 54 portnum INT
13d00 45 47 45 52 2c 0a 3b 3b 20 20 20 20 20 20 20 20 EGER,.;;
13d10 20 20 20 73 74 61 72 74 5f 74 69 6d 65 20 54 49 start_time TI
13d20 4d 45 53 54 41 4d 50 20 44 45 46 41 55 4c 54 20 MESTAMP DEFAULT
13d30 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 (strftime('%s','
13d40 6e 6f 77 27 29 29 2c 0a 3b 3b 20 20 20 20 20 20 now')),.;;
13d50 20 20 20 20 20 20 20 20 43 4f 4e 53 54 52 41 49 CONSTRAI
13d60 4e 54 20 68 6f 73 74 70 6f 72 74 20 55 4e 49 51 NT hostport UNIQ
13d70 55 45 20 28 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 UE (hostname,por
13d80 74 6e 75 6d 29 0a 3b 3b 20 20 20 20 20 20 20 20 tnum).;;
13d90 20 29 3b 22 0a 3b 3b 20 20 20 20 20 20 20 29 29 );".;; ))
13da0 0a 3b 3b 20 20 20 20 20 64 62 29 29 0a 3b 3b 20 .;; db)).;;
13db0 0a 3b 3b 20 3b 3b 20 72 65 67 69 73 74 65 72 20 .;; ;; register
13dc0 61 20 64 61 73 68 62 6f 61 72 64 20 0a 3b 3b 20 a dashboard .;;
13dd0 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 20 28 6d ;;.;; (define (m
13de0 64 64 62 3a 72 65 67 69 73 74 65 72 2d 64 61 73 ddb:register-das
13df0 68 62 6f 61 72 64 20 70 6f 72 74 29 0a 3b 3b 20 hboard port).;;
13e00 20 20 28 6c 65 74 2a 20 28 28 70 69 64 20 20 20 (let* ((pid
13e10 20 20 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 (current-proc
13e20 65 73 73 2d 69 64 29 29 0a 3b 3b 20 09 20 28 68 ess-id)).;; . (h
13e30 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f 73 ostname (get-hos
13e40 74 2d 6e 61 6d 65 29 29 0a 3b 3b 20 09 20 28 69 t-name)).;; . (i
13e50 70 61 64 64 72 20 20 20 28 73 65 72 76 65 72 3a paddr (server:
13e60 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 get-best-guess-a
13e70 64 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 ddress hostname)
13e80 29 0a 3b 3b 20 09 20 28 75 73 65 72 6e 61 6d 65 ).;; . (username
13e90 20 28 63 75 72 72 65 6e 74 2d 75 73 65 72 2d 6e (current-user-n
13ea0 61 6d 65 29 29 20 3b 3b 20 28 63 61 72 20 75 73 ame)) ;; (car us
13eb0 65 72 69 6e 66 6f 29 29 29 0a 3b 3b 20 09 20 28 erinfo))).;; . (
13ec0 64 62 20 20 20 20 20 20 28 6d 64 64 62 3a 6f 70 db (mddb:op
13ed0 65 6e 2d 64 62 29 29 29 0a 3b 3b 20 20 20 20 20 en-db))).;;
13ee0 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 (print "Register
13ef0 20 6d 6f 6e 69 74 6f 72 2c 20 70 69 64 3a 20 22 monitor, pid: "
13f00 20 70 69 64 20 22 2c 20 68 6f 73 74 6e 61 6d 65 pid ", hostname
13f10 3a 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 2c 20 : " hostname ",
13f20 70 6f 72 74 3a 20 22 20 70 6f 72 74 20 22 2c 20 port: " port ",
13f30 75 73 65 72 6e 61 6d 65 3a 20 22 20 75 73 65 72 username: " user
13f40 6e 61 6d 65 29 0a 3b 3b 20 20 20 20 20 28 65 78 name).;; (ex
13f50 65 63 20 28 73 71 6c 20 64 62 20 22 49 4e 53 45 ec (sql db "INSE
13f60 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 49 4e RT OR REPLACE IN
13f70 54 4f 20 64 61 73 68 62 6f 61 72 64 73 20 28 70 TO dashboards (p
13f80 69 64 2c 75 73 65 72 6e 61 6d 65 2c 68 6f 73 74 id,username,host
13f90 6e 61 6d 65 2c 69 70 61 64 64 72 2c 70 6f 72 74 name,ipaddr,port
13fa0 6e 75 6d 29 20 56 41 4c 55 45 53 20 28 3f 2c 3f num) VALUES (?,?
13fb0 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 3b 3b 20 09 20 ,?,?,?);").;; .
13fc0 20 20 70 69 64 20 75 73 65 72 6e 61 6d 65 20 68 pid username h
13fd0 6f 73 74 6e 61 6d 65 20 69 70 61 64 64 72 20 70 ostname ipaddr p
13fe0 6f 72 74 29 0a 3b 3b 20 20 20 20 20 28 63 6c 6f ort).;; (clo
13ff0 73 65 2d 64 61 74 61 62 61 73 65 20 64 62 29 29 se-database db))
14000 29 0a 3b 3b 20 0a 3b 3b 20 3b 3b 20 75 6e 72 65 ).;; .;; ;; unre
14010 67 69 73 74 65 72 20 61 20 6d 6f 6e 69 74 6f 72 gister a monitor
14020 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e .;; ;;.;; (defin
14030 65 20 28 6d 64 64 62 3a 75 6e 72 65 67 69 73 74 e (mddb:unregist
14040 65 72 2d 64 61 73 68 62 6f 61 72 64 20 68 6f 73 er-dashboard hos
14050 74 20 70 6f 72 74 29 0a 3b 3b 20 20 20 28 6c 65 t port).;; (le
14060 74 2a 20 28 28 64 62 20 20 20 20 20 20 28 6d 64 t* ((db (md
14070 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 3b 3b db:open-db))).;;
14080 20 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 67 (print "Reg
14090 69 73 74 65 72 20 75 6e 72 65 67 69 73 74 65 72 ister unregister
140a0 20 6d 6f 6e 69 74 6f 72 2c 20 68 6f 73 74 3a 70 monitor, host:p
140b0 6f 72 74 3d 22 20 68 6f 73 74 20 22 3a 22 20 70 ort=" host ":" p
140c0 6f 72 74 29 0a 3b 3b 20 20 20 20 20 28 65 78 65 ort).;; (exe
140d0 63 20 28 73 71 6c 20 64 62 20 22 44 45 4c 45 54 c (sql db "DELET
140e0 45 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 E FROM dashboard
140f0 73 20 57 48 45 52 45 20 68 6f 73 74 6e 61 6d 65 s WHERE hostname
14100 3d 3f 20 41 4e 44 20 70 6f 72 74 6e 75 6d 3d 3f =? AND portnum=?
14110 3b 22 29 20 68 6f 73 74 20 70 6f 72 74 29 0a 3b ;") host port).;
14120 3b 20 20 20 20 20 28 63 6c 6f 73 65 2d 64 61 74 ; (close-dat
14130 61 62 61 73 65 20 64 62 29 29 29 0a 3b 3b 20 0a abase db))).;; .
14140 3b 3b 20 3b 3b 20 67 65 74 20 72 65 67 69 73 74 ;; ;; get regist
14150 65 72 65 64 20 64 61 73 68 62 6f 61 72 64 73 0a ered dashboards.
14160 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e 65 ;; ;;.;; (define
14170 20 28 6d 64 64 62 3a 67 65 74 2d 64 61 73 68 62 (mddb:get-dashb
14180 6f 61 72 64 73 29 0a 3b 3b 20 20 20 28 6c 65 74 oards).;; (let
14190 20 28 28 64 62 20 28 6d 64 64 62 3a 6f 70 65 6e ((db (mddb:open
141a0 2d 64 62 29 29 29 0a 3b 3b 20 20 20 20 20 28 71 -db))).;; (q
141b0 75 65 72 79 20 66 65 74 63 68 2d 63 6f 6c 75 6d uery fetch-colum
141c0 6e 0a 3b 3b 20 09 20 20 20 28 73 71 6c 20 64 62 n.;; . (sql db
141d0 20 22 53 45 4c 45 43 54 20 69 70 61 64 64 72 20 "SELECT ipaddr
141e0 7c 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 74 6e 75 || ':' || portnu
141f0 6d 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 m FROM dashboard
14200 73 3b 22 29 29 29 29 0a 20 20 20 20 0a 3b 3b 3d s;")))). .;;=
14210 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14220 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14230 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14240 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14250 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 =====.;; T E S
14260 54 20 20 20 4c 20 41 20 55 20 4e 20 43 20 48 20 T L A U N C H
14270 49 20 4e 20 47 20 20 20 50 20 45 20 52 20 20 20 I N G P E R
14280 49 20 54 20 45 20 4d 20 20 20 57 20 49 20 54 20 I T E M W I T
14290 48 20 20 20 48 20 4f 20 53 20 54 20 20 20 54 20 H H O S T T
142a0 59 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d Y P E S.;;======
142b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142f0 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 73 5d 0a .;; .;; [hosts].
14300 3b 3b 20 61 72 6d 20 63 75 62 69 65 30 31 20 63 ;; arm cubie01 c
14310 75 62 69 65 30 32 0a 3b 3b 20 78 38 36 5f 36 34 ubie02.;; x86_64
14320 20 7a 65 75 73 20 78 65 6e 61 20 6d 79 74 68 30 zeus xena myth0
14330 31 0a 3b 3b 20 61 6c 6c 68 6f 73 74 73 20 23 7b 1.;; allhosts #{
14340 67 20 68 6f 73 74 73 20 61 72 6d 7d 20 23 7b 67 g hosts arm} #{g
14350 20 68 6f 73 74 73 20 78 38 36 5f 36 34 7d 0a 3b hosts x86_64}.;
14360 3b 20 0a 3b 3b 20 5b 68 6f 73 74 2d 74 79 70 65 ; .;; [host-type
14370 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 23 4d s].;; general #M
14380 54 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 TLOWESTLOAD #{g
14390 68 6f 73 74 73 20 61 6c 6c 68 6f 73 74 73 7d 0a hosts allhosts}.
143a0 3b 3b 20 61 72 6d 20 20 20 20 20 23 4d 54 4c 4f ;; arm #MTLO
143b0 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 68 6f 73 WESTLOAD #{g hos
143c0 74 73 20 61 72 6d 7d 0a 3b 3b 20 6e 62 67 65 6e ts arm}.;; nbgen
143d0 65 72 61 6c 20 6e 62 6a 6f 62 20 72 75 6e 20 4a eral nbjob run J
143e0 4f 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f 67 20 24 OBCOMMAND -log $
143f0 4d 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 4d 54 5f MT_LINKTREE/$MT_
14400 54 41 52 47 45 54 2f 24 4d 54 5f 52 55 4e 4e 41 TARGET/$MT_RUNNA
14410 4d 45 2e 24 4d 54 5f 54 45 53 54 4e 41 4d 45 2d ME.$MT_TESTNAME-
14420 24 4d 54 5f 49 54 45 4d 5f 50 41 54 48 2e 6c 67 $MT_ITEM_PATH.lg
14430 6f 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 6e 63 68 o.;; .;; [launch
14440 65 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 74 75 70 ers].;; envsetup
14450 20 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 6f 72 2f general.;; xor/
14460 25 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 25 20 6e %/n 4C16G.;; % n
14470 62 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a 3b 3b 20 bgeneral.;; .;;
14480 5b 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b 20 23 20 [jobtools].;; #
14490 69 66 20 64 65 66 69 6e 65 64 20 61 6e 64 20 6e if defined and n
144a0 6f 74 20 22 6e 6f 22 20 66 6c 65 78 69 2d 6c 61 ot "no" flexi-la
144b0 75 6e 63 68 65 72 20 77 69 6c 6c 20 62 79 70 61 uncher will bypa
144c0 73 73 20 22 6c 61 75 6e 63 68 65 72 22 20 75 6e ss "launcher" un
144d0 6c 65 73 73 20 6e 6f 20 6d 61 74 63 68 2e 0a 3b less no match..;
144e0 3b 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 ; flexi-launcher
144f0 20 79 65 73 20 20 0a 3b 3b 20 6c 61 75 6e 63 68 yes .;; launch
14500 65 72 20 6e 62 66 61 6b 65 0a 3b 3b 0a 28 64 65 er nbfake.;;.(de
14510 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
14520 2d 6c 61 75 6e 63 68 65 72 20 63 6f 6e 66 69 67 -launcher config
14530 64 61 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 dat testname ite
14540 6d 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 mpath). (let ((
14550 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 fallback-launche
14560 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
14570 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 p configdat "job
14580 74 6f 6f 6c 73 22 20 22 6c 61 75 6e 63 68 65 72 tools" "launcher
14590 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e "))). (if (an
145a0 64 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 d (configf:looku
145b0 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 p configdat "job
145c0 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 tools" "flexi-la
145d0 75 6e 63 68 65 72 22 29 20 3b 3b 20 6f 76 65 72 uncher") ;; over
145e0 72 69 64 65 73 20 6c 61 75 6e 63 68 65 72 0a 09 rides launcher..
145f0 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c (not (equal
14600 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ? (configf:looku
14610 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 p configdat "job
14620 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 tools" "flexi-la
14630 75 6e 63 68 65 72 22 29 20 22 6e 6f 22 29 29 29 uncher") "no")))
14640 0a 09 28 6c 65 74 2a 20 28 28 6c 61 75 6e 63 68 ..(let* ((launch
14650 65 72 73 20 20 20 20 20 20 20 20 20 28 68 61 73 ers (has
14660 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
14670 75 6c 74 20 63 6f 6e 66 69 67 64 61 74 20 22 6c ult configdat "l
14680 61 75 6e 63 68 65 72 73 22 20 27 28 29 29 29 29 aunchers" '())))
14690 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c .. (if (null? l
146a0 61 75 6e 63 68 65 72 73 29 0a 09 20 20 20 20 20 aunchers)..
146b0 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 fallback-launch
146c0 65 72 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c er.. (let l
146d0 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 6c oop ((hed (car l
146e0 61 75 6e 63 68 65 72 73 29 29 0a 09 09 09 20 28 aunchers)).... (
146f0 74 61 6c 20 28 63 64 72 20 6c 61 75 6e 63 68 65 tal (cdr launche
14700 72 73 29 29 29 0a 09 09 28 6c 65 74 20 28 28 70 rs)))...(let ((p
14710 61 74 74 20 20 20 20 20 20 28 63 61 72 20 68 65 att (car he
14720 64 29 29 0a 09 09 20 20 20 20 20 20 28 68 6f 73 d))... (hos
14730 74 2d 74 79 70 65 20 28 63 61 64 72 20 68 65 64 t-type (cadr hed
14740 29 29 29 0a 09 09 20 20 28 69 66 20 28 74 65 73 )))... (if (tes
14750 74 73 3a 6d 61 74 63 68 20 70 61 74 74 20 74 65 ts:match patt te
14760 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 stname itempath)
14770 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
14780 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
14790 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d info 2 *default-
147a0 6c 6f 67 2d 70 6f 72 74 2a 20 22 48 61 76 65 20 log-port* "Have
147b0 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 6d flexi-launcher m
147c0 61 74 63 68 20 66 6f 72 20 22 20 74 65 73 74 6e atch for " testn
147d0 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 ame "/" itempath
147e0 20 22 20 3d 20 22 20 68 6f 73 74 2d 74 79 70 65 " = " host-type
147f0 29 0a 09 09 09 28 6c 65 74 20 28 28 6c 61 75 6e )....(let ((laun
14800 63 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f cher (configf:lo
14810 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 okup configdat "
14820 68 6f 73 74 2d 74 79 70 65 73 22 20 68 6f 73 74 host-types" host
14830 2d 74 79 70 65 29 29 29 0a 09 09 09 20 20 28 69 -type))).... (i
14840 66 20 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 f launcher....
14850 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 61 75 6e (let* ((laun
14860 63 68 65 72 2d 70 61 72 74 73 20 28 73 74 72 69 cher-parts (stri
14870 6e 67 2d 73 70 6c 69 74 20 6c 61 75 6e 63 68 65 ng-split launche
14880 72 29 29 0a 09 09 09 09 20 20 20 20 20 28 6c 61 r))..... (la
14890 75 6e 63 68 65 72 2d 65 78 65 20 20 20 28 63 61 uncher-exe (ca
148a0 72 20 6c 61 75 6e 63 68 65 72 2d 70 61 72 74 73 r launcher-parts
148b0 29 29 29 0a 09 09 09 09 28 69 66 20 28 65 71 75 ))).....(if (equ
148c0 61 6c 3f 20 6c 61 75 6e 63 68 65 72 2d 65 78 65 al? launcher-exe
148d0 20 22 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 22 "#MTLOWESTLOAD"
148e0 29 20 3b 3b 20 74 68 69 73 20 69 73 20 6f 75 72 ) ;; this is our
148f0 20 73 70 65 63 69 61 6c 20 63 61 73 65 2c 20 77 special case, w
14900 65 20 77 69 6c 6c 20 66 69 6e 64 20 74 68 65 20 e will find the
14910 6c 6f 77 65 73 74 20 6c 6f 61 64 20 61 6e 64 20 lowest load and
14920 63 72 61 66 74 20 61 20 6e 62 66 61 6b 65 20 63 craft a nbfake c
14930 6f 6d 6d 61 6e 64 6c 69 6e 65 0a 09 09 09 09 20 ommandline.....
14940 20 20 20 28 6c 65 74 20 28 28 74 61 72 67 2d 68 (let ((targ-h
14950 6f 73 74 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ost (common:get-
14960 6c 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 least-loaded-hos
14970 74 20 28 63 64 72 20 6c 61 75 6e 63 68 65 72 2d t (cdr launcher-
14980 70 61 72 74 73 29 29 29 29 0a 09 09 09 09 20 20 parts)))).....
14990 20 20 20 20 28 63 6f 6e 63 20 22 72 65 6d 72 75 (conc "remru
149a0 6e 20 22 20 74 61 72 67 2d 68 6f 73 74 29 29 0a n " targ-host)).
149b0 09 09 09 09 20 20 20 20 6c 61 75 6e 63 68 65 72 .... launcher
149c0 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 )).... (beg
149d0 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 in.....(debug:pr
149e0 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
149f0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
14a00 41 52 4e 49 4e 47 3a 20 6e 6f 20 6c 61 75 6e 63 ARNING: no launc
14a10 68 65 72 20 66 6f 75 6e 64 20 66 6f 72 20 68 6f her found for ho
14a20 73 74 2d 74 79 70 65 20 22 20 68 6f 73 74 2d 74 st-type " host-t
14a30 79 70 65 29 0a 09 09 09 09 28 69 66 20 28 6e 75 ype).....(if (nu
14a40 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 20 ll? tal).....
14a50 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 fallback-launch
14a60 65 72 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 er..... (loop
14a70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
14a80 61 6c 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 al)))))))...
14a90 20 20 3b 3b 20 6e 6f 20 6d 61 74 63 68 2c 20 74 ;; no match, t
14aa0 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 ry again...
14ab0 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
14ac0 0a 09 09 09 20 20 66 61 6c 6c 62 61 63 6b 2d 6c .... fallback-l
14ad0 61 75 6e 63 68 65 72 0a 09 09 09 20 20 28 6c 6f auncher.... (lo
14ae0 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
14af0 20 74 61 6c 29 29 29 29 29 29 29 29 0a 09 66 61 tal))))))))..fa
14b00 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 29 llback-launcher)
14b10 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d )). .;;========
14b20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
14b60 3b 20 44 20 41 20 53 20 48 20 42 20 4f 20 41 20 ; D A S H B O A
14b70 52 20 44 20 20 20 55 20 53 20 45 20 52 20 20 20 R D U S E R
14b80 56 20 49 20 45 20 57 20 53 0a 3b 3b 3d 3d 3d 3d V I E W S.;;====
14b90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ba0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14bc0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14bd0 3d 3d 0a 0a 3b 3b 20 66 69 72 73 74 20 72 65 61 ==..;; first rea
14be0 64 20 7e 2f 76 69 65 77 73 2e 63 6f 6e 66 69 67 d ~/views.config
14bf0 20 69 66 20 69 74 20 65 78 69 73 74 73 2c 20 74 if it exists, t
14c00 68 65 6e 20 72 65 61 64 20 24 4d 54 52 41 48 2f hen read $MTRAH/
14c10 76 69 65 77 73 2e 63 6f 6e 66 69 67 20 69 66 20 views.config if
14c20 69 74 20 65 78 69 73 74 73 0a 3b 3b 0a 28 64 65 it exists.;;.(de
14c30 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 61 fine (common:loa
14c40 64 2d 76 69 65 77 73 2d 63 6f 6e 66 69 67 29 0a d-views-config).
14c50 20 20 28 6c 65 74 2a 20 28 28 76 69 65 77 2d 63 (let* ((view-c
14c60 66 67 64 61 74 20 20 20 20 28 6d 61 6b 65 2d 68 fgdat (make-h
14c70 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 68 ash-table)).. (h
14c80 6f 6d 65 2d 63 66 67 66 69 6c 65 20 20 20 28 63 ome-cfgfile (c
14c90 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e onc (get-environ
14ca0 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 ment-variable "H
14cb0 4f 4d 45 22 29 20 22 2f 2e 6d 74 76 69 65 77 73 OME") "/.mtviews
14cc0 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 6d 74 .config")).. (mt
14cd0 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 28 63 6f home-cfgfile (co
14ce0 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e nc *toppath* "/.
14cf0 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 29 mtviews.config")
14d00 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d )). (if (comm
14d10 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
14d20 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a mthome-cfgfile).
14d30 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 6d 74 .(read-config mt
14d40 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 65 home-cfgfile vie
14d50 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 20 w-cfgdat #t)).
14d60 20 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 68 65 ;; we load the
14d70 20 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 20 41 home dir file A
14d80 46 54 45 52 20 74 68 65 20 4d 54 52 41 48 20 66 FTER the MTRAH f
14d90 69 6c 65 20 73 6f 20 74 68 65 20 75 73 65 72 20 ile so the user
14da0 63 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 74 74 can clobber sett
14db0 69 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e 69 6e ings when runnin
14dc0 67 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 20 g the dashboard
14dd0 69 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 72 65 in read-only are
14de0 61 73 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d as. (if (comm
14df0 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
14e00 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a 09 28 home-cfgfile)..(
14e10 72 65 61 64 2d 63 6f 6e 66 69 67 20 68 6f 6d 65 read-config home
14e20 2d 63 66 67 66 69 6c 65 20 76 69 65 77 2d 63 66 -cfgfile view-cf
14e30 67 64 61 74 20 23 74 29 29 0a 20 20 20 20 76 69 gdat #t)). vi
14e40 65 77 2d 63 66 67 64 61 74 29 29 0a 0a 3b 3b 3d ew-cfgdat))..;;=
14e50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e90 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 61 6e 61 67 65 20 =====.;; Manage
14ea0 70 6b 74 73 2c 20 75 73 65 64 20 69 6e 20 73 65 pkts, used in se
14eb0 72 76 65 72 73 2c 20 74 65 73 74 73 20 61 6e 64 rvers, tests and
14ec0 20 6c 69 6b 65 6c 79 20 6f 74 68 65 72 20 63 6f likely other co
14ed0 6e 74 65 78 74 73 20 73 6f 20 70 75 74 0a 3b 3b ntexts so put.;;
14ee0 20 69 6e 20 63 6f 6d 6d 6f 6e 0a 3b 3b 3d 3d 3d in common.;;===
14ef0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f30 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6d ===..(define com
14f40 6d 6f 6e 3a 70 6b 74 73 2d 73 70 65 63 0a 20 20 mon:pkts-spec.
14f50 27 28 28 64 65 66 61 75 6c 74 20 2e 20 28 28 70 '((default . ((p
14f60 61 72 65 6e 74 20 20 20 20 2e 20 50 29 0a 20 20 arent . P).
14f70 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
14f80 63 74 69 6f 6e 20 20 20 20 2e 20 61 29 0a 20 20 ction . a).
14f90 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 66 (f
14fa0 69 6c 65 6e 61 6d 65 20 20 2e 20 66 29 29 29 0a ilename . f))).
14fb0 20 20 20 20 28 63 6f 6e 66 69 67 66 20 2e 20 28 (configf . (
14fc0 28 70 61 72 65 6e 74 20 20 20 20 2e 20 50 29 0a (parent . P).
14fd0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
14fe0 28 61 63 74 69 6f 6e 20 20 20 20 2e 20 61 29 0a (action . a).
14ff0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
15000 28 66 69 6c 65 6e 61 6d 65 20 20 2e 20 66 29 29 (filename . f))
15010 29 0a 20 20 20 20 28 73 65 72 76 65 72 20 20 2e ). (server .
15020 20 28 28 61 63 74 69 6f 6e 20 20 20 20 2e 20 61 ((action . a
15030 29 0a 09 09 28 70 69 64 20 20 20 20 20 20 20 2e )...(pid .
15040 20 64 29 0a 09 09 28 69 70 61 64 64 72 20 20 20 d)...(ipaddr
15050 20 2e 20 69 29 0a 09 09 28 70 6f 72 74 20 20 20 . i)...(port
15060 20 20 20 2e 20 70 29 0a 09 09 28 70 61 72 65 6e . p)...(paren
15070 74 20 20 20 20 2e 20 50 29 29 29 0a 20 20 20 20 t . P))).
15080 09 09 09 20 20 0a 20 20 20 20 28 74 65 73 74 20 ... . (test
15090 20 20 20 2e 20 28 28 63 70 75 75 73 65 20 20 20 . ((cpuuse
150a0 20 2e 20 63 29 0a 09 09 28 64 69 73 6b 75 73 65 . c)...(diskuse
150b0 20 20 20 2e 20 64 29 0a 09 09 28 69 74 65 6d 2d . d)...(item-
150c0 70 61 74 68 20 2e 20 69 29 0a 09 09 28 72 75 6e path . i)...(run
150d0 6e 61 6d 65 20 20 20 2e 20 72 29 0a 09 09 28 73 name . r)...(s
150e0 74 61 74 65 20 20 20 20 20 2e 20 73 29 0a 09 09 tate . s)...
150f0 28 74 61 72 67 65 74 20 20 20 20 2e 20 74 29 0a (target . t).
15100 09 09 28 73 74 61 74 75 73 20 20 20 20 2e 20 75 ..(status . u
15110 29 0a 09 09 28 70 61 72 65 6e 74 20 20 20 20 2e )...(parent .
15120 20 50 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 P)))))..(define
15130 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 70 6b 74 (common:get-pkt
15140 73 2d 64 69 72 73 20 6d 74 63 6f 6e 66 20 75 73 s-dirs mtconf us
15150 65 2d 6c 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 e-lt). (let* ((
15160 70 6b 74 73 64 69 72 73 2d 73 74 72 20 28 6f 72 pktsdirs-str (or
15170 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
15180 20 6d 74 63 6f 6e 66 20 22 73 65 74 75 70 22 20 mtconf "setup"
15190 20 22 70 6b 74 73 64 69 72 73 22 29 0a 09 09 09 "pktsdirs")....
151a0 20 20 20 28 61 6e 64 20 75 73 65 2d 6c 74 0a 09 (and use-lt..
151b0 09 09 09 28 63 6f 6e 63 20 28 6f 72 20 2a 74 6f ...(conc (or *to
151c0 70 70 61 74 68 2a 0a 09 09 09 09 09 20 20 28 63 ppath*...... (c
151d0 75 72 72 65 6e 74 2d 64 69 72 65 63 74 6f 72 79 urrent-directory
151e0 29 29 0a 09 09 09 09 20 20 20 20 20 20 22 2f 6c ))..... "/l
151f0 74 2f 2e 70 6b 74 73 22 29 29 29 29 0a 09 20 28 t/.pkts")))).. (
15200 70 6b 74 73 64 69 72 73 20 20 28 69 66 20 70 6b pktsdirs (if pk
15210 74 73 64 69 72 73 2d 73 74 72 0a 09 09 09 28 73 tsdirs-str....(s
15220 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 6b 74 73 tring-split pkts
15230 64 69 72 73 2d 73 74 72 20 22 20 22 29 0a 09 09 dirs-str " ")...
15240 09 23 66 29 29 29 0a 20 20 20 20 70 6b 74 73 64 .#f))). pktsd
15250 69 72 73 29 29 0a 0a 3b 3b 20 75 73 65 2d 6c 74 irs))..;; use-lt
15260 20 69 73 20 75 73 65 20 6c 69 6e 6b 74 72 65 65 is use linktree
15270 20 22 6c 74 22 20 6c 69 6e 6b 20 74 6f 20 66 69 "lt" link to fi
15280 6e 64 20 70 6b 74 73 20 64 69 72 0a 28 64 65 66 nd pkts dir.(def
15290 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 61 76 65 ine (common:save
152a0 2d 70 6b 74 20 70 6b 74 61 6c 69 73 74 2d 69 6e -pkt pktalist-in
152b0 20 6d 74 63 6f 6e 66 20 75 73 65 2d 6c 74 20 23 mtconf use-lt #
152c0 21 6b 65 79 20 28 61 64 64 2d 6f 6e 6c 79 20 23 !key (add-only #
152d0 66 29 29 20 3b 3b 20 61 64 64 2d 6f 6e 6c 79 20 f)) ;; add-only
152e0 73 61 76 65 73 20 74 68 65 20 70 6b 74 20 6f 6e saves the pkt on
152f0 6c 79 20 69 66 20 74 68 65 72 65 20 69 73 20 61 ly if there is a
15300 20 70 61 72 65 6e 74 20 61 6c 72 65 61 64 79 0a parent already.
15310 20 20 28 69 66 20 28 6f 72 20 61 64 64 2d 6f 6e (if (or add-on
15320 6c 79 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c ly.. (hash-tabl
15330 65 2d 65 78 69 73 74 73 3f 20 2a 70 6b 74 73 2d e-exists? *pkts-
15340 69 6e 66 6f 2a 20 27 6c 61 73 74 2d 70 61 72 65 info* 'last-pare
15350 6e 74 29 29 0a 20 20 20 20 20 20 28 6c 65 74 2a nt)). (let*
15360 20 28 28 70 61 72 65 6e 74 20 20 20 28 68 61 73 ((parent (has
15370 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
15380 75 6c 74 20 2a 70 6b 74 73 2d 69 6e 66 6f 2a 20 ult *pkts-info*
15390 27 6c 61 73 74 2d 70 61 72 65 6e 74 20 23 66 29 'last-parent #f)
153a0 29 0a 09 20 20 20 20 20 28 70 6b 74 61 6c 69 73 ).. (pktalis
153b0 74 20 28 69 66 20 70 61 72 65 6e 74 0a 09 09 09 t (if parent....
153c0 20 20 20 28 63 6f 6e 73 20 60 28 70 61 72 65 6e (cons `(paren
153d0 74 20 2e 20 2c 70 61 72 65 6e 74 29 0a 09 09 09 t . ,parent)....
153e0 09 20 70 6b 74 61 6c 69 73 74 2d 69 6e 29 0a 09 . pktalist-in)..
153f0 09 09 20 20 20 70 6b 74 61 6c 69 73 74 2d 69 6e .. pktalist-in
15400 29 29 29 0a 09 28 6c 65 74 2d 76 61 6c 75 65 73 )))..(let-values
15410 20 28 28 28 75 75 69 64 20 70 6b 74 29 0a 09 09 (((uuid pkt)...
15420 20 20 20 20 20 20 28 61 6c 69 73 74 2d 3e 70 6b (alist->pk
15430 74 20 70 6b 74 61 6c 69 73 74 20 63 6f 6d 6d 6f t pktalist commo
15440 6e 3a 70 6b 74 73 2d 73 70 65 63 29 29 29 0a 09 n:pkts-spec)))..
15450 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 (hash-table-se
15460 74 21 20 2a 70 6b 74 73 2d 69 6e 66 6f 2a 20 27 t! *pkts-info* '
15470 6c 61 73 74 2d 70 61 72 65 6e 74 20 75 75 69 64 last-parent uuid
15480 29 0a 09 20 20 28 6c 65 74 20 28 28 70 6b 74 73 ).. (let ((pkts
15490 64 69 72 20 28 6f 72 20 28 68 61 73 68 2d 74 61 dir (or (hash-ta
154a0 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 ble-ref/default
154b0 2a 70 6b 74 73 2d 69 6e 66 6f 2a 20 27 70 6b 74 *pkts-info* 'pkt
154c0 73 2d 64 69 72 20 23 66 29 0a 09 09 09 20 20 20 s-dir #f)....
154d0 20 20 28 6c 65 74 2a 20 28 28 70 6b 74 73 64 69 (let* ((pktsdi
154e0 72 73 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 70 rs (common:get-p
154f0 6b 74 73 2d 64 69 72 73 20 6d 74 63 6f 6e 66 20 kts-dirs mtconf
15500 75 73 65 2d 6c 74 29 29 0a 09 09 09 09 20 20 20 use-lt)).....
15510 20 28 70 6b 74 73 64 69 72 20 20 20 28 63 61 72 (pktsdir (car
15520 20 70 6b 74 73 64 69 72 73 29 29 29 20 3b 3b 20 pktsdirs))) ;;
15530 61 73 73 75 6d 65 20 69 74 20 69 73 20 74 68 65 assume it is the
15540 72 65 0a 09 09 09 20 20 20 20 20 20 20 28 68 61 re.... (ha
15550 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 70 sh-table-set! *p
15560 6b 74 73 2d 69 6e 66 6f 2a 20 27 70 6b 74 73 2d kts-info* 'pkts-
15570 64 69 72 20 70 6b 74 73 64 69 72 29 0a 09 09 09 dir pktsdir)....
15580 20 20 20 20 20 20 20 70 6b 74 73 64 69 72 29 29 pktsdir))
15590 29 29 0a 09 20 20 20 20 28 69 66 20 28 6e 6f 74 )).. (if (not
155a0 20 28 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 (file-exists? p
155b0 6b 74 73 64 69 72 29 29 0a 09 09 28 63 72 65 61 ktsdir))...(crea
155c0 74 65 2d 64 69 72 65 63 74 6f 72 79 20 70 6b 74 te-directory pkt
155d0 73 64 69 72 20 23 74 29 29 0a 09 20 20 20 20 28 sdir #t)).. (
155e0 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
155f0 69 6c 65 0a 09 09 28 63 6f 6e 63 20 70 6b 74 73 ile...(conc pkts
15600 64 69 72 20 22 2f 22 20 75 75 69 64 20 22 2e 70 dir "/" uuid ".p
15610 6b 74 22 29 0a 09 20 20 20 20 20 20 28 6c 61 6d kt").. (lam
15620 62 64 61 20 28 29 0a 09 09 28 70 72 69 6e 74 20 bda ()...(print
15630 70 6b 74 29 29 29 29 29 29 29 29 0a 09 0a 28 64 pkt))))))))...(d
15640 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 efine (common:wi
15650 74 68 2d 71 75 65 75 65 2d 64 62 20 6d 74 63 6f th-queue-db mtco
15660 6e 66 20 70 72 6f 63 20 23 21 6b 65 79 20 28 75 nf proc #!key (u
15670 73 65 2d 6c 74 20 23 66 29 28 74 6f 70 70 61 74 se-lt #f)(toppat
15680 68 2d 69 6e 20 23 66 29 29 0a 20 20 28 6c 65 74 h-in #f)). (let
15690 2a 20 28 28 70 6b 74 73 64 69 72 73 20 28 63 6f * ((pktsdirs (co
156a0 6d 6d 6f 6e 3a 67 65 74 2d 70 6b 74 73 2d 64 69 mmon:get-pkts-di
156b0 72 73 20 6d 74 63 6f 6e 66 20 75 73 65 2d 6c 74 rs mtconf use-lt
156c0 29 29 0a 09 20 28 70 6b 74 73 64 69 72 20 20 28 )).. (pktsdir (
156d0 69 66 20 70 6b 74 73 64 69 72 73 20 28 63 61 72 if pktsdirs (car
156e0 20 70 6b 74 73 64 69 72 73 29 20 23 66 29 29 0a pktsdirs) #f)).
156f0 09 20 28 74 6f 70 70 61 74 68 20 20 28 6f 72 20 . (toppath (or
15700 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
15710 6d 74 63 6f 6e 66 20 22 73 63 72 61 74 63 68 64 mtconf "scratchd
15720 61 74 22 20 22 74 6f 70 70 61 74 68 22 29 0a 09 at" "toppath")..
15730 09 20 20 20 20 20 20 20 74 6f 70 70 61 74 68 2d . toppath-
15740 69 6e 29 29 0a 09 20 28 70 64 62 70 61 74 68 20 in)).. (pdbpath
15750 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f (or (configf:lo
15760 6f 6b 75 70 20 6d 74 63 6f 6e 66 20 22 73 65 74 okup mtconf "set
15770 75 70 22 20 20 22 70 64 62 70 61 74 68 22 29 20 up" "pdbpath")
15780 70 6b 74 73 64 69 72 29 29 29 0a 20 20 20 20 28 pktsdir))). (
15790 63 6f 6e 64 0a 20 20 20 20 20 28 28 6e 6f 74 20 cond. ((not
157a0 28 61 6e 64 20 20 70 6b 74 73 64 69 72 20 74 6f (and pktsdir to
157b0 70 70 61 74 68 20 70 64 62 70 61 74 68 29 29 0a ppath pdbpath)).
157c0 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
157d0 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 0 *default-lo
157e0 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 g-port* "ERROR:
157f0 73 65 74 74 69 6e 67 73 20 61 72 65 20 6d 69 73 settings are mis
15800 73 69 6e 67 20 69 6e 20 79 6f 75 72 20 6d 65 67 sing in your meg
15810 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 66 6f 72 atest.config for
15820 20 61 72 65 61 20 6d 61 6e 61 67 65 6d 65 6e 74 area management
15830 2e 22 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 ."). (debug
15840 3a 70 72 69 6e 74 20 20 30 20 2a 64 65 66 61 75 :print 0 *defau
15850 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 lt-log-port* "
15860 79 6f 75 20 6e 65 65 64 20 74 6f 20 68 61 76 65 you need to have
15870 20 70 6b 74 73 64 69 72 20 69 6e 20 74 68 65 20 pktsdir in the
15880 5b 73 65 74 75 70 5d 20 73 65 63 74 69 6f 6e 2e [setup] section.
15890 22 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 28 ")). ((not (
158a0 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
158b0 74 73 3f 20 70 6b 74 73 64 69 72 29 29 0a 20 20 ts? pktsdir)).
158c0 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
158d0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
158e0 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 70 6b port* "ERROR: pk
158f0 74 73 20 64 69 72 65 63 74 6f 72 79 20 6e 6f 74 ts directory not
15900 20 66 6f 75 6e 64 20 22 20 70 6b 74 73 64 69 72 found " pktsdir
15910 29 29 0a 20 20 20 20 20 28 28 6e 6f 74 20 28 65 )). ((not (e
15920 71 75 61 6c 3f 20 28 66 69 6c 65 2d 6f 77 6e 65 qual? (file-owne
15930 72 20 70 6b 74 73 64 69 72 29 28 63 75 72 72 65 r pktsdir)(curre
15940 6e 74 2d 65 66 66 65 63 74 69 76 65 2d 75 73 65 nt-effective-use
15950 72 2d 69 64 29 29 29 0a 20 20 20 20 20 20 28 64 r-id))). (d
15960 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
15970 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
15980 22 45 52 52 4f 52 3a 20 64 69 72 65 63 74 6f 72 "ERROR: director
15990 79 20 22 20 70 6b 74 73 64 69 72 20 22 20 69 73 y " pktsdir " is
159a0 20 6e 6f 74 20 6f 77 6e 65 64 20 62 79 20 22 20 not owned by "
159b0 28 63 75 72 72 65 6e 74 2d 65 66 66 65 63 74 69 (current-effecti
159c0 76 65 2d 75 73 65 72 2d 6e 61 6d 65 29 29 29 0a ve-user-name))).
159d0 20 20 20 20 20 28 65 6c 73 65 0a 09 28 6c 65 74 (else..(let
159e0 2a 20 28 28 70 64 62 20 20 28 6f 70 65 6e 2d 71 * ((pdb (open-q
159f0 75 65 75 65 2d 64 62 20 70 64 62 70 61 74 68 20 ueue-db pdbpath
15a00 22 70 6b 74 73 2e 64 62 22 0a 09 09 09 09 20 20 "pkts.db".....
15a10 20 20 73 63 68 65 6d 61 3a 20 27 28 22 43 52 45 schema: '("CRE
15a20 41 54 45 20 54 41 42 4c 45 20 67 72 6f 75 70 73 ATE TABLE groups
15a30 20 28 69 64 20 49 4e 54 45 47 45 52 20 50 52 49 (id INTEGER PRI
15a40 4d 41 52 59 20 4b 45 59 2c 67 72 6f 75 70 6e 61 MARY KEY,groupna
15a50 6d 65 20 54 45 58 54 2c 20 43 4f 4e 53 54 52 41 me TEXT, CONSTRA
15a60 49 4e 54 20 67 72 6f 75 70 5f 63 6f 6e 73 74 72 INT group_constr
15a70 61 69 6e 74 20 55 4e 49 51 55 45 20 28 67 72 6f aint UNIQUE (gro
15a80 75 70 6e 61 6d 65 29 29 3b 22 29 29 29 29 0a 09 upname));"))))..
15a90 20 20 28 70 72 6f 63 20 70 6b 74 73 64 69 72 73 (proc pktsdirs
15aa0 20 70 6b 74 73 64 69 72 20 70 64 62 29 0a 09 20 pktsdir pdb)..
15ab0 20 28 64 62 69 3a 63 6c 6f 73 65 20 70 64 62 29 (dbi:close pdb)
15ac0 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
15ad0 63 6f 6d 6d 6f 6e 3a 6c 6f 61 64 2d 70 6b 74 73 common:load-pkts
15ae0 2d 74 6f 2d 64 62 20 6d 74 63 6f 6e 66 20 23 21 -to-db mtconf #!
15af0 6b 65 79 20 28 75 73 65 2d 6c 74 20 23 66 29 29 key (use-lt #f))
15b00 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d . (common:with-
15b10 71 75 65 75 65 2d 64 62 0a 20 20 20 6d 74 63 6f queue-db. mtco
15b20 6e 66 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 70 nf. (lambda (p
15b30 6b 74 73 64 69 72 73 20 70 6b 74 73 64 69 72 20 ktsdirs pktsdir
15b40 70 64 62 29 0a 20 20 20 20 20 28 66 6f 72 2d 65 pdb). (for-e
15b50 61 63 68 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 ach. (lambd
15b60 61 20 28 70 6b 74 73 64 69 72 29 20 3b 3b 20 6c a (pktsdir) ;; l
15b70 6f 6f 6b 20 61 74 20 61 6c 6c 0a 09 28 63 6f 6e ook at all..(con
15b80 64 0a 09 20 28 28 6e 6f 74 20 28 63 6f 6d 6d 6f d.. ((not (commo
15b90 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 70 n:file-exists? p
15ba0 6b 74 73 64 69 72 29 29 0a 09 20 20 28 64 65 62 ktsdir)).. (deb
15bb0 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
15bc0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 ult-log-port* "E
15bd0 52 52 4f 52 3a 20 70 61 63 6b 65 74 73 20 64 69 RROR: packets di
15be0 72 65 63 74 6f 72 79 20 22 20 70 6b 74 73 64 69 rectory " pktsdi
15bf0 72 20 22 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 r " does not exi
15c00 73 74 2e 22 29 29 0a 09 20 28 28 6e 6f 74 20 28 st.")).. ((not (
15c10 64 69 72 65 63 74 6f 72 79 3f 20 70 6b 74 73 64 directory? pktsd
15c20 69 72 29 29 0a 09 20 20 28 64 65 62 75 67 3a 70 ir)).. (debug:p
15c30 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
15c40 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
15c50 3a 20 70 61 63 6b 65 74 73 20 64 69 72 65 63 74 : packets direct
15c60 6f 72 79 20 70 61 74 68 20 22 20 70 6b 74 73 64 ory path " pktsd
15c70 69 72 20 22 20 69 73 20 6e 6f 74 20 61 20 64 69 ir " is not a di
15c80 72 65 63 74 6f 72 79 2e 22 29 29 0a 09 20 28 28 rectory.")).. ((
15c90 6e 6f 74 20 28 66 69 6c 65 2d 72 65 61 64 2d 61 not (file-read-a
15ca0 63 63 65 73 73 3f 20 70 6b 74 73 64 69 72 29 29 ccess? pktsdir))
15cb0 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
15cc0 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
15cd0 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 70 61 port* "ERROR: pa
15ce0 63 6b 65 74 73 20 64 69 72 65 63 74 6f 72 79 20 ckets directory
15cf0 70 61 74 68 20 22 20 70 6b 74 73 64 69 72 20 22 path " pktsdir "
15d00 20 69 73 20 6e 6f 74 20 72 65 61 64 61 62 6c 65 is not readable
15d10 2e 22 29 29 0a 09 20 28 65 6c 73 65 0a 09 20 20 .")).. (else..
15d20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
15d30 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
15d40 2d 70 6f 72 74 2a 20 22 4c 6f 61 64 69 6e 67 20 -port* "Loading
15d50 70 61 63 6b 65 74 73 20 66 6f 75 6e 64 20 69 6e packets found in
15d60 20 22 20 70 6b 74 73 64 69 72 29 0a 09 20 20 28 " pktsdir).. (
15d70 6c 65 74 20 28 28 70 6b 74 73 20 28 67 6c 6f 62 let ((pkts (glob
15d80 20 28 63 6f 6e 63 20 70 6b 74 73 64 69 72 20 22 (conc pktsdir "
15d90 2f 2a 2e 70 6b 74 22 29 29 29 29 0a 09 20 20 20 /*.pkt"))))..
15da0 20 28 66 6f 72 2d 65 61 63 68 0a 09 20 20 20 20 (for-each..
15db0 20 28 6c 61 6d 62 64 61 20 28 70 6b 74 29 0a 09 (lambda (pkt)..
15dc0 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 75 (let* ((u
15dd0 75 69 64 20 20 20 20 28 63 61 64 72 20 28 73 74 uid (cadr (st
15de0 72 69 6e 67 2d 6d 61 74 63 68 20 22 2e 2a 2f 28 ring-match ".*/(
15df0 5b 30 2d 39 61 2d 66 5d 2b 29 2e 70 6b 74 22 20 [0-9a-f]+).pkt"
15e00 70 6b 74 29 29 29 0a 09 09 20 20 20 20 20 20 28 pkt)))... (
15e10 65 78 69 73 74 73 20 20 28 6c 6f 6f 6b 75 70 2d exists (lookup-
15e20 62 79 2d 75 75 69 64 20 70 64 62 20 75 75 69 64 by-uuid pdb uuid
15e30 20 23 66 29 29 29 0a 09 09 20 28 69 66 20 28 6e #f)))... (if (n
15e40 6f 74 20 65 78 69 73 74 73 29 0a 09 09 20 20 20 ot exists)...
15e50 20 20 28 6c 65 74 2a 20 28 28 70 6b 74 64 61 74 (let* ((pktdat
15e60 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
15e70 65 72 73 65 0a 09 09 09 09 20 20 20 20 20 28 77 erse..... (w
15e80 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
15e90 69 6c 65 20 70 6b 74 20 72 65 61 64 2d 6c 69 6e ile pkt read-lin
15ea0 65 73 29 0a 09 09 09 09 20 20 20 20 20 22 5c 6e es)..... "\n
15eb0 22 29 29 0a 09 09 09 20 20 20 20 28 61 70 6b 74 ")).... (apkt
15ec0 20 20 20 28 70 6b 74 2d 3e 61 6c 69 73 74 20 70 (pkt->alist p
15ed0 6b 74 64 61 74 29 29 0a 09 09 09 20 20 20 20 28 ktdat)).... (
15ee0 70 74 79 70 65 20 20 28 61 6c 69 73 74 2d 72 65 ptype (alist-re
15ef0 66 20 27 54 20 61 70 6b 74 29 29 29 0a 09 09 20 f 'T apkt)))...
15f00 20 20 20 20 20 20 28 61 64 64 2d 74 6f 2d 71 75 (add-to-qu
15f10 65 75 65 20 70 64 62 20 70 6b 74 64 61 74 20 75 eue pdb pktdat u
15f20 75 69 64 20 28 6f 72 20 70 74 79 70 65 20 27 63 uid (or ptype 'c
15f30 6d 64 29 20 23 66 20 30 29 0a 09 09 20 20 20 20 md) #f 0)...
15f40 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
15f50 34 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 4 *default-log-p
15f60 6f 72 74 2a 20 22 41 64 64 65 64 20 22 20 75 75 ort* "Added " uu
15f70 69 64 20 22 20 6f 66 20 74 79 70 65 20 22 20 70 id " of type " p
15f80 74 79 70 65 20 22 20 74 6f 20 71 75 65 75 65 22 type " to queue"
15f90 29 29 0a 09 09 20 20 20 20 20 28 64 65 62 75 67 ))... (debug
15fa0 3a 70 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c :print 4 *defaul
15fb0 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 6b 74 t-log-port* "pkt
15fc0 3a 20 22 20 75 75 69 64 20 22 20 65 78 69 73 74 : " uuid " exist
15fd0 73 2c 20 73 6b 69 70 70 69 6e 67 2e 2e 2e 22 29 s, skipping...")
15fe0 0a 09 09 20 20 20 20 20 29 29 29 0a 09 20 20 20 ... )))..
15ff0 20 20 70 6b 74 73 29 29 29 29 29 0a 20 20 20 20 pkts))))).
16000 20 20 70 6b 74 73 64 69 72 73 29 29 0a 20 20 20 pktsdirs)).
16010 75 73 65 2d 6c 74 3a 20 75 73 65 2d 6c 74 29 29 use-lt: use-lt))
16020 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
16030 6e 3a 67 65 74 2d 70 6b 74 2d 61 6c 69 73 74 73 n:get-pkt-alists
16040 20 70 6b 74 73 29 0a 20 20 28 6d 61 70 20 28 6c pkts). (map (l
16050 61 6d 62 64 61 20 28 78 29 0a 09 20 28 61 6c 69 ambda (x).. (ali
16060 73 74 2d 72 65 66 20 27 61 70 6b 74 20 78 29 29 st-ref 'apkt x))
16070 20 3b 3b 20 27 70 6b 74 61 20 70 75 6c 6c 73 20 ;; 'pkta pulls
16080 6f 75 74 20 74 68 65 20 61 6c 69 73 74 20 66 72 out the alist fr
16090 6f 6d 20 74 68 65 20 72 65 61 64 20 70 6b 74 0a om the read pkt.
160a0 20 20 20 20 20 20 20 70 6b 74 73 29 29 0a 0a 3b pkts))..;
160b0 3b 20 67 69 76 65 6e 20 6c 69 73 74 20 6f 66 20 ; given list of
160c0 70 6b 74 73 20 28 61 6c 69 73 74 20 6d 6f 64 65 pkts (alist mode
160d0 29 20 72 65 74 75 72 6e 20 6c 69 73 74 20 6f 66 ) return list of
160e0 20 44 20 63 61 72 64 73 20 61 73 20 55 6e 69 78 D cards as Unix
160f0 20 65 70 6f 63 68 2c 20 73 6f 72 74 65 64 20 64 epoch, sorted d
16100 65 73 63 65 6e 64 69 6e 67 0a 3b 3b 20 61 6c 73 escending.;; als
16110 6f 20 64 65 6c 65 74 65 20 64 75 70 6c 69 63 61 o delete duplica
16120 74 65 73 20 62 79 20 74 61 72 67 65 74 20 69 2e tes by target i.
16130 65 2e 20 28 63 61 72 20 70 6b 74 29 0a 3b 3b 0a e. (car pkt).;;.
16140 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
16150 67 65 74 2d 70 6b 74 2d 74 69 6d 65 73 20 70 6b get-pkt-times pk
16160 74 73 29 0a 20 20 28 64 65 6c 65 74 65 2d 64 75 ts). (delete-du
16170 70 6c 69 63 61 74 65 73 0a 20 20 20 28 73 6f 72 plicates. (sor
16180 74 20 0a 20 20 20 20 28 6d 61 70 20 28 6c 61 6d t . (map (lam
16190 62 64 61 20 28 78 29 0a 09 20 20 20 60 28 2c 28 bda (x).. `(,(
161a0 61 6c 69 73 74 2d 72 65 66 20 27 74 20 78 29 20 alist-ref 't x)
161b0 2e 20 2c 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 . ,(string->numb
161c0 65 72 20 28 61 6c 69 73 74 2d 72 65 66 20 27 44 er (alist-ref 'D
161d0 20 78 29 29 29 29 0a 09 20 70 6b 74 73 29 0a 20 x)))).. pkts).
161e0 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 (lambda (a b)
161f0 28 3e 20 28 63 64 72 20 61 29 28 63 64 72 20 62 (> (cdr a)(cdr b
16200 29 29 29 29 20 20 20 20 20 20 3b 3b 20 73 6f 72 )))) ;; sor
16210 74 20 64 65 73 63 65 6e 64 69 6e 67 0a 20 20 20 t descending.
16220 28 6c 61 6d 62 64 61 20 28 61 20 62 29 28 65 71 (lambda (a b)(eq
16230 75 61 6c 3f 20 28 63 61 72 20 61 29 28 63 61 72 ual? (car a)(car
16240 20 62 29 29 29 29 29 20 3b 3b 20 72 65 6d 6f 76 b))))) ;; remov
16250 65 20 64 75 70 6c 69 63 61 74 65 73 20 62 79 20 e duplicates by
16260 74 61 72 67 65 74 0a 0a 0a 0a target....