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 64 61 74 61 2d 73 74 72 srfi-1 data-str
01f0: 75 63 74 75 72 65 73 20 70 6f 73 69 78 20 72 65 uctures posix re
0200: 67 65 78 2d 63 61 73 65 20 62 61 73 65 36 34 20 gex-case base64
0210: 66 6f 72 6d 61 74 20 64 6f 74 2d 6c 6f 63 6b 69 format dot-locki
0220: 6e 67 20 63 73 76 2d 78 6d 6c 20 7a 33 20 73 71 ng csv-xml z3 sq
0230: 6c 2d 64 65 2d 6c 69 74 65 20 68 6f 73 74 69 6e l-de-lite hostin
0240: 66 6f 20 6d 64 35 20 6d 65 73 73 61 67 65 2d 64 fo md5 message-d
0250: 69 67 65 73 74 20 74 79 70 65 64 2d 72 65 63 6f igest typed-reco
0260: 72 64 73 20 64 69 72 65 63 74 6f 72 79 2d 75 74 rds directory-ut
0270: 69 6c 73 20 73 74 61 63 6b 0a 20 20 20 20 20 6d ils stack. m
0280: 61 74 63 68 61 62 6c 65 29 0a 28 72 65 71 75 69 atchable).(requi
0290: 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 72 65 67 re-extension reg
02a0: 65 78 20 70 6f 73 69 78 29 0a 0a 28 72 65 71 75 ex posix)..(requ
02b0: 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 28 73 ire-extension (s
02c0: 72 66 69 20 31 38 29 20 65 78 74 72 61 73 20 74 rfi 18) extras t
02d0: 63 70 20 72 70 63 29 0a 0a 28 69 6d 70 6f 72 74 cp rpc)..(import
02e0: 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 65 33 (prefix sqlite3
02f0: 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 69 6d 70 sqlite3:)).(imp
0300: 6f 72 74 20 28 70 72 65 66 69 78 20 62 61 73 65 ort (prefix base
0310: 36 34 20 62 61 73 65 36 34 3a 29 29 0a 0a 28 64 64 base64:))..(d
0320: 65 63 6c 61 72 65 20 28 75 6e 69 74 20 63 6f 6d eclare (unit com
0330: 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 65 20 mon))..(include
0340: 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 2e "common_records.
0350: 73 63 6d 22 29 0a 0a 3b 3b 20 28 72 65 71 75 69 scm")..;; (requi
0360: 72 65 2d 6c 69 62 72 61 72 79 20 6d 61 72 67 73 re-library margs
0370: 29 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 22 6d ).;; (include "m
0380: 61 72 67 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 28 args.scm")..;; (
0390: 64 65 66 69 6e 65 20 6f 6c 64 2d 65 78 69 74 20 define old-exit
03a0: 65 78 69 74 29 0a 3b 3b 20 0a 3b 3b 20 28 64 65 exit).;; .;; (de
03b0: 66 69 6e 65 20 28 65 78 69 74 20 2e 20 63 6f 64 fine (exit . cod
03c0: 65 29 0a 3b 3b 20 20 20 28 69 66 20 28 6e 75 6c e).;; (if (nul
03d0: 6c 3f 20 63 6f 64 65 29 0a 3b 3b 20 20 20 20 20 l? code).;;
03e0: 20 20 28 6f 6c 64 2d 65 78 69 74 29 0a 3b 3b 20 (old-exit).;;
03f0: 20 20 20 20 20 20 28 6f 6c 64 2d 65 78 69 74 20 (old-exit
0400: 63 6f 64 65 29 29 29 0a 0a 0a 3b 3b 20 65 78 65 code)))...;; exe
0410: 63 75 74 65 20 74 68 75 6e 6b 2c 20 72 65 74 75 cute thunk, retu
0420: 72 6e 20 76 61 6c 75 65 2e 20 20 49 66 20 65 78 rn value. If ex
0430: 63 65 70 74 69 6f 6e 20 74 68 72 6f 77 6e 2c 20 ception thrown,
0440: 74 72 61 70 20 65 78 63 65 70 74 69 6f 6e 2c 20 trap exception,
0450: 72 65 74 75 72 6e 20 23 66 2c 20 61 6e 64 20 65 return #f, and e
0460: 6d 69 74 20 6e 6f 6e 66 61 74 61 6c 20 63 6f 6e mit nonfatal con
0470: 64 69 74 69 6f 6e 20 6e 6f 74 65 20 74 6f 20 2a dition note to *
0480: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0490: 2a 20 2e 0a 3b 3b 20 61 72 67 75 6d 65 6e 74 73 * ..;; arguments
04a0: 20 2d 20 74 68 75 6e 6b 2c 20 6d 65 73 73 61 67 - thunk, messag
04b0: 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f e.(define (commo
04c0: 6e 3a 66 61 69 6c 2d 73 61 66 65 20 74 68 75 6e n:fail-safe thun
04d0: 6b 20 77 61 72 6e 69 6e 67 2d 6d 65 73 73 61 67 k warning-messag
04e0: 65 2d 6f 6e 2d 65 78 63 65 70 74 69 6f 6e 29 0a e-on-exception).
04f0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
0500: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 ions. exn. (
0510: 62 65 67 69 6e 0a 20 20 20 20 20 28 64 65 62 75 begin. (debu
0520: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
0530: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0540: 2a 20 22 6e 6f 74 61 62 6c 65 20 62 75 74 20 6e * "notable but n
0550: 6f 6e 66 61 74 61 6c 20 63 6f 6e 64 69 74 69 6f onfatal conditio
0560: 6e 20 2d 20 22 77 61 72 6e 69 6e 67 2d 6d 65 73 n - "warning-mes
0570: 73 61 67 65 2d 6f 6e 2d 65 78 63 65 70 74 69 6f sage-on-exceptio
0580: 6e 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 n). (debug:p
0590: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
05a0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a 20 ault-log-port*.
05b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
05c0: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 75 (string-su
05d0: 62 73 74 69 74 75 74 65 20 22 5c 6e 3f 45 72 72 bstitute "\n?Err
05e0: 6f 72 3a 22 20 22 6e 6f 6e 66 61 74 61 6c 20 63 or:" "nonfatal c
05f0: 6f 6e 64 69 74 69 6f 6e 3a 22 0a 20 20 20 20 20 ondition:".
0600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0620: 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 (with-outpu
0630: 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 20 20 20 20 t-to-string.
0640: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0650: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0660: 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 (lambda
0670: 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ().
0680: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
06a0: 20 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d 65 (print-error-me
06b0: 73 73 61 67 65 20 65 78 6e 29 20 29 29 29 29 0a ssage exn) )))).
06c0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
06d0: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
06e0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 t-log-port* "
06f0: 20 2d 2d 20 63 6f 6e 74 69 6e 75 69 6e 67 20 61 -- continuing a
0700: 66 74 65 72 20 6e 6f 6e 66 61 74 61 6c 20 63 6f fter nonfatal co
0710: 6e 64 69 74 69 6f 6e 2e 2e 2e 22 29 0a 20 20 20 ndition...").
0720: 20 20 23 66 29 0a 20 20 20 28 74 68 75 6e 6b 29 #f). (thunk)
0730: 29 29 0a 0a 28 64 65 66 69 6e 65 20 67 65 74 65 ))..(define gete
0740: 6e 76 20 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 nv get-environme
0750: 6e 74 2d 76 61 72 69 61 62 6c 65 29 0a 28 64 65 nt-variable).(de
0760: 66 69 6e 65 20 28 73 61 66 65 2d 73 65 74 65 6e fine (safe-seten
0770: 76 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 69 66 v key val). (if
0780: 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 65 (substring-inde
0790: 78 20 22 3a 22 20 6b 65 79 29 20 3b 3b 20 76 61 x ":" key) ;; va
07a0: 72 69 61 62 6c 65 73 20 63 6f 6e 74 61 69 6e 69 riables containi
07b0: 6e 67 20 3a 20 61 72 65 20 66 6f 72 20 69 6e 74 ng : are for int
07c0: 65 72 6e 61 6c 20 75 73 65 20 61 6e 64 20 63 61 ernal use and ca
07d0: 6e 6e 6f 74 20 62 65 20 65 6e 76 69 72 6f 6e 6d nnot be environm
07e0: 65 6e 74 20 76 61 72 69 61 62 6c 65 73 2e 0a 20 ent variables..
07f0: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
0800: 74 2d 65 72 72 6f 72 20 34 20 2a 64 65 66 61 75 t-error 4 *defau
0810: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 6b lt-log-port* "sk
0820: 69 70 20 73 65 74 74 69 6e 67 20 69 6e 74 65 72 ip setting inter
0830: 6e 61 6c 20 75 73 65 20 6f 6e 6c 79 20 76 61 72 nal use only var
0840: 69 61 62 6c 65 73 20 63 6f 6e 74 61 69 6e 69 6e iables containin
0850: 67 20 5c 22 3a 5c 22 22 29 0a 20 20 20 20 20 20 g \":\"").
0860: 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (if (and (string
0870: 3f 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 28 ? val).. (
0880: 73 74 72 69 6e 67 3f 20 6b 65 79 29 29 0a 09 20 string? key))..
0890: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
08a0: 6f 6e 73 0a 09 20 20 20 20 20 20 65 78 6e 0a 09 ons.. exn..
08b0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
08c0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
08d0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 62 ult-log-port* "b
08e0: 61 64 20 76 61 6c 75 65 20 66 6f 72 20 73 65 74 ad value for set
08f0: 65 6e 76 2c 20 6b 65 79 3d 22 20 6b 65 79 20 22 env, key=" key "
0900: 2c 20 76 61 6c 75 65 3d 22 20 76 61 6c 29 0a 09 , value=" val)..
0910: 20 20 20 20 28 73 65 74 65 6e 76 20 6b 65 79 20 (setenv key
0920: 76 61 6c 29 29 0a 09 20 20 28 64 65 62 75 67 3a val)).. (debug:
0930: 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 print-error 0 *d
0940: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
0950: 20 22 62 61 64 20 76 61 6c 75 65 20 66 6f 72 20 "bad value for
0960: 73 65 74 65 6e 76 2c 20 6b 65 79 3d 22 20 6b 65 setenv, key=" ke
0970: 79 20 22 2c 20 76 61 6c 75 65 3d 22 20 76 61 6c y ", value=" val
0980: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 6f ))))..(define ho
0990: 6d 65 20 28 67 65 74 65 6e 76 20 22 48 4f 4d 45 me (getenv "HOME
09a0: 22 29 29 0a 28 64 65 66 69 6e 65 20 75 73 65 72 ")).(define user
09b0: 20 28 67 65 74 65 6e 76 20 22 55 53 45 52 22 29 (getenv "USER")
09c0: 29 0a 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 6c )...;; returns l
09d0: 69 73 74 20 6f 66 20 66 64 20 63 6f 75 6e 74 2c ist of fd count,
09e0: 20 73 6f 63 6b 65 74 20 63 6f 75 6e 74 0a 28 64 socket count.(d
09f0: 65 66 69 6e 65 20 28 67 65 74 2d 66 69 6c 65 2d efine (get-file-
0a00: 64 65 73 63 72 69 70 74 6f 72 2d 63 6f 75 6e 74 descriptor-count
0a10: 20 23 21 6b 65 79 20 20 28 70 69 64 20 28 63 75 #!key (pid (cu
0a20: 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 rrent-process-id
0a30: 20 29 29 29 0a 20 20 28 6c 69 73 74 0a 20 20 20 ))). (list.
0a40: 20 28 6c 65 6e 67 74 68 20 28 67 6c 6f 62 20 28 (length (glob (
0a50: 63 6f 6e 63 20 22 2f 70 72 6f 63 2f 22 20 70 69 conc "/proc/" pi
0a60: 64 20 22 2f 66 64 2f 2a 22 29 29 29 0a 20 20 20 d "/fd/*"))).
0a70: 20 28 6c 65 6e 67 74 68 20 20 28 66 69 6c 74 65 (length (filte
0a80: 72 20 69 64 65 6e 74 69 74 79 20 28 6d 61 70 20 r identity (map
0a90: 73 6f 63 6b 65 74 3f 20 28 67 6c 6f 62 20 28 63 socket? (glob (c
0aa0: 6f 6e 63 20 22 2f 70 72 6f 63 2f 22 20 70 69 64 onc "/proc/" pid
0ab0: 20 22 2f 66 64 2f 2a 22 29 29 29 29 29 0a 20 20 "/fd/*"))))).
0ac0: 29 0a 29 0a 0a 0a 3b 3b 20 47 4c 4f 42 41 4c 53 ).)...;; GLOBALS
0ad0: 0a 0a 3b 3b 20 43 4f 4e 54 45 58 54 53 0a 28 64 ..;; CONTEXTS.(d
0ae0: 65 66 73 74 72 75 63 74 20 63 78 74 0a 20 20 28 efstruct cxt. (
0af0: 74 61 73 6b 64 62 20 23 66 29 0a 20 20 28 63 6d taskdb #f). (cm
0b00: 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 78 utex (make-mutex
0b10: 29 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a ))).;; (define *
0b20: 63 6f 6e 74 65 78 74 73 2a 20 28 6d 61 6b 65 2d contexts* (make-
0b30: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 3b 3b 20 hash-table)).;;
0b40: 28 64 65 66 69 6e 65 20 2a 63 6f 6e 74 65 78 74 (define *context
0b50: 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 -mutex* (make-mu
0b60: 74 65 78 29 29 0a 0a 3b 3b 20 3b 3b 20 73 61 66 tex))..;; ;; saf
0b70: 65 20 6d 65 74 68 6f 64 20 66 6f 72 20 61 63 63 e method for acc
0b80: 65 73 73 69 6e 67 20 61 20 63 6f 6e 74 65 78 74 essing a context
0b90: 20 67 69 76 65 6e 20 61 20 74 6f 70 70 61 74 68 given a toppath
0ba0: 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 6e .;; ;;.;; (defin
0bb0: 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d 63 e (common:with-c
0bc0: 78 74 20 74 6f 70 70 61 74 68 20 70 72 6f 63 29 xt toppath proc)
0bd0: 0a 3b 3b 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 .;; (mutex-loc
0be0: 6b 21 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 65 k! *context-mute
0bf0: 78 2a 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 x*).;; (let ((
0c00: 63 78 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d cxt (hash-table-
0c10: 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f 6e ref/default *con
0c20: 74 65 78 74 73 2a 20 74 6f 70 70 61 74 68 20 23 texts* toppath #
0c30: 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 20 f))).;; (if
0c40: 28 6e 6f 74 20 63 78 74 29 0a 3b 3b 20 20 20 20 (not cxt).;;
0c50: 20 20 20 20 20 28 73 65 74 21 20 63 78 74 20 28 (set! cxt (
0c60: 6c 65 74 20 28 28 78 20 28 6d 61 6b 65 2d 63 78 let ((x (make-cx
0c70: 74 29 29 29 28 68 61 73 68 2d 74 61 62 6c 65 2d t)))(hash-table-
0c80: 73 65 74 21 20 2a 63 6f 6e 74 65 78 74 73 2a 20 set! *contexts*
0c90: 74 6f 70 70 61 74 68 20 78 29 20 78 29 29 29 0a toppath x) x))).
0ca0: 3b 3b 20 20 20 20 20 28 6c 65 74 20 28 28 63 78 ;; (let ((cx
0cb0: 74 2d 6d 75 74 65 78 20 28 63 78 74 2d 6d 75 74 t-mutex (cxt-mut
0cc0: 65 78 20 63 78 74 29 29 29 0a 3b 3b 20 20 20 20 ex cxt))).;;
0cd0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
0ce0: 21 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 65 78 ! *context-mutex
0cf0: 2a 29 0a 3b 3b 20 20 20 20 20 20 20 28 6d 75 74 *).;; (mut
0d00: 65 78 2d 6c 6f 63 6b 21 20 63 78 74 2d 6d 75 74 ex-lock! cxt-mut
0d10: 65 78 29 0a 3b 3b 20 20 20 20 20 20 20 28 6c 65 ex).;; (le
0d20: 74 20 28 28 72 65 73 20 28 70 72 6f 63 20 63 78 t ((res (proc cx
0d30: 74 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 t))).;;
0d40: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 63 (mutex-unlock! c
0d50: 78 74 2d 6d 75 74 65 78 29 0a 3b 3b 20 20 20 20 xt-mutex).;;
0d60: 20 20 20 20 20 72 65 73 29 29 29 29 0a 20 20 20 res)))).
0d70: 20 20 20 20 20 0a 3b 3b 20 41 20 68 61 73 68 20 .;; A hash
0d80: 74 61 62 6c 65 20 74 68 61 74 20 63 61 6e 20 62 table that can b
0d90: 65 20 61 63 63 65 73 73 65 64 20 62 79 20 23 7b e accessed by #{
0da0: 73 63 68 65 6d 65 20 2e 2e 2e 7d 20 63 61 6c 6c scheme ...} call
0db0: 73 20 69 6e 0a 3b 3b 20 63 6f 6e 66 69 67 20 66 s in.;; config f
0dc0: 69 6c 65 73 2e 20 41 6c 6c 6f 77 73 20 63 6f 6d iles. Allows com
0dd0: 6d 75 6e 69 63 61 74 69 6e 67 20 62 65 74 77 65 municating betwe
0de0: 65 6e 20 63 6f 6e 66 67 73 0a 3b 3b 0a 28 64 65 en confgs.;;.(de
0df0: 66 69 6e 65 20 2a 75 73 65 72 2d 68 61 73 68 2d fine *user-hash-
0e00: 64 61 74 61 2a 20 28 6d 61 6b 65 2d 68 61 73 68 data* (make-hash
0e10: 2d 74 61 62 6c 65 29 29 0a 0a 28 64 65 66 69 6e -table))..(defin
0e20: 65 20 2a 64 62 2d 6b 65 79 73 2a 20 23 66 29 0a e *db-keys* #f).
0e30: 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 .(define *config
0e40: 69 6e 66 6f 2a 20 20 20 23 66 29 20 20 20 3b 3b info* #f) ;;
0e50: 20 72 61 77 20 72 65 73 75 6c 74 73 20 66 72 6f raw results fro
0e60: 6d 20 73 65 74 75 70 2c 20 69 6e 63 6c 75 64 65 m setup, include
0e70: 73 20 74 6f 70 70 61 74 68 20 61 6e 64 20 74 61 s toppath and ta
0e80: 62 6c 65 20 66 72 6f 6d 20 6d 65 67 61 74 65 73 ble from megates
0e90: 74 2e 63 6f 6e 66 69 67 0a 28 64 65 66 69 6e 65 t.config.(define
0ea0: 20 2a 72 75 6e 63 6f 6e 66 69 67 64 61 74 2a 20 *runconfigdat*
0eb0: 23 66 29 20 20 20 3b 3b 20 72 75 6e 20 63 6f 6e #f) ;; run con
0ec0: 66 69 67 73 20 64 61 74 61 0a 28 64 65 66 69 6e figs data.(defin
0ed0: 65 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 20 20 e *configdat*
0ee0: 20 23 66 29 20 20 20 3b 3b 20 6d 65 67 61 74 65 #f) ;; megate
0ef0: 73 74 2e 63 6f 6e 66 69 67 20 64 61 74 61 0a 28 st.config data.(
0f00: 64 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 73 74 define *configst
0f10: 61 74 75 73 2a 20 23 66 29 20 20 20 3b 3b 20 73 atus* #f) ;; s
0f20: 74 61 74 75 73 20 6f 66 20 64 61 74 61 3b 20 27 tatus of data; '
0f30: 66 75 6c 6c 64 61 74 61 20 3a 20 61 6c 6c 20 70 fulldata : all p
0f40: 72 6f 63 65 73 73 69 6e 67 20 64 6f 6e 65 2c 20 rocessing done,
0f50: 23 66 20 3a 20 6e 6f 20 64 61 74 61 20 79 65 74 #f : no data yet
0f60: 2c 20 27 70 61 72 74 69 61 6c 64 61 74 61 20 3a , 'partialdata :
0f70: 20 70 61 72 74 69 61 6c 20 72 65 61 64 20 64 6f partial read do
0f80: 6e 65 0a 28 64 65 66 69 6e 65 20 2a 74 6f 70 70 ne.(define *topp
0f90: 61 74 68 2a 20 20 20 20 20 20 23 66 29 0a 28 64 ath* #f).(d
0fa0: 65 66 69 6e 65 20 2a 61 6c 72 65 61 64 79 2d 73 efine *already-s
0fb0: 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 2d 69 6e een-runconfig-in
0fc0: 66 6f 2a 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 fo* #f)..(define
0fd0: 20 2a 74 65 73 74 2d 6d 65 74 61 2d 75 70 64 61 *test-meta-upda
0fe0: 74 65 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d ted* (make-hash-
0ff0: 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 table)).(define
1000: 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 *globalexitstatu
1010: 73 2a 20 20 30 29 20 3b 3b 20 61 74 74 65 6d 70 s* 0) ;; attemp
1020: 74 20 74 6f 20 77 6f 72 6b 20 61 72 6f 75 6e 64 t to work around
1030: 20 70 6f 73 73 69 62 6c 65 20 74 68 72 65 61 64 possible thread
1040: 20 69 73 73 75 65 73 0a 28 64 65 66 69 6e 65 20 issues.(define
1050: 2a 70 61 73 73 6e 75 6d 2a 20 20 20 20 20 20 20 *passnum*
1060: 20 20 20 20 30 29 20 3b 3b 20 77 68 65 6e 20 72 0) ;; when r
1070: 75 6e 6e 69 6e 67 20 74 72 61 63 6b 20 63 61 6c unning track cal
1080: 6c 73 20 74 6f 20 72 75 6e 2d 74 65 73 74 73 20 ls to run-tests
1090: 6f 72 20 73 69 6d 69 6c 61 72 0a 3b 3b 20 28 64 or similar.;; (d
10a0: 65 66 69 6e 65 20 2a 61 6c 74 2d 6c 6f 67 2d 66 efine *alt-log-f
10b0: 69 6c 65 2a 20 23 66 29 20 20 3b 3b 20 75 73 65 ile* #f) ;; use
10c0: 64 20 62 79 20 2d 6c 6f 67 0a 28 64 65 66 69 6e d by -log.(defin
10d0: 65 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 e *common:denois
10e0: 65 2a 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 e* (make-hash
10f0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 66 6f 72 20 -table)) ;; for
1100: 6c 6f 77 20 6e 6f 69 73 65 20 70 72 69 6e 74 69 low noise printi
1110: 6e 67 0a 28 64 65 66 69 6e 65 20 2a 64 65 66 61 ng.(define *defa
1120: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 20 28 ult-log-port* (
1130: 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 6f current-error-po
1140: 72 74 29 29 0a 28 64 65 66 69 6e 65 20 2a 74 69 rt)).(define *ti
1150: 6d 65 2d 7a 65 72 6f 2a 20 28 63 75 72 72 65 6e me-zero* (curren
1160: 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 66 t-seconds)) ;; f
1170: 6f 72 20 74 68 65 20 77 61 74 63 68 64 6f 67 0a or the watchdog.
1180: 0a 3b 3b 20 44 41 54 41 42 41 53 45 0a 28 64 65 .;; DATABASE.(de
1190: 66 69 6e 65 20 2a 64 62 73 74 72 75 63 74 2d 64 fine *dbstruct-d
11a0: 62 2a 20 20 20 20 20 20 20 20 20 23 66 29 20 3b b* #f) ;
11b0: 3b 20 75 73 65 64 20 74 6f 20 63 61 63 68 65 20 ; used to cache
11c0: 74 68 65 20 64 62 73 74 72 75 63 74 20 69 6e 20 the dbstruct in
11d0: 64 62 3a 73 65 74 75 70 2e 20 47 6f 61 6c 20 69 db:setup. Goal i
11e0: 73 20 74 6f 20 72 65 6d 6f 76 65 20 74 68 69 73 s to remove this
11f0: 2e 0a 3b 3b 20 64 62 20 73 74 61 74 73 0a 28 64 ..;; db stats.(d
1200: 65 66 69 6e 65 20 2a 64 62 2d 73 74 61 74 73 2a efine *db-stats*
1210: 20 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b (mak
1220: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b e-hash-table)) ;
1230: 3b 20 68 61 73 68 20 6f 66 20 76 65 63 74 6f 72 ; hash of vector
1240: 73 20 3c 20 63 6f 75 6e 74 20 64 75 72 61 74 69 s < count durati
1250: 6f 6e 2d 74 6f 74 61 6c 20 3e 0a 28 64 65 66 69 on-total >.(defi
1260: 6e 65 20 2a 64 62 2d 73 74 61 74 73 2d 6d 75 74 ne *db-stats-mut
1270: 65 78 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d 6d ex* (make-m
1280: 75 74 65 78 29 29 0a 3b 3b 20 64 62 20 61 63 63 utex)).;; db acc
1290: 65 73 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d ess.(define *db-
12a0: 6c 61 73 74 2d 61 63 63 65 73 73 2a 20 20 20 20 last-access*
12b0: 20 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e (current-secon
12c0: 64 73 29 29 20 3b 3b 20 6c 61 73 74 20 64 62 20 ds)) ;; last db
12d0: 61 63 63 65 73 73 2c 20 75 73 65 64 20 69 6e 20 access, used in
12e0: 73 65 72 76 65 72 0a 28 64 65 66 69 6e 65 20 2a server.(define *
12f0: 64 62 2d 77 72 69 74 65 2d 61 63 63 65 73 73 2a db-write-access*
1300: 20 20 20 20 20 23 74 29 0a 3b 3b 20 64 62 20 73 #t).;; db s
1310: 79 6e 63 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d ync.(define *db-
1320: 6c 61 73 74 2d 73 79 6e 63 2a 20 20 20 20 20 20 last-sync*
1330: 20 20 30 29 20 20 20 20 20 20 20 20 20 20 20 20 0)
1340: 20 20 20 20 20 3b 3b 20 6c 61 73 74 20 74 69 6d ;; last tim
1350: 65 20 74 68 65 20 73 79 6e 63 20 74 6f 20 6d 65 e the sync to me
1360: 67 61 74 65 73 74 2e 64 62 20 68 61 70 70 65 6e gatest.db happen
1370: 65 64 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 ed.(define *db-s
1380: 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a ync-in-progress*
1390: 20 23 66 29 20 20 20 20 20 20 20 20 20 20 20 20 #f)
13a0: 20 20 20 20 3b 3b 20 69 66 20 74 68 65 72 65 20 ;; if there
13b0: 69 73 20 61 20 73 79 6e 63 20 69 6e 20 70 72 6f is a sync in pro
13c0: 67 72 65 73 73 20 64 6f 20 6e 6f 74 20 74 72 79 gress do not try
13d0: 20 74 6f 20 73 74 61 72 74 20 61 6e 6f 74 68 65 to start anothe
13e0: 72 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 6d 75 r.(define *db-mu
13f0: 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 65 78 2a 20 lti-sync-mutex*
1400: 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 20 20 (make-mutex))
1410: 20 20 20 3b 3b 20 70 72 6f 74 65 63 74 20 61 63 ;; protect ac
1420: 63 65 73 73 20 74 6f 20 2a 64 62 2d 73 79 6e 63 cess to *db-sync
1430: 2d 69 6e 2d 70 72 6f 67 72 65 73 73 2a 2c 20 2a -in-progress*, *
1440: 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 0a 3b 3b db-last-sync*.;;
1450: 20 74 61 73 6b 20 64 62 0a 28 64 65 66 69 6e 65 task db.(define
1460: 20 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 20 20 *task-db*
1470: 20 20 20 20 20 20 20 23 66 29 20 3b 3b 20 28 76 #f) ;; (v
1480: 65 63 74 6f 72 20 64 62 20 70 61 74 68 2d 74 6f ector db path-to
1490: 2d 64 62 29 0a 28 64 65 66 69 6e 65 20 2a 64 62 -db).(define *db
14a0: 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 2a -access-allowed*
14b0: 20 20 20 23 74 29 20 3b 3b 20 66 6c 61 67 20 74 #t) ;; flag t
14c0: 6f 20 61 6c 6c 6f 77 20 61 63 63 65 73 73 0a 28 o allow access.(
14d0: 64 65 66 69 6e 65 20 2a 64 62 2d 61 63 63 65 73 define *db-acces
14e0: 73 2d 6d 75 74 65 78 2a 20 20 20 20 20 28 6d 61 s-mutex* (ma
14f0: 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 66 69 ke-mutex)).(defi
1500: 6e 65 20 2a 64 62 2d 74 72 61 6e 73 61 63 74 69 ne *db-transacti
1510: 6f 6e 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d on-mutex* (make-
1520: 6d 75 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 mutex)).(define
1530: 2a 64 62 2d 63 61 63 68 65 2d 70 61 74 68 2a 20 *db-cache-path*
1540: 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 69 6e #f).(defin
1550: 65 20 2a 64 62 2d 77 69 74 68 2d 64 62 2d 6d 75 e *db-with-db-mu
1560: 74 65 78 2a 20 20 20 20 28 6d 61 6b 65 2d 6d 75 tex* (make-mu
1570: 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 64 tex)).(define *d
1580: 62 2d 61 70 69 2d 63 61 6c 6c 2d 74 69 6d 65 2a b-api-call-time*
1590: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
15a0: 61 62 6c 65 29 29 20 3b 3b 20 68 61 73 68 20 6f able)) ;; hash o
15b0: 66 20 63 6f 6d 6d 61 6e 64 20 3d 3e 20 28 6c 69 f command => (li
15c0: 73 74 20 6f 66 20 74 69 6d 65 73 29 0a 3b 3b 20 st of times).;;
15d0: 6e 6f 20 73 79 6e 63 20 64 62 0a 28 64 65 66 69 no sync db.(defi
15e0: 6e 65 20 2a 6e 6f 2d 73 79 6e 63 2d 64 62 2a 20 ne *no-sync-db*
15f0: 20 20 20 20 20 20 20 20 20 23 66 29 0a 0a 3b 3b #f)..;;
1600: 20 53 45 52 56 45 52 0a 28 64 65 66 69 6e 65 20 SERVER.(define
1610: 2a 6d 79 2d 63 6c 69 65 6e 74 2d 73 69 67 6e 61 *my-client-signa
1620: 74 75 72 65 2a 20 23 66 29 0a 28 64 65 66 69 6e ture* #f).(defin
1630: 65 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 79 70 e *transport-typ
1640: 65 2a 20 20 20 20 27 68 74 74 70 29 20 20 20 20 e* 'http)
1650: 20 20 20 20 20 20 20 20 20 3b 3b 20 6f 76 65 72 ;; over
1660: 72 69 64 65 20 77 69 74 68 20 5b 73 65 72 76 65 ride with [serve
1670: 72 5d 20 74 72 61 6e 73 70 6f 72 74 20 68 74 74 r] transport htt
1680: 70 7c 72 70 63 7c 6e 6d 73 67 0a 28 64 65 66 69 p|rpc|nmsg.(defi
1690: 6e 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 20 ne *runremote*
16a0: 20 20 20 20 20 20 20 23 66 29 20 20 20 20 20 20 #f)
16b0: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 69 66 20 ;; if
16c0: 73 65 74 20 75 70 20 66 6f 72 20 73 65 72 76 65 set up for serve
16d0: 72 20 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 r communication
16e0: 74 68 69 73 20 77 69 6c 6c 20 68 6f 6c 64 20 3c this will hold <
16f0: 68 6f 73 74 20 70 6f 72 74 3e 0a 3b 3b 20 28 64 host port>.;; (d
1700: 65 66 69 6e 65 20 2a 6d 61 78 2d 63 61 63 68 65 efine *max-cache
1710: 2d 73 69 7a 65 2a 20 20 20 20 30 29 0a 28 64 65 -size* 0).(de
1720: 66 69 6e 65 20 2a 6c 6f 67 67 65 64 2d 69 6e 2d fine *logged-in-
1730: 63 6c 69 65 6e 74 73 2a 20 28 6d 61 6b 65 2d 68 clients* (make-h
1740: 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 ash-table)).(def
1750: 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 64 2a 20 ine *server-id*
1760: 20 20 20 20 20 20 20 20 23 66 29 0a 28 64 65 66 #f).(def
1770: 69 6e 65 20 2a 73 65 72 76 65 72 2d 69 6e 66 6f ine *server-info
1780: 2a 20 20 20 20 20 20 20 23 66 29 20 20 3b 3b 20 * #f) ;;
1790: 67 6f 6f 64 20 63 61 6e 64 69 64 61 74 65 20 66 good candidate f
17a0: 6f 72 20 65 61 73 69 6c 79 20 63 6f 6e 76 65 72 or easily conver
17b0: 74 20 74 6f 20 6e 6f 6e 2d 67 6c 6f 62 61 6c 0a t to non-global.
17c0: 28 64 65 66 69 6e 65 20 2a 74 69 6d 65 2d 74 6f (define *time-to
17d0: 2d 65 78 69 74 2a 20 20 20 20 20 20 23 66 29 0a -exit* #f).
17e0: 28 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d (define *server-
17f0: 72 75 6e 2a 20 20 20 20 20 20 20 20 23 74 29 0a run* #t).
1800: 28 64 65 66 69 6e 65 20 2a 72 75 6e 2d 69 64 2a (define *run-id*
1810: 20 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a #f).
1820: 28 64 65 66 69 6e 65 20 2a 73 65 72 76 65 72 2d (define *server-
1830: 6b 69 6e 64 2d 72 75 6e 2a 20 20 20 28 6d 61 6b kind-run* (mak
1840: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 e-hash-table)).(
1850: 64 65 66 69 6e 65 20 2a 68 6f 6d 65 2d 68 6f 73 define *home-hos
1860: 74 2a 20 20 20 20 20 20 20 20 20 23 66 29 0a 3b t* #f).;
1870: 3b 20 28 64 65 66 69 6e 65 20 2a 74 6f 74 61 6c ; (define *total
1880: 2d 6e 6f 6e 2d 77 72 69 74 65 2d 64 65 6c 61 79 -non-write-delay
1890: 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 68 65 * 0).(define *he
18a0: 61 72 74 62 65 61 74 2d 6d 75 74 65 78 2a 20 20 artbeat-mutex*
18b0: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 (make-mutex)).(
18c0: 64 65 66 69 6e 65 20 2a 61 70 69 2d 70 72 6f 63 define *api-proc
18d0: 65 73 73 2d 72 65 71 75 65 73 74 2d 63 6f 75 6e ess-request-coun
18e0: 74 2a 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 6d t* 0).(define *m
18f0: 61 78 2d 61 70 69 2d 70 72 6f 63 65 73 73 2d 72 ax-api-process-r
1900: 65 71 75 65 73 74 73 2a 20 30 29 0a 28 64 65 66 equests* 0).(def
1910: 69 6e 65 20 2a 73 65 72 76 65 72 2d 6f 76 65 72 ine *server-over
1920: 6c 6f 61 64 65 64 2a 20 20 23 66 29 0a 0a 3b 3b loaded* #f)..;;
1930: 20 63 6c 69 65 6e 74 0a 28 64 65 66 69 6e 65 20 client.(define
1940: 2a 72 6d 74 2d 6d 75 74 65 78 2a 20 20 20 20 20 *rmt-mutex*
1950: 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 (make-mutex)
1960: 29 20 20 20 20 20 3b 3b 20 72 65 6d 6f 74 65 20 ) ;; remote
1970: 61 63 63 65 73 73 20 63 61 6c 6c 73 20 6d 75 74 access calls mut
1980: 65 78 20 0a 0a 3b 3b 20 52 50 43 20 74 72 61 6e ex ..;; RPC tran
1990: 73 70 6f 72 74 0a 28 64 65 66 69 6e 65 20 2a 72 sport.(define *r
19a0: 70 63 3a 6c 69 73 74 65 6e 65 72 2a 20 20 20 20 pc:listener*
19b0: 20 20 23 66 29 0a 0a 3b 3b 20 4b 45 59 20 69 6e #f)..;; KEY in
19c0: 66 6f 0a 28 64 65 66 69 6e 65 20 2a 74 61 72 67 fo.(define *targ
19d0: 65 74 2a 20 20 20 20 20 20 20 20 20 20 20 20 28 et* (
19e0: 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
19f0: 29 20 3b 3b 20 63 61 63 68 65 20 74 68 65 20 74 ) ;; cache the t
1a00: 61 72 67 65 74 20 68 65 72 65 3b 20 74 61 72 67 arget here; targ
1a10: 65 74 20 69 73 20 6b 65 79 76 61 6c 31 2f 6b 65 et is keyval1/ke
1a20: 79 76 61 6c 32 2f 2e 2e 2e 2f 6b 65 79 76 61 6c yval2/.../keyval
1a30: 4e 0a 28 64 65 66 69 6e 65 20 2a 6b 65 79 73 2a N.(define *keys*
1a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6d (m
1a50: 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
1a60: 20 3b 3b 20 63 61 63 68 65 20 74 68 65 20 6b 65 ;; cache the ke
1a70: 79 73 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 ys here.(define
1a80: 2a 6b 65 79 76 61 6c 73 2a 20 20 20 20 20 20 20 *keyvals*
1a90: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1aa0: 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a able)).(define *
1ab0: 74 6f 70 74 65 73 74 2d 70 61 74 68 73 2a 20 20 toptest-paths*
1ac0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1ad0: 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 74 ble)) ;; cache t
1ae0: 6f 70 74 65 73 74 20 70 61 74 68 20 73 65 74 74 optest path sett
1af0: 69 6e 67 73 20 68 65 72 65 0a 28 64 65 66 69 6e ings here.(defin
1b00: 65 20 2a 74 65 73 74 2d 70 61 74 68 73 2a 20 20 e *test-paths*
1b10: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
1b20: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 -table)) ;; cach
1b30: 65 20 74 65 73 74 2d 69 64 20 74 6f 20 74 65 73 e test-id to tes
1b40: 74 20 72 75 6e 20 70 61 74 68 73 20 68 65 72 65 t run paths here
1b50: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 69 .(define *test-i
1b60: 64 73 2a 20 20 20 20 20 20 20 20 20 20 28 6d 61 ds* (ma
1b70: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1b80: 3b 3b 20 63 61 63 68 65 20 72 75 6e 2d 69 64 2c ;; cache run-id,
1b90: 20 74 65 73 74 6e 61 6d 65 2c 20 61 6e 64 20 69 testname, and i
1ba0: 74 65 6d 2d 70 61 74 68 20 3d 3e 20 74 65 73 74 tem-path => test
1bb0: 2d 69 64 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 -id.(define *tes
1bc0: 74 2d 69 6e 66 6f 2a 20 20 20 20 20 20 20 20 20 t-info*
1bd0: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1be0: 29 29 20 3b 3b 20 63 61 63 68 65 20 74 68 65 20 )) ;; cache the
1bf0: 74 65 73 74 20 69 6e 66 6f 20 72 65 63 6f 72 64 test info record
1c00: 73 2c 20 75 70 64 61 74 65 20 74 68 65 20 73 74 s, update the st
1c10: 61 74 65 2c 20 73 74 61 74 75 73 2c 20 72 75 6e ate, status, run
1c20: 5f 64 75 72 61 74 69 6f 6e 20 65 74 63 2e 20 66 _duration etc. f
1c30: 72 6f 6d 20 74 65 73 74 64 61 74 2e 64 62 0a 0a rom testdat.db..
1c40: 28 64 65 66 69 6e 65 20 2a 72 75 6e 2d 69 6e 66 (define *run-inf
1c50: 6f 2d 63 61 63 68 65 2a 20 20 20 20 20 28 6d 61 o-cache* (ma
1c60: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1c70: 3b 3b 20 72 75 6e 20 69 6e 66 6f 20 69 73 20 73 ;; run info is s
1c80: 74 61 62 6c 65 2c 20 6e 6f 20 6e 65 65 64 20 74 table, no need t
1c90: 6f 20 72 65 67 65 74 0a 28 64 65 66 69 6e 65 20 o reget.(define
1ca0: 2a 6c 61 75 6e 63 68 2d 73 65 74 75 70 2d 6d 75 *launch-setup-mu
1cb0: 74 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 tex* (make-mutex
1cc0: 29 29 20 20 20 20 20 3b 3b 20 6e 65 65 64 20 74 )) ;; need t
1cd0: 6f 20 62 65 20 61 62 6c 65 20 74 6f 20 63 61 6c o be able to cal
1ce0: 6c 20 6c 61 75 6e 63 68 3a 73 65 74 75 70 20 6f l launch:setup o
1cf0: 66 74 65 6e 20 73 6f 20 6d 75 74 65 78 20 69 74 ften so mutex it
1d00: 20 61 6e 64 20 72 65 2d 63 61 6c 6c 20 74 68 65 and re-call the
1d10: 20 72 65 61 6c 20 64 65 61 6c 20 6f 6e 6c 79 20 real deal only
1d20: 69 66 20 2a 74 6f 70 70 61 74 68 2a 20 6e 6f 74 if *toppath* not
1d30: 20 73 65 74 0a 28 64 65 66 69 6e 65 20 2a 68 6f set.(define *ho
1d40: 6d 65 68 6f 73 74 2d 6d 75 74 65 78 2a 20 20 20 mehost-mutex*
1d50: 20 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a (make-mutex)).
1d60: 0a 3b 3b 20 4d 69 73 63 65 6c 6c 61 6e 65 6f 75 .;; Miscellaneou
1d70: 73 0a 28 64 65 66 69 6e 65 20 2a 74 72 69 67 67 s.(define *trigg
1d80: 65 72 73 2d 6d 75 74 65 78 2a 20 20 20 20 20 28 ers-mutex* (
1d90: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 20 20 20 20 make-mutex))
1da0: 20 3b 3b 20 62 6c 6f 63 6b 20 6f 76 65 72 6c 61 ;; block overla
1db0: 70 70 69 6e 67 20 70 72 6f 63 65 73 73 69 6e 67 pping processing
1dc0: 20 6f 66 20 74 72 69 67 67 65 72 73 0a 0a 28 64 of triggers..(d
1dd0: 65 66 73 74 72 75 63 74 20 72 65 6d 6f 74 65 0a efstruct remote.
1de0: 20 20 28 68 68 2d 64 61 74 20 20 20 20 20 20 20 (hh-dat
1df0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
1e00: 2d 68 6f 6d 65 68 6f 73 74 29 29 20 3b 3b 20 68 -homehost)) ;; h
1e10: 6f 6d 65 68 6f 73 74 20 72 65 63 6f 72 64 20 28 omehost record (
1e20: 20 61 64 64 72 20 2e 20 68 68 66 6c 61 67 20 29 addr . hhflag )
1e30: 0a 20 20 28 73 65 72 76 65 72 2d 75 72 6c 20 20 . (server-url
1e40: 20 20 20 20 20 20 28 69 66 20 2a 74 6f 70 70 61 (if *toppa
1e50: 74 68 2a 20 28 73 65 72 76 65 72 3a 63 68 65 63 th* (server:chec
1e60: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f k-if-running *to
1e70: 70 70 61 74 68 2a 29 29 29 20 3b 3b 20 28 73 65 ppath*))) ;; (se
1e80: 72 76 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 rver:check-if-ru
1e90: 6e 6e 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 nning *toppath*)
1ea0: 20 23 66 29 29 0a 20 20 28 6c 61 73 74 2d 73 65 #f)). (last-se
1eb0: 72 76 65 72 2d 63 68 65 63 6b 20 30 29 20 20 3b rver-check 0) ;
1ec0: 3b 20 6c 61 73 74 20 74 69 6d 65 20 77 65 20 63 ; last time we c
1ed0: 68 65 63 6b 65 64 20 74 6f 20 73 65 65 20 69 66 hecked to see if
1ee0: 20 74 68 65 20 73 65 72 76 65 72 20 77 61 73 20 the server was
1ef0: 61 6c 69 76 65 0a 20 20 28 63 6f 6e 6e 64 61 74 alive. (conndat
1f00: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 0a 20 #f).
1f10: 20 28 74 72 61 6e 73 70 6f 72 74 20 20 20 20 20 (transport
1f20: 20 20 20 20 2a 74 72 61 6e 73 70 6f 72 74 2d 74 *transport-t
1f30: 79 70 65 2a 29 0a 20 20 28 73 65 72 76 65 72 2d ype*). (server-
1f40: 74 69 6d 65 6f 75 74 20 20 20 20 28 73 65 72 76 timeout (serv
1f50: 65 72 3a 65 78 70 69 72 61 74 69 6f 6e 2d 74 69 er:expiration-ti
1f60: 6d 65 6f 75 74 29 29 0a 20 20 28 66 6f 72 63 65 meout)). (force
1f70: 2d 73 65 72 76 65 72 20 20 20 20 20 20 23 66 29 -server #f)
1f80: 0a 20 20 28 72 6f 2d 6d 6f 64 65 20 20 20 20 20 . (ro-mode
1f90: 20 20 20 20 20 20 23 66 29 20 20 0a 20 20 28 72 #f) . (r
1fa0: 6f 2d 6d 6f 64 65 2d 63 68 65 63 6b 65 64 20 20 o-mode-checked
1fb0: 20 23 66 29 29 20 3b 3b 20 66 6c 61 67 20 74 68 #f)) ;; flag th
1fc0: 61 74 20 69 6e 64 69 63 61 74 65 73 20 77 65 20 at indicates we
1fd0: 68 61 76 65 20 63 68 65 63 6b 65 64 20 66 6f 72 have checked for
1fe0: 20 72 6f 2d 6d 6f 64 65 0a 0a 3b 3b 20 6c 61 75 ro-mode..;; lau
1ff0: 6e 63 68 69 6e 67 20 61 6e 64 20 68 6f 73 74 73 nching and hosts
2000: 0a 28 64 65 66 73 74 72 75 63 74 20 68 6f 73 74 .(defstruct host
2010: 0a 20 20 28 72 65 61 63 68 61 62 6c 65 20 20 20 . (reachable
2020: 20 23 66 29 0a 20 20 28 6c 61 73 74 2d 75 70 64 #f). (last-upd
2030: 61 74 65 20 20 30 29 0a 20 20 28 6c 61 73 74 2d ate 0). (last-
2040: 75 73 65 64 20 20 20 20 30 29 0a 20 20 28 6c 61 used 0). (la
2050: 73 74 2d 63 70 75 6c 6f 61 64 20 31 29 29 0a 0a st-cpuload 1))..
2060: 28 64 65 66 69 6e 65 20 2a 68 6f 73 74 2d 6c 6f (define *host-lo
2070: 61 64 73 2a 20 20 20 20 20 20 20 20 20 28 6d 61 ads* (ma
2080: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
2090: 0a 3b 3b 20 63 61 63 68 65 20 65 6e 76 69 72 6f .;; cache enviro
20a0: 6e 6d 65 6e 74 20 76 61 72 73 20 66 6f 72 20 65 nment vars for e
20b0: 61 63 68 20 72 75 6e 20 68 65 72 65 0a 28 64 65 ach run here.(de
20c0: 66 69 6e 65 20 2a 65 6e 76 2d 76 61 72 73 2d 62 fine *env-vars-b
20d0: 79 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 6b 65 2d y-run-id* (make-
20e0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b hash-table))..;;
20f0: 20 54 65 73 74 63 6f 6e 66 69 67 20 61 6e 64 20 Testconfig and
2100: 72 75 6e 63 6f 6e 66 69 67 20 63 61 63 68 65 73 runconfig caches
2110: 2e 20 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 . .(define *test
2120: 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 20 20 20 configs*
2130: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
2140: 29 29 20 3b 3b 20 74 65 73 74 2d 6e 61 6d 65 20 )) ;; test-name
2150: 3d 3e 20 74 65 73 74 63 6f 6e 66 69 67 0a 28 64 => testconfig.(d
2160: 65 66 69 6e 65 20 2a 72 75 6e 63 6f 6e 66 69 67 efine *runconfig
2170: 73 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 s* (make
2180: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
2190: 20 74 61 72 67 65 74 20 20 20 20 3d 3e 20 72 75 target => ru
21a0: 6e 63 6f 6e 66 69 67 0a 0a 3b 3b 20 54 68 69 73 nconfig..;; This
21b0: 20 69 73 20 61 20 63 61 63 68 65 20 6f 66 20 70 is a cache of p
21c0: 72 65 2d 72 65 71 73 20 6d 65 74 2c 20 64 6f 6e re-reqs met, don
21d0: 27 74 20 72 65 2d 63 61 6c 63 20 69 6e 20 63 61 't re-calc in ca
21e0: 73 65 73 20 77 68 65 72 65 20 63 61 6c 6c 65 64 ses where called
21f0: 20 77 69 74 68 20 73 61 6d 65 20 70 61 72 61 6d with same param
2200: 73 20 6c 65 73 73 20 74 68 61 6e 0a 3b 3b 20 66 s less than.;; f
2210: 69 76 65 20 73 65 63 6f 6e 64 73 20 61 67 6f 0a ive seconds ago.
2220: 28 64 65 66 69 6e 65 20 2a 70 72 65 2d 72 65 71 (define *pre-req
2230: 73 2d 6d 65 74 2d 63 61 63 68 65 2a 20 28 6d 61 s-met-cache* (ma
2240: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a ke-hash-table)).
2250: 0a 3b 3b 20 63 61 63 68 65 20 6f 66 20 76 65 72 .;; cache of ver
2260: 62 6f 73 69 74 79 20 67 69 76 65 6e 20 73 74 72 bosity given str
2270: 69 6e 67 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 2a ing.;;.(define *
2280: 76 65 72 62 6f 73 69 74 79 2d 63 61 63 68 65 2a verbosity-cache*
2290: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
22a0: 61 62 6c 65 29 29 0a 0a 28 64 65 66 69 6e 65 20 able))..(define
22b0: 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 72 2d 63 61 (common:clear-ca
22c0: 63 68 65 73 29 0a 20 20 28 73 65 74 21 20 2a 74 ches). (set! *t
22d0: 61 72 67 65 74 2a 20 20 20 20 20 20 20 20 20 20 arget*
22e0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
22f0: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 6b ble)). (set! *k
2300: 65 79 73 2a 20 20 20 20 20 20 20 20 20 20 20 20 eys*
2310: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
2320: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 6b ble)). (set! *k
2330: 65 79 76 61 6c 73 2a 20 20 20 20 20 20 20 20 20 eyvals*
2340: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
2350: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 ble)). (set! *t
2360: 6f 70 74 65 73 74 2d 70 61 74 68 73 2a 20 20 20 optest-paths*
2370: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
2380: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 ble)). (set! *t
2390: 65 73 74 2d 70 61 74 68 73 2a 20 20 20 20 20 20 est-paths*
23a0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
23b0: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 ble)). (set! *t
23c0: 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 20 20 est-ids*
23d0: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
23e0: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 ble)). (set! *t
23f0: 65 73 74 2d 69 6e 66 6f 2a 20 20 20 20 20 20 20 est-info*
2400: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
2410: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 72 ble)). (set! *r
2420: 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 20 un-info-cache*
2430: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
2440: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 65 ble)). (set! *e
2450: 6e 76 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 nv-vars-by-run-i
2460: 64 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 d* (make-hash-ta
2470: 62 6c 65 29 29 0a 20 20 28 73 65 74 21 20 2a 74 ble)). (set! *t
2480: 65 73 74 2d 69 64 2d 63 61 63 68 65 2a 20 20 20 est-id-cache*
2490: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
24a0: 62 6c 65 29 29 29 0a 0a 3b 3b 20 47 65 6e 65 72 ble)))..;; Gener
24b0: 69 63 20 73 74 72 69 6e 67 20 64 61 74 61 62 61 ic string databa
24c0: 73 65 0a 28 64 65 66 69 6e 65 20 73 64 62 3a 71 se.(define sdb:q
24d0: 72 79 20 23 66 29 20 3b 3b 20 28 6d 61 6b 65 2d ry #f) ;; (make-
24e0: 73 64 62 3a 71 72 79 29 29 20 3b 3b 20 20 27 69 sdb:qry)) ;; 'i
24f0: 6e 69 74 20 23 66 29 0a 3b 3b 20 47 65 6e 65 72 nit #f).;; Gener
2500: 69 63 20 70 61 74 68 20 64 61 74 61 62 61 73 65 ic path database
2510: 0a 28 64 65 66 69 6e 65 20 2a 66 64 62 2a 20 23 .(define *fdb* #
2520: 66 29 0a 0a 28 64 65 66 69 6e 65 20 2a 6c 61 73 f)..(define *las
2530: 74 2d 6c 61 75 6e 63 68 2a 20 28 63 75 72 72 65 t-launch* (curre
2540: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 3b 3b 20 nt-seconds)) ;;
2550: 75 73 65 20 66 6f 72 20 74 68 72 6f 74 74 6c 69 use for throttli
2560: 6e 67 20 74 68 65 20 6c 61 75 6e 63 68 20 72 61 ng the launch ra
2570: 74 65 2e 20 57 6f 75 6c 64 20 62 65 20 62 65 74 te. Would be bet
2580: 74 65 72 20 74 6f 20 75 73 65 20 74 68 65 20 64 ter to use the d
2590: 62 20 61 6e 64 20 6c 61 73 74 20 74 69 6d 65 20 b and last time
25a0: 6f 66 20 61 20 74 65 73 74 20 69 6e 20 4c 41 55 of a test in LAU
25b0: 4e 43 48 45 44 20 73 74 61 74 65 2e 0a 0a 3b 3b NCHED state...;;
25c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
25f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2600: 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 56 20 45 20 52 20 ======.;; V E R
2610: 53 20 49 20 4f 20 4e 0a 3b 3b 3d 3d 3d 3d 3d 3d S I O N.;;======
2620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2660: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
2670: 6e 3a 67 65 74 2d 66 75 6c 6c 2d 76 65 72 73 69 n:get-full-versi
2680: 6f 6e 29 0a 20 20 28 63 6f 6e 63 20 6d 65 67 61 on). (conc mega
2690: 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 test-version "-"
26a0: 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 73 69 6c megatest-fossil
26b0: 2d 68 61 73 68 29 29 0a 0a 28 64 65 66 69 6e 65 -hash))..(define
26c0: 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e (common:version
26d0: 2d 73 69 67 6e 61 74 75 72 65 29 0a 20 20 28 63 -signature). (c
26e0: 6f 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 72 onc megatest-ver
26f0: 73 69 6f 6e 20 22 2d 22 20 28 73 75 62 73 74 72 sion "-" (substr
2700: 69 6e 67 20 6d 65 67 61 74 65 73 74 2d 66 6f 73 ing megatest-fos
2710: 73 69 6c 2d 68 61 73 68 20 30 20 34 29 29 29 0a sil-hash 0 4))).
2720: 0a 3b 3b 20 66 72 6f 6d 20 6d 65 74 61 64 61 74 .;; from metadat
2730: 20 6c 6f 6f 6b 75 70 20 4d 45 47 41 54 45 53 54 lookup MEGATEST
2740: 5f 56 45 52 53 49 4f 4e 0a 3b 3b 0a 28 64 65 66 _VERSION.;;.(def
2750: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
2760: 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e last-run-version
2770: 29 20 3b 3b 20 52 41 44 54 20 3d 3e 20 48 6f 77 ) ;; RADT => How
2780: 20 64 6f 65 73 20 74 68 69 73 20 77 6f 72 6b 20 does this work
2790: 69 6e 20 73 65 6e 64 2d 72 65 63 65 69 76 65 20 in send-receive
27a0: 66 75 6e 63 74 69 6f 6e 3f 3f 3b 20 61 73 73 75 function??; assu
27b0: 6d 65 20 69 74 20 69 73 20 74 68 65 20 76 61 6c me it is the val
27c0: 75 65 20 73 61 76 65 64 20 69 6e 20 73 6f 6d 65 ue saved in some
27d0: 20 44 42 0a 20 20 28 72 6d 74 3a 67 65 74 2d 76 DB. (rmt:get-v
27e0: 61 72 20 22 4d 45 47 41 54 45 53 54 5f 56 45 52 ar "MEGATEST_VER
27f0: 53 49 4f 4e 22 29 29 0a 0a 28 64 65 66 69 6e 65 SION"))..(define
2800: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 (common:get-las
2810: 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 2d 6e 75 t-run-version-nu
2820: 6d 62 65 72 29 0a 20 20 28 73 74 72 69 6e 67 2d mber). (string-
2830: 3e 6e 75 6d 62 65 72 20 0a 20 20 20 28 73 75 62 >number . (sub
2840: 73 74 72 69 6e 67 20 28 63 6f 6d 6d 6f 6e 3a 67 string (common:g
2850: 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 et-last-run-vers
2860: 69 6f 6e 29 20 30 20 36 29 29 29 0a 0a 28 64 65 ion) 0 6)))..(de
2870: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 fine (common:set
2880: 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f -last-run-versio
2890: 6e 29 0a 20 20 28 72 6d 74 3a 73 65 74 2d 76 61 n). (rmt:set-va
28a0: 72 20 22 4d 45 47 41 54 45 53 54 5f 56 45 52 53 r "MEGATEST_VERS
28b0: 49 4f 4e 22 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 ION" (common:ver
28c0: 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 29 sion-signature))
28d0: 29 0a 0a 3b 3b 20 70 6f 73 74 69 76 65 20 6e 75 )..;; postive nu
28e0: 6d 62 65 72 20 69 66 20 6d 65 67 61 74 65 73 74 mber if megatest
28f0: 20 76 65 72 73 69 6f 6e 20 3e 20 64 62 20 76 65 version > db ve
2900: 72 73 69 6f 6e 0a 3b 3b 20 6e 65 67 61 74 69 76 rsion.;; negativ
2910: 65 20 6e 75 6d 62 65 72 20 69 66 20 6d 65 67 61 e number if mega
2920: 74 65 73 74 20 76 65 72 73 69 6f 6e 20 3c 20 64 test version < d
2930: 62 20 76 65 72 73 69 6f 6e 0a 28 64 65 66 69 6e b version.(defin
2940: 65 20 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f e (common:versio
2950: 6e 2d 64 62 2d 64 65 6c 74 61 29 0a 20 20 20 20 n-db-delta).
2960: 20 20 20 20 20 28 2d 20 6d 65 67 61 74 65 73 74 (- megatest
2970: 2d 76 65 72 73 69 6f 6e 20 28 63 6f 6d 6d 6f 6e -version (common
2980: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
2990: 72 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 29 29 0a rsion-number))).
29a0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
29b0: 3a 76 65 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 :version-changed
29c0: 3f 29 0a 20 20 28 6e 6f 74 20 28 65 71 75 61 6c ?). (not (equal
29d0: 3f 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 ? (common:get-la
29e0: 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 29 0a st-run-version).
29f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
2a00: 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 common:version-s
2a10: 69 67 6e 61 74 75 72 65 29 29 29 29 0a 0a 28 64 ignature))))..(d
2a20: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 70 efine (common:ap
2a30: 69 2d 63 68 61 6e 67 65 64 3f 29 0a 20 20 28 6e i-changed?). (n
2a40: 6f 74 20 28 65 71 75 61 6c 3f 20 28 73 75 62 73 ot (equal? (subs
2a50: 74 72 69 6e 67 20 28 2d 3e 73 74 72 69 6e 67 20 tring (->string
2a60: 6d 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e megatest-version
2a70: 29 20 30 20 34 29 0a 20 20 20 20 20 20 20 20 20 ) 0 4).
2a80: 20 20 20 20 20 20 28 73 75 62 73 74 72 69 6e 67 (substring
2a90: 20 28 63 6f 6e 63 20 28 63 6f 6d 6d 6f 6e 3a 67 (conc (common:g
2aa0: 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 et-last-run-vers
2ab0: 69 6f 6e 29 29 20 30 20 34 29 29 29 29 0a 20 20 ion)) 0 4)))).
2ac0: 0a 3b 3b 20 4d 6f 76 65 20 6d 65 20 65 6c 73 65 .;; Move me else
2ad0: 77 68 65 72 65 20 2e 2e 2e 0a 3b 3b 20 52 41 44 where ....;; RAD
2ae0: 54 20 3d 3e 20 57 68 79 20 64 6f 20 77 65 20 6d T => Why do we m
2af0: 65 65 64 20 74 68 65 20 76 65 72 73 69 6f 6e 20 eed the version
2b00: 63 68 65 63 6b 20 68 65 72 65 2c 20 74 68 69 73 check here, this
2b10: 20 69 73 20 63 61 6c 6c 65 64 20 6f 6e 6c 79 20 is called only
2b20: 69 66 20 76 65 72 73 69 6f 6e 20 6d 69 73 6d 61 if version misma
2b30: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
2b40: 6d 6f 6e 3a 63 6c 65 61 6e 75 70 2d 64 62 20 64 mon:cleanup-db d
2b50: 62 73 74 72 75 63 74 20 23 21 6b 65 79 20 28 66 bstruct #!key (f
2b60: 75 6c 6c 20 23 66 29 29 0a 20 20 28 61 70 70 6c ull #f)). (appl
2b70: 79 20 64 62 3a 6d 75 6c 74 69 2d 64 62 2d 73 79 y db:multi-db-sy
2b80: 6e 63 20 0a 20 20 20 64 62 73 74 72 75 63 74 0a nc . dbstruct.
2b90: 20 20 20 27 73 63 68 65 6d 61 0a 20 20 20 3b 3b 'schema. ;;
2ba0: 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 27 6b 69 'new2old. 'ki
2bb0: 6c 6c 73 65 72 76 65 72 73 0a 20 20 20 27 61 64 llservers. 'ad
2bc0: 6a 2d 74 61 72 67 65 74 0a 20 20 20 3b 3b 20 27 j-target. ;; '
2bd0: 6f 6c 64 32 6e 65 77 0a 20 20 20 27 6e 65 77 32 old2new. 'new2
2be0: 6f 6c 64 0a 20 20 20 3b 3b 20 28 69 66 20 66 75 old. ;; (if fu
2bf0: 6c 6c 0a 20 20 20 20 20 20 20 27 28 64 65 6a 75 ll. '(deju
2c00: 6e 6b 29 0a 20 20 20 20 20 20 20 3b 3b 20 27 28 nk). ;; '(
2c10: 29 29 0a 20 20 20 20 20 20 20 29 0a 20 20 28 69 )). ). (i
2c20: 66 20 28 63 6f 6d 6d 6f 6e 3a 61 70 69 2d 63 68 f (common:api-ch
2c30: 61 6e 67 65 64 3f 29 0a 20 20 20 20 20 20 28 63 anged?). (c
2c40: 6f 6d 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 ommon:set-last-r
2c50: 75 6e 2d 76 65 72 73 69 6f 6e 29 29 29 0a 0a 3b un-version)))..;
2c60: 3b 20 52 6f 74 61 74 65 20 6c 6f 67 73 2c 20 6c ; Rotate logs, l
2c70: 6f 67 69 63 3a 20 0a 3b 3b 20 20 20 20 20 20 20 ogic: .;;
2c80: 20 20 20 20 20 20 20 20 20 20 69 66 20 3e 20 35 if > 5
2c90: 30 30 6b 20 61 6e 64 20 6f 6c 64 65 72 20 74 68 00k and older th
2ca0: 61 6e 20 31 20 77 65 65 6b 3a 0a 3b 3b 20 20 20 an 1 week:.;;
2cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2cc0: 20 20 72 65 6d 6f 76 65 20 70 72 65 76 69 6f 75 remove previou
2cd0: 73 20 63 6f 6d 70 72 65 73 73 65 64 20 6c 6f 67 s compressed log
2ce0: 20 61 6e 64 20 63 6f 6d 70 72 65 73 73 20 74 68 and compress th
2cf0: 69 73 20 6c 6f 67 0a 3b 3b 20 57 41 52 4e 49 4e is log.;; WARNIN
2d00: 47 3a 20 54 68 69 73 20 70 72 6f 63 20 6f 70 65 G: This proc ope
2d10: 72 61 74 65 73 20 61 73 73 75 6d 69 6e 67 20 74 rates assuming t
2d20: 68 61 74 20 69 74 20 69 73 20 69 6e 20 74 68 65 hat it is in the
2d30: 20 64 69 72 65 63 74 6f 72 79 20 61 62 6f 76 65 directory above
2d40: 20 74 68 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 the.;;
2d50: 20 6c 6f 67 73 20 64 69 72 65 63 74 6f 72 79 20 logs directory
2d60: 79 6f 75 20 77 69 73 68 20 74 6f 20 6c 6f 67 2d you wish to log-
2d70: 72 6f 74 61 74 65 2e 0a 3b 3b 0a 28 64 65 66 69 rotate..;;.(defi
2d80: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 6f 74 61 74 ne (common:rotat
2d90: 65 2d 6c 6f 67 73 29 0a 20 20 28 69 66 20 28 6e e-logs). (if (n
2da0: 6f 74 20 28 64 69 72 65 63 74 6f 72 79 2d 65 78 ot (directory-ex
2db0: 69 73 74 73 3f 20 22 6c 6f 67 73 22 29 29 28 63 ists? "logs"))(c
2dc0: 72 65 61 74 65 2d 64 69 72 65 63 74 6f 72 79 20 reate-directory
2dd0: 22 6c 6f 67 73 22 29 29 0a 20 20 28 64 69 72 65 "logs")). (dire
2de0: 63 74 6f 72 79 2d 66 6f 6c 64 20 0a 20 20 20 28 ctory-fold . (
2df0: 6c 61 6d 62 64 61 20 28 66 69 6c 65 20 72 65 6d lambda (file rem
2e00: 29 0a 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 ). (handle-e
2e10: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 xceptions.
2e20: 65 78 6e 0a 20 20 20 20 20 20 28 64 65 62 75 67 exn. (debug
2e30: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
2e40: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2e50: 20 22 66 61 69 6c 65 64 20 74 6f 20 72 6f 74 61 "failed to rota
2e60: 74 65 20 6c 6f 67 20 22 20 66 69 6c 65 20 22 2c te log " file ",
2e70: 20 70 72 6f 62 61 62 6c 79 20 68 61 6e 64 6c 65 probably handle
2e80: 64 20 62 79 20 61 6e 6f 74 68 65 72 20 70 72 6f d by another pro
2e90: 63 65 73 73 2e 22 29 0a 20 20 20 20 20 20 28 6c cess."). (l
2ea0: 65 74 2a 20 28 28 66 75 6c 6c 6e 61 6d 65 20 28 et* ((fullname (
2eb0: 63 6f 6e 63 20 22 6c 6f 67 73 2f 22 20 66 69 6c conc "logs/" fil
2ec0: 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 e)).
2ed0: 20 28 66 69 6c 65 2d 61 67 65 20 28 2d 20 28 63 (file-age (- (c
2ee0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 urrent-seconds)(
2ef0: 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f file-modificatio
2f00: 6e 2d 74 69 6d 65 20 66 75 6c 6c 6e 61 6d 65 29 n-time fullname)
2f10: 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 ))). (if
2f20: 28 6f 72 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (or (and (string
2f30: 2d 6d 61 74 63 68 20 22 5e 2e 2a 2e 6c 6f 67 22 -match "^.*.log"
2f40: 20 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 file).
2f50: 20 20 20 20 20 20 20 20 20 20 20 20 28 3e 20 28 (> (
2f60: 66 69 6c 65 2d 73 69 7a 65 20 66 75 6c 6c 6e 61 file-size fullna
2f70: 6d 65 29 20 32 30 30 30 30 30 29 29 0a 20 20 20 me) 200000)).
2f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6e (an
2f90: 64 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 d (string-match
2fa0: 22 5e 73 65 72 76 65 72 2d 2e 2a 2e 6c 6f 67 22 "^server-.*.log"
2fb0: 20 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 file).
2fc0: 20 20 20 20 20 20 20 20 20 20 20 20 28 3e 20 28 (> (
2fd0: 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e - (current-secon
2fe0: 64 73 29 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 ds) (file-modifi
2ff0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 75 6c 6c cation-time full
3000: 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 name)).
3010: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
3020: 2a 20 38 20 36 30 20 36 30 29 29 29 29 0a 20 20 * 8 60 60)))).
3030: 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 20 28 (let (
3040: 28 67 7a 66 69 6c 65 20 28 63 6f 6e 63 20 66 75 (gzfile (conc fu
3050: 6c 6c 6e 61 6d 65 20 22 2e 67 7a 22 29 29 29 0a llname ".gz"))).
3060: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
3070: 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
3080: 78 69 73 74 73 3f 20 67 7a 66 69 6c 65 29 0a 20 xists? gzfile).
3090: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30a0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 (begin.
30b0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
30c0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
30d0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
30e0: 74 2a 20 22 72 65 6d 6f 76 69 6e 67 20 22 20 67 t* "removing " g
30f0: 7a 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 zfile).
3100: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 65 (dele
3110: 74 65 2d 66 69 6c 65 20 67 7a 66 69 6c 65 29 29 te-file gzfile))
3120: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
3130: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
3140: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
3150: 2d 70 6f 72 74 2a 20 22 63 6f 6d 70 72 65 73 73 -port* "compress
3160: 69 6e 67 20 22 20 66 69 6c 65 29 0a 20 20 20 20 ing " file).
3170: 20 20 20 20 20 20 20 20 20 20 28 73 79 73 74 65 (syste
3180: 6d 20 28 63 6f 6e 63 20 22 67 7a 69 70 20 22 20 m (conc "gzip "
3190: 66 75 6c 6c 6e 61 6d 65 29 29 29 0a 20 20 20 20 fullname))).
31a0: 20 20 20 20 20 20 20 20 28 69 66 20 28 3e 20 66 (if (> f
31b0: 69 6c 65 2d 61 67 65 20 28 2a 20 28 73 74 72 69 ile-age (* (stri
31c0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 6f 72 20 28 ng->number (or (
31d0: 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a configf:lookup *
31e0: 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 configdat* "setu
31f0: 70 22 20 22 6c 6f 67 2d 65 78 70 69 72 65 2d 64 p" "log-expire-d
3200: 61 79 73 22 29 20 22 33 30 22 29 29 20 32 34 20 ays") "30")) 24
3210: 33 36 30 30 29 29 0a 20 20 20 20 20 20 20 20 20 3600)).
3220: 20 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 (handle-e
3230: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 xceptions.
3240: 20 20 20 20 20 20 20 20 20 20 20 65 78 6e 0a 20 exn.
3250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3260: 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 #f.
3270: 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 (delete-file
3280: 20 66 75 6c 6c 6e 61 6d 65 29 29 29 29 29 29 29 fullname)))))))
3290: 0a 20 20 20 27 28 29 0a 20 20 20 22 6c 6f 67 73 . '(). "logs
32a0: 22 29 29 0a 0a 3b 3b 20 46 6f 72 63 65 20 61 20 "))..;; Force a
32b0: 6d 65 67 61 74 65 73 74 20 63 6c 65 61 6e 75 70 megatest cleanup
32c0: 2d 64 62 20 69 66 20 76 65 72 73 69 6f 6e 20 69 -db if version i
32d0: 73 20 63 68 61 6e 67 65 64 20 61 6e 64 20 73 6b s changed and sk
32e0: 69 70 2d 76 65 72 73 69 6f 6e 2d 63 68 65 63 6b ip-version-check
32f0: 20 6e 6f 74 20 73 70 65 63 69 66 69 65 64 0a 3b not specified.;
3300: 3b 20 44 6f 20 4e 4f 54 20 63 68 65 63 6b 20 69 ; Do NOT check i
3310: 66 20 6e 6f 74 20 6f 6e 20 68 6f 6d 65 68 6f 73 f not on homehos
3320: 74 21 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 t!.;;.(define (c
3330: 6f 6d 6d 6f 6e 3a 65 78 69 74 2d 6f 6e 2d 76 65 ommon:exit-on-ve
3340: 72 73 69 6f 6e 2d 63 68 61 6e 67 65 64 29 0a 20 rsion-changed).
3350: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d (if (common:on-
3360: 68 6f 6d 65 68 6f 73 74 3f 29 0a 20 20 20 20 20 homehost?).
3370: 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 61 70 69 (if (common:api
3380: 2d 63 68 61 6e 67 65 64 3f 29 0a 09 20 20 28 6c -changed?).. (l
3390: 65 74 2a 20 28 28 6d 74 63 6f 6e 66 20 28 63 6f et* ((mtconf (co
33a0: 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d nc (get-environm
33b0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 ent-variable "MT
33c0: 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 29 _RUN_AREA_HOME")
33d0: 20 22 2f 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 "/megatest.conf
33e0: 69 67 22 29 29 0a 20 20 20 20 20 20 20 20 20 20 ig")).
33f0: 20 20 20 20 20 20 28 64 62 66 69 6c 65 20 28 63 (dbfile (c
3400: 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e onc (get-environ
3410: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d ment-variable "M
3420: 54 5f 52 55 4e 5f 41 52 45 41 5f 48 4f 4d 45 22 T_RUN_AREA_HOME"
3430: 29 20 22 2f 6d 65 67 61 74 65 73 74 2e 64 62 22 ) "/megatest.db"
3440: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
3450: 20 20 20 28 72 65 61 64 2d 6f 6e 6c 79 20 28 6e (read-only (n
3460: 6f 74 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 ot (file-write-a
3470: 63 63 65 73 73 3f 20 64 62 66 69 6c 65 29 29 29 ccess? dbfile)))
3480: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3490: 20 28 64 62 73 74 72 75 63 74 20 28 64 62 3a 73 (dbstruct (db:s
34a0: 65 74 75 70 20 23 74 29 29 29 0a 09 20 20 20 20 etup #t)))..
34b0: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a (debug:print 0 *
34c0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
34d0: 2a 0a 09 09 09 20 22 57 41 52 4e 49 4e 47 3a 20 *.... "WARNING:
34e0: 56 65 72 73 69 6f 6e 20 6d 69 73 6d 61 74 63 68 Version mismatch
34f0: 21 5c 6e 22 0a 09 09 09 20 22 20 20 20 65 78 70 !\n".... " exp
3500: 65 63 74 65 64 3a 20 22 20 28 63 6f 6d 6d 6f 6e ected: " (common
3510: 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 :version-signatu
3520: 72 65 29 20 22 5c 6e 22 0a 09 09 09 20 22 20 20 re) "\n".... "
3530: 20 67 6f 74 3a 20 20 20 20 20 20 22 20 28 63 6f got: " (co
3540: 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 mmon:get-last-ru
3550: 6e 2d 76 65 72 73 69 6f 6e 29 29 0a 20 20 20 20 n-version)).
3560: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
3570: 20 20 20 20 20 20 20 20 20 20 20 28 28 67 65 74 ((get
3580: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
3590: 69 61 62 6c 65 20 22 4d 54 5f 53 4b 49 50 5f 44 iable "MT_SKIP_D
35a0: 42 5f 4d 49 47 52 41 54 45 22 29 20 23 74 29 0a B_MIGRATE") #t).
35b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 61 ((a
35c0: 6e 64 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d nd (common:file-
35d0: 65 78 69 73 74 73 3f 20 6d 74 63 6f 6e 66 29 20 exists? mtconf)
35e0: 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 (common:file-exi
35f0: 73 74 73 3f 20 64 62 66 69 6c 65 29 20 28 6e 6f sts? dbfile) (no
3600: 74 20 72 65 61 64 2d 6f 6e 6c 79 29 0a 20 20 20 t read-only).
3610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3620: 28 65 71 3f 20 28 63 75 72 72 65 6e 74 2d 75 73 (eq? (current-us
3630: 65 72 2d 69 64 29 28 66 69 6c 65 2d 6f 77 6e 65 er-id)(file-owne
3640: 72 20 6d 74 63 6f 6e 66 29 29 29 20 3b 3b 20 73 r mtconf))) ;; s
3650: 61 66 65 20 74 6f 20 72 75 6e 20 2d 63 6c 65 61 afe to run -clea
3660: 6e 75 70 2d 64 62 0a 20 20 20 20 20 20 20 20 20 nup-db.
3670: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3680: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3690: 2d 70 6f 72 74 2a 20 22 20 20 20 49 20 73 65 65 -port* " I see
36a0: 20 79 6f 75 20 61 72 65 20 74 68 65 20 6f 77 6e you are the own
36b0: 65 72 20 6f 66 20 6d 65 67 61 74 65 73 74 2e 63 er of megatest.c
36c0: 6f 6e 66 69 67 2c 20 61 74 74 65 6d 70 74 69 6e onfig, attemptin
36d0: 67 20 74 6f 20 63 6c 65 61 6e 75 70 20 61 6e 64 g to cleanup and
36e0: 20 72 65 73 65 74 20 74 6f 20 6e 65 77 20 76 65 reset to new ve
36f0: 72 73 69 6f 6e 22 29 0a 20 20 20 20 20 20 20 20 rsion").
3700: 20 20 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 (handle-ex
3710: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 20 ceptions.
3720: 20 20 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 exn.
3730: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
3740: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
3750: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 (debug:print
3760: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
3770: 6f 72 74 2a 20 22 46 61 69 6c 65 64 20 74 6f 20 ort* "Failed to
3780: 73 77 69 74 63 68 20 76 65 72 73 69 6f 6e 73 2e switch versions.
3790: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
37a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
37b0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
37c0: 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a port* " message:
37d0: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
37e0: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
37f0: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
3800: 65 78 6e 29 29 0a 20 20 20 20 20 20 20 20 20 20 exn)).
3810: 20 20 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 (print-ca
3820: 6c 6c 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e ll-chain (curren
3830: 74 2d 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 t-error-port)).
3840: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3850: 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 20 20 (exit 1)).
3860: 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e (common
3870: 3a 63 6c 65 61 6e 75 70 2d 64 62 20 64 62 73 74 :cleanup-db dbst
3880: 72 75 63 74 29 29 29 0a 20 20 20 20 20 20 20 20 ruct))).
3890: 20 20 20 20 20 28 28 6e 6f 74 20 28 63 6f 6d 6d ((not (comm
38a0: 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
38b0: 6d 74 63 6f 6e 66 29 29 0a 20 20 20 20 20 20 20 mtconf)).
38c0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
38d0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
38e0: 6f 67 2d 70 6f 72 74 2a 20 22 20 20 20 6d 65 67 og-port* " meg
38f0: 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 64 6f 65 atest.config doe
3900: 73 20 6e 6f 74 20 65 78 69 73 74 20 69 6e 20 74 s not exist in t
3910: 68 69 73 20 61 72 65 61 2e 20 20 43 61 6e 6e 6f his area. Canno
3920: 74 20 70 72 6f 63 65 65 64 20 77 69 74 68 20 6d t proceed with m
3930: 65 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e 20 egatest version
3940: 6d 69 67 72 61 74 69 6f 6e 2e 22 29 0a 20 20 20 migration.").
3950: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 (exit
3960: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1)).
3970: 20 20 28 28 6e 6f 74 20 28 63 6f 6d 6d 6f 6e 3a ((not (common:
3980: 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 66 file-exists? dbf
3990: 69 6c 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ile)).
39a0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
39b0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
39c0: 70 6f 72 74 2a 20 22 20 20 20 6d 65 67 61 74 65 port* " megate
39d0: 73 74 2e 64 62 20 64 6f 65 73 20 6e 6f 74 20 65 st.db does not e
39e0: 78 69 73 74 20 69 6e 20 74 68 69 73 20 61 72 65 xist in this are
39f0: 61 2e 20 20 43 61 6e 6e 6f 74 20 70 72 6f 63 65 a. Cannot proce
3a00: 65 64 20 77 69 74 68 20 6d 65 67 61 74 65 73 74 ed with megatest
3a10: 20 76 65 72 73 69 6f 6e 20 6d 69 67 72 61 74 69 version migrati
3a20: 6f 6e 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 on.").
3a30: 20 20 20 20 28 65 78 69 74 20 31 29 29 0a 20 20 (exit 1)).
3a40: 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f 74 ((not
3a50: 20 28 65 71 3f 20 28 63 75 72 72 65 6e 74 2d 75 (eq? (current-u
3a60: 73 65 72 2d 69 64 29 28 66 69 6c 65 2d 6f 77 6e ser-id)(file-own
3a70: 65 72 20 6d 74 63 6f 6e 66 29 29 29 0a 20 20 20 er mtconf))).
3a80: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
3a90: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3aa0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 lt-log-port* "
3ab0: 20 59 6f 75 20 64 6f 20 6e 6f 74 20 6f 77 6e 20 You do not own
3ac0: 6d 65 67 61 74 65 73 74 2e 64 62 20 69 6e 20 74 megatest.db in t
3ad0: 68 69 73 20 61 72 65 61 2e 20 20 43 61 6e 6e 6f his area. Canno
3ae0: 74 20 70 72 6f 63 65 65 64 20 77 69 74 68 20 6d t proceed with m
3af0: 65 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e 20 egatest version
3b00: 6d 69 67 72 61 74 69 6f 6e 2e 22 29 0a 20 20 20 migration.").
3b10: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 (exit
3b20: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1)).
3b30: 20 20 28 72 65 61 64 2d 6f 6e 6c 79 0a 20 20 20 (read-only.
3b40: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
3b50: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
3b60: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 lt-log-port* "
3b70: 20 59 6f 75 20 68 61 76 65 20 72 65 61 64 2d 6f You have read-o
3b80: 6e 6c 79 20 61 63 63 65 73 73 20 74 6f 20 74 68 nly access to th
3b90: 69 73 20 61 72 65 61 2e 20 20 43 61 6e 6e 6f 74 is area. Cannot
3ba0: 20 70 72 6f 63 65 65 64 20 77 69 74 68 20 6d 65 proceed with me
3bb0: 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e 20 6d gatest version m
3bc0: 69 67 72 61 74 69 6f 6e 2e 22 29 0a 20 20 20 20 igration.").
3bd0: 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 20 (exit
3be0: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
3bf0: 20 28 65 6c 73 65 0a 20 20 20 20 20 20 20 20 20 (else.
3c00: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
3c10: 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 t 0 *default-log
3c20: 2d 70 6f 72 74 2a 20 22 20 74 6f 20 73 77 69 74 -port* " to swit
3c30: 63 68 20 76 65 72 73 69 6f 6e 73 20 79 6f 75 20 ch versions you
3c40: 63 61 6e 20 72 75 6e 3a 20 5c 22 6d 65 67 61 74 can run: \"megat
3c50: 65 73 74 20 2d 63 6c 65 61 6e 75 70 2d 64 62 5c est -cleanup-db\
3c60: 22 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 "").
3c70: 20 20 28 65 78 69 74 20 31 29 29 29 29 29 29 29 (exit 1)))))))
3c80: 0a 3b 3b 20 20 20 20 20 20 28 62 65 67 69 6e 0a .;; (begin.
3c90: 3b 3b 09 28 64 65 62 75 67 3a 70 72 69 6e 74 20 ;;.(debug:print
3ca0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
3cb0: 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 63 61 6e ort* "ERROR: can
3cc0: 6e 6f 74 20 6d 69 67 72 61 74 65 20 76 65 72 73 not migrate vers
3cd0: 69 6f 6e 20 75 6e 6c 65 73 73 20 6f 6e 20 68 6f ion unless on ho
3ce0: 6d 65 68 6f 73 74 2e 20 45 78 69 74 69 6e 67 2e mehost. Exiting.
3cf0: 22 29 0a 3b 3b 09 28 65 78 69 74 20 31 29 29 29 ").;;.(exit 1)))
3d00: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
3d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 ===========.;; S
3d50: 20 50 20 41 20 52 20 53 20 45 20 20 20 41 20 52 P A R S E A R
3d60: 20 52 20 41 20 59 20 53 0a 3b 3b 3d 3d 3d 3d 3d R A Y S.;;=====
3d70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3db0: 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d 61 6b 65 =..(define (make
3dc0: 2d 73 70 61 72 73 65 2d 61 72 72 61 79 29 0a 20 -sparse-array).
3dd0: 20 28 6c 65 74 20 28 28 61 20 28 6d 61 6b 65 2d (let ((a (make-
3de0: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 29 sparse-vector)))
3df0: 0a 20 20 20 20 28 73 70 61 72 73 65 2d 76 65 63 . (sparse-vec
3e00: 74 6f 72 2d 73 65 74 21 20 61 20 30 20 28 6d 61 tor-set! a 0 (ma
3e10: 6b 65 2d 73 70 61 72 73 65 2d 76 65 63 74 6f 72 ke-sparse-vector
3e20: 29 29 0a 20 20 20 20 61 29 29 0a 0a 28 64 65 66 )). a))..(def
3e30: 69 6e 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 ine (sparse-arra
3e40: 79 3f 20 61 29 0a 20 20 28 61 6e 64 20 28 73 70 y? a). (and (sp
3e50: 61 72 73 65 2d 76 65 63 74 6f 72 3f 20 61 29 0a arse-vector? a).
3e60: 20 20 20 20 20 20 20 28 73 70 61 72 73 65 2d 76 (sparse-v
3e70: 65 63 74 6f 72 3f 20 28 73 70 61 72 73 65 2d 76 ector? (sparse-v
3e80: 65 63 74 6f 72 2d 72 65 66 20 61 20 30 29 29 29 ector-ref a 0)))
3e90: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 61 72 )..(define (spar
3ea0: 73 65 2d 61 72 72 61 79 2d 72 65 66 20 61 20 78 se-array-ref a x
3eb0: 20 79 29 0a 20 20 28 6c 65 74 20 28 28 72 6f 77 y). (let ((row
3ec0: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d (sparse-vector-
3ed0: 72 65 66 20 61 20 78 29 29 29 0a 20 20 20 20 28 ref a x))). (
3ee0: 69 66 20 72 6f 77 0a 09 28 73 70 61 72 73 65 2d if row..(sparse-
3ef0: 76 65 63 74 6f 72 2d 72 65 66 20 72 6f 77 20 79 vector-ref row y
3f00: 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e )..#f)))..(defin
3f10: 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 2d e (sparse-array-
3f20: 73 65 74 21 20 61 20 78 20 79 20 76 61 6c 29 0a set! a x y val).
3f30: 20 20 28 6c 65 74 20 28 28 72 6f 77 20 28 73 70 (let ((row (sp
3f40: 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 20 arse-vector-ref
3f50: 61 20 78 29 29 29 0a 20 20 20 20 28 69 66 20 72 a x))). (if r
3f60: 6f 77 0a 09 28 73 70 61 72 73 65 2d 76 65 63 74 ow..(sparse-vect
3f70: 6f 72 2d 73 65 74 21 20 72 6f 77 20 79 20 76 61 or-set! row y va
3f80: 6c 29 0a 09 28 6c 65 74 20 28 28 6e 65 77 2d 72 l)..(let ((new-r
3f90: 6f 77 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d ow (make-sparse-
3fa0: 76 65 63 74 6f 72 29 29 29 0a 09 20 20 28 73 70 vector))).. (sp
3fb0: 61 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 arse-vector-set!
3fc0: 20 61 20 78 20 6e 65 77 2d 72 6f 77 29 0a 09 20 a x new-row)..
3fd0: 20 28 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d (sparse-vector-
3fe0: 73 65 74 21 20 6e 65 77 2d 72 6f 77 20 79 20 76 set! new-row y v
3ff0: 61 6c 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d al)))))..;;=====
4000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4020: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4040: 3d 0a 3b 3b 20 4c 20 4f 20 43 20 4b 20 45 20 52 =.;; L O C K E R
4050: 20 53 20 20 20 41 20 4e 20 44 20 20 20 42 20 4c S A N D B L
4060: 20 4f 20 43 20 4b 20 45 20 52 20 53 20 0a 3b 3b O C K E R S .;;
4070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
40b0: 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 62 6c 6f 63 6b ======..;; block
40c0: 20 66 75 72 74 68 65 72 20 61 63 63 65 73 73 65 further accesse
40d0: 73 20 74 6f 20 64 61 74 61 62 61 73 65 73 2e 20 s to databases.
40e0: 43 61 6c 6c 20 74 68 69 73 20 62 65 66 6f 72 65 Call this before
40f0: 20 73 68 75 74 74 69 6e 67 20 64 62 20 64 6f 77 shutting db dow
4100: 6e 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f n.(define (commo
4110: 6e 3a 64 62 2d 62 6c 6f 63 6b 2d 66 75 72 74 68 n:db-block-furth
4120: 65 72 2d 71 75 65 72 69 65 73 29 0a 20 20 28 6d er-queries). (m
4130: 75 74 65 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 utex-lock! *db-a
4140: 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 0a 20 20 ccess-mutex*).
4150: 28 73 65 74 21 20 2a 64 62 2d 61 63 63 65 73 73 (set! *db-access
4160: 2d 61 6c 6c 6f 77 65 64 2a 20 23 66 29 0a 20 20 -allowed* #f).
4170: 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a (mutex-unlock! *
4180: 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a db-access-mutex*
4190: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
41a0: 6d 6f 6e 3a 64 62 2d 61 63 63 65 73 73 2d 61 6c mon:db-access-al
41b0: 6c 6f 77 65 64 3f 29 0a 20 20 28 6c 65 74 20 28 lowed?). (let (
41c0: 28 76 61 6c 20 28 62 65 67 69 6e 0a 09 20 20 20 (val (begin..
41d0: 20 20 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b 21 (mutex-lock!
41e0: 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 *db-access-mute
41f0: 78 2a 29 0a 09 20 20 20 20 20 20 20 2a 64 62 2d x*).. *db-
4200: 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 2a 0a access-allowed*.
4210: 09 20 20 20 20 20 20 20 28 6d 75 74 65 78 2d 75 . (mutex-u
4220: 6e 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 nlock! *db-acces
4230: 73 2d 6d 75 74 65 78 2a 29 29 29 29 0a 20 20 20 s-mutex*)))).
4240: 20 76 61 6c 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d val))..;;======
4250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4280: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4290: 0a 3b 3b 20 55 20 53 20 45 20 46 20 55 20 4c 20 .;; U S E F U L
42a0: 20 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d S T U F F.;;==
42b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
42f0: 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 ====..;; convert
4300: 20 74 68 69 6e 67 73 20 74 6f 20 61 6e 20 61 6c things to an al
4310: 69 73 74 20 6f 72 20 61 73 73 6f 63 20 6c 69 73 ist or assoc lis
4320: 74 2c 20 23 66 20 67 65 74 73 20 63 6f 6e 76 65 t, #f gets conve
4330: 72 74 65 64 20 74 6f 20 22 22 0a 3b 3b 0a 28 64 rted to "".;;.(d
4340: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 74 6f efine (common:to
4350: 2d 61 6c 69 73 74 20 64 61 74 29 0a 20 20 28 63 -alist dat). (c
4360: 6f 6e 64 0a 20 20 20 28 28 6c 69 73 74 3f 20 64 ond. ((list? d
4370: 61 74 29 20 20 20 28 6d 61 70 20 63 6f 6d 6d 6f at) (map commo
4380: 6e 3a 74 6f 2d 61 6c 69 73 74 20 64 61 74 29 29 n:to-alist dat))
4390: 0a 20 20 20 28 28 76 65 63 74 6f 72 3f 20 64 61 . ((vector? da
43a0: 74 29 0a 20 20 20 20 28 6d 61 70 20 63 6f 6d 6d t). (map comm
43b0: 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 76 65 63 on:to-alist (vec
43c0: 74 6f 72 2d 3e 6c 69 73 74 20 64 61 74 29 29 29 tor->list dat)))
43d0: 0a 20 20 20 28 28 70 61 69 72 3f 20 64 61 74 29 . ((pair? dat)
43e0: 0a 20 20 20 20 28 63 6f 6e 73 20 28 63 6f 6d 6d . (cons (comm
43f0: 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 61 72 on:to-alist (car
4400: 20 64 61 74 29 29 0a 09 20 20 28 63 6f 6d 6d 6f dat)).. (commo
4410: 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 63 64 72 20 n:to-alist (cdr
4420: 64 61 74 29 29 29 29 0a 20 20 20 28 28 68 61 73 dat)))). ((has
4430: 68 2d 74 61 62 6c 65 3f 20 64 61 74 29 0a 20 20 h-table? dat).
4440: 20 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f (map common:to
4450: 2d 61 6c 69 73 74 20 28 68 61 73 68 2d 74 61 62 -alist (hash-tab
4460: 6c 65 2d 3e 61 6c 69 73 74 20 64 61 74 29 29 29 le->alist dat)))
4470: 0a 20 20 20 28 65 6c 73 65 0a 20 20 20 20 28 69 . (else. (i
4480: 66 20 64 61 74 0a 09 64 61 74 0a 09 22 22 29 29 f dat..dat..""))
4490: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
44a0: 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 mon:low-noise-pr
44b0: 69 6e 74 20 77 61 69 74 76 61 6c 20 2e 20 6b 65 int waitval . ke
44c0: 79 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b 65 ys). (let* ((ke
44d0: 79 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 69 y (string-i
44e0: 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 20 ntersperse (map
44f0: 63 6f 6e 63 20 6b 65 79 73 29 20 22 2d 22 20 29 conc keys) "-" )
4500: 29 0a 09 20 28 6c 61 73 74 74 69 6d 65 20 28 68 ).. (lasttime (h
4510: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
4520: 66 61 75 6c 74 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 fault *common:de
4530: 6e 6f 69 73 65 2a 20 6b 65 79 20 30 29 29 0a 09 noise* key 0))..
4540: 20 28 63 75 72 72 74 69 6d 65 20 28 63 75 72 72 (currtime (curr
4550: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 ent-seconds))).
4560: 20 20 20 28 69 66 20 28 3e 20 28 2d 20 63 75 72 (if (> (- cur
4570: 72 74 69 6d 65 20 6c 61 73 74 74 69 6d 65 29 20 rtime lasttime)
4580: 77 61 69 74 76 61 6c 29 0a 09 28 62 65 67 69 6e waitval)..(begin
4590: 0a 09 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d .. (hash-table-
45a0: 73 65 74 21 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 6e set! *common:den
45b0: 6f 69 73 65 2a 20 6b 65 79 20 63 75 72 72 74 69 oise* key currti
45c0: 6d 65 29 0a 09 20 20 23 74 29 0a 09 23 66 29 29 me).. #t)..#f))
45d0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
45e0: 6f 6e 3a 67 65 74 2d 6d 65 67 61 74 65 73 74 2d on:get-megatest-
45f0: 65 78 65 29 0a 20 20 28 6f 72 20 28 67 65 74 65 exe). (or (gete
4600: 6e 76 20 22 4d 54 5f 4d 45 47 41 54 45 53 54 22 nv "MT_MEGATEST"
4610: 29 20 22 6d 65 67 61 74 65 73 74 22 29 29 0a 0a ) "megatest"))..
4620: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
4630: 72 65 61 64 2d 65 6e 63 6f 64 65 64 2d 73 74 72 read-encoded-str
4640: 69 6e 67 20 69 6e 73 74 72 29 0a 20 20 28 68 61 ing instr). (ha
4650: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
4660: 20 20 20 65 78 6e 0a 20 20 20 28 68 61 6e 64 6c exn. (handl
4670: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 e-exceptions.
4680: 20 65 78 6e 0a 20 20 20 20 28 62 65 67 69 6e 0a exn. (begin.
4690: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
46a0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
46b0: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 ult-log-port* "r
46c0: 65 63 65 69 76 65 64 20 62 61 64 20 65 6e 63 6f eceived bad enco
46d0: 64 65 64 20 73 74 72 69 6e 67 20 5c 22 22 20 69 ded string \"" i
46e0: 6e 73 74 72 20 22 5c 22 2c 20 6d 65 73 73 61 67 nstr "\", messag
46f0: 65 3a 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e e: " ((condition
4700: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
4710: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
4720: 29 20 65 78 6e 29 29 0a 20 20 20 20 20 20 28 70 ) exn)). (p
4730: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
4740: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
4750: 6f 72 74 29 29 0a 20 20 20 20 20 20 23 66 29 0a ort)). #f).
4760: 20 20 20 20 28 72 65 61 64 20 28 6f 70 65 6e 2d (read (open-
4770: 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 28 62 61 input-string (ba
4780: 73 65 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f se64:base64-deco
4790: 64 65 20 69 6e 73 74 72 29 29 29 29 0a 20 20 20 de instr)))).
47a0: 28 72 65 61 64 20 28 6f 70 65 6e 2d 69 6e 70 75 (read (open-inpu
47b0: 74 2d 73 74 72 69 6e 67 20 28 7a 33 3a 64 65 63 t-string (z3:dec
47c0: 6f 64 65 2d 62 75 66 66 65 72 20 28 62 61 73 65 ode-buffer (base
47d0: 36 34 3a 62 61 73 65 36 34 2d 64 65 63 6f 64 65 64:base64-decode
47e0: 20 69 6e 73 74 72 29 29 29 29 29 29 0a 0a 3b 3b instr))))))..;;
47f0: 20 64 6f 74 2d 6c 6f 63 6b 69 6e 67 20 65 67 67 dot-locking egg
4800: 20 73 65 65 6d 73 20 6e 6f 74 20 74 6f 20 77 6f seems not to wo
4810: 72 6b 2c 20 75 73 69 6e 67 20 74 68 69 73 20 66 rk, using this f
4820: 6f 72 20 6e 6f 77 0a 3b 3b 20 69 66 20 6c 6f 63 or now.;; if loc
4830: 6b 20 69 73 20 6f 6c 64 65 72 20 74 68 61 6e 20 k is older than
4840: 65 78 70 69 72 65 2d 74 69 6d 65 20 74 68 65 6e expire-time then
4850: 20 72 65 6d 6f 76 65 20 69 74 20 61 6e 64 20 74 remove it and t
4860: 72 79 20 61 67 61 69 6e 0a 3b 3b 20 74 6f 20 67 ry again.;; to g
4870: 65 74 20 74 68 65 20 6c 6f 63 6b 0a 3b 3b 0a 28 et the lock.;;.(
4880: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
4890: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
48a0: 66 6e 61 6d 65 20 23 21 6b 65 79 20 28 65 78 70 fname #!key (exp
48b0: 69 72 65 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 ire-time 300)).
48c0: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
48d0: 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 ons. exn.
48e0: 20 20 20 20 23 66 20 3b 3b 20 64 6f 6e 27 74 20 #f ;; don't
48f0: 72 65 61 6c 6c 79 20 63 61 72 65 20 77 68 61 74 really care what
4900: 20 77 65 6e 74 20 77 72 6f 6e 67 20 72 69 67 68 went wrong righ
4910: 74 20 6e 6f 77 2e 20 4e 4f 54 45 3a 20 49 20 68 t now. NOTE: I h
4920: 61 76 65 20 6e 6f 74 20 73 65 65 6e 20 74 68 69 ave not seen thi
4930: 73 20 6f 6e 65 20 61 63 74 75 61 6c 6c 79 20 66 s one actually f
4940: 61 69 6c 2e 0a 20 20 20 20 28 69 66 20 28 63 6f ail.. (if (co
4950: 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 mmon:file-exists
4960: 3f 20 66 6e 61 6d 65 29 0a 09 28 69 66 20 28 3e ? fname)..(if (>
4970: 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 63 (- (current-sec
4980: 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f 64 69 66 onds)(file-modif
4990: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 6e 61 ication-time fna
49a0: 6d 65 29 29 20 65 78 70 69 72 65 2d 74 69 6d 65 me)) expire-time
49b0: 29 0a 09 20 20 20 20 28 62 65 67 69 6e 0a 09 20 ).. (begin..
49c0: 20 20 20 20 20 28 64 65 6c 65 74 65 2d 66 69 6c (delete-fil
49d0: 65 2a 20 66 6e 61 6d 65 29 0a 09 20 20 20 20 20 e* fname)..
49e0: 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d (common:simple-
49f0: 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 file-lock fname
4a00: 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 expire-time: exp
4a10: 69 72 65 2d 74 69 6d 65 29 29 0a 09 20 20 20 20 ire-time))..
4a20: 23 66 29 0a 09 28 6c 65 74 20 28 28 6b 65 79 2d #f)..(let ((key-
4a30: 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 67 65 string (conc (ge
4a40: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 20 22 2d 22 t-host-name) "-"
4a50: 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 (current-proces
4a60: 73 2d 69 64 29 29 29 29 0a 09 20 20 28 77 69 74 s-id)))).. (wit
4a70: 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
4a80: 20 66 6e 61 6d 65 0a 09 20 20 20 20 28 6c 61 6d fname.. (lam
4a90: 62 64 61 20 28 29 0a 09 20 20 20 20 20 20 28 70 bda ().. (p
4aa0: 72 69 6e 74 20 6b 65 79 2d 73 74 72 69 6e 67 29 rint key-string)
4ab0: 29 29 0a 09 20 20 28 74 68 72 65 61 64 2d 73 6c )).. (thread-sl
4ac0: 65 65 70 21 20 30 2e 32 35 29 0a 09 20 20 28 69 eep! 0.25).. (i
4ad0: 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 f (common:file-e
4ae0: 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a 09 20 xists? fname)..
4af0: 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 (with-input
4b00: 2d 66 72 6f 6d 2d 66 69 6c 65 20 66 6e 61 6d 65 -from-file fname
4b10: 0a 09 09 28 6c 61 6d 62 64 61 20 28 29 0a 09 09 ...(lambda ()...
4b20: 20 20 28 65 71 75 61 6c 3f 20 6b 65 79 2d 73 74 (equal? key-st
4b30: 72 69 6e 67 20 28 72 65 61 64 2d 6c 69 6e 65 29 ring (read-line)
4b40: 29 29 29 0a 09 20 20 20 20 20 20 23 66 29 29 29 ))).. #f)))
4b50: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
4b60: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
4b70: 6c 6f 63 6b 2d 61 6e 64 2d 77 61 69 74 20 66 6e lock-and-wait fn
4b80: 61 6d 65 20 23 21 6b 65 79 20 28 65 78 70 69 72 ame #!key (expir
4b90: 65 2d 74 69 6d 65 20 33 30 30 29 29 0a 20 20 28 e-time 300)). (
4ba0: 6c 65 74 20 28 28 65 6e 64 2d 74 69 6d 65 20 28 let ((end-time (
4bb0: 2b 20 65 78 70 69 72 65 2d 74 69 6d 65 20 28 63 + expire-time (c
4bc0: 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 urrent-seconds))
4bd0: 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 )). (let loop
4be0: 20 28 28 67 6f 74 2d 6c 6f 63 6b 20 28 63 6f 6d ((got-lock (com
4bf0: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d mon:simple-file-
4c00: 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 78 70 69 72 lock fname expir
4c10: 65 2d 74 69 6d 65 3a 20 65 78 70 69 72 65 2d 74 e-time: expire-t
4c20: 69 6d 65 29 29 29 0a 20 20 20 20 20 20 28 69 66 ime))). (if
4c30: 20 67 6f 74 2d 6c 6f 63 6b 0a 09 20 20 23 74 0a got-lock.. #t.
4c40: 09 20 20 28 69 66 20 28 3e 20 65 6e 64 2d 74 69 . (if (> end-ti
4c50: 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f me (current-seco
4c60: 6e 64 73 29 29 0a 09 20 20 20 20 20 20 28 62 65 nds)).. (be
4c70: 67 69 6e 0a 09 09 28 74 68 72 65 61 64 2d 73 6c gin...(thread-sl
4c80: 65 65 70 21 20 33 29 0a 09 09 28 6c 6f 6f 70 20 eep! 3)...(loop
4c90: 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 (common:simple-f
4ca0: 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 65 ile-lock fname e
4cb0: 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 78 70 69 xpire-time: expi
4cc0: 72 65 2d 74 69 6d 65 29 29 29 0a 09 20 20 20 20 re-time)))..
4cd0: 20 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 #f)))))..(defi
4ce0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c ne (common:simpl
4cf0: 65 2d 66 69 6c 65 2d 72 65 6c 65 61 73 65 2d 6c e-file-release-l
4d00: 6f 63 6b 20 66 6e 61 6d 65 29 0a 20 20 28 68 61 ock fname). (ha
4d10: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
4d20: 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 exn.
4d30: 23 66 20 3b 3b 20 49 20 64 6f 6e 27 74 20 72 65 #f ;; I don't re
4d40: 61 6c 6c 79 20 63 61 72 65 20 77 68 79 20 74 68 ally care why th
4d50: 69 73 20 66 61 69 6c 65 64 20 28 61 74 20 6c 65 is failed (at le
4d60: 61 73 74 20 66 6f 72 20 6e 6f 77 29 0a 20 20 20 ast for now).
4d70: 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 2a 20 66 (delete-file* f
4d80: 6e 61 6d 65 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d name)))..;;=====
4d90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4da0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4db0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4dd0: 3d 0a 3b 3b 20 53 20 54 20 41 20 54 20 45 20 53 =.;; S T A T E S
4de0: 20 20 20 41 20 4e 20 44 20 20 20 53 20 54 20 41 A N D S T A
4df0: 20 54 20 55 20 53 20 45 20 53 0a 3b 3b 3d 3d 3d T U S E S.;;===
4e00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
4e40: 3d 3d 3d 0a 0a 3b 3b 20 42 42 6e 6f 74 65 3a 20 ===..;; BBnote:
4e50: 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 *common:std-stat
4e60: 65 73 2a 20 2d 20 64 61 73 68 62 6f 61 72 64 20 es* - dashboard
4e70: 66 69 6c 74 65 72 20 63 6f 6e 74 72 6f 6c 20 61 filter control a
4e80: 6e 64 20 74 65 73 74 20 63 6f 6e 74 72 6f 6c 20 nd test control
4e90: 73 74 61 74 65 20 62 75 74 74 6f 6e 73 20 64 65 state buttons de
4ea0: 66 69 6e 65 64 20 68 65 72 65 3b 20 75 73 65 64 fined here; used
4eb0: 20 69 6e 20 73 65 74 2d 66 69 65 6c 64 73 2d 70 in set-fields-p
4ec0: 61 6e 65 6c 20 61 6e 64 20 64 62 6f 61 72 64 3a anel and dboard:
4ed0: 6d 61 6b 65 2d 63 6f 6e 74 72 6f 6c 73 0a 28 64 make-controls.(d
4ee0: 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 efine *common:st
4ef0: 64 2d 73 74 61 74 65 73 2a 20 20 20 3b 3b 20 66 d-states* ;; f
4f00: 6f 72 20 74 6f 67 67 6c 65 20 62 75 74 74 6f 6e or toggle button
4f10: 73 20 69 6e 20 64 61 73 68 62 6f 61 72 64 0a 20 s in dashboard.
4f20: 20 27 28 28 30 20 22 41 52 43 48 49 56 45 44 22 '((0 "ARCHIVED"
4f30: 29 0a 20 20 20 20 28 31 20 22 53 54 55 43 4b 22 ). (1 "STUCK"
4f40: 29 0a 20 20 20 20 28 32 20 22 4b 49 4c 4c 52 45 ). (2 "KILLRE
4f50: 51 22 29 0a 20 20 20 20 28 33 20 22 4b 49 4c 4c Q"). (3 "KILL
4f60: 45 44 22 29 0a 20 20 20 20 28 34 20 22 4e 4f 54 ED"). (4 "NOT
4f70: 5f 53 54 41 52 54 45 44 22 29 0a 20 20 20 20 28 _STARTED"). (
4f80: 35 20 22 43 4f 4d 50 4c 45 54 45 44 22 29 0a 20 5 "COMPLETED").
4f90: 20 20 20 28 36 20 22 4c 41 55 4e 43 48 45 44 22 (6 "LAUNCHED"
4fa0: 29 0a 20 20 20 20 28 37 20 22 52 45 4d 4f 54 45 ). (7 "REMOTE
4fb0: 48 4f 53 54 53 54 41 52 54 22 29 0a 20 20 20 20 HOSTSTART").
4fc0: 28 38 20 22 52 55 4e 4e 49 4e 47 22 29 0a 20 20 (8 "RUNNING").
4fd0: 20 20 29 29 0a 0a 3b 3b 20 42 42 6e 6f 74 65 3a ))..;; BBnote:
4fe0: 20 2a 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 *common:std-sta
4ff0: 74 75 73 65 73 2a 20 64 61 73 68 62 6f 61 72 64 tuses* dashboard
5000: 20 66 69 6c 74 65 72 20 63 6f 6e 74 72 6f 6c 20 filter control
5010: 61 6e 64 20 74 65 73 74 20 63 6f 6e 74 72 6f 6c and test control
5020: 20 73 74 61 74 75 73 20 62 75 74 74 6f 6e 73 20 status buttons
5030: 64 65 66 69 6e 65 64 20 68 65 72 65 3b 20 75 73 defined here; us
5040: 65 64 20 69 6e 20 73 65 74 2d 66 69 65 6c 64 73 ed in set-fields
5050: 2d 70 61 6e 65 6c 20 61 6e 64 20 64 62 6f 61 72 -panel and dboar
5060: 64 3a 6d 61 6b 65 2d 63 6f 6e 74 72 6f 6c 73 0a d:make-controls.
5070: 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a (define *common:
5080: 73 74 64 2d 73 74 61 74 75 73 65 73 2a 0a 20 20 std-statuses*.
5090: 27 28 3b 3b 20 28 30 20 22 44 45 4c 45 54 45 44 '(;; (0 "DELETED
50a0: 22 29 0a 20 20 20 20 28 31 20 22 6e 2f 61 22 29 "). (1 "n/a")
50b0: 0a 20 20 20 20 28 32 20 22 50 41 53 53 22 29 0a . (2 "PASS").
50c0: 20 20 20 20 28 33 20 22 53 4b 49 50 22 29 0a 20 (3 "SKIP").
50d0: 20 20 20 28 34 20 22 57 41 52 4e 22 29 0a 20 20 (4 "WARN").
50e0: 20 20 28 35 20 22 57 41 49 56 45 44 22 29 0a 20 (5 "WAIVED").
50f0: 20 20 20 28 36 20 22 43 48 45 43 4b 22 29 0a 20 (6 "CHECK").
5100: 20 20 20 28 37 20 22 53 54 55 43 4b 2f 44 45 41 (7 "STUCK/DEA
5110: 44 22 29 0a 20 20 20 20 28 38 20 22 44 45 41 44 D"). (8 "DEAD
5120: 22 29 0a 20 20 20 20 28 39 20 22 46 41 49 4c 22 "). (9 "FAIL"
5130: 29 0a 20 20 20 20 28 31 30 20 22 50 52 45 51 5f ). (10 "PREQ_
5140: 46 41 49 4c 22 29 0a 20 20 20 20 28 31 31 20 22 FAIL"). (11 "
5150: 41 42 4f 52 54 22 29 29 29 0a 0a 28 64 65 66 69 ABORT")))..(defi
5160: 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 65 6e 64 65 64 ne *common:ended
5170: 2d 73 74 61 74 65 73 2a 20 20 20 20 20 20 20 3b -states* ;
5180: 3b 20 73 74 61 74 65 73 20 77 68 69 63 68 20 69 ; states which i
5190: 6e 64 69 63 61 74 65 20 74 68 65 20 74 65 73 74 ndicate the test
51a0: 20 69 73 20 73 74 6f 70 70 65 64 20 61 6e 64 20 is stopped and
51b0: 77 69 6c 6c 20 6e 6f 74 20 70 72 6f 63 65 65 64 will not proceed
51c0: 0a 20 20 27 28 22 43 4f 4d 50 4c 45 54 45 44 22 . '("COMPLETED"
51d0: 20 22 41 52 43 48 49 56 45 44 22 20 22 4b 49 4c "ARCHIVED" "KIL
51e0: 4c 45 44 22 20 22 4b 49 4c 4c 52 45 51 22 20 22 LED" "KILLREQ" "
51f0: 53 54 55 43 4b 22 20 22 49 4e 43 4f 4d 50 4c 45 STUCK" "INCOMPLE
5200: 54 45 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a TE"))..(define *
5210: 63 6f 6d 6d 6f 6e 3a 62 61 64 6c 79 2d 65 6e 64 common:badly-end
5220: 65 64 2d 73 74 61 74 65 73 2a 20 3b 3b 20 74 68 ed-states* ;; th
5230: 65 73 65 20 72 6f 6c 6c 20 75 70 20 61 73 20 43 ese roll up as C
5240: 48 45 43 4b 2c 20 69 2e 65 2e 20 72 65 73 75 6c HECK, i.e. resul
5250: 74 73 20 6e 65 65 64 20 74 6f 20 62 65 20 63 68 ts need to be ch
5260: 65 63 6b 65 64 0a 20 20 27 28 22 4b 49 4c 4c 45 ecked. '("KILLE
5270: 44 22 20 22 4b 49 4c 4c 52 45 51 22 20 22 53 54 D" "KILLREQ" "ST
5280: 55 43 4b 22 20 22 49 4e 43 4f 4d 50 4c 45 54 45 UCK" "INCOMPLETE
5290: 22 20 22 44 45 41 44 22 29 29 0a 0a 3b 3b 20 42 " "DEAD"))..;; B
52a0: 42 6e 6f 74 65 3a 20 2a 63 6f 6d 6d 6f 6e 3a 72 Bnote: *common:r
52b0: 75 6e 6e 69 6e 67 2d 73 74 61 74 65 73 2a 20 75 unning-states* u
52c0: 73 65 64 20 66 72 6f 6d 20 64 62 3a 73 65 74 2d sed from db:set-
52d0: 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 6e 64 state-status-and
52e0: 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 0a 28 -roll-up-items.(
52f0: 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 72 define *common:r
5300: 75 6e 6e 69 6e 67 2d 73 74 61 74 65 73 2a 20 20 unning-states*
5310: 20 20 20 3b 3b 20 74 65 73 74 20 69 73 20 65 69 ;; test is ei
5320: 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f 72 20 ther running or
5330: 63 61 6e 20 62 65 20 72 75 6e 0a 20 20 27 28 22 can be run. '("
5340: 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f 54 45 RUNNING" "REMOTE
5350: 48 4f 53 54 53 54 41 52 54 22 20 22 4c 41 55 4e HOSTSTART" "LAUN
5360: 43 48 45 44 22 20 22 53 54 41 52 54 45 44 22 29 CHED" "STARTED")
5370: 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d )..(define *comm
5380: 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 61 74 on:cant-run-stat
5390: 65 73 2a 20 20 20 20 3b 3b 20 54 68 65 73 65 20 es* ;; These
53a0: 61 72 65 20 73 74 6f 70 70 69 6e 67 20 63 6f 6e are stopping con
53b0: 64 69 74 69 6f 6e 73 20 74 68 61 74 20 70 72 65 ditions that pre
53c0: 76 65 6e 74 20 61 20 74 65 73 74 20 66 72 6f 6d vent a test from
53d0: 20 62 65 69 6e 67 20 72 75 6e 0a 20 20 27 28 22 being run. '("
53e0: 43 4f 4d 50 4c 45 54 45 44 22 20 22 4b 49 4c 4c COMPLETED" "KILL
53f0: 45 44 22 20 22 55 4e 4b 4e 4f 57 4e 22 20 22 49 ED" "UNKNOWN" "I
5400: 4e 43 4f 4d 50 4c 45 54 45 22 20 22 41 52 43 48 NCOMPLETE" "ARCH
5410: 49 56 45 44 22 29 29 0a 0a 28 64 65 66 69 6e 65 IVED"))..(define
5420: 20 2a 63 6f 6d 6d 6f 6e 3a 6e 6f 74 2d 73 74 61 *common:not-sta
5430: 72 74 65 64 2d 6f 6b 2d 73 74 61 74 75 73 65 73 rted-ok-statuses
5440: 2a 20 3b 3b 20 69 66 20 6e 6f 74 20 6f 6e 65 20 * ;; if not one
5450: 6f 66 20 74 68 65 73 65 20 73 74 61 74 75 73 65 of these statuse
5460: 73 20 77 68 65 6e 20 69 6e 20 6e 6f 74 5f 73 74 s when in not_st
5470: 61 72 74 65 64 20 73 74 61 74 65 20 74 72 65 61 arted state trea
5480: 74 20 61 73 20 64 65 61 64 0a 20 20 27 28 22 6e t as dead. '("n
5490: 2f 61 22 20 22 6e 61 22 20 22 50 41 53 53 22 20 /a" "na" "PASS"
54a0: 22 46 41 49 4c 22 20 22 57 41 52 4e 22 20 22 43 "FAIL" "WARN" "C
54b0: 48 45 43 4b 22 20 22 57 41 49 56 45 44 22 20 22 HECK" "WAIVED" "
54c0: 44 45 41 44 22 20 22 53 4b 49 50 22 29 29 0a 0a DEAD" "SKIP"))..
54d0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
54e0: 73 70 65 63 69 61 6c 2d 73 6f 72 74 20 69 74 65 special-sort ite
54f0: 6d 73 20 6f 72 64 65 72 20 63 6f 6d 70 29 0a 20 ms order comp).
5500: 20 28 6c 65 74 20 28 28 69 74 65 6d 73 2d 6f 72 (let ((items-or
5510: 64 65 72 20 28 6d 61 70 20 72 65 76 65 72 73 65 der (map reverse
5520: 20 6f 72 64 65 72 29 29 0a 20 20 20 20 20 20 20 order)).
5530: 20 28 61 63 6f 6d 70 20 20 20 20 20 20 20 28 6f (acomp (o
5540: 72 20 63 6f 6d 70 20 3e 29 29 29 0a 20 20 20 20 r comp >))).
5550: 28 73 6f 72 74 20 69 74 65 6d 73 0a 20 20 20 20 (sort items.
5560: 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 (lambda (a b
5570: 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 ). (let
5580: 20 28 28 61 2d 6e 75 6d 20 28 63 61 64 72 20 28 ((a-num (cadr (
5590: 6f 72 20 28 61 73 73 6f 63 20 61 20 69 74 65 6d or (assoc a item
55a0: 73 2d 6f 72 64 65 72 29 20 27 28 30 20 30 29 29 s-order) '(0 0))
55b0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
55c0: 20 20 20 28 62 2d 6e 75 6d 20 28 63 61 64 72 20 (b-num (cadr
55d0: 28 6f 72 20 28 61 73 73 6f 63 20 62 20 69 74 65 (or (assoc b ite
55e0: 6d 73 2d 6f 72 64 65 72 29 20 27 28 30 20 30 29 ms-order) '(0 0)
55f0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
5600: 20 28 61 63 6f 6d 70 20 61 2d 6e 75 6d 20 62 2d (acomp a-num b-
5610: 6e 75 6d 29 29 29 29 29 29 0a 0a 3b 3b 20 3b 3b num))))))..;; ;;
5620: 20 67 69 76 65 6e 20 61 20 74 6f 70 6c 65 76 65 given a topleve
5630: 6c 20 77 69 74 68 20 63 75 72 72 73 74 61 74 65 l with currstate
5640: 2c 20 63 75 72 72 73 74 61 74 75 73 20 61 70 70 , currstatus app
5650: 6c 79 20 73 74 61 74 65 20 61 6e 64 20 73 74 61 ly state and sta
5660: 74 75 73 0a 3b 3b 20 3b 3b 20 20 3d 3e 20 28 6e tus.;; ;; => (n
5670: 65 77 73 74 61 74 65 20 2e 20 6e 65 77 73 74 61 ewstate . newsta
5680: 74 75 73 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 tus).;; (define
5690: 28 63 6f 6d 6d 6f 6e 3a 61 70 70 6c 79 2d 73 74 (common:apply-st
56a0: 61 74 65 2d 73 74 61 74 75 73 20 63 75 72 72 73 ate-status currs
56b0: 74 61 74 65 20 63 75 72 72 73 74 61 74 75 73 20 tate currstatus
56c0: 73 74 61 74 65 20 73 74 61 74 75 73 29 0a 3b 3b state status).;;
56d0: 20 20 20 28 6c 65 74 2a 20 28 28 63 73 74 61 74 (let* ((cstat
56e0: 65 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 e (string->symb
56f0: 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 ol (string-downc
5700: 61 73 65 20 63 75 72 72 73 74 61 74 65 29 29 29 ase currstate)))
5710: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 63 73 .;; (cs
5720: 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d 3e 73 tatus (string->s
5730: 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f ymbol (string-do
5740: 77 6e 63 61 73 65 20 63 75 72 72 73 74 61 74 75 wncase currstatu
5750: 73 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 s))).;;
5760: 20 28 73 73 74 61 74 65 20 20 28 73 74 72 69 6e (sstate (strin
5770: 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e g->symbol (strin
5780: 67 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 65 g-downcase state
5790: 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ))).;;
57a0: 28 73 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 (sstatus (string
57b0: 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 ->symbol (string
57c0: 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 75 73 -downcase status
57d0: 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ))).;;
57e0: 28 6e 73 74 61 74 65 20 20 23 66 29 0a 3b 3b 20 (nstate #f).;;
57f0: 20 20 20 20 20 20 20 20 20 28 6e 73 74 61 74 75 (nstatu
5800: 73 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 28 73 s #f)).;; (s
5810: 65 74 21 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 et! nstate.;;
5820: 20 20 20 20 20 20 20 20 28 63 61 73 65 20 63 73 (case cs
5830: 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 tate.;;
5840: 20 20 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 ((completed
5850: 6e 6f 74 5f 73 74 61 72 74 65 64 20 6b 69 6c 6c not_started kill
5860: 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b ed killreq stuck
5870: 20 61 72 63 68 69 76 65 64 29 20 0a 3b 3b 20 20 archived) .;;
5880: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 (cas
5890: 65 20 73 73 74 61 74 65 20 3b 3b 20 63 6f 6d 70 e sstate ;; comp
58a0: 6c 65 74 65 64 20 2d 3e 20 73 73 74 61 74 65 0a leted -> sstate.
58b0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
58c0: 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 ((completed ki
58d0: 6c 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 lled killreq stu
58e0: 63 6b 20 61 72 63 68 69 76 65 64 29 20 63 6f 6d ck archived) com
58f0: 70 6c 65 74 65 64 29 0a 3b 3b 20 20 20 20 20 20 pleted).;;
5900: 20 20 20 20 20 20 20 20 20 20 28 28 72 75 6e 6e ((runn
5910: 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 73 74 ing remotehostst
5920: 61 72 74 20 6c 61 75 6e 63 68 65 64 29 20 20 20 art launched)
5930: 20 20 20 20 20 72 75 6e 6e 69 6e 67 29 0a 3b 3b running).;;
5940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5950: 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 (else
5960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5970: 20 20 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f unkno
5980: 77 6e 2d 65 72 72 6f 72 2d 31 29 29 29 0a 3b 3b wn-error-1))).;;
5990: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 72 ((r
59a0: 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 unning remotehos
59b0: 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 tstart launched)
59c0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
59d0: 20 28 63 61 73 65 20 73 73 74 61 74 65 0a 3b 3b (case sstate.;;
59e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
59f0: 28 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 6c 6c ((completed kill
5a00: 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 63 6b ed killreq stuck
5a10: 20 61 72 63 68 69 76 65 64 29 20 23 66 29 20 3b archived) #f) ;
5a20: 3b 20 6e 65 65 64 20 74 6f 20 6c 6f 6f 6b 20 61 ; need to look a
5a30: 74 20 61 6c 6c 20 69 74 65 6d 73 0a 3b 3b 20 20 t all items.;;
5a40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
5a50: 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f running remoteho
5a60: 73 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 ststart launched
5a70: 29 20 20 20 20 20 20 20 20 72 75 6e 6e 69 6e 67 ) running
5a80: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
5a90: 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 (else
5aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 75 u
5ac0: 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 32 29 29 nknown-error-2))
5ad0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
5ae0: 20 28 65 6c 73 65 20 75 6e 6b 6e 6f 77 6e 2d 65 (else unknown-e
5af0: 72 72 6f 72 2d 33 29 29 29 0a 3b 3b 20 20 20 20 rror-3))).;;
5b00: 20 28 73 65 74 21 20 6e 73 74 61 74 75 73 0a 3b (set! nstatus.;
5b10: 3b 20 20 20 20 20 20 20 20 20 20 20 28 63 61 73 ; (cas
5b20: 65 20 73 73 74 61 74 75 73 0a 3b 3b 20 20 20 20 e sstatus.;;
5b30: 20 20 20 20 20 20 20 20 20 28 28 70 61 73 73 29 ((pass)
5b40: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 .;;
5b50: 20 28 63 61 73 65 20 6e 73 74 61 74 65 0a 3b 3b (case nstate.;;
5b60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5b70: 28 28 70 61 73 73 20 6e 2f 61 20 64 65 6c 65 74 ((pass n/a delet
5b80: 65 64 29 20 20 20 20 20 70 61 73 73 29 0a 3b 3b ed) pass).;;
5b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5ba0: 28 28 77 61 72 6e 29 20 20 20 20 20 20 20 20 20 ((warn)
5bb0: 20 20 20 20 20 20 20 20 77 61 72 6e 29 0a 3b 3b warn).;;
5bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5bd0: 28 28 66 61 69 6c 29 20 20 20 20 20 20 20 20 20 ((fail)
5be0: 20 20 20 20 20 20 20 20 66 61 69 6c 29 0a 3b 3b fail).;;
5bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c00: 28 28 63 68 65 63 6b 29 20 20 20 20 20 20 20 20 ((check)
5c10: 20 20 20 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b check).;;
5c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c30: 28 28 77 61 69 76 65 64 29 20 20 20 20 20 20 20 ((waived)
5c40: 20 20 20 20 20 20 77 61 69 76 65 64 29 0a 3b 3b waived).;;
5c50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c60: 28 28 73 6b 69 70 29 20 20 20 20 20 20 20 20 20 ((skip)
5c70: 20 20 20 20 20 20 20 20 73 6b 69 70 29 0a 3b 3b skip).;;
5c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5c90: 28 28 73 74 75 63 6b 2f 64 65 61 64 29 20 20 20 ((stuck/dead)
5ca0: 20 20 20 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b stuck).;;
5cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cc0: 28 28 61 62 6f 72 74 29 20 20 20 20 20 20 20 20 ((abort)
5cd0: 20 20 20 20 20 20 20 61 62 6f 72 74 29 0a 3b 3b abort).;;
5ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5cf0: 28 65 6c 73 65 20 20 20 20 20 20 20 20 75 6e 6b (else unk
5d00: 6e 6f 77 6e 2d 65 72 72 6f 72 2d 34 29 29 29 0a nown-error-4))).
5d10: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ;; (
5d20: 28 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 20 20 (warn).;;
5d30: 20 20 20 20 20 20 20 28 63 61 73 65 20 6e 73 74 (case nst
5d40: 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ate.;;
5d50: 20 20 20 20 20 20 28 28 70 61 73 73 20 77 61 72 ((pass war
5d60: 6e 20 6e 2f 61 20 73 6b 69 70 20 64 65 6c 65 74 n n/a skip delet
5d70: 65 64 29 20 20 20 77 61 72 6e 29 0a 3b 3b 20 20 ed) warn).;;
5d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
5d90: 66 61 69 6c 29 20 20 20 20 20 20 20 20 20 20 20 fail)
5da0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 66 61 fa
5db0: 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 il).;;
5dc0: 20 20 20 20 20 20 28 28 63 68 65 63 6b 29 20 20 ((check)
5dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5de0: 20 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b 20 20 check).;;
5df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
5e00: 77 61 69 76 65 64 29 20 20 20 20 20 20 20 20 20 waived)
5e10: 20 20 20 20 20 20 20 20 20 20 20 20 77 61 69 76 waiv
5e20: 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ed).;;
5e30: 20 20 20 20 20 20 28 28 73 74 75 63 6b 2f 64 65 ((stuck/de
5e40: 61 64 29 20 20 20 20 20 20 20 20 20 20 20 20 20 ad)
5e50: 20 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b 20 20 stuck).;;
5e60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 65 (e
5e70: 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 20 20 lse
5e80: 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 unknown-error
5e90: 2d 35 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 -5))).;;
5ea0: 20 20 20 20 20 28 28 66 61 69 6c 29 0a 3b 3b 20 ((fail).;;
5eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 (ca
5ec0: 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 20 20 se nstate.;;
5ed0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 ((pa
5ee0: 73 73 20 77 61 72 6e 20 66 61 69 6c 20 63 68 65 ss warn fail che
5ef0: 63 6b 20 6e 2f 61 20 77 61 69 76 65 64 20 73 6b ck n/a waived sk
5f00: 69 70 20 64 65 6c 65 74 65 64 20 73 74 75 63 6b ip deleted stuck
5f10: 2f 64 65 61 64 20 73 74 75 63 6b 29 20 20 66 61 /dead stuck) fa
5f20: 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 il).;;
5f30: 20 20 20 20 20 20 28 28 61 62 6f 72 74 29 20 20 ((abort)
5f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f70: 20 20 20 20 20 20 20 61 62 6f 72 74 29 0a 3b 3b abort).;;
5f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f90: 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 (else
5fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fc0: 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 unknown-e
5fd0: 72 72 6f 72 2d 36 29 29 29 0a 3b 3b 20 20 20 20 rror-6))).;;
5fe0: 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 20 (else
5ff0: 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d unknown-error-
6000: 37 29 29 29 0a 3b 3b 20 20 20 20 20 28 63 6f 6e 7))).;; (con
6010: 73 20 0a 3b 3b 20 20 20 20 20 20 28 69 66 20 6e s .;; (if n
6020: 73 74 61 74 65 20 20 28 73 79 6d 62 6f 6c 2d 3e state (symbol->
6030: 73 74 72 69 6e 67 20 6e 73 74 61 74 65 29 20 20 string nstate)
6040: 6e 73 74 61 74 65 29 0a 3b 3b 20 20 20 20 20 20 nstate).;;
6050: 28 69 66 20 6e 73 74 61 74 75 73 20 28 73 79 6d (if nstatus (sym
6060: 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 73 74 61 bol->string nsta
6070: 74 75 73 29 20 6e 73 74 61 74 75 73 29 29 29 29 tus) nstatus))))
6080: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
6090: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
60a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 45 =========.;; D E
60e0: 20 42 20 55 20 47 20 47 20 49 20 4e 20 47 20 20 B U G G I N G
60f0: 20 53 20 54 20 55 20 46 20 46 20 0a 3b 3b 3d 3d S T U F F .;;==
6100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6140: 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 2a 76 ====..(define *v
6150: 65 72 62 6f 73 69 74 79 2a 20 20 20 20 20 20 20 erbosity*
6160: 20 20 31 29 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 1).(define *lo
6170: 67 67 69 6e 67 2a 20 20 20 20 20 20 20 20 20 20 gging*
6180: 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 #f)..(define (g
6190: 65 74 2d 77 69 74 68 2d 64 65 66 61 75 6c 74 20 et-with-default
61a0: 76 61 6c 20 64 65 66 61 75 6c 74 29 0a 20 20 28 val default). (
61b0: 6c 65 74 20 28 28 76 61 6c 20 28 61 72 67 73 3a let ((val (args:
61c0: 67 65 74 2d 61 72 67 20 76 61 6c 29 29 29 0a 20 get-arg val))).
61d0: 20 20 20 28 69 66 20 76 61 6c 20 76 61 6c 20 64 (if val val d
61e0: 65 66 61 75 6c 74 29 29 29 0a 0a 28 64 65 66 69 efault)))..(defi
61f0: 6e 65 20 28 61 73 73 6f 63 2f 64 65 66 61 75 6c ne (assoc/defaul
6200: 74 20 6b 65 79 20 6c 73 74 20 2e 20 64 65 66 61 t key lst . defa
6210: 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 72 65 ult). (let ((re
6220: 73 20 28 61 73 73 6f 63 20 6b 65 79 20 6c 73 74 s (assoc key lst
6230: 29 29 29 0a 20 20 20 20 28 69 66 20 72 65 73 20 ))). (if res
6240: 28 63 61 64 72 20 72 65 73 29 28 69 66 20 28 6e (cadr res)(if (n
6250: 75 6c 6c 3f 20 64 65 66 61 75 6c 74 29 20 23 66 ull? default) #f
6260: 20 28 63 61 72 20 64 65 66 61 75 6c 74 29 29 29 (car default)))
6270: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
6280: 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 74 mon:get-testsuit
6290: 65 2d 6e 61 6d 65 29 0a 20 20 28 6f 72 20 28 63 e-name). (or (c
62a0: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
62b0: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
62c0: 22 20 22 61 72 65 61 2d 6e 61 6d 65 22 29 20 3b " "area-name") ;
62d0: 3b 20 6d 65 67 61 74 65 73 74 20 69 73 20 61 20 ; megatest is a
62e0: 66 6c 65 78 69 62 6c 65 20 74 6f 6f 6c 2c 20 74 flexible tool, t
62f0: 65 73 74 73 75 69 74 65 20 69 73 20 74 6f 6f 20 estsuite is too
6300: 6c 69 6d 69 74 69 6e 67 20 61 20 64 65 73 63 72 limiting a descr
6310: 69 70 74 69 6f 6e 2e 0a 20 20 20 20 20 20 28 63 iption.. (c
6320: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
6330: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
6340: 22 20 22 74 65 73 74 73 75 69 74 65 22 20 29 0a " "testsuite" ).
6350: 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 22 4d (getenv "M
6360: 54 5f 54 45 53 54 53 55 49 54 45 5f 4e 41 4d 45 T_TESTSUITE_NAME
6370: 22 29 0a 20 20 20 20 20 20 28 69 66 20 28 73 74 "). (if (st
6380: 72 69 6e 67 3f 20 2a 74 6f 70 70 61 74 68 2a 20 ring? *toppath*
6390: 29 0a 20 20 20 20 20 20 20 20 20 20 28 70 61 74 ). (pat
63a0: 68 6e 61 6d 65 2d 66 69 6c 65 20 2a 74 6f 70 70 hname-file *topp
63b0: 61 74 68 2a 29 0a 20 20 20 20 20 20 20 20 20 20 ath*).
63c0: 23 66 29 29 29 20 3b 3b 20 28 70 61 74 68 6e 61 #f))) ;; (pathna
63d0: 6d 65 2d 66 69 6c 65 20 28 63 75 72 72 65 6e 74 me-file (current
63e0: 2d 64 69 72 65 63 74 6f 72 79 29 29 29 29 29 0a -directory))))).
63f0: 0a 28 64 65 66 69 6e 65 20 63 6f 6d 6d 6f 6e 3a .(define common:
6400: 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 20 63 6f get-area-name co
6410: 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 69 mmon:get-testsui
6420: 74 65 2d 6e 61 6d 65 29 0a 0a 28 64 65 66 69 6e te-name)..(defin
6430: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 e (common:get-db
6440: 2d 74 6d 70 2d 61 72 65 61 20 2e 20 6a 75 6e 6b -tmp-area . junk
6450: 29 0a 20 20 28 69 66 20 2a 64 62 2d 63 61 63 68 ). (if *db-cach
6460: 65 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 2a 64 e-path*. *d
6470: 62 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 20 b-cache-path*.
6480: 20 20 20 20 28 69 66 20 2a 74 6f 70 70 61 74 68 (if *toppath
6490: 2a 20 3b 3b 20 63 6f 6d 6d 6f 6e 3a 67 65 74 2d * ;; common:get-
64a0: 63 72 65 61 74 65 2d 77 72 69 74 65 61 62 6c 65 create-writeable
64b0: 2d 64 69 72 0a 09 20 20 28 68 61 6e 64 6c 65 2d -dir.. (handle-
64c0: 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 20 20 20 exceptions..
64d0: 20 20 65 78 6e 0a 09 20 20 20 20 20 20 28 62 65 exn.. (be
64e0: 67 69 6e 0a 09 09 28 64 65 62 75 67 3a 70 72 69 gin...(debug:pri
64f0: 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
6500: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 43 ult-log-port* "C
6510: 6f 75 6c 64 6e 27 74 20 63 72 65 61 74 65 20 70 ouldn't create p
6520: 61 74 68 20 74 6f 20 22 20 64 62 64 69 72 29 0a ath to " dbdir).
6530: 09 09 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 ..(exit 1))..
6540: 20 28 6c 65 74 20 28 28 64 62 70 61 74 68 20 28 (let ((dbpath (
6550: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 74 common:get-creat
6560: 65 2d 77 72 69 74 65 61 62 6c 65 2d 64 69 72 0a e-writeable-dir.
6570: 09 09 09 20 20 20 28 6c 69 73 74 20 28 63 6f 6e ... (list (con
6580: 63 20 22 2f 74 6d 70 2f 22 20 28 63 75 72 72 65 c "/tmp/" (curre
6590: 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 0a 09 09 nt-user-name)...
65a0: 09 09 20 20 20 20 20 20 20 22 2f 6d 65 67 61 74 .. "/megat
65b0: 65 73 74 5f 6c 6f 63 61 6c 64 62 2f 22 0a 09 09 est_localdb/"...
65c0: 09 09 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e .. (common
65d0: 3a 67 65 74 2d 74 65 73 74 73 75 69 74 65 2d 6e :get-testsuite-n
65e0: 61 6d 65 29 20 22 2f 22 0a 09 09 09 09 20 20 20 ame) "/".....
65f0: 20 20 20 20 28 73 74 72 69 6e 67 2d 74 72 61 6e (string-tran
6600: 73 6c 61 74 65 20 2a 74 6f 70 70 61 74 68 2a 20 slate *toppath*
6610: 22 2f 22 20 22 2e 22 29 29 29 29 29 29 20 3b 3b "/" ".")))))) ;;
6620: 20 20 23 74 29 29 29 29 0a 09 20 20 20 20 20 20 #t))))..
6630: 28 73 65 74 21 20 2a 64 62 2d 63 61 63 68 65 2d (set! *db-cache-
6640: 70 61 74 68 2a 20 64 62 70 61 74 68 29 0a 09 20 path* dbpath)..
6650: 20 20 20 20 20 64 62 70 61 74 68 29 29 0a 09 20 dbpath))..
6660: 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f)))..(define
6670: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 (common:get-area
6680: 2d 70 61 74 68 2d 73 69 67 6e 61 74 75 72 65 29 -path-signature)
6690: 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 . (message-dige
66a0: 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 st-string (md5-p
66b0: 72 69 6d 69 74 69 76 65 29 20 2a 74 6f 70 70 61 rimitive) *toppa
66c0: 74 68 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 th*))..(define (
66d0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 73 69 67 6e 61 common:get-signa
66e0: 74 75 72 65 20 73 74 72 29 0a 20 20 28 6d 65 73 ture str). (mes
66f0: 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 72 69 sage-digest-stri
6700: 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 69 76 ng (md5-primitiv
6710: 65 29 20 73 74 72 29 29 0a 0a 3b 3b 3d 3d 3d 3d e) str))..;;====
6720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6760: 3d 3d 0a 3b 3b 20 45 20 58 20 49 20 54 20 20 20 ==.;; E X I T
6770: 48 20 41 20 4e 20 44 20 4c 20 49 20 4e 20 47 0a H A N D L I N G.
6780: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
67a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
67b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
67c0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
67d0: 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 e (common:run-sy
67e0: 6e 63 3f 29 0a 20 20 20 20 28 61 6e 64 20 28 63 nc?). (and (c
67f0: 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 ommon:on-homehos
6800: 74 3f 29 0a 09 20 28 61 72 67 73 3a 67 65 74 2d t?).. (args:get-
6810: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 29 arg "-server")))
6820: 0a 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 6f 68 ..;; (let ((oh
6830: 68 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d h (common:on-hom
6840: 65 68 6f 73 74 3f 29 29 0a 3b 3b 20 09 28 73 72 ehost?)).;; .(sr
6850: 76 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 v (args:get-arg
6860: 22 2d 73 65 72 76 65 72 22 29 29 29 0a 3b 3b 20 "-server"))).;;
6870: 20 20 20 20 28 61 6e 64 20 6f 68 68 20 73 72 76 (and ohh srv
6880: 29 29 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 75 ))). ;; (debu
6890: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
68a0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
68b0: 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 * "common:run-sy
68c0: 6e 63 3f 20 6f 68 68 3d 22 20 6f 68 68 20 22 2c nc? ohh=" ohh ",
68d0: 20 73 72 76 3d 22 20 73 72 76 29 0a 0a 0a 0a 28 srv=" srv)....(
68e0: 64 65 66 69 6e 65 20 2a 77 64 6e 75 6d 2a 20 30 define *wdnum* 0
68f0: 29 0a 28 64 65 66 69 6e 65 20 2a 77 64 6e 75 6d ).(define *wdnum
6900: 2a 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 *mutex (make-mut
6910: 65 78 29 29 0a 3b 3b 20 63 75 72 72 65 6e 74 6c ex)).;; currentl
6920: 79 20 74 68 65 20 70 72 69 6d 61 72 79 20 6a 6f y the primary jo
6930: 62 20 6f 66 20 74 68 65 20 77 61 74 63 68 64 6f b of the watchdo
6940: 67 20 69 73 20 74 6f 20 72 75 6e 20 74 68 65 20 g is to run the
6950: 73 79 6e 63 20 62 61 63 6b 20 74 6f 20 6d 65 67 sync back to meg
6960: 61 74 65 73 74 2e 64 62 20 66 72 6f 6d 20 74 68 atest.db from th
6970: 65 20 64 62 20 69 6e 20 2f 74 6d 70 0a 3b 3b 20 e db in /tmp.;;
6980: 69 66 20 77 65 20 61 72 65 20 6f 6e 20 74 68 65 if we are on the
6990: 20 68 6f 6d 65 68 6f 73 74 20 61 6e 64 20 77 65 homehost and we
69a0: 20 61 72 65 20 61 20 73 65 72 76 65 72 20 28 62 are a server (b
69b0: 79 20 64 65 66 69 6e 69 74 69 6f 6e 20 77 65 20 y definition we
69c0: 61 72 65 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 are on the homeh
69d0: 6f 73 74 20 69 66 20 77 65 20 61 72 65 20 61 20 ost if we are a
69e0: 73 65 72 76 65 72 29 0a 3b 3b 0a 0a 0a 28 64 65 server).;;...(de
69f0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 fine (common:rea
6a00: 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 64 donly-watchdog d
6a10: 62 73 74 72 75 63 74 29 0a 20 20 28 74 68 72 65 bstruct). (thre
6a20: 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 20 ad-sleep! 0.05)
6a30: 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 73 74 61 ;; delay for sta
6a40: 72 74 75 70 0a 20 20 28 64 65 62 75 67 3a 70 72 rtup. (debug:pr
6a50: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
6a60: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6a70: 63 6f 6d 6d 6f 6e 3a 72 65 61 64 6f 6e 6c 79 2d common:readonly-
6a80: 77 61 74 63 68 64 6f 67 20 65 6e 74 65 72 65 64 watchdog entered
6a90: 2e 22 29 0a 20 20 3b 3b 20 73 79 6e 63 20 6d 65 ."). ;; sync me
6aa0: 67 61 74 65 73 74 2e 64 62 20 74 6f 20 2f 74 6d gatest.db to /tm
6ab0: 70 2f 2e 2e 2e 2f 6d 65 67 61 74 73 74 2e 64 62 p/.../megatst.db
6ac0: 0a 20 20 28 6c 65 74 2a 20 28 28 73 79 6e 63 2d . (let* ((sync-
6ad0: 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 6f cool-off-duratio
6ae0: 6e 20 20 20 33 29 0a 20 20 20 20 20 20 20 20 28 n 3). (
6af0: 67 6f 6c 64 65 6e 2d 6d 74 64 62 20 20 20 20 20 golden-mtdb
6b00: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 6d 74 (dbr:dbstruct-mt
6b10: 64 62 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 db dbstruct)).
6b20: 20 20 20 20 20 20 28 67 6f 6c 64 65 6e 2d 6d 74 (golden-mt
6b30: 70 61 74 68 20 20 20 28 64 62 3a 64 62 64 61 74 path (db:dbdat
6b40: 2d 67 65 74 2d 70 61 74 68 20 67 6f 6c 64 65 6e -get-path golden
6b50: 2d 6d 74 64 62 29 29 0a 20 20 20 20 20 20 20 20 -mtdb)).
6b60: 28 74 6d 70 2d 6d 74 64 62 20 20 20 20 20 20 20 (tmp-mtdb
6b70: 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 74 (dbr:dbstruct-t
6b80: 6d 70 64 62 20 64 62 73 74 72 75 63 74 29 29 0a mpdb dbstruct)).
6b90: 20 20 20 20 20 20 20 20 28 74 6d 70 2d 6d 74 70 (tmp-mtp
6ba0: 61 74 68 20 20 20 20 20 20 28 64 62 3a 64 62 64 ath (db:dbd
6bb0: 61 74 2d 67 65 74 2d 70 61 74 68 20 74 6d 70 2d at-get-path tmp-
6bc0: 6d 74 64 62 29 29 29 0a 20 20 20 20 28 64 65 62 mtdb))). (deb
6bd0: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
6be0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6bf0: 74 2a 20 22 52 65 61 64 2d 6f 6e 6c 79 20 70 65 t* "Read-only pe
6c00: 72 69 6f 64 69 63 20 73 79 6e 63 20 74 68 72 65 riodic sync thre
6c10: 61 64 20 73 74 61 72 74 65 64 2e 22 29 0a 20 20 ad started.").
6c20: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 61 (let loop ((la
6c30: 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 30 29 29 st-sync-time 0))
6c40: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
6c50: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
6c60: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6c70: 6c 6f 6f 70 20 74 6f 70 20 74 6d 70 2d 6d 74 70 loop top tmp-mtp
6c80: 61 74 68 3d 22 74 6d 70 2d 6d 74 70 61 74 68 22 ath="tmp-mtpath"
6c90: 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 3d 22 golden-mtpath="
6ca0: 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 29 0a 20 golden-mtpath).
6cb0: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 75 72 (let* ((dur
6cc0: 61 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 ation-since-last
6cd0: 2d 73 79 6e 63 20 28 2d 20 28 63 75 72 72 65 6e -sync (- (curren
6ce0: 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d t-seconds) last-
6cf0: 73 79 6e 63 2d 74 69 6d 65 29 29 29 0a 20 20 20 sync-time))).
6d00: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6d10: 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 t-info 13 *defau
6d20: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 75 lt-log-port* "du
6d30: 72 61 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 ration-since-las
6d40: 74 2d 73 79 6e 63 3d 22 64 75 72 61 74 69 6f 6e t-sync="duration
6d50: 2d 73 69 6e 63 65 2d 6c 61 73 74 2d 73 79 6e 63 -since-last-sync
6d60: 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 61 ). (if (a
6d70: 6e 64 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f nd (not *time-to
6d80: 2d 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 20 -exit*).
6d90: 20 20 20 20 20 20 20 20 20 28 3c 20 64 75 72 61 (< dura
6da0: 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 2d tion-since-last-
6db0: 73 79 6e 63 20 73 79 6e 63 2d 63 6f 6f 6c 2d 6f sync sync-cool-o
6dc0: 66 66 2d 64 75 72 61 74 69 6f 6e 29 29 0a 20 20 ff-duration)).
6dd0: 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 (threa
6de0: 64 2d 73 6c 65 65 70 21 20 28 2d 20 73 79 6e 63 d-sleep! (- sync
6df0: 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 -cool-off-durati
6e00: 6f 6e 20 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 on duration-sinc
6e10: 65 2d 6c 61 73 74 2d 73 79 6e 63 29 29 29 0a 20 e-last-sync))).
6e20: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
6e30: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a *time-to-exit*).
6e40: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
6e50: 20 28 28 67 6f 6c 64 65 6e 2d 6d 74 64 62 2d 6d ((golden-mtdb-m
6e60: 74 69 6d 65 20 28 66 69 6c 65 2d 6d 6f 64 69 66 time (file-modif
6e70: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 67 6f 6c ication-time gol
6e80: 64 65 6e 2d 6d 74 70 61 74 68 29 29 0a 20 20 20 den-mtpath)).
6e90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
6ea0: 74 6d 70 2d 6d 74 64 62 2d 6d 74 69 6d 65 20 20 tmp-mtdb-mtime
6eb0: 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 (file-modifica
6ec0: 74 69 6f 6e 2d 74 69 6d 65 20 74 6d 70 2d 6d 74 tion-time tmp-mt
6ed0: 70 61 74 68 29 29 29 0a 09 20 20 20 20 20 20 28 path))).. (
6ee0: 69 66 20 28 3e 20 67 6f 6c 64 65 6e 2d 6d 74 64 if (> golden-mtd
6ef0: 62 2d 6d 74 69 6d 65 20 74 6d 70 2d 6d 74 64 62 b-mtime tmp-mtdb
6f00: 2d 6d 74 69 6d 65 29 0a 09 09 20 20 28 69 66 20 -mtime)... (if
6f10: 28 3c 20 67 6f 6c 64 65 6e 2d 6d 74 64 62 2d 6d (< golden-mtdb-m
6f20: 74 69 6d 65 20 28 2d 20 28 63 75 72 72 65 6e 74 time (- (current
6f30: 2d 73 65 63 6f 6e 64 73 29 20 33 29 29 20 3b 3b -seconds) 3)) ;;
6f40: 20 66 69 6c 65 20 68 61 73 20 4e 4f 54 20 62 65 file has NOT be
6f50: 65 6e 20 74 6f 75 63 68 65 64 20 69 6e 20 70 61 en touched in pa
6f60: 73 74 20 74 68 72 65 65 20 73 65 63 6f 6e 64 73 st three seconds
6f70: 2c 20 74 68 69 73 20 77 61 79 20 6d 75 6c 74 69 , this way multi
6f80: 70 6c 65 20 73 65 72 76 65 72 73 20 77 6f 6e 27 ple servers won'
6f90: 74 20 66 69 67 68 74 20 74 6f 20 73 79 6e 63 20 t fight to sync
6fa0: 62 61 63 6b 0a 09 09 20 20 20 20 20 20 28 6c 65 back... (le
6fb0: 74 20 28 28 72 65 73 20 28 64 62 3a 6d 75 6c 74 t ((res (db:mult
6fc0: 69 2d 64 62 2d 73 79 6e 63 20 64 62 73 74 72 75 i-db-sync dbstru
6fd0: 63 74 20 27 6f 6c 64 32 6e 65 77 29 29 29 0a 09 ct 'old2new)))..
6fe0: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
6ff0: 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d nfo 13 *default-
7000: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6f 73 79 6e log-port* "rosyn
7010: 63 20 63 61 6c 6c 65 64 2c 20 22 20 72 65 73 20 c called, " res
7020: 22 20 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 " records transf
7030: 65 72 72 65 64 2e 22 29 29 29 29 0a 20 20 20 20 erred.")))).
7040: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
7050: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
7060: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
7070: 23 74 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 #t))). (debug
7080: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
7090: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
70a0: 20 22 45 78 69 74 69 6e 67 20 72 65 61 64 6f 6e "Exiting readon
70b0: 6c 79 2d 77 61 74 63 68 64 6f 67 20 74 69 6d 65 ly-watchdog time
70c0: 72 2c 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 r, *time-to-exit
70d0: 2a 20 3d 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 * = " *time-to-e
70e0: 78 69 74 2a 22 20 70 69 64 3d 22 28 63 75 72 72 xit*" pid="(curr
70f0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 ent-process-id)"
7100: 20 6d 74 70 61 74 68 3d 22 67 6f 6c 64 65 6e 2d mtpath="golden-
7110: 6d 74 70 61 74 68 29 29 29 0a 0a 3b 3b 20 54 4f mtpath)))..;; TO
7120: 44 4f 3a 20 66 6f 72 20 6d 75 6c 74 69 70 6c 65 DO: for multiple
7130: 20 61 72 65 61 73 2c 20 77 65 20 77 69 6c 6c 20 areas, we will
7140: 68 61 76 65 20 6d 75 6c 74 69 70 6c 65 20 77 61 have multiple wa
7150: 74 63 68 64 6f 67 73 3b 20 61 6e 64 20 6d 75 6c tchdogs; and mul
7160: 74 69 70 6c 65 20 74 68 72 65 61 64 73 20 74 6f tiple threads to
7170: 20 6d 61 6e 61 67 65 0a 28 64 65 66 69 6e 65 20 manage.(define
7180: 28 63 6f 6d 6d 6f 6e 3a 77 61 74 63 68 64 6f 67 (common:watchdog
7190: 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
71a0: 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c -info 13 *defaul
71b0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d t-log-port* "com
71c0: 6d 6f 6e 3a 77 61 74 63 68 64 6f 67 20 65 6e 74 mon:watchdog ent
71d0: 65 72 65 64 2e 22 29 0a 20 20 28 69 66 20 28 6c ered."). (if (l
71e0: 61 75 6e 63 68 3a 73 65 74 75 70 29 0a 20 20 20 aunch:setup).
71f0: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f (if (common:o
7200: 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 20 n-homehost?)..
7210: 28 6c 65 74 20 28 28 64 62 73 74 72 75 63 74 20 (let ((dbstruct
7220: 28 64 62 3a 73 65 74 75 70 20 23 74 29 29 29 0a (db:setup #t))).
7230: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
7240: 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 t-info 13 *defau
7250: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 66 lt-log-port* "af
7260: 74 65 72 20 64 62 3a 73 65 74 75 70 20 77 69 74 ter db:setup wit
7270: 68 20 64 62 73 74 72 75 63 74 3d 22 20 64 62 73 h dbstruct=" dbs
7280: 74 72 75 63 74 29 0a 09 20 20 20 20 28 63 6f 6e truct).. (con
7290: 64 0a 09 20 20 20 20 20 28 28 64 62 72 3a 64 62 d.. ((dbr:db
72a0: 73 74 72 75 63 74 2d 72 65 61 64 2d 6f 6e 6c 79 struct-read-only
72b0: 20 64 62 73 74 72 75 63 74 29 0a 09 20 20 20 20 dbstruct)..
72c0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
72d0: 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d nfo 13 *default-
72e0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c 6f 61 64 69 log-port* "loadi
72f0: 6e 67 20 72 65 61 64 2d 6f 6e 6c 79 20 77 61 74 ng read-only wat
7300: 63 68 64 6f 67 22 29 0a 09 20 20 20 20 20 20 28 chdog").. (
7310: 63 6f 6d 6d 6f 6e 3a 72 65 61 64 6f 6e 6c 79 2d common:readonly-
7320: 77 61 74 63 68 64 6f 67 20 64 62 73 74 72 75 63 watchdog dbstruc
7330: 74 29 29 0a 09 20 20 20 20 20 28 65 6c 73 65 0a t)).. (else.
7340: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
7350: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
7360: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
7370: 6c 6f 61 64 69 6e 67 20 77 72 69 74 61 62 6c 65 loading writable
7380: 2d 77 61 74 63 68 64 6f 67 2e 22 29 0a 09 20 20 -watchdog.")..
7390: 20 20 20 20 28 73 65 72 76 65 72 3a 77 72 69 74 (server:writ
73a0: 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 20 64 62 able-watchdog db
73b0: 73 74 72 75 63 74 29 29 29 0a 09 20 20 20 20 28 struct))).. (
73c0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
73d0: 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 13 *default-log
73e0: 2d 70 6f 72 74 2a 20 22 77 61 74 63 68 64 6f 67 -port* "watchdog
73f0: 20 64 6f 6e 65 2e 22 29 29 0a 09 20 20 28 64 65 done.")).. (de
7400: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
7410: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
7420: 6f 72 74 2a 20 22 6e 6f 20 6e 65 65 64 20 66 6f ort* "no need fo
7430: 72 20 77 61 74 63 68 64 6f 67 20 6f 6e 20 6e 6f r watchdog on no
7440: 6e 2d 68 6f 6d 65 68 6f 73 74 22 29 29 29 29 0a n-homehost")))).
7450: 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d 65 ..(define (std-e
7460: 78 69 74 2d 70 72 6f 63 65 64 75 72 65 29 0a 20 xit-procedure).
7470: 20 28 6f 6e 2d 65 78 69 74 20 28 6c 61 6d 62 64 (on-exit (lambd
7480: 61 20 28 29 20 30 29 29 0a 20 20 3b 3b 28 64 65 a () 0)). ;;(de
7490: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
74a0: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
74b0: 6f 72 74 2a 20 22 73 74 64 2d 65 78 69 74 2d 70 ort* "std-exit-p
74c0: 72 6f 63 65 64 75 72 65 20 63 61 6c 6c 65 64 3b rocedure called;
74d0: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 3d *time-to-exit*=
74e0: 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 "*time-to-exit*)
74f0: 0a 20 20 28 6c 65 74 20 28 28 6e 6f 2d 68 75 72 . (let ((no-hur
7500: 72 79 20 20 28 69 66 20 2a 74 69 6d 65 2d 74 6f ry (if *time-to
7510: 2d 65 78 69 74 2a 20 3b 3b 20 68 75 72 72 79 20 -exit* ;; hurry
7520: 75 70 0a 09 09 20 20 20 20 20 20 20 23 66 0a 09 up... #f..
7530: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
7540: 09 09 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 .. (set! *time-t
7550: 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 09 09 20 o-exit* #t)....
7560: 23 74 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 #t)))). (debu
7570: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
7580: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7590: 2a 20 22 73 74 61 72 74 69 6e 67 20 65 78 69 74 * "starting exit
75a0: 20 70 72 6f 63 65 73 73 2c 20 66 69 6e 61 6c 69 process, finali
75b0: 7a 69 6e 67 20 64 61 74 61 62 61 73 65 73 2e 22 zing databases."
75c0: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 6e ). (if (and n
75d0: 6f 2d 68 75 72 72 79 20 28 64 65 62 75 67 3a 64 o-hurry (debug:d
75e0: 65 62 75 67 2d 6d 6f 64 65 20 31 38 29 29 0a 09 ebug-mode 18))..
75f0: 28 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 (rmt:print-db-st
7600: 61 74 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 ats)). (let (
7610: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa
7620: 64 20 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b 20 d (lambda () ;;
7630: 74 68 72 65 61 64 20 66 6f 72 20 63 6c 65 61 6e thread for clean
7640: 69 6e 67 20 75 70 2c 20 67 69 76 65 20 69 74 20 ing up, give it
7650: 66 69 76 65 20 73 65 63 6f 6e 64 73 0a 20 20 20 five seconds.
7660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7670: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 2a (if *
7680: 64 62 73 74 72 75 63 74 2d 64 62 2a 20 28 64 62 dbstruct-db* (db
7690: 3a 63 6c 6f 73 65 2d 61 6c 6c 20 2a 64 62 73 74 :close-all *dbst
76a0: 72 75 63 74 2d 64 62 2a 29 29 20 3b 3b 20 6f 6e ruct-db*)) ;; on
76b0: 65 20 73 65 63 6f 6e 64 20 61 6c 6c 6f 63 61 74 e second allocat
76c0: 65 64 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ed.... (if
76d0: 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 0a 09 09 *task-db* ...
76e0: 09 09 20 20 28 6c 65 74 20 28 28 64 62 20 28 63 .. (let ((db (c
76f0: 64 72 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 0a dr *task-db*))).
7700: 09 09 09 09 20 20 20 20 28 69 66 20 28 73 71 6c .... (if (sql
7710: 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 64 ite3:database? d
7720: 62 29 0a 09 09 09 09 09 28 62 65 67 69 6e 0a 09 b)......(begin..
7730: 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 69 .... (sqlite3:i
7740: 6e 74 65 72 72 75 70 74 21 20 64 62 29 0a 09 09 nterrupt! db)...
7750: 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 66 69 ... (sqlite3:fi
7760: 6e 61 6c 69 7a 65 21 20 64 62 20 23 74 29 0a 09 nalize! db #t)..
7770: 09 09 09 09 20 20 3b 3b 20 28 76 65 63 74 6f 72 .... ;; (vector
7780: 2d 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 -set! *task-db*
7790: 30 20 23 66 29 0a 09 09 09 09 09 20 20 28 73 65 0 #f)...... (se
77a0: 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 23 66 29 t! *task-db* #f)
77b0: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
77c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77d0: 20 20 20 28 68 74 74 70 2d 63 6c 69 65 6e 74 23 (http-client#
77e0: 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 close-all-connec
77f0: 74 69 6f 6e 73 21 29 0a 20 20 20 20 20 20 20 20 tions!).
7800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7810: 20 20 20 20 20 20 3b 3b 20 28 69 66 20 28 61 6e ;; (if (an
7820: 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 20 20 d *runremote*.
7830: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7840: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ;;
7850: 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d (remote-
7860: 63 6f 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d 6f conndat *runremo
7870: 74 65 2a 29 29 0a 20 20 20 20 20 20 20 20 20 20 te*)).
7880: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7890: 20 20 20 20 3b 3b 20 20 20 20 20 28 62 65 67 69 ;; (begi
78a0: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
78b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
78c0: 3b 3b 20 20 20 20 20 20 20 28 68 74 74 70 2d 63 ;; (http-c
78d0: 6c 69 65 6e 74 23 63 6c 6f 73 65 2d 61 6c 6c 2d lient#close-all-
78e0: 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 20 connections!)))
78f0: 3b 3b 20 66 6f 72 20 68 74 74 70 2d 63 6c 69 65 ;; for http-clie
7900: 6e 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nt.
7910: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7920: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a (if (not (eq? *
7930: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7940: 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 * (current-error
7950: 2d 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 20 -port))).
7960: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7970: 20 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 (clos
7980: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 2a 64 e-output-port *d
7990: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
79a0: 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 )).... (set
79b0: 21 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 ! *default-log-p
79c0: 6f 72 74 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 ort* (current-er
79d0: 72 6f 72 2d 70 6f 72 74 29 29 29 20 22 43 6c 65 ror-port))) "Cle
79e0: 61 6e 75 70 20 64 62 20 65 78 69 74 20 74 68 72 anup db exit thr
79f0: 65 61 64 22 29 29 0a 09 20 20 28 74 68 32 20 28 ead")).. (th2 (
7a00: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
7a10: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
7a20: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a (debug:print 4 *
7a30: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7a40: 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 20 63 6c * "Attempting cl
7a50: 65 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 ean exit. Please
7a60: 20 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 be patient and
7a70: 77 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e wait a few secon
7a80: 64 73 2e 2e 2e 22 29 0a 09 09 09 20 20 20 20 20 ds...")....
7a90: 20 28 69 66 20 6e 6f 2d 68 75 72 72 79 0a 20 20 (if no-hurry.
7aa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ac0: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
7ad0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7ae0: 20 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 (thre
7af0: 61 64 2d 73 6c 65 65 70 21 20 35 29 29 20 3b 3b ad-sleep! 5)) ;;
7b00: 20 67 69 76 65 20 74 68 65 20 63 6c 65 61 6e 20 give the clean
7b10: 75 70 20 66 65 77 20 73 65 63 6f 6e 64 73 20 74 up few seconds t
7b20: 6f 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a o do it's stuff.
7b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7b50: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 09 (begin. .
7b60: 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
7b70: 65 70 21 20 32 29 29 29 0a 20 20 20 20 20 20 09 ep! 2))). .
7b80: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
7b90: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
7ba0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 log-port* " ...
7bb0: 64 6f 6e 65 22 29 0a 20 20 20 20 20 20 09 09 09 done"). ...
7bc0: 20 20 20 20 20 20 29 0a 09 09 09 20 20 20 20 22 ).... "
7bd0: 63 6c 65 61 6e 20 65 78 69 74 22 29 29 29 0a 20 clean exit"))).
7be0: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 (thread-sta
7bf0: 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 28 rt! th1). (
7c00: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
7c10: 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2). (thread
7c20: 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 20 20 20 20 -join! th1).
7c30: 20 20 29 0a 20 20 20 20 29 0a 0a 20 20 30 29 0a ). ).. 0).
7c40: 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d 73 69 .(define (std-si
7c50: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 gnal-handler sig
7c60: 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 6e 61 num). ;; (signa
7c70: 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a l-mask! signum).
7c80: 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f (set! *time-to
7c90: 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 3b 3b 28 -exit* #t). ;;(
7ca0: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7cb0: 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 13 *default-log
7cc0: 2d 70 6f 72 74 2a 20 22 67 6f 74 20 73 69 67 6e -port* "got sign
7cd0: 61 6c 20 22 73 69 67 6e 75 6d 29 0a 20 20 28 64 al "signum). (d
7ce0: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
7cf0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7d00: 70 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 20 port* "Received
7d10: 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 signal " signum
7d20: 22 20 65 78 69 74 69 6e 67 20 70 72 6f 6d 70 74 " exiting prompt
7d30: 6c 79 22 29 0a 20 20 3b 3b 20 28 73 74 64 2d 65 ly"). ;; (std-e
7d40: 78 69 74 2d 70 72 6f 63 65 64 75 72 65 29 20 3b xit-procedure) ;
7d50: 3b 20 73 68 6f 75 6c 64 6e 27 74 20 6e 65 65 64 ; shouldn't need
7d60: 20 74 68 69 73 20 73 69 6e 63 65 20 77 65 20 61 this since we a
7d70: 72 65 20 65 78 69 74 69 6e 67 20 61 6e 64 20 69 re exiting and i
7d80: 74 20 77 69 6c 6c 20 62 65 20 63 61 6c 6c 65 64 t will be called
7d90: 20 61 6e 79 77 61 79 0a 20 20 28 65 78 69 74 29 anyway. (exit)
7da0: 29 0a 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 )..(set-signal-h
7db0: 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 andler! signal/i
7dc0: 6e 74 20 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 nt std-signal-h
7dd0: 61 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 43 0a 28 andler) ;; ^C.(
7de0: 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c set-signal-handl
7df0: 65 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 6d 20 er! signal/term
7e00: 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c std-signal-handl
7e10: 65 72 29 0a 3b 3b 20 28 73 65 74 2d 73 69 67 6e er).;; (set-sign
7e20: 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e al-handler! sign
7e30: 61 6c 2f 73 74 6f 70 20 73 74 64 2d 73 69 67 6e al/stop std-sign
7e40: 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b 20 al-handler) ;;
7e50: 5e 5a 20 4e 4f 2c 20 64 6f 20 4e 4f 54 20 68 61 ^Z NO, do NOT ha
7e60: 6e 64 6c 65 20 5e 5a 21 0a 0a 3b 3b 3d 3d 3d 3d ndle ^Z!..;;====
7e70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7e90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ea0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7eb0: 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 ==.;; M I S C
7ec0: 55 20 54 20 49 20 4c 20 53 0a 3b 3b 3d 3d 3d 3d U T I L S.;;====
7ed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ef0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7f10: 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 73 ==..;; convert s
7f20: 74 75 66 66 20 74 6f 20 61 20 6e 75 6d 62 65 72 tuff to a number
7f30: 20 69 66 20 70 6f 73 73 69 62 6c 65 0a 28 64 65 if possible.(de
7f40: 66 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 fine (any->numbe
7f50: 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 20 0a r val). (cond .
7f60: 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c ((number? val
7f70: 29 20 76 61 6c 29 0a 20 20 20 28 28 73 74 72 69 ) val). ((stri
7f80: 6e 67 3f 20 76 61 6c 29 20 28 73 74 72 69 6e 67 ng? val) (string
7f90: 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 ->number val)).
7fa0: 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 ((symbol? val)
7fb0: 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 73 (any->number (s
7fc0: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 ymbol->string va
7fd0: 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 20 23 66 l))). (else #f
7fe0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 6e )))..(define (an
7ff0: 79 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 6f 73 y->number-if-pos
8000: 73 69 62 6c 65 20 76 61 6c 29 0a 20 20 28 6c 65 sible val). (le
8010: 74 20 28 28 6e 75 6d 20 28 61 6e 79 2d 3e 6e 75 t ((num (any->nu
8020: 6d 62 65 72 20 76 61 6c 29 29 29 0a 20 20 20 20 mber val))).
8030: 28 69 66 20 6e 75 6d 20 6e 75 6d 20 76 61 6c 29 (if num num val)
8040: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 74 ))..(define (pat
8050: 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 69 74 65 t-list-match ite
8060: 6d 20 70 61 74 74 73 29 0a 20 20 28 64 65 62 75 m patts). (debu
8070: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a g:print-info 8 *
8080: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
8090: 2a 20 22 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 * "patt-list-mat
80a0: 63 68 20 69 74 65 6d 3d 22 20 69 74 65 6d 20 22 ch item=" item "
80b0: 20 70 61 74 74 73 3d 22 20 70 61 74 74 73 29 0a patts=" patts).
80c0: 20 20 28 69 66 20 28 61 6e 64 20 69 74 65 6d 20 (if (and item
80d0: 70 61 74 74 73 29 20 20 3b 3b 20 68 65 72 65 20 patts) ;; here
80e0: 77 65 20 61 72 65 20 66 69 6c 74 65 72 69 6e 67 we are filtering
80f0: 20 66 6f 72 20 6d 61 74 63 68 65 73 20 77 69 74 for matches wit
8100: 68 20 69 74 65 6d 20 70 61 74 74 65 72 6e 73 0a h item patterns.
8110: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
8120: 20 23 66 29 29 20 20 20 3b 3b 20 6c 6f 6f 6b 20 #f)) ;; look
8130: 74 68 72 6f 75 67 68 20 61 6c 6c 20 74 68 65 20 through all the
8140: 69 74 65 6d 2d 70 61 74 74 73 20 69 66 20 64 65 item-patts if de
8150: 66 69 6e 65 64 2c 20 66 6f 72 6d 61 74 20 69 73 fined, format is
8160: 20 70 61 74 74 31 2c 70 61 74 74 32 2c 70 61 74 patt1,patt2,pat
8170: 74 33 20 2e 2e 2e 20 77 69 6c 64 63 61 72 64 20 t3 ... wildcard
8180: 69 73 20 25 0a 09 28 66 6f 72 2d 65 61 63 68 20 is %..(for-each
8190: 0a 09 20 28 6c 61 6d 62 64 61 20 28 70 61 74 74 .. (lambda (patt
81a0: 29 0a 09 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 ).. (let ((mod
81b0: 70 61 74 74 20 28 73 74 72 69 6e 67 2d 73 75 62 patt (string-sub
81c0: 73 74 69 74 75 74 65 20 22 25 22 20 22 2e 2a 22 stitute "%" ".*"
81d0: 20 70 61 74 74 20 23 74 29 29 29 0a 09 20 20 20 patt #t)))..
81e0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
81f0: 6e 66 6f 20 31 30 20 2a 64 65 66 61 75 6c 74 2d nfo 10 *default-
8200: 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 20 log-port* "patt
8210: 22 20 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 " patt " modpatt
8220: 20 22 20 6d 6f 64 70 61 74 74 29 0a 09 20 20 20 " modpatt)..
8230: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
8240: 74 63 68 20 28 72 65 67 65 78 70 20 6d 6f 64 70 tch (regexp modp
8250: 61 74 74 29 20 69 74 65 6d 29 0a 09 09 20 28 73 att) item)... (s
8260: 65 74 21 20 72 65 73 20 23 74 29 29 29 29 0a 09 et! res #t))))..
8270: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 (string-split p
8280: 61 74 74 73 20 22 2c 22 29 29 0a 09 72 65 73 29 atts ","))..res)
8290: 0a 20 20 20 20 20 20 23 74 29 29 0a 0a 3b 3b 20 . #t))..;;
82a0: 27 28 70 72 69 6e 74 20 28 73 74 72 69 6e 67 2d '(print (string-
82b0: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
82c0: 20 63 61 64 72 20 28 68 61 73 68 2d 74 61 62 6c cadr (hash-tabl
82d0: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 72 e-ref/default (r
82e0: 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 ead-config "mega
82f0: 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 5c 23 66 test.config" \#f
8300: 20 5c 23 74 29 20 22 64 69 73 6b 73 22 20 27 22 \#t) "disks" '"
8310: 27 22 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 '"'("none" "")))
8320: 20 22 5c 6e 22 29 29 27 0a 28 64 65 66 69 6e 65 "\n"))'.(define
8330: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 (common:get-dis
8340: 6b 73 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 67 ks #!key (config
8350: 66 20 23 66 29 29 0a 20 20 28 68 61 73 68 2d 74 f #f)). (hash-t
8360: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
8370: 20 0a 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 . (or configf
8380: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d (read-config "m
8390: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 egatest.config"
83a0: 23 66 20 23 74 29 29 0a 20 20 20 22 64 69 73 6b #f #t)). "disk
83b0: 73 22 20 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 s" '("none" ""))
83c0: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 )..;; return fir
83d0: 73 74 20 63 6f 6d 6d 61 6e 64 20 74 68 61 74 20 st command that
83e0: 65 78 69 73 74 73 2c 20 65 6c 73 65 20 23 66 0a exists, else #f.
83f0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
8400: 6f 6e 3a 77 68 69 63 68 20 63 6d 64 73 29 0a 20 on:which cmds).
8410: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 (if (null? cmds
8420: 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 ). #f.
8430: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
8440: 20 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 20 (car cmds))...
8450: 28 74 61 6c 20 28 63 64 72 20 63 6d 64 73 29 29 (tal (cdr cmds))
8460: 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 77 )..(let ((res (w
8470: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
8480: 69 70 65 20 28 63 6f 6e 63 20 22 77 68 69 63 68 ipe (conc "which
8490: 20 22 20 68 65 64 29 20 72 65 61 64 2d 6c 69 6e " hed) read-lin
84a0: 65 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 e))).. (if (and
84b0: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 (string? res)..
84c0: 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 . (common:file
84d0: 2d 65 78 69 73 74 73 3f 20 72 65 73 29 29 0a 09 -exists? res))..
84e0: 20 20 20 20 20 20 72 65 73 0a 09 20 20 20 20 20 res..
84f0: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
8500: 0a 09 09 20 20 23 66 0a 09 09 20 20 28 6c 6f 6f ... #f... (loo
8510: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
8520: 74 61 6c 29 29 29 29 29 29 29 29 0a 20 20 0a 28 tal)))))))). .(
8530: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
8540: 65 74 2d 69 6e 73 74 61 6c 6c 2d 61 72 65 61 29 et-install-area)
8550: 0a 20 20 28 6c 65 74 20 28 28 65 78 65 2d 70 61 . (let ((exe-pa
8560: 74 68 20 28 63 61 72 20 28 61 72 67 76 29 29 29 th (car (argv)))
8570: 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f ). (if (commo
8580: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 65 n:file-exists? e
8590: 78 65 2d 70 61 74 68 29 0a 09 28 68 61 6e 64 6c xe-path)..(handl
85a0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 65 e-exceptions.. e
85b0: 78 6e 0a 09 20 23 66 0a 09 20 28 70 61 74 68 6e xn.. #f.. (pathn
85c0: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 0a 09 20 ame-directory..
85d0: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
85e0: 74 6f 72 79 20 0a 09 20 20 20 28 70 61 74 68 6e tory .. (pathn
85f0: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 65 78 ame-directory ex
8600: 65 2d 70 61 74 68 29 29 29 29 0a 09 23 66 29 29 e-path))))..#f))
8610: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 )..;; return fir
8620: 73 74 20 70 61 74 68 20 74 68 61 74 20 63 61 6e st path that can
8630: 20 62 65 20 63 72 65 61 74 65 64 20 6f 72 20 61 be created or a
8640: 6c 72 65 61 64 79 20 65 78 69 73 74 73 20 61 6e lready exists an
8650: 64 20 69 73 20 77 72 69 74 61 62 6c 65 0a 3b 3b d is writable.;;
8660: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
8670: 3a 67 65 74 2d 63 72 65 61 74 65 2d 77 72 69 74 :get-create-writ
8680: 65 61 62 6c 65 2d 64 69 72 20 64 69 72 73 29 0a eable-dir dirs).
8690: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 69 72 (if (null? dir
86a0: 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 s). #f.
86b0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
86c0: 64 20 28 63 61 72 20 64 69 72 73 29 29 0a 09 09 d (car dirs))...
86d0: 20 28 74 61 6c 20 28 63 64 72 20 64 69 72 73 29 (tal (cdr dirs)
86e0: 29 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 ))..(let ((res (
86f0: 6f 72 20 28 61 6e 64 20 28 64 69 72 65 63 74 6f or (and (directo
8700: 72 79 3f 20 68 65 64 29 0a 09 09 09 20 20 20 20 ry? hed)....
8710: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
8720: 73 73 3f 20 68 65 64 29 0a 09 09 09 20 20 20 20 ss? hed)....
8730: 68 65 64 29 0a 09 09 20 20 20 20 20 20 20 28 68 hed)... (h
8740: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
8750: 0a 09 09 09 65 78 6e 0a 09 09 09 23 66 0a 09 09 ....exn....#f...
8760: 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f .(create-directo
8770: 72 79 20 68 65 64 20 23 74 29 29 29 29 29 0a 09 ry hed #t)))))..
8780: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
8790: 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 28 64 ng? res)... (d
87a0: 69 72 65 63 74 6f 72 79 3f 20 72 65 73 29 29 0a irectory? res)).
87b0: 09 20 20 20 20 20 20 72 65 73 0a 09 20 20 20 20 . res..
87c0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
87d0: 29 0a 09 09 20 20 23 66 0a 09 09 20 20 28 6c 6f )... #f... (lo
87e0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
87f0: 20 74 61 6c 29 29 29 29 29 29 29 29 0a 0a 3b 3b tal))))))))..;;
8800: 20 72 65 74 75 72 6e 20 74 68 65 20 79 6f 75 6e return the youn
8810: 67 65 73 74 20 74 69 6d 65 73 74 61 6d 70 20 2e gest timestamp .
8820: 20 66 69 6c 65 6e 61 6d 65 0a 3b 3b 0a 28 64 65 filename.;;.(de
8830: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
8840: 2d 79 6f 75 6e 67 65 73 74 20 67 6c 6f 62 2d 6c -youngest glob-l
8850: 69 73 74 29 0a 20 20 28 6c 65 74 20 28 28 61 6c ist). (let ((al
8860: 6c 2d 66 69 6c 65 73 20 28 61 70 70 6c 79 20 61 l-files (apply a
8870: 70 70 65 6e 64 0a 09 09 09 20 20 28 6d 61 70 20 ppend.... (map
8880: 28 6c 61 6d 62 64 61 20 28 70 61 74 74 29 0a 09 (lambda (patt)..
8890: 09 09 09 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ... (handle-exce
88a0: 70 74 69 6f 6e 73 0a 09 09 09 09 20 20 20 20 20 ptions.....
88b0: 65 78 6e 0a 09 09 09 09 20 20 20 20 20 27 28 29 exn..... '()
88c0: 0a 09 09 09 09 20 20 20 28 67 6c 6f 62 20 70 61 ..... (glob pa
88d0: 74 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 tt)))....
88e0: 67 6c 6f 62 2d 6c 69 73 74 29 29 29 29 0a 20 20 glob-list)))).
88f0: 20 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 (fold (lambda
8900: 28 66 6e 61 6d 65 20 72 65 73 29 0a 09 20 20 20 (fname res)..
8910: 20 28 6c 65 74 20 28 28 6c 61 73 74 2d 6d 6f 64 (let ((last-mod
8920: 20 28 63 61 72 20 72 65 73 29 29 0a 09 09 20 20 (car res))...
8930: 28 63 75 72 6d 6f 64 20 20 20 28 68 61 6e 64 6c (curmod (handl
8940: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
8950: 09 65 78 6e 0a 09 09 09 09 30 0a 09 09 09 20 20 .exn.....0....
8960: 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 (file-modifi
8970: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 6e 61 6d cation-time fnam
8980: 65 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 e)))).. (if
8990: 20 28 3e 20 63 75 72 6d 6f 64 20 6c 61 73 74 2d (> curmod last-
89a0: 6d 6f 64 29 0a 09 09 20 20 28 6c 69 73 74 20 63 mod)... (list c
89b0: 75 72 6d 6f 64 20 66 6e 61 6d 65 29 0a 09 09 20 urmod fname)...
89c0: 20 72 65 73 29 29 29 0a 09 20 20 27 28 30 20 22 res))).. '(0 "
89d0: 6e 2f 61 22 29 0a 09 20 20 61 6c 6c 2d 66 69 6c n/a").. all-fil
89e0: 65 73 29 29 29 0a 0a 3b 3b 20 75 73 65 20 62 61 es)))..;; use ba
89f0: 73 68 20 74 6f 20 65 78 70 61 6e 64 20 61 20 67 sh to expand a g
8a00: 6c 6f 62 2e 20 44 6f 65 73 20 4e 4f 54 20 68 61 lob. Does NOT ha
8a10: 6e 64 6c 65 20 70 61 74 68 73 20 77 69 74 68 20 ndle paths with
8a20: 73 70 61 63 65 73 21 0a 3b 3b 0a 28 64 65 66 69 spaces!.;;.(defi
8a30: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 62 61 73 68 2d ne (common:bash-
8a40: 67 6c 6f 62 20 69 6e 73 74 72 29 0a 20 20 28 73 glob instr). (s
8a50: 74 72 69 6e 67 2d 73 70 6c 69 74 0a 20 20 20 28 tring-split. (
8a60: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
8a70: 70 69 70 65 0a 20 20 20 20 20 20 20 28 63 6f 6e pipe. (con
8a80: 63 20 22 2f 62 69 6e 2f 62 61 73 68 20 2d 63 20 c "/bin/bash -c
8a90: 5c 22 65 63 68 6f 20 22 20 69 6e 73 74 72 20 22 \"echo " instr "
8aa0: 5c 22 22 29 0a 20 20 20 20 20 72 65 61 64 2d 6c \""). read-l
8ab0: 69 6e 65 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d ine))). .;;====
8ac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ad0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ae0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8af0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b00: 3d 3d 0a 3b 3b 20 54 20 41 20 52 20 47 20 45 20 ==.;; T A R G E
8b10: 54 20 53 20 20 2c 20 20 20 53 20 54 20 41 20 54 T S , S T A T
8b20: 20 45 20 2c 20 20 20 53 20 54 20 41 20 54 20 55 E , S T A T U
8b30: 20 53 20 2c 20 20 20 0a 3b 3b 20 20 20 20 20 20 S , .;;
8b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 52 20 R
8b50: 55 20 4e 20 4e 20 41 20 4d 20 45 20 20 20 20 41 U N N A M E A
8b60: 20 4e 20 44 20 20 20 54 20 45 20 53 20 54 20 50 N D T E S T P
8b70: 20 41 20 54 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d A T T.;;=======
8b80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8b90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8ba0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8bb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8bc0: 0a 3b 3b 20 28 6d 61 70 20 70 72 69 6e 74 20 28 .;; (map print (
8bd0: 6d 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 map car (hash-ta
8be0: 62 6c 65 2d 3e 61 6c 69 73 74 20 28 72 65 61 64 ble->alist (read
8bf0: 2d 63 6f 6e 66 69 67 20 22 72 75 6e 63 6f 6e 66 -config "runconf
8c00: 69 67 73 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 igs.config" #f #
8c10: 74 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 t)))).;;.(define
8c20: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 75 6e (common:get-run
8c30: 63 6f 6e 66 69 67 2d 74 61 72 67 65 74 73 20 23 config-targets #
8c40: 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 !key (configf #f
8c50: 29 29 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 )). (let ((targ
8c60: 73 20 20 20 20 20 20 20 28 73 6f 72 74 20 28 6d s (sort (m
8c70: 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 ap car (hash-tab
8c80: 6c 65 2d 3e 61 6c 69 73 74 0a 09 09 09 09 20 20 le->alist.....
8c90: 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 20 3b (or configf ;
8ca0: 3b 20 4e 4f 54 45 3a 20 54 68 65 72 65 20 69 73 ; NOTE: There is
8cb0: 20 6e 6f 20 76 61 6c 75 65 20 69 6e 20 75 73 69 no value in usi
8cc0: 6e 67 20 72 75 6e 63 6f 6e 66 69 67 3a 72 65 61 ng runconfig:rea
8cd0: 64 20 68 65 72 65 2e 0a 09 09 09 09 09 20 28 72 d here....... (r
8ce0: 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 ead-config (conc
8cf0: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
8d00: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
8d10: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 20 ....... #f
8d20: 23 74 29 0a 09 09 09 09 09 20 28 6d 61 6b 65 2d #t)...... (make-
8d30: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 hash-table))))..
8d40: 09 09 20 20 20 73 74 72 69 6e 67 3c 3f 29 29 0a .. string<?)).
8d50: 09 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 61 .(target-patt (a
8d60: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
8d70: 72 67 65 74 22 29 29 29 0a 20 20 20 20 28 69 66 rget"))). (if
8d80: 20 74 61 72 67 65 74 2d 70 61 74 74 0a 09 28 66 target-patt..(f
8d90: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
8da0: 29 0a 09 09 20 20 28 70 61 74 74 2d 6c 69 73 74 )... (patt-list
8db0: 2d 6d 61 74 63 68 20 78 20 74 61 72 67 65 74 2d -match x target-
8dc0: 70 61 74 74 29 29 0a 09 09 74 61 72 67 73 29 0a patt))...targs).
8dd0: 09 74 61 72 67 73 29 29 29 0a 0a 3b 3b 20 4c 6f .targs)))..;; Lo
8de0: 6f 6b 75 70 20 61 20 76 61 6c 75 65 20 69 6e 20 okup a value in
8df0: 72 75 6e 63 6f 6e 66 69 67 73 20 62 61 73 65 64 runconfigs based
8e00: 20 6f 6e 20 2d 72 65 71 74 61 72 67 20 6f 72 20 on -reqtarg or
8e10: 2d 74 61 72 67 65 74 0a 3b 3b 20 0a 28 64 65 66 -target.;; .(def
8e20: 69 6e 65 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d ine (runconfigs-
8e30: 67 65 74 20 63 6f 6e 66 69 67 20 76 61 72 29 0a get config var).
8e40: 20 20 28 6c 65 74 20 28 28 74 61 72 67 20 28 63 (let ((targ (c
8e50: 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 ommon:args-get-t
8e60: 61 72 67 65 74 29 29 29 20 3b 3b 20 28 6f 72 20 arget))) ;; (or
8e70: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8e80: 72 65 71 74 61 72 67 22 29 28 61 72 67 73 3a 67 reqtarg")(args:g
8e90: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
8ea0: 29 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 )(getenv "MT_TAR
8eb0: 47 45 54 22 29 29 29 29 0a 20 20 20 20 28 69 66 GET")))). (if
8ec0: 20 74 61 72 67 0a 09 28 6f 72 20 28 63 6f 6e 66 targ..(or (conf
8ed0: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
8ee0: 67 20 74 61 72 67 20 76 61 72 29 0a 09 20 20 20 g targ var)..
8ef0: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
8f00: 20 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 config "default
8f10: 22 20 76 61 72 29 29 0a 09 28 63 6f 6e 66 69 67 " var))..(config
8f20: 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 f:lookup config
8f30: 22 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 29 "default" var)))
8f40: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
8f50: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 on:args-get-stat
8f60: 65 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 e). (or (args:g
8f70: 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 29 et-arg "-state")
8f80: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
8f90: 73 74 61 74 65 22 29 29 29 0a 0a 28 64 65 66 69 state")))..(defi
8fa0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d ne (common:args-
8fb0: 67 65 74 2d 73 74 61 74 75 73 29 0a 20 20 28 6f get-status). (o
8fc0: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
8fd0: 22 2d 73 74 61 74 75 73 22 29 28 61 72 67 73 3a "-status")(args:
8fe0: 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 get-arg ":status
8ff0: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ")))..(define (c
9000: 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 ommon:args-get-t
9010: 65 73 74 70 61 74 74 20 72 63 6f 6e 66 29 0a 20 estpatt rconf).
9020: 20 28 6c 65 74 2a 20 28 3b 3b 20 28 74 61 67 65 (let* (;; (tage
9030: 78 70 72 20 20 20 20 20 20 20 28 61 72 67 73 3a xpr (args:
9040: 67 65 74 2d 61 72 67 20 22 2d 74 61 67 65 78 70 get-arg "-tagexp
9050: 72 22 29 29 0a 20 20 20 20 20 20 20 20 20 3b 3b r")). ;;
9060: 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 20 (tags-testpatt
9070: 28 69 66 20 74 61 67 65 78 70 72 20 28 73 74 72 (if tagexpr (str
9080: 69 6e 67 2d 6a 6f 69 6e 20 28 72 75 6e 73 3a 67 ing-join (runs:g
9090: 65 74 2d 74 65 73 74 73 2d 6d 61 74 63 68 69 6e et-tests-matchin
90a0: 67 2d 74 61 67 73 20 74 61 67 65 78 70 72 29 20 g-tags tagexpr)
90b0: 22 2c 22 29 20 23 66 29 29 0a 20 20 20 20 20 20 ",") #f)).
90c0: 20 20 20 28 74 65 73 74 70 61 74 74 2d 6b 65 79 (testpatt-key
90d0: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
90e0: 61 72 67 20 22 2d 2d 6d 6f 64 65 70 61 74 74 22 arg "--modepatt"
90f0: 29 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ) (args:get-arg
9100: 22 2d 2d 6d 6f 64 65 70 61 74 74 22 29 20 22 54 "--modepatt") "T
9110: 45 53 54 50 41 54 54 22 29 29 0a 20 20 20 20 20 ESTPATT")).
9120: 20 20 20 20 28 61 72 67 73 2d 74 65 73 74 70 61 (args-testpa
9130: 74 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 tt (or (args:get
9140: 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 -arg "-testpatt"
9150: 29 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ) (args:get-arg
9160: 22 2d 72 75 6e 74 65 73 74 73 22 29 20 22 25 22 "-runtests") "%"
9170: 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 74 65 )). (rte
9180: 73 74 70 61 74 74 20 20 20 20 20 28 69 66 20 72 stpatt (if r
9190: 63 6f 6e 66 20 28 72 75 6e 63 6f 6e 66 69 67 73 conf (runconfigs
91a0: 2d 67 65 74 20 72 63 6f 6e 66 20 74 65 73 74 70 -get rconf testp
91b0: 61 74 74 2d 6b 65 79 29 20 23 66 29 29 29 0a 20 att-key) #f))).
91c0: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
91d0: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 2d args:get-arg "--
91e0: 6d 6f 64 65 70 61 74 74 22 29 20 3b 3b 20 6d 6f modepatt") ;; mo
91f0: 64 65 70 61 74 74 20 69 73 20 61 20 66 6f 72 63 depatt is a forc
9200: 65 64 20 73 65 74 74 69 6e 67 2c 20 77 68 65 6e ed setting, when
9210: 20 73 65 74 20 69 74 20 4d 55 53 54 20 72 65 66 set it MUST ref
9220: 65 72 20 74 6f 20 61 6e 20 65 78 69 73 74 69 6e er to an existin
9230: 67 20 50 41 54 54 20 69 6e 20 74 68 65 20 72 75 g PATT in the ru
9240: 6e 63 6f 6e 66 69 67 0a 20 20 20 20 20 20 28 69 nconfig. (i
9250: 66 20 72 63 6f 6e 66 0a 09 20 20 28 72 75 6e 63 f rconf.. (runc
9260: 6f 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 onfigs-get rconf
9270: 20 74 65 73 74 70 61 74 74 2d 6b 65 79 29 0a 09 testpatt-key)..
9280: 20 20 23 66 29 29 20 20 20 20 20 3b 3b 20 57 65 #f)) ;; We
9290: 20 64 6f 20 4e 4f 54 20 66 61 6c 6c 20 62 61 63 do NOT fall bac
92a0: 6b 20 74 6f 20 22 25 22 0a 20 20 20 20 20 3b 3b k to "%". ;;
92b0: 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 0a (tags-testpatt.
92c0: 20 20 20 20 20 3b 3b 20 20 28 64 65 62 75 67 3a ;; (debug:
92d0: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
92e0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
92f0: 22 2d 74 61 67 65 78 70 72 20 22 74 61 67 65 78 "-tagexpr "tagex
9300: 70 72 22 20 73 65 6c 65 63 74 73 20 74 65 73 74 pr" selects test
9310: 70 61 74 74 20 22 74 61 67 73 2d 74 65 73 74 70 patt "tags-testp
9320: 61 74 74 29 0a 20 20 20 20 20 3b 3b 20 20 74 61 att). ;; ta
9330: 67 73 2d 74 65 73 74 70 61 74 74 29 0a 20 20 20 gs-testpatt).
9340: 20 20 28 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 ((and (equal?
9350: 61 72 67 73 2d 74 65 73 74 70 61 74 74 20 22 25 args-testpatt "%
9360: 22 29 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 ") rtestpatt).
9370: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
9380: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
9390: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
93a0: 70 61 74 74 20 64 65 66 69 6e 65 64 20 69 6e 20 patt defined in
93b0: 22 74 65 73 74 70 61 74 74 2d 6b 65 79 22 20 66 "testpatt-key" f
93c0: 72 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 3a 20 rom runconfigs:
93d0: 22 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 20 " rtestpatt).
93e0: 20 20 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 rtestpatt).
93f0: 20 20 20 28 65 6c 73 65 20 61 72 67 73 2d 74 65 (else args-te
9400: 73 74 70 61 74 74 29 29 29 29 0a 0a 0a 0a 28 64 stpatt))))....(d
9410: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 61 efine (common:fa
9420: 6c 73 65 2d 6f 6e 2d 65 78 63 65 70 74 69 6f 6e lse-on-exception
9430: 20 74 68 75 6e 6b 20 23 21 6b 65 79 20 28 6d 65 thunk #!key (me
9440: 73 73 61 67 65 20 23 66 29 29 0a 20 20 28 68 61 ssage #f)). (ha
9450: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 ndle-exceptions
9460: 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 exn.
9470: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
9480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9490: 20 20 20 20 20 20 20 28 69 66 20 6d 65 73 73 61 (if messa
94a0: 67 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ge.
94b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
94c0: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
94d0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
94e0: 6f 72 74 2a 20 6d 65 73 73 61 67 65 29 29 0a 20 ort* message)).
94f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9500: 20 20 20 20 20 20 23 66 29 20 28 74 68 75 6e 6b #f) (thunk
9510: 29 20 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ) ))..(define (c
9520: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
9530: 73 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 29 0a s? path-string).
9540: 20 20 3b 3b 20 74 68 69 73 20 61 76 6f 69 64 73 ;; this avoids
9550: 20 73 74 61 63 6b 20 64 75 6d 70 73 20 69 6e 20 stack dumps in
9560: 74 68 65 20 63 61 73 65 20 77 68 65 72 65 20 0a the case where .
9570: 0a 20 20 3b 3b 3b 3b 20 54 4f 44 4f 3a 20 63 61 . ;;;; TODO: ca
9580: 74 63 68 20 70 65 72 6d 69 73 73 69 6f 6e 20 64 tch permission d
9590: 65 6e 69 65 64 20 65 78 63 65 70 74 69 6f 6e 73 enied exceptions
95a0: 20 61 6e 64 20 65 6d 69 74 20 61 70 70 72 6f 70 and emit approp
95b0: 72 69 61 74 65 20 77 61 72 6e 69 6e 67 73 2c 20 riate warnings,
95c0: 65 67 3a 20 20 73 79 73 74 65 6d 20 65 72 72 6f eg: system erro
95d0: 72 20 77 68 69 6c 65 20 74 72 79 69 6e 67 20 74 r while trying t
95e0: 6f 20 61 63 63 65 73 73 20 66 69 6c 65 3a 20 22 o access file: "
95f0: 2f 6e 66 73 2f 70 64 78 2f 64 69 73 6b 73 2f 69 /nfs/pdx/disks/i
9600: 63 66 5f 65 6e 76 5f 64 69 73 6b 30 30 31 2f 62 cf_env_disk001/b
9610: 6a 62 61 72 63 6c 61 2f 67 77 61 2f 69 73 73 75 jbarcla/gwa/issu
9620: 65 73 2f 6d 74 64 65 76 2f 72 61 6e 64 79 2d 73 es/mtdev/randy-s
9630: 6c 6f 77 2f 72 65 70 72 6f 64 75 63 65 2f 71 2e low/reproduce/q.
9640: 2e 2e 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 66 61 6c ... (common:fal
9650: 73 65 2d 6f 6e 2d 65 78 63 65 70 74 69 6f 6e 20 se-on-exception
9660: 28 6c 61 6d 62 64 61 20 28 29 20 28 66 69 6c 65 (lambda () (file
9670: 2d 65 78 69 73 74 73 3f 20 70 61 74 68 2d 73 74 -exists? path-st
9680: 72 69 6e 67 29 29 0a 20 20 20 20 20 20 20 20 20 ring)).
9690: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96a0: 20 20 20 20 6d 65 73 73 61 67 65 3a 20 28 63 6f message: (co
96b0: 6e 63 20 22 55 6e 61 62 6c 65 20 74 6f 20 61 63 nc "Unable to ac
96c0: 63 65 73 73 20 70 61 74 68 3a 20 22 20 70 61 74 cess path: " pat
96d0: 68 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 20 20 h-string).
96e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
96f0: 20 20 20 20 20 20 20 29 29 0a 0a 28 64 65 66 69 ))..(defi
9700: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 69 72 65 63 ne (common:direc
9710: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 61 74 tory-exists? pat
9720: 68 2d 73 74 72 69 6e 67 29 0a 20 20 3b 3b 3b 3b h-string). ;;;;
9730: 20 54 4f 44 4f 3a 20 63 61 74 63 68 20 70 65 72 TODO: catch per
9740: 6d 69 73 73 69 6f 6e 20 64 65 6e 69 65 64 20 65 mission denied e
9750: 78 63 65 70 74 69 6f 6e 73 20 61 6e 64 20 65 6d xceptions and em
9760: 69 74 20 61 70 70 72 6f 70 72 69 61 74 65 20 77 it appropriate w
9770: 61 72 6e 69 6e 67 73 2c 20 65 67 3a 20 20 73 79 arnings, eg: sy
9780: 73 74 65 6d 20 65 72 72 6f 72 20 77 68 69 6c 65 stem error while
9790: 20 74 72 79 69 6e 67 20 74 6f 20 61 63 63 65 73 trying to acces
97a0: 73 20 66 69 6c 65 3a 20 22 2f 6e 66 73 2f 70 64 s file: "/nfs/pd
97b0: 78 2f 64 69 73 6b 73 2f 69 63 66 5f 65 6e 76 5f x/disks/icf_env_
97c0: 64 69 73 6b 30 30 31 2f 62 6a 62 61 72 63 6c 61 disk001/bjbarcla
97d0: 2f 67 77 61 2f 69 73 73 75 65 73 2f 6d 74 64 65 /gwa/issues/mtde
97e0: 76 2f 72 61 6e 64 79 2d 73 6c 6f 77 2f 72 65 70 v/randy-slow/rep
97f0: 72 6f 64 75 63 65 2f 71 2e 2e 2e 0a 20 20 28 63 roduce/q.... (c
9800: 6f 6d 6d 6f 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 ommon:false-on-e
9810: 78 63 65 70 74 69 6f 6e 20 28 6c 61 6d 62 64 61 xception (lambda
9820: 20 28 29 20 28 64 69 72 65 63 74 6f 72 79 2d 65 () (directory-e
9830: 78 69 73 74 73 3f 20 70 61 74 68 2d 73 74 72 69 xists? path-stri
9840: 6e 67 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ng)).
9850: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9860: 20 20 6d 65 73 73 61 67 65 3a 20 28 63 6f 6e 63 message: (conc
9870: 20 22 55 6e 61 62 6c 65 20 74 6f 20 61 63 63 65 "Unable to acce
9880: 73 73 20 70 61 74 68 3a 20 22 20 70 61 74 68 2d ss path: " path-
9890: 73 74 72 69 6e 67 29 0a 20 20 20 20 20 20 20 20 string).
98a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
98b0: 20 20 20 20 20 29 29 0a 0a 3b 3b 20 64 6f 65 73 ))..;; does
98c0: 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 65 the directory e
98d0: 78 69 73 74 20 61 6e 64 20 64 6f 20 77 65 20 68 xist and do we h
98e0: 61 76 65 20 77 72 69 74 65 20 61 63 63 65 73 73 ave write access
98f0: 3f 0a 3b 3b 0a 3b 3b 20 20 20 20 72 65 74 75 72 ?.;;.;; retur
9900: 6e 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 ns the directory
9910: 20 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e or #f.;;.(defin
9920: 65 20 28 63 6f 6d 6d 6f 6e 3a 64 69 72 65 63 74 e (common:direct
9930: 6f 72 79 2d 77 72 69 74 61 62 6c 65 3f 20 70 61 ory-writable? pa
9940: 74 68 2d 73 74 72 69 6e 67 29 0a 20 20 28 68 61 th-string). (ha
9950: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
9960: 20 20 20 65 78 6e 0a 20 20 20 23 66 0a 20 20 20 exn. #f.
9970: 28 69 66 20 28 61 6e 64 20 28 64 69 72 65 63 74 (if (and (direct
9980: 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 61 74 68 ory-exists? path
9990: 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 20 20 20 -string).
99a0: 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 (file-write
99b0: 2d 61 63 63 65 73 73 3f 20 70 61 74 68 2d 73 74 -access? path-st
99c0: 72 69 6e 67 29 29 0a 20 20 20 20 20 20 20 70 61 ring)). pa
99d0: 74 68 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 th-string.
99e0: 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f)))..(define
99f0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
9a00: 74 72 65 65 29 0a 20 20 28 6f 72 20 28 67 65 74 tree). (or (get
9a10: 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 env "MT_LINKTREE
9a20: 22 29 0a 20 20 20 20 20 20 28 69 66 20 2a 63 6f "). (if *co
9a30: 6e 66 69 67 64 61 74 2a 0a 09 20 20 28 63 6f 6e nfigdat*.. (con
9a40: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
9a50: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
9a60: 22 6c 69 6e 6b 74 72 65 65 22 29 0a 09 20 20 28 "linktree").. (
9a70: 69 66 20 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 if *toppath*..
9a80: 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 (conc *toppa
9a90: 74 68 2a 20 22 2f 6c 74 22 29 0a 09 20 20 20 20 th* "/lt")..
9aa0: 20 20 23 66 29 29 29 29 0a 0a 28 64 65 66 69 6e #f))))..(defin
9ab0: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 e (common:args-g
9ac0: 65 74 2d 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c et-runname). (l
9ad0: 65 74 20 28 28 72 65 73 20 28 6f 72 20 28 61 72 et ((res (or (ar
9ae0: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
9af0: 6e 61 6d 65 22 29 0a 09 09 20 28 61 72 67 73 3a name")... (args:
9b00: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
9b10: 65 22 29 0a 09 09 20 28 67 65 74 65 6e 76 20 22 e")... (getenv "
9b20: 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 29 29 29 0a MT_RUNNAME")))).
9b30: 20 20 20 20 3b 3b 20 28 69 66 20 72 65 73 20 28 ;; (if res (
9b40: 73 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d set-environment-
9b50: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e variable "MT_RUN
9b60: 4e 41 4d 45 22 20 72 65 73 29 29 20 3b 3b 20 6e NAME" res)) ;; n
9b70: 6f 74 20 73 75 72 65 20 69 66 20 74 68 69 73 20 ot sure if this
9b80: 69 73 20 61 20 67 6f 6f 64 20 69 64 65 61 2e 20 is a good idea.
9b90: 73 69 64 65 20 65 66 66 65 63 74 20 61 6e 64 20 side effect and
9ba0: 61 6c 6c 20 2e 2e 2e 0a 20 20 20 20 72 65 73 29 all .... res)
9bb0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
9bc0: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 on:args-get-targ
9bd0: 65 74 20 23 21 6b 65 79 20 28 73 70 6c 69 74 20 et #!key (split
9be0: 23 66 29 28 65 78 69 74 2d 69 66 2d 62 61 64 20 #f)(exit-if-bad
9bf0: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b #f)). (let* ((k
9c00: 65 79 73 20 20 20 20 28 69 66 20 28 68 61 73 68 eys (if (hash
9c10: 2d 74 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 -table? *configd
9c20: 61 74 2a 29 20 28 6b 65 79 73 3a 63 6f 6e 66 69 at*) (keys:confi
9c30: 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f g-get-fields *co
9c40: 6e 66 69 67 64 61 74 2a 29 20 27 28 29 29 29 0a nfigdat*) '())).
9c50: 09 20 28 6e 75 6d 6b 65 79 73 20 28 6c 65 6e 67 . (numkeys (leng
9c60: 74 68 20 6b 65 79 73 29 29 0a 09 20 28 74 61 72 th keys)).. (tar
9c70: 67 65 74 20 20 28 6f 72 20 28 61 72 67 73 3a 67 get (or (args:g
9c80: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
9c90: 22 29 0a 09 09 20 20 20 20 20 20 28 61 72 67 73 ")... (args
9ca0: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
9cb0: 74 22 29 0a 09 09 20 20 20 20 20 20 28 67 65 74 t")... (get
9cc0: 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 env "MT_TARGET")
9cd0: 29 29 0a 09 20 28 74 6c 69 73 74 20 20 20 28 69 )).. (tlist (i
9ce0: 66 20 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 f target (string
9cf0: 2d 73 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f -split target "/
9d00: 22 20 23 74 29 20 27 28 29 29 29 0a 09 20 28 76 " #t) '())).. (v
9d10: 61 6c 69 64 20 20 20 28 69 66 20 74 61 72 67 65 alid (if targe
9d20: 74 0a 09 09 20 20 20 20 20 20 28 6f 72 20 28 6e t... (or (n
9d30: 75 6c 6c 3f 20 6b 65 79 73 29 20 3b 3b 20 70 72 ull? keys) ;; pr
9d40: 6f 62 61 62 6c 79 20 64 6f 6e 27 74 20 6b 6e 6f obably don't kno
9d50: 77 20 6f 75 72 20 6b 65 79 73 20 79 65 74 0a 09 w our keys yet..
9d60: 09 09 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e .. (and (not (n
9d70: 75 6c 6c 3f 20 74 6c 69 73 74 29 29 0a 09 09 09 ull? tlist))....
9d80: 20 20 20 20 20 20 20 28 65 71 3f 20 6e 75 6d 6b (eq? numk
9d90: 65 79 73 20 28 6c 65 6e 67 74 68 20 74 6c 69 73 eys (length tlis
9da0: 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e t)).... (n
9db0: 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 73 74 72 ull? (filter str
9dc0: 69 6e 67 2d 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 ing-null? tlist)
9dd0: 29 29 29 0a 09 09 20 20 20 20 20 20 23 66 29 29 )))... #f))
9de0: 29 0a 20 20 20 20 28 69 66 20 76 61 6c 69 64 0a ). (if valid.
9df0: 09 28 69 66 20 73 70 6c 69 74 0a 09 20 20 20 20 .(if split..
9e00: 74 6c 69 73 74 0a 09 20 20 20 20 74 61 72 67 65 tlist.. targe
9e10: 74 29 0a 09 28 69 66 20 74 61 72 67 65 74 0a 09 t)..(if target..
9e20: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
9e30: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
9e40: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
9e50: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 76 61 6c log-port* "Inval
9e60: 69 64 20 74 61 72 67 65 74 2c 20 73 70 61 63 65 id target, space
9e70: 73 20 6f 72 20 62 6c 61 6e 6b 73 20 6e 6f 74 20 s or blanks not
9e80: 61 6c 6c 6f 77 65 64 20 5c 22 22 20 74 61 72 67 allowed \"" targ
9e90: 65 74 20 22 5c 22 2c 20 74 61 72 67 65 74 20 73 et "\", target s
9ea0: 68 6f 75 6c 64 20 62 65 3a 20 22 20 28 73 74 72 hould be: " (str
9eb0: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
9ec0: 6b 65 79 73 20 22 2f 22 29 20 22 2c 20 68 61 76 keys "/") ", hav
9ed0: 65 20 22 20 74 6c 69 73 74 20 22 20 66 6f 72 20 e " tlist " for
9ee0: 65 6c 65 6d 65 6e 74 73 22 29 0a 09 20 20 20 20 elements")..
9ef0: 20 20 28 69 66 20 65 78 69 74 2d 69 66 2d 62 61 (if exit-if-ba
9f00: 64 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 d (exit 1))..
9f10: 20 20 20 23 66 29 0a 09 20 20 20 20 23 66 29 29 #f).. #f))
9f20: 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 69 6e 67 20 6f ))..;; looking o
9f30: 6e 6c 79 20 28 61 74 20 6c 65 61 73 74 20 66 6f nly (at least fo
9f40: 72 20 6e 6f 77 29 20 61 74 20 74 68 65 20 4d 54 r now) at the MT
9f50: 5f 20 76 61 72 69 61 62 6c 65 73 20 63 72 61 66 _ variables craf
9f60: 74 20 74 68 65 20 66 75 6c 6c 20 74 65 73 74 6e t the full testn
9f70: 61 6d 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ame.;;.(define (
9f80: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c 2d common:get-full-
9f90: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 69 66 test-name). (if
9fa0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 (getenv "MT_TES
9fb0: 54 5f 4e 41 4d 45 22 29 0a 20 20 20 20 20 20 28 T_NAME"). (
9fc0: 69 66 20 28 61 6e 64 20 28 67 65 74 65 6e 76 20 if (and (getenv
9fd0: 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 0a 20 "MT_ITEMPATH").
9fe0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
9ff0: 6f 74 20 28 65 71 75 61 6c 3f 20 28 67 65 74 65 ot (equal? (gete
a000: 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 nv "MT_ITEMPATH"
a010: 29 20 22 22 29 29 29 0a 20 20 20 20 20 20 20 20 ) ""))).
a020: 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 (getenv "MT_TE
a030: 53 54 5f 4e 41 4d 45 22 29 0a 20 20 20 20 20 20 ST_NAME").
a040: 20 20 20 20 28 63 6f 6e 63 20 28 67 65 74 65 6e (conc (geten
a050: 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 v "MT_TEST_NAME"
a060: 29 20 22 2f 22 20 28 67 65 74 65 6e 76 20 22 4d ) "/" (getenv "M
a070: 54 5f 49 54 45 4d 50 41 54 48 22 29 29 29 0a 20 T_ITEMPATH"))).
a080: 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 6c 6f #f))..;; lo
a090: 67 69 63 20 66 6f 72 20 67 65 74 74 69 6e 67 20 gic for getting
a0a0: 68 6f 6d 65 68 6f 73 74 2e 20 52 65 74 75 72 6e homehost. Return
a0b0: 73 20 28 68 6f 73 74 20 2e 20 61 74 2d 68 6f 6d s (host . at-hom
a0c0: 65 29 0a 3b 3b 20 49 46 20 2a 74 6f 70 70 61 74 e).;; IF *toppat
a0d0: 68 2a 20 69 73 20 6e 6f 74 20 73 65 74 2c 20 77 h* is not set, w
a0e0: 61 69 74 20 75 70 20 74 6f 20 66 69 76 65 20 73 ait up to five s
a0f0: 65 63 6f 6e 64 73 20 74 72 79 69 6e 67 20 65 76 econds trying ev
a100: 65 72 79 20 74 77 6f 20 73 65 63 6f 6e 64 73 0a ery two seconds.
a110: 3b 3b 20 28 74 68 69 73 20 69 73 20 74 6f 20 61 ;; (this is to a
a120: 63 63 6f 6d 6f 64 61 74 65 20 74 68 65 20 77 61 ccomodate the wa
a130: 74 63 68 64 6f 67 29 0a 3b 3b 0a 28 64 65 66 69 tchdog).;;.(defi
a140: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 ne (common:get-h
a150: 6f 6d 65 68 6f 73 74 20 23 21 6b 65 79 20 28 74 omehost #!key (t
a160: 72 79 6e 75 6d 20 35 29 29 0a 20 20 3b 3b 20 63 rynum 5)). ;; c
a170: 61 6c 6c 65 64 20 6f 66 74 65 6e 20 65 73 70 65 alled often espe
a180: 63 69 61 6c 6c 79 20 61 74 20 73 74 61 72 74 20 cially at start
a190: 75 70 2e 20 75 73 65 20 6d 75 74 65 78 20 74 6f up. use mutex to
a1a0: 20 65 6c 69 6d 69 6e 61 74 65 20 63 6f 6c 6c 69 eliminate colli
a1b0: 73 69 6f 6e 73 0a 20 20 28 6d 75 74 65 78 2d 6c sions. (mutex-l
a1c0: 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d ock! *homehost-m
a1d0: 75 74 65 78 2a 29 0a 20 20 28 63 6f 6e 64 0a 20 utex*). (cond.
a1e0: 20 20 28 2a 68 6f 6d 65 2d 68 6f 73 74 2a 0a 20 (*home-host*.
a1f0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
a200: 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 ! *homehost-mute
a210: 78 2a 29 0a 20 20 20 20 2a 68 6f 6d 65 2d 68 6f x*). *home-ho
a220: 73 74 2a 29 0a 20 20 20 28 28 6e 6f 74 20 2a 74 st*). ((not *t
a230: 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 28 6d 75 oppath*). (mu
a240: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d tex-unlock! *hom
a250: 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 ehost-mutex*).
a260: 20 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 29 (launch:setup)
a270: 20 3b 3b 20 73 61 66 65 6c 79 20 6d 75 74 65 78 ;; safely mutex
a280: 65 64 20 6e 6f 77 0a 20 20 20 20 28 69 66 20 28 ed now. (if (
a290: 3e 20 74 72 79 6e 75 6d 20 30 29 0a 09 28 62 65 > trynum 0)..(be
a2a0: 67 69 6e 0a 09 20 20 28 74 68 72 65 61 64 2d 73 gin.. (thread-s
a2b0: 6c 65 65 70 21 20 32 29 0a 09 20 20 28 63 6f 6d leep! 2).. (com
a2c0: 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mon:get-homehost
a2d0: 20 74 72 79 6e 75 6d 3a 20 28 2d 20 74 72 79 6e trynum: (- tryn
a2e0: 75 6d 20 31 29 29 29 0a 09 23 66 29 29 0a 20 20 um 1)))..#f)).
a2f0: 20 28 65 6c 73 65 0a 20 20 20 20 28 6c 65 74 2a (else. (let*
a300: 20 28 28 63 75 72 72 68 6f 73 74 20 28 67 65 74 ((currhost (get
a310: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 -host-name))..
a320: 20 28 62 65 73 74 61 64 72 73 20 28 73 65 72 76 (bestadrs (serv
a330: 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 er:get-best-gues
a340: 73 2d 61 64 64 72 65 73 73 20 63 75 72 72 68 6f s-address currho
a350: 73 74 29 29 0a 09 20 20 20 3b 3b 20 66 69 72 73 st)).. ;; firs
a360: 74 20 6c 6f 6f 6b 20 69 6e 20 63 6f 6e 66 69 67 t look in config
a370: 2c 20 74 68 65 6e 20 6c 6f 6f 6b 20 69 6e 20 66 , then look in f
a380: 69 6c 65 20 2e 68 6f 6d 65 68 6f 73 74 2c 20 63 ile .homehost, c
a390: 72 65 61 74 65 20 69 74 20 69 66 20 6e 6f 74 20 reate it if not
a3a0: 66 6f 75 6e 64 0a 09 20 20 20 28 68 6f 6d 65 68 found.. (homeh
a3b0: 6f 73 74 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 ost (or (configf
a3c0: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
a3d0: 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 68 6f at* "server" "ho
a3e0: 6d 65 68 6f 73 74 22 20 29 0a 09 09 09 20 28 68 mehost" ).... (h
a3f0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
a400: 0a 09 09 09 20 20 20 20 20 65 78 6e 0a 09 09 09 .... exn....
a410: 20 20 20 20 20 28 69 66 20 28 3e 20 74 72 79 6e (if (> tryn
a420: 75 6d 20 30 29 0a 09 09 09 09 20 28 6c 65 74 20 um 0)..... (let
a430: 28 28 64 65 6c 61 79 2d 74 69 6d 65 20 28 2a 20 ((delay-time (*
a440: 28 2d 20 35 20 74 72 79 6e 75 6d 29 20 35 29 29 (- 5 trynum) 5))
a450: 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d )..... (mutex-
a460: 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 unlock! *homehos
a470: 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 09 20 20 t-mutex*).....
a480: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
a490: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
a4a0: 74 2a 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 t* "ERROR: Faile
a4b0: 64 20 74 6f 20 72 65 61 64 20 2e 68 6f 6d 65 68 d to read .homeh
a4c0: 6f 73 74 20 66 69 6c 65 2c 20 64 65 6c 61 79 69 ost file, delayi
a4d0: 6e 67 20 22 20 64 65 6c 61 79 2d 74 69 6d 65 20 ng " delay-time
a4e0: 22 20 73 65 63 6f 6e 64 73 20 61 6e 64 20 74 72 " seconds and tr
a4f0: 79 69 6e 67 20 61 67 61 69 6e 2c 20 6d 65 73 73 ying again, mess
a500: 61 67 65 3a 20 22 20 20 28 28 63 6f 6e 64 69 74 age: " ((condit
a510: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
a520: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
a530: 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 09 20 age) exn)).....
a540: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
a550: 20 64 65 6c 61 79 2d 74 69 6d 65 29 0a 09 09 09 delay-time)....
a560: 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d . (common:get-
a570: 68 6f 6d 65 68 6f 73 74 20 74 72 79 6e 75 6d 3a homehost trynum:
a580: 20 28 2d 20 74 72 79 6e 75 6d 20 31 29 29 29 0a (- trynum 1))).
a590: 09 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 09 .... (begin.....
a5a0: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
a5b0: 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 ! *homehost-mute
a5c0: 78 2a 29 0a 09 09 09 09 20 20 20 28 64 65 62 75 x*)..... (debu
a5d0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
a5e0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
a5f0: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 72 ROR: Failed to r
a600: 65 61 64 20 2e 68 6f 6d 65 68 6f 73 74 20 66 69 ead .homehost fi
a610: 6c 65 20 61 66 74 65 72 20 74 72 79 69 6e 67 20 le after trying
a620: 66 69 76 65 20 74 69 6d 65 73 2e 20 47 69 76 69 five times. Givi
a630: 6e 67 20 75 70 20 61 6e 64 20 65 78 69 74 69 6e ng up and exitin
a640: 67 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 20 28 g, message: " (
a650: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
a660: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
a670: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
a680: 29 0a 09 09 09 09 20 20 20 28 65 78 69 74 20 31 )..... (exit 1
a690: 29 29 29 0a 09 09 09 20 20 20 28 6c 65 74 20 28 ))).... (let (
a6a0: 28 68 68 66 20 28 63 6f 6e 63 20 2a 74 6f 70 70 (hhf (conc *topp
a6b0: 61 74 68 2a 20 22 2f 2e 68 6f 6d 65 68 6f 73 74 ath* "/.homehost
a6c0: 22 29 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 "))).... (if
a6d0: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
a6e0: 69 73 74 73 3f 20 68 68 66 29 0a 09 09 09 09 20 ists? hhf).....
a6f0: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
a700: 2d 66 69 6c 65 20 68 68 66 20 72 65 61 64 2d 6c -file hhf read-l
a710: 69 6e 65 29 0a 09 09 09 09 20 28 69 66 20 28 66 ine)..... (if (f
a720: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
a730: 3f 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 09 ? *toppath*)....
a740: 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 . (begin....
a750: 09 20 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 . (with-ou
a760: 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 68 68 66 tput-to-file hhf
a770: 0a 09 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 ...... (lambda (
a780: 29 0a 09 09 09 09 09 20 20 20 28 70 72 69 6e 74 )...... (print
a790: 20 62 65 73 74 61 64 72 73 29 29 29 0a 09 09 09 bestadrs)))....
a7a0: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
a7b0: 09 09 09 09 20 28 6d 75 74 65 78 2d 75 6e 6c 6f .... (mutex-unlo
a7c0: 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 ck! *homehost-mu
a7d0: 74 65 78 2a 29 0a 09 09 09 09 09 20 28 63 61 72 tex*)...... (car
a7e0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d (common:get-hom
a7f0: 65 68 6f 73 74 29 29 29 29 0a 09 09 09 09 20 20 ehost)))).....
a800: 20 20 20 23 66 29 29 29 29 29 29 0a 09 20 20 20 #f))))))..
a810: 28 61 74 2d 68 6f 6d 65 20 20 28 6f 72 20 28 65 (at-home (or (e
a820: 71 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 63 qual? homehost c
a830: 75 72 72 68 6f 73 74 29 0a 09 09 09 20 28 65 71 urrhost).... (eq
a840: 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 62 65 ual? homehost be
a850: 73 74 61 64 72 73 29 29 29 29 0a 20 20 20 20 20 stadrs)))).
a860: 20 28 73 65 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 (set! *home-hos
a870: 74 2a 20 28 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 t* (cons homehos
a880: 74 20 61 74 2d 68 6f 6d 65 29 29 0a 20 20 20 20 t at-home)).
a890: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
a8a0: 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 *homehost-mutex
a8b0: 2a 29 0a 20 20 20 20 20 20 2a 68 6f 6d 65 2d 68 *). *home-h
a8c0: 6f 73 74 2a 29 29 29 29 0a 0a 3b 3b 20 61 6d 20 ost*))))..;; am
a8d0: 49 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 I on the homehos
a8e0: 74 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 t?.;;.(define (c
a8f0: 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 ommon:on-homehos
a900: 74 3f 29 0a 20 20 28 6c 65 74 20 28 28 68 68 20 t?). (let ((hh
a910: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 (common:get-home
a920: 68 6f 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 host))). (if
a930: 68 68 0a 09 28 63 64 72 20 68 68 29 0a 09 23 66 hh..(cdr hh)..#f
a940: 29 29 29 0a 0a 3b 3b 20 64 6f 20 77 65 20 68 6f )))..;; do we ho
a950: 6e 6f 72 20 74 68 65 20 63 61 63 68 65 73 20 6f nor the caches o
a960: 66 20 74 68 65 20 63 6f 6e 66 69 67 20 66 69 6c f the config fil
a970: 65 73 3f 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 es?.;;.(define (
a980: 63 6f 6d 6d 6f 6e 3a 75 73 65 2d 63 61 63 68 65 common:use-cache
a990: 3f 29 0a 20 20 28 6c 65 74 20 28 28 72 65 73 20 ?). (let ((res
a9a0: 23 74 29 29 20 3b 3b 20 70 72 69 6f 72 69 74 79 #t)) ;; priority
a9b0: 20 62 79 20 6f 72 64 65 72 20 6f 66 20 65 76 61 by order of eva
a9c0: 6c 75 61 74 69 6f 6e 0a 20 20 20 20 28 69 66 20 luation. (if
a9d0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 3b 3b 20 73 *configdat* ;; s
a9e0: 69 6c 6c 79 6e 65 73 73 20 68 65 72 65 2e 20 63 illyness here. c
a9f0: 61 6e 27 74 20 75 73 65 20 73 65 74 75 70 2f 75 an't use setup/u
aa00: 73 65 2d 63 61 63 68 65 20 74 6f 20 6b 6e 6f 77 se-cache to know
aa10: 20 69 66 20 77 65 20 63 61 6e 20 75 73 65 20 74 if we can use t
aa20: 68 65 20 63 61 63 68 65 64 20 66 69 6c 65 73 21 he cached files!
aa30: 0a 09 28 69 66 20 28 65 71 75 61 6c 3f 20 28 63 ..(if (equal? (c
aa40: 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 onfigf:lookup *c
aa50: 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 onfigdat* "setup
aa60: 22 20 22 75 73 65 2d 63 61 63 68 65 22 29 20 22 " "use-cache") "
aa70: 6e 6f 22 29 0a 09 20 20 20 20 28 73 65 74 21 20 no").. (set!
aa80: 72 65 73 20 23 66 29 0a 09 20 20 20 20 28 69 66 res #f).. (if
aa90: 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 67 (equal? (config
aaa0: 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 f:lookup *config
aab0: 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 75 73 dat* "setup" "us
aac0: 65 2d 63 61 63 68 65 22 29 20 22 79 65 73 22 29 e-cache") "yes")
aad0: 0a 09 09 28 73 65 74 21 20 72 65 73 20 23 74 29 ...(set! res #t)
aae0: 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 72 67 ))). (if (arg
aaf0: 73 3a 67 65 74 2d 61 72 67 20 22 2d 6e 6f 2d 63 s:get-arg "-no-c
ab00: 61 63 68 65 22 29 28 73 65 74 21 20 72 65 73 20 ache")(set! res
ab10: 23 66 29 29 20 3b 3b 20 6f 76 65 72 72 69 64 65 #f)) ;; override
ab20: 73 20 73 65 74 74 69 6e 67 20 69 6e 20 22 73 65 s setting in "se
ab30: 74 75 70 22 0a 20 20 20 20 28 69 66 20 28 67 65 tup". (if (ge
ab40: 74 65 6e 76 20 22 4d 54 5f 55 53 45 5f 43 41 43 tenv "MT_USE_CAC
ab50: 48 45 22 29 0a 09 28 69 66 20 28 65 71 75 61 6c HE")..(if (equal
ab60: 3f 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 55 53 ? (getenv "MT_US
ab70: 45 5f 43 41 43 48 45 22 29 20 22 79 65 73 22 29 E_CACHE") "yes")
ab80: 0a 09 20 20 20 20 28 73 65 74 21 20 72 65 73 20 .. (set! res
ab90: 23 74 29 0a 09 20 20 20 20 28 69 66 20 28 65 71 #t).. (if (eq
aba0: 75 61 6c 3f 20 28 67 65 74 65 6e 76 20 22 4d 54 ual? (getenv "MT
abb0: 5f 55 53 45 5f 43 41 43 48 45 22 29 20 22 6e 6f _USE_CACHE") "no
abc0: 22 29 0a 09 09 28 73 65 74 21 20 72 65 73 20 23 ")...(set! res #
abd0: 66 29 29 29 29 20 20 20 20 3b 3b 20 6f 76 65 72 f)))) ;; over
abe0: 72 69 64 65 73 20 2d 6e 6f 2d 63 61 63 68 65 20 rides -no-cache
abf0: 73 77 69 74 63 68 0a 20 20 20 20 72 65 73 29 29 switch. res))
ac00: 0a 20 20 0a 3b 3b 20 66 6f 72 63 65 20 75 73 65 . .;; force use
ac10: 20 6f 66 20 73 65 72 76 65 72 3f 0a 3b 3b 0a 28 of server?.;;.(
ac20: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 define (common:f
ac30: 6f 72 63 65 2d 73 65 72 76 65 72 3f 29 0a 20 20 orce-server?).
ac40: 28 6c 65 74 2a 20 28 28 66 6f 72 63 65 2d 73 65 (let* ((force-se
ac50: 74 74 69 6e 67 20 28 63 6f 6e 66 69 67 66 3a 6c tting (configf:l
ac60: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
ac70: 2a 20 22 73 65 72 76 65 72 22 20 22 66 6f 72 63 * "server" "forc
ac80: 65 22 29 29 0a 09 20 28 66 6f 72 63 65 2d 74 79 e")).. (force-ty
ac90: 70 65 20 20 20 20 28 69 66 20 66 6f 72 63 65 2d pe (if force-
aca0: 73 65 74 74 69 6e 67 20 28 73 74 72 69 6e 67 2d setting (string-
acb0: 3e 73 79 6d 62 6f 6c 20 66 6f 72 63 65 2d 73 65 >symbol force-se
acc0: 74 74 69 6e 67 29 20 23 66 29 29 0a 09 20 28 66 tting) #f)).. (f
acd0: 6f 72 63 65 2d 72 65 73 75 6c 74 20 20 28 63 61 orce-result (ca
ace0: 73 65 20 66 6f 72 63 65 2d 74 79 70 65 0a 09 09 se force-type...
acf0: 09 20 20 28 28 23 66 29 20 20 20 20 20 23 66 29 . ((#f) #f)
ad00: 0a 09 09 09 20 20 28 28 61 6c 77 61 79 73 29 20 .... ((always)
ad10: 23 74 29 0a 09 09 09 20 20 28 28 74 65 73 74 29 #t).... ((test)
ad20: 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 (if (args:get
ad30: 2d 61 72 67 20 22 2d 65 78 65 63 75 74 65 22 29 -arg "-execute")
ad40: 20 3b 3b 20 77 65 20 61 72 65 20 69 6e 20 61 20 ;; we are in a
ad50: 74 65 73 74 0a 09 09 09 09 09 23 74 0a 09 09 09 test......#t....
ad60: 09 09 23 66 29 29 0a 09 09 09 20 20 28 65 6c 73 ..#f)).... (els
ad70: 65 0a 09 09 09 20 20 20 28 64 65 62 75 67 3a 70 e.... (debug:p
ad80: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
ad90: 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 4f 52 log-port* "ERROR
ada0: 3a 20 42 61 64 20 73 65 72 76 65 72 20 66 6f 72 : Bad server for
adb0: 63 65 20 73 65 74 74 69 6e 67 20 22 20 66 6f 72 ce setting " for
adc0: 63 65 2d 73 65 74 74 69 6e 67 20 22 2c 20 66 6f ce-setting ", fo
add0: 72 63 69 6e 67 20 73 65 72 76 65 72 2e 22 29 0a rcing server.").
ade0: 09 09 09 20 20 20 23 74 29 29 29 29 20 3b 3b 20 ... #t)))) ;;
adf0: 64 65 66 61 75 6c 74 20 74 6f 20 72 65 71 75 69 default to requi
ae00: 72 69 6e 67 20 73 65 72 76 65 72 0a 20 20 20 20 ring server.
ae10: 28 69 66 20 66 6f 72 63 65 2d 72 65 73 75 6c 74 (if force-result
ae20: 0a 09 28 62 65 67 69 6e 0a 09 20 20 28 64 65 62 ..(begin.. (deb
ae30: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
ae40: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
ae50: 74 2a 20 22 66 6f 72 63 69 6e 67 20 75 73 65 20 t* "forcing use
ae60: 6f 66 20 73 65 72 76 65 72 2c 20 66 6f 72 63 65 of server, force
ae70: 20 73 65 74 74 69 6e 67 20 69 73 20 5c 22 22 20 setting is \""
ae80: 66 6f 72 63 65 2d 73 65 74 74 69 6e 67 20 22 5c force-setting "\
ae90: 22 2e 22 29 0a 09 20 20 23 74 29 0a 09 23 66 29 ".").. #t)..#f)
aea0: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
aeb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aec0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aed0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
aee0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
aef0: 4d 20 49 20 53 20 43 20 20 20 4c 20 49 20 53 20 M I S C L I S
af00: 54 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d T S.;;==========
af10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
af40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b ============..;;
af50: 20 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 61 20 items in lista
af60: 61 72 65 20 6d 61 74 63 68 65 64 20 76 61 6c 75 are matched valu
af70: 65 20 61 6e 64 20 70 6f 73 69 74 69 6f 6e 20 69 e and position i
af80: 6e 20 6c 69 73 74 62 0a 3b 3b 20 72 65 74 75 72 n listb.;; retur
af90: 6e 20 74 68 65 20 72 65 6d 61 69 6e 69 6e 67 20 n the remaining
afa0: 69 74 65 6d 73 20 69 6e 20 6c 69 73 74 62 20 6f items in listb o
afb0: 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 r #f.;;.(define
afc0: 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 69 73 2d (common:list-is-
afd0: 73 75 62 6c 69 73 74 20 6c 69 73 74 61 20 6c 69 sublist lista li
afe0: 73 74 62 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c stb). (if (null
aff0: 3f 20 6c 69 73 74 61 29 0a 20 20 20 20 20 20 6c ? lista). l
b000: 69 73 74 62 20 3b 3b 20 61 6c 6c 20 69 74 65 6d istb ;; all item
b010: 73 20 69 6e 20 6c 69 73 74 62 20 61 72 65 20 22 s in listb are "
b020: 72 65 6d 61 69 6e 69 6e 67 22 0a 20 20 20 20 20 remaining".
b030: 20 28 69 66 20 28 3e 20 28 6c 65 6e 67 74 68 20 (if (> (length
b040: 6c 69 73 74 61 29 28 6c 65 6e 67 74 68 20 6c 69 lista)(length li
b050: 73 74 62 29 29 20 0a 09 20 20 23 66 0a 09 20 20 stb)) .. #f..
b060: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 61 (let loop ((heda
b070: 20 28 63 61 72 20 6c 69 73 74 61 29 29 0a 09 09 (car lista))...
b080: 20 20 20 20 20 28 74 61 6c 61 20 28 63 64 72 20 (tala (cdr
b090: 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 20 28 lista))... (
b0a0: 68 65 64 62 20 28 63 61 72 20 6c 69 73 74 62 29 hedb (car listb)
b0b0: 29 0a 09 09 20 20 20 20 20 28 74 61 6c 62 20 28 )... (talb (
b0c0: 63 64 72 20 6c 69 73 74 62 29 29 29 0a 09 20 20 cdr listb)))..
b0d0: 20 20 28 69 66 20 28 65 71 75 61 6c 3f 20 68 65 (if (equal? he
b0e0: 64 61 20 68 65 64 62 29 0a 09 09 28 69 66 20 28 da hedb)...(if (
b0f0: 6e 75 6c 6c 3f 20 74 61 6c 61 29 20 3b 3b 20 77 null? tala) ;; w
b100: 65 20 61 72 65 20 64 6f 6e 65 0a 09 09 20 20 20 e are done...
b110: 20 74 61 6c 62 0a 09 09 20 20 20 20 28 6c 6f 6f talb... (loo
b120: 70 20 28 63 61 72 20 74 61 6c 61 29 0a 09 09 09 p (car tala)....
b130: 20 20 28 63 64 72 20 74 61 6c 61 29 0a 09 09 09 (cdr tala)....
b140: 20 20 28 63 61 72 20 74 61 6c 62 29 0a 09 09 09 (car talb)....
b150: 20 20 0a 09 09 09 20 20 28 63 64 72 20 74 61 6c .... (cdr tal
b160: 62 29 29 29 0a 09 09 23 66 29 29 29 29 29 0a 0a b)))...#f)))))..
b170: 3b 3b 20 4e 65 65 64 65 64 20 66 6f 72 20 6c 6f ;; Needed for lo
b180: 6e 67 20 6c 69 73 74 73 20 74 6f 20 62 65 20 73 ng lists to be s
b190: 6f 72 74 65 64 20 77 68 65 72 65 20 28 61 70 70 orted where (app
b1a0: 6c 79 20 6d 61 78 20 2e 2e 2e 20 29 20 64 69 65 ly max ... ) die
b1b0: 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f s.;;.(define (co
b1c0: 6d 6d 6f 6e 3a 6d 61 78 20 69 6e 6c 73 74 29 0a mmon:max inlst).
b1d0: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6d 61 (let loop ((ma
b1e0: 78 2d 76 61 6c 20 28 63 61 72 20 69 6e 6c 73 74 x-val (car inlst
b1f0: 29 29 0a 09 20 20 20 20 20 28 68 65 64 20 20 20 )).. (hed
b200: 20 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 (car inlst))..
b210: 20 20 20 20 20 28 74 61 6c 20 20 20 20 20 28 63 (tal (c
b220: 64 72 20 69 6e 6c 73 74 29 29 29 0a 20 20 20 20 dr inlst))).
b230: 28 69 66 20 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 (if (not (null?
b240: 74 61 6c 29 29 0a 09 28 6c 6f 6f 70 20 28 6d 61 tal))..(loop (ma
b250: 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 0a 09 x hed max-val)..
b260: 20 20 20 20 20 20 28 63 61 72 20 74 61 6c 29 0a (car tal).
b270: 09 20 20 20 20 20 20 28 63 64 72 20 74 61 6c 29 . (cdr tal)
b280: 29 0a 09 28 6d 61 78 20 68 65 64 20 6d 61 78 2d )..(max hed max-
b290: 76 61 6c 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 val))))..;; get
b2a0: 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 75 73 65 20 min or max, use
b2b0: 3e 20 66 6f 72 20 6d 61 78 20 61 6e 64 20 3c 20 > for max and <
b2c0: 66 6f 72 20 6d 69 6e 2c 20 74 68 69 73 20 77 6f for min, this wo
b2d0: 72 6b 73 20 61 72 6f 75 6e 64 20 74 68 65 20 6c rks around the l
b2e0: 69 6d 69 74 73 20 6f 6e 20 61 70 70 6c 79 0a 3b imits on apply.;
b2f0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
b300: 6e 3a 6d 69 6e 2d 6d 61 78 20 63 6f 6d 70 20 6c n:min-max comp l
b310: 73 74 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f st). (if (null?
b320: 20 6c 73 74 29 0a 20 20 20 20 20 20 23 66 20 3b lst). #f ;
b330: 3b 20 62 65 74 74 65 72 20 74 68 61 6e 20 61 6e ; better than an
b340: 20 65 78 63 65 70 74 69 6f 6e 20 66 6f 72 20 6d exception for m
b350: 79 20 6e 65 65 64 73 0a 20 20 20 20 20 20 28 66 y needs. (f
b360: 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 61 20 62 old (lambda (a b
b370: 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 63 6f ).. (if (co
b380: 6d 70 20 61 20 62 29 20 61 20 62 29 29 0a 09 20 mp a b) a b))..
b390: 20 20 20 28 63 61 72 20 6c 73 74 29 0a 09 20 20 (car lst)..
b3a0: 20 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 67 65 74 lst)))..;; get
b3b0: 20 6d 69 6e 20 6f 72 20 6d 61 78 2c 20 75 73 65 min or max, use
b3c0: 20 3e 20 66 6f 72 20 6d 61 78 20 61 6e 64 20 3c > for max and <
b3d0: 20 66 6f 72 20 6d 69 6e 2c 20 74 68 69 73 20 77 for min, this w
b3e0: 6f 72 6b 73 20 61 72 6f 75 6e 64 20 74 68 65 20 orks around the
b3f0: 6c 69 6d 69 74 73 20 6f 6e 20 61 70 70 6c 79 0a limits on apply.
b400: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
b410: 6f 6e 3a 73 75 6d 20 6c 73 74 29 0a 20 20 28 69 on:sum lst). (i
b420: 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 29 0a 20 20 f (null? lst).
b430: 20 20 20 20 30 0a 20 20 20 20 20 20 28 66 6f 6c 0. (fol
b440: 64 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a d (lambda (a b).
b450: 09 20 20 20 20 20 20 28 2b 20 61 20 62 29 29 0a . (+ a b)).
b460: 09 20 20 20 20 28 63 61 72 20 6c 73 74 29 0a 09 . (car lst)..
b470: 20 20 20 20 6c 73 74 29 29 29 0a 0a 3b 3b 20 70 lst)))..;; p
b480: 61 74 68 20 6c 69 73 74 20 74 6f 20 68 61 73 68 ath list to hash
b490: 2d 74 61 62 6c 65 20 74 72 65 65 0a 3b 3b 20 20 -table tree.;;
b4a0: 20 28 28 61 20 62 20 63 29 28 61 20 62 20 64 29 ((a b c)(a b d)
b4b0: 28 65 20 62 20 63 29 29 20 3d 3e 20 28 28 61 20 (e b c)) => ((a
b4c0: 28 62 20 28 64 29 20 28 63 29 29 29 20 28 65 20 (b (d) (c))) (e
b4d0: 28 62 20 28 63 29 29 29 29 0a 3b 3b 0a 28 64 65 (b (c)))).;;.(de
b4e0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 fine (common:lis
b4f0: 74 2d 3e 68 74 72 65 65 20 6c 73 74 29 0a 20 20 t->htree lst).
b500: 28 6c 65 74 20 28 28 72 65 73 68 20 28 6d 61 6b (let ((resh (mak
b510: 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a e-hash-table))).
b520: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 (for-each.
b530: 20 20 20 28 6c 61 6d 62 64 61 20 28 69 6e 6c 73 (lambda (inls
b540: 74 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 6c t). (let l
b550: 6f 6f 70 20 28 28 68 74 20 20 72 65 73 68 29 0a oop ((ht resh).
b560: 09 09 20 20 28 68 65 64 20 28 63 61 72 20 69 6e .. (hed (car in
b570: 6c 73 74 29 29 0a 09 09 20 20 28 74 61 6c 20 28 lst))... (tal (
b580: 63 64 72 20 69 6e 6c 73 74 29 29 29 0a 09 20 28 cdr inlst))).. (
b590: 69 66 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 if (hash-table-r
b5a0: 65 66 2f 64 65 66 61 75 6c 74 20 68 74 20 68 65 ef/default ht he
b5b0: 64 20 23 66 29 0a 09 20 20 20 20 20 28 69 66 20 d #f).. (if
b5c0: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
b5d0: 29 0a 09 09 20 28 6c 6f 6f 70 20 28 68 61 73 68 )... (loop (hash
b5e0: 2d 74 61 62 6c 65 2d 72 65 66 20 68 74 20 68 65 -table-ref ht he
b5f0: 64 29 0a 09 09 20 20 20 20 20 20 20 28 63 61 72 d)... (car
b600: 20 74 61 6c 29 0a 09 09 20 20 20 20 20 20 20 28 tal)... (
b610: 63 64 72 20 74 61 6c 29 29 29 0a 09 20 20 20 20 cdr tal)))..
b620: 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 20 20 (begin..
b630: 28 68 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 (hash-table-set!
b640: 20 68 74 20 68 65 64 20 28 6d 61 6b 65 2d 68 61 ht hed (make-ha
b650: 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 20 sh-table))..
b660: 20 20 20 28 6c 6f 6f 70 20 68 74 20 68 65 64 20 (loop ht hed
b670: 74 61 6c 29 29 29 29 29 0a 20 20 20 20 20 6c 73 tal))))). ls
b680: 74 29 0a 20 20 20 20 72 65 73 68 29 29 0a 0a 3b t). resh))..;
b690: 3b 20 68 61 73 68 2d 74 61 62 6c 65 20 74 72 65 ; hash-table tre
b6a0: 65 20 74 6f 20 68 74 6d 6c 20 6c 69 73 74 20 74 e to html list t
b6b0: 72 65 65 0a 3b 3b 0a 3b 3b 20 20 20 74 69 70 66 ree.;;.;; tipf
b6c0: 75 6e 63 20 74 61 6b 65 73 20 74 77 6f 20 70 61 unc takes two pa
b6d0: 72 61 6d 65 74 65 72 73 3a 20 79 20 74 68 65 20 rameters: y the
b6e0: 74 69 70 20 76 61 6c 75 65 20 61 6e 64 20 70 61 tip value and pa
b6f0: 74 68 20 74 68 65 20 70 61 74 68 20 74 6f 20 74 th the path to t
b700: 68 61 74 20 70 6f 69 6e 74 0a 3b 3b 0a 28 64 65 hat point.;;.(de
b710: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 fine (common:htr
b720: 65 65 2d 3e 68 74 6d 6c 20 68 74 20 70 61 74 68 ee->html ht path
b730: 20 74 69 70 66 75 6e 63 29 0a 20 20 28 6c 65 74 tipfunc). (let
b740: 20 28 28 64 61 74 6c 69 73 74 20 09 28 73 6f 72 ((datlist .(sor
b750: 74 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e 61 t (hash-table->a
b760: 6c 69 73 74 20 68 74 29 0a 20 20 20 20 20 20 20 list ht).
b770: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b780: 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 (lambda (
b790: 61 20 62 29 0a 20 20 20 20 20 20 20 20 20 20 20 a b).
b7a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
b7b0: 20 20 20 20 20 28 73 74 72 69 6e 67 3c 20 28 63 (string< (c
b7c0: 61 72 20 61 29 28 63 61 72 20 62 29 29 29 29 29 ar a)(car b)))))
b7d0: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
b7e0: 20 64 61 74 6c 69 73 74 29 0a 20 20 20 20 09 28 datlist). .(
b7f0: 74 69 70 66 75 6e 63 20 23 66 20 70 61 74 68 29 tipfunc #f path)
b800: 20 3b 3b 20 72 65 61 6c 6c 79 20 73 68 6f 75 6c ;; really shoul
b810: 64 6e 27 74 20 67 65 74 20 68 65 72 65 0a 09 28 dn't get here..(
b820: 73 3a 75 6c 0a 09 20 28 6d 61 70 20 28 6c 61 6d s:ul.. (map (lam
b830: 62 64 61 20 28 78 29 0a 09 09 28 6c 65 74 2a 20 bda (x)...(let*
b840: 28 28 6c 65 76 65 6c 6e 61 6d 65 20 28 63 61 72 ((levelname (car
b850: 20 78 29 29 0a 09 09 20 20 20 20 20 20 20 28 79 x))... (y
b860: 20 20 20 20 20 20 20 20 20 28 63 64 72 20 78 29 (cdr x)
b870: 29 0a 09 09 20 20 20 20 20 20 20 28 6e 65 77 70 )... (newp
b880: 61 74 68 20 20 20 28 61 70 70 65 6e 64 20 70 61 ath (append pa
b890: 74 68 20 28 6c 69 73 74 20 6c 65 76 65 6c 6e 61 th (list levelna
b8a0: 6d 65 29 29 29 0a 09 09 20 20 20 20 20 20 20 28 me)))... (
b8b0: 6c 65 61 66 20 20 20 20 20 20 28 6f 72 20 28 6e leaf (or (n
b8c0: 6f 74 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 ot (hash-table?
b8d0: 79 29 29 0a 09 09 09 09 20 20 20 20 20 20 28 6e y))..... (n
b8e0: 75 6c 6c 3f 20 28 68 61 73 68 2d 74 61 62 6c 65 ull? (hash-table
b8f0: 2d 6b 65 79 73 20 79 29 29 29 29 29 0a 09 09 20 -keys y)))))...
b900: 20 28 69 66 20 6c 65 61 66 0a 09 09 20 20 20 20 (if leaf...
b910: 20 20 28 73 3a 6c 69 20 28 74 69 70 66 75 6e 63 (s:li (tipfunc
b920: 20 79 20 6e 65 77 70 61 74 68 29 29 0a 09 09 20 y newpath))...
b930: 20 20 20 20 20 28 73 3a 6c 69 0a 09 09 20 20 20 (s:li...
b940: 20 20 20 20 28 6c 69 73 74 20 0a 09 09 09 6c 65 (list ....le
b950: 76 65 6c 6e 61 6d 65 0a 09 09 09 28 63 6f 6d 6d velname....(comm
b960: 6f 6e 3a 68 74 72 65 65 2d 3e 68 74 6d 6c 20 79 on:htree->html y
b970: 20 6e 65 77 70 61 74 68 20 74 69 70 66 75 6e 63 newpath tipfunc
b980: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 64 61 )))))).. da
b990: 74 6c 69 73 74 29 29 29 29 29 0a 0a 3b 3b 20 68 tlist)))))..;; h
b9a0: 61 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 ash-table tree t
b9b0: 6f 20 61 6c 69 73 74 20 74 72 65 65 0a 3b 3b 0a o alist tree.;;.
b9c0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
b9d0: 68 74 72 65 65 2d 3e 61 74 72 65 65 20 68 74 29 htree->atree ht)
b9e0: 0a 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 . (map (lambda
b9f0: 28 78 29 0a 09 20 28 63 6f 6e 73 20 28 63 61 72 (x).. (cons (car
ba00: 20 78 29 0a 09 20 20 20 20 20 20 20 28 6c 65 74 x).. (let
ba10: 20 28 28 79 20 28 63 64 72 20 78 29 29 29 0a 09 ((y (cdr x)))..
ba20: 09 20 28 69 66 20 28 68 61 73 68 2d 74 61 62 6c . (if (hash-tabl
ba30: 65 3f 20 79 29 0a 09 09 20 20 20 20 20 28 63 6f e? y)... (co
ba40: 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e 61 74 72 65 mmon:htree->atre
ba50: 65 20 79 29 0a 09 09 20 20 20 20 20 79 29 29 29 e y)... y)))
ba60: 29 0a 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 ). (hash-t
ba70: 61 62 6c 65 2d 3e 61 6c 69 73 74 20 68 74 29 29 able->alist ht))
ba80: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
ba90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
baa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bab0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bac0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d ===========.;; M
bad0: 20 55 20 4e 20 47 20 45 20 20 20 44 20 41 20 54 U N G E D A T
bae0: 20 41 20 20 20 49 20 4e 20 54 20 4f 20 20 20 4e A I N T O N
baf0: 20 49 20 43 20 45 20 20 20 46 20 4f 20 52 20 4d I C E F O R M
bb00: 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;===========
bb10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bb20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bb30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bb40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
bb50: 47 65 6e 65 72 61 74 65 20 61 6e 20 69 6e 64 65 Generate an inde
bb60: 78 20 66 6f 72 20 61 20 73 70 61 72 73 65 20 6c x for a sparse l
bb70: 69 73 74 20 6f 66 20 6b 65 79 20 76 61 6c 75 65 ist of key value
bb80: 73 0a 3b 3b 20 20 20 28 20 28 72 6f 77 6e 61 6d s.;; ( (rownam
bb90: 65 31 20 63 6f 6c 6e 61 6d 65 31 20 76 61 6c 31 e1 colname1 val1
bba0: 29 28 72 6f 77 6e 61 6d 65 32 20 63 6f 6c 6e 61 )(rowname2 colna
bbb0: 6d 65 32 20 76 61 6c 32 29 20 29 0a 3b 3b 0a 3b me2 val2) ).;;.;
bbc0: 3b 20 3d 3e 20 0a 3b 3b 0a 3b 3b 20 20 20 28 20 ; => .;;.;; (
bbd0: 28 72 6f 77 6e 61 6d 65 31 20 30 29 28 72 6f 77 (rowname1 0)(row
bbe0: 6e 61 6d 65 32 20 31 29 29 20 20 20 20 3b 3b 20 name2 1)) ;;
bbf0: 72 6f 77 6e 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a rownames -> num.
bc00: 3b 3b 20 20 20 20 20 28 63 6f 6c 6e 61 6d 65 31 ;; (colname1
bc10: 20 30 29 28 63 6f 6c 6e 61 6d 65 32 20 31 29 29 0)(colname2 1))
bc20: 20 29 20 20 3b 3b 20 63 6f 6c 6e 61 6d 65 73 20 ) ;; colnames
bc30: 2d 3e 20 6e 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 -> num.;; .;; op
bc40: 74 69 6f 6e 61 6c 20 61 70 70 6c 79 20 70 72 6f tional apply pro
bc50: 63 20 74 6f 20 72 6f 77 6e 75 6d 20 63 6f 6c 6e c to rownum coln
bc60: 75 6d 20 76 61 6c 75 65 0a 28 64 65 66 69 6e 65 um value.(define
bc70: 20 28 63 6f 6d 6d 6f 6e 3a 73 70 61 72 73 65 2d (common:sparse-
bc80: 6c 69 73 74 2d 67 65 6e 65 72 61 74 65 2d 69 6e list-generate-in
bc90: 64 65 78 20 64 61 74 61 20 23 21 6b 65 79 20 28 dex data #!key (
bca0: 70 72 6f 63 20 23 66 29 29 0a 20 20 28 69 66 20 proc #f)). (if
bcb0: 28 6e 75 6c 6c 3f 20 64 61 74 61 29 0a 20 20 20 (null? data).
bcc0: 20 20 20 28 6c 69 73 74 20 27 28 29 20 27 28 29 (list '() '()
bcd0: 29 0a 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f ). (let loo
bce0: 70 20 28 28 68 65 64 20 28 63 61 72 20 64 61 74 p ((hed (car dat
bcf0: 61 29 29 0a 09 09 20 28 74 61 6c 20 28 63 64 72 a))... (tal (cdr
bd00: 20 64 61 74 61 29 29 0a 09 09 20 28 72 6f 77 6e data))... (rown
bd10: 61 6d 65 73 20 27 28 29 29 0a 09 09 20 28 63 6f ames '())... (co
bd20: 6c 6e 61 6d 65 73 20 27 28 29 29 0a 09 09 20 28 lnames '())... (
bd30: 72 6f 77 6e 75 6d 20 20 20 30 29 0a 09 09 20 28 rownum 0)... (
bd40: 63 6f 6c 6e 75 6d 20 20 20 30 29 29 0a 09 28 6c colnum 0))..(l
bd50: 65 74 2a 20 28 28 72 6f 77 6b 65 79 20 20 20 20 et* ((rowkey
bd60: 20 20 20 20 20 20 28 63 61 72 20 20 20 68 65 64 (car hed
bd70: 29 29 0a 09 20 20 20 20 20 20 20 28 63 6f 6c 6b )).. (colk
bd80: 65 79 20 20 20 20 20 20 20 20 20 20 28 63 61 64 ey (cad
bd90: 72 20 20 68 65 64 29 29 0a 09 20 20 20 20 20 20 r hed))..
bda0: 20 28 76 61 6c 75 65 20 20 20 20 20 20 20 20 20 (value
bdb0: 20 20 28 63 61 64 64 72 20 68 65 64 29 29 0a 09 (caddr hed))..
bdc0: 20 20 20 20 20 20 20 28 65 78 69 73 74 69 6e 67 (existing
bdd0: 2d 72 6f 77 64 61 74 20 28 61 73 73 6f 63 20 72 -rowdat (assoc r
bde0: 6f 77 6b 65 79 20 72 6f 77 6e 61 6d 65 73 29 29 owkey rownames))
bdf0: 0a 09 20 20 20 20 20 20 20 28 65 78 69 73 74 69 .. (existi
be00: 6e 67 2d 63 6f 6c 64 61 74 20 28 61 73 73 6f 63 ng-coldat (assoc
be10: 20 63 6f 6c 6b 65 79 20 63 6f 6c 6e 61 6d 65 73 colkey colnames
be20: 29 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 )).. (curr
be30: 2d 72 6f 77 6e 75 6d 20 20 20 20 20 28 69 66 20 -rownum (if
be40: 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 74 20 existing-rowdat
be50: 72 6f 77 6e 75 6d 20 28 2b 20 72 6f 77 6e 75 6d rownum (+ rownum
be60: 20 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 63 1))).. (c
be70: 75 72 72 2d 63 6f 6c 6e 75 6d 20 20 20 20 20 28 urr-colnum (
be80: 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c 64 if existing-cold
be90: 61 74 20 63 6f 6c 6e 75 6d 20 28 2b 20 63 6f 6c at colnum (+ col
bea0: 6e 75 6d 20 31 29 29 29 0a 09 20 20 20 20 20 20 num 1)))..
beb0: 20 28 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 20 (new-rownames
bec0: 20 20 28 69 66 20 65 78 69 73 74 69 6e 67 2d 72 (if existing-r
bed0: 6f 77 64 61 74 20 72 6f 77 6e 61 6d 65 73 20 28 owdat rownames (
bee0: 63 6f 6e 73 20 28 6c 69 73 74 20 72 6f 77 6b 65 cons (list rowke
bef0: 79 20 63 75 72 72 2d 72 6f 77 6e 75 6d 29 20 72 y curr-rownum) r
bf00: 6f 77 6e 61 6d 65 73 29 29 29 0a 09 20 20 20 20 ownames)))..
bf10: 20 20 20 28 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 (new-colnames
bf20: 20 20 20 20 28 69 66 20 65 78 69 73 74 69 6e 67 (if existing
bf30: 2d 63 6f 6c 64 61 74 20 63 6f 6c 6e 61 6d 65 73 -coldat colnames
bf40: 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 63 6f 6c (cons (list col
bf50: 6b 65 79 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 29 key curr-colnum)
bf60: 20 63 6f 6c 6e 61 6d 65 73 29 29 29 29 0a 09 20 colnames))))..
bf70: 20 3b 3b 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ;; (debug:print
bf80: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
bf90: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 50 72 6f 63 -log-port* "Proc
bfa0: 65 73 73 69 6e 67 20 72 65 63 6f 72 64 3a 20 22 essing record: "
bfb0: 20 68 65 64 20 29 0a 09 20 20 28 69 66 20 70 72 hed ).. (if pr
bfc0: 6f 63 20 28 70 72 6f 63 20 63 75 72 72 2d 72 6f oc (proc curr-ro
bfd0: 77 6e 75 6d 20 63 75 72 72 2d 63 6f 6c 6e 75 6d wnum curr-colnum
bfe0: 20 72 6f 77 6b 65 79 20 63 6f 6c 6b 65 79 20 76 rowkey colkey v
bff0: 61 6c 75 65 29 29 0a 09 20 20 28 69 66 20 28 6e alue)).. (if (n
c000: 75 6c 6c 3f 20 74 61 6c 29 0a 09 20 20 20 20 20 ull? tal)..
c010: 20 28 6c 69 73 74 20 6e 65 77 2d 72 6f 77 6e 61 (list new-rowna
c020: 6d 65 73 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 mes new-colnames
c030: 29 0a 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 ).. (loop (
c040: 63 61 72 20 74 61 6c 29 0a 09 09 20 20 20 20 28 car tal)... (
c050: 63 64 72 20 74 61 6c 29 0a 09 09 20 20 20 20 6e cdr tal)... n
c060: 65 77 2d 72 6f 77 6e 61 6d 65 73 0a 09 09 20 20 ew-rownames...
c070: 20 20 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 0a 09 new-colnames..
c080: 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 72 . (if (> curr
c090: 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 20 -rownum rownum)
c0a0: 63 75 72 72 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e curr-rownum rown
c0b0: 75 6d 29 0a 09 09 20 20 20 20 28 69 66 20 28 3e um)... (if (>
c0c0: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c curr-colnum col
c0d0: 6e 75 6d 29 20 63 75 72 72 2d 63 6f 6c 6e 75 6d num) curr-colnum
c0e0: 20 63 6f 6c 6e 75 6d 29 0a 09 09 20 20 20 20 29 colnum)... )
c0f0: 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d )))))..;;=======
c100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
c140: 3b 3b 20 53 20 59 20 53 20 54 20 45 20 4d 20 20 ;; S Y S T E M
c150: 20 53 20 54 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d S T U F F.;;===
c160: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c1a0: 3d 3d 3d 0a 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 ===..;; lazy-saf
c1b0: 65 20 67 65 74 20 66 69 6c 65 20 6d 6f 64 20 74 e get file mod t
c1c0: 69 6d 65 2e 20 6f 6e 20 61 6e 79 20 65 72 72 6f ime. on any erro
c1d0: 72 20 28 66 69 6c 65 20 6e 6f 74 20 65 78 69 73 r (file not exis
c1e0: 74 69 6e 67 20 65 74 63 2e 29 20 72 65 74 75 72 ting etc.) retur
c1f0: 6e 20 30 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 n 0.;;.(define (
c200: 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 common:lazy-modi
c210: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 70 fication-time fp
c220: 61 74 68 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 ath). (handle-e
c230: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 xceptions.
c240: 65 78 6e 0a 20 20 20 20 20 20 30 0a 20 20 20 20 exn. 0.
c250: 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 74 69 (file-modificati
c260: 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 29 29 on-time fpath)))
c270: 0a 0a 3b 3b 20 66 69 6e 64 20 74 69 6d 65 73 74 ..;; find timest
c280: 61 6d 70 20 6f 66 20 6e 65 77 65 73 74 20 66 69 amp of newest fi
c290: 6c 65 20 61 73 73 6f 63 69 61 74 65 64 20 77 69 le associated wi
c2a0: 74 68 20 61 20 73 71 6c 69 74 65 20 64 62 20 66 th a sqlite db f
c2b0: 69 6c 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ile.(define (com
c2c0: 6d 6f 6e 3a 6c 61 7a 79 2d 73 71 6c 69 74 65 2d mon:lazy-sqlite-
c2d0: 64 62 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d db-modification-
c2e0: 74 69 6d 65 20 66 70 61 74 68 29 0a 20 20 28 6c time fpath). (l
c2f0: 65 74 2a 20 28 28 67 6c 6f 62 2d 6c 69 73 74 20 et* ((glob-list
c300: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
c310: 6e 73 0a 09 09 09 65 78 6e 0a 09 09 09 60 28 2c ns....exn....`(,
c320: 28 63 6f 6e 63 20 22 2f 6e 6f 2f 73 75 63 68 2f (conc "/no/such/
c330: 66 69 6c 65 2c 20 6d 65 73 73 61 67 65 3a 20 22 file, message: "
c340: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
c350: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
c360: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
c370: 6e 29 29 29 0a 09 09 20 20 20 20 20 20 28 67 6c n)))... (gl
c380: 6f 62 20 28 63 6f 6e 63 20 66 70 61 74 68 20 22 ob (conc fpath "
c390: 2a 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 *")))).
c3a0: 28 66 69 6c 65 2d 6c 69 73 74 20 28 69 66 20 28 (file-list (if (
c3b0: 65 71 3f 20 30 20 28 6c 65 6e 67 74 68 20 67 6c eq? 0 (length gl
c3c0: 6f 62 2d 6c 69 73 74 29 29 0a 09 09 09 27 28 22 ob-list))....'("
c3d0: 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 22 29 0a /no/such/file").
c3e0: 09 09 09 67 6c 6f 62 2d 6c 69 73 74 29 29 29 0a ...glob-list))).
c3f0: 20 20 28 61 70 70 6c 79 20 6d 61 78 0a 20 20 20 (apply max.
c400: 28 6d 61 70 0a 20 20 20 20 63 6f 6d 6d 6f 6e 3a (map. common:
c410: 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 74 69 6f lazy-modificatio
c420: 6e 2d 74 69 6d 65 20 0a 20 20 20 20 66 69 6c 65 n-time . file
c430: 2d 6c 69 73 74 29 29 29 29 0a 0a 3b 3b 20 72 65 -list))))..;; re
c440: 74 75 72 6e 20 61 20 6e 69 63 65 20 63 6c 65 61 turn a nice clea
c450: 6e 20 70 61 74 68 6e 61 6d 65 20 6d 61 64 65 20 n pathname made
c460: 61 62 73 6f 6c 75 74 65 0a 28 64 65 66 69 6e 65 absolute.(define
c470: 20 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 (common:nice-pa
c480: 74 68 20 64 69 72 29 0a 20 20 28 6c 65 74 20 28 th dir). (let (
c490: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 6d (match (string-m
c4a0: 61 74 63 68 20 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a atch "^(~[^\\/]*
c4b0: 29 28 5c 5c 2f 2e 2a 7c 29 24 22 20 64 69 72 29 )(\\/.*|)$" dir)
c4c0: 29 29 0a 20 20 20 20 28 69 66 20 6d 61 74 63 68 )). (if match
c4d0: 20 3b 3b 20 75 73 69 6e 67 20 7e 20 66 6f 72 20 ;; using ~ for
c4e0: 68 6f 6d 65 3f 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e home?..(common:n
c4f0: 69 63 65 2d 70 61 74 68 20 28 63 6f 6e 63 20 28 ice-path (conc (
c500: 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b common:read-link
c510: 2d 66 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 -f (cadr match))
c520: 20 22 2f 22 20 28 63 61 64 64 72 20 6d 61 74 63 "/" (caddr matc
c530: 68 29 29 29 0a 09 28 6e 6f 72 6d 61 6c 69 7a 65 h)))..(normalize
c540: 2d 70 61 74 68 6e 61 6d 65 20 28 69 66 20 28 61 -pathname (if (a
c550: 62 73 6f 6c 75 74 65 2d 70 61 74 68 6e 61 6d 65 bsolute-pathname
c560: 3f 20 64 69 72 29 0a 09 09 09 09 64 69 72 0a 09 ? dir).....dir..
c570: 09 09 09 28 63 6f 6e 63 20 28 63 75 72 72 65 6e ...(conc (curren
c580: 74 2d 64 69 72 65 63 74 6f 72 79 29 20 22 2f 22 t-directory) "/"
c590: 20 64 69 72 29 29 29 29 29 29 0a 0a 3b 3b 20 6d dir))))))..;; m
c5a0: 61 6b 65 20 22 6e 69 63 65 2d 70 61 74 68 22 20 ake "nice-path"
c5b0: 61 76 61 69 6c 61 62 6c 65 20 69 6e 20 63 6f 6e available in con
c5c0: 66 69 67 20 66 69 6c 65 73 20 61 6e 64 20 74 68 fig files and th
c5d0: 65 20 72 65 70 6c 0a 28 64 65 66 69 6e 65 20 6e e repl.(define n
c5e0: 69 63 65 2d 70 61 74 68 20 63 6f 6d 6d 6f 6e 3a ice-path common:
c5f0: 6e 69 63 65 2d 70 61 74 68 29 0a 0a 28 64 65 66 nice-path)..(def
c600: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 ine (common:read
c610: 2d 6c 69 6e 6b 2d 66 20 70 61 74 68 29 0a 20 20 -link-f path).
c620: 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f (handle-exceptio
c630: 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 ns. exn.
c640: 20 20 20 28 62 65 67 69 6e 0a 09 28 64 65 62 75 (begin..(debu
c650: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
c660: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
c670: 74 2a 20 22 63 6f 6d 6d 61 6e 64 20 5c 22 2f 62 t* "command \"/b
c680: 69 6e 2f 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 in/readlink -f "
c690: 20 70 61 74 68 20 22 5c 22 20 66 61 69 6c 65 64 path "\" failed
c6a0: 2e 22 29 0a 09 70 61 74 68 29 20 3b 3b 20 6a 75 .")..path) ;; ju
c6b0: 73 74 20 67 69 76 65 20 75 70 0a 20 20 20 20 28 st give up. (
c6c0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
c6d0: 70 69 70 65 0a 09 28 63 6f 6e 63 20 22 2f 62 69 pipe..(conc "/bi
c6e0: 6e 2f 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 n/readlink -f "
c6f0: 70 61 74 68 29 0a 20 20 20 20 20 20 28 6c 61 6d path). (lam
c700: 62 64 61 20 28 29 0a 09 28 72 65 61 64 2d 6c 69 bda ()..(read-li
c710: 6e 65 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ne)))))..(define
c720: 20 28 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 23 (get-cpu-load #
c730: 21 6b 65 79 20 28 72 65 6d 6f 74 65 2d 68 6f 73 !key (remote-hos
c740: 74 20 23 66 29 29 0a 20 20 28 63 61 72 20 28 63 t #f)). (car (c
c750: 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f ommon:get-cpu-lo
c760: 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 ad remote-host))
c770: 29 0a 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 6c ).;; (let* ((l
c780: 6f 61 64 2d 72 65 73 20 28 70 72 6f 63 65 73 73 oad-res (process
c790: 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 :cmd-run->list "
c7a0: 75 70 74 69 6d 65 22 29 29 0a 3b 3b 20 09 20 28 uptime")).;; . (
c7b0: 6c 6f 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 load-rx (regexp
c7c0: 20 22 6c 6f 61 64 20 61 76 65 72 61 67 65 3a 5c "load average:\
c7d0: 5c 73 2b 28 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 \s+(\\d+)")).;;
c7e0: 09 20 28 63 70 75 2d 6c 6f 61 64 20 23 66 29 29 . (cpu-load #f))
c7f0: 0a 3b 3b 20 20 20 20 20 28 66 6f 72 2d 65 61 63 .;; (for-eac
c800: 68 20 28 6c 61 6d 62 64 61 20 28 6c 29 0a 3b 3b h (lambda (l).;;
c810: 20 09 09 28 6c 65 74 20 28 28 6d 61 74 63 68 20 ..(let ((match
c820: 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 6c (string-search l
c830: 6f 61 64 2d 72 78 20 6c 29 29 29 0a 3b 3b 20 09 oad-rx l))).;; .
c840: 09 20 20 28 69 66 20 6d 61 74 63 68 0a 3b 3b 20 . (if match.;;
c850: 09 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e .. (let ((n
c860: 65 77 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e ewval (string->n
c870: 75 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 umber (cadr matc
c880: 68 29 29 29 29 0a 3b 3b 20 09 09 09 28 69 66 20 h)))).;; ...(if
c890: 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 (number? newval)
c8a0: 0a 3b 3b 20 09 09 09 20 20 20 20 28 73 65 74 21 .;; ... (set!
c8b0: 20 63 70 75 2d 6c 6f 61 64 20 6e 65 77 76 61 6c cpu-load newval
c8c0: 29 29 29 29 29 29 0a 3b 3b 20 09 20 20 20 20 20 )))))).;; .
c8d0: 20 28 63 61 72 20 6c 6f 61 64 2d 72 65 73 29 29 (car load-res))
c8e0: 0a 3b 3b 20 20 20 20 20 63 70 75 2d 6c 6f 61 64 .;; cpu-load
c8f0: 29 29 0a 0a 3b 3b 20 67 65 74 20 63 70 75 20 6c ))..;; get cpu l
c900: 6f 61 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 oad by reading f
c910: 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 rom /proc/loadav
c920: 67 2c 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 g, return all th
c930: 72 65 65 20 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 ree values.;;.(d
c940: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 efine (common:ge
c950: 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 t-cpu-load remot
c960: 65 2d 68 6f 73 74 29 0a 20 20 28 69 66 20 72 65 e-host). (if re
c970: 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 20 20 20 mote-host.
c980: 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 72 65 (map (lambda (re
c990: 73 29 0a 09 20 20 20 20 20 28 69 66 20 28 65 6f s).. (if (eo
c9a0: 66 2d 6f 62 6a 65 63 74 3f 20 72 65 73 29 20 39 f-object? res) 9
c9b0: 65 39 39 20 72 65 73 29 29 0a 09 20 20 20 28 77 e99 res)).. (w
c9c0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
c9d0: 69 70 65 20 0a 09 20 20 20 20 28 63 6f 6e 63 20 ipe .. (conc
c9e0: 22 73 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f "ssh " remote-ho
c9f0: 73 74 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c st " cat /proc/l
ca00: 6f 61 64 61 76 67 22 29 0a 09 20 20 20 20 28 6c oadavg").. (l
ca10: 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 28 72 ambda ()(list (r
ca20: 65 61 64 29 28 72 65 61 64 29 28 72 65 61 64 29 ead)(read)(read)
ca30: 29 29 29 29 0a 20 20 20 20 20 20 28 77 69 74 68 )))). (with
ca40: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 -input-from-file
ca50: 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 22 "/proc/loadavg"
ca60: 20 0a 09 28 6c 61 6d 62 64 61 20 28 29 28 6c 69 ..(lambda ()(li
ca70: 73 74 20 28 72 65 61 64 29 28 72 65 61 64 29 28 st (read)(read)(
ca80: 72 65 61 64 29 29 29 29 29 29 0a 0a 3b 3b 20 67 read))))))..;; g
ca90: 65 74 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 63 70 et normalized cp
caa0: 75 20 6c 6f 61 64 20 62 79 20 72 65 61 64 69 6e u load by readin
cab0: 67 20 66 72 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 g from /proc/loa
cac0: 64 61 76 67 20 61 6e 64 20 2f 70 72 6f 63 2f 63 davg and /proc/c
cad0: 70 75 69 6e 66 6f 20 72 65 74 75 72 6e 20 61 6c puinfo return al
cae0: 6c 20 74 68 72 65 65 20 76 61 6c 75 65 73 20 61 l three values a
caf0: 6e 64 20 74 68 65 20 6e 75 6d 62 65 72 20 6f 66 nd the number of
cb00: 20 72 65 61 6c 20 63 70 75 73 20 61 6e 64 20 74 real cpus and t
cb10: 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 74 68 72 he number of thr
cb20: 65 61 64 73 0a 3b 3b 20 72 65 74 75 72 6e 73 20 eads.;; returns
cb30: 61 6c 69 73 74 20 27 28 28 61 64 6a 2d 63 70 75 alist '((adj-cpu
cb40: 2d 6c 6f 61 64 20 2e 20 6e 6f 72 6d 61 6c 69 7a -load . normaliz
cb50: 65 64 2d 70 72 6f 63 2d 6c 6f 61 64 29 20 2e 2e ed-proc-load) ..
cb60: 2e 20 65 74 63 2e 0a 3b 3b 20 20 6b 65 79 73 3a . etc..;; keys:
cb70: 20 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 2c 20 adj-proc-load,
cb80: 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 2c 20 31 adj-core-load, 1
cb90: 6d 2d 6c 6f 61 64 2c 20 35 6d 2d 6c 6f 61 64 2c m-load, 5m-load,
cba0: 20 31 35 6d 2d 6c 6f 61 64 0a 3b 3b 0a 28 64 65 15m-load.;;.(de
cbb0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
cbc0: 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d -normalized-cpu-
cbd0: 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f 73 74 load remote-host
cbe0: 29 0a 20 20 28 6c 65 74 20 28 28 64 61 74 61 20 ). (let ((data
cbf0: 28 69 66 20 72 65 6d 6f 74 65 2d 68 6f 73 74 0a (if remote-host.
cc00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
cc10: 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 (with-input-fr
cc20: 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 20 20 20 om-pipe .
cc30: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
cc40: 63 20 22 73 73 68 20 22 20 72 65 6d 6f 74 65 2d c "ssh " remote-
cc50: 68 6f 73 74 20 22 20 63 61 74 20 2f 70 72 6f 63 host " cat /proc
cc60: 2f 6c 6f 61 64 61 76 67 3b 63 61 74 20 2f 70 72 /loadavg;cat /pr
cc70: 6f 63 2f 63 70 75 69 6e 66 6f 3b 65 63 68 6f 20 oc/cpuinfo;echo
cc80: 65 6e 64 22 29 0a 20 20 20 20 20 20 20 20 20 20 end").
cc90: 20 20 20 20 20 20 20 20 20 72 65 61 64 2d 6c 69 read-li
cca0: 6e 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 nes).
ccb0: 20 20 20 20 20 20 20 28 61 70 70 65 6e 64 20 0a (append .
ccc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ccd0: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
cce0: 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f rom-file "/proc/
ccf0: 6c 6f 61 64 61 76 67 22 20 0a 20 20 20 20 20 20 loadavg" .
cd00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 72 r
cd10: 65 61 64 2d 6c 69 6e 65 73 29 0a 20 20 20 20 20 ead-lines).
cd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
cd30: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 ith-input-from-f
cd40: 69 6c 65 20 22 2f 70 72 6f 63 2f 63 70 75 69 6e ile "/proc/cpuin
cd50: 66 6f 22 0a 20 20 20 20 20 20 20 20 20 20 20 20 fo".
cd60: 20 20 20 20 20 20 20 20 20 72 65 61 64 2d 6c 69 read-li
cd70: 6e 65 73 29 0a 20 20 20 20 20 20 20 20 20 20 20 nes).
cd80: 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 22 65 (list "e
cd90: 6e 64 22 29 29 29 29 0a 20 20 20 20 20 20 20 20 nd")))).
cda0: 28 6c 6f 61 64 2d 72 78 20 20 28 72 65 67 65 78 (load-rx (regex
cdb0: 70 20 22 5e 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c p "^([\\d\\.]+)\
cdc0: 5c 73 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c \s+([\\d\\.]+)\\
cdd0: 73 2b 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 s+([\\d\\.]+)\\s
cde0: 2b 2e 2a 24 22 29 29 0a 20 20 20 20 20 20 20 20 +.*$")).
cdf0: 28 70 72 6f 63 2d 72 78 20 20 28 72 65 67 65 78 (proc-rx (regex
ce00: 70 20 22 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 p "^processor\\s
ce10: 2b 3a 5c 5c 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a +:\\s+(\\d+)\\s*
ce20: 24 22 29 29 0a 20 20 20 20 20 20 20 20 28 63 6f $")). (co
ce30: 72 65 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 re-rx (regexp "
ce40: 5e 63 6f 72 65 20 69 64 5c 5c 73 2b 3a 5c 5c 73 ^core id\\s+:\\s
ce50: 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a +(\\d+)\\s*$")).
ce60: 20 20 20 20 20 20 20 20 28 70 68 79 73 2d 72 78 (phys-rx
ce70: 20 20 28 72 65 67 65 78 70 20 22 5e 70 68 79 73 (regexp "^phys
ce80: 69 63 61 6c 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b ical id\\s+:\\s+
ce90: 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 (\\d+)\\s*$")).
cea0: 20 20 20 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 (max-num
ceb0: 20 28 6c 61 6d 62 64 61 20 28 70 20 6e 29 28 6d (lambda (p n)(m
cec0: 61 78 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 ax (string->numb
ced0: 65 72 20 70 29 20 6e 29 29 29 29 0a 20 20 20 20 er p) n)))).
cee0: 3b 3b 20 28 70 72 69 6e 74 20 22 64 61 74 61 3d ;; (print "data=
cef0: 22 20 64 61 74 61 29 0a 20 20 20 20 28 69 66 20 " data). (if
cf00: 28 6e 75 6c 6c 3f 20 64 61 74 61 29 20 3b 3b 20 (null? data) ;;
cf10: 73 6f 6d 65 74 68 69 6e 67 20 77 65 6e 74 20 77 something went w
cf20: 72 6f 6e 67 0a 20 20 20 20 20 20 20 20 23 66 0a rong. #f.
cf30: 20 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f (let loo
cf40: 70 20 28 28 68 65 64 20 20 20 20 20 20 28 63 61 p ((hed (ca
cf50: 72 20 64 61 74 61 29 29 0a 20 20 20 20 20 20 20 r data)).
cf60: 20 20 20 20 20 20 20 20 20 20 20 20 28 74 61 6c (tal
cf70: 20 20 20 20 20 20 28 63 64 72 20 64 61 74 61 29 (cdr data)
cf80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
cf90: 20 20 20 20 20 28 6c 6f 61 64 73 20 20 20 20 23 (loads #
cfa0: 66 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 f).
cfb0: 20 20 20 20 20 20 28 70 72 6f 63 2d 6e 75 6d 20 (proc-num
cfc0: 30 29 20 20 3b 3b 20 70 72 6f 63 65 73 73 6f 72 0) ;; processor
cfd0: 20 69 6e 63 6c 75 64 65 73 20 74 68 72 65 61 64 includes thread
cfe0: 73 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 s.
cff0: 20 20 20 20 20 28 70 68 79 73 2d 6e 75 6d 20 30 (phys-num 0
d000: 29 20 20 3b 3b 20 70 68 79 73 69 63 61 6c 20 63 ) ;; physical c
d010: 68 69 70 20 6f 6e 20 6d 6f 74 68 65 72 62 6f 61 hip on motherboa
d020: 72 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 rd.
d030: 20 20 20 20 20 20 28 63 6f 72 65 2d 6e 75 6d 20 (core-num
d040: 30 29 29 20 3b 3b 20 63 6f 72 65 0a 20 20 20 20 0)) ;; core.
d050: 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ;; (print
d060: 68 65 64 20 22 2c 20 22 20 6c 6f 61 64 73 20 22 hed ", " loads "
d070: 2c 20 22 20 70 72 6f 63 2d 6e 75 6d 20 22 2c 20 , " proc-num ",
d080: 22 20 70 68 79 73 2d 6e 75 6d 20 22 2c 20 22 20 " phys-num ", "
d090: 63 6f 72 65 2d 6e 75 6d 29 0a 20 20 20 20 20 20 core-num).
d0a0: 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 (if (null? t
d0b0: 61 6c 29 20 3b 3b 20 68 61 76 65 20 61 6c 6c 20 al) ;; have all
d0c0: 6f 75 72 20 64 61 74 61 2c 20 63 61 6c 63 75 6c our data, calcul
d0d0: 61 74 65 20 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c ate normalized l
d0e0: 6f 61 64 20 61 6e 64 20 72 65 74 75 72 6e 20 72 oad and return r
d0f0: 65 73 75 6c 74 0a 20 20 20 20 20 20 20 20 20 20 esult.
d100: 20 20 20 20 28 6c 65 74 2a 20 28 28 61 63 74 2d (let* ((act-
d110: 70 72 6f 63 20 28 2b 20 70 72 6f 63 2d 6e 75 6d proc (+ proc-num
d120: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1)).
d130: 20 20 20 20 20 20 20 20 20 20 28 61 63 74 2d 70 (act-p
d140: 68 79 73 20 28 2b 20 70 68 79 73 2d 6e 75 6d 20 hys (+ phys-num
d150: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
d160: 20 20 20 20 20 20 20 20 20 28 61 63 74 2d 63 6f (act-co
d170: 72 65 20 28 2b 20 63 6f 72 65 2d 6e 75 6d 20 31 re (+ core-num 1
d180: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d190: 20 20 20 20 20 20 20 20 28 61 64 6a 2d 70 72 6f (adj-pro
d1a0: 63 2d 6c 6f 61 64 20 28 2f 20 28 63 61 72 20 6c c-load (/ (car l
d1b0: 6f 61 64 73 29 20 61 63 74 2d 70 72 6f 63 29 29 oads) act-proc))
d1c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d1d0: 20 20 20 20 20 20 28 61 64 6a 2d 63 6f 72 65 2d (adj-core-
d1e0: 6c 6f 61 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 load (/ (car loa
d1f0: 64 73 29 20 61 63 74 2d 63 6f 72 65 29 29 29 0a ds) act-core))).
d200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d210: 28 61 70 70 65 6e 64 20 28 6c 69 73 74 20 28 63 (append (list (c
d220: 6f 6e 73 20 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f ons 'adj-proc-lo
d230: 61 64 20 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 ad adj-proc-load
d240: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d250: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d260: 28 63 6f 6e 73 20 27 61 64 6a 2d 63 6f 72 65 2d (cons 'adj-core-
d270: 6c 6f 61 64 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f load adj-core-lo
d280: 61 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ad)).
d290: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
d2a0: 73 74 20 28 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 st (cons '1m-loa
d2b0: 64 20 28 63 61 72 20 6c 6f 61 64 73 29 29 0a 20 d (car loads)).
d2c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d2d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
d2e0: 6e 73 20 27 35 6d 2d 6c 6f 61 64 20 28 63 61 64 ns '5m-load (cad
d2f0: 72 20 6c 6f 61 64 73 29 29 0a 20 20 20 20 20 20 r loads)).
d300: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d310: 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 31 (cons '1
d320: 35 6d 2d 6c 6f 61 64 20 28 63 61 64 64 72 20 6c 5m-load (caddr l
d330: 6f 61 64 73 29 29 29 0a 20 20 20 20 20 20 20 20 oads))).
d340: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d350: 28 6c 69 73 74 20 28 63 6f 6e 73 20 27 70 72 6f (list (cons 'pro
d360: 63 20 61 63 74 2d 70 72 6f 63 29 0a 20 20 20 20 c act-proc).
d370: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d380: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
d390: 27 63 6f 72 65 20 61 63 74 2d 63 6f 72 65 29 0a 'core act-core).
d3a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d3b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
d3c0: 6f 6e 73 20 27 70 68 79 73 20 61 63 74 2d 70 68 ons 'phys act-ph
d3d0: 79 73 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 ys)))).
d3e0: 20 20 20 20 20 28 72 65 67 65 78 2d 63 61 73 65 (regex-case
d3f0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d400: 68 65 64 0a 20 20 20 20 20 20 20 20 20 20 20 20 hed.
d410: 20 20 20 28 6c 6f 61 64 2d 72 78 20 20 28 20 78 (load-rx ( x
d420: 20 6c 31 20 6c 35 20 6c 31 35 20 29 20 28 6c 6f l1 l5 l15 ) (lo
d430: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
d440: 20 74 61 6c 29 28 6d 61 70 20 73 74 72 69 6e 67 tal)(map string
d450: 2d 3e 6e 75 6d 62 65 72 20 28 6c 69 73 74 20 6c ->number (list l
d460: 31 20 6c 35 20 6c 31 35 29 29 20 70 72 6f 63 2d 1 l5 l15)) proc-
d470: 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 63 6f 72 num phys-num cor
d480: 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 20 20 20 e-num)).
d490: 20 20 20 20 20 20 20 28 70 72 6f 63 2d 72 78 20 (proc-rx
d4a0: 20 28 20 78 20 70 20 20 20 20 20 20 20 20 20 29 ( x p )
d4b0: 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
d4c0: 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 20 (cdr tal) loads
d4d0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 78 2d 6e (max-n
d4e0: 75 6d 20 70 20 70 72 6f 63 2d 6e 75 6d 29 20 70 um p proc-num) p
d4f0: 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d hys-num core-num
d500: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d510: 20 20 28 70 68 79 73 2d 72 78 20 20 28 20 78 20 (phys-rx ( x
d520: 70 20 20 20 20 20 20 20 20 20 29 20 28 6c 6f 6f p ) (loo
d530: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
d540: 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 20 tal) loads
d550: 20 20 20 20 20 70 72 6f 63 2d 6e 75 6d 20 28 6d proc-num (m
d560: 61 78 2d 6e 75 6d 20 70 20 70 68 79 73 2d 6e 75 ax-num p phys-nu
d570: 6d 29 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 m) core-num)).
d580: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
d590: 72 65 2d 72 78 20 20 28 20 78 20 63 20 20 20 20 re-rx ( x c
d5a0: 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 61 ) (loop (ca
d5b0: 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 r tal)(cdr tal)
d5c0: 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 20 20 loads
d5d0: 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 proc-num phys-nu
d5e0: 6d 20 28 6d 61 78 2d 6e 75 6d 20 63 20 63 6f 72 m (max-num c cor
d5f0: 65 2d 6e 75 6d 29 29 29 0a 20 20 20 20 20 20 20 e-num))).
d600: 20 20 20 20 20 20 20 20 28 65 6c 73 65 20 0a 20 (else .
d610: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d620: 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 20 begin.
d630: 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 69 6e ;; (prin
d640: 74 20 22 4e 4f 20 4d 41 54 43 48 3a 20 22 20 68 t "NO MATCH: " h
d650: 65 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ed).
d660: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 (loop (car
d670: 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 20 6c tal)(cdr tal) l
d680: 6f 61 64 73 20 70 72 6f 63 2d 6e 75 6d 20 70 68 oads proc-num ph
d690: 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 ys-num core-num)
d6a0: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
d6b0: 65 20 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 e (common:unix-p
d6c0: 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 ing hostname).
d6d0: 28 6c 65 74 20 28 28 72 65 73 20 28 73 79 73 74 (let ((res (syst
d6e0: 65 6d 20 28 63 6f 6e 63 20 22 70 69 6e 67 20 2d em (conc "ping -
d6f0: 63 20 31 20 22 20 68 6f 73 74 6e 61 6d 65 20 22 c 1 " hostname "
d700: 20 3e 20 2f 64 65 76 2f 6e 75 6c 6c 22 29 29 29 > /dev/null")))
d710: 29 0a 20 20 20 20 28 65 71 3f 20 72 65 73 20 30 ). (eq? res 0
d720: 29 29 29 0a 0a 3b 3b 20 69 64 65 61 6c 6c 79 20 )))..;; ideally
d730: 70 75 74 20 61 6c 6c 20 74 68 69 73 20 69 6e 66 put all this inf
d740: 6f 20 69 6e 74 6f 20 74 68 65 20 64 62 2c 20 6e o into the db, n
d750: 6f 20 6e 65 65 64 20 74 6f 20 70 72 65 73 65 72 o need to preser
d760: 76 65 20 69 74 20 61 63 72 6f 73 73 20 6d 6f 76 ve it across mov
d770: 69 6e 67 20 68 6f 6d 65 68 6f 73 74 0a 3b 3b 0a ing homehost.;;.
d780: 3b 3b 20 72 65 74 75 72 6e 20 6c 69 73 74 20 6f ;; return list o
d790: 66 0a 3b 3b 20 20 28 20 72 65 61 63 68 61 62 6c f.;; ( reachabl
d7a0: 65 3f 20 63 70 75 6c 6f 61 64 20 75 70 64 61 74 e? cpuload updat
d7b0: 65 2d 74 69 6d 65 20 29 0a 28 64 65 66 69 6e 65 e-time ).(define
d7c0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 73 (common:get-hos
d7d0: 74 2d 69 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 t-info hostname)
d7e0: 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 69 . (let* ((loadi
d7f0: 6e 66 6f 20 28 72 6d 74 3a 67 65 74 2d 6c 61 74 nfo (rmt:get-lat
d800: 65 73 74 2d 68 6f 73 74 2d 6c 6f 61 64 20 68 6f est-host-load ho
d810: 73 74 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 20 stname)).
d820: 20 20 28 6c 6f 61 64 20 28 63 61 72 20 6c 6f 61 (load (car loa
d830: 64 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 dinfo)).
d840: 20 28 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 (load-sample-ti
d850: 6d 65 20 28 63 64 72 20 6c 6f 61 64 69 6e 66 6f me (cdr loadinfo
d860: 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 )). (loa
d870: 64 2d 73 61 6d 70 6c 65 2d 61 67 65 20 28 2d 20 d-sample-age (-
d880: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
d890: 29 20 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 ) load-sample-ti
d8a0: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c me)). (l
d8b0: 6f 61 64 69 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d oadinfo-timeout-
d8c0: 73 65 63 6f 6e 64 73 20 32 30 29 0a 20 20 20 20 seconds 20).
d8d0: 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d (host-last-
d8e0: 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 2d 73 update-timeout-s
d8f0: 65 63 6f 6e 64 73 20 31 30 29 0a 20 20 20 20 20 econds 10).
d900: 20 20 20 20 28 68 6f 73 74 2d 72 65 63 20 28 68 (host-rec (h
d910: 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
d920: 66 61 75 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 fault *host-load
d930: 73 2a 20 68 6f 73 74 6e 61 6d 65 20 23 66 29 29 s* hostname #f))
d940: 0a 20 20 20 20 20 20 20 20 20 29 0a 20 20 20 20 . ).
d950: 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 3c 20 6c (cond. ((< l
d960: 6f 61 64 2d 73 61 6d 70 6c 65 2d 61 67 65 20 6c oad-sample-age l
d970: 6f 61 64 69 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d oadinfo-timeout-
d980: 73 65 63 6f 6e 64 73 29 0a 20 20 20 20 20 20 28 seconds). (
d990: 6c 69 73 74 20 23 74 0a 20 20 20 20 20 20 20 20 list #t.
d9a0: 20 20 20 20 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d load-sample-
d9b0: 74 69 6d 65 0a 20 20 20 20 20 20 20 20 20 20 20 time.
d9c0: 20 6c 6f 61 64 29 29 0a 20 20 20 20 20 28 28 61 load)). ((a
d9d0: 6e 64 20 68 6f 73 74 2d 72 65 63 0a 20 20 20 20 nd host-rec.
d9e0: 20 20 20 20 20 20 20 28 3c 20 28 63 75 72 72 65 (< (curre
d9f0: 6e 74 2d 73 65 63 6f 6e 64 73 29 20 28 2b 20 28 nt-seconds) (+ (
da00: 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 host-last-update
da10: 20 68 6f 73 74 2d 72 65 63 29 20 68 6f 73 74 2d host-rec) host-
da20: 6c 61 73 74 2d 75 70 64 61 74 65 2d 74 69 6d 65 last-update-time
da30: 6f 75 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 out-seconds))).
da40: 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a 20 20 (list #t.
da50: 20 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d (host-
da60: 6c 61 73 74 2d 75 70 64 61 74 65 20 68 6f 73 74 last-update host
da70: 2d 72 65 63 29 0a 20 20 20 20 20 20 20 20 20 20 -rec).
da80: 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 63 70 75 (host-last-cpu
da90: 6c 6f 61 64 20 68 6f 73 74 2d 72 65 63 20 29 29 load host-rec ))
daa0: 29 0a 20 20 20 20 20 28 28 63 6f 6d 6d 6f 6e 3a ). ((common:
dab0: 75 6e 69 78 2d 70 69 6e 67 20 68 6f 73 74 6e 61 unix-ping hostna
dac0: 6d 65 29 0a 20 20 20 20 20 20 28 6c 69 73 74 20 me). (list
dad0: 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 #t. (
dae0: 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 current-seconds)
daf0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 61 6c . (al
db00: 69 73 74 2d 72 65 66 20 27 61 64 6a 2d 63 6f 72 ist-ref 'adj-cor
db10: 65 2d 6c 6f 61 64 20 28 63 6f 6d 6d 6f 6e 3a 67 e-load (common:g
db20: 65 74 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 et-normalized-cp
db30: 75 2d 6c 6f 61 64 20 68 6f 73 74 6e 61 6d 65 29 u-load hostname)
db40: 29 29 29 0a 20 20 20 20 20 28 65 6c 73 65 0a 20 ))). (else.
db50: 20 20 20 20 20 28 6c 69 73 74 20 23 66 20 30 20 (list #f 0
db60: 2d 31 29 29 29 29 29 0a 20 20 20 20 0a 28 64 65 -1))))). .(de
db70: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 75 70 64 fine (common:upd
db80: 61 74 65 2d 68 6f 73 74 2d 6c 6f 61 64 73 2d 74 ate-host-loads-t
db90: 61 62 6c 65 20 68 6f 73 74 73 2d 72 61 77 29 0a able hosts-raw).
dba0: 20 20 28 6c 65 74 2a 20 28 28 68 6f 73 74 73 20 (let* ((hosts
dbb0: 28 66 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 (filter (lambda
dbc0: 28 78 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 (x).
dbd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
dbe0: 74 72 69 6e 67 2d 6d 61 74 63 68 20 28 72 65 67 tring-match (reg
dbf0: 65 78 70 20 22 5e 5c 5c 53 2b 24 22 29 20 78 29 exp "^\\S+$") x)
dc00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
dc10: 20 20 20 20 20 20 20 20 20 20 68 6f 73 74 73 2d hosts-
dc20: 72 61 77 29 29 29 0a 20 20 20 20 28 66 6f 72 2d raw))). (for-
dc30: 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
dc40: 61 20 28 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 a (hostname).
dc50: 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 63 20 (let* ((rec
dc60: 20 20 20 20 20 20 28 6c 65 74 20 28 28 68 20 28 (let ((h (
dc70: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
dc80: 65 66 61 75 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 efault *host-loa
dc90: 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 23 66 29 ds* hostname #f)
dca0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
dcb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
dcc0: 20 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h.
dcd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dce0: 20 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h.
dcf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd00: 20 28 6c 65 74 20 28 28 68 20 28 6d 61 6b 65 2d (let ((h (make-
dd10: 68 6f 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 host))).
dd20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd30: 20 20 20 20 20 20 20 20 28 68 61 73 68 2d 74 61 (hash-ta
dd40: 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 74 2d 6c ble-set! *host-l
dd50: 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 20 68 oads* hostname h
dd60: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
dd70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dd80: 20 20 68 29 29 29 29 0a 20 20 20 20 20 20 20 20 h)))).
dd90: 20 20 20 20 20 20 28 68 6f 73 74 2d 69 6e 66 6f (host-info
dda0: 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e (common
ddb0: 3a 67 65 74 2d 68 6f 73 74 2d 69 6e 66 6f 20 68 :get-host-info h
ddc0: 6f 73 74 6e 61 6d 65 29 29 0a 20 20 20 20 20 20 ostname)).
ddd0: 20 20 20 20 20 20 20 20 28 69 73 2d 72 65 61 63 (is-reac
dde0: 68 61 62 6c 65 20 20 20 20 20 20 28 63 61 72 20 hable (car
ddf0: 68 6f 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 host-info)).
de00: 20 20 20 20 20 20 20 20 20 20 28 6c 61 73 74 2d (last-
de10: 72 65 61 63 68 65 64 2d 74 69 6d 65 20 28 63 61 reached-time (ca
de20: 64 72 20 68 6f 73 74 2d 69 6e 66 6f 29 29 0a 20 dr host-info)).
de30: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f (lo
de40: 61 64 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ad
de50: 28 63 61 64 64 72 20 68 6f 73 74 2d 69 6e 66 6f (caddr host-info
de60: 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f ))). (ho
de70: 73 74 2d 72 65 61 63 68 61 62 6c 65 2d 73 65 74 st-reachable-set
de80: 21 20 20 20 20 72 65 63 20 69 73 2d 72 65 61 63 ! rec is-reac
de90: 68 61 62 6c 65 29 0a 20 20 20 20 20 20 20 20 20 hable).
dea0: 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 74 (host-last-updat
deb0: 65 2d 73 65 74 21 20 20 72 65 63 20 6c 61 73 74 e-set! rec last
dec0: 2d 72 65 61 63 68 65 64 2d 74 69 6d 65 29 0a 20 -reached-time).
ded0: 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 (host-la
dee0: 73 74 2d 63 70 75 6c 6f 61 64 2d 73 65 74 21 20 st-cpuload-set!
def0: 72 65 63 20 6c 6f 61 64 29 29 29 0a 20 20 20 20 rec load))).
df00: 20 68 6f 73 74 73 29 29 29 0a 0a 28 64 65 66 69 hosts)))..(defi
df10: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c ne (common:get-l
df20: 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 east-loaded-host
df30: 20 68 6f 73 74 73 2d 72 61 77 29 0a 20 20 28 6c hosts-raw). (l
df40: 65 74 2a 20 28 28 68 6f 73 74 73 20 28 66 69 6c et* ((hosts (fil
df50: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
df60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
df70: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
df80: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
df90: 22 5e 5c 5c 53 2b 24 22 29 20 78 29 29 0a 20 20 "^\\S+$") x)).
dfa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
dfb0: 20 20 20 20 20 20 68 6f 73 74 73 2d 72 61 77 29 hosts-raw)
dfc0: 29 0a 20 20 20 20 20 20 20 20 20 28 62 65 73 74 ). (best
dfd0: 2d 68 6f 73 74 20 23 66 29 0a 20 20 20 20 20 20 -host #f).
dfe0: 20 20 20 28 62 65 73 74 2d 6c 6f 61 64 20 39 39 (best-load 99
dff0: 39 39 39 29 0a 20 20 20 20 20 20 20 20 20 28 63 999). (c
e000: 75 72 72 2d 74 69 6d 65 20 28 63 75 72 72 65 6e urr-time (curren
e010: 74 2d 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 t-seconds))).
e020: 20 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d (common:update-
e030: 68 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 host-loads-table
e040: 20 68 6f 73 74 73 29 0a 20 20 20 20 28 66 6f 72 hosts). (for
e050: 2d 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 -each. (lamb
e060: 64 61 20 28 68 6f 73 74 6e 61 6d 65 29 0a 20 20 da (hostname).
e070: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 72 65 63 (let* ((rec
e080: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
e090: 28 6c 65 74 20 28 28 68 20 28 68 61 73 68 2d 74 (let ((h (hash-t
e0a0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
e0b0: 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f *host-loads* ho
e0c0: 73 74 6e 61 6d 65 20 23 66 29 29 29 0a 20 20 20 stname #f))).
e0d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 (i
e0e0: 66 20 68 0a 20 20 20 20 20 20 20 20 20 20 20 20 f h.
e0f0: 20 20 20 20 20 20 20 20 20 68 0a 20 20 20 20 20 h.
e100: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e110: 28 6c 65 74 20 28 28 68 20 28 6d 61 6b 65 2d 68 (let ((h (make-h
e120: 6f 73 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 ost))).
e130: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
e140: 61 73 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a ash-table-set! *
e150: 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 host-loads* host
e160: 6e 61 6d 65 20 68 29 0a 20 20 20 20 20 20 20 20 name h).
e170: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 h
e180: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
e190: 20 20 20 28 72 65 61 63 68 61 62 6c 65 20 28 68 (reachable (h
e1a0: 6f 73 74 2d 72 65 61 63 68 61 62 6c 65 20 72 65 ost-reachable re
e1b0: 63 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 c)).
e1c0: 20 20 28 6c 6f 61 64 20 20 20 20 20 20 28 68 6f (load (ho
e1d0: 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 64 20 st-last-cpuload
e1e0: 20 20 72 65 63 29 29 29 0a 20 20 20 20 20 20 20 rec))).
e1f0: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
e200: 20 20 28 28 6e 6f 74 20 72 65 61 63 68 61 62 6c ((not reachabl
e210: 65 29 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 e) #f).
e220: 20 28 28 3c 20 28 2b 20 6c 6f 61 64 20 28 2f 20 ((< (+ load (/
e230: 28 72 61 6e 64 6f 6d 20 32 35 30 29 20 31 30 30 (random 250) 100
e240: 30 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 61 0)) ;; a
e250: 64 64 20 61 20 72 61 6e 64 6f 6d 20 66 61 63 74 dd a random fact
e260: 6f 72 20 74 6f 20 6b 65 65 70 20 66 72 6f 6d 20 or to keep from
e270: 67 65 74 74 69 6e 67 20 69 6e 20 61 20 72 75 74 getting in a rut
e280: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
e290: 2b 20 62 65 73 74 2d 6c 6f 61 64 20 28 2f 20 28 + best-load (/ (
e2a0: 72 61 6e 64 6f 6d 20 32 35 30 29 20 31 30 30 30 random 250) 1000
e2b0: 29 29 20 20 29 0a 20 20 20 20 20 20 20 20 20 20 )) ).
e2c0: 20 28 73 65 74 21 20 62 65 73 74 2d 6c 6f 61 64 (set! best-load
e2d0: 20 6c 6f 61 64 29 0a 20 20 20 20 20 20 20 20 20 load).
e2e0: 20 20 28 73 65 74 21 20 62 65 73 74 2d 68 6f 73 (set! best-hos
e2f0: 74 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 29 0a t hostname))))).
e300: 20 20 20 20 20 68 6f 73 74 73 29 0a 20 20 20 20 hosts).
e310: 62 65 73 74 2d 68 6f 73 74 29 29 0a 0a 28 64 65 best-host))..(de
e320: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 fine (common:wai
e330: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
e340: 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 61 xload numcpus wa
e350: 69 74 64 65 6c 61 79 20 23 21 6b 65 79 20 28 63 itdelay #!key (c
e360: 6f 75 6e 74 20 31 30 30 30 29 20 28 6d 73 67 20 ount 1000) (msg
e370: 23 66 29 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 #f)(remote-host
e380: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6c #f)). (let* ((l
e390: 6f 61 64 61 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 oadavg (common:g
e3a0: 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 65 6d 6f et-cpu-load remo
e3b0: 74 65 2d 68 6f 73 74 29 29 0a 09 20 28 66 69 72 te-host)).. (fir
e3c0: 73 74 20 20 20 28 63 61 72 20 6c 6f 61 64 61 76 st (car loadav
e3d0: 67 29 29 0a 09 20 28 6e 65 78 74 20 20 20 20 28 g)).. (next (
e3e0: 63 61 64 72 20 6c 6f 61 64 61 76 67 29 29 0a 09 cadr loadavg))..
e3f0: 20 28 61 64 6a 6c 6f 61 64 20 28 2a 20 6d 61 78 (adjload (* max
e400: 6c 6f 61 64 20 6e 75 6d 63 70 75 73 29 29 0a 09 load numcpus))..
e410: 20 28 6c 6f 61 64 6a 6d 70 20 28 2d 20 66 69 72 (loadjmp (- fir
e420: 73 74 20 6e 65 78 74 29 29 29 0a 20 20 20 20 28 st next))). (
e430: 63 6f 6e 64 0a 20 20 20 20 20 28 28 61 6e 64 20 cond. ((and
e440: 28 3e 20 66 69 72 73 74 20 61 64 6a 6c 6f 61 64 (> first adjload
e450: 29 0a 09 20 20 20 28 3e 20 63 6f 75 6e 74 20 30 ).. (> count 0
e460: 29 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a )). (debug:
e470: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
e480: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
e490: 22 73 65 72 76 65 72 20 73 74 61 72 74 20 64 65 "server start de
e4a0: 6c 61 79 65 64 20 22 20 77 61 69 74 64 65 6c 61 layed " waitdela
e4b0: 79 20 22 20 73 65 63 6f 6e 64 73 20 64 75 65 20 y " seconds due
e4c0: 74 6f 20 6c 6f 61 64 20 22 20 66 69 72 73 74 20 to load " first
e4d0: 22 20 65 78 63 65 65 64 69 6e 67 20 6d 61 78 20 " exceeding max
e4e0: 6f 66 20 22 20 61 64 6a 6c 6f 61 64 20 22 20 6f of " adjload " o
e4f0: 6e 20 73 65 72 76 65 72 20 22 20 28 6f 72 20 72 n server " (or r
e500: 65 6d 6f 74 65 2d 68 6f 73 74 20 28 67 65 74 2d emote-host (get-
e510: 68 6f 73 74 2d 6e 61 6d 65 29 29 20 22 20 28 6e host-name)) " (n
e520: 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 2d 6c ormalized load-l
e530: 69 6d 69 74 3a 20 22 20 6d 61 78 6c 6f 61 64 20 imit: " maxload
e540: 22 29 20 22 20 28 69 66 20 6d 73 67 20 6d 73 67 ") " (if msg msg
e550: 20 22 22 29 29 0a 20 20 20 20 20 20 28 74 68 72 "")). (thr
e560: 65 61 64 2d 73 6c 65 65 70 21 20 77 61 69 74 64 ead-sleep! waitd
e570: 65 6c 61 79 29 0a 20 20 20 20 20 20 28 63 6f 6d elay). (com
e580: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 mon:wait-for-cpu
e590: 6c 6f 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d load maxload num
e5a0: 63 70 75 73 20 77 61 69 74 64 65 6c 61 79 20 63 cpus waitdelay c
e5b0: 6f 75 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 20 31 ount: (- count 1
e5c0: 29 20 6d 73 67 3a 20 6d 73 67 20 72 65 6d 6f 74 ) msg: msg remot
e5d0: 65 2d 68 6f 73 74 3a 20 72 65 6d 6f 74 65 2d 68 e-host: remote-h
e5e0: 6f 73 74 29 29 0a 20 20 20 20 20 28 28 61 6e 64 ost)). ((and
e5f0: 20 28 3e 20 6c 6f 61 64 6a 6d 70 20 6e 75 6d 63 (> loadjmp numc
e600: 70 75 73 29 0a 09 20 20 20 28 3e 20 63 6f 75 6e pus).. (> coun
e610: 74 20 30 29 29 0a 20 20 20 20 20 20 28 64 65 62 t 0)). (deb
e620: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
e630: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
e640: 74 2a 20 22 77 61 69 74 69 6e 67 20 22 20 77 61 t* "waiting " wa
e650: 69 74 64 65 6c 61 79 20 22 20 73 65 63 6f 6e 64 itdelay " second
e660: 73 20 64 75 65 20 74 6f 20 6c 6f 61 64 20 6a 75 s due to load ju
e670: 6d 70 20 22 20 6c 6f 61 64 6a 6d 70 20 22 20 3e mp " loadjmp " >
e680: 20 6e 75 6d 63 70 75 73 20 22 20 6e 75 6d 63 70 numcpus " numcp
e690: 75 73 20 28 69 66 20 6d 73 67 20 6d 73 67 20 22 us (if msg msg "
e6a0: 22 29 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 ")). (threa
e6b0: 64 2d 73 6c 65 65 70 21 20 77 61 69 74 64 65 6c d-sleep! waitdel
e6c0: 61 79 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f ay). (commo
e6d0: 6e 3a 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f n:wait-for-cpulo
e6e0: 61 64 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 ad maxload numcp
e6f0: 75 73 20 77 61 69 74 64 65 6c 61 79 20 63 6f 75 us waitdelay cou
e700: 6e 74 3a 20 28 2d 20 63 6f 75 6e 74 20 31 29 20 nt: (- count 1)
e710: 6d 73 67 3a 20 6d 73 67 20 72 65 6d 6f 74 65 2d msg: msg remote-
e720: 68 6f 73 74 3a 20 72 65 6d 6f 74 65 2d 68 6f 73 host: remote-hos
e730: 74 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 t)))))..(define
e740: 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 (common:wait-for
e750: 2d 68 6f 6d 65 68 6f 73 74 2d 6c 6f 61 64 20 6d -homehost-load m
e760: 61 78 6c 6f 61 64 20 6d 73 67 29 0a 20 20 28 6c axload msg). (l
e770: 65 74 2a 20 28 28 68 68 2d 64 61 74 20 28 69 66 et* ((hh-dat (if
e780: 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 (common:on-home
e790: 68 6f 73 74 3f 29 20 3b 3b 20 69 66 20 77 65 20 host?) ;; if we
e7a0: 61 72 65 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 are on the homeh
e7b0: 6f 73 74 20 74 68 65 6e 20 70 61 73 73 20 69 6e ost then pass in
e7c0: 20 23 66 20 73 6f 20 74 68 65 20 63 61 6c 6c 73 #f so the calls
e7d0: 20 61 72 65 20 6c 6f 63 61 6c 2e 0a 20 20 20 20 are local..
e7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e7f0: 20 23 66 0a 20 20 20 20 20 20 20 20 20 20 20 20 #f.
e800: 20 20 20 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e (common
e810: 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 29 29 29 :get-homehost)))
e820: 0a 20 20 20 20 20 20 20 20 20 28 68 68 20 20 20 . (hh
e830: 20 20 28 69 66 20 68 68 2d 64 61 74 20 28 63 61 (if hh-dat (ca
e840: 72 20 68 68 2d 64 61 74 29 20 23 66 29 29 0a 20 r hh-dat) #f)).
e850: 20 20 20 20 20 20 20 20 28 6e 75 6d 63 70 75 73 (numcpus
e860: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d (common:get-num
e870: 2d 63 70 75 73 20 68 68 29 29 29 0a 20 20 20 20 -cpus hh))).
e880: 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 (common:wait-for
e890: 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c 6f 61 64 -normalized-load
e8a0: 20 6d 61 78 6c 6f 61 64 20 6d 73 67 20 68 68 29 maxload msg hh)
e8b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
e8c0: 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 73 mon:get-num-cpus
e8d0: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 20 remote-host).
e8e0: 28 6c 65 74 20 28 28 70 72 6f 63 20 28 6c 61 6d (let ((proc (lam
e8f0: 62 64 61 20 28 29 0a 09 09 28 6c 65 74 20 6c 6f bda ()...(let lo
e900: 6f 70 20 28 28 6e 75 6d 63 70 75 20 30 29 0a 09 op ((numcpu 0)..
e910: 09 09 20 20 20 28 69 6e 6c 20 20 20 20 28 72 65 .. (inl (re
e920: 61 64 2d 6c 69 6e 65 29 29 29 0a 09 09 20 20 28 ad-line)))... (
e930: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
e940: 69 6e 6c 29 0a 09 09 20 20 20 20 20 20 6e 75 6d inl)... num
e950: 63 70 75 0a 09 09 20 20 20 20 20 20 28 6c 6f 6f cpu... (loo
e960: 70 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 p (if (string-ma
e970: 74 63 68 20 22 5e 70 72 6f 63 65 73 73 6f 72 5c tch "^processor\
e980: 5c 73 2b 3a 5c 5c 73 2b 5c 5c 64 2b 24 22 20 69 \s+:\\s+\\d+$" i
e990: 6e 6c 29 0a 09 09 09 09 28 2b 20 6e 75 6d 63 70 nl).....(+ numcp
e9a0: 75 20 31 29 0a 09 09 09 09 6e 75 6d 63 70 75 29 u 1).....numcpu)
e9b0: 0a 09 09 09 20 20 20 20 28 72 65 61 64 2d 6c 69 .... (read-li
e9c0: 6e 65 29 29 29 29 29 29 29 0a 20 20 20 20 28 69 ne))))))). (i
e9d0: 66 20 72 65 6d 6f 74 65 2d 68 6f 73 74 0a 09 28 f remote-host..(
e9e0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
e9f0: 70 69 70 65 20 0a 09 20 28 63 6f 6e 63 20 22 73 pipe .. (conc "s
ea00: 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 sh " remote-host
ea10: 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 63 70 75 " cat /proc/cpu
ea20: 69 6e 66 6f 22 29 0a 09 20 70 72 6f 63 29 0a 09 info").. proc)..
ea30: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
ea40: 2d 66 69 6c 65 20 22 2f 70 72 6f 63 2f 63 70 75 -file "/proc/cpu
ea50: 69 6e 66 6f 22 20 70 72 6f 63 29 29 29 29 0a 0a info" proc))))..
ea60: 3b 3b 20 77 61 69 74 20 66 6f 72 20 6e 6f 72 6d ;; wait for norm
ea70: 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f 61 64 20 alized cpu load
ea80: 74 6f 20 64 72 6f 70 20 62 65 6c 6f 77 20 6d 61 to drop below ma
ea90: 78 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 xload.;;.(define
eaa0: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
eab0: 72 2d 6e 6f 72 6d 61 6c 69 7a 65 64 2d 6c 6f 61 r-normalized-loa
eac0: 64 20 6d 61 78 6c 6f 61 64 20 6d 73 67 20 72 65 d maxload msg re
ead0: 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 20 28 6c 65 mote-host). (le
eae0: 74 20 28 28 6e 75 6d 2d 63 70 75 73 20 28 63 6f t ((num-cpus (co
eaf0: 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 mmon:get-num-cpu
eb00: 73 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 s remote-host)))
eb10: 0a 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 . (common:wai
eb20: 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d 61 t-for-cpuload ma
eb30: 78 6c 6f 61 64 20 6e 75 6d 2d 63 70 75 73 20 31 xload num-cpus 1
eb40: 35 20 6d 73 67 3a 20 6d 73 67 20 72 65 6d 6f 74 5 msg: msg remot
eb50: 65 2d 68 6f 73 74 3a 20 72 65 6d 6f 74 65 2d 68 e-host: remote-h
eb60: 6f 73 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ost)))..(define
eb70: 28 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 61 72 (get-uname . par
eb80: 61 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 ams). (let* ((u
eb90: 6e 61 6d 65 2d 72 65 73 20 28 70 72 6f 63 65 73 name-res (proces
eba0: 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 s:cmd-run->list
ebb0: 28 63 6f 6e 63 20 22 75 6e 61 6d 65 20 22 20 28 (conc "uname " (
ebc0: 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 if (null? params
ebd0: 29 20 22 2d 61 22 20 28 63 61 72 20 70 61 72 61 ) "-a" (car para
ebe0: 6d 73 29 29 29 29 29 0a 09 20 28 75 6e 61 6d 65 ms))))).. (uname
ebf0: 20 23 66 29 29 0a 20 20 20 20 28 69 66 20 28 6e #f)). (if (n
ec00: 75 6c 6c 3f 20 28 63 61 72 20 75 6e 61 6d 65 2d ull? (car uname-
ec10: 72 65 73 29 29 0a 09 22 75 6e 6b 6e 6f 77 6e 22 res)).."unknown"
ec20: 0a 09 28 63 61 61 72 20 75 6e 61 6d 65 2d 72 65 ..(caar uname-re
ec30: 73 29 29 29 29 0a 0a 3b 3b 20 66 6f 72 20 72 65 s))))..;; for re
ec40: 61 73 6f 6e 73 20 49 20 64 6f 6e 27 74 20 75 6e asons I don't un
ec50: 64 65 72 73 74 61 6e 64 20 6d 75 6c 74 69 70 6c derstand multipl
ec60: 65 20 63 61 6c 6c 73 20 74 6f 20 72 65 61 6c 2d e calls to real-
ec70: 70 61 74 68 20 69 6e 20 70 61 72 61 6c 6c 65 6c path in parallel
ec80: 20 74 68 72 65 61 64 73 0a 3b 3b 20 6d 75 73 74 threads.;; must
ec90: 20 62 65 20 70 72 6f 74 65 63 74 65 64 20 62 79 be protected by
eca0: 20 6d 75 74 65 78 65 73 0a 3b 3b 0a 28 64 65 66 mutexes.;;.(def
ecb0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c ine (common:real
ecc0: 2d 70 61 74 68 20 69 6e 70 61 74 68 29 0a 20 20 -path inpath).
ecd0: 3b 3b 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d ;; (process:cmd-
ece0: 72 75 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 2d run-with-stderr-
ecf0: 3e 6c 69 73 74 20 22 72 65 61 64 6c 69 6e 6b 22 >list "readlink"
ed00: 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 20 3b "-f" inpath)) ;
ed10: 3b 20 63 6d 64 20 2e 20 70 61 72 61 6d 73 29 0a ; cmd . params).
ed20: 20 20 3b 3b 20 28 6c 65 74 2d 76 61 6c 75 65 73 ;; (let-values
ed30: 20 0a 20 20 3b 3b 20 20 28 28 28 69 6e 70 20 6f . ;; (((inp o
ed40: 75 70 20 70 69 64 29 20 28 70 72 6f 63 65 73 73 up pid) (process
ed50: 20 22 72 65 61 64 6c 69 6e 6b 22 20 28 6c 69 73 "readlink" (lis
ed60: 74 20 22 2d 66 22 20 69 6e 70 61 74 68 29 29 29 t "-f" inpath)))
ed70: 29 0a 20 20 3b 3b 20 20 28 77 69 74 68 2d 69 6e ). ;; (with-in
ed80: 70 75 74 2d 66 72 6f 6d 2d 70 6f 72 74 20 69 6e put-from-port in
ed90: 70 0a 20 20 3b 3b 20 20 20 20 28 6c 65 74 20 6c p. ;; (let l
eda0: 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 2d oop ((inl (read-
edb0: 6c 69 6e 65 29 29 0a 20 20 3b 3b 20 20 20 20 20 line)). ;;
edc0: 20 20 09 28 72 65 73 20 23 66 29 29 0a 20 20 3b .(res #f)). ;
edd0: 3b 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 69 ; (print "i
ede0: 6e 6c 3d 22 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 nl=" inl). ;;
edf0: 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a (if (eof-obj
ee00: 65 63 74 3f 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 ect? inl). ;;
ee10: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
ee20: 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 28 ;; (
ee30: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
ee40: 20 69 6e 70 29 0a 20 20 3b 3b 20 20 20 20 20 20 inp). ;;
ee50: 20 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 (close-out
ee60: 70 75 74 2d 70 6f 72 74 20 6f 75 70 29 0a 20 20 put-port oup).
ee70: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b ;; ;;
ee80: 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 (process-wait p
ee90: 69 64 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 id). ;;
eea0: 20 20 20 20 72 65 73 29 0a 20 20 3b 3b 20 20 20 res). ;;
eeb0: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 (loop (re
eec0: 61 64 2d 6c 69 6e 65 29 20 69 6e 6c 29 29 29 29 ad-line) inl))))
eed0: 29 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 )). (with-input
eee0: 2d 66 72 6f 6d 2d 70 69 70 65 20 28 63 6f 6e 63 -from-pipe (conc
eef0: 20 22 72 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 "readlink -f "
ef00: 69 6e 70 61 74 68 29 20 72 65 61 64 2d 6c 69 6e inpath) read-lin
ef10: 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d e))..;;=========
ef20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ef30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ef40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ef50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
ef60: 20 44 20 49 20 53 20 4b 20 20 20 53 20 50 20 41 D I S K S P A
ef70: 20 43 20 45 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d C E .;;========
ef80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
ef90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
efa0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
efb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a ==============..
efc0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
efd0: 67 65 74 2d 64 69 73 6b 2d 73 70 61 63 65 2d 75 get-disk-space-u
efe0: 73 65 64 20 66 70 61 74 68 29 0a 20 20 28 77 69 sed fpath). (wi
eff0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
f000: 70 65 20 28 63 6f 6e 63 20 22 2f 75 73 72 2f 62 pe (conc "/usr/b
f010: 69 6e 2f 64 75 20 2d 73 20 22 20 66 70 61 74 68 in/du -s " fpath
f020: 29 20 72 65 61 64 29 29 0a 0a 3b 3b 20 67 69 76 ) read))..;; giv
f030: 65 6e 20 70 61 74 68 20 67 65 74 20 66 72 65 65 en path get free
f040: 20 73 70 61 63 65 2c 20 61 6c 6c 6f 77 73 20 6f space, allows o
f050: 76 65 72 72 69 64 65 20 69 6e 20 5b 73 65 74 75 verride in [setu
f060: 70 5d 0a 3b 3b 20 77 69 74 68 20 66 72 65 65 2d p].;; with free-
f070: 73 70 61 63 65 2d 73 63 72 69 70 74 20 2f 70 61 space-script /pa
f080: 74 68 2f 74 6f 2f 73 6f 6d 65 2f 73 63 72 69 70 th/to/some/scrip
f090: 74 2e 73 68 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 t.sh.;;.(define
f0a0: 28 67 65 74 2d 64 66 20 70 61 74 68 29 0a 20 20 (get-df path).
f0b0: 28 69 66 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (if (configf:loo
f0c0: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
f0d0: 22 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 70 "setup" "free-sp
f0e0: 61 63 65 2d 73 63 72 69 70 74 22 29 0a 20 20 20 ace-script").
f0f0: 20 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 (with-input-f
f100: 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 20 20 20 rom-pipe .
f110: 20 28 63 6f 6e 63 20 28 63 6f 6e 66 69 67 66 3a (conc (configf:
f120: 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 lookup *configda
f130: 74 2a 20 22 73 65 74 75 70 22 20 22 66 72 65 65 t* "setup" "free
f140: 2d 73 70 61 63 65 2d 73 63 72 69 70 74 22 29 20 -space-script")
f150: 22 20 22 20 70 61 74 68 29 0a 20 20 20 20 20 20 " " path).
f160: 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 28 6c (lambda ().. (l
f170: 65 74 20 28 28 72 65 73 20 28 72 65 61 64 2d 6c et ((res (read-l
f180: 69 6e 65 29 29 29 0a 09 20 20 20 28 69 66 20 28 ine))).. (if (
f190: 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 20 20 string? res)..
f1a0: 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 (string->nu
f1b0: 6d 62 65 72 20 72 65 73 29 29 29 29 29 0a 20 20 mber res))))).
f1c0: 20 20 20 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 (get-unix-df
f1d0: 20 70 61 74 68 29 29 29 0a 0a 28 64 65 66 69 6e path)))..(defin
f1e0: 65 20 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 70 e (get-unix-df p
f1f0: 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 ath). (let* ((d
f200: 66 2d 72 65 73 75 6c 74 73 20 28 70 72 6f 63 65 f-results (proce
f210: 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 ss:cmd-run->list
f220: 20 28 63 6f 6e 63 20 22 64 66 20 22 20 70 61 74 (conc "df " pat
f230: 68 29 29 29 0a 09 20 28 73 70 61 63 65 2d 72 78 h))).. (space-rx
f240: 20 20 20 28 72 65 67 65 78 70 20 22 28 5b 30 2d (regexp "([0-
f250: 39 5d 2b 29 5c 5c 73 2b 28 5b 30 2d 39 5d 2b 29 9]+)\\s+([0-9]+)
f260: 25 22 29 29 0a 09 20 28 66 72 65 65 73 70 63 20 %")).. (freespc
f270: 20 20 20 23 66 29 29 0a 20 20 20 20 3b 3b 20 28 #f)). ;; (
f280: 77 72 69 74 65 20 64 66 2d 72 65 73 75 6c 74 73 write df-results
f290: 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 ). (for-each
f2a0: 28 6c 61 6d 62 64 61 20 28 6c 29 0a 09 09 28 6c (lambda (l)...(l
f2b0: 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 69 et ((match (stri
f2c0: 6e 67 2d 73 65 61 72 63 68 20 73 70 61 63 65 2d ng-search space-
f2d0: 72 78 20 6c 29 29 29 0a 09 09 20 20 28 69 66 20 rx l)))... (if
f2e0: 6d 61 74 63 68 20 0a 09 09 20 20 20 20 20 20 28 match ... (
f2f0: 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 73 74 let ((newval (st
f300: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 63 61 ring->number (ca
f310: 64 72 20 6d 61 74 63 68 29 29 29 29 0a 09 09 09 dr match))))....
f320: 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e 65 77 (if (number? new
f330: 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 65 74 val).... (set
f340: 21 20 66 72 65 65 73 70 63 20 6e 65 77 76 61 6c ! freespc newval
f350: 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 28 63 )))))).. (c
f360: 61 72 20 64 66 2d 72 65 73 75 6c 74 73 29 29 0a ar df-results)).
f370: 20 20 20 20 66 72 65 65 73 70 63 29 29 0a 0a 28 freespc))..(
f380: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 define (common:c
f390: 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 heck-space-in-di
f3a0: 72 20 64 69 72 70 61 74 68 20 72 65 71 75 69 72 r dirpath requir
f3b0: 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 62 ed). (let* ((db
f3c0: 73 70 61 63 65 20 20 28 69 66 20 28 64 69 72 65 space (if (dire
f3d0: 63 74 6f 72 79 3f 20 64 69 72 70 61 74 68 29 0a ctory? dirpath).
f3e0: 09 09 20 20 20 20 20 20 20 28 67 65 74 2d 64 66 .. (get-df
f3f0: 20 64 69 72 70 61 74 68 29 0a 09 09 20 20 20 20 dirpath)...
f400: 20 20 20 30 29 29 29 0a 20 20 20 20 28 6c 69 73 0))). (lis
f410: 74 20 28 3e 20 64 62 73 70 61 63 65 20 72 65 71 t (> dbspace req
f420: 75 69 72 65 64 29 0a 09 20 20 64 62 73 70 61 63 uired).. dbspac
f430: 65 0a 09 20 20 72 65 71 75 69 72 65 64 0a 09 20 e.. required..
f440: 20 64 69 72 70 61 74 68 29 29 29 0a 0a 3b 3b 20 dirpath)))..;;
f450: 63 68 65 63 6b 20 73 70 61 63 65 20 69 6e 20 64 check space in d
f460: 62 64 69 72 20 61 6e 64 20 69 6e 20 6d 65 67 61 bdir and in mega
f470: 74 65 73 74 20 64 69 72 0a 3b 3b 20 72 65 74 75 test dir.;; retu
f480: 72 6e 73 3a 20 6f 6b 2f 6e 6f 74 20 64 62 73 70 rns: ok/not dbsp
f490: 61 63 65 20 72 65 71 75 69 72 65 64 2d 73 70 61 ace required-spa
f4a0: 63 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ce.;;.(define (c
f4b0: 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 ommon:check-db-d
f4c0: 69 72 2d 73 70 61 63 65 29 0a 20 20 28 6c 65 74 ir-space). (let
f4d0: 2a 20 28 28 72 65 71 75 69 72 65 64 20 28 73 74 * ((required (st
f4e0: 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a 09 09 ring->number ...
f4f0: 20 20 20 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 (or (configf
f500: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
f510: 61 74 2a 20 22 73 65 74 75 70 22 20 22 64 62 64 at* "setup" "dbd
f520: 69 72 2d 73 70 61 63 65 2d 72 65 71 75 69 72 65 ir-space-require
f530: 64 22 29 0a 09 09 09 22 31 30 30 30 30 30 22 29 d")...."100000")
f540: 29 29 0a 09 20 28 64 62 64 69 72 20 20 20 20 28 )).. (dbdir (
f550: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d common:get-db-tm
f560: 70 2d 61 72 65 61 29 29 20 3b 3b 20 28 64 62 3a p-area)) ;; (db:
f570: 67 65 74 2d 64 62 64 69 72 29 29 0a 09 20 28 74 get-dbdir)).. (t
f580: 64 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a dbspace (common:
f590: 63 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 check-space-in-d
f5a0: 69 72 20 64 62 64 69 72 20 72 65 71 75 69 72 65 ir dbdir require
f5b0: 64 29 29 0a 09 20 28 6d 64 62 73 70 61 63 65 20 d)).. (mdbspace
f5c0: 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 (common:check-sp
f5d0: 61 63 65 2d 69 6e 2d 64 69 72 20 2a 74 6f 70 70 ace-in-dir *topp
f5e0: 61 74 68 2a 20 72 65 71 75 69 72 65 64 29 29 29 ath* required)))
f5f0: 0a 20 20 20 20 28 73 6f 72 74 20 28 6c 69 73 74 . (sort (list
f600: 20 74 64 62 73 70 61 63 65 20 6d 64 62 73 70 61 tdbspace mdbspa
f610: 63 65 29 20 28 6c 61 6d 62 64 61 20 28 61 20 62 ce) (lambda (a b
f620: 29 0a 09 09 09 09 20 20 20 20 20 28 3c 20 28 63 )..... (< (c
f630: 61 64 72 20 61 29 28 63 61 64 72 20 62 29 29 29 adr a)(cadr b)))
f640: 29 29 29 0a 20 20 20 20 0a 3b 3b 20 63 68 65 63 ))). .;; chec
f650: 6b 20 61 76 61 69 6c 61 62 6c 65 20 73 70 61 63 k available spac
f660: 65 20 69 6e 20 64 62 64 69 72 2c 20 65 78 69 74 e in dbdir, exit
f670: 20 69 66 20 69 6e 73 75 66 66 69 63 69 65 6e 74 if insufficient
f680: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
f690: 6d 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 mon:check-db-dir
f6a0: 2d 61 6e 64 2d 65 78 69 74 2d 69 66 2d 69 6e 73 -and-exit-if-ins
f6b0: 75 66 66 69 63 69 65 6e 74 29 0a 20 20 28 6c 65 ufficient). (le
f6c0: 74 2a 20 28 28 73 70 61 63 65 64 61 74 20 28 63 t* ((spacedat (c
f6d0: 61 72 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b ar (common:check
f6e0: 2d 64 62 2d 64 69 72 2d 73 70 61 63 65 29 29 29 -db-dir-space)))
f6f0: 20 3b 3b 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 ;; look only at
f700: 20 77 6f 72 73 74 20 66 6f 72 20 6e 6f 77 0a 09 worst for now..
f710: 20 28 69 73 2d 6f 6b 20 20 20 20 28 63 61 72 20 (is-ok (car
f720: 73 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 62 spacedat)).. (db
f730: 73 70 61 63 65 20 20 28 63 61 64 72 20 73 70 61 space (cadr spa
f740: 63 65 64 61 74 29 29 0a 09 20 28 72 65 71 75 69 cedat)).. (requi
f750: 72 65 64 20 28 63 61 64 64 72 20 73 70 61 63 65 red (caddr space
f760: 64 61 74 29 29 0a 09 20 28 64 62 64 69 72 20 20 dat)).. (dbdir
f770: 20 20 28 63 61 64 64 64 72 20 73 70 61 63 65 64 (cadddr spaced
f780: 61 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e at))). (if (n
f790: 6f 74 20 69 73 2d 6f 6b 29 0a 09 28 62 65 67 69 ot is-ok)..(begi
f7a0: 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e n.. (debug:prin
f7b0: 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 t-error 0 *defau
f7c0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e lt-log-port* "In
f7d0: 73 75 66 66 69 63 69 65 6e 74 20 73 70 61 63 65 sufficient space
f7e0: 20 69 6e 20 22 20 64 62 64 69 72 20 22 2c 20 72 in " dbdir ", r
f7f0: 65 71 75 69 72 65 20 22 20 72 65 71 75 69 72 65 equire " require
f800: 64 20 22 2c 20 68 61 76 65 20 22 20 64 62 73 70 d ", have " dbsp
f810: 61 63 65 20 20 22 2c 20 65 78 69 74 69 6e 67 20 ace ", exiting
f820: 6e 6f 77 2e 22 29 0a 09 20 20 28 65 78 69 74 20 now.").. (exit
f830: 31 29 29 29 29 29 0a 20 20 0a 3b 3b 20 70 61 74 1))))). .;; pat
f840: 68 73 20 69 73 20 6c 69 73 74 20 6f 66 20 6c 69 hs is list of li
f850: 73 74 73 20 28 28 6e 61 6d 65 20 70 61 74 68 29 sts ((name path)
f860: 20 2e 2e 2e 20 29 0a 3b 3b 0a 28 64 65 66 69 6e ... ).;;.(defin
f870: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 e (common:get-di
f880: 73 6b 2d 77 69 74 68 2d 6d 6f 73 74 2d 66 72 65 sk-with-most-fre
f890: 65 2d 73 70 61 63 65 20 64 69 73 6b 73 20 6d 69 e-space disks mi
f8a0: 6e 73 69 7a 65 29 0a 20 20 28 6c 65 74 20 28 28 nsize). (let ((
f8b0: 62 65 73 74 20 20 20 20 20 23 66 29 0a 09 28 62 best #f)..(b
f8c0: 65 73 74 73 69 7a 65 20 30 29 29 0a 20 20 20 20 estsize 0)).
f8d0: 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
f8e0: 28 6c 61 6d 62 64 61 20 28 64 69 73 6b 2d 6e 75 (lambda (disk-nu
f8f0: 6d 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 m). (let*
f900: 28 28 64 69 72 70 61 74 68 20 20 20 20 28 63 61 ((dirpath (ca
f910: 64 72 20 28 61 73 73 6f 63 20 64 69 73 6b 2d 6e dr (assoc disk-n
f920: 75 6d 20 64 69 73 6b 73 29 29 29 0a 09 20 20 20 um disks)))..
f930: 20 20 20 28 66 72 65 65 73 70 63 20 20 20 20 28 (freespc (
f940: 63 6f 6e 64 0a 09 09 09 20 20 20 28 28 6e 6f 74 cond.... ((not
f950: 20 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 72 (directory? dir
f960: 70 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 path)).... (i
f970: 66 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f f (common:low-no
f980: 69 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 ise-print 300 "d
f990: 69 73 6b 73 20 6e 6f 74 20 61 20 64 69 72 20 22 isks not a dir "
f9a0: 20 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 disk-num).....(
f9b0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
f9c0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
f9d0: 20 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 "WARNING: disk
f9e0: 22 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 " disk-num " at
f9f0: 70 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 path \"" dirpath
fa00: 20 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 64 69 "\" is not a di
fa10: 72 65 63 74 6f 72 79 20 2d 20 69 67 6e 6f 72 69 rectory - ignori
fa20: 6e 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 ng it."))....
fa30: 20 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 -1).... ((not
fa40: 20 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 (file-write-acc
fa50: 65 73 73 3f 20 64 69 72 70 61 74 68 29 29 0a 09 ess? dirpath))..
fa60: 09 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f .. (if (commo
fa70: 6e 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e n:low-noise-prin
fa80: 74 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 t 300 "disks not
fa90: 20 77 72 69 74 65 61 62 6c 65 20 22 20 64 69 73 writeable " dis
faa0: 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 75 k-num).....(debu
fab0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
fac0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
fad0: 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 RNING: disk " di
fae0: 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 68 sk-num " at path
faf0: 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c 22 \"" dirpath "\"
fb00: 20 69 73 20 6e 6f 74 20 77 72 69 74 65 61 62 6c is not writeabl
fb10: 65 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e e - ignoring it.
fb20: 22 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 ")).... -1)..
fb30: 09 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 .. ((not (eq?
fb40: 28 73 74 72 69 6e 67 2d 72 65 66 20 64 69 72 70 (string-ref dirp
fb50: 61 74 68 20 30 29 20 23 5c 2f 29 29 0a 09 09 09 ath 0) #\/))....
fb60: 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a (if (common:
fb70: 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 low-noise-print
fb80: 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 61 300 "disks not a
fb90: 20 70 72 6f 70 65 72 20 70 61 74 68 20 22 20 64 proper path " d
fba0: 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 isk-num).....(de
fbb0: 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 bug:print 0 *def
fbc0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
fbd0: 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 WARNING: disk "
fbe0: 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 disk-num " at pa
fbf0: 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 th \"" dirpath "
fc00: 5c 22 20 69 73 20 6e 6f 74 20 61 20 66 75 6c 6c \" is not a full
fc10: 79 20 71 75 61 6c 69 66 69 65 64 20 70 61 74 68 y qualified path
fc20: 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 - ignoring it."
fc30: 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 )).... -1)...
fc40: 09 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 . (else....
fc50: 20 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 (get-df dirpath
fc60: 29 29 29 29 29 0a 09 20 28 69 66 20 28 3e 20 66 ))))).. (if (> f
fc70: 72 65 65 73 70 63 20 62 65 73 74 73 69 7a 65 29 reespc bestsize)
fc80: 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 .. (begin..
fc90: 20 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 (set! best
fca0: 20 20 20 20 20 28 63 6f 6e 73 20 64 69 73 6b 2d (cons disk-
fcb0: 6e 75 6d 20 64 69 72 70 61 74 68 29 29 0a 09 20 num dirpath))..
fcc0: 20 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 (set! best
fcd0: 73 69 7a 65 20 66 72 65 65 73 70 63 29 29 29 29 size freespc))))
fce0: 29 0a 20 20 20 20 20 28 6d 61 70 20 63 61 72 20 ). (map car
fcf0: 64 69 73 6b 73 29 29 0a 20 20 20 20 28 69 66 20 disks)). (if
fd00: 28 61 6e 64 20 62 65 73 74 20 28 3e 20 62 65 73 (and best (> bes
fd10: 74 73 69 7a 65 20 6d 69 6e 73 69 7a 65 29 29 0a tsize minsize)).
fd20: 09 62 65 73 74 0a 09 23 66 29 29 29 20 3b 3b 20 .best..#f))) ;;
fd30: 23 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 73 6b #f means no disk
fd40: 20 63 61 6e 64 69 64 61 74 65 20 66 6f 75 6e 64 candidate found
fd50: 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
fd60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd70: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd80: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fd90: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 ==========.;; E
fda0: 4e 20 56 20 49 20 52 20 4f 20 4e 20 4d 20 45 20 N V I R O N M E
fdb0: 4e 20 54 20 20 20 56 20 41 20 52 20 53 0a 3b 3b N T V A R S.;;
fdc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fdd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fde0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fdf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
fe00: 3d 3d 3d 3d 3d 3d 0a 28 64 65 66 69 6e 65 20 28 ======.(define (
fe10: 62 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 23 21 bb-check-path #!
fe20: 6b 65 79 20 28 6d 73 67 20 22 63 68 65 63 6b 2d key (msg "check-
fe30: 70 61 74 68 3a 20 22 29 29 0a 20 20 28 6c 65 74 path: ")). (let
fe40: 20 28 28 70 61 74 68 20 28 6f 72 20 28 67 65 74 ((path (or (get
fe50: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
fe60: 69 61 62 6c 65 20 22 50 41 54 48 22 29 20 22 6e iable "PATH") "n
fe70: 6f 6e 65 22 29 29 29 0a 20 20 20 20 28 64 65 62 one"))). (deb
fe80: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
fe90: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
fea0: 74 2a 20 28 63 6f 6e 63 20 6d 73 67 22 20 3a 20 t* (conc msg" :
feb0: 24 50 41 54 48 3d 22 70 61 74 68 29 29 0a 20 20 $PATH="path)).
fec0: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
fed0: 74 63 68 20 22 5e 2e 2a 2f 69 73 6f 65 6e 76 2d tch "^.*/isoenv-
fee0: 63 6f 72 65 2f 2e 2a 22 20 70 61 74 68 29 0a 20 core/.*" path).
fef0: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
ff00: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
ff10: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 ault-log-port* (
ff20: 63 6f 6e 63 20 6d 73 67 22 20 3a 20 21 21 49 53 conc msg" : !!IS
ff30: 4f 45 4e 56 20 50 52 45 53 45 4e 54 21 21 22 29 OENV PRESENT!!")
ff40: 29 20 3b 3b 20 72 65 6d 6f 76 65 20 66 6f 72 20 ) ;; remove for
ff50: 70 72 6f 64 0a 20 20 20 20 20 20 20 20 28 64 65 prod. (de
ff60: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
ff70: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
ff80: 72 74 2a 20 28 63 6f 6e 63 20 6d 73 67 22 20 3a rt* (conc msg" :
ff90: 20 2a 2a 6e 6f 20 69 73 6f 65 6e 76 20 70 72 65 **no isoenv pre
ffa0: 73 65 6e 74 2a 2a 22 29 29 29 29 29 0a 0a 09 20 sent**")))))...
ffb0: 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 73 .(define (s
ffc0: 61 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d ave-environment-
ffd0: 61 73 2d 66 69 6c 65 73 20 66 6e 61 6d 65 20 23 as-files fname #
ffe0: 21 6b 65 79 20 28 69 67 6e 6f 72 65 76 61 72 73 !key (ignorevars
fff0: 20 28 6c 69 73 74 20 22 55 53 45 52 22 20 22 48 (list "USER" "H
10000 4f 4d 45 22 20 22 44 49 53 50 4c 41 59 22 20 22 OME" "DISPLAY" "
10010 4c 53 5f 43 4f 4c 4f 52 53 22 20 22 58 4b 45 59 LS_COLORS" "XKEY
10020 53 59 4d 44 42 22 20 22 45 44 49 54 4f 52 22 20 SYMDB" "EDITOR"
10030 22 4d 41 4b 45 46 4c 41 47 53 22 20 22 4d 41 4b "MAKEFLAGS" "MAK
10040 45 46 22 20 22 4d 41 4b 45 4f 56 45 52 52 49 44 EF" "MAKEOVERRID
10050 45 53 22 29 29 29 0a 20 20 3b 3b 28 62 62 2d 63 ES"))). ;;(bb-c
10060 68 65 63 6b 2d 70 61 74 68 20 6d 73 67 3a 20 22 heck-path msg: "
10070 73 61 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 save-environment
10080 2d 61 73 2d 66 69 6c 65 73 20 65 6e 74 72 79 22 -as-files entry"
10090 29 0a 20 20 28 6c 65 74 20 28 28 65 6e 76 76 61 ). (let ((envva
100a0 72 73 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d rs (get-environm
100b0 65 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a ent-variables)).
100c0 20 20 20 20 20 20 20 20 28 77 68 69 74 65 73 70 (whitesp
100d0 20 28 72 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 (regexp "[^a-zA
100e0 2d 5a 30 2d 39 5f 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 -Z0-9_\\-:,.\\/%
100f0 24 5d 22 29 29 0a 09 28 6d 75 6e 67 65 76 61 6c $]"))..(mungeval
10100 20 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 09 (lambda (val)..
10110 09 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 . (cond...
10120 20 20 28 28 65 71 3f 20 76 61 6c 20 23 74 29 20 ((eq? val #t)
10130 22 22 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 "") ;; convert #
10140 74 20 74 6f 20 65 6d 70 74 79 20 73 74 72 69 6e t to empty strin
10150 67 0a 09 09 20 20 20 20 20 28 28 65 71 3f 20 76 g... ((eq? v
10160 61 6c 20 23 66 29 20 23 66 29 20 3b 3b 20 63 6f al #f) #f) ;; co
10170 6e 76 65 72 74 20 23 66 20 74 6f 20 69 74 73 65 nvert #f to itse
10180 6c 66 20 28 73 74 69 6c 6c 20 74 68 69 6e 6b 69 lf (still thinki
10190 6e 67 20 61 62 6f 75 74 20 74 68 69 73 20 6f 6e ng about this on
101a0 65 0a 09 09 20 20 20 20 20 28 65 6c 73 65 20 76 e... (else v
101b0 61 6c 29 29 29 29 29 0a 20 20 20 20 28 77 69 74 al))))). (wit
101c0 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 h-output-to-file
101d0 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 (conc fname ".c
101e0 73 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d sh"). (lam
101f0 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 bda ().
10200 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 (for-each (lamb
10210 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 da (keyval)...
10220 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 (let* ((key
10230 20 20 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a (car keyval)).
10240 09 09 09 20 20 20 20 20 28 76 61 6c 20 20 20 28 ... (val (
10250 63 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 cdr keyval))....
10260 20 20 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 (delim (if
10270 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 (string-search w
10280 68 69 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 hitesp val) ....
10290 09 09 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 .."\""......""))
102a0 29 0a 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 )....(print (if
102b0 28 6f 72 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 (or (member key
102c0 69 67 6e 6f 72 65 76 61 72 73 29 0a 09 09 09 09 ignorevars).....
102d0 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 (string-s
102e0 65 61 72 63 68 20 77 68 69 74 65 73 70 20 6b 65 earch whitesp ke
102f0 79 29 29 0a 09 09 09 09 20 20 20 22 23 20 73 65 y))..... "# se
10300 74 65 6e 76 20 22 0a 09 09 09 09 20 20 20 22 73 tenv "..... "s
10310 65 74 65 6e 76 20 22 29 0a 09 09 09 20 20 20 20 etenv ")....
10320 20 20 20 6b 65 79 20 22 20 22 20 64 65 6c 69 6d key " " delim
10330 20 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 (mungeval val)
10340 64 65 6c 69 6d 29 29 29 0a 09 09 20 20 20 20 65 delim)))... e
10350 6e 76 76 61 72 73 29 29 29 0a 20 20 20 20 20 28 nvvars))). (
10360 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 with-output-to-f
10370 69 6c 65 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 ile (conc fname
10380 22 2e 73 68 22 29 0a 20 20 20 20 20 20 20 28 6c ".sh"). (l
10390 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 ambda ().
103a0 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
103b0 6d 62 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 mbda (keyval)...
103c0 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 (let* ((ke
103d0 79 20 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a y (car keyval)).
103e0 09 09 09 20 20 20 20 20 28 76 61 6c 20 28 63 64 ... (val (cd
103f0 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 r keyval))....
10400 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 28 73 (delim (if (s
10410 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 tring-search whi
10420 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 09 09 tesp val) ......
10430 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 29 0a "\""......""))).
10440 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 28 6f ...(print (if (o
10450 72 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 r (member key ig
10460 6e 6f 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 norevars).....
10470 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 61 (string-sea
10480 72 63 68 20 77 68 69 74 65 73 70 20 6b 65 79 29 rch whitesp key)
10490 0a 09 09 09 09 20 20 20 20 20 20 20 28 73 74 72 ..... (str
104a0 69 6e 67 2d 73 65 61 72 63 68 20 22 3a 22 20 6b ing-search ":" k
104b0 65 79 29 29 20 3b 3b 20 69 6e 74 65 72 6e 61 6c ey)) ;; internal
104c0 20 6f 6e 6c 79 20 76 61 6c 75 65 73 20 74 6f 20 only values to
104d0 62 65 20 73 6b 69 70 70 65 64 2e 0a 09 09 09 09 be skipped......
104e0 20 20 20 22 23 20 65 78 70 6f 72 74 20 22 0a 09 "# export "..
104f0 09 09 09 20 20 20 22 65 78 70 6f 72 74 20 22 29 ... "export ")
10500 0a 09 09 09 20 20 20 20 20 20 20 6b 65 79 20 22 .... key "
10510 3d 22 20 64 65 6c 69 6d 20 28 6d 75 6e 67 65 76 =" delim (mungev
10520 61 6c 20 76 61 6c 29 20 64 65 6c 69 6d 29 29 29 al val) delim)))
10530 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
10540 20 20 20 20 20 65 6e 76 76 61 72 73 29 29 29 29 envvars))))
10550 29 0a 0a 3b 3b 20 73 65 74 20 73 6f 6d 65 20 65 )..;; set some e
10560 6e 76 20 76 61 72 73 20 66 72 6f 6d 20 61 6e 20 nv vars from an
10570 61 6c 69 73 74 2c 20 72 65 74 75 72 6e 20 61 6e alist, return an
10580 20 61 6c 69 73 74 20 77 69 74 68 20 6f 72 69 67 alist with orig
10590 69 6e 61 6c 20 76 61 6c 75 65 73 0a 3b 3b 20 28 inal values.;; (
105a0 28 22 56 41 52 22 20 22 76 61 6c 75 65 22 29 20 ("VAR" "value")
105b0 2e 2e 2e 29 0a 28 64 65 66 69 6e 65 20 28 61 6c ...).(define (al
105c0 69 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 6c 73 ist->env-vars ls
105d0 74 29 0a 20 20 28 69 66 20 28 6c 69 73 74 3f 20 t). (if (list?
105e0 6c 73 74 29 0a 20 20 20 20 20 20 28 6c 65 74 20 lst). (let
105f0 28 28 72 65 73 20 27 28 29 29 29 0a 09 28 66 6f ((res '()))..(fo
10600 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
10610 70 29 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 p)... (let* (
10620 28 76 61 72 20 28 63 61 72 20 20 70 29 29 0a 09 (var (car p))..
10630 09 09 20 20 20 28 76 61 6c 20 28 63 61 64 72 20 .. (val (cadr
10640 70 29 29 0a 09 09 09 20 20 20 28 70 72 76 20 28 p)).... (prv (
10650 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
10660 76 61 72 69 61 62 6c 65 20 76 61 72 29 29 29 0a variable var))).
10670 09 09 20 20 20 20 20 20 28 73 65 74 21 20 72 65 .. (set! re
10680 73 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 76 61 s (cons (list va
10690 72 20 70 72 76 29 20 72 65 73 29 29 0a 09 09 20 r prv) res))...
106a0 20 20 20 20 20 28 69 66 20 76 61 6c 20 0a 09 09 (if val ...
106b0 09 20 20 28 73 61 66 65 2d 73 65 74 65 6e 76 20 . (safe-setenv
106c0 76 61 72 20 28 2d 3e 73 74 72 69 6e 67 20 76 61 var (->string va
106d0 6c 29 29 0a 09 09 09 20 20 28 75 6e 73 65 74 65 l)).... (unsete
106e0 6e 76 20 76 61 72 29 29 29 29 0a 09 09 20 20 6c nv var))))... l
106f0 73 74 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 st)..res).
10700 27 28 29 29 29 0a 0a 3b 3b 20 63 6c 65 61 72 20 '()))..;; clear
10710 76 61 72 73 20 6d 61 74 63 68 69 6e 67 20 70 61 vars matching pa
10720 74 74 65 72 6e 2c 20 72 75 6e 20 70 72 6f 63 2c ttern, run proc,
10730 20 73 65 74 20 76 61 72 73 20 62 61 63 6b 0a 3b set vars back.;
10740 3b 20 69 66 20 70 72 6f 63 20 69 73 20 61 20 73 ; if proc is a s
10750 74 72 69 6e 67 20 72 75 6e 20 74 68 61 74 20 73 tring run that s
10760 74 72 69 6e 67 20 61 73 20 61 20 63 6f 6d 6d 61 tring as a comma
10770 6e 64 20 77 69 74 68 0a 3b 3b 20 73 79 73 74 65 nd with.;; syste
10780 6d 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 m..;;.(define (c
10790 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 ommon:without-va
107a0 72 73 20 70 72 6f 63 20 2e 20 76 61 72 2d 70 61 rs proc . var-pa
107b0 74 74 73 29 0a 20 20 28 6c 65 74 20 28 28 76 61 tts). (let ((va
107c0 72 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 rs (make-hash-ta
107d0 62 6c 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d ble))). (for-
107e0 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
107f0 61 20 28 76 61 72 64 61 74 29 20 3b 3b 20 65 61 a (vardat) ;; ea
10800 63 68 20 65 6e 76 20 76 61 72 0a 20 20 20 20 20 ch env var.
10810 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 (for-each..(la
10820 6d 62 64 61 20 28 76 61 72 2d 70 61 74 74 29 0a mbda (var-patt).
10830 09 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d . (if (string-m
10840 61 74 63 68 20 76 61 72 2d 70 61 74 74 20 28 63 atch var-patt (c
10850 61 72 20 76 61 72 64 61 74 29 29 0a 09 20 20 20 ar vardat))..
10860 20 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 (let ((var (c
10870 61 72 20 76 61 72 64 61 74 29 29 0a 09 09 20 20 ar vardat))...
10880 20 20 28 76 61 6c 20 28 63 64 72 20 76 61 72 64 (val (cdr vard
10890 61 74 29 29 29 0a 09 09 28 68 61 73 68 2d 74 61 at)))...(hash-ta
108a0 62 6c 65 2d 73 65 74 21 20 76 61 72 73 20 76 61 ble-set! vars va
108b0 72 20 76 61 6c 29 0a 09 09 28 75 6e 73 65 74 65 r val)...(unsete
108c0 6e 76 20 76 61 72 29 29 29 29 0a 09 76 61 72 2d nv var))))..var-
108d0 70 61 74 74 73 29 29 0a 20 20 20 20 20 28 67 65 patts)). (ge
108e0 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 t-environment-va
108f0 72 69 61 62 6c 65 73 29 29 0a 20 20 20 20 28 63 riables)). (c
10900 6f 6e 64 0a 20 20 20 20 20 28 28 73 74 72 69 6e ond. ((strin
10910 67 3f 20 70 72 6f 63 29 28 73 79 73 74 65 6d 20 g? proc)(system
10920 70 72 6f 63 29 29 0a 20 20 20 20 20 28 70 72 6f proc)). (pro
10930 63 20 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 c (proc
10940 29 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 ))). (hash-ta
10950 62 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 ble-for-each.
10960 20 20 76 61 72 73 0a 20 20 20 20 20 28 6c 61 6d vars. (lam
10970 62 64 61 20 28 76 61 72 20 76 61 6c 29 0a 20 20 bda (var val).
10980 20 20 20 20 20 28 73 65 74 65 6e 76 20 76 61 72 (setenv var
10990 20 76 61 6c 29 29 29 0a 20 20 20 20 76 61 72 73 val))). vars
109a0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
109b0 6d 6f 6e 3a 72 75 6e 2d 61 2d 63 6f 6d 6d 61 6e mon:run-a-comman
109c0 64 20 63 6d 64 20 23 21 6b 65 79 20 28 77 69 74 d cmd #!key (wit
109d0 68 2d 76 61 72 73 20 23 66 29 29 0a 20 20 28 6c h-vars #f)). (l
109e0 65 74 2a 20 28 28 70 72 65 2d 63 6d 64 20 20 28 et* ((pre-cmd (
109f0 64 74 65 73 74 73 3a 67 65 74 2d 70 72 65 2d 63 dtests:get-pre-c
10a00 6f 6d 6d 61 6e 64 29 29 0a 20 20 20 20 20 20 20 ommand)).
10a10 20 20 28 70 6f 73 74 2d 63 6d 64 20 28 64 74 65 (post-cmd (dte
10a20 73 74 73 3a 67 65 74 2d 70 6f 73 74 2d 63 6f 6d sts:get-post-com
10a30 6d 61 6e 64 29 29 0a 20 20 20 20 20 20 20 20 20 mand)).
10a40 28 66 75 6c 6c 63 6d 64 20 20 28 69 66 20 28 6f (fullcmd (if (o
10a50 72 20 70 72 65 2d 63 6d 64 20 70 6f 73 74 2d 63 r pre-cmd post-c
10a60 6d 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 md).
10a70 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 (conc
10a80 20 70 72 65 2d 63 6d 64 20 63 6d 64 20 70 6f 73 pre-cmd cmd pos
10a90 74 2d 63 6d 64 29 0a 20 20 20 20 20 20 20 20 20 t-cmd).
10aa0 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
10ab0 6f 6e 63 20 22 76 69 65 77 73 63 72 65 65 6e 20 onc "viewscreen
10ac0 22 20 63 6d 64 29 29 29 29 0a 20 20 20 20 28 64 " cmd)))). (d
10ad0 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
10ae0 30 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 02 *default-log-
10af0 70 6f 72 74 2a 20 22 52 75 6e 6e 69 6e 67 20 63 port* "Running c
10b00 6f 6d 6d 61 6e 64 3a 20 22 20 66 75 6c 6c 63 6d ommand: " fullcm
10b10 64 29 0a 20 20 20 20 28 69 66 20 77 69 74 68 2d d). (if with-
10b20 76 61 72 73 0a 20 20 20 20 20 20 20 20 28 63 6f vars. (co
10b30 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 mmon:without-var
10b40 73 20 63 6d 64 29 0a 20 20 20 20 20 20 20 20 28 s cmd). (
10b50 63 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 common:without-v
10b60 61 72 73 20 66 75 6c 6c 63 6d 64 20 22 4d 54 5f ars fullcmd "MT_
10b70 2e 2a 22 29 29 29 29 0a 09 09 20 20 0a 3b 3b 3d .*"))))... .;;=
10b80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10ba0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10bb0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10bc0 3d 3d 3d 3d 3d 0a 3b 3b 20 54 20 49 20 4d 20 45 =====.;; T I M E
10bd0 20 20 20 41 20 4e 20 44 20 20 20 44 20 41 20 54 A N D D A T
10be0 20 45 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E.;;===========
10bf0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 ===========..;;
10c30 43 6f 6e 76 65 72 74 20 73 74 72 69 6e 67 73 20 Convert strings
10c40 6c 69 6b 65 20 22 35 73 20 32 68 20 33 6d 22 20 like "5s 2h 3m"
10c50 3d 3e 20 36 30 78 36 30 78 32 20 2b 20 33 78 36 => 60x60x2 + 3x6
10c60 30 20 2b 20 35 0a 28 64 65 66 69 6e 65 20 28 63 0 + 5.(define (c
10c70 6f 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 ommon:hms-string
10c80 2d 3e 73 65 63 6f 6e 64 73 20 74 73 74 72 29 0a ->seconds tstr).
10c90 20 20 28 6c 65 74 20 28 28 70 61 72 74 73 20 20 (let ((parts
10ca0 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 (string-split
10cb0 20 74 73 74 72 29 29 0a 09 28 74 69 6d 65 2d 73 tstr))..(time-s
10cc0 65 63 73 20 30 29 0a 09 3b 3b 20 73 3d 73 65 63 ecs 0)..;; s=sec
10cd0 6f 6e 64 73 2c 20 6d 3d 6d 69 6e 75 74 65 73 2c onds, m=minutes,
10ce0 20 68 3d 68 6f 75 72 73 2c 20 64 3d 64 61 79 73 h=hours, d=days
10cf0 0a 09 28 74 72 78 20 20 20 20 20 20 20 28 72 65 ..(trx (re
10d00 67 65 78 70 20 22 28 5c 5c 64 2b 29 28 5b 73 6d gexp "(\\d+)([sm
10d10 68 64 5d 29 22 29 29 29 0a 20 20 20 20 28 66 6f hd])"))). (fo
10d20 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 r-each (lambda (
10d30 70 61 72 74 29 0a 09 09 28 6c 65 74 20 28 28 6d part)...(let ((m
10d40 61 74 63 68 20 20 28 73 74 72 69 6e 67 2d 6d 61 atch (string-ma
10d50 74 63 68 20 74 72 78 20 70 61 72 74 29 29 29 0a tch trx part))).
10d60 09 09 20 20 28 69 66 20 6d 61 74 63 68 0a 09 09 .. (if match...
10d70 20 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c (let ((val
10d80 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
10d90 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 0a (cadr match))).
10da0 09 09 09 20 20 20 20 28 75 6e 74 20 28 63 61 64 ... (unt (cad
10db0 64 72 20 6d 61 74 63 68 29 29 29 0a 09 09 09 28 dr match)))....(
10dc0 69 66 20 76 61 6c 20 0a 09 09 09 20 20 20 20 28 if val .... (
10dd0 73 65 74 21 20 74 69 6d 65 2d 73 65 63 73 20 28 set! time-secs (
10de0 2b 20 74 69 6d 65 2d 73 65 63 73 20 28 2a 20 76 + time-secs (* v
10df0 61 6c 0a 09 09 09 09 09 09 09 20 20 20 20 28 63 al........ (c
10e00 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ase (string->sym
10e10 62 6f 6c 20 75 6e 74 29 0a 09 09 09 09 09 09 09 bol unt)........
10e20 20 20 20 20 20 20 28 28 73 29 20 31 29 0a 09 09 ((s) 1)...
10e30 09 09 09 09 09 20 20 20 20 20 20 28 28 6d 29 20 ..... ((m)
10e40 36 30 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 60)........
10e50 20 28 28 68 29 20 28 2a 20 36 30 20 36 30 29 29 ((h) (* 60 60))
10e60 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 ........ ((
10e70 64 29 20 28 2a 20 32 34 20 36 30 20 36 30 29 29 d) (* 24 60 60))
10e80 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 28 65 ........ (e
10e90 6c 73 65 20 30 29 29 29 29 29 29 29 29 29 29 0a lse 0)))))))))).
10ea0 09 20 20 20 20 20 20 70 61 72 74 73 29 0a 20 20 . parts).
10eb0 20 20 74 69 6d 65 2d 73 65 63 73 29 29 0a 09 09 time-secs))...
10ec0 20 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 .(define
10ed0 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e (seconds->hr-min
10ee0 2d 73 65 63 20 73 65 63 73 29 0a 20 20 28 6c 65 -sec secs). (le
10ef0 74 2a 20 28 28 68 72 73 20 28 71 75 6f 74 69 65 t* ((hrs (quotie
10f00 6e 74 20 73 65 63 73 20 33 36 30 30 29 29 0a 09 nt secs 3600))..
10f10 20 28 6d 69 6e 20 28 71 75 6f 74 69 65 6e 74 20 (min (quotient
10f20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 33 (- secs (* hrs 3
10f30 36 30 30 29 29 20 36 30 29 29 0a 09 20 28 73 65 600)) 60)).. (se
10f40 63 20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 73 c (- secs (* hrs
10f50 20 33 36 30 30 29 28 2a 20 6d 69 6e 20 36 30 29 3600)(* min 60)
10f60 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 69 ))). (conc (i
10f70 66 20 28 3e 20 68 72 73 20 30 29 28 63 6f 6e 63 f (> hrs 0)(conc
10f80 20 68 72 73 20 22 68 72 20 22 29 20 22 22 29 0a hrs "hr ") "").
10f90 09 20 20 28 69 66 20 28 3e 20 6d 69 6e 20 30 29 . (if (> min 0)
10fa0 28 63 6f 6e 63 20 6d 69 6e 20 22 6d 20 22 29 20 (conc min "m ")
10fb0 20 22 22 29 0a 09 20 20 73 65 63 20 22 73 22 29 "").. sec "s")
10fc0 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ))..(define (sec
10fd0 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e onds->time-strin
10fe0 67 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e g sec). (time->
10ff0 73 74 72 69 6e 67 20 0a 20 20 20 28 73 65 63 6f string . (seco
11000 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 nds->local-time
11010 73 65 63 29 20 22 25 48 3a 25 4d 3a 25 53 22 29 sec) "%H:%M:%S")
11020 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
11030 6e 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 nds->work-week/d
11040 61 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 28 ay-time sec). (
11050 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 time->string.
11060 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
11070 74 69 6d 65 20 73 65 63 29 20 22 77 77 25 56 2e time sec) "ww%V.
11080 25 75 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 %u %H:%M"))..(de
11090 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 fine (seconds->w
110a0 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 20 73 65 63 ork-week/day sec
110b0 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e ). (time->strin
110c0 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c g. (seconds->l
110d0 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 ocal-time sec) "
110e0 77 77 25 56 2e 25 75 22 29 29 0a 0a 28 64 65 66 ww%V.%u"))..(def
110f0 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 ine (seconds->ye
11100 61 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 ar-work-week/day
11110 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
11120 74 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 tring. (second
11130 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
11140 63 29 20 22 25 79 77 77 25 56 2e 25 77 22 29 29 c) "%yww%V.%w"))
11150 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e ..(define (secon
11160 64 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 ds->year-work-we
11170 65 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 ek/day-time sec)
11180 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 . (time->string
11190 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
111a0 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 cal-time sec) "%
111b0 59 77 77 25 56 2e 25 77 20 25 48 3a 25 4d 22 29 Yww%V.%w %H:%M")
111c0 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
111d0 6e 64 73 2d 3e 79 65 61 72 2d 77 65 65 6b 2f 64 nds->year-week/d
111e0 61 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 28 ay-time sec). (
111f0 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 time->string.
11200 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
11210 74 69 6d 65 20 73 65 63 29 20 22 25 59 77 25 56 time sec) "%Yw%V
11220 2e 25 77 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 .%w %H:%M"))..(d
11230 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e efine (seconds->
11240 71 75 61 72 74 65 72 20 73 65 63 29 0a 20 20 28 quarter sec). (
11250 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 6e 75 case (string->nu
11260 6d 62 65 72 0a 09 20 28 74 69 6d 65 2d 3e 73 74 mber.. (time->st
11270 72 69 6e 67 20 0a 09 20 20 28 73 65 63 6f 6e 64 ring .. (second
11280 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 s->local-time se
11290 63 29 0a 09 20 20 22 25 6d 22 29 29 0a 20 20 20 c).. "%m")).
112a0 20 28 28 31 20 32 20 33 29 20 31 29 0a 20 20 20 ((1 2 3) 1).
112b0 20 28 28 34 20 35 20 36 29 20 32 29 0a 20 20 20 ((4 5 6) 2).
112c0 20 28 28 37 20 38 20 39 29 20 33 29 0a 20 20 20 ((7 8 9) 3).
112d0 20 28 28 31 30 20 31 31 20 31 32 29 20 34 29 0a ((10 11 12) 4).
112e0 20 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 0a (else #f))).
112f0 0a 3b 3b 20 62 61 73 69 63 20 49 53 4f 38 36 30 .;; basic ISO860
11300 31 20 66 6f 72 6d 61 74 20 28 65 2e 67 2e 20 22 1 format (e.g. "
11310 32 30 31 37 2d 30 32 2d 32 38 20 30 36 3a 30 32 2017-02-28 06:02
11320 3a 35 34 22 29 20 64 61 74 65 20 74 69 6d 65 20 :54") date time
11330 3d 3e 20 55 6e 69 78 20 65 70 6f 63 68 0a 3b 3b => Unix epoch.;;
11340 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
11350 3a 64 61 74 65 2d 74 69 6d 65 2d 3e 73 65 63 6f :date-time->seco
11360 6e 64 73 20 64 61 74 65 74 69 6d 65 29 0a 20 20 nds datetime).
11370 28 6c 6f 63 61 6c 2d 74 69 6d 65 2d 3e 73 65 63 (local-time->sec
11380 6f 6e 64 73 20 28 73 74 72 69 6e 67 2d 3e 74 69 onds (string->ti
11390 6d 65 20 64 61 74 65 74 69 6d 65 20 22 25 59 2d me datetime "%Y-
113a0 25 6d 2d 25 64 20 25 48 3a 25 4d 3a 25 53 22 29 %m-%d %H:%M:%S")
113b0 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 73 70 61 ))..;; given spa
113c0 6e 20 6f 66 20 73 65 63 6f 6e 64 73 20 74 73 74 n of seconds tst
113d0 61 72 74 20 74 6f 20 74 65 6e 64 0a 3b 3b 20 66 art to tend.;; f
113e0 69 6e 64 20 73 74 61 72 74 20 74 69 6d 65 20 74 ind start time t
113f0 6f 20 6d 61 72 6b 20 61 6e 64 20 6d 61 72 6b 20 o mark and mark
11400 64 65 6c 74 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 delta.;;.(define
11410 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 73 74 (common:find-st
11420 61 72 74 2d 6d 61 72 6b 2d 61 6e 64 2d 6d 61 72 art-mark-and-mar
11430 6b 2d 64 65 6c 74 61 20 74 73 74 61 72 74 20 74 k-delta tstart t
11440 65 6e 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 end). (let* ((d
11450 65 6c 74 61 74 20 20 20 28 2d 20 28 6d 61 78 20 eltat (- (max
11460 74 65 6e 64 20 28 2b 20 74 65 6e 64 20 31 30 29 tend (+ tend 10)
11470 29 20 74 73 74 61 72 74 29 29 20 3b 3b 20 63 61 ) tstart)) ;; ca
11480 6e 27 74 20 68 61 6e 64 6c 65 20 72 75 6e 73 20 n't handle runs
11490 6f 66 20 6c 65 73 73 20 74 68 61 6e 20 34 20 73 of less than 4 s
114a0 65 63 6f 6e 64 73 2e 20 50 61 64 20 69 74 20 74 econds. Pad it t
114b0 6f 20 31 30 20 73 65 63 6f 6e 64 73 20 2e 2e 2e o 10 seconds ...
114c0 0a 09 20 28 72 65 73 75 6c 74 20 20 20 23 66 29 .. (result #f)
114d0 0a 09 20 28 6d 69 6e 20 20 20 20 20 20 36 30 29 .. (min 60)
114e0 0a 09 20 28 68 72 20 20 20 20 20 20 20 28 2a 20 .. (hr (*
114f0 36 30 20 36 30 29 29 0a 09 20 28 64 61 79 20 20 60 60)).. (day
11500 20 20 20 20 28 2a 20 32 34 20 68 72 29 29 0a 09 (* 24 hr))..
11510 20 28 79 72 20 20 20 20 20 20 20 28 2a 20 33 36 (yr (* 36
11520 35 20 64 61 79 29 29 20 3b 3b 20 79 65 61 72 0a 5 day)) ;; year.
11530 09 20 28 6d 6f 20 20 20 20 20 20 20 28 2f 20 79 . (mo (/ y
11540 72 20 31 32 29 29 0a 09 20 28 77 6b 20 20 20 20 r 12)).. (wk
11550 20 20 20 28 2a 20 64 61 79 20 37 29 29 29 0a 20 (* day 7))).
11560 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 (for-each.
11570 20 20 28 6c 61 6d 62 64 61 20 28 6d 61 78 2d 62 (lambda (max-b
11580 6c 6b 73 29 0a 20 20 20 20 20 20 20 28 66 6f 72 lks). (for
11590 2d 65 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 -each..(lambda (
115a0 73 70 61 6e 29 20 3b 3b 20 35 20 32 20 31 0a 09 span) ;; 5 2 1..
115b0 20 20 28 69 66 20 28 6e 6f 74 20 72 65 73 75 6c (if (not resul
115c0 74 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d 65 t).. (for-e
115d0 61 63 68 20 0a 09 20 20 20 20 20 20 20 28 6c 61 ach .. (la
115e0 6d 62 64 61 20 28 74 69 6d 65 75 6e 69 74 20 74 mbda (timeunit t
115f0 69 6d 65 73 79 6d 29 20 3b 3b 20 79 65 61 72 20 imesym) ;; year
11600 6d 6f 6e 74 68 20 64 61 79 20 68 72 20 6d 69 6e month day hr min
11610 20 73 65 63 0a 09 09 20 28 69 66 20 28 6e 6f 74 sec... (if (not
11620 20 72 65 73 75 6c 74 29 0a 09 09 20 20 20 20 20 result)...
11630 28 6c 65 74 2a 20 28 28 74 69 6d 65 2d 62 6c 6b (let* ((time-blk
11640 20 28 2a 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 (* span timeuni
11650 74 29 29 0a 09 09 09 20 20 20 20 28 6e 75 6d 2d t)).... (num-
11660 62 6c 6b 73 20 28 71 75 6f 74 69 65 6e 74 20 64 blks (quotient d
11670 65 6c 74 61 74 20 74 69 6d 65 2d 62 6c 6b 29 29 eltat time-blk))
11680 29 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 28 )... (if (
11690 61 6e 64 20 28 3e 20 6e 75 6d 2d 62 6c 6b 73 20 and (> num-blks
116a0 34 29 28 3c 20 6e 75 6d 2d 62 6c 6b 73 20 6d 61 4)(< num-blks ma
116b0 78 2d 62 6c 6b 73 29 29 0a 09 09 09 20 20 20 28 x-blks)).... (
116c0 6c 65 74 20 28 28 66 69 72 73 74 20 28 2a 20 28 let ((first (* (
116d0 71 75 6f 74 69 65 6e 74 20 74 73 74 61 72 74 20 quotient tstart
116e0 74 69 6d 65 2d 62 6c 6b 29 20 74 69 6d 65 2d 62 time-blk) time-b
116f0 6c 6b 29 29 29 0a 09 09 09 20 20 20 20 20 28 73 lk))).... (s
11700 65 74 21 20 72 65 73 75 6c 74 20 28 6c 69 73 74 et! result (list
11710 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 20 74 span timeunit t
11720 69 6d 65 2d 62 6c 6b 20 66 69 72 73 74 20 74 69 ime-blk first ti
11730 6d 65 73 79 6d 29 29 0a 09 09 09 20 20 20 20 20 mesym))....
11740 29 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 6c ))))).. (l
11750 69 73 74 20 79 72 20 6d 6f 20 77 6b 20 64 61 79 ist yr mo wk day
11760 20 68 72 20 6d 69 6e 20 31 29 0a 09 20 20 20 20 hr min 1)..
11770 20 20 20 27 28 20 20 20 20 20 79 20 20 6d 6f 20 '( y mo
11780 77 20 20 64 20 20 20 68 20 20 6d 20 20 20 73 29 w d h m s)
11790 29 29 29 0a 09 28 6c 69 73 74 20 38 20 36 20 35 )))..(list 8 6 5
117a0 20 32 20 31 29 29 29 0a 20 20 20 20 20 27 28 35 2 1))). '(5
117b0 20 31 30 20 31 35 20 32 30 20 33 30 20 34 30 20 10 15 20 30 40
117c0 35 30 20 35 30 30 29 29 0a 20 20 20 20 28 69 66 50 500)). (if
117d0 20 76 61 6c 75 65 73 0a 09 28 61 70 70 6c 79 20 values..(apply
117e0 76 61 6c 75 65 73 20 72 65 73 75 6c 74 29 0a 09 values result)..
117f0 28 76 61 6c 75 65 73 20 30 20 64 61 79 20 31 20 (values 0 day 1
11800 30 20 27 64 29 29 29 29 0a 0a 3b 3b 20 67 69 76 0 'd))))..;; giv
11810 65 6e 20 78 20 79 20 6c 69 6d 20 72 65 74 75 72 en x y lim retur
11820 6e 20 74 68 65 20 63 72 6f 6e 20 65 78 70 61 6e n the cron expan
11830 73 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 sion.;;.(define
11840 28 63 6f 6d 6d 6f 6e 3a 65 78 70 61 6e 64 2d 63 (common:expand-c
11850 72 6f 6e 2d 73 6c 61 73 68 20 78 20 79 20 6c 69 ron-slash x y li
11860 6d 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 m). (let loop (
11870 28 63 75 72 72 20 78 29 0a 09 20 20 20 20 20 28 (curr x).. (
11880 72 65 73 20 20 60 28 29 29 29 0a 20 20 20 20 28 res `())). (
11890 69 66 20 28 3c 20 63 75 72 72 20 6c 69 6d 29 0a if (< curr lim).
118a0 09 28 6c 6f 6f 70 20 28 2b 20 63 75 72 72 20 79 .(loop (+ curr y
118b0 29 20 28 63 6f 6e 73 20 63 75 72 72 20 72 65 73 ) (cons curr res
118c0 29 29 0a 09 28 72 65 76 65 72 73 65 20 72 65 73 ))..(reverse res
118d0 29 29 29 29 0a 0a 3b 3b 20 65 78 70 61 6e 64 20 ))))..;; expand
118e0 61 20 63 6f 6d 70 6c 65 78 20 63 72 6f 6e 20 73 a complex cron s
118f0 74 72 69 6e 67 20 74 6f 20 61 20 6c 69 73 74 20 tring to a list
11900 6f 66 20 63 72 6f 6e 20 73 74 72 69 6e 67 73 0a of cron strings.
11910 3b 3b 0a 3b 3b 20 20 78 2f 79 20 20 20 3d 3e 20 ;;.;; x/y =>
11920 78 2c 20 78 2b 79 2c 20 78 2b 32 79 2c 20 78 2b x, x+y, x+2y, x+
11930 33 79 20 77 68 69 6c 65 20 78 2b 4e 79 3c 6d 61 3y while x+Ny<ma
11940 78 5f 66 6f 72 5f 66 69 65 6c 64 0a 3b 3b 20 20 x_for_field.;;
11950 61 2c 62 2c 63 20 3d 3e 20 61 2c 20 62 20 2c 63 a,b,c => a, b ,c
11960 0a 3b 3b 0a 3b 3b 20 20 20 4e 4f 54 45 3a 20 77 .;;.;; NOTE: w
11970 69 74 68 20 66 6c 61 74 74 65 6e 20 61 20 6c 6f ith flatten a lo
11980 74 20 6f 66 20 74 68 65 20 63 72 75 64 20 62 65 t of the crud be
11990 6c 6f 77 20 63 61 6e 20 62 65 20 66 61 63 74 6f low can be facto
119a0 72 65 64 20 64 6f 77 6e 2e 0a 3b 3b 0a 28 64 65 red down..;;.(de
119b0 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f fine (common:cro
119c0 6e 2d 65 78 70 61 6e 64 20 63 72 6f 6e 2d 73 74 n-expand cron-st
119d0 72 29 0a 20 20 28 69 66 20 28 6c 69 73 74 3f 20 r). (if (list?
119e0 63 72 6f 6e 2d 73 74 72 29 0a 20 20 20 20 20 20 cron-str).
119f0 28 66 6c 61 74 74 65 6e 0a 20 20 20 20 20 20 20 (flatten.
11a00 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 78 (fold (lambda (x
11a10 20 72 65 73 29 0a 09 20 20 20 20 20 20 20 28 69 res).. (i
11a20 66 20 28 6c 69 73 74 3f 20 78 29 0a 09 09 20 20 f (list? x)...
11a30 20 28 6c 65 74 20 28 28 6e 65 77 72 65 73 20 28 (let ((newres (
11a40 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d map common:cron-
11a50 65 78 70 61 6e 64 20 78 29 29 29 0a 09 09 20 20 expand x)))...
11a60 20 20 20 28 61 70 70 65 6e 64 20 78 20 6e 65 77 (append x new
11a70 72 65 73 29 29 0a 09 09 20 20 20 28 63 6f 6e 73 res))... (cons
11a80 20 78 20 72 65 73 29 29 29 0a 09 20 20 20 20 20 x res)))..
11a90 27 28 29 0a 09 20 20 20 20 20 63 72 6f 6e 2d 73 '().. cron-s
11aa0 74 72 29 29 20 3b 3b 20 28 6d 61 70 20 63 6f 6d tr)) ;; (map com
11ab0 6d 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 mon:cron-expand
11ac0 63 72 6f 6e 2d 73 74 72 29 29 0a 20 20 20 20 20 cron-str)).
11ad0 20 28 6c 65 74 20 28 28 63 72 6f 6e 2d 69 74 65 (let ((cron-ite
11ae0 6d 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 ms (string-split
11af0 20 63 72 6f 6e 2d 73 74 72 29 29 0a 09 20 20 20 cron-str))..
11b00 20 28 73 6c 61 73 68 2d 72 78 20 20 20 28 72 65 (slash-rx (re
11b10 67 65 78 70 20 22 28 5c 5c 64 2b 29 2f 28 5c 5c gexp "(\\d+)/(\\
11b20 64 2b 29 22 29 29 0a 09 20 20 20 20 28 63 6f 6d d+)")).. (com
11b30 6d 61 2d 72 78 20 20 20 28 72 65 67 65 78 70 20 ma-rx (regexp
11b40 22 2e 2a 2c 2e 2a 22 29 29 0a 09 20 20 20 20 28 ".*,.*")).. (
11b50 6d 61 78 2d 76 61 6c 73 20 20 20 27 28 28 6d 69 max-vals '((mi
11b60 6e 20 20 20 20 20 20 20 20 2e 20 36 30 29 0a 09 n . 60)..
11b70 09 09 20 20 28 68 6f 75 72 20 20 20 20 20 20 20 .. (hour
11b80 2e 20 32 34 29 0a 09 09 09 20 20 28 64 61 79 6f . 24).... (dayo
11b90 66 6d 6f 6e 74 68 20 2e 20 32 38 29 20 3b 3b 3b fmonth . 28) ;;;
11ba0 20 42 55 47 21 21 21 21 20 54 68 69 73 20 77 69 BUG!!!! This wi
11bb0 6c 6c 20 62 65 20 61 20 62 75 67 20 66 6f 72 20 ll be a bug for
11bc0 73 6f 6d 65 20 63 6f 6d 62 69 6e 61 74 69 6f 6e some combination
11bd0 73 0a 09 09 09 20 20 28 6d 6f 6e 74 68 20 20 20 s.... (month
11be0 20 20 20 2e 20 31 32 29 0a 09 09 09 20 20 28 64 . 12).... (d
11bf0 61 79 6f 66 77 65 65 6b 20 20 2e 20 37 29 29 29 ayofweek . 7)))
11c00 29 0a 09 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 )..(if (< (lengt
11c10 68 20 63 72 6f 6e 2d 69 74 65 6d 73 29 20 35 29 h cron-items) 5)
11c20 20 3b 3b 20 62 61 64 20 73 70 65 63 0a 09 20 20 ;; bad spec..
11c30 20 20 63 72 6f 6e 2d 73 74 72 20 3b 3b 20 60 28 cron-str ;; `(
11c40 2c 63 72 6f 6e 2d 73 74 72 29 20 20 20 20 20 20 ,cron-str)
11c50 20 20 20 20 20 20 20 20 3b 3b 20 6a 75 73 74 20 ;; just
11c60 72 65 74 75 72 6e 20 74 68 65 20 73 74 72 69 6e return the strin
11c70 67 2c 20 73 6f 6d 65 74 68 69 6e 67 20 64 6f 77 g, something dow
11c80 6e 73 74 72 65 61 6d 20 77 69 6c 6c 20 66 69 78 nstream will fix
11c90 20 69 74 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f it.. (let lo
11ca0 6f 70 20 28 28 68 65 64 20 20 28 63 61 72 20 63 op ((hed (car c
11cb0 72 6f 6e 2d 69 74 65 6d 73 29 29 0a 09 09 20 20 ron-items))...
11cc0 20 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 (tal (cdr
11cd0 63 72 6f 6e 2d 69 74 65 6d 73 29 29 0a 09 09 20 cron-items))...
11ce0 20 20 20 20 20 20 28 74 79 70 65 20 27 6d 69 6e (type 'min
11cf0 29 0a 09 09 20 20 20 20 20 20 20 28 74 79 70 65 )... (type
11d00 2d 74 61 6c 20 27 28 68 6f 75 72 20 64 61 79 6f -tal '(hour dayo
11d10 66 6d 6f 6e 74 68 20 6d 6f 6e 74 68 20 64 61 79 fmonth month day
11d20 6f 66 77 65 65 6b 29 29 0a 09 09 20 20 20 20 20 ofweek))...
11d30 20 20 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 (res '()))..
11d40 20 20 20 20 20 28 72 65 67 65 78 2d 63 61 73 65 (regex-case
11d50 0a 09 09 20 20 68 65 64 0a 09 09 28 73 6c 61 73 ... hed...(slas
11d60 68 2d 72 78 20 28 20 5f 20 62 61 73 65 20 69 6e h-rx ( _ base in
11d70 63 72 20 29 20 28 6c 65 74 2a 20 28 28 62 61 73 cr ) (let* ((bas
11d80 65 6e 20 20 20 20 20 20 20 20 20 20 28 73 74 72 en (str
11d90 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 62 61 73 65 ing->number base
11da0 29 29 0a 09 09 09 09 09 09 20 28 69 6e 63 72 6e ))....... (incrn
11db0 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
11dc0 67 2d 3e 6e 75 6d 62 65 72 20 69 6e 63 72 29 29 g->number incr))
11dd0 0a 09 09 09 09 09 09 20 28 65 78 70 61 6e 64 65 ....... (expande
11de0 64 2d 76 61 6c 73 20 20 28 63 6f 6d 6d 6f 6e 3a d-vals (common:
11df0 65 78 70 61 6e 64 2d 63 72 6f 6e 2d 73 6c 61 73 expand-cron-slas
11e00 68 20 62 61 73 65 6e 20 69 6e 63 72 6e 20 28 61 h basen incrn (a
11e10 6c 69 73 74 2d 72 65 66 20 74 79 70 65 20 6d 61 list-ref type ma
11e20 78 2d 76 61 6c 73 29 29 29 0a 09 09 09 09 09 09 x-vals))).......
11e30 20 28 6e 65 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 (new-list-crons
11e40 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 (fold (lambda (
11e50 78 20 6d 79 72 65 73 29 0a 09 09 09 09 09 09 09 x myres)........
11e60 09 09 20 28 63 6f 6e 73 20 28 63 6f 6e 63 20 28 .. (cons (conc (
11e70 69 66 20 28 6e 75 6c 6c 3f 20 72 65 73 29 0a 09 if (null? res)..
11e80 09 09 09 09 09 09 09 09 09 09 20 22 22 0a 09 09 .......... ""...
11e90 09 09 09 09 09 09 09 09 09 20 28 63 6f 6e 63 20 ......... (conc
11ea0 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
11eb0 72 73 65 20 72 65 73 20 22 20 22 29 20 22 20 22 rse res " ") " "
11ec0 29 29 0a 09 09 09 09 09 09 09 09 09 09 20 20 20 ))...........
11ed0 20 20 78 20 22 20 22 20 28 73 74 72 69 6e 67 2d x " " (string-
11ee0 69 6e 74 65 72 73 70 65 72 73 65 20 74 61 6c 20 intersperse tal
11ef0 22 20 22 29 29 0a 09 09 09 09 09 09 09 09 09 20 " "))..........
11f00 20 20 20 20 20 20 6d 79 72 65 73 29 29 0a 09 09 myres))...
11f10 09 09 09 09 09 09 20 20 20 20 20 20 20 27 28 29 ...... '()
11f20 20 65 78 70 61 6e 64 65 64 2d 76 61 6c 73 29 29 expanded-vals))
11f30 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 28 70 )...... ;; (p
11f40 72 69 6e 74 20 22 6e 65 77 2d 6c 69 73 74 2d 63 rint "new-list-c
11f50 72 6f 6e 73 3a 20 22 20 6e 65 77 2d 6c 69 73 74 rons: " new-list
11f60 2d 63 72 6f 6e 73 29 0a 09 09 09 09 09 20 20 20 -crons)......
11f70 20 3b 3b 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 ;; (fold (lambd
11f80 61 20 28 78 20 72 65 73 29 0a 09 09 09 09 09 20 a (x res)......
11f90 20 20 20 3b 3b 20 09 20 20 20 20 28 69 66 20 28 ;; . (if (
11fa0 6c 69 73 74 3f 20 78 29 0a 09 09 09 09 09 20 20 list? x)......
11fb0 20 20 3b 3b 20 09 09 28 6c 65 74 20 28 28 6e 65 ;; ..(let ((ne
11fc0 77 72 65 73 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e wres (map common
11fd0 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 78 29 29 :cron-expand x))
11fe0 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 09 09 )...... ;; ..
11ff0 20 20 28 61 70 70 65 6e 64 20 78 20 6e 65 77 72 (append x newr
12000 65 73 29 29 0a 09 09 09 09 09 20 20 20 20 3b 3b es))...... ;;
12010 20 09 09 28 63 6f 6e 73 20 78 20 72 65 73 29 29 ..(cons x res))
12020 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 09 20 )...... ;; .
12030 20 27 28 29 0a 09 09 09 09 09 20 20 20 20 28 66 '()...... (f
12040 6c 61 74 74 65 6e 20 28 6d 61 70 20 63 6f 6d 6d latten (map comm
12050 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 6e on:cron-expand n
12060 65 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 29 29 29 ew-list-crons)))
12070 29 0a 09 09 3b 3b 09 09 09 09 09 20 20 20 20 28 )...;;..... (
12080 6d 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d map common:cron-
12090 65 78 70 61 6e 64 20 28 6d 61 70 20 63 6f 6d 6d expand (map comm
120a0 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 6e on:cron-expand n
120b0 65 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 29 29 29 ew-list-crons)))
120c0 29 0a 09 09 28 65 6c 73 65 20 28 69 66 20 28 6e )...(else (if (n
120d0 75 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 63 ull? tal).... c
120e0 72 6f 6e 2d 73 74 72 0a 09 09 09 20 20 28 6c 6f ron-str.... (lo
120f0 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
12100 20 74 61 6c 29 28 63 61 72 20 74 79 70 65 2d 74 tal)(car type-t
12110 61 6c 29 28 63 64 72 20 74 79 70 65 2d 74 61 6c al)(cdr type-tal
12120 29 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 )(append res (li
12130 73 74 20 68 65 64 29 29 29 29 29 29 29 29 29 29 st hed))))))))))
12140 29 0a 09 09 20 20 20 20 20 20 0a 09 20 20 20 20 )... ..
12150 0a 3b 3b 20 67 69 76 65 6e 20 61 20 63 72 6f 6e .;; given a cron
12160 20 73 74 72 69 6e 67 20 61 6e 64 20 74 68 65 20 string and the
12170 6c 61 73 74 20 74 69 6d 65 20 65 76 65 6e 74 20 last time event
12180 77 61 73 20 70 72 6f 63 65 73 73 65 64 20 72 65 was processed re
12190 74 75 72 6e 20 23 74 20 74 6f 20 72 75 6e 20 6f turn #t to run o
121a0 72 20 23 66 20 74 6f 20 6e 6f 74 20 72 75 6e 0a r #f to not run.
121b0 3b 3b 0a 3b 3b 20 20 6d 69 6e 20 20 20 20 68 6f ;;.;; min ho
121c0 75 72 20 20 20 64 61 79 6f 66 6d 6f 6e 74 68 20 ur dayofmonth
121d0 6d 6f 6e 74 68 20 20 64 61 79 6f 66 77 65 65 6b month dayofweek
121e0 0a 3b 3b 20 30 2d 35 39 20 20 20 20 30 2d 32 33 .;; 0-59 0-23
121f0 20 20 20 31 2d 33 31 20 20 20 20 20 20 20 31 2d 1-31 1-
12200 31 32 20 20 20 30 2d 36 20 20 20 20 20 20 20 20 12 0-6
12210 20 20 23 23 23 20 4e 4f 54 45 3a 20 64 61 79 6f ### NOTE: dayo
12220 66 77 65 65 6b 20 64 6f 65 73 20 6e 6f 74 20 69 fweek does not i
12230 6e 63 6c 75 64 65 20 37 0a 3b 3b 0a 3b 3b 20 20 nclude 7.;;.;;
12240 23 74 20 3d 3e 20 79 65 73 2c 20 72 75 6e 20 74 #t => yes, run t
12250 68 65 20 6a 6f 62 0a 3b 3b 20 20 23 66 20 3d 3e he job.;; #f =>
12260 20 6e 6f 2c 20 64 6f 20 6e 6f 74 20 72 75 6e 20 no, do not run
12270 74 68 65 20 6a 6f 62 0a 3b 3b 0a 28 64 65 66 69 the job.;;.(defi
12280 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d ne (common:cron-
12290 65 76 65 6e 74 20 63 72 6f 6e 2d 73 74 72 20 6e event cron-str n
122a0 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 6c 61 ow-seconds-in la
122b0 73 74 2d 64 6f 6e 65 29 20 3b 3b 20 72 65 66 2d st-done) ;; ref-
122c0 73 65 63 6f 6e 64 73 20 3d 20 23 66 20 69 73 20 seconds = #f is
122d0 4e 4f 57 2e 0a 20 20 28 6c 65 74 2a 20 28 28 63 NOW.. (let* ((c
122e0 72 6f 6e 2d 69 74 65 6d 73 20 20 20 20 20 28 6d ron-items (m
122f0 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 ap string->numbe
12300 72 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 r (string-split
12310 63 72 6f 6e 2d 73 74 72 29 29 29 0a 09 20 28 6e cron-str))).. (n
12320 6f 77 2d 73 65 63 6f 6e 64 73 20 20 20 20 28 6f ow-seconds (o
12330 72 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e r now-seconds-in
12340 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
12350 73 29 29 29 0a 09 20 28 6e 6f 77 2d 74 69 6d 65 s))).. (now-time
12360 20 20 20 20 20 20 20 28 73 65 63 6f 6e 64 73 2d (seconds-
12370 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6e 6f 77 2d >local-time now-
12380 73 65 63 6f 6e 64 73 29 29 0a 09 20 28 6c 61 73 seconds)).. (las
12390 74 2d 64 6f 6e 65 2d 74 69 6d 65 20 28 73 65 63 t-done-time (sec
123a0 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
123b0 20 6c 61 73 74 2d 64 6f 6e 65 29 29 0a 09 20 28 last-done)).. (
123c0 61 6c 6c 2d 74 69 6d 65 73 20 20 20 20 20 20 28 all-times (
123d0 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 make-hash-table)
123e0 29 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 )). ;; (print
123f0 20 22 63 72 6f 6e 2d 69 74 65 6d 73 3a 20 22 20 "cron-items: "
12400 63 72 6f 6e 2d 69 74 65 6d 73 20 22 28 6c 65 6e cron-items "(len
12410 67 74 68 20 63 72 6f 6e 2d 69 74 65 6d 73 29 3a gth cron-items):
12420 20 22 20 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d " (length cron-
12430 69 74 65 6d 73 29 29 0a 20 20 20 20 28 69 66 20 items)). (if
12440 28 6e 6f 74 20 28 65 71 3f 20 28 6c 65 6e 67 74 (not (eq? (lengt
12450 68 20 63 72 6f 6e 2d 69 74 65 6d 73 29 20 35 29 h cron-items) 5)
12460 29 20 3b 3b 20 64 6f 6e 27 74 20 65 76 65 6e 20 ) ;; don't even
12470 74 72 79 20 74 6f 20 66 69 67 75 72 65 20 6f 75 try to figure ou
12480 74 20 6a 75 6e 6b 20 73 74 72 69 6e 67 73 0a 09 t junk strings..
12490 23 66 0a 09 28 6d 61 74 63 68 2d 6c 65 74 20 28 #f..(match-let (
124a0 28 28 20 20 20 20 20 63 6d 69 6e 20 63 68 6f 75 (( cmin chou
124b0 72 20 63 64 61 79 6f 66 6d 6f 6e 74 68 20 63 6d r cdayofmonth cm
124c0 6f 6e 74 68 20 20 20 20 63 64 61 79 6f 66 77 65 onth cdayofwe
124d0 65 6b 29 0a 09 09 20 20 20 20 20 63 72 6f 6e 2d ek)... cron-
124e0 69 74 65 6d 73 29 0a 09 09 20 20 20 20 3b 3b 20 items)... ;;
124f0 30 20 20 20 20 20 31 20 20 20 20 32 20 20 20 20 0 1 2
12500 20 20 20 20 33 20 20 20 20 20 20 20 20 20 34 20 3 4
12510 20 20 20 35 20 20 20 20 20 20 36 0a 09 09 20 20 5 6...
12520 20 20 28 28 6e 73 65 63 20 6e 6d 69 6e 20 6e 68 ((nsec nmin nh
12530 6f 75 72 20 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 our ndayofmonth
12540 6e 6d 6f 6e 74 68 20 6e 79 72 20 6e 64 61 79 6f nmonth nyr ndayo
12550 66 77 65 65 6b 20 6e 37 20 6e 38 20 6e 39 29 0a fweek n7 n8 n9).
12560 09 09 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e .. (vector->
12570 6c 69 73 74 20 6e 6f 77 2d 74 69 6d 65 29 29 0a list now-time)).
12580 09 09 20 20 20 20 28 28 6c 73 65 63 20 6c 6d 69 .. ((lsec lmi
12590 6e 20 6c 68 6f 75 72 20 6c 64 61 79 6f 66 6d 6f n lhour ldayofmo
125a0 6e 74 68 20 6c 6d 6f 6e 74 68 20 6c 79 72 20 6c nth lmonth lyr l
125b0 64 61 79 6f 66 77 65 65 6b 20 6c 37 20 6c 38 20 dayofweek l7 l8
125c0 6c 39 29 0a 09 09 20 20 20 20 20 28 76 65 63 74 l9)... (vect
125d0 6f 72 2d 3e 6c 69 73 74 20 6c 61 73 74 2d 64 6f or->list last-do
125e0 6e 65 2d 74 69 6d 65 29 29 29 0a 09 20 20 3b 3b ne-time))).. ;;
125f0 20 63 72 65 61 74 65 20 61 6c 6c 20 70 6f 73 73 create all poss
12600 69 62 6c 65 20 74 69 6d 65 20 73 6c 6f 74 73 0a ible time slots.
12610 09 20 20 3b 3b 20 72 65 6d 6f 76 65 20 69 6e 76 . ;; remove inv
12620 61 6c 69 64 20 73 6c 6f 74 73 20 64 75 65 20 74 alid slots due t
12630 6f 20 28 66 6f 72 20 65 78 61 6d 70 6c 65 29 20 o (for example)
12640 64 61 79 20 6f 66 20 77 65 65 6b 0a 09 20 20 3b day of week.. ;
12650 3b 20 67 65 74 20 74 68 65 20 73 74 61 72 74 20 ; get the start
12660 61 6e 64 20 65 6e 64 20 65 6e 74 72 69 65 73 20 and end entries
12670 66 6f 72 20 74 68 65 20 72 65 66 2d 73 65 63 6f for the ref-seco
12680 6e 64 73 20 28 63 75 72 72 65 6e 74 29 20 74 69 nds (current) ti
12690 6d 65 0a 09 20 20 3b 3b 20 69 66 20 6c 61 73 74 me.. ;; if last
126a0 2d 64 6f 6e 65 20 3e 20 72 65 66 2d 73 65 63 6f -done > ref-seco
126b0 6e 64 73 20 3d 3e 20 74 68 69 73 20 69 73 20 61 nds => this is a
126c0 6e 20 45 52 52 4f 52 21 0a 09 20 20 3b 3b 20 64 n ERROR!.. ;; d
126d0 6f 65 73 20 74 68 65 20 6c 61 73 74 2d 64 6f 6e oes the last-don
126e0 65 20 74 69 6d 65 20 66 61 6c 6c 20 69 6e 20 74 e time fall in t
126f0 68 65 20 6c 65 67 69 74 20 72 65 67 69 6f 6e 3f he legit region?
12700 0a 09 20 20 3b 3b 20 20 20 20 79 65 73 20 3d 3e .. ;; yes =>
12710 20 23 66 20 20 64 6f 20 6e 6f 74 20 72 75 6e 20 #f do not run
12720 61 67 61 69 6e 20 74 68 69 73 20 63 6f 6d 6d 61 again this comma
12730 6e 64 0a 09 20 20 3b 3b 20 20 20 20 6e 6f 20 20 nd.. ;; no
12740 3d 3e 20 23 74 20 20 6f 6b 20 74 6f 20 72 75 6e => #t ok to run
12750 20 74 68 65 20 63 6f 6d 6d 61 6e 64 0a 09 20 20 the command..
12760 28 66 6f 72 2d 65 61 63 68 20 3b 3b 20 6d 6f 6e (for-each ;; mon
12770 74 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 th.. (lambda (
12780 6d 6f 6e 74 68 29 0a 09 20 20 20 20 20 28 66 6f month).. (fo
12790 72 2d 65 61 63 68 20 3b 3b 20 64 61 79 6f 66 6d r-each ;; dayofm
127a0 6f 6e 74 68 0a 09 20 20 20 20 20 20 28 6c 61 6d onth.. (lam
127b0 62 64 61 20 28 64 6f 6d 29 0a 09 09 28 66 6f 72 bda (dom)...(for
127c0 2d 65 61 63 68 0a 09 09 20 28 6c 61 6d 62 64 61 -each... (lambda
127d0 20 28 68 72 29 20 3b 3b 20 68 6f 75 72 0a 09 09 (hr) ;; hour...
127e0 20 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 (for-each...
127f0 20 20 20 28 6c 61 6d 62 64 61 20 28 6d 69 6e 75 (lambda (minu
12800 74 65 29 20 3b 3b 20 6d 69 6e 75 74 65 0a 09 09 te) ;; minute...
12810 20 20 20 20 20 20 28 6c 65 74 20 28 28 63 6f 70 (let ((cop
12820 79 2d 6e 6f 77 20 28 61 70 70 6c 79 20 76 65 63 y-now (apply vec
12830 74 6f 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 tor (vector->lis
12840 74 20 6e 6f 77 2d 74 69 6d 65 29 29 29 29 0a 09 t now-time))))..
12850 09 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 ..(vector-set! c
12860 6f 70 79 2d 6e 6f 77 20 30 20 30 29 20 3b 3b 20 opy-now 0 0) ;;
12870 66 6f 72 63 65 20 73 65 63 6f 6e 64 73 20 74 6f force seconds to
12880 20 7a 65 72 6f 0a 09 09 09 28 76 65 63 74 6f 72 zero....(vector
12890 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 20 31 -set! copy-now 1
128a0 20 6d 69 6e 75 74 65 29 0a 09 09 09 28 76 65 63 minute)....(vec
128b0 74 6f 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f tor-set! copy-no
128c0 77 20 32 20 68 72 29 0a 09 09 09 28 76 65 63 74 w 2 hr)....(vect
128d0 6f 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 or-set! copy-now
128e0 20 33 20 64 6f 6d 29 20 20 3b 3b 20 64 6f 6d 20 3 dom) ;; dom
128f0 69 73 20 61 6c 72 65 61 64 79 20 63 6f 72 72 65 is already corre
12900 63 74 65 64 20 66 6f 72 20 7a 65 72 6f 20 72 65 cted for zero re
12910 66 65 72 65 6e 63 65 64 0a 09 09 09 28 76 65 63 ferenced....(vec
12920 74 6f 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f tor-set! copy-no
12930 77 20 34 20 6d 6f 6e 74 68 29 0a 09 09 09 28 6c w 4 month)....(l
12940 65 74 2a 20 28 28 63 6f 70 79 2d 6e 6f 77 2d 73 et* ((copy-now-s
12950 65 63 73 20 28 6c 6f 63 61 6c 2d 74 69 6d 65 2d ecs (local-time-
12960 3e 73 65 63 6f 6e 64 73 20 63 6f 70 79 2d 6e 6f >seconds copy-no
12970 77 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e w)).... (n
12980 65 77 2d 63 6f 70 79 20 20 20 20 20 20 28 73 65 ew-copy (se
12990 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d conds->local-tim
129a0 65 20 63 6f 70 79 2d 6e 6f 77 2d 73 65 63 73 29 e copy-now-secs)
129b0 29 29 20 3b 3b 20 72 65 6d 61 6b 65 20 74 68 65 )) ;; remake the
129c0 20 74 69 6d 65 20 76 65 63 74 6f 72 0a 09 09 09 time vector....
129d0 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 63 (if (or (not c
129e0 64 61 79 6f 66 77 65 65 6b 29 0a 09 09 09 09 20 dayofweek).....
129f0 20 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 (equal? (vector
12a00 2d 72 65 66 20 6e 65 77 2d 63 6f 70 79 20 36 29 -ref new-copy 6)
12a10 0a 09 09 09 09 09 20 20 63 64 61 79 6f 66 77 65 ...... cdayofwe
12a20 65 6b 29 29 20 3b 3b 20 69 66 20 74 68 65 20 64 ek)) ;; if the d
12a30 61 79 20 69 73 20 73 70 65 63 69 66 69 65 64 20 ay is specified
12a40 61 6e 64 20 61 20 6d 61 74 63 68 20 4f 52 20 69 and a match OR i
12a50 66 20 74 68 65 20 64 61 79 20 69 73 20 4e 4f 54 f the day is NOT
12a60 20 73 70 65 63 69 66 69 65 64 0a 09 09 09 20 20 specified....
12a70 20 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 (if (or (not
12a80 20 63 64 61 79 6f 66 6d 6f 6e 74 68 29 0a 09 09 cdayofmonth)...
12a90 09 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 .. (equal?
12aa0 28 76 65 63 74 6f 72 2d 72 65 66 20 6e 65 77 2d (vector-ref new-
12ab0 63 6f 70 79 20 33 29 0a 09 09 09 09 09 20 20 20 copy 3)......
12ac0 20 20 20 28 2b 20 31 20 63 64 61 79 6f 66 6d 6f (+ 1 cdayofmo
12ad0 6e 74 68 29 29 29 20 3b 3b 20 69 66 20 74 68 65 nth))) ;; if the
12ae0 20 6d 6f 6e 74 68 20 69 73 20 73 70 65 63 69 66 month is specif
12af0 69 65 64 20 61 6e 64 20 61 20 6d 61 74 63 68 20 ied and a match
12b00 4f 52 20 69 66 20 74 68 65 20 6d 6f 6e 74 68 20 OR if the month
12b10 69 73 20 4e 4f 54 20 73 70 65 63 69 66 69 65 64 is NOT specified
12b20 0a 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 ..... (hash-tab
12b30 6c 65 2d 73 65 74 21 20 61 6c 6c 2d 74 69 6d 65 le-set! all-time
12b40 73 20 63 6f 70 79 2d 6e 6f 77 2d 73 65 63 73 20 s copy-now-secs
12b50 6e 65 77 2d 63 6f 70 79 29 29 29 29 29 29 0a 09 new-copy))))))..
12b60 09 20 20 20 20 28 69 66 20 63 6d 69 6e 0a 09 09 . (if cmin...
12b70 09 60 28 2c 63 6d 69 6e 29 20 20 3b 3b 20 69 66 .`(,cmin) ;; if
12b80 20 67 69 76 65 6e 20 63 6d 69 6e 2c 20 68 61 76 given cmin, hav
12b90 65 20 74 6f 20 75 73 65 20 69 74 0a 09 09 09 28 e to use it....(
12ba0 6c 69 73 74 20 28 2d 20 6e 6d 69 6e 20 31 29 20 list (- nmin 1)
12bb0 6e 6d 69 6e 20 28 2b 20 6e 6d 69 6e 20 31 29 29 nmin (+ nmin 1))
12bc0 29 29 29 20 3b 3b 20 6d 69 6e 75 74 65 0a 09 09 ))) ;; minute...
12bd0 20 28 69 66 20 63 68 6f 75 72 0a 09 09 20 20 20 (if chour...
12be0 20 20 60 28 2c 63 68 6f 75 72 29 0a 09 09 20 20 `(,chour)...
12bf0 20 20 20 28 6c 69 73 74 20 28 2d 20 6e 68 6f 75 (list (- nhou
12c00 72 20 31 29 20 6e 68 6f 75 72 20 28 2b 20 6e 68 r 1) nhour (+ nh
12c10 6f 75 72 20 31 29 29 29 29 29 20 3b 3b 20 68 6f our 1))))) ;; ho
12c20 75 72 0a 09 20 20 20 20 20 20 28 69 66 20 63 64 ur.. (if cd
12c30 61 79 6f 66 6d 6f 6e 74 68 0a 09 09 20 20 60 28 ayofmonth... `(
12c40 2c 63 64 61 79 6f 66 6d 6f 6e 74 68 29 0a 09 09 ,cdayofmonth)...
12c50 20 20 28 6c 69 73 74 20 28 2d 20 6e 64 61 79 6f (list (- ndayo
12c60 66 6d 6f 6e 74 68 20 31 29 20 6e 64 61 79 6f 66 fmonth 1) ndayof
12c70 6d 6f 6e 74 68 20 28 2b 20 6e 64 61 79 6f 66 6d month (+ ndayofm
12c80 6f 6e 74 68 20 31 29 29 29 29 29 0a 09 20 20 20 onth 1)))))..
12c90 28 69 66 20 63 6d 6f 6e 74 68 0a 09 20 20 20 20 (if cmonth..
12ca0 20 20 20 60 28 2c 63 6d 6f 6e 74 68 29 0a 09 20 `(,cmonth)..
12cb0 20 20 20 20 20 20 28 6c 69 73 74 20 28 2d 20 6e (list (- n
12cc0 6d 6f 6e 74 68 20 31 29 20 6e 6d 6f 6e 74 68 20 month 1) nmonth
12cd0 28 2b 20 6e 6d 6f 6e 74 68 20 31 29 29 29 29 0a (+ nmonth 1)))).
12ce0 09 20 20 28 6c 65 74 20 28 28 62 65 66 6f 72 65 . (let ((before
12cf0 20 23 66 29 0a 09 09 28 69 73 2d 69 6e 20 20 23 #f)...(is-in #
12d00 66 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 f)).. (for-ea
12d10 63 68 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 ch.. (lambda
12d20 20 28 6d 6f 6d 65 6e 74 29 0a 09 20 20 20 20 20 (moment)..
12d30 20 20 28 69 66 20 28 61 6e 64 20 62 65 66 6f 72 (if (and befor
12d40 65 0a 09 09 09 28 3c 3d 20 62 65 66 6f 72 65 20 e....(<= before
12d50 6e 6f 77 2d 73 65 63 6f 6e 64 73 29 0a 09 09 09 now-seconds)....
12d60 28 3e 3d 20 6d 6f 6d 65 6e 74 20 6e 6f 77 2d 73 (>= moment now-s
12d70 65 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 28 62 econds))... (b
12d80 65 67 69 6e 0a 09 09 20 20 20 20 20 3b 3b 20 28 egin... ;; (
12d90 70 72 69 6e 74 29 0a 09 09 20 20 20 20 20 3b 3b print)... ;;
12da0 20 28 70 72 69 6e 74 20 22 42 65 66 6f 72 65 3a (print "Before:
12db0 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 " (time->string
12dc0 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
12dd0 2d 74 69 6d 65 20 62 65 66 6f 72 65 29 29 29 0a -time before))).
12de0 09 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 .. ;; (print
12df0 20 22 4e 6f 77 3a 20 20 20 20 22 20 28 74 69 6d "Now: " (tim
12e00 65 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e e->string (secon
12e10 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6e ds->local-time n
12e20 6f 77 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 ow-seconds)))...
12e30 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 ;; (print "
12e40 41 66 74 65 72 3a 20 20 22 20 28 74 69 6d 65 2d After: " (time-
12e50 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 >string (seconds
12e60 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6d 6f 6d ->local-time mom
12e70 65 6e 74 29 29 29 0a 09 09 20 20 20 20 20 3b 3b ent)))... ;;
12e80 20 28 70 72 69 6e 74 20 22 4c 61 73 74 3a 20 20 (print "Last:
12e90 20 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 " (time->string
12ea0 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c (seconds->local
12eb0 2d 74 69 6d 65 20 6c 61 73 74 2d 64 6f 6e 65 29 -time last-done)
12ec0 29 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 3c ))... (if (<
12ed0 20 20 6c 61 73 74 2d 64 6f 6e 65 20 62 65 66 6f last-done befo
12ee0 72 65 29 0a 09 09 09 20 28 73 65 74 21 20 69 73 re).... (set! is
12ef0 2d 69 6e 20 62 65 66 6f 72 65 29 29 0a 09 09 20 -in before))...
12f00 20 20 20 20 29 29 0a 09 20 20 20 20 20 20 20 28 )).. (
12f10 73 65 74 21 20 62 65 66 6f 72 65 20 6d 6f 6d 65 set! before mome
12f20 6e 74 29 29 0a 09 20 20 20 20 20 28 73 6f 72 74 nt)).. (sort
12f30 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
12f40 73 20 61 6c 6c 2d 74 69 6d 65 73 29 20 3c 29 29 s all-times) <))
12f50 0a 09 20 20 20 20 69 73 2d 69 6e 29 29 29 29 29 .. is-in)))))
12f60 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
12f70 6e 3a 65 78 74 65 6e 64 65 64 2d 63 72 6f 6e 20 n:extended-cron
12f80 20 63 72 6f 6e 2d 73 74 72 20 6e 6f 77 2d 73 65 cron-str now-se
12f90 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 2d 64 6f conds-in last-do
12fa0 6e 65 29 0a 20 20 28 6c 65 74 20 28 28 65 78 70 ne). (let ((exp
12fb0 61 6e 64 65 64 2d 63 72 6f 6e 20 28 63 6f 6d 6d anded-cron (comm
12fc0 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 63 on:cron-expand c
12fd0 72 6f 6e 2d 73 74 72 29 29 29 0a 20 20 20 20 28 ron-str))). (
12fe0 69 66 20 28 73 74 72 69 6e 67 3f 20 65 78 70 61 if (string? expa
12ff0 6e 64 65 64 2d 63 72 6f 6e 29 0a 09 28 63 6f 6d nded-cron)..(com
13000 6d 6f 6e 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 65 mon:cron-event e
13010 78 70 61 6e 64 65 64 2d 63 72 6f 6e 20 6e 6f 77 xpanded-cron now
13020 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 -seconds-in last
13030 2d 64 6f 6e 65 29 0a 09 28 6c 65 74 20 6c 6f 6f -done)..(let loo
13040 70 20 28 28 68 65 64 20 28 63 61 72 20 65 78 70 p ((hed (car exp
13050 61 6e 64 65 64 2d 63 72 6f 6e 29 29 0a 09 09 20 anded-cron))...
13060 20 20 28 74 61 6c 20 28 63 64 72 20 65 78 70 61 (tal (cdr expa
13070 6e 64 65 64 2d 63 72 6f 6e 29 29 29 0a 09 20 20 nded-cron)))..
13080 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e (if (common:cron
13090 2d 65 76 65 6e 74 20 68 65 64 20 6e 6f 77 2d 73 -event hed now-s
130a0 65 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 2d 64 econds-in last-d
130b0 6f 6e 65 29 0a 09 20 20 20 20 20 20 23 74 0a 09 one).. #t..
130c0 20 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f (if (null?
130d0 20 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 tal)... #f...
130e0 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 (loop (car tal)
130f0 28 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 (cdr tal))))))))
13100 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ..;;============
13110 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13120 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13130 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13140 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 20 ==========.;; C
13150 4f 20 4c 20 4f 20 52 20 53 0a 3b 3b 3d 3d 3d 3d O L O R S.;;====
13160 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13170 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13180 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13190 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
131a0 3d 3d 0a 20 20 20 20 20 20 0a 28 64 65 66 69 6e ==. .(defin
131b0 65 20 28 63 6f 6d 6d 6f 6e 3a 6e 61 6d 65 2d 3e e (common:name->
131c0 69 75 70 2d 63 6f 6c 6f 72 20 6e 61 6d 65 29 0a iup-color name).
131d0 20 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d (case (string-
131e0 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d >symbol (string-
131f0 64 6f 77 6e 63 61 73 65 20 6e 61 6d 65 29 29 0a downcase name)).
13200 20 20 20 20 28 28 72 65 64 29 20 20 20 20 22 32 ((red) "2
13210 32 33 20 33 33 20 34 39 22 29 0a 20 20 20 20 28 23 33 49"). (
13220 28 67 72 65 79 29 20 20 20 22 31 39 32 20 31 39 (grey) "192 19
13230 32 20 31 39 32 22 29 0a 20 20 20 20 28 28 6f 72 2 192"). ((or
13240 61 6e 67 65 29 20 22 32 35 35 20 31 37 32 20 31 ange) "255 172 1
13250 33 22 29 0a 20 20 20 20 28 28 70 75 72 70 6c 65 3"). ((purple
13260 29 20 22 54 68 69 73 20 69 73 20 75 6e 66 69 6e ) "This is unfin
13270 69 73 68 65 64 20 2e 2e 2e 22 29 29 29 0a 0a 3b ished ...")))..;
13280 3b 20 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ; (define (commo
13290 6e 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 6f 72 2d n:get-color-for-
132a0 73 74 61 74 65 2d 73 74 61 74 75 73 20 73 74 61 state-status sta
132b0 74 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 te status).;;
132c0 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 (case (string->s
132d0 79 6d 62 6f 6c 20 73 74 61 74 65 29 0a 3b 3b 20 ymbol state).;;
132e0 20 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 29 ((COMPLETED)
132f0 0a 3b 3b 20 20 20 20 20 20 28 63 61 73 65 20 28 .;; (case (
13300 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 string->symbol s
13310 74 61 74 75 73 29 0a 3b 3b 20 20 20 20 20 20 20 tatus).;;
13320 20 28 28 50 41 53 53 29 20 20 20 20 20 20 20 20 ((PASS)
13330 22 37 30 20 20 32 34 39 20 37 33 22 29 0a 3b 3b "70 249 73").;;
13340 20 20 20 20 20 20 20 20 28 28 57 41 52 4e 20 57 ((WARN W
13350 41 49 56 45 44 29 20 22 32 35 35 20 31 37 32 20 AIVED) "255 172
13360 31 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 13").;; (
13370 28 53 4b 49 50 29 20 20 20 20 20 20 20 20 22 32 (SKIP) "2
13380 33 30 20 32 33 30 20 30 22 29 0a 3b 3b 20 20 20 30 230 0").;;
13390 20 20 20 20 20 28 65 6c 73 65 20 22 32 32 33 20 (else "223
133a0 33 33 20 34 39 22 29 29 29 0a 3b 3b 20 20 20 20 33 49"))).;;
133b0 20 28 28 4c 41 55 4e 43 48 45 44 29 20 20 20 20 ((LAUNCHED)
133c0 20 20 20 20 20 22 31 30 31 20 31 32 33 20 31 34 "101 123 14
133d0 32 22 29 0a 3b 3b 20 20 20 20 20 28 28 43 48 45 2").;; ((CHE
133e0 43 4b 29 20 20 20 20 20 20 20 20 20 20 20 20 22 CK) "
133f0 32 35 35 20 31 30 30 20 35 30 22 29 0a 3b 3b 20 255 100 50").;;
13400 20 20 20 20 28 28 52 45 4d 4f 54 45 48 4f 53 54 ((REMOTEHOST
13410 53 54 41 52 54 29 20 20 22 35 30 20 20 31 33 30 START) "50 130
13420 20 31 39 35 22 29 0a 3b 3b 20 20 20 20 20 28 28 195").;; ((
13430 52 55 4e 4e 49 4e 47 29 20 20 20 20 20 20 20 20 RUNNING)
13440 20 20 22 39 20 20 20 31 33 31 20 32 33 32 22 29 "9 131 232")
13450 0a 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c 52 45 .;; ((KILLRE
13460 51 29 20 20 20 20 20 20 20 20 20 20 22 33 39 20 Q) "39
13470 20 38 32 20 20 32 30 36 22 29 0a 3b 3b 20 20 20 82 206").;;
13480 20 20 28 28 4b 49 4c 4c 45 44 29 20 20 20 20 20 ((KILLED)
13490 20 20 20 20 20 20 22 32 33 34 20 31 30 31 20 31 "234 101 1
134a0 37 22 29 0a 3b 3b 20 20 20 20 20 28 28 4e 4f 54 7").;; ((NOT
134b0 5f 53 54 41 52 54 45 44 29 20 20 20 20 20 20 22 _STARTED) "
134c0 32 34 30 20 32 34 30 20 32 34 30 22 29 0a 3b 3b 240 240 240").;;
134d0 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 (else
134e0 20 20 20 20 20 20 20 20 20 22 31 39 32 20 31 39 "192 19
134f0 32 20 31 39 32 22 29 29 29 0a 0a 28 64 65 66 69 2 192")))..(defi
13500 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 69 75 70 2d 63 ne (common:iup-c
13510 6f 6c 6f 72 2d 3e 72 67 62 2d 68 65 78 20 69 6e olor->rgb-hex in
13520 73 74 72 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 str). (string-i
13530 6e 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 ntersperse . (
13540 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
13550 20 20 20 20 20 20 20 20 20 20 28 6e 75 6d 62 65 (numbe
13560 72 2d 3e 73 74 72 69 6e 67 20 78 20 31 36 29 29 r->string x 16))
13570 0a 20 20 20 20 20 20 20 20 28 6d 61 70 20 73 74 . (map st
13580 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 20 20 20 ring->number.
13590 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
135a0 67 2d 73 70 6c 69 74 20 69 6e 73 74 72 29 29 29 g-split instr)))
135b0 0a 20 20 20 22 2f 22 29 29 0a 0a 3b 3b 3d 3d 3d . "/"))..;;===
135c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
135d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
135e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
135f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13600 3d 3d 3d 0a 3b 3b 20 4c 20 4f 20 43 20 4b 20 49 ===.;; L O C K I
13610 20 4e 20 47 20 20 20 4d 20 45 20 43 20 48 20 41 N G M E C H A
13620 20 4e 20 49 20 53 20 4d 20 53 20 0a 3b 3b 3d 3d N I S M S .;;==
13630 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13640 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13650 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13660 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13670 3d 3d 3d 3d 0a 0a 3b 3b 20 66 61 75 78 2d 6c 6f ====..;; faux-lo
13680 63 6b 20 69 73 20 64 65 70 72 65 63 61 74 65 64 ck is deprecated
13690 2e 20 50 6c 65 61 73 65 20 75 73 65 20 73 69 6d . Please use sim
136a0 70 6c 65 2d 6c 6f 63 6b 20 62 65 6c 6f 77 0a 3b ple-lock below.;
136b0 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
136c0 6e 3a 66 61 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e n:faux-lock keyn
136d0 61 6d 65 20 23 21 6b 65 79 20 28 77 61 69 74 2d ame #!key (wait-
136e0 74 69 6d 65 20 38 29 28 61 6c 6c 6f 77 2d 6c 6f time 8)(allow-lo
136f0 63 6b 2d 73 74 65 61 6c 20 23 74 29 29 0a 20 20 ck-steal #t)).
13700 28 69 66 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 (if (rmt:no-sync
13710 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 6b 65 79 -get/default key
13720 6e 61 6d 65 20 23 66 29 20 3b 3b 20 64 6f 20 6e name #f) ;; do n
13730 6f 74 20 62 65 20 74 65 6d 70 74 65 64 20 74 6f ot be tempted to
13740 20 63 6f 6d 70 61 72 65 20 74 6f 20 70 69 64 2e compare to pid.
13750 20 6c 6f 63 6b 69 6e 67 20 69 73 20 61 20 6f 6e locking is a on
13760 65 2d 73 68 6f 74 20 61 63 74 69 6f 6e 2c 20 69 e-shot action, i
13770 66 20 61 6c 72 65 61 64 79 20 6c 6f 63 6b 65 64 f already locked
13780 20 66 6f 72 20 74 68 69 73 20 70 69 64 20 69 74 for this pid it
13790 20 64 6f 65 73 6e 27 74 20 61 63 74 75 61 6c 6c doesn't actuall
137a0 79 20 63 6f 75 6e 74 0a 20 20 20 20 20 20 28 69 y count. (i
137b0 66 20 28 3e 20 77 61 69 74 2d 74 69 6d 65 20 30 f (> wait-time 0
137c0 29 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 ).. (begin..
137d0 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 (thread-sleep!
137e0 31 29 0a 09 20 20 20 20 28 69 66 20 28 65 71 3f 1).. (if (eq?
137f0 20 77 61 69 74 2d 74 69 6d 65 20 31 29 20 3b 3b wait-time 1) ;;
13800 20 6f 6e 6c 79 20 6f 6e 65 20 73 65 63 6f 6e 64 only one second
13810 20 6c 65 66 74 2c 20 73 74 65 61 6c 20 74 68 65 left, steal the
13820 20 6c 6f 63 6b 0a 09 09 28 62 65 67 69 6e 0a 09 lock...(begin..
13830 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d . (debug:print-
13840 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
13850 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 74 65 61 6c log-port* "steal
13860 69 6e 67 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6b ing lock for " k
13870 65 79 6e 61 6d 65 29 0a 09 09 20 20 28 63 6f 6d eyname)... (com
13880 6d 6f 6e 3a 66 61 75 78 2d 75 6e 6c 6f 63 6b 20 mon:faux-unlock
13890 6b 65 79 6e 61 6d 65 20 66 6f 72 63 65 3a 20 23 keyname force: #
138a0 74 29 29 29 0a 09 20 20 20 20 28 63 6f 6d 6d 6f t))).. (commo
138b0 6e 3a 66 61 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e n:faux-lock keyn
138c0 61 6d 65 20 77 61 69 74 2d 74 69 6d 65 3a 20 28 ame wait-time: (
138d0 2d 20 77 61 69 74 2d 74 69 6d 65 20 31 29 29 29 - wait-time 1)))
138e0 0a 09 20 20 23 66 29 0a 20 20 20 20 20 20 28 62 .. #f). (b
138f0 65 67 69 6e 0a 20 20 20 20 20 20 20 20 28 72 6d egin. (rm
13900 74 3a 6e 6f 2d 73 79 6e 63 2d 73 65 74 20 6b 65 t:no-sync-set ke
13910 79 6e 61 6d 65 20 28 63 6f 6e 63 20 28 63 75 72 yname (conc (cur
13920 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
13930 29 29 0a 20 20 20 20 20 20 20 20 28 65 71 75 61 )). (equa
13940 6c 3f 20 28 63 6f 6e 63 20 28 63 75 72 72 65 6e l? (conc (curren
13950 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 20 28 t-process-id)) (
13960 63 6f 6e 63 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e conc (rmt:no-syn
13970 63 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 6b 65 c-get/default ke
13980 79 6e 61 6d 65 20 23 66 29 29 29 29 29 29 0a 0a yname #f))))))..
13990 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
139a0 66 61 75 78 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e faux-unlock keyn
139b0 61 6d 65 20 23 21 6b 65 79 20 28 66 6f 72 63 65 ame #!key (force
139c0 20 23 66 29 29 0a 20 20 28 69 66 20 28 6f 72 20 #f)). (if (or
139d0 66 6f 72 63 65 20 28 65 71 75 61 6c 3f 20 28 63 force (equal? (c
139e0 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 72 6f onc (current-pro
139f0 63 65 73 73 2d 69 64 29 29 20 28 63 6f 6e 63 20 cess-id)) (conc
13a00 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (rmt:no-sync-get
13a10 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 /default keyname
13a20 20 23 66 29 29 29 29 0a 20 20 20 20 20 20 28 62 #f)))). (b
13a30 65 67 69 6e 0a 20 20 20 20 20 20 20 20 28 69 66 egin. (if
13a40 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 (rmt:no-sync-ge
13a50 74 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d t/default keynam
13a60 65 20 23 66 29 20 28 72 6d 74 3a 6e 6f 2d 73 79 e #f) (rmt:no-sy
13a70 6e 63 2d 64 65 6c 21 20 6b 65 79 6e 61 6d 65 29 nc-del! keyname)
13a80 29 0a 20 20 20 20 20 20 20 20 23 74 29 0a 20 20 ). #t).
13a90 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 73 69 6d #f))..;; sim
13aa0 70 6c 65 20 6c 6f 63 6b 2e 20 69 6d 70 72 6f 76 ple lock. improv
13ab0 65 20 61 6e 64 20 63 6f 6e 76 65 72 67 65 20 6f e and converge o
13ac0 6e 20 74 68 69 73 20 6f 6e 65 2e 0a 3b 3b 0a 28 n this one..;;.(
13ad0 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
13ae0 69 6d 70 6c 65 2d 6c 6f 63 6b 20 6b 65 79 6e 61 imple-lock keyna
13af0 6d 65 29 0a 20 20 28 72 6d 74 3a 6e 6f 2d 73 79 me). (rmt:no-sy
13b00 6e 63 2d 67 65 74 2d 6c 6f 63 6b 20 6b 65 79 6e nc-get-lock keyn
13b10 61 6d 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d ame))..;;=======
13b20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
13b60 3b 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;.;;===========
13b70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13ba0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
13bb0 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d fine (common:in-
13bc0 72 75 6e 6e 69 6e 67 2d 74 65 73 74 3f 29 0a 20 running-test?).
13bd0 20 28 61 6e 64 20 28 61 72 67 73 3a 67 65 74 2d (and (args:get-
13be0 61 72 67 20 22 2d 65 78 65 63 75 74 65 22 29 20 arg "-execute")
13bf0 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
13c00 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 43 4d -variable "MT_CM
13c10 44 49 4e 46 4f 22 29 29 29 0a 0a 28 64 65 66 69 DINFO")))..(defi
13c20 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 ne (common:get-c
13c30 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 olor-from-status
13c40 20 73 74 61 74 75 73 29 0a 20 20 28 63 6f 6e 64 status). (cond
13c50 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
13c60 74 75 73 20 22 50 41 53 53 22 29 20 20 20 20 22 tus "PASS") "
13c70 67 72 65 65 6e 22 29 0a 20 20 20 28 28 65 71 75 green"). ((equ
13c80 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c al? status "FAIL
13c90 22 29 20 20 20 20 22 72 65 64 22 29 0a 20 20 20 ") "red").
13ca0 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
13cb0 22 57 41 52 4e 22 29 20 20 20 20 22 6f 72 61 6e "WARN") "oran
13cc0 67 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ge"). ((equal?
13cd0 20 73 74 61 74 75 73 20 22 4b 49 4c 4c 45 44 22 status "KILLED"
13ce0 29 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 ) "orange").
13cf0 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
13d00 22 4b 49 4c 4c 52 45 51 22 29 20 22 70 75 72 70 "KILLREQ") "purp
13d10 6c 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f le"). ((equal?
13d20 20 73 74 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 status "RUNNING
13d30 22 29 20 22 62 6c 75 65 22 29 0a 20 20 20 28 28 ") "blue"). ((
13d40 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 41 equal? status "A
13d50 42 4f 52 54 22 29 20 20 20 22 62 72 6f 77 6e 22 BORT") "brown"
13d60 29 0a 20 20 20 28 65 6c 73 65 20 22 62 6c 61 63 ). (else "blac
13d70 6b 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d k")))..;;=======
13d80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13d90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13da0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13db0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
13dc0 3b 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 53 20 47 ;; N A N O M S G
13dd0 20 20 20 43 20 4c 20 49 20 45 20 4e 20 54 0a 3b C L I E N T.;
13de0 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
13df0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13e20 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
13e30 20 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 (server:get-bes
13e40 74 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 t-guess-address
13e50 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 hostname). (let
13e60 20 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 ((res #f)).
13e70 28 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 (for-each .
13e80 28 6c 61 6d 62 64 61 20 28 61 64 72 29 0a 20 20 (lambda (adr).
13e90 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
13ea0 71 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 65 66 q? (u8vector-ref
13eb0 20 61 64 72 20 30 29 20 31 32 37 29 29 0a 09 20 adr 0) 127))..
13ec0 20 20 28 73 65 74 21 20 72 65 73 20 61 64 72 29 (set! res adr)
13ed0 29 29 0a 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a )). ;; NOTE:
13ee0 20 54 68 69 73 20 63 61 6e 20 66 61 69 6c 20 77 This can fail w
13ef0 68 65 6e 20 74 68 65 72 65 20 69 73 20 6e 6f 20 hen there is no
13f00 6d 65 6e 74 69 6f 6e 20 6f 66 20 74 68 65 20 68 mention of the h
13f10 6f 73 74 20 69 6e 20 2f 65 74 63 2f 68 6f 73 74 ost in /etc/host
13f20 73 2e 20 46 49 58 4d 45 0a 20 20 20 20 20 28 76 s. FIXME. (v
13f30 65 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 ector->list (hos
13f40 74 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 tinfo-addresses
13f50 28 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 (hostname->hosti
13f60 6e 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 nfo hostname))))
13f70 0a 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 . (string-int
13f80 65 72 73 70 65 72 73 65 20 0a 20 20 20 20 20 28 ersperse . (
13f90 6d 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 map number->stri
13fa0 6e 67 0a 09 20 20 28 75 38 76 65 63 74 6f 72 2d ng.. (u8vector-
13fb0 3e 6c 69 73 74 0a 09 20 20 20 28 69 66 20 72 65 >list.. (if re
13fc0 73 20 72 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d s res (hostname-
13fd0 3e 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 >ip hostname))))
13fe0 20 22 2e 22 29 29 29 0a 0a 0a 28 64 65 66 69 6e ".")))...(defin
13ff0 65 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e 64 2d 64 e (common:send-d
14000 62 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 61 6e 67 board-main-chang
14010 65 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 61 ed). (let* ((da
14020 73 68 62 6f 61 72 64 2d 69 70 73 20 28 6d 64 64 shboard-ips (mdd
14030 62 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 64 73 b:get-dashboards
14040 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ))). (for-eac
14050 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
14060 69 70 61 64 72 29 0a 20 20 20 20 20 20 20 28 6c ipadr). (l
14070 65 74 2a 20 28 28 73 6f 63 20 28 63 6f 6d 6d 6f et* ((soc (commo
14080 6e 3a 6f 70 65 6e 2d 6e 6d 2d 72 65 71 20 28 63 n:open-nm-req (c
14090 6f 6e 63 20 22 74 63 70 3a 2f 2f 22 20 69 70 61 onc "tcp://" ipa
140a0 64 72 29 29 29 0a 09 20 20 20 20 20 20 28 6d 73 dr))).. (ms
140b0 67 20 28 63 6f 6e 63 20 22 6d 61 69 6e 20 22 20 g (conc "main "
140c0 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 20 20 *toppath*))..
140d0 20 20 20 28 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a (res (common:
140e0 6e 6d 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 2d nm-send-receive-
140f0 74 69 6d 65 6f 75 74 20 73 6f 63 20 6d 73 67 29 timeout soc msg)
14100 29 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 72 65 )).. (if (not re
14110 73 29 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 s) ;; couldn't r
14120 65 61 63 68 20 74 68 61 74 20 64 61 73 68 62 6f each that dashbo
14130 61 72 64 20 2d 20 72 65 6d 6f 76 65 20 69 74 20 ard - remove it
14140 66 72 6f 6d 20 64 62 0a 09 20 20 20 20 20 28 70 from db.. (p
14150 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 63 6f 75 rint "ERROR: cou
14160 6c 64 6e 27 74 20 72 65 61 63 68 20 64 61 73 68 ldn't reach dash
14170 62 6f 61 72 64 20 22 20 69 70 61 64 72 29 29 0a board " ipadr)).
14180 09 20 72 65 73 29 29 0a 20 20 20 20 20 64 61 73 . res)). das
14190 68 62 6f 61 72 64 2d 69 70 73 29 29 29 0a 20 20 hboard-ips))).
141a0 20 20 0a 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d . .;;======
141b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
141c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
141d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
141e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
141f0 0a 3b 3b 20 44 20 41 20 53 20 48 20 42 20 4f 20 .;; D A S H B O
14200 41 20 52 20 44 20 20 20 44 20 42 20 0a 3b 3b 3d A R D D B .;;=
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 0a 28 64 65 66 69 6e 65 20 28 =====..(define (
14260 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 0a 20 20 mddb:open-db).
14270 28 6c 65 74 2a 20 28 28 64 62 20 28 6f 70 65 6e (let* ((db (open
14280 2d 64 61 74 61 62 61 73 65 20 28 63 6f 6e 63 20 -database (conc
14290 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
142a0 2d 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 22 -variable "HOME"
142b0 29 20 22 2f 2e 64 61 73 68 62 6f 61 72 64 2e 64 ) "/.dashboard.d
142c0 62 22 29 29 29 29 0a 20 20 20 20 28 73 65 74 2d b")))). (set-
142d0 62 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 busy-handler! db
142e0 20 28 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 (busy-timeout 1
142f0 30 30 30 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 0000)). (for-
14300 65 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 each. (lambd
14310 61 20 28 71 72 79 29 0a 20 20 20 20 20 20 20 28 a (qry). (
14320 65 78 65 63 20 28 73 71 6c 20 64 62 20 71 72 79 exec (sql db qry
14330 29 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 0a ))). (list .
14340 20 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 "CREATE TA
14350 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 BLE IF NOT EXIST
14360 53 20 76 61 72 73 20 20 20 20 20 20 20 28 69 64 S vars (id
14370 20 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 INTEGER PRIMARY
14380 20 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 20 76 KEY,key TEXT, v
14390 61 6c 20 54 45 58 54 2c 20 43 4f 4e 53 54 52 41 al TEXT, CONSTRA
143a0 49 4e 54 20 76 61 72 73 63 6f 6e 73 74 72 61 69 INT varsconstrai
143b0 6e 74 20 55 4e 49 51 55 45 20 28 6b 65 79 29 29 nt UNIQUE (key))
143c0 3b 22 0a 20 20 20 20 20 20 22 43 52 45 41 54 45 ;". "CREATE
143d0 20 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 TABLE IF NOT EX
143e0 49 53 54 53 20 64 61 73 68 62 6f 61 72 64 73 20 ISTS dashboards
143f0 28 0a 20 20 20 20 20 20 20 20 20 20 69 64 20 20 (. id
14400 20 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 INTEGER P
14410 52 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 RIMARY KEY,.
14420 20 20 20 20 20 20 70 69 64 20 20 20 20 20 20 20 pid
14430 20 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 INTEGER,.
14440 20 20 20 20 75 73 65 72 6e 61 6d 65 20 20 20 54 username T
14450 45 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 68 EXT,. h
14460 6f 73 74 6e 61 6d 65 20 20 20 54 45 58 54 2c 0a ostname TEXT,.
14470 20 20 20 20 20 20 20 20 20 20 69 70 61 64 64 72 ipaddr
14480 20 20 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 TEXT,.
14490 20 20 20 20 20 70 6f 72 74 6e 75 6d 20 20 20 20 portnum
144a0 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 INTEGER,.
144b0 20 20 20 73 74 61 72 74 5f 74 69 6d 65 20 54 49 start_time TI
144c0 4d 45 53 54 41 4d 50 20 44 45 46 41 55 4c 54 20 MESTAMP DEFAULT
144d0 28 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 (strftime('%s','
144e0 6e 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 20 20 now')),.
144f0 20 20 20 20 20 43 4f 4e 53 54 52 41 49 4e 54 20 CONSTRAINT
14500 68 6f 73 74 70 6f 72 74 20 55 4e 49 51 55 45 20 hostport UNIQUE
14510 28 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 6e 75 (hostname,portnu
14520 6d 29 0a 20 20 20 20 20 20 20 20 29 3b 22 0a 20 m). );".
14530 20 20 20 20 20 29 29 0a 20 20 20 20 64 62 29 29 )). db))
14540 0a 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 ..;; register a
14550 64 61 73 68 62 6f 61 72 64 20 0a 3b 3b 0a 28 64 dashboard .;;.(d
14560 65 66 69 6e 65 20 28 6d 64 64 62 3a 72 65 67 69 efine (mddb:regi
14570 73 74 65 72 2d 64 61 73 68 62 6f 61 72 64 20 70 ster-dashboard p
14580 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 ort). (let* ((p
14590 69 64 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 id (current
145a0 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 09 20 -process-id))..
145b0 28 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 (hostname (get-h
145c0 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 ost-name)).. (ip
145d0 61 64 64 72 20 20 20 28 73 65 72 76 65 72 3a 67 addr (server:g
145e0 65 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 et-best-guess-ad
145f0 64 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 29 dress hostname))
14600 0a 09 20 28 75 73 65 72 6e 61 6d 65 20 28 63 75 .. (username (cu
14610 72 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 rrent-user-name)
14620 29 20 3b 3b 20 28 63 61 72 20 75 73 65 72 69 6e ) ;; (car userin
14630 66 6f 29 29 29 0a 09 20 28 64 62 20 20 20 20 20 fo))).. (db
14640 20 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 (mddb:open-db))
14650 29 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 ). (print "Re
14660 67 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 gister monitor,
14670 70 69 64 3a 20 22 20 70 69 64 20 22 2c 20 68 6f pid: " pid ", ho
14680 73 74 6e 61 6d 65 3a 20 22 20 68 6f 73 74 6e 61 stname: " hostna
14690 6d 65 20 22 2c 20 70 6f 72 74 3a 20 22 20 70 6f me ", port: " po
146a0 72 74 20 22 2c 20 75 73 65 72 6e 61 6d 65 3a 20 rt ", username:
146b0 22 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 20 " username).
146c0 28 65 78 65 63 20 28 73 71 6c 20 64 62 20 22 49 (exec (sql db "I
146d0 4e 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 NSERT OR REPLACE
146e0 20 49 4e 54 4f 20 64 61 73 68 62 6f 61 72 64 73 INTO dashboards
146f0 20 28 70 69 64 2c 75 73 65 72 6e 61 6d 65 2c 68 (pid,username,h
14700 6f 73 74 6e 61 6d 65 2c 69 70 61 64 64 72 2c 70 ostname,ipaddr,p
14710 6f 72 74 6e 75 6d 29 20 56 41 4c 55 45 53 20 28 ortnum) VALUES (
14720 3f 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 ?,?,?,?,?);")..
14730 20 20 70 69 64 20 75 73 65 72 6e 61 6d 65 20 68 pid username h
14740 6f 73 74 6e 61 6d 65 20 69 70 61 64 64 72 20 70 ostname ipaddr p
14750 6f 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d ort). (close-
14760 64 61 74 61 62 61 73 65 20 64 62 29 29 29 0a 0a database db)))..
14770 3b 3b 20 75 6e 72 65 67 69 73 74 65 72 20 61 20 ;; unregister a
14780 6d 6f 6e 69 74 6f 72 0a 3b 3b 0a 28 64 65 66 69 monitor.;;.(defi
14790 6e 65 20 28 6d 64 64 62 3a 75 6e 72 65 67 69 73 ne (mddb:unregis
147a0 74 65 72 2d 64 61 73 68 62 6f 61 72 64 20 68 6f ter-dashboard ho
147b0 73 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a st port). (let*
147c0 20 28 28 64 62 20 20 20 20 20 20 28 6d 64 64 62 ((db (mddb
147d0 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 :open-db))).
147e0 28 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 (print "Register
147f0 20 75 6e 72 65 67 69 73 74 65 72 20 6d 6f 6e 69 unregister moni
14800 74 6f 72 2c 20 68 6f 73 74 3a 70 6f 72 74 3d 22 tor, host:port="
14810 20 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 0a host ":" port).
14820 20 20 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 (exec (sql d
14830 62 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 64 b "DELETE FROM d
14840 61 73 68 62 6f 61 72 64 73 20 57 48 45 52 45 20 ashboards WHERE
14850 68 6f 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 70 hostname=? AND p
14860 6f 72 74 6e 75 6d 3d 3f 3b 22 29 20 68 6f 73 74 ortnum=?;") host
14870 20 70 6f 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 port). (clos
14880 65 2d 64 61 74 61 62 61 73 65 20 64 62 29 29 29 e-database db)))
14890 0a 0a 3b 3b 20 67 65 74 20 72 65 67 69 73 74 65 ..;; get registe
148a0 72 65 64 20 64 61 73 68 62 6f 61 72 64 73 0a 3b red dashboards.;
148b0 3b 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a ;.(define (mddb:
148c0 67 65 74 2d 64 61 73 68 62 6f 61 72 64 73 29 0a get-dashboards).
148d0 20 20 28 6c 65 74 20 28 28 64 62 20 28 6d 64 64 (let ((db (mdd
148e0 62 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 b:open-db))).
148f0 20 28 71 75 65 72 79 20 66 65 74 63 68 2d 63 6f (query fetch-co
14900 6c 75 6d 6e 0a 09 20 20 20 28 73 71 6c 20 64 62 lumn.. (sql db
14910 20 22 53 45 4c 45 43 54 20 69 70 61 64 64 72 20 "SELECT ipaddr
14920 7c 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 74 6e 75 || ':' || portnu
14930 6d 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 m FROM dashboard
14940 73 3b 22 29 29 29 29 0a 20 20 20 20 0a 3b 3b 3d s;")))). .;;=
14950 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14960 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14970 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14980 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14990 3d 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 =====.;; T E S
149a0 54 20 20 20 4c 20 41 20 55 20 4e 20 43 20 48 20 T L A U N C H
149b0 49 20 4e 20 47 20 20 20 50 20 45 20 52 20 20 20 I N G P E R
149c0 49 20 54 20 45 20 4d 20 20 20 57 20 49 20 54 20 I T E M W I T
149d0 48 20 20 20 48 20 4f 20 53 20 54 20 20 20 54 20 H H O S T T
149e0 59 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d Y P E S.;;======
149f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14a00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14a10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14a20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14a30 0a 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 73 5d 0a .;; .;; [hosts].
14a40 3b 3b 20 61 72 6d 20 63 75 62 69 65 30 31 20 63 ;; arm cubie01 c
14a50 75 62 69 65 30 32 0a 3b 3b 20 78 38 36 5f 36 34 ubie02.;; x86_64
14a60 20 7a 65 75 73 20 78 65 6e 61 20 6d 79 74 68 30 zeus xena myth0
14a70 31 0a 3b 3b 20 61 6c 6c 68 6f 73 74 73 20 23 7b 1.;; allhosts #{
14a80 67 20 68 6f 73 74 73 20 61 72 6d 7d 20 23 7b 67 g hosts arm} #{g
14a90 20 68 6f 73 74 73 20 78 38 36 5f 36 34 7d 0a 3b hosts x86_64}.;
14aa0 3b 20 0a 3b 3b 20 5b 68 6f 73 74 2d 74 79 70 65 ; .;; [host-type
14ab0 73 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 23 4d s].;; general #M
14ac0 54 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 TLOWESTLOAD #{g
14ad0 68 6f 73 74 73 20 61 6c 6c 68 6f 73 74 73 7d 0a hosts allhosts}.
14ae0 3b 3b 20 61 72 6d 20 20 20 20 20 23 4d 54 4c 4f ;; arm #MTLO
14af0 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 68 6f 73 WESTLOAD #{g hos
14b00 74 73 20 61 72 6d 7d 0a 3b 3b 20 6e 62 67 65 6e ts arm}.;; nbgen
14b10 65 72 61 6c 20 6e 62 6a 6f 62 20 72 75 6e 20 4a eral nbjob run J
14b20 4f 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f 67 20 24 OBCOMMAND -log $
14b30 4d 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 4d 54 5f MT_LINKTREE/$MT_
14b40 54 41 52 47 45 54 2f 24 4d 54 5f 52 55 4e 4e 41 TARGET/$MT_RUNNA
14b50 4d 45 2e 24 4d 54 5f 54 45 53 54 4e 41 4d 45 2d ME.$MT_TESTNAME-
14b60 24 4d 54 5f 49 54 45 4d 5f 50 41 54 48 2e 6c 67 $MT_ITEM_PATH.lg
14b70 6f 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 6e 63 68 o.;; .;; [launch
14b80 65 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 74 75 70 ers].;; envsetup
14b90 20 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 6f 72 2f general.;; xor/
14ba0 25 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 25 20 6e %/n 4C16G.;; % n
14bb0 62 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a 3b 3b 20 bgeneral.;; .;;
14bc0 5b 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b 20 23 20 [jobtools].;; #
14bd0 69 66 20 64 65 66 69 6e 65 64 20 61 6e 64 20 6e if defined and n
14be0 6f 74 20 22 6e 6f 22 20 66 6c 65 78 69 2d 6c 61 ot "no" flexi-la
14bf0 75 6e 63 68 65 72 20 77 69 6c 6c 20 62 79 70 61 uncher will bypa
14c00 73 73 20 22 6c 61 75 6e 63 68 65 72 22 20 75 6e ss "launcher" un
14c10 6c 65 73 73 20 6e 6f 20 6d 61 74 63 68 2e 0a 3b less no match..;
14c20 3b 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 ; flexi-launcher
14c30 20 79 65 73 20 20 0a 3b 3b 20 6c 61 75 6e 63 68 yes .;; launch
14c40 65 72 20 6e 62 66 61 6b 65 0a 3b 3b 0a 28 64 65 er nbfake.;;.(de
14c50 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
14c60 2d 6c 61 75 6e 63 68 65 72 20 63 6f 6e 66 69 67 -launcher config
14c70 64 61 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 dat testname ite
14c80 6d 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 mpath). (let ((
14c90 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 fallback-launche
14ca0 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 r (configf:looku
14cb0 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 p configdat "job
14cc0 74 6f 6f 6c 73 22 20 22 6c 61 75 6e 63 68 65 72 tools" "launcher
14cd0 22 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e "))). (if (an
14ce0 64 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 d (configf:looku
14cf0 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 p configdat "job
14d00 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 tools" "flexi-la
14d10 75 6e 63 68 65 72 22 29 20 3b 3b 20 6f 76 65 72 uncher") ;; over
14d20 72 69 64 65 73 20 6c 61 75 6e 63 68 65 72 0a 09 rides launcher..
14d30 20 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c (not (equal
14d40 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 ? (configf:looku
14d50 70 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 p configdat "job
14d60 74 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 tools" "flexi-la
14d70 75 6e 63 68 65 72 22 29 20 22 6e 6f 22 29 29 29 uncher") "no")))
14d80 0a 09 28 6c 65 74 2a 20 28 28 6c 61 75 6e 63 68 ..(let* ((launch
14d90 65 72 73 20 20 20 20 20 20 20 20 20 28 68 61 73 ers (has
14da0 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 h-table-ref/defa
14db0 75 6c 74 20 63 6f 6e 66 69 67 64 61 74 20 22 6c ult configdat "l
14dc0 61 75 6e 63 68 65 72 73 22 20 27 28 29 29 29 29 aunchers" '())))
14dd0 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c .. (if (null? l
14de0 61 75 6e 63 68 65 72 73 29 0a 09 20 20 20 20 20 aunchers)..
14df0 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 fallback-launch
14e00 65 72 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c er.. (let l
14e10 6f 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 6c oop ((hed (car l
14e20 61 75 6e 63 68 65 72 73 29 29 0a 09 09 09 20 28 aunchers)).... (
14e30 74 61 6c 20 28 63 64 72 20 6c 61 75 6e 63 68 65 tal (cdr launche
14e40 72 73 29 29 29 0a 09 09 28 6c 65 74 20 28 28 70 rs)))...(let ((p
14e50 61 74 74 20 20 20 20 20 20 28 63 61 72 20 68 65 att (car he
14e60 64 29 29 0a 09 09 20 20 20 20 20 20 28 68 6f 73 d))... (hos
14e70 74 2d 74 79 70 65 20 28 63 61 64 72 20 68 65 64 t-type (cadr hed
14e80 29 29 29 0a 09 09 20 20 28 69 66 20 28 74 65 73 )))... (if (tes
14e90 74 73 3a 6d 61 74 63 68 20 70 61 74 74 20 74 65 ts:match patt te
14ea0 73 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 stname itempath)
14eb0 0a 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a ... (begin.
14ec0 09 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d ...(debug:print-
14ed0 69 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d info 2 *default-
14ee0 6c 6f 67 2d 70 6f 72 74 2a 20 22 48 61 76 65 20 log-port* "Have
14ef0 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 6d flexi-launcher m
14f00 61 74 63 68 20 66 6f 72 20 22 20 74 65 73 74 6e atch for " testn
14f10 61 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 ame "/" itempath
14f20 20 22 20 3d 20 22 20 68 6f 73 74 2d 74 79 70 65 " = " host-type
14f30 29 0a 09 09 09 28 6c 65 74 20 28 28 6c 61 75 6e )....(let ((laun
14f40 63 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f cher (configf:lo
14f50 6f 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 okup configdat "
14f60 68 6f 73 74 2d 74 79 70 65 73 22 20 68 6f 73 74 host-types" host
14f70 2d 74 79 70 65 29 29 29 0a 09 09 09 20 20 28 69 -type))).... (i
14f80 66 20 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 f launcher....
14f90 20 20 20 20 28 6c 65 74 2a 20 28 28 6c 61 75 6e (let* ((laun
14fa0 63 68 65 72 2d 70 61 72 74 73 20 28 73 74 72 69 cher-parts (stri
14fb0 6e 67 2d 73 70 6c 69 74 20 6c 61 75 6e 63 68 65 ng-split launche
14fc0 72 29 29 0a 09 09 09 09 20 20 20 20 20 28 6c 61 r))..... (la
14fd0 75 6e 63 68 65 72 2d 65 78 65 20 20 20 28 63 61 uncher-exe (ca
14fe0 72 20 6c 61 75 6e 63 68 65 72 2d 70 61 72 74 73 r launcher-parts
14ff0 29 29 29 0a 09 09 09 09 28 69 66 20 28 65 71 75 ))).....(if (equ
15000 61 6c 3f 20 6c 61 75 6e 63 68 65 72 2d 65 78 65 al? launcher-exe
15010 20 22 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 22 "#MTLOWESTLOAD"
15020 29 20 3b 3b 20 74 68 69 73 20 69 73 20 6f 75 72 ) ;; this is our
15030 20 73 70 65 63 69 61 6c 20 63 61 73 65 2c 20 77 special case, w
15040 65 20 77 69 6c 6c 20 66 69 6e 64 20 74 68 65 20 e will find the
15050 6c 6f 77 65 73 74 20 6c 6f 61 64 20 61 6e 64 20 lowest load and
15060 63 72 61 66 74 20 61 20 6e 62 66 61 6b 65 20 63 craft a nbfake c
15070 6f 6d 6d 61 6e 64 6c 69 6e 65 0a 09 09 09 09 20 ommandline.....
15080 20 20 20 28 6c 65 74 20 28 28 74 61 72 67 2d 68 (let ((targ-h
15090 6f 73 74 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ost (common:get-
150a0 6c 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 least-loaded-hos
150b0 74 20 28 63 64 72 20 6c 61 75 6e 63 68 65 72 2d t (cdr launcher-
150c0 70 61 72 74 73 29 29 29 29 0a 09 09 09 09 20 20 parts)))).....
150d0 20 20 20 20 28 63 6f 6e 63 20 22 72 65 6d 72 75 (conc "remru
150e0 6e 20 22 20 74 61 72 67 2d 68 6f 73 74 29 29 0a n " targ-host)).
150f0 09 09 09 09 20 20 20 20 6c 61 75 6e 63 68 65 72 .... launcher
15100 29 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 )).... (beg
15110 69 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 in.....(debug:pr
15120 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
15130 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
15140 41 52 4e 49 4e 47 3a 20 6e 6f 20 6c 61 75 6e 63 ARNING: no launc
15150 68 65 72 20 66 6f 75 6e 64 20 66 6f 72 20 68 6f her found for ho
15160 73 74 2d 74 79 70 65 20 22 20 68 6f 73 74 2d 74 st-type " host-t
15170 79 70 65 29 0a 09 09 09 09 28 69 66 20 28 6e 75 ype).....(if (nu
15180 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 20 ll? tal).....
15190 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 fallback-launch
151a0 65 72 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 er..... (loop
151b0 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 (car tal)(cdr t
151c0 61 6c 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 al)))))))...
151d0 20 20 3b 3b 20 6e 6f 20 6d 61 74 63 68 2c 20 74 ;; no match, t
151e0 72 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 ry again...
151f0 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
15200 0a 09 09 09 20 20 66 61 6c 6c 62 61 63 6b 2d 6c .... fallback-l
15210 61 75 6e 63 68 65 72 0a 09 09 09 20 20 28 6c 6f auncher.... (lo
15220 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
15230 20 74 61 6c 29 29 29 29 29 29 29 29 0a 09 66 61 tal))))))))..fa
15240 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 29 llback-launcher)
15250 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d )). .;;========
15260 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15270 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15280 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15290 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
152a0 3b 20 44 20 41 20 53 20 48 20 42 20 4f 20 41 20 ; D A S H B O A
152b0 52 20 44 20 20 20 55 20 53 20 45 20 52 20 20 20 R D U S E R
152c0 56 20 49 20 45 20 57 20 53 0a 3b 3b 3d 3d 3d 3d V I E W S.;;====
152d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
152f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15300 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15310 3d 3d 0a 0a 3b 3b 20 66 69 72 73 74 20 72 65 61 ==..;; first rea
15320 64 20 7e 2f 76 69 65 77 73 2e 63 6f 6e 66 69 67 d ~/views.config
15330 20 69 66 20 69 74 20 65 78 69 73 74 73 2c 20 74 if it exists, t
15340 68 65 6e 20 72 65 61 64 20 24 4d 54 52 41 48 2f hen read $MTRAH/
15350 76 69 65 77 73 2e 63 6f 6e 66 69 67 20 69 66 20 views.config if
15360 69 74 20 65 78 69 73 74 73 0a 3b 3b 0a 28 64 65 it exists.;;.(de
15370 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 61 fine (common:loa
15380 64 2d 76 69 65 77 73 2d 63 6f 6e 66 69 67 29 0a d-views-config).
15390 20 20 28 6c 65 74 2a 20 28 28 76 69 65 77 2d 63 (let* ((view-c
153a0 66 67 64 61 74 20 20 20 20 28 6d 61 6b 65 2d 68 fgdat (make-h
153b0 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 28 68 ash-table)).. (h
153c0 6f 6d 65 2d 63 66 67 66 69 6c 65 20 20 20 28 63 ome-cfgfile (c
153d0 6f 6e 63 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e onc (get-environ
153e0 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 48 ment-variable "H
153f0 4f 4d 45 22 29 20 22 2f 2e 6d 74 76 69 65 77 73 OME") "/.mtviews
15400 2e 63 6f 6e 66 69 67 22 29 29 0a 09 20 28 6d 74 .config")).. (mt
15410 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 28 63 6f home-cfgfile (co
15420 6e 63 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 2e nc *toppath* "/.
15430 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 29 mtviews.config")
15440 29 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d )). (if (comm
15450 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
15460 6d 74 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a mthome-cfgfile).
15470 09 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 6d 74 .(read-config mt
15480 68 6f 6d 65 2d 63 66 67 66 69 6c 65 20 76 69 65 home-cfgfile vie
15490 77 2d 63 66 67 64 61 74 20 23 74 29 29 0a 20 20 w-cfgdat #t)).
154a0 20 20 3b 3b 20 77 65 20 6c 6f 61 64 20 74 68 65 ;; we load the
154b0 20 68 6f 6d 65 20 64 69 72 20 66 69 6c 65 20 41 home dir file A
154c0 46 54 45 52 20 74 68 65 20 4d 54 52 41 48 20 66 FTER the MTRAH f
154d0 69 6c 65 20 73 6f 20 74 68 65 20 75 73 65 72 20 ile so the user
154e0 63 61 6e 20 63 6c 6f 62 62 65 72 20 73 65 74 74 can clobber sett
154f0 69 6e 67 73 20 77 68 65 6e 20 72 75 6e 6e 69 6e ings when runnin
15500 67 20 74 68 65 20 64 61 73 68 62 6f 61 72 64 20 g the dashboard
15510 69 6e 20 72 65 61 64 2d 6f 6e 6c 79 20 61 72 65 in read-only are
15520 61 73 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d as. (if (comm
15530 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 on:file-exists?
15540 68 6f 6d 65 2d 63 66 67 66 69 6c 65 29 0a 09 28 home-cfgfile)..(
15550 72 65 61 64 2d 63 6f 6e 66 69 67 20 68 6f 6d 65 read-config home
15560 2d 63 66 67 66 69 6c 65 20 76 69 65 77 2d 63 66 -cfgfile view-cf
15570 67 64 61 74 20 23 74 29 29 0a 20 20 20 20 76 69 gdat #t)). vi
15580 65 77 2d 63 66 67 64 61 74 29 29 0a 0a ew-cfgdat))..