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 28 70 72 65 66 69 78 gex-case (prefix
0210: 20 62 61 73 65 36 34 20 62 61 73 65 36 34 3a 29 base64 base64:)
0220: 0a 20 20 20 20 20 66 6f 72 6d 61 74 20 64 6f 74 . format dot
0230: 2d 6c 6f 63 6b 69 6e 67 20 63 73 76 2d 78 6d 6c -locking csv-xml
0240: 20 7a 33 20 3b 3b 20 73 71 6c 2d 64 65 2d 6c 69 z3 ;; sql-de-li
0250: 74 65 0a 20 20 20 20 20 68 6f 73 74 69 6e 66 6f te. hostinfo
0260: 20 6d 64 35 20 6d 65 73 73 61 67 65 2d 64 69 67 md5 message-dig
0270: 65 73 74 20 74 79 70 65 64 2d 72 65 63 6f 72 64 est typed-record
0280: 73 20 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c s directory-util
0290: 73 20 73 74 61 63 6b 0a 20 20 20 20 20 6d 61 74 s stack. mat
02a0: 63 68 61 62 6c 65 20 72 65 67 65 78 20 70 6f 73 chable regex pos
02b0: 69 78 20 28 73 72 66 69 20 31 38 29 20 65 78 74 ix (srfi 18) ext
02c0: 72 61 73 20 3b 3b 20 74 63 70 20 0a 20 20 20 20 ras ;; tcp .
02d0: 20 28 70 72 65 66 69 78 20 6e 61 6e 6f 6d 73 67 (prefix nanomsg
02e0: 20 6e 6d 73 67 3a 29 0a 20 20 20 20 20 28 70 72 nmsg:). (pr
02f0: 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c efix sqlite3 sql
0300: 69 74 65 33 3a 29 0a 20 20 20 20 20 29 0a 0a 28 ite3:). )..(
0310: 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 63 6f declare (unit co
0320: 6d 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 65 mmon))..(include
0330: 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 73 "common_records
0340: 2e 73 63 6d 22 29 0a 0a 3b 3b 20 28 72 65 71 75 .scm")..;; (requ
0350: 69 72 65 2d 6c 69 62 72 61 72 79 20 6d 61 72 67 ire-library marg
0360: 73 29 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 22 s).;; (include "
0370: 6d 61 72 67 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 margs.scm")..;;
0380: 28 64 65 66 69 6e 65 20 6f 6c 64 2d 65 78 69 74 (define old-exit
0390: 20 65 78 69 74 29 0a 3b 3b 20 0a 3b 3b 20 28 64 exit).;; .;; (d
03a0: 65 66 69 6e 65 20 28 65 78 69 74 20 2e 20 63 6f efine (exit . co
03b0: 64 65 29 0a 3b 3b 20 20 20 28 69 66 20 28 6e 75 de).;; (if (nu
03c0: 6c 6c 3f 20 63 6f 64 65 29 0a 3b 3b 20 20 20 20 ll? code).;;
03d0: 20 20 20 28 6f 6c 64 2d 65 78 69 74 29 0a 3b 3b (old-exit).;;
03e0: 20 20 20 20 20 20 20 28 6f 6c 64 2d 65 78 69 74 (old-exit
03f0: 20 63 6f 64 65 29 29 29 0a 0a 0a 3b 3b 20 65 78 code)))...;; ex
0400: 65 63 75 74 65 20 74 68 75 6e 6b 2c 20 72 65 74 ecute thunk, ret
0410: 75 72 6e 20 76 61 6c 75 65 2e 20 20 49 66 20 65 urn value. If e
0420: 78 63 65 70 74 69 6f 6e 20 74 68 72 6f 77 6e 2c xception thrown,
0430: 20 74 72 61 70 20 65 78 63 65 70 74 69 6f 6e 2c trap exception,
0440: 20 72 65 74 75 72 6e 20 23 66 2c 20 61 6e 64 20 return #f, and
0450: 65 6d 69 74 20 6e 6f 6e 66 61 74 61 6c 20 63 6f emit nonfatal co
0460: 6e 64 69 74 69 6f 6e 20 6e 6f 74 65 20 74 6f 20 ndition note to
0470: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0480: 74 2a 20 2e 0a 3b 3b 20 61 72 67 75 6d 65 6e 74 t* ..;; argument
0490: 73 20 2d 20 74 68 75 6e 6b 2c 20 6d 65 73 73 61 s - thunk, messa
04a0: 67 65 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ge.(define (comm
04b0: 6f 6e 3a 66 61 69 6c 2d 73 61 66 65 20 74 68 75 on:fail-safe thu
04c0: 6e 6b 20 77 61 72 6e 69 6e 67 2d 6d 65 73 73 61 nk warning-messa
04d0: 67 65 2d 6f 6e 2d 65 78 63 65 70 74 69 6f 6e 29 ge-on-exception)
04e0: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
04f0: 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 tions. exn.
0500: 28 62 65 67 69 6e 0a 20 20 20 20 20 28 64 65 62 (begin. (deb
0510: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
0520: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
0530: 74 2a 20 22 6e 6f 74 61 62 6c 65 20 62 75 74 20 t* "notable but
0540: 6e 6f 6e 66 61 74 61 6c 20 63 6f 6e 64 69 74 69 nonfatal conditi
0550: 6f 6e 20 2d 20 22 77 61 72 6e 69 6e 67 2d 6d 65 on - "warning-me
0560: 73 73 61 67 65 2d 6f 6e 2d 65 78 63 65 70 74 69 ssage-on-excepti
0570: 6f 6e 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a on). (debug:
0580: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
0590: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 0a fault-log-port*.
05a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
05b0: 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 (string-s
05c0: 75 62 73 74 69 74 75 74 65 20 22 5c 6e 3f 45 72 ubstitute "\n?Er
05d0: 72 6f 72 3a 22 20 22 6e 6f 6e 66 61 74 61 6c 20 ror:" "nonfatal
05e0: 63 6f 6e 64 69 74 69 6f 6e 3a 22 0a 20 20 20 20 condition:".
05f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0610: 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 (with-outp
0620: 75 74 2d 74 6f 2d 73 74 72 69 6e 67 0a 20 20 20 ut-to-string.
0630: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 28 6c 61 6d 62 64 61 (lambda
0660: 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ().
0670: 20 20 20 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 28 70 72 69 6e 74 2d 65 72 72 6f 72 2d 6d (print-error-m
06a0: 65 73 73 61 67 65 20 65 78 6e 29 20 29 29 29 29 essage exn) ))))
06b0: 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
06c0: 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
06d0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 lt-log-port* "
06e0: 20 20 2d 2d 20 63 6f 6e 74 69 6e 75 69 6e 67 20 -- continuing
06f0: 61 66 74 65 72 20 6e 6f 6e 66 61 74 61 6c 20 63 after nonfatal c
0700: 6f 6e 64 69 74 69 6f 6e 2e 2e 2e 22 29 0a 20 20 ondition...").
0710: 20 20 20 23 66 29 0a 20 20 20 28 74 68 75 6e 6b #f). (thunk
0720: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 67 65 74 )))..(define get
0730: 65 6e 76 20 67 65 74 2d 65 6e 76 69 72 6f 6e 6d env get-environm
0740: 65 6e 74 2d 76 61 72 69 61 62 6c 65 29 0a 28 64 ent-variable).(d
0750: 65 66 69 6e 65 20 28 73 61 66 65 2d 73 65 74 65 efine (safe-sete
0760: 6e 76 20 6b 65 79 20 76 61 6c 29 0a 20 20 28 69 nv key val). (i
0770: 66 20 28 73 75 62 73 74 72 69 6e 67 2d 69 6e 64 f (substring-ind
0780: 65 78 20 22 3a 22 20 6b 65 79 29 20 3b 3b 20 76 ex ":" key) ;; v
0790: 61 72 69 61 62 6c 65 73 20 63 6f 6e 74 61 69 6e ariables contain
07a0: 69 6e 67 20 3a 20 61 72 65 20 66 6f 72 20 69 6e ing : are for in
07b0: 74 65 72 6e 61 6c 20 75 73 65 20 61 6e 64 20 63 ternal use and c
07c0: 61 6e 6e 6f 74 20 62 65 20 65 6e 76 69 72 6f 6e annot be environ
07d0: 6d 65 6e 74 20 76 61 72 69 61 62 6c 65 73 2e 0a ment variables..
07e0: 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
07f0: 6e 74 2d 65 72 72 6f 72 20 34 20 2a 64 65 66 61 nt-error 4 *defa
0800: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 ult-log-port* "s
0810: 6b 69 70 20 73 65 74 74 69 6e 67 20 69 6e 74 65 kip setting inte
0820: 72 6e 61 6c 20 75 73 65 20 6f 6e 6c 79 20 76 61 rnal use only va
0830: 72 69 61 62 6c 65 73 20 63 6f 6e 74 61 69 6e 69 riables containi
0840: 6e 67 20 5c 22 3a 5c 22 22 29 0a 20 20 20 20 20 ng \":\"").
0850: 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 6e (if (and (strin
0860: 67 3f 20 76 61 6c 29 0a 09 20 20 20 20 20 20 20 g? val)..
0870: 28 73 74 72 69 6e 67 3f 20 6b 65 79 29 29 0a 09 (string? key))..
0880: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
0890: 69 6f 6e 73 0a 09 20 20 20 20 20 20 65 78 6e 0a ions.. exn.
08a0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
08b0: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
08c0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
08d0: 62 61 64 20 76 61 6c 75 65 20 66 6f 72 20 73 65 bad value for se
08e0: 74 65 6e 76 2c 20 6b 65 79 3d 22 20 6b 65 79 20 tenv, key=" key
08f0: 22 2c 20 76 61 6c 75 65 3d 22 20 76 61 6c 29 0a ", value=" val).
0900: 09 20 20 20 20 28 73 65 74 65 6e 76 20 6b 65 79 . (setenv key
0910: 20 76 61 6c 29 29 0a 09 20 20 28 64 65 62 75 67 val)).. (debug
0920: 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a :print-error 0 *
0930: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
0940: 2a 20 22 62 61 64 20 76 61 6c 75 65 20 66 6f 72 * "bad value for
0950: 20 73 65 74 65 6e 76 2c 20 6b 65 79 3d 22 20 6b setenv, key=" k
0960: 65 79 20 22 2c 20 76 61 6c 75 65 3d 22 20 76 61 ey ", value=" va
0970: 6c 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 68 l))))..(define h
0980: 6f 6d 65 20 28 67 65 74 65 6e 76 20 22 48 4f 4d ome (getenv "HOM
0990: 45 22 29 29 0a 28 64 65 66 69 6e 65 20 75 73 65 E")).(define use
09a0: 72 20 28 67 65 74 65 6e 76 20 22 55 53 45 52 22 r (getenv "USER"
09b0: 29 29 0a 0a 0a 3b 3b 20 72 65 74 75 72 6e 73 20 ))...;; returns
09c0: 6c 69 73 74 20 6f 66 20 66 64 20 63 6f 75 6e 74 list of fd count
09d0: 2c 20 73 6f 63 6b 65 74 20 63 6f 75 6e 74 0a 28 , socket count.(
09e0: 64 65 66 69 6e 65 20 28 67 65 74 2d 66 69 6c 65 define (get-file
09f0: 2d 64 65 73 63 72 69 70 74 6f 72 2d 63 6f 75 6e -descriptor-coun
0a00: 74 20 23 21 6b 65 79 20 20 28 70 69 64 20 28 63 t #!key (pid (c
0a10: 75 72 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 urrent-process-i
0a20: 64 20 29 29 29 0a 20 20 28 6c 69 73 74 0a 20 20 d ))). (list.
0a30: 20 20 28 6c 65 6e 67 74 68 20 28 67 6c 6f 62 20 (length (glob
0a40: 28 63 6f 6e 63 20 22 2f 70 72 6f 63 2f 22 20 70 (conc "/proc/" p
0a50: 69 64 20 22 2f 66 64 2f 2a 22 29 29 29 0a 20 20 id "/fd/*"))).
0a60: 20 20 28 6c 65 6e 67 74 68 20 20 28 66 69 6c 74 (length (filt
0a70: 65 72 20 69 64 65 6e 74 69 74 79 20 28 6d 61 70 er identity (map
0a80: 20 73 6f 63 6b 65 74 3f 20 28 67 6c 6f 62 20 28 socket? (glob (
0a90: 63 6f 6e 63 20 22 2f 70 72 6f 63 2f 22 20 70 69 conc "/proc/" pi
0aa0: 64 20 22 2f 66 64 2f 2a 22 29 29 29 29 29 0a 20 d "/fd/*"))))).
0ab0: 20 29 0a 29 0a 0a 0a 3b 3b 20 47 4c 4f 42 41 4c ).)...;; GLOBAL
0ac0: 53 0a 0a 3b 3b 20 43 4f 4e 54 45 58 54 53 0a 28 S..;; CONTEXTS.(
0ad0: 64 65 66 73 74 72 75 63 74 20 63 78 74 0a 20 20 defstruct cxt.
0ae0: 28 74 61 73 6b 64 62 20 23 66 29 0a 20 20 28 63 (taskdb #f). (c
0af0: 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 65 mutex (make-mute
0b00: 78 29 29 29 0a 3b 3b 20 28 64 65 66 69 6e 65 20 x))).;; (define
0b10: 2a 63 6f 6e 74 65 78 74 73 2a 20 28 6d 61 6b 65 *contexts* (make
0b20: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 3b 3b -hash-table)).;;
0b30: 20 28 64 65 66 69 6e 65 20 2a 63 6f 6e 74 65 78 (define *contex
0b40: 74 2d 6d 75 74 65 78 2a 20 28 6d 61 6b 65 2d 6d t-mutex* (make-m
0b50: 75 74 65 78 29 29 0a 0a 3b 3b 20 3b 3b 20 73 61 utex))..;; ;; sa
0b60: 66 65 20 6d 65 74 68 6f 64 20 66 6f 72 20 61 63 fe method for ac
0b70: 63 65 73 73 69 6e 67 20 61 20 63 6f 6e 74 65 78 cessing a contex
0b80: 74 20 67 69 76 65 6e 20 61 20 74 6f 70 70 61 74 t given a toppat
0b90: 68 0a 3b 3b 20 3b 3b 0a 3b 3b 20 28 64 65 66 69 h.;; ;;.;; (defi
0ba0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d ne (common:with-
0bb0: 63 78 74 20 74 6f 70 70 61 74 68 20 70 72 6f 63 cxt toppath proc
0bc0: 29 0a 3b 3b 20 20 20 28 6d 75 74 65 78 2d 6c 6f ).;; (mutex-lo
0bd0: 63 6b 21 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 ck! *context-mut
0be0: 65 78 2a 29 0a 3b 3b 20 20 20 28 6c 65 74 20 28 ex*).;; (let (
0bf0: 28 63 78 74 20 28 68 61 73 68 2d 74 61 62 6c 65 (cxt (hash-table
0c00: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f -ref/default *co
0c10: 6e 74 65 78 74 73 2a 20 74 6f 70 70 61 74 68 20 ntexts* toppath
0c20: 23 66 29 29 29 0a 3b 3b 20 20 20 20 20 28 69 66 #f))).;; (if
0c30: 20 28 6e 6f 74 20 63 78 74 29 0a 3b 3b 20 20 20 (not cxt).;;
0c40: 20 20 20 20 20 20 28 73 65 74 21 20 63 78 74 20 (set! cxt
0c50: 28 6c 65 74 20 28 28 78 20 28 6d 61 6b 65 2d 63 (let ((x (make-c
0c60: 78 74 29 29 29 28 68 61 73 68 2d 74 61 62 6c 65 xt)))(hash-table
0c70: 2d 73 65 74 21 20 2a 63 6f 6e 74 65 78 74 73 2a -set! *contexts*
0c80: 20 74 6f 70 70 61 74 68 20 78 29 20 78 29 29 29 toppath x) x)))
0c90: 0a 3b 3b 20 20 20 20 20 28 6c 65 74 20 28 28 63 .;; (let ((c
0ca0: 78 74 2d 6d 75 74 65 78 20 28 63 78 74 2d 6d 75 xt-mutex (cxt-mu
0cb0: 74 65 78 20 63 78 74 29 29 29 0a 3b 3b 20 20 20 tex cxt))).;;
0cc0: 20 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 (mutex-unloc
0cd0: 6b 21 20 2a 63 6f 6e 74 65 78 74 2d 6d 75 74 65 k! *context-mute
0ce0: 78 2a 29 0a 3b 3b 20 20 20 20 20 20 20 28 6d 75 x*).;; (mu
0cf0: 74 65 78 2d 6c 6f 63 6b 21 20 63 78 74 2d 6d 75 tex-lock! cxt-mu
0d00: 74 65 78 29 0a 3b 3b 20 20 20 20 20 20 20 28 6c tex).;; (l
0d10: 65 74 20 28 28 72 65 73 20 28 70 72 6f 63 20 63 et ((res (proc c
0d20: 78 74 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 xt))).;;
0d30: 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 (mutex-unlock!
0d40: 63 78 74 2d 6d 75 74 65 78 29 0a 3b 3b 20 20 20 cxt-mutex).;;
0d50: 20 20 20 20 20 20 72 65 73 29 29 29 29 0a 20 20 res)))).
0d60: 20 20 20 20 20 20 0a 3b 3b 20 41 20 68 61 73 68 .;; A hash
0d70: 20 74 61 62 6c 65 20 74 68 61 74 20 63 61 6e 20 table that can
0d80: 62 65 20 61 63 63 65 73 73 65 64 20 62 79 20 23 be accessed by #
0d90: 7b 73 63 68 65 6d 65 20 2e 2e 2e 7d 20 63 61 6c {scheme ...} cal
0da0: 6c 73 20 69 6e 0a 3b 3b 20 63 6f 6e 66 69 67 20 ls in.;; config
0db0: 66 69 6c 65 73 2e 20 41 6c 6c 6f 77 73 20 63 6f files. Allows co
0dc0: 6d 6d 75 6e 69 63 61 74 69 6e 67 20 62 65 74 77 mmunicating betw
0dd0: 65 65 6e 20 63 6f 6e 66 67 73 0a 3b 3b 0a 28 64 een confgs.;;.(d
0de0: 65 66 69 6e 65 20 2a 75 73 65 72 2d 68 61 73 68 efine *user-hash
0df0: 2d 64 61 74 61 2a 20 28 6d 61 6b 65 2d 68 61 73 -data* (make-has
0e00: 68 2d 74 61 62 6c 65 29 29 0a 0a 3b 3b 20 28 64 h-table))..;; (d
0e10: 65 66 69 6e 65 20 2a 64 62 2d 6b 65 79 73 2a 20 efine *db-keys*
0e20: 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f #f)..(define *co
0e30: 6e 66 69 67 69 6e 66 6f 2a 20 20 20 23 66 29 20 nfiginfo* #f)
0e40: 20 20 3b 3b 20 72 61 77 20 72 65 73 75 6c 74 73 ;; raw results
0e50: 20 66 72 6f 6d 20 73 65 74 75 70 2c 20 69 6e 63 from setup, inc
0e60: 6c 75 64 65 73 20 74 6f 70 70 61 74 68 20 61 6e ludes toppath an
0e70: 64 20 74 61 62 6c 65 20 66 72 6f 6d 20 6d 65 67 d table from meg
0e80: 61 74 65 73 74 2e 63 6f 6e 66 69 67 0a 28 64 65 atest.config.(de
0e90: 66 69 6e 65 20 2a 72 75 6e 63 6f 6e 66 69 67 64 fine *runconfigd
0ea0: 61 74 2a 20 23 66 29 20 20 20 3b 3b 20 72 75 6e at* #f) ;; run
0eb0: 20 63 6f 6e 66 69 67 73 20 64 61 74 61 0a 28 64 configs data.(d
0ec0: 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 64 61 74 efine *configdat
0ed0: 2a 20 20 20 20 23 66 29 20 20 20 3b 3b 20 6d 65 * #f) ;; me
0ee0: 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 20 64 61 gatest.config da
0ef0: 74 61 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 ta.(define *conf
0f00: 69 67 73 74 61 74 75 73 2a 20 23 66 29 20 20 20 igstatus* #f)
0f10: 3b 3b 20 73 74 61 74 75 73 20 6f 66 20 64 61 74 ;; status of dat
0f20: 61 3b 20 27 66 75 6c 6c 64 61 74 61 20 3a 20 61 a; 'fulldata : a
0f30: 6c 6c 20 70 72 6f 63 65 73 73 69 6e 67 20 64 6f ll processing do
0f40: 6e 65 2c 20 23 66 20 3a 20 6e 6f 20 64 61 74 61 ne, #f : no data
0f50: 20 79 65 74 2c 20 27 70 61 72 74 69 61 6c 64 61 yet, 'partialda
0f60: 74 61 20 3a 20 70 61 72 74 69 61 6c 20 72 65 61 ta : partial rea
0f70: 64 20 64 6f 6e 65 0a 28 64 65 66 69 6e 65 20 2a d done.(define *
0f80: 74 6f 70 70 61 74 68 2a 20 20 20 20 20 20 23 66 toppath* #f
0f90: 29 0a 28 64 65 66 69 6e 65 20 2a 61 6c 72 65 61 ).(define *alrea
0fa0: 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 dy-seen-runconfi
0fb0: 67 2d 69 6e 66 6f 2a 20 23 66 29 0a 0a 28 64 65 g-info* #f)..(de
0fc0: 66 69 6e 65 20 2a 74 65 73 74 2d 6d 65 74 61 2d fine *test-meta-
0fd0: 75 70 64 61 74 65 64 2a 20 28 6d 61 6b 65 2d 68 updated* (make-h
0fe0: 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 65 66 ash-table)).(def
0ff0: 69 6e 65 20 2a 67 6c 6f 62 61 6c 65 78 69 74 73 ine *globalexits
1000: 74 61 74 75 73 2a 20 20 30 29 20 3b 3b 20 61 74 tatus* 0) ;; at
1010: 74 65 6d 70 74 20 74 6f 20 77 6f 72 6b 20 61 72 tempt to work ar
1020: 6f 75 6e 64 20 70 6f 73 73 69 62 6c 65 20 74 68 ound possible th
1030: 72 65 61 64 20 69 73 73 75 65 73 0a 28 64 65 66 read issues.(def
1040: 69 6e 65 20 2a 70 61 73 73 6e 75 6d 2a 20 20 20 ine *passnum*
1050: 20 20 20 20 20 20 20 20 30 29 20 3b 3b 20 77 68 0) ;; wh
1060: 65 6e 20 72 75 6e 6e 69 6e 67 20 74 72 61 63 6b en running track
1070: 20 63 61 6c 6c 73 20 74 6f 20 72 75 6e 2d 74 65 calls to run-te
1080: 73 74 73 20 6f 72 20 73 69 6d 69 6c 61 72 0a 3b sts or similar.;
1090: 3b 20 28 64 65 66 69 6e 65 20 2a 61 6c 74 2d 6c ; (define *alt-l
10a0: 6f 67 2d 66 69 6c 65 2a 20 23 66 29 20 20 3b 3b og-file* #f) ;;
10b0: 20 75 73 65 64 20 62 79 20 2d 6c 6f 67 0a 28 64 used by -log.(d
10c0: 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 64 65 efine *common:de
10d0: 6e 6f 69 73 65 2a 20 20 20 20 28 6d 61 6b 65 2d noise* (make-
10e0: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
10f0: 66 6f 72 20 6c 6f 77 20 6e 6f 69 73 65 20 70 72 for low noise pr
1100: 69 6e 74 69 6e 67 0a 28 64 65 66 69 6e 65 20 2a inting.(define *
1110: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
1120: 2a 20 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f * (current-erro
1130: 72 2d 70 6f 72 74 29 29 0a 28 64 65 66 69 6e 65 r-port)).(define
1140: 20 2a 74 69 6d 65 2d 7a 65 72 6f 2a 20 28 63 75 *time-zero* (cu
1150: 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 29 20 rrent-seconds))
1160: 3b 3b 20 66 6f 72 20 74 68 65 20 77 61 74 63 68 ;; for the watch
1170: 64 6f 67 0a 0a 3b 3b 20 44 41 54 41 42 41 53 45 dog..;; DATABASE
1180: 0a 28 64 65 66 69 6e 65 20 2a 64 62 73 74 72 75 .(define *dbstru
1190: 63 74 2d 64 62 2a 20 20 20 20 20 20 20 20 20 23 ct-db* #
11a0: 66 29 20 3b 3b 20 75 73 65 64 20 74 6f 20 63 61 f) ;; used to ca
11b0: 63 68 65 20 74 68 65 20 64 62 73 74 72 75 63 74 che the dbstruct
11c0: 20 69 6e 20 64 62 3a 73 65 74 75 70 2e 20 47 6f in db:setup. Go
11d0: 61 6c 20 69 73 20 74 6f 20 72 65 6d 6f 76 65 20 al is to remove
11e0: 74 68 69 73 2e 0a 3b 3b 20 64 62 20 73 74 61 74 this..;; db stat
11f0: 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 73 74 s.(define *db-st
1200: 61 74 73 2a 20 20 20 20 20 20 20 20 20 20 20 20 ats*
1210: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1220: 29 29 20 3b 3b 20 68 61 73 68 20 6f 66 20 76 65 )) ;; hash of ve
1230: 63 74 6f 72 73 20 3c 20 63 6f 75 6e 74 20 64 75 ctors < count du
1240: 72 61 74 69 6f 6e 2d 74 6f 74 61 6c 20 3e 0a 28 ration-total >.(
1250: 64 65 66 69 6e 65 20 2a 64 62 2d 73 74 61 74 73 define *db-stats
1260: 2d 6d 75 74 65 78 2a 20 20 20 20 20 20 28 6d 61 -mutex* (ma
1270: 6b 65 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 64 62 ke-mutex)).;; db
1280: 20 61 63 63 65 73 73 0a 28 64 65 66 69 6e 65 20 access.(define
1290: 2a 64 62 2d 6c 61 73 74 2d 61 63 63 65 73 73 2a *db-last-access*
12a0: 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d 73 (current-s
12b0: 65 63 6f 6e 64 73 29 29 20 3b 3b 20 6c 61 73 74 econds)) ;; last
12c0: 20 64 62 20 61 63 63 65 73 73 2c 20 75 73 65 64 db access, used
12d0: 20 69 6e 20 73 65 72 76 65 72 0a 28 64 65 66 69 in server.(defi
12e0: 6e 65 20 2a 64 62 2d 77 72 69 74 65 2d 61 63 63 ne *db-write-acc
12f0: 65 73 73 2a 20 20 20 20 20 23 74 29 0a 3b 3b 20 ess* #t).;;
1300: 64 62 20 73 79 6e 63 0a 28 64 65 66 69 6e 65 20 db sync.(define
1310: 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 2a 20 20 *db-last-sync*
1320: 20 20 20 20 20 20 30 29 20 20 20 20 20 20 20 20 0)
1330: 20 20 20 20 20 20 20 20 20 3b 3b 20 6c 61 73 74 ;; last
1340: 20 74 69 6d 65 20 74 68 65 20 73 79 6e 63 20 74 time the sync t
1350: 6f 20 6d 65 67 61 74 65 73 74 2e 64 62 20 68 61 o megatest.db ha
1360: 70 70 65 6e 65 64 0a 28 64 65 66 69 6e 65 20 2a ppened.(define *
1370: 64 62 2d 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 db-sync-in-progr
1380: 65 73 73 2a 20 23 66 29 20 20 20 20 20 20 20 20 ess* #f)
1390: 20 20 20 20 20 20 20 20 3b 3b 20 69 66 20 74 68 ;; if th
13a0: 65 72 65 20 69 73 20 61 20 73 79 6e 63 20 69 6e ere is a sync in
13b0: 20 70 72 6f 67 72 65 73 73 20 64 6f 20 6e 6f 74 progress do not
13c0: 20 74 72 79 20 74 6f 20 73 74 61 72 74 20 61 6e try to start an
13d0: 6f 74 68 65 72 0a 28 64 65 66 69 6e 65 20 2a 64 other.(define *d
13e0: 62 2d 6d 75 6c 74 69 2d 73 79 6e 63 2d 6d 75 74 b-multi-sync-mut
13f0: 65 78 2a 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 ex* (make-mutex)
1400: 29 20 20 20 20 20 20 3b 3b 20 70 72 6f 74 65 63 ) ;; protec
1410: 74 20 61 63 63 65 73 73 20 74 6f 20 2a 64 62 2d t access to *db-
1420: 73 79 6e 63 2d 69 6e 2d 70 72 6f 67 72 65 73 73 sync-in-progress
1430: 2a 2c 20 2a 64 62 2d 6c 61 73 74 2d 73 79 6e 63 *, *db-last-sync
1440: 2a 0a 3b 3b 20 74 61 73 6b 20 64 62 0a 28 64 65 *.;; task db.(de
1450: 66 69 6e 65 20 2a 74 61 73 6b 2d 64 62 2a 20 20 fine *task-db*
1460: 20 20 20 20 20 20 20 20 20 20 20 23 66 29 20 3b #f) ;
1470: 3b 20 28 76 65 63 74 6f 72 20 64 62 20 70 61 74 ; (vector db pat
1480: 68 2d 74 6f 2d 64 62 29 0a 28 64 65 66 69 6e 65 h-to-db).(define
1490: 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c 6c 6f *db-access-allo
14a0: 77 65 64 2a 20 20 20 23 74 29 20 3b 3b 20 66 6c wed* #t) ;; fl
14b0: 61 67 20 74 6f 20 61 6c 6c 6f 77 20 61 63 63 65 ag to allow acce
14c0: 73 73 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 61 ss.(define *db-a
14d0: 63 63 65 73 73 2d 6d 75 74 65 78 2a 20 20 20 20 ccess-mutex*
14e0: 20 28 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 (make-mutex)).(
14f0: 64 65 66 69 6e 65 20 2a 64 62 2d 74 72 61 6e 73 define *db-trans
1500: 61 63 74 69 6f 6e 2d 6d 75 74 65 78 2a 20 28 6d action-mutex* (m
1510: 61 6b 65 2d 6d 75 74 65 78 29 29 0a 3b 3b 20 28 ake-mutex)).;; (
1520: 64 65 66 69 6e 65 20 2a 64 62 2d 63 61 63 68 65 define *db-cache
1530: 2d 70 61 74 68 2a 20 20 20 20 20 20 20 23 66 29 -path* #f)
1540: 0a 28 64 65 66 69 6e 65 20 2a 64 62 2d 77 69 74 .(define *db-wit
1550: 68 2d 64 62 2d 6d 75 74 65 78 2a 20 20 20 20 28 h-db-mutex* (
1560: 6d 61 6b 65 2d 6d 75 74 65 78 29 29 0a 28 64 65 make-mutex)).(de
1570: 66 69 6e 65 20 2a 64 62 2d 61 70 69 2d 63 61 6c fine *db-api-cal
1580: 6c 2d 74 69 6d 65 2a 20 20 20 20 28 6d 61 6b 65 l-time* (make
1590: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b -hash-table)) ;;
15a0: 20 68 61 73 68 20 6f 66 20 63 6f 6d 6d 61 6e 64 hash of command
15b0: 20 3d 3e 20 28 6c 69 73 74 20 6f 66 20 74 69 6d => (list of tim
15c0: 65 73 29 0a 3b 3b 20 6e 6f 20 73 79 6e 63 20 64 es).;; no sync d
15d0: 62 0a 28 64 65 66 69 6e 65 20 2a 6e 6f 2d 73 79 b.(define *no-sy
15e0: 6e 63 2d 64 62 2a 20 20 20 20 20 20 20 20 20 20 nc-db*
15f0: 23 66 29 0a 0a 3b 3b 20 53 45 52 56 45 52 0a 28 #f)..;; SERVER.(
1600: 64 65 66 69 6e 65 20 2a 6d 79 2d 63 6c 69 65 6e define *my-clien
1610: 74 2d 73 69 67 6e 61 74 75 72 65 2a 20 23 66 29 t-signature* #f)
1620: 0a 28 64 65 66 69 6e 65 20 2a 74 72 61 6e 73 70 .(define *transp
1630: 6f 72 74 2d 74 79 70 65 2a 20 20 20 20 27 68 74 ort-type* 'ht
1640: 74 70 29 20 20 20 20 20 20 20 20 20 20 20 20 20 tp)
1650: 3b 3b 20 6f 76 65 72 72 69 64 65 20 77 69 74 68 ;; override with
1660: 20 5b 73 65 72 76 65 72 5d 20 74 72 61 6e 73 70 [server] transp
1670: 6f 72 74 20 68 74 74 70 7c 72 70 63 7c 6e 6d 73 ort http|rpc|nms
1680: 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 6e 72 65 g.(define *runre
1690: 6d 6f 74 65 2a 20 20 20 20 20 20 20 20 20 23 66 mote* #f
16a0: 29 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 )
16b0: 20 3b 3b 20 69 66 20 73 65 74 20 75 70 20 66 6f ;; if set up fo
16c0: 72 20 73 65 72 76 65 72 20 63 6f 6d 6d 75 6e 69 r server communi
16d0: 63 61 74 69 6f 6e 20 74 68 69 73 20 77 69 6c 6c cation this will
16e0: 20 68 6f 6c 64 20 3c 68 6f 73 74 20 70 6f 72 74 hold <host port
16f0: 3e 0a 3b 3b 20 28 64 65 66 69 6e 65 20 2a 6d 61 >.;; (define *ma
1700: 78 2d 63 61 63 68 65 2d 73 69 7a 65 2a 20 20 20 x-cache-size*
1710: 20 30 29 0a 28 64 65 66 69 6e 65 20 2a 6c 6f 67 0).(define *log
1720: 67 65 64 2d 69 6e 2d 63 6c 69 65 6e 74 73 2a 20 ged-in-clients*
1730: 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 (make-hash-table
1740: 29 29 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 76 )).(define *serv
1750: 65 72 2d 69 64 2a 20 20 20 20 20 20 20 20 20 23 er-id* #
1760: 66 29 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 76 f).(define *serv
1770: 65 72 2d 69 6e 66 6f 2a 20 20 20 20 20 20 20 23 er-info* #
1780: 66 29 20 20 3b 3b 20 67 6f 6f 64 20 63 61 6e 64 f) ;; good cand
1790: 69 64 61 74 65 20 66 6f 72 20 65 61 73 69 6c 79 idate for easily
17a0: 20 63 6f 6e 76 65 72 74 20 74 6f 20 6e 6f 6e 2d convert to non-
17b0: 67 6c 6f 62 61 6c 0a 28 64 65 66 69 6e 65 20 2a global.(define *
17c0: 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 20 20 20 time-to-exit*
17d0: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
17e0: 73 65 72 76 65 72 2d 72 75 6e 2a 20 20 20 20 20 server-run*
17f0: 20 20 20 23 74 29 0a 28 64 65 66 69 6e 65 20 2a #t).(define *
1800: 72 75 6e 2d 69 64 2a 20 20 20 20 20 20 20 20 20 run-id*
1810: 20 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 2a #f).(define *
1820: 73 65 72 76 65 72 2d 6b 69 6e 64 2d 72 75 6e 2a server-kind-run*
1830: 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 (make-hash-ta
1840: 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 68 ble)).(define *h
1850: 6f 6d 65 2d 68 6f 73 74 2a 20 20 20 20 20 20 20 ome-host*
1860: 20 20 23 66 29 0a 3b 3b 20 28 64 65 66 69 6e 65 #f).;; (define
1870: 20 2a 74 6f 74 61 6c 2d 6e 6f 6e 2d 77 72 69 74 *total-non-writ
1880: 65 2d 64 65 6c 61 79 2a 20 30 29 0a 28 64 65 66 e-delay* 0).(def
1890: 69 6e 65 20 2a 68 65 61 72 74 62 65 61 74 2d 6d ine *heartbeat-m
18a0: 75 74 65 78 2a 20 20 20 28 6d 61 6b 65 2d 6d 75 utex* (make-mu
18b0: 74 65 78 29 29 0a 28 64 65 66 69 6e 65 20 2a 61 tex)).(define *a
18c0: 70 69 2d 70 72 6f 63 65 73 73 2d 72 65 71 75 65 pi-process-reque
18d0: 73 74 2d 63 6f 75 6e 74 2a 20 30 29 0a 28 64 65 st-count* 0).(de
18e0: 66 69 6e 65 20 2a 6d 61 78 2d 61 70 69 2d 70 72 fine *max-api-pr
18f0: 6f 63 65 73 73 2d 72 65 71 75 65 73 74 73 2a 20 ocess-requests*
1900: 30 29 0a 28 64 65 66 69 6e 65 20 2a 73 65 72 76 0).(define *serv
1910: 65 72 2d 6f 76 65 72 6c 6f 61 64 65 64 2a 20 20 er-overloaded*
1920: 23 66 29 0a 0a 3b 3b 20 63 6c 69 65 6e 74 0a 28 #f)..;; client.(
1930: 64 65 66 69 6e 65 20 2a 72 6d 74 2d 6d 75 74 65 define *rmt-mute
1940: 78 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 x* (make
1950: 2d 6d 75 74 65 78 29 29 20 20 20 20 20 3b 3b 20 -mutex)) ;;
1960: 72 65 6d 6f 74 65 20 61 63 63 65 73 73 20 63 61 remote access ca
1970: 6c 6c 73 20 6d 75 74 65 78 20 0a 0a 3b 3b 20 52 lls mutex ..;; R
1980: 50 43 20 74 72 61 6e 73 70 6f 72 74 0a 28 64 65 PC transport.(de
1990: 66 69 6e 65 20 2a 72 70 63 3a 6c 69 73 74 65 6e fine *rpc:listen
19a0: 65 72 2a 20 20 20 20 20 20 23 66 29 0a 0a 3b 3b er* #f)..;;
19b0: 20 4b 45 59 20 69 6e 66 6f 0a 28 64 65 66 69 6e KEY info.(defin
19c0: 65 20 2a 74 61 72 67 65 74 2a 20 20 20 20 20 20 e *target*
19d0: 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 (make-hash
19e0: 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 -table)) ;; cach
19f0: 65 20 74 68 65 20 74 61 72 67 65 74 20 68 65 72 e the target her
1a00: 65 3b 20 74 61 72 67 65 74 20 69 73 20 6b 65 79 e; target is key
1a10: 76 61 6c 31 2f 6b 65 79 76 61 6c 32 2f 2e 2e 2e val1/keyval2/...
1a20: 2f 6b 65 79 76 61 6c 4e 0a 28 64 65 66 69 6e 65 /keyvalN.(define
1a30: 20 2a 6b 65 79 73 2a 20 20 20 20 20 20 20 20 20 *keys*
1a40: 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d (make-hash-
1a50: 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 table)) ;; cache
1a60: 20 74 68 65 20 6b 65 79 73 20 68 65 72 65 0a 28 the keys here.(
1a70: 64 65 66 69 6e 65 20 2a 6b 65 79 76 61 6c 73 2a define *keyvals*
1a80: 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 (make
1a90: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 28 64 -hash-table)).(d
1aa0: 65 66 69 6e 65 20 2a 74 6f 70 74 65 73 74 2d 70 efine *toptest-p
1ab0: 61 74 68 73 2a 20 20 20 20 20 28 6d 61 6b 65 2d aths* (make-
1ac0: 68 61 73 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 hash-table)) ;;
1ad0: 63 61 63 68 65 20 74 6f 70 74 65 73 74 20 70 61 cache toptest pa
1ae0: 74 68 20 73 65 74 74 69 6e 67 73 20 68 65 72 65 th settings here
1af0: 0a 28 64 65 66 69 6e 65 20 2a 74 65 73 74 2d 70 .(define *test-p
1b00: 61 74 68 73 2a 20 20 20 20 20 20 20 20 28 6d 61 aths* (ma
1b10: 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
1b20: 3b 3b 20 63 61 63 68 65 20 74 65 73 74 2d 69 64 ;; cache test-id
1b30: 20 74 6f 20 74 65 73 74 20 72 75 6e 20 70 61 74 to test run pat
1b40: 68 73 20 68 65 72 65 0a 28 64 65 66 69 6e 65 20 hs here.(define
1b50: 2a 74 65 73 74 2d 69 64 73 2a 20 20 20 20 20 20 *test-ids*
1b60: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1b70: 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 68 65 20 able)) ;; cache
1b80: 72 75 6e 2d 69 64 2c 20 74 65 73 74 6e 61 6d 65 run-id, testname
1b90: 2c 20 61 6e 64 20 69 74 65 6d 2d 70 61 74 68 20 , and item-path
1ba0: 3d 3e 20 74 65 73 74 2d 69 64 0a 28 64 65 66 69 => test-id.(defi
1bb0: 6e 65 20 2a 74 65 73 74 2d 69 6e 66 6f 2a 20 20 ne *test-info*
1bc0: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
1bd0: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 63 61 63 h-table)) ;; cac
1be0: 68 65 20 74 68 65 20 74 65 73 74 20 69 6e 66 6f he the test info
1bf0: 20 72 65 63 6f 72 64 73 2c 20 75 70 64 61 74 65 records, update
1c00: 20 74 68 65 20 73 74 61 74 65 2c 20 73 74 61 74 the state, stat
1c10: 75 73 2c 20 72 75 6e 5f 64 75 72 61 74 69 6f 6e us, run_duration
1c20: 20 65 74 63 2e 20 66 72 6f 6d 20 74 65 73 74 64 etc. from testd
1c30: 61 74 2e 64 62 0a 0a 28 64 65 66 69 6e 65 20 2a at.db..(define *
1c40: 72 75 6e 2d 69 6e 66 6f 2d 63 61 63 68 65 2a 20 run-info-cache*
1c50: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
1c60: 61 62 6c 65 29 29 20 3b 3b 20 72 75 6e 20 69 6e able)) ;; run in
1c70: 66 6f 20 69 73 20 73 74 61 62 6c 65 2c 20 6e 6f fo is stable, no
1c80: 20 6e 65 65 64 20 74 6f 20 72 65 67 65 74 0a 28 need to reget.(
1c90: 64 65 66 69 6e 65 20 2a 6c 61 75 6e 63 68 2d 73 define *launch-s
1ca0: 65 74 75 70 2d 6d 75 74 65 78 2a 20 28 6d 61 6b etup-mutex* (mak
1cb0: 65 2d 6d 75 74 65 78 29 29 20 20 20 20 20 3b 3b e-mutex)) ;;
1cc0: 20 6e 65 65 64 20 74 6f 20 62 65 20 61 62 6c 65 need to be able
1cd0: 20 74 6f 20 63 61 6c 6c 20 6c 61 75 6e 63 68 3a to call launch:
1ce0: 73 65 74 75 70 20 6f 66 74 65 6e 20 73 6f 20 6d setup often so m
1cf0: 75 74 65 78 20 69 74 20 61 6e 64 20 72 65 2d 63 utex it and re-c
1d00: 61 6c 6c 20 74 68 65 20 72 65 61 6c 20 64 65 61 all the real dea
1d10: 6c 20 6f 6e 6c 79 20 69 66 20 2a 74 6f 70 70 61 l only if *toppa
1d20: 74 68 2a 20 6e 6f 74 20 73 65 74 0a 28 64 65 66 th* not set.(def
1d30: 69 6e 65 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 ine *homehost-mu
1d40: 74 65 78 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d tex* (make-m
1d50: 75 74 65 78 29 29 0a 0a 3b 3b 20 4d 69 73 63 65 utex))..;; Misce
1d60: 6c 6c 61 6e 65 6f 75 73 0a 28 64 65 66 69 6e 65 llaneous.(define
1d70: 20 2a 74 72 69 67 67 65 72 73 2d 6d 75 74 65 78 *triggers-mutex
1d80: 2a 20 20 20 20 20 28 6d 61 6b 65 2d 6d 75 74 65 * (make-mute
1d90: 78 29 29 20 20 20 20 20 3b 3b 20 62 6c 6f 63 6b x)) ;; block
1da0: 20 6f 76 65 72 6c 61 70 70 69 6e 67 20 70 72 6f overlapping pro
1db0: 63 65 73 73 69 6e 67 20 6f 66 20 74 72 69 67 67 cessing of trigg
1dc0: 65 72 73 0a 0a 28 64 65 66 73 74 72 75 63 74 20 ers..(defstruct
1dd0: 72 65 6d 6f 74 65 0a 20 20 28 68 68 2d 64 61 74 remote. (hh-dat
1de0: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6d (com
1df0: 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mon:get-homehost
1e00: 29 29 20 3b 3b 20 68 6f 6d 65 68 6f 73 74 20 72 )) ;; homehost r
1e10: 65 63 6f 72 64 20 28 20 61 64 64 72 20 2e 20 68 ecord ( addr . h
1e20: 68 66 6c 61 67 20 29 0a 20 20 28 73 65 72 76 65 hflag ). (serve
1e30: 72 2d 75 72 6c 20 20 20 20 20 20 20 20 28 69 66 r-url (if
1e40: 20 2a 74 6f 70 70 61 74 68 2a 20 28 73 65 72 76 *toppath* (serv
1e50: 65 72 3a 63 68 65 63 6b 2d 69 66 2d 72 75 6e 6e er:check-if-runn
1e60: 69 6e 67 20 2a 74 6f 70 70 61 74 68 2a 29 29 29 ing *toppath*)))
1e70: 20 3b 3b 20 28 73 65 72 76 65 72 3a 63 68 65 63 ;; (server:chec
1e80: 6b 2d 69 66 2d 72 75 6e 6e 69 6e 67 20 2a 74 6f k-if-running *to
1e90: 70 70 61 74 68 2a 29 20 23 66 29 29 0a 20 20 28 ppath*) #f)). (
1ea0: 6c 61 73 74 2d 73 65 72 76 65 72 2d 63 68 65 63 last-server-chec
1eb0: 6b 20 30 29 20 20 3b 3b 20 6c 61 73 74 20 74 69 k 0) ;; last ti
1ec0: 6d 65 20 77 65 20 63 68 65 63 6b 65 64 20 74 6f me we checked to
1ed0: 20 73 65 65 20 69 66 20 74 68 65 20 73 65 72 76 see if the serv
1ee0: 65 72 20 77 61 73 20 61 6c 69 76 65 0a 20 20 28 er was alive. (
1ef0: 63 6f 6e 6e 64 61 74 20 20 20 20 20 20 20 20 20 conndat
1f00: 20 20 23 66 29 0a 20 20 28 74 72 61 6e 73 70 6f #f). (transpo
1f10: 72 74 20 20 20 20 20 20 20 20 20 2a 74 72 61 6e rt *tran
1f20: 73 70 6f 72 74 2d 74 79 70 65 2a 29 0a 20 20 28 sport-type*). (
1f30: 73 65 72 76 65 72 2d 74 69 6d 65 6f 75 74 20 20 server-timeout
1f40: 20 20 28 73 65 72 76 65 72 3a 65 78 70 69 72 61 (server:expira
1f50: 74 69 6f 6e 2d 74 69 6d 65 6f 75 74 29 29 0a 20 tion-timeout)).
1f60: 20 28 66 6f 72 63 65 2d 73 65 72 76 65 72 20 20 (force-server
1f70: 20 20 20 20 23 66 29 0a 20 20 28 72 6f 2d 6d 6f #f). (ro-mo
1f80: 64 65 20 20 20 20 20 20 20 20 20 20 20 23 66 29 de #f)
1f90: 20 20 0a 20 20 28 72 6f 2d 6d 6f 64 65 2d 63 68 . (ro-mode-ch
1fa0: 65 63 6b 65 64 20 20 20 23 66 29 29 20 3b 3b 20 ecked #f)) ;;
1fb0: 66 6c 61 67 20 74 68 61 74 20 69 6e 64 69 63 61 flag that indica
1fc0: 74 65 73 20 77 65 20 68 61 76 65 20 63 68 65 63 tes we have chec
1fd0: 6b 65 64 20 66 6f 72 20 72 6f 2d 6d 6f 64 65 0a ked for ro-mode.
1fe0: 0a 3b 3b 20 6c 61 75 6e 63 68 69 6e 67 20 61 6e .;; launching an
1ff0: 64 20 68 6f 73 74 73 0a 28 64 65 66 73 74 72 75 d hosts.(defstru
2000: 63 74 20 68 6f 73 74 0a 20 20 28 72 65 61 63 68 ct host. (reach
2010: 61 62 6c 65 20 20 20 20 23 66 29 0a 20 20 28 6c able #f). (l
2020: 61 73 74 2d 75 70 64 61 74 65 20 20 30 29 0a 20 ast-update 0).
2030: 20 28 6c 61 73 74 2d 75 73 65 64 20 20 20 20 30 (last-used 0
2040: 29 0a 20 20 28 6c 61 73 74 2d 63 70 75 6c 6f 61 ). (last-cpuloa
2050: 64 20 31 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a d 1))..(define *
2060: 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 20 20 20 20 host-loads*
2070: 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 (make-hash-t
2080: 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 65 able))..;; cache
2090: 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 76 61 72 environment var
20a0: 73 20 66 6f 72 20 65 61 63 68 20 72 75 6e 20 68 s for each run h
20b0: 65 72 65 0a 28 64 65 66 69 6e 65 20 2a 65 6e 76 ere.(define *env
20c0: 2d 76 61 72 73 2d 62 79 2d 72 75 6e 2d 69 64 2a -vars-by-run-id*
20d0: 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
20e0: 65 29 29 0a 0a 3b 3b 20 54 65 73 74 63 6f 6e 66 e))..;; Testconf
20f0: 69 67 20 61 6e 64 20 72 75 6e 63 6f 6e 66 69 67 ig and runconfig
2100: 20 63 61 63 68 65 73 2e 20 0a 28 64 65 66 69 6e caches. .(defin
2110: 65 20 2a 74 65 73 74 63 6f 6e 66 69 67 73 2a 20 e *testconfigs*
2120: 20 20 20 20 20 20 20 28 6d 61 6b 65 2d 68 61 73 (make-has
2130: 68 2d 74 61 62 6c 65 29 29 20 3b 3b 20 74 65 73 h-table)) ;; tes
2140: 74 2d 6e 61 6d 65 20 3d 3e 20 74 65 73 74 63 6f t-name => testco
2150: 6e 66 69 67 0a 28 64 65 66 69 6e 65 20 2a 72 75 nfig.(define *ru
2160: 6e 63 6f 6e 66 69 67 73 2a 20 20 20 20 20 20 20 nconfigs*
2170: 20 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 (make-hash-tab
2180: 6c 65 29 29 20 3b 3b 20 74 61 72 67 65 74 20 20 le)) ;; target
2190: 20 20 3d 3e 20 72 75 6e 63 6f 6e 66 69 67 0a 0a => runconfig..
21a0: 3b 3b 20 54 68 69 73 20 69 73 20 61 20 63 61 63 ;; This is a cac
21b0: 68 65 20 6f 66 20 70 72 65 2d 72 65 71 73 20 6d he of pre-reqs m
21c0: 65 74 2c 20 64 6f 6e 27 74 20 72 65 2d 63 61 6c et, don't re-cal
21d0: 63 20 69 6e 20 63 61 73 65 73 20 77 68 65 72 65 c in cases where
21e0: 20 63 61 6c 6c 65 64 20 77 69 74 68 20 73 61 6d called with sam
21f0: 65 20 70 61 72 61 6d 73 20 6c 65 73 73 20 74 68 e params less th
2200: 61 6e 0a 3b 3b 20 66 69 76 65 20 73 65 63 6f 6e an.;; five secon
2210: 64 73 20 61 67 6f 0a 28 64 65 66 69 6e 65 20 2a ds ago.(define *
2220: 70 72 65 2d 72 65 71 73 2d 6d 65 74 2d 63 61 63 pre-reqs-met-cac
2230: 68 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 he* (make-hash-t
2240: 61 62 6c 65 29 29 0a 0a 3b 3b 20 63 61 63 68 65 able))..;; cache
2250: 20 6f 66 20 76 65 72 62 6f 73 69 74 79 20 67 69 of verbosity gi
2260: 76 65 6e 20 73 74 72 69 6e 67 0a 3b 3b 0a 28 64 ven string.;;.(d
2270: 65 66 69 6e 65 20 2a 76 65 72 62 6f 73 69 74 79 efine *verbosity
2280: 2d 63 61 63 68 65 2a 20 20 20 20 28 6d 61 6b 65 -cache* (make
2290: 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 0a 28 -hash-table))..(
22a0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 define (common:c
22b0: 6c 65 61 72 2d 63 61 63 68 65 73 29 0a 20 20 28 lear-caches). (
22c0: 73 65 74 21 20 2a 74 61 72 67 65 74 2a 20 20 20 set! *target*
22d0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
22e0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
22f0: 73 65 74 21 20 2a 6b 65 79 73 2a 20 20 20 20 20 set! *keys*
2300: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
2310: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
2320: 73 65 74 21 20 2a 6b 65 79 76 61 6c 73 2a 20 20 set! *keyvals*
2330: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
2340: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
2350: 73 65 74 21 20 2a 74 6f 70 74 65 73 74 2d 70 61 set! *toptest-pa
2360: 74 68 73 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d ths* (make-
2370: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
2380: 73 65 74 21 20 2a 74 65 73 74 2d 70 61 74 68 73 set! *test-paths
2390: 2a 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d * (make-
23a0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
23b0: 73 65 74 21 20 2a 74 65 73 74 2d 69 64 73 2a 20 set! *test-ids*
23c0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
23d0: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
23e0: 73 65 74 21 20 2a 74 65 73 74 2d 69 6e 66 6f 2a set! *test-info*
23f0: 20 20 20 20 20 20 20 20 20 20 28 6d 61 6b 65 2d (make-
2400: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
2410: 73 65 74 21 20 2a 72 75 6e 2d 69 6e 66 6f 2d 63 set! *run-info-c
2420: 61 63 68 65 2a 20 20 20 20 20 28 6d 61 6b 65 2d ache* (make-
2430: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
2440: 73 65 74 21 20 2a 65 6e 76 2d 76 61 72 73 2d 62 set! *env-vars-b
2450: 79 2d 72 75 6e 2d 69 64 2a 20 28 6d 61 6b 65 2d y-run-id* (make-
2460: 68 61 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 28 hash-table)). (
2470: 73 65 74 21 20 2a 74 65 73 74 2d 69 64 2d 63 61 set! *test-id-ca
2480: 63 68 65 2a 20 20 20 20 20 20 28 6d 61 6b 65 2d che* (make-
2490: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 0a 0a 3b hash-table)))..;
24a0: 3b 20 47 65 6e 65 72 69 63 20 73 74 72 69 6e 67 ; Generic string
24b0: 20 64 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e database.(defin
24c0: 65 20 73 64 62 3a 71 72 79 20 23 66 29 20 3b 3b e sdb:qry #f) ;;
24d0: 20 28 6d 61 6b 65 2d 73 64 62 3a 71 72 79 29 29 (make-sdb:qry))
24e0: 20 3b 3b 20 20 27 69 6e 69 74 20 23 66 29 0a 3b ;; 'init #f).;
24f0: 3b 20 47 65 6e 65 72 69 63 20 70 61 74 68 20 64 ; Generic path d
2500: 61 74 61 62 61 73 65 0a 28 64 65 66 69 6e 65 20 atabase.(define
2510: 2a 66 64 62 2a 20 23 66 29 0a 0a 28 64 65 66 69 *fdb* #f)..(defi
2520: 6e 65 20 2a 6c 61 73 74 2d 6c 61 75 6e 63 68 2a ne *last-launch*
2530: 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 (current-second
2540: 73 29 29 20 3b 3b 20 75 73 65 20 66 6f 72 20 74 s)) ;; use for t
2550: 68 72 6f 74 74 6c 69 6e 67 20 74 68 65 20 6c 61 hrottling the la
2560: 75 6e 63 68 20 72 61 74 65 2e 20 57 6f 75 6c 64 unch rate. Would
2570: 20 62 65 20 62 65 74 74 65 72 20 74 6f 20 75 73 be better to us
2580: 65 20 74 68 65 20 64 62 20 61 6e 64 20 6c 61 73 e the db and las
2590: 74 20 74 69 6d 65 20 6f 66 20 61 20 74 65 73 74 t time of a test
25a0: 20 69 6e 20 4c 41 55 4e 43 48 45 44 20 73 74 61 in LAUNCHED sta
25b0: 74 65 2e 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d te...;;=========
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 0a 3b 3b =============.;;
2600: 20 56 20 45 20 52 20 53 20 49 20 4f 20 4e 0a 3b V E R S I O N.;
2610: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
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 0a 0a 28 64 65 66 69 6e 65 =======..(define
2660: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c (common:get-ful
2670: 6c 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 63 6f l-version). (co
2680: 6e 63 20 6d 65 67 61 74 65 73 74 2d 76 65 72 73 nc megatest-vers
2690: 69 6f 6e 20 22 2d 22 20 6d 65 67 61 74 65 73 74 ion "-" megatest
26a0: 2d 66 6f 73 73 69 6c 2d 68 61 73 68 29 29 0a 0a -fossil-hash))..
26b0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
26c0: 76 65 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 version-signatur
26d0: 65 29 0a 20 20 28 63 6f 6e 63 20 6d 65 67 61 74 e). (conc megat
26e0: 65 73 74 2d 76 65 72 73 69 6f 6e 20 22 2d 22 20 est-version "-"
26f0: 28 73 75 62 73 74 72 69 6e 67 20 6d 65 67 61 74 (substring megat
2700: 65 73 74 2d 66 6f 73 73 69 6c 2d 68 61 73 68 20 est-fossil-hash
2710: 30 20 34 29 29 29 0a 0a 3b 3b 20 66 72 6f 6d 20 0 4)))..;; from
2720: 6d 65 74 61 64 61 74 20 6c 6f 6f 6b 75 70 20 4d metadat lookup M
2730: 45 47 41 54 45 53 54 5f 56 45 52 53 49 4f 4e 0a EGATEST_VERSION.
2740: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
2750: 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d on:get-last-run-
2760: 76 65 72 73 69 6f 6e 29 20 3b 3b 20 52 41 44 54 version) ;; RADT
2770: 20 3d 3e 20 48 6f 77 20 64 6f 65 73 20 74 68 69 => How does thi
2780: 73 20 77 6f 72 6b 20 69 6e 20 73 65 6e 64 2d 72 s work in send-r
2790: 65 63 65 69 76 65 20 66 75 6e 63 74 69 6f 6e 3f eceive function?
27a0: 3f 3b 20 61 73 73 75 6d 65 20 69 74 20 69 73 20 ?; assume it is
27b0: 74 68 65 20 76 61 6c 75 65 20 73 61 76 65 64 20 the value saved
27c0: 69 6e 20 73 6f 6d 65 20 44 42 0a 20 20 28 72 6d in some DB. (rm
27d0: 74 3a 67 65 74 2d 76 61 72 20 22 4d 45 47 41 54 t:get-var "MEGAT
27e0: 45 53 54 5f 56 45 52 53 49 4f 4e 22 29 29 0a 0a EST_VERSION"))..
27f0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
2800: 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 get-last-run-ver
2810: 73 69 6f 6e 2d 6e 75 6d 62 65 72 29 0a 20 20 28 sion-number). (
2820: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 0a string->number .
2830: 20 20 20 28 73 75 62 73 74 72 69 6e 67 20 28 63 (substring (c
2840: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 ommon:get-last-r
2850: 75 6e 2d 76 65 72 73 69 6f 6e 29 20 30 20 36 29 un-version) 0 6)
2860: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
2870: 6d 6f 6e 3a 73 65 74 2d 6c 61 73 74 2d 72 75 6e mon:set-last-run
2880: 2d 76 65 72 73 69 6f 6e 29 0a 20 20 28 72 6d 74 -version). (rmt
2890: 3a 73 65 74 2d 76 61 72 20 22 4d 45 47 41 54 45 :set-var "MEGATE
28a0: 53 54 5f 56 45 52 53 49 4f 4e 22 20 28 63 6f 6d ST_VERSION" (com
28b0: 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d 73 69 67 6e mon:version-sign
28c0: 61 74 75 72 65 29 29 29 0a 0a 3b 3b 20 70 6f 73 ature)))..;; pos
28d0: 74 69 76 65 20 6e 75 6d 62 65 72 20 69 66 20 6d tive number if m
28e0: 65 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e 20 egatest version
28f0: 3e 20 64 62 20 76 65 72 73 69 6f 6e 0a 3b 3b 20 > db version.;;
2900: 6e 65 67 61 74 69 76 65 20 6e 75 6d 62 65 72 20 negative number
2910: 69 66 20 6d 65 67 61 74 65 73 74 20 76 65 72 73 if megatest vers
2920: 69 6f 6e 20 3c 20 64 62 20 76 65 72 73 69 6f 6e ion < db version
2930: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
2940: 3a 76 65 72 73 69 6f 6e 2d 64 62 2d 64 65 6c 74 :version-db-delt
2950: 61 29 0a 20 20 20 20 20 20 20 20 20 28 2d 20 6d a). (- m
2960: 65 67 61 74 65 73 74 2d 76 65 72 73 69 6f 6e 20 egatest-version
2970: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 (common:get-last
2980: 2d 72 75 6e 2d 76 65 72 73 69 6f 6e 2d 6e 75 6d -run-version-num
2990: 62 65 72 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ber)))..(define
29a0: 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d (common:version-
29b0: 63 68 61 6e 67 65 64 3f 29 0a 20 20 28 6e 6f 74 changed?). (not
29c0: 20 28 65 71 75 61 6c 3f 20 28 63 6f 6d 6d 6f 6e (equal? (common
29d0: 3a 67 65 74 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 :get-last-run-ve
29e0: 72 73 69 6f 6e 29 0a 20 20 20 20 20 20 20 20 20 rsion).
29f0: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 76 65 (common:ve
2a00: 72 73 69 6f 6e 2d 73 69 67 6e 61 74 75 72 65 29 rsion-signature)
2a10: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f )))..(define (co
2a20: 6d 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e 67 65 64 mmon:api-changed
2a30: 3f 29 0a 20 20 28 6e 6f 74 20 28 65 71 75 61 6c ?). (not (equal
2a40: 3f 20 28 73 75 62 73 74 72 69 6e 67 20 28 2d 3e ? (substring (->
2a50: 73 74 72 69 6e 67 20 6d 65 67 61 74 65 73 74 2d string megatest-
2a60: 76 65 72 73 69 6f 6e 29 20 30 20 34 29 0a 20 20 version) 0 4).
2a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 75 (su
2a80: 62 73 74 72 69 6e 67 20 28 63 6f 6e 63 20 28 63 bstring (conc (c
2a90: 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 61 73 74 2d 72 ommon:get-last-r
2aa0: 75 6e 2d 76 65 72 73 69 6f 6e 29 29 20 30 20 34 un-version)) 0 4
2ab0: 29 29 29 29 0a 20 20 0a 3b 3b 20 4d 6f 76 65 20 )))). .;; Move
2ac0: 6d 65 20 65 6c 73 65 77 68 65 72 65 20 2e 2e 2e me elsewhere ...
2ad0: 0a 3b 3b 20 52 41 44 54 20 3d 3e 20 57 68 79 20 .;; RADT => Why
2ae0: 64 6f 20 77 65 20 6d 65 65 64 20 74 68 65 20 76 do we meed the v
2af0: 65 72 73 69 6f 6e 20 63 68 65 63 6b 20 68 65 72 ersion check her
2b00: 65 2c 20 74 68 69 73 20 69 73 20 63 61 6c 6c 65 e, this is calle
2b10: 64 20 6f 6e 6c 79 20 69 66 20 76 65 72 73 69 6f d only if versio
2b20: 6e 20 6d 69 73 6d 61 0a 3b 3b 0a 28 64 65 66 69 n misma.;;.(defi
2b30: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e ne (common:clean
2b40: 75 70 2d 64 62 20 64 62 73 74 72 75 63 74 20 23 up-db dbstruct #
2b50: 21 6b 65 79 20 28 66 75 6c 6c 20 23 66 29 29 0a !key (full #f)).
2b60: 20 20 28 61 70 70 6c 79 20 64 62 3a 6d 75 6c 74 (apply db:mult
2b70: 69 2d 64 62 2d 73 79 6e 63 20 0a 20 20 20 64 62 i-db-sync . db
2b80: 73 74 72 75 63 74 0a 20 20 20 27 73 63 68 65 6d struct. 'schem
2b90: 61 0a 20 20 20 3b 3b 20 27 6e 65 77 32 6f 6c 64 a. ;; 'new2old
2ba0: 0a 20 20 20 27 6b 69 6c 6c 73 65 72 76 65 72 73 . 'killservers
2bb0: 0a 20 20 20 27 61 64 6a 2d 74 61 72 67 65 74 0a . 'adj-target.
2bc0: 20 20 20 3b 3b 20 27 6f 6c 64 32 6e 65 77 0a 20 ;; 'old2new.
2bd0: 20 20 27 6e 65 77 32 6f 6c 64 0a 20 20 20 3b 3b 'new2old. ;;
2be0: 20 28 69 66 20 66 75 6c 6c 0a 20 20 20 20 20 20 (if full.
2bf0: 20 27 28 64 65 6a 75 6e 6b 29 0a 20 20 20 20 20 '(dejunk).
2c00: 20 20 3b 3b 20 27 28 29 29 0a 20 20 20 20 20 20 ;; '()).
2c10: 20 29 0a 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e ). (if (common
2c20: 3a 61 70 69 2d 63 68 61 6e 67 65 64 3f 29 0a 20 :api-changed?).
2c30: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 73 65 74 (common:set
2c40: 2d 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f -last-run-versio
2c50: 6e 29 29 29 0a 0a 3b 3b 20 52 6f 74 61 74 65 20 n)))..;; Rotate
2c60: 6c 6f 67 73 2c 20 6c 6f 67 69 63 3a 20 0a 3b 3b logs, logic: .;;
2c70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2c80: 20 69 66 20 3e 20 35 30 30 6b 20 61 6e 64 20 6f if > 500k and o
2c90: 6c 64 65 72 20 74 68 61 6e 20 31 20 77 65 65 6b lder than 1 week
2ca0: 3a 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 :.;;
2cb0: 20 20 20 20 20 20 20 20 20 72 65 6d 6f 76 65 20 remove
2cc0: 70 72 65 76 69 6f 75 73 20 63 6f 6d 70 72 65 73 previous compres
2cd0: 73 65 64 20 6c 6f 67 20 61 6e 64 20 63 6f 6d 70 sed log and comp
2ce0: 72 65 73 73 20 74 68 69 73 20 6c 6f 67 0a 3b 3b ress this log.;;
2cf0: 20 57 41 52 4e 49 4e 47 3a 20 54 68 69 73 20 70 WARNING: This p
2d00: 72 6f 63 20 6f 70 65 72 61 74 65 73 20 61 73 73 roc operates ass
2d10: 75 6d 69 6e 67 20 74 68 61 74 20 69 74 20 69 73 uming that it is
2d20: 20 69 6e 20 74 68 65 20 64 69 72 65 63 74 6f 72 in the director
2d30: 79 20 61 62 6f 76 65 20 74 68 65 0a 3b 3b 20 20 y above the.;;
2d40: 20 20 20 20 20 20 20 20 6c 6f 67 73 20 64 69 72 logs dir
2d50: 65 63 74 6f 72 79 20 79 6f 75 20 77 69 73 68 20 ectory you wish
2d60: 74 6f 20 6c 6f 67 2d 72 6f 74 61 74 65 2e 0a 3b to log-rotate..;
2d70: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
2d80: 6e 3a 72 6f 74 61 74 65 2d 6c 6f 67 73 29 0a 20 n:rotate-logs).
2d90: 20 28 69 66 20 28 6e 6f 74 20 28 64 69 72 65 63 (if (not (direc
2da0: 74 6f 72 79 2d 65 78 69 73 74 73 3f 20 22 6c 6f tory-exists? "lo
2db0: 67 73 22 29 29 28 63 72 65 61 74 65 2d 64 69 72 gs"))(create-dir
2dc0: 65 63 74 6f 72 79 20 22 6c 6f 67 73 22 29 29 0a ectory "logs")).
2dd0: 20 20 28 64 69 72 65 63 74 6f 72 79 2d 66 6f 6c (directory-fol
2de0: 64 20 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 66 d . (lambda (f
2df0: 69 6c 65 20 72 65 6d 29 0a 20 20 20 20 20 28 68 ile rem). (h
2e00: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
2e10: 0a 20 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 . exn.
2e20: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e (debug:print-in
2e30: 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f fo 0 *default-lo
2e40: 67 2d 70 6f 72 74 2a 20 22 66 61 69 6c 65 64 20 g-port* "failed
2e50: 74 6f 20 72 6f 74 61 74 65 20 6c 6f 67 20 22 20 to rotate log "
2e60: 66 69 6c 65 20 22 2c 20 70 72 6f 62 61 62 6c 79 file ", probably
2e70: 20 68 61 6e 64 6c 65 64 20 62 79 20 61 6e 6f 74 handled by anot
2e80: 68 65 72 20 70 72 6f 63 65 73 73 2e 22 29 0a 20 her process.").
2e90: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 66 75 6c (let* ((ful
2ea0: 6c 6e 61 6d 65 20 28 63 6f 6e 63 20 22 6c 6f 67 lname (conc "log
2eb0: 73 2f 22 20 66 69 6c 65 29 29 0a 20 20 20 20 20 s/" file)).
2ec0: 20 20 20 20 20 20 20 20 28 66 69 6c 65 2d 61 67 (file-ag
2ed0: 65 20 28 2d 20 28 63 75 72 72 65 6e 74 2d 73 65 e (- (current-se
2ee0: 63 6f 6e 64 73 29 28 66 69 6c 65 2d 6d 6f 64 69 conds)(file-modi
2ef0: 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 75 fication-time fu
2f00: 6c 6c 6e 61 6d 65 29 29 29 29 0a 20 20 20 20 20 llname)))).
2f10: 20 20 20 28 69 66 20 28 6f 72 20 28 61 6e 64 20 (if (or (and
2f20: 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 22 5e (string-match "^
2f30: 2e 2a 2e 6c 6f 67 22 20 66 69 6c 65 29 0a 20 20 .*.log" file).
2f40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2f50: 20 20 20 28 3e 20 28 66 69 6c 65 2d 73 69 7a 65 (> (file-size
2f60: 20 66 75 6c 6c 6e 61 6d 65 29 20 32 30 30 30 30 fullname) 20000
2f70: 30 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 0)).
2f80: 20 20 20 20 28 61 6e 64 20 28 73 74 72 69 6e 67 (and (string
2f90: 2d 6d 61 74 63 68 20 22 5e 73 65 72 76 65 72 2d -match "^server-
2fa0: 2e 2a 2e 6c 6f 67 22 20 66 69 6c 65 29 0a 20 20 .*.log" file).
2fb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
2fc0: 20 20 20 28 3e 20 28 2d 20 28 63 75 72 72 65 6e (> (- (curren
2fd0: 74 2d 73 65 63 6f 6e 64 73 29 20 28 66 69 6c 65 t-seconds) (file
2fe0: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
2ff0: 6d 65 20 66 75 6c 6c 6e 61 6d 65 29 29 0a 20 20 me fullname)).
3000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3010: 20 20 20 20 20 20 28 2a 20 38 20 36 30 20 36 30 (* 8 60 60
3020: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
3030: 20 28 6c 65 74 20 28 28 67 7a 66 69 6c 65 20 28 (let ((gzfile (
3040: 63 6f 6e 63 20 66 75 6c 6c 6e 61 6d 65 20 22 2e conc fullname ".
3050: 67 7a 22 29 29 29 0a 20 20 20 20 20 20 20 20 20 gz"))).
3060: 20 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e (if (common
3070: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 67 7a :file-exists? gz
3080: 66 69 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 file).
3090: 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 20 (begin.
30a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
30b0: 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d (debug:print-
30c0: 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d info 0 *default-
30d0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 65 6d 6f 76 log-port* "remov
30e0: 69 6e 67 20 22 20 67 7a 66 69 6c 65 29 0a 20 20 ing " gzfile).
30f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
3100: 20 20 28 64 65 6c 65 74 65 2d 66 69 6c 65 20 67 (delete-file g
3110: 7a 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 20 zfile))).
3120: 20 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 (debug:pr
3130: 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 int-info 0 *defa
3140: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 ult-log-port* "c
3150: 6f 6d 70 72 65 73 73 69 6e 67 20 22 20 66 69 6c ompressing " fil
3160: 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 e).
3170: 20 28 73 79 73 74 65 6d 20 28 63 6f 6e 63 20 22 (system (conc "
3180: 67 7a 69 70 20 22 20 66 75 6c 6c 6e 61 6d 65 29 gzip " fullname)
3190: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
31a0: 69 66 20 28 3e 20 66 69 6c 65 2d 61 67 65 20 28 if (> file-age (
31b0: 2a 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 * (string->numbe
31c0: 72 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c r (or (configf:l
31d0: 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 ookup *configdat
31e0: 2a 20 22 73 65 74 75 70 22 20 22 6c 6f 67 2d 65 * "setup" "log-e
31f0: 78 70 69 72 65 2d 64 61 79 73 22 29 20 22 33 30 xpire-days") "30
3200: 22 29 29 20 32 34 20 33 36 30 30 29 29 0a 20 20 ")) 24 3600)).
3210: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 (h
3220: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
3230: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3240: 20 20 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 exn.
3250: 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 20 #f.
3260: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 6c 65 (dele
3270: 74 65 2d 66 69 6c 65 20 66 75 6c 6c 6e 61 6d 65 te-file fullname
3280: 29 29 29 29 29 29 29 0a 20 20 20 27 28 29 0a 20 ))))))). '().
3290: 20 20 22 6c 6f 67 73 22 29 29 0a 0a 3b 3b 20 46 "logs"))..;; F
32a0: 6f 72 63 65 20 61 20 6d 65 67 61 74 65 73 74 20 orce a megatest
32b0: 63 6c 65 61 6e 75 70 2d 64 62 20 69 66 20 76 65 cleanup-db if ve
32c0: 72 73 69 6f 6e 20 69 73 20 63 68 61 6e 67 65 64 rsion is changed
32d0: 20 61 6e 64 20 73 6b 69 70 2d 76 65 72 73 69 6f and skip-versio
32e0: 6e 2d 63 68 65 63 6b 20 6e 6f 74 20 73 70 65 63 n-check not spec
32f0: 69 66 69 65 64 0a 3b 3b 20 44 6f 20 4e 4f 54 20 ified.;; Do NOT
3300: 63 68 65 63 6b 20 69 66 20 6e 6f 74 20 6f 6e 20 check if not on
3310: 68 6f 6d 65 68 6f 73 74 21 0a 3b 3b 0a 28 64 65 homehost!.;;.(de
3320: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 65 78 69 fine (common:exi
3330: 74 2d 6f 6e 2d 76 65 72 73 69 6f 6e 2d 63 68 61 t-on-version-cha
3340: 6e 67 65 64 29 0a 20 20 28 69 66 20 28 63 6f 6d nged). (if (com
3350: 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 3f mon:on-homehost?
3360: 29 0a 20 20 20 20 20 20 28 69 66 20 28 63 6f 6d ). (if (com
3370: 6d 6f 6e 3a 61 70 69 2d 63 68 61 6e 67 65 64 3f mon:api-changed?
3380: 29 0a 09 20 20 28 6c 65 74 2a 20 28 28 6d 74 63 ).. (let* ((mtc
3390: 6f 6e 66 20 28 63 6f 6e 63 20 28 67 65 74 2d 65 onf (conc (get-e
33a0: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
33b0: 62 6c 65 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 ble "MT_RUN_AREA
33c0: 5f 48 4f 4d 45 22 29 20 22 2f 6d 65 67 61 74 65 _HOME") "/megate
33d0: 73 74 2e 63 6f 6e 66 69 67 22 29 29 0a 20 20 20 st.config")).
33e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 62 (db
33f0: 66 69 6c 65 20 28 63 6f 6e 63 20 28 67 65 74 2d file (conc (get-
3400: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
3410: 61 62 6c 65 20 22 4d 54 5f 52 55 4e 5f 41 52 45 able "MT_RUN_ARE
3420: 41 5f 48 4f 4d 45 22 29 20 22 2f 6d 65 67 61 74 A_HOME") "/megat
3430: 65 73 74 2e 64 62 22 29 29 0a 20 20 20 20 20 20 est.db")).
3440: 20 20 20 20 20 20 20 20 20 20 28 72 65 61 64 2d (read-
3450: 6f 6e 6c 79 20 28 6e 6f 74 20 28 66 69 6c 65 2d only (not (file-
3460: 77 72 69 74 65 2d 61 63 63 65 73 73 3f 20 64 62 write-access? db
3470: 66 69 6c 65 29 29 29 0a 20 20 20 20 20 20 20 20 file))).
3480: 20 20 20 20 20 20 20 20 28 64 62 73 74 72 75 63 (dbstruc
3490: 74 20 28 64 62 3a 73 65 74 75 70 20 23 74 29 29 t (db:setup #t))
34a0: 29 0a 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 ).. (debug:pr
34b0: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
34c0: 6f 67 2d 70 6f 72 74 2a 0a 09 09 09 20 22 57 41 og-port*.... "WA
34d0: 52 4e 49 4e 47 3a 20 56 65 72 73 69 6f 6e 20 6d RNING: Version m
34e0: 69 73 6d 61 74 63 68 21 5c 6e 22 0a 09 09 09 20 ismatch!\n"....
34f0: 22 20 20 20 65 78 70 65 63 74 65 64 3a 20 22 20 " expected: "
3500: 28 63 6f 6d 6d 6f 6e 3a 76 65 72 73 69 6f 6e 2d (common:version-
3510: 73 69 67 6e 61 74 75 72 65 29 20 22 5c 6e 22 0a signature) "\n".
3520: 09 09 09 20 22 20 20 20 67 6f 74 3a 20 20 20 20 ... " got:
3530: 20 20 22 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d " (common:get-
3540: 6c 61 73 74 2d 72 75 6e 2d 76 65 72 73 69 6f 6e last-run-version
3550: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 )). (
3560: 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 20 cond.
3570: 20 20 28 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d ((get-environm
3580: 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 22 4d 54 ent-variable "MT
3590: 5f 53 4b 49 50 5f 44 42 5f 4d 49 47 52 41 54 45 _SKIP_DB_MIGRATE
35a0: 22 29 20 23 74 29 0a 20 20 20 20 20 20 20 20 20 ") #t).
35b0: 20 20 20 20 28 28 61 6e 64 20 28 63 6f 6d 6d 6f ((and (commo
35c0: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 6d n:file-exists? m
35d0: 74 63 6f 6e 66 29 20 28 63 6f 6d 6d 6f 6e 3a 66 tconf) (common:f
35e0: 69 6c 65 2d 65 78 69 73 74 73 3f 20 64 62 66 69 ile-exists? dbfi
35f0: 6c 65 29 20 28 6e 6f 74 20 72 65 61 64 2d 6f 6e le) (not read-on
3600: 6c 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ly).
3610: 20 20 20 20 20 20 20 28 65 71 3f 20 28 63 75 72 (eq? (cur
3620: 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 28 66 69 rent-user-id)(fi
3630: 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 6f 6e 66 29 le-owner mtconf)
3640: 29 29 20 3b 3b 20 73 61 66 65 20 74 6f 20 72 75 )) ;; safe to ru
3650: 6e 20 2d 63 6c 65 61 6e 75 70 2d 64 62 0a 20 20 n -cleanup-db.
3660: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
3670: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
3680: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
3690: 20 20 49 20 73 65 65 20 79 6f 75 20 61 72 65 20 I see you are
36a0: 74 68 65 20 6f 77 6e 65 72 20 6f 66 20 6d 65 67 the owner of meg
36b0: 61 74 65 73 74 2e 63 6f 6e 66 69 67 2c 20 61 74 atest.config, at
36c0: 74 65 6d 70 74 69 6e 67 20 74 6f 20 63 6c 65 61 tempting to clea
36d0: 6e 75 70 20 61 6e 64 20 72 65 73 65 74 20 74 6f nup and reset to
36e0: 20 6e 65 77 20 76 65 72 73 69 6f 6e 22 29 0a 20 new version").
36f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 68 61 (ha
3700: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
3710: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 65 e
3720: 78 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 xn.
3730: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 (begin.
3740: 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 67 (debug
3750: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
3760: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 46 61 69 t-log-port* "Fai
3770: 6c 65 64 20 74 6f 20 73 77 69 74 63 68 20 76 65 led to switch ve
3780: 72 73 69 6f 6e 73 2e 22 29 0a 20 20 20 20 20 20 rsions.").
3790: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
37a0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
37b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 6d lt-log-port* " m
37c0: 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f 6e 64 essage: " ((cond
37d0: 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 ition-property-a
37e0: 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 ccessor 'exn 'me
37f0: 73 73 61 67 65 29 20 65 78 6e 29 29 0a 20 20 20 ssage) exn)).
3800: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
3810: 72 69 6e 74 2d 63 61 6c 6c 2d 63 68 61 69 6e 20 rint-call-chain
3820: 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 2d 70 (current-error-p
3830: 6f 72 74 29 29 0a 20 20 20 20 20 20 20 20 20 20 ort)).
3840: 20 20 20 20 20 20 20 28 65 78 69 74 20 31 29 29 (exit 1))
3850: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
3860: 28 63 6f 6d 6d 6f 6e 3a 63 6c 65 61 6e 75 70 2d (common:cleanup-
3870: 64 62 20 64 62 73 74 72 75 63 74 29 29 29 0a 20 db dbstruct))).
3880: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f ((no
3890: 74 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 t (common:file-e
38a0: 78 69 73 74 73 3f 20 6d 74 63 6f 6e 66 29 29 0a xists? mtconf)).
38b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
38c0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
38d0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
38e0: 22 20 20 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e " megatest.con
38f0: 66 69 67 20 64 6f 65 73 20 6e 6f 74 20 65 78 69 fig does not exi
3900: 73 74 20 69 6e 20 74 68 69 73 20 61 72 65 61 2e st in this area.
3910: 20 20 43 61 6e 6e 6f 74 20 70 72 6f 63 65 65 64 Cannot proceed
3920: 20 77 69 74 68 20 6d 65 67 61 74 65 73 74 20 76 with megatest v
3930: 65 72 73 69 6f 6e 20 6d 69 67 72 61 74 69 6f 6e ersion migration
3940: 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 .").
3950: 20 20 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 (exit 1)).
3960: 20 20 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 ((not (
3970: 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 common:file-exis
3980: 74 73 3f 20 64 62 66 69 6c 65 29 29 0a 20 20 20 ts? dbfile)).
3990: 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 75 (debu
39a0: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
39b0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 20 lt-log-port* "
39c0: 20 6d 65 67 61 74 65 73 74 2e 64 62 20 64 6f 65 megatest.db doe
39d0: 73 20 6e 6f 74 20 65 78 69 73 74 20 69 6e 20 74 s not exist in t
39e0: 68 69 73 20 61 72 65 61 2e 20 20 43 61 6e 6e 6f his area. Canno
39f0: 74 20 70 72 6f 63 65 65 64 20 77 69 74 68 20 6d t proceed with m
3a00: 65 67 61 74 65 73 74 20 76 65 72 73 69 6f 6e 20 egatest version
3a10: 6d 69 67 72 61 74 69 6f 6e 2e 22 29 0a 20 20 20 migration.").
3a20: 20 20 20 20 20 20 20 20 20 20 20 28 65 78 69 74 (exit
3a30: 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 1)).
3a40: 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 28 63 75 ((not (eq? (cu
3a50: 72 72 65 6e 74 2d 75 73 65 72 2d 69 64 29 28 66 rrent-user-id)(f
3a60: 69 6c 65 2d 6f 77 6e 65 72 20 6d 74 63 6f 6e 66 ile-owner mtconf
3a70: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
3a80: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3a90: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3aa0: 72 74 2a 20 22 20 20 20 59 6f 75 20 64 6f 20 6e rt* " You do n
3ab0: 6f 74 20 6f 77 6e 20 6d 65 67 61 74 65 73 74 2e ot own megatest.
3ac0: 64 62 20 69 6e 20 74 68 69 73 20 61 72 65 61 2e db in this area.
3ad0: 20 20 43 61 6e 6e 6f 74 20 70 72 6f 63 65 65 64 Cannot proceed
3ae0: 20 77 69 74 68 20 6d 65 67 61 74 65 73 74 20 76 with megatest v
3af0: 65 72 73 69 6f 6e 20 6d 69 67 72 61 74 69 6f 6e ersion migration
3b00: 2e 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 .").
3b10: 20 20 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 (exit 1)).
3b20: 20 20 20 20 20 20 20 20 20 28 72 65 61 64 2d 6f (read-o
3b30: 6e 6c 79 0a 20 20 20 20 20 20 20 20 20 20 20 20 nly.
3b40: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
3b50: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
3b60: 72 74 2a 20 22 20 20 20 59 6f 75 20 68 61 76 65 rt* " You have
3b70: 20 72 65 61 64 2d 6f 6e 6c 79 20 61 63 63 65 73 read-only acces
3b80: 73 20 74 6f 20 74 68 69 73 20 61 72 65 61 2e 20 s to this area.
3b90: 20 43 61 6e 6e 6f 74 20 70 72 6f 63 65 65 64 20 Cannot proceed
3ba0: 77 69 74 68 20 6d 65 67 61 74 65 73 74 20 76 65 with megatest ve
3bb0: 72 73 69 6f 6e 20 6d 69 67 72 61 74 69 6f 6e 2e rsion migration.
3bc0: 22 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ").
3bd0: 20 28 65 78 69 74 20 31 29 29 0a 20 20 20 20 20 (exit 1)).
3be0: 20 20 20 20 20 20 20 20 28 65 6c 73 65 0a 20 20 (else.
3bf0: 20 20 20 20 20 20 20 20 20 20 20 20 28 64 65 62 (deb
3c00: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
3c10: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 ult-log-port* "
3c20: 74 6f 20 73 77 69 74 63 68 20 76 65 72 73 69 6f to switch versio
3c30: 6e 73 20 79 6f 75 20 63 61 6e 20 72 75 6e 3a 20 ns you can run:
3c40: 5c 22 6d 65 67 61 74 65 73 74 20 2d 63 6c 65 61 \"megatest -clea
3c50: 6e 75 70 2d 64 62 5c 22 22 29 0a 20 20 20 20 20 nup-db\"").
3c60: 20 20 20 20 20 20 20 20 20 28 65 78 69 74 20 31 (exit 1
3c70: 29 29 29 29 29 29 29 0a 3b 3b 20 20 20 20 20 20 ))))))).;;
3c80: 28 62 65 67 69 6e 0a 3b 3b 09 28 64 65 62 75 67 (begin.;;.(debug
3c90: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
3ca0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 52 t-log-port* "ERR
3cb0: 4f 52 3a 20 63 61 6e 6e 6f 74 20 6d 69 67 72 61 OR: cannot migra
3cc0: 74 65 20 76 65 72 73 69 6f 6e 20 75 6e 6c 65 73 te version unles
3cd0: 73 20 6f 6e 20 68 6f 6d 65 68 6f 73 74 2e 20 45 s on homehost. E
3ce0: 78 69 74 69 6e 67 2e 22 29 0a 3b 3b 09 28 65 78 xiting.").;;.(ex
3cf0: 69 74 20 31 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d it 1))))..;;====
3d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
3d40: 3d 3d 0a 3b 3b 20 53 20 50 20 41 20 52 20 53 20 ==.;; S P A R S
3d50: 45 20 20 20 41 20 52 20 52 20 41 20 59 20 53 0a E A R R A Y S.
3d60: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
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 0a 0a 28 64 65 66 69 6e ========..(defin
3db0: 65 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d 61 e (make-sparse-a
3dc0: 72 72 61 79 29 0a 20 20 28 6c 65 74 20 28 28 61 rray). (let ((a
3dd0: 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 2d 76 65 (make-sparse-ve
3de0: 63 74 6f 72 29 29 29 0a 20 20 20 20 28 73 70 61 ctor))). (spa
3df0: 72 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 rse-vector-set!
3e00: 61 20 30 20 28 6d 61 6b 65 2d 73 70 61 72 73 65 a 0 (make-sparse
3e10: 2d 76 65 63 74 6f 72 29 29 0a 20 20 20 20 61 29 -vector)). a)
3e20: 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 70 61 72 )..(define (spar
3e30: 73 65 2d 61 72 72 61 79 3f 20 61 29 0a 20 20 28 se-array? a). (
3e40: 61 6e 64 20 28 73 70 61 72 73 65 2d 76 65 63 74 and (sparse-vect
3e50: 6f 72 3f 20 61 29 0a 20 20 20 20 20 20 20 28 73 or? a). (s
3e60: 70 61 72 73 65 2d 76 65 63 74 6f 72 3f 20 28 73 parse-vector? (s
3e70: 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 66 parse-vector-ref
3e80: 20 61 20 30 29 29 29 29 0a 0a 28 64 65 66 69 6e a 0))))..(defin
3e90: 65 20 28 73 70 61 72 73 65 2d 61 72 72 61 79 2d e (sparse-array-
3ea0: 72 65 66 20 61 20 78 20 79 29 0a 20 20 28 6c 65 ref a x y). (le
3eb0: 74 20 28 28 72 6f 77 20 28 73 70 61 72 73 65 2d t ((row (sparse-
3ec0: 76 65 63 74 6f 72 2d 72 65 66 20 61 20 78 29 29 vector-ref a x))
3ed0: 29 0a 20 20 20 20 28 69 66 20 72 6f 77 0a 09 28 ). (if row..(
3ee0: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 2d 72 65 sparse-vector-re
3ef0: 66 20 72 6f 77 20 79 29 0a 09 23 66 29 29 29 0a f row y)..#f))).
3f00: 0a 28 64 65 66 69 6e 65 20 28 73 70 61 72 73 65 .(define (sparse
3f10: 2d 61 72 72 61 79 2d 73 65 74 21 20 61 20 78 20 -array-set! a x
3f20: 79 20 76 61 6c 29 0a 20 20 28 6c 65 74 20 28 28 y val). (let ((
3f30: 72 6f 77 20 28 73 70 61 72 73 65 2d 76 65 63 74 row (sparse-vect
3f40: 6f 72 2d 72 65 66 20 61 20 78 29 29 29 0a 20 20 or-ref a x))).
3f50: 20 20 28 69 66 20 72 6f 77 0a 09 28 73 70 61 72 (if row..(spar
3f60: 73 65 2d 76 65 63 74 6f 72 2d 73 65 74 21 20 72 se-vector-set! r
3f70: 6f 77 20 79 20 76 61 6c 29 0a 09 28 6c 65 74 20 ow y val)..(let
3f80: 28 28 6e 65 77 2d 72 6f 77 20 28 6d 61 6b 65 2d ((new-row (make-
3f90: 73 70 61 72 73 65 2d 76 65 63 74 6f 72 29 29 29 sparse-vector)))
3fa0: 0a 09 20 20 28 73 70 61 72 73 65 2d 76 65 63 74 .. (sparse-vect
3fb0: 6f 72 2d 73 65 74 21 20 61 20 78 20 6e 65 77 2d or-set! a x new-
3fc0: 72 6f 77 29 0a 09 20 20 28 73 70 61 72 73 65 2d row).. (sparse-
3fd0: 76 65 63 74 6f 72 2d 73 65 74 21 20 6e 65 77 2d vector-set! new-
3fe0: 72 6f 77 20 79 20 76 61 6c 29 29 29 29 29 0a 0a row y val)))))..
3ff0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
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 0a 3b 3b 20 4c 20 4f 20 ========.;; L O
4040: 43 20 4b 20 45 20 52 20 53 20 20 20 41 20 4e 20 C K E R S A N
4050: 44 20 20 20 42 20 4c 20 4f 20 43 20 4b 20 45 20 D B L O C K E
4060: 52 20 53 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 0a 3b =============..;
40b0: 3b 20 62 6c 6f 63 6b 20 66 75 72 74 68 65 72 20 ; block further
40c0: 61 63 63 65 73 73 65 73 20 74 6f 20 64 61 74 61 accesses to data
40d0: 62 61 73 65 73 2e 20 43 61 6c 6c 20 74 68 69 73 bases. Call this
40e0: 20 62 65 66 6f 72 65 20 73 68 75 74 74 69 6e 67 before shutting
40f0: 20 64 62 20 64 6f 77 6e 0a 28 64 65 66 69 6e 65 db down.(define
4100: 20 28 63 6f 6d 6d 6f 6e 3a 64 62 2d 62 6c 6f 63 (common:db-bloc
4110: 6b 2d 66 75 72 74 68 65 72 2d 71 75 65 72 69 65 k-further-querie
4120: 73 29 0a 20 20 28 6d 75 74 65 78 2d 6c 6f 63 6b s). (mutex-lock
4130: 21 20 2a 64 62 2d 61 63 63 65 73 73 2d 6d 75 74 ! *db-access-mut
4140: 65 78 2a 29 0a 20 20 28 73 65 74 21 20 2a 64 62 ex*). (set! *db
4150: 2d 61 63 63 65 73 73 2d 61 6c 6c 6f 77 65 64 2a -access-allowed*
4160: 20 23 66 29 0a 20 20 28 6d 75 74 65 78 2d 75 6e #f). (mutex-un
4170: 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 73 73 lock! *db-access
4180: 2d 6d 75 74 65 78 2a 29 29 0a 0a 28 64 65 66 69 -mutex*))..(defi
4190: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 64 62 2d 61 63 ne (common:db-ac
41a0: 63 65 73 73 2d 61 6c 6c 6f 77 65 64 3f 29 0a 20 cess-allowed?).
41b0: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 62 65 67 (let ((val (beg
41c0: 69 6e 0a 09 20 20 20 20 20 20 20 28 6d 75 74 65 in.. (mute
41d0: 78 2d 6c 6f 63 6b 21 20 2a 64 62 2d 61 63 63 65 x-lock! *db-acce
41e0: 73 73 2d 6d 75 74 65 78 2a 29 0a 09 20 20 20 20 ss-mutex*)..
41f0: 20 20 20 2a 64 62 2d 61 63 63 65 73 73 2d 61 6c *db-access-al
4200: 6c 6f 77 65 64 2a 0a 09 20 20 20 20 20 20 20 28 lowed*.. (
4210: 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 64 mutex-unlock! *d
4220: 62 2d 61 63 63 65 73 73 2d 6d 75 74 65 78 2a 29 b-access-mutex*)
4230: 29 29 29 0a 20 20 20 20 76 61 6c 29 29 0a 0a 3b ))). val))..;
4240: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
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 0a 3b 3b 20 55 20 53 20 45 =======.;; U S E
4290: 20 46 20 55 20 4c 20 20 20 53 20 54 20 55 20 46 F U L S T U F
42a0: 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 0a 3b 3b 20 ===========..;;
42f0: 63 6f 6e 76 65 72 74 20 74 68 69 6e 67 73 20 74 convert things t
4300: 6f 20 61 6e 20 61 6c 69 73 74 20 6f 72 20 61 73 o an alist or as
4310: 73 6f 63 20 6c 69 73 74 2c 20 23 66 20 67 65 74 soc list, #f get
4320: 73 20 63 6f 6e 76 65 72 74 65 64 20 74 6f 20 22 s converted to "
4330: 22 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ".;;.(define (co
4340: 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 64 61 mmon:to-alist da
4350: 74 29 0a 20 20 28 63 6f 6e 64 0a 20 20 20 28 28 t). (cond. ((
4360: 6c 69 73 74 3f 20 64 61 74 29 20 20 20 28 6d 61 list? dat) (ma
4370: 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 p common:to-alis
4380: 74 20 64 61 74 29 29 0a 20 20 20 28 28 76 65 63 t dat)). ((vec
4390: 74 6f 72 3f 20 64 61 74 29 0a 20 20 20 20 28 6d tor? dat). (m
43a0: 61 70 20 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 ap common:to-ali
43b0: 73 74 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 st (vector->list
43c0: 20 64 61 74 29 29 29 0a 20 20 20 28 28 70 61 69 dat))). ((pai
43d0: 72 3f 20 64 61 74 29 0a 20 20 20 20 28 63 6f 6e r? dat). (con
43e0: 73 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 s (common:to-ali
43f0: 73 74 20 28 63 61 72 20 64 61 74 29 29 0a 09 20 st (car dat))..
4400: 20 28 63 6f 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 (common:to-alis
4410: 74 20 28 63 64 72 20 64 61 74 29 29 29 29 0a 20 t (cdr dat)))).
4420: 20 20 28 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 ((hash-table?
4430: 64 61 74 29 0a 20 20 20 20 28 6d 61 70 20 63 6f dat). (map co
4440: 6d 6d 6f 6e 3a 74 6f 2d 61 6c 69 73 74 20 28 68 mmon:to-alist (h
4450: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
4460: 20 64 61 74 29 29 29 0a 20 20 20 28 65 6c 73 65 dat))). (else
4470: 0a 20 20 20 20 28 69 66 20 64 61 74 0a 09 64 61 . (if dat..da
4480: 74 0a 09 22 22 29 29 29 29 0a 0a 28 64 65 66 69 t..""))))..(defi
4490: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e ne (common:low-n
44a0: 6f 69 73 65 2d 70 72 69 6e 74 20 77 61 69 74 76 oise-print waitv
44b0: 61 6c 20 2e 20 6b 65 79 73 29 0a 20 20 28 6c 65 al . keys). (le
44c0: 74 2a 20 28 28 6b 65 79 20 20 20 20 20 20 28 73 t* ((key (s
44d0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
44e0: 65 20 28 6d 61 70 20 63 6f 6e 63 20 6b 65 79 73 e (map conc keys
44f0: 29 20 22 2d 22 20 29 29 0a 09 20 28 6c 61 73 74 ) "-" )).. (last
4500: 74 69 6d 65 20 28 68 61 73 68 2d 74 61 62 6c 65 time (hash-table
4510: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 63 6f -ref/default *co
4520: 6d 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 6b 65 mmon:denoise* ke
4530: 79 20 30 29 29 0a 09 20 28 63 75 72 72 74 69 6d y 0)).. (currtim
4540: 65 20 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e e (current-secon
4550: 64 73 29 29 29 0a 20 20 20 20 28 69 66 20 28 3e ds))). (if (>
4560: 20 28 2d 20 63 75 72 72 74 69 6d 65 20 6c 61 73 (- currtime las
4570: 74 74 69 6d 65 29 20 77 61 69 74 76 61 6c 29 0a ttime) waitval).
4580: 09 28 62 65 67 69 6e 0a 09 20 20 28 68 61 73 68 .(begin.. (hash
4590: 2d 74 61 62 6c 65 2d 73 65 74 21 20 2a 63 6f 6d -table-set! *com
45a0: 6d 6f 6e 3a 64 65 6e 6f 69 73 65 2a 20 6b 65 79 mon:denoise* key
45b0: 20 63 75 72 72 74 69 6d 65 29 0a 09 20 20 23 74 currtime).. #t
45c0: 29 0a 09 23 66 29 29 29 0a 0a 28 64 65 66 69 6e )..#f)))..(defin
45d0: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6d 65 e (common:get-me
45e0: 67 61 74 65 73 74 2d 65 78 65 29 0a 20 20 28 6f gatest-exe). (o
45f0: 72 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 4d 45 r (getenv "MT_ME
4600: 47 41 54 45 53 54 22 29 20 22 6d 65 67 61 74 65 GATEST") "megate
4610: 73 74 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 st"))..(define (
4620: 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 65 6e 63 6f common:read-enco
4630: 64 65 64 2d 73 74 72 69 6e 67 20 69 6e 73 74 72 ded-string instr
4640: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
4650: 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 ptions. exn.
4660: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
4670: 6f 6e 73 0a 20 20 20 20 65 78 6e 0a 20 20 20 20 ons. exn.
4680: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 28 64 65 (begin. (de
4690: 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 bug:print-error
46a0: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
46b0: 6f 72 74 2a 20 22 72 65 63 65 69 76 65 64 20 62 ort* "received b
46c0: 61 64 20 65 6e 63 6f 64 65 64 20 73 74 72 69 6e ad encoded strin
46d0: 67 20 5c 22 22 20 69 6e 73 74 72 20 22 5c 22 2c g \"" instr "\",
46e0: 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 6f message: " ((co
46f0: 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 79 ndition-property
4700: 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 27 -accessor 'exn '
4710: 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 0a 20 message) exn)).
4720: 20 20 20 20 20 28 70 72 69 6e 74 2d 63 61 6c 6c (print-call
4730: 2d 63 68 61 69 6e 20 28 63 75 72 72 65 6e 74 2d -chain (current-
4740: 65 72 72 6f 72 2d 70 6f 72 74 29 29 0a 20 20 20 error-port)).
4750: 20 20 20 23 66 29 0a 20 20 20 20 28 72 65 61 64 #f). (read
4760: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 73 74 72 (open-input-str
4770: 69 6e 67 20 28 62 61 73 65 36 34 3a 62 61 73 65 ing (base64:base
4780: 36 34 2d 64 65 63 6f 64 65 20 69 6e 73 74 72 29 64-decode instr)
4790: 29 29 29 0a 20 20 20 28 72 65 61 64 20 28 6f 70 ))). (read (op
47a0: 65 6e 2d 69 6e 70 75 74 2d 73 74 72 69 6e 67 20 en-input-string
47b0: 28 7a 33 3a 64 65 63 6f 64 65 2d 62 75 66 66 65 (z3:decode-buffe
47c0: 72 20 28 62 61 73 65 36 34 3a 62 61 73 65 36 34 r (base64:base64
47d0: 2d 64 65 63 6f 64 65 20 69 6e 73 74 72 29 29 29 -decode instr)))
47e0: 29 29 29 0a 0a 3b 3b 20 64 6f 74 2d 6c 6f 63 6b )))..;; dot-lock
47f0: 69 6e 67 20 65 67 67 20 73 65 65 6d 73 20 6e 6f ing egg seems no
4800: 74 20 74 6f 20 77 6f 72 6b 2c 20 75 73 69 6e 67 t to work, using
4810: 20 74 68 69 73 20 66 6f 72 20 6e 6f 77 0a 3b 3b this for now.;;
4820: 20 69 66 20 6c 6f 63 6b 20 69 73 20 6f 6c 64 65 if lock is olde
4830: 72 20 74 68 61 6e 20 65 78 70 69 72 65 2d 74 69 r than expire-ti
4840: 6d 65 20 74 68 65 6e 20 72 65 6d 6f 76 65 20 69 me then remove i
4850: 74 20 61 6e 64 20 74 72 79 20 61 67 61 69 6e 0a t and try again.
4860: 3b 3b 20 74 6f 20 67 65 74 20 74 68 65 20 6c 6f ;; to get the lo
4870: 63 6b 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 ck.;;.(define (c
4880: 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c ommon:simple-fil
4890: 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 20 23 21 6b e-lock fname #!k
48a0: 65 79 20 28 65 78 70 69 72 65 2d 74 69 6d 65 20 ey (expire-time
48b0: 33 30 30 29 29 0a 20 20 28 68 61 6e 64 6c 65 2d 300)). (handle-
48c0: 65 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 exceptions.
48d0: 20 65 78 6e 0a 20 20 20 20 20 20 23 66 20 3b 3b exn. #f ;;
48e0: 20 64 6f 6e 27 74 20 72 65 61 6c 6c 79 20 63 61 don't really ca
48f0: 72 65 20 77 68 61 74 20 77 65 6e 74 20 77 72 6f re what went wro
4900: 6e 67 20 72 69 67 68 74 20 6e 6f 77 2e 20 4e 4f ng right now. NO
4910: 54 45 3a 20 49 20 68 61 76 65 20 6e 6f 74 20 73 TE: I have not s
4920: 65 65 6e 20 74 68 69 73 20 6f 6e 65 20 61 63 74 een this one act
4930: 75 61 6c 6c 79 20 66 61 69 6c 2e 0a 20 20 20 20 ually fail..
4940: 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 (if (common:file
4950: 2d 65 78 69 73 74 73 3f 20 66 6e 61 6d 65 29 0a -exists? fname).
4960: 09 28 69 66 20 28 3e 20 28 2d 20 28 63 75 72 72 .(if (> (- (curr
4970: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 28 66 69 6c ent-seconds)(fil
4980: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
4990: 69 6d 65 20 66 6e 61 6d 65 29 29 20 65 78 70 69 ime fname)) expi
49a0: 72 65 2d 74 69 6d 65 29 0a 09 20 20 20 20 28 62 re-time).. (b
49b0: 65 67 69 6e 0a 09 20 20 20 20 20 20 28 64 65 6c egin.. (del
49c0: 65 74 65 2d 66 69 6c 65 2a 20 66 6e 61 6d 65 29 ete-file* fname)
49d0: 0a 09 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a .. (common:
49e0: 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b simple-file-lock
49f0: 20 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 fname expire-ti
4a00: 6d 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 me: expire-time)
4a10: 29 0a 09 20 20 20 20 23 66 29 0a 09 28 6c 65 74 ).. #f)..(let
4a20: 20 28 28 6b 65 79 2d 73 74 72 69 6e 67 20 28 63 ((key-string (c
4a30: 6f 6e 63 20 28 67 65 74 2d 68 6f 73 74 2d 6e 61 onc (get-host-na
4a40: 6d 65 29 20 22 2d 22 20 28 63 75 72 72 65 6e 74 me) "-" (current
4a50: 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 29 29 0a -process-id)))).
4a60: 09 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d . (with-output-
4a70: 74 6f 2d 66 69 6c 65 20 66 6e 61 6d 65 0a 09 20 to-file fname..
4a80: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 20 (lambda ()..
4a90: 20 20 20 20 20 28 70 72 69 6e 74 20 6b 65 79 2d (print key-
4aa0: 73 74 72 69 6e 67 29 29 29 0a 09 20 20 28 74 68 string))).. (th
4ab0: 72 65 61 64 2d 73 6c 65 65 70 21 20 30 2e 32 35 read-sleep! 0.25
4ac0: 29 0a 09 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e ).. (if (common
4ad0: 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 66 6e :file-exists? fn
4ae0: 61 6d 65 29 0a 09 20 20 20 20 20 20 28 77 69 74 ame).. (wit
4af0: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c h-input-from-fil
4b00: 65 20 66 6e 61 6d 65 0a 09 09 28 6c 61 6d 62 64 e fname...(lambd
4b10: 61 20 28 29 0a 09 09 20 20 28 65 71 75 61 6c 3f a ()... (equal?
4b20: 20 6b 65 79 2d 73 74 72 69 6e 67 20 28 72 65 61 key-string (rea
4b30: 64 2d 6c 69 6e 65 29 29 29 29 0a 09 20 20 20 20 d-line))))..
4b40: 20 20 23 66 29 29 29 29 29 0a 0a 28 64 65 66 69 #f)))))..(defi
4b50: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c ne (common:simpl
4b60: 65 2d 66 69 6c 65 2d 6c 6f 63 6b 2d 61 6e 64 2d e-file-lock-and-
4b70: 77 61 69 74 20 66 6e 61 6d 65 20 23 21 6b 65 79 wait fname #!key
4b80: 20 28 65 78 70 69 72 65 2d 74 69 6d 65 20 33 30 (expire-time 30
4b90: 30 29 29 0a 20 20 28 6c 65 74 20 28 28 65 6e 64 0)). (let ((end
4ba0: 2d 74 69 6d 65 20 28 2b 20 65 78 70 69 72 65 2d -time (+ expire-
4bb0: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 time (current-se
4bc0: 63 6f 6e 64 73 29 29 29 29 0a 20 20 20 20 28 6c conds)))). (l
4bd0: 65 74 20 6c 6f 6f 70 20 28 28 67 6f 74 2d 6c 6f et loop ((got-lo
4be0: 63 6b 20 28 63 6f 6d 6d 6f 6e 3a 73 69 6d 70 6c ck (common:simpl
4bf0: 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 66 6e 61 6d e-file-lock fnam
4c00: 65 20 65 78 70 69 72 65 2d 74 69 6d 65 3a 20 65 e expire-time: e
4c10: 78 70 69 72 65 2d 74 69 6d 65 29 29 29 0a 20 20 xpire-time))).
4c20: 20 20 20 20 28 69 66 20 67 6f 74 2d 6c 6f 63 6b (if got-lock
4c30: 0a 09 20 20 23 74 0a 09 20 20 28 69 66 20 28 3e .. #t.. (if (>
4c40: 20 65 6e 64 2d 74 69 6d 65 20 28 63 75 72 72 65 end-time (curre
4c50: 6e 74 2d 73 65 63 6f 6e 64 73 29 29 0a 09 20 20 nt-seconds))..
4c60: 20 20 20 20 28 62 65 67 69 6e 0a 09 09 28 74 68 (begin...(th
4c70: 72 65 61 64 2d 73 6c 65 65 70 21 20 33 29 0a 09 read-sleep! 3)..
4c80: 09 28 6c 6f 6f 70 20 28 63 6f 6d 6d 6f 6e 3a 73 .(loop (common:s
4c90: 69 6d 70 6c 65 2d 66 69 6c 65 2d 6c 6f 63 6b 20 imple-file-lock
4ca0: 66 6e 61 6d 65 20 65 78 70 69 72 65 2d 74 69 6d fname expire-tim
4cb0: 65 3a 20 65 78 70 69 72 65 2d 74 69 6d 65 29 29 e: expire-time))
4cc0: 29 0a 09 20 20 20 20 20 20 23 66 29 29 29 29 29 ).. #f)))))
4cd0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
4ce0: 6e 3a 73 69 6d 70 6c 65 2d 66 69 6c 65 2d 72 65 n:simple-file-re
4cf0: 6c 65 61 73 65 2d 6c 6f 63 6b 20 66 6e 61 6d 65 lease-lock fname
4d00: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
4d10: 70 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e ptions. exn
4d20: 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 49 20 64 . #f ;; I d
4d30: 6f 6e 27 74 20 72 65 61 6c 6c 79 20 63 61 72 65 on't really care
4d40: 20 77 68 79 20 74 68 69 73 20 66 61 69 6c 65 64 why this failed
4d50: 20 28 61 74 20 6c 65 61 73 74 20 66 6f 72 20 6e (at least for n
4d60: 6f 77 29 0a 20 20 20 20 28 64 65 6c 65 74 65 2d ow). (delete-
4d70: 66 69 6c 65 2a 20 66 6e 61 6d 65 29 29 29 0a 0a file* fname)))..
4d80: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
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 0a 3b 3b 20 53 20 54 20 ========.;; S T
4dd0: 41 20 54 20 45 20 53 20 20 20 41 20 4e 20 44 20 A T E S A N D
4de0: 20 20 53 20 54 20 41 20 54 20 55 20 53 20 45 20 S T A T U S E
4df0: 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 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 0a 0a 3b 3b 20 42 ==========..;; B
4e40: 42 6e 6f 74 65 3a 20 2a 63 6f 6d 6d 6f 6e 3a 73 Bnote: *common:s
4e50: 74 64 2d 73 74 61 74 65 73 2a 20 2d 20 64 61 73 td-states* - das
4e60: 68 62 6f 61 72 64 20 66 69 6c 74 65 72 20 63 6f hboard filter co
4e70: 6e 74 72 6f 6c 20 61 6e 64 20 74 65 73 74 20 63 ntrol and test c
4e80: 6f 6e 74 72 6f 6c 20 73 74 61 74 65 20 62 75 74 ontrol state but
4e90: 74 6f 6e 73 20 64 65 66 69 6e 65 64 20 68 65 72 tons defined her
4ea0: 65 3b 20 75 73 65 64 20 69 6e 20 73 65 74 2d 66 e; used in set-f
4eb0: 69 65 6c 64 73 2d 70 61 6e 65 6c 20 61 6e 64 20 ields-panel and
4ec0: 64 62 6f 61 72 64 3a 6d 61 6b 65 2d 63 6f 6e 74 dboard:make-cont
4ed0: 72 6f 6c 73 0a 28 64 65 66 69 6e 65 20 2a 63 6f rols.(define *co
4ee0: 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 65 73 2a mmon:std-states*
4ef0: 20 20 20 3b 3b 20 66 6f 72 20 74 6f 67 67 6c 65 ;; for toggle
4f00: 20 62 75 74 74 6f 6e 73 20 69 6e 20 64 61 73 68 buttons in dash
4f10: 62 6f 61 72 64 0a 20 20 27 28 28 30 20 22 41 52 board. '((0 "AR
4f20: 43 48 49 56 45 44 22 29 0a 20 20 20 20 28 31 20 CHIVED"). (1
4f30: 22 53 54 55 43 4b 22 29 0a 20 20 20 20 28 32 20 "STUCK"). (2
4f40: 22 4b 49 4c 4c 52 45 51 22 29 0a 20 20 20 20 28 "KILLREQ"). (
4f50: 33 20 22 4b 49 4c 4c 45 44 22 29 0a 20 20 20 20 3 "KILLED").
4f60: 28 34 20 22 4e 4f 54 5f 53 54 41 52 54 45 44 22 (4 "NOT_STARTED"
4f70: 29 0a 20 20 20 20 28 35 20 22 43 4f 4d 50 4c 45 ). (5 "COMPLE
4f80: 54 45 44 22 29 0a 20 20 20 20 28 36 20 22 4c 41 TED"). (6 "LA
4f90: 55 4e 43 48 45 44 22 29 0a 20 20 20 20 28 37 20 UNCHED"). (7
4fa0: 22 52 45 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 "REMOTEHOSTSTART
4fb0: 22 29 0a 20 20 20 20 28 38 20 22 52 55 4e 4e 49 "). (8 "RUNNI
4fc0: 4e 47 22 29 0a 20 20 20 20 29 29 0a 0a 3b 3b 20 NG"). ))..;;
4fd0: 42 42 6e 6f 74 65 3a 20 2a 63 6f 6d 6d 6f 6e 3a BBnote: *common:
4fe0: 73 74 64 2d 73 74 61 74 75 73 65 73 2a 20 64 61 std-statuses* da
4ff0: 73 68 62 6f 61 72 64 20 66 69 6c 74 65 72 20 63 shboard filter c
5000: 6f 6e 74 72 6f 6c 20 61 6e 64 20 74 65 73 74 20 ontrol and test
5010: 63 6f 6e 74 72 6f 6c 20 73 74 61 74 75 73 20 62 control status b
5020: 75 74 74 6f 6e 73 20 64 65 66 69 6e 65 64 20 68 uttons defined h
5030: 65 72 65 3b 20 75 73 65 64 20 69 6e 20 73 65 74 ere; used in set
5040: 2d 66 69 65 6c 64 73 2d 70 61 6e 65 6c 20 61 6e -fields-panel an
5050: 64 20 64 62 6f 61 72 64 3a 6d 61 6b 65 2d 63 6f d dboard:make-co
5060: 6e 74 72 6f 6c 73 0a 28 64 65 66 69 6e 65 20 2a ntrols.(define *
5070: 63 6f 6d 6d 6f 6e 3a 73 74 64 2d 73 74 61 74 75 common:std-statu
5080: 73 65 73 2a 0a 20 20 27 28 3b 3b 20 28 30 20 22 ses*. '(;; (0 "
5090: 44 45 4c 45 54 45 44 22 29 0a 20 20 20 20 28 31 DELETED"). (1
50a0: 20 22 6e 2f 61 22 29 0a 20 20 20 20 28 32 20 22 "n/a"). (2 "
50b0: 50 41 53 53 22 29 0a 20 20 20 20 28 33 20 22 53 PASS"). (3 "S
50c0: 4b 49 50 22 29 0a 20 20 20 20 28 34 20 22 57 41 KIP"). (4 "WA
50d0: 52 4e 22 29 0a 20 20 20 20 28 35 20 22 57 41 49 RN"). (5 "WAI
50e0: 56 45 44 22 29 0a 20 20 20 20 28 36 20 22 43 48 VED"). (6 "CH
50f0: 45 43 4b 22 29 0a 20 20 20 20 28 37 20 22 53 54 ECK"). (7 "ST
5100: 55 43 4b 2f 44 45 41 44 22 29 0a 20 20 20 20 28 UCK/DEAD"). (
5110: 38 20 22 44 45 41 44 22 29 0a 20 20 20 20 28 39 8 "DEAD"). (9
5120: 20 22 46 41 49 4c 22 29 0a 20 20 20 20 28 31 30 "FAIL"). (10
5130: 20 22 41 42 4f 52 54 22 29 29 29 0a 0a 28 64 65 "ABORT")))..(de
5140: 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 65 6e 64 fine *common:end
5150: 65 64 2d 73 74 61 74 65 73 2a 20 20 20 20 20 20 ed-states*
5160: 20 3b 3b 20 73 74 61 74 65 73 20 77 68 69 63 68 ;; states which
5170: 20 69 6e 64 69 63 61 74 65 20 74 68 65 20 74 65 indicate the te
5180: 73 74 20 69 73 20 73 74 6f 70 70 65 64 20 61 6e st is stopped an
5190: 64 20 77 69 6c 6c 20 6e 6f 74 20 70 72 6f 63 65 d will not proce
51a0: 65 64 0a 20 20 27 28 22 43 4f 4d 50 4c 45 54 45 ed. '("COMPLETE
51b0: 44 22 20 22 41 52 43 48 49 56 45 44 22 20 22 4b D" "ARCHIVED" "K
51c0: 49 4c 4c 45 44 22 20 22 4b 49 4c 4c 52 45 51 22 ILLED" "KILLREQ"
51d0: 20 22 53 54 55 43 4b 22 20 22 49 4e 43 4f 4d 50 "STUCK" "INCOMP
51e0: 4c 45 54 45 22 29 29 0a 0a 28 64 65 66 69 6e 65 LETE"))..(define
51f0: 20 2a 63 6f 6d 6d 6f 6e 3a 62 61 64 6c 79 2d 65 *common:badly-e
5200: 6e 64 65 64 2d 73 74 61 74 65 73 2a 20 3b 3b 20 nded-states* ;;
5210: 74 68 65 73 65 20 72 6f 6c 6c 20 75 70 20 61 73 these roll up as
5220: 20 43 48 45 43 4b 2c 20 69 2e 65 2e 20 72 65 73 CHECK, i.e. res
5230: 75 6c 74 73 20 6e 65 65 64 20 74 6f 20 62 65 20 ults need to be
5240: 63 68 65 63 6b 65 64 0a 20 20 27 28 22 4b 49 4c checked. '("KIL
5250: 4c 45 44 22 20 22 4b 49 4c 4c 52 45 51 22 20 22 LED" "KILLREQ" "
5260: 53 54 55 43 4b 22 20 22 49 4e 43 4f 4d 50 4c 45 STUCK" "INCOMPLE
5270: 54 45 22 20 22 44 45 41 44 22 29 29 0a 0a 3b 3b TE" "DEAD"))..;;
5280: 20 42 42 6e 6f 74 65 3a 20 2a 63 6f 6d 6d 6f 6e BBnote: *common
5290: 3a 72 75 6e 6e 69 6e 67 2d 73 74 61 74 65 73 2a :running-states*
52a0: 20 75 73 65 64 20 66 72 6f 6d 20 64 62 3a 73 65 used from db:se
52b0: 74 2d 73 74 61 74 65 2d 73 74 61 74 75 73 2d 61 t-state-status-a
52c0: 6e 64 2d 72 6f 6c 6c 2d 75 70 2d 69 74 65 6d 73 nd-roll-up-items
52d0: 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6d 6d 6f 6e .(define *common
52e0: 3a 72 75 6e 6e 69 6e 67 2d 73 74 61 74 65 73 2a :running-states*
52f0: 20 20 20 20 20 3b 3b 20 74 65 73 74 20 69 73 20 ;; test is
5300: 65 69 74 68 65 72 20 72 75 6e 6e 69 6e 67 20 6f either running o
5310: 72 20 63 61 6e 20 62 65 20 72 75 6e 0a 20 20 27 r can be run. '
5320: 28 22 52 55 4e 4e 49 4e 47 22 20 22 52 45 4d 4f ("RUNNING" "REMO
5330: 54 45 48 4f 53 54 53 54 41 52 54 22 20 22 4c 41 TEHOSTSTART" "LA
5340: 55 4e 43 48 45 44 22 20 22 53 54 41 52 54 45 44 UNCHED" "STARTED
5350: 22 29 29 0a 0a 28 64 65 66 69 6e 65 20 2a 63 6f "))..(define *co
5360: 6d 6d 6f 6e 3a 63 61 6e 74 2d 72 75 6e 2d 73 74 mmon:cant-run-st
5370: 61 74 65 73 2a 20 20 20 20 3b 3b 20 54 68 65 73 ates* ;; Thes
5380: 65 20 61 72 65 20 73 74 6f 70 70 69 6e 67 20 63 e are stopping c
5390: 6f 6e 64 69 74 69 6f 6e 73 20 74 68 61 74 20 70 onditions that p
53a0: 72 65 76 65 6e 74 20 61 20 74 65 73 74 20 66 72 revent a test fr
53b0: 6f 6d 20 62 65 69 6e 67 20 72 75 6e 0a 20 20 27 om being run. '
53c0: 28 22 43 4f 4d 50 4c 45 54 45 44 22 20 22 4b 49 ("COMPLETED" "KI
53d0: 4c 4c 45 44 22 20 22 55 4e 4b 4e 4f 57 4e 22 20 LLED" "UNKNOWN"
53e0: 22 49 4e 43 4f 4d 50 4c 45 54 45 22 20 22 41 52 "INCOMPLETE" "AR
53f0: 43 48 49 56 45 44 22 29 29 0a 0a 28 64 65 66 69 CHIVED"))..(defi
5400: 6e 65 20 2a 63 6f 6d 6d 6f 6e 3a 6e 6f 74 2d 73 ne *common:not-s
5410: 74 61 72 74 65 64 2d 6f 6b 2d 73 74 61 74 75 73 tarted-ok-status
5420: 65 73 2a 20 3b 3b 20 69 66 20 6e 6f 74 20 6f 6e es* ;; if not on
5430: 65 20 6f 66 20 74 68 65 73 65 20 73 74 61 74 75 e of these statu
5440: 73 65 73 20 77 68 65 6e 20 69 6e 20 6e 6f 74 5f ses when in not_
5450: 73 74 61 72 74 65 64 20 73 74 61 74 65 20 74 72 started state tr
5460: 65 61 74 20 61 73 20 64 65 61 64 0a 20 20 27 28 eat as dead. '(
5470: 22 6e 2f 61 22 20 22 6e 61 22 20 22 50 41 53 53 "n/a" "na" "PASS
5480: 22 20 22 46 41 49 4c 22 20 22 57 41 52 4e 22 20 " "FAIL" "WARN"
5490: 22 43 48 45 43 4b 22 20 22 57 41 49 56 45 44 22 "CHECK" "WAIVED"
54a0: 20 22 44 45 41 44 22 20 22 53 4b 49 50 22 29 29 "DEAD" "SKIP"))
54b0: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ..(define (commo
54c0: 6e 3a 73 70 65 63 69 61 6c 2d 73 6f 72 74 20 69 n:special-sort i
54d0: 74 65 6d 73 20 6f 72 64 65 72 20 63 6f 6d 70 29 tems order comp)
54e0: 0a 20 20 28 6c 65 74 20 28 28 69 74 65 6d 73 2d . (let ((items-
54f0: 6f 72 64 65 72 20 28 6d 61 70 20 72 65 76 65 72 order (map rever
5500: 73 65 20 6f 72 64 65 72 29 29 0a 20 20 20 20 20 se order)).
5510: 20 20 20 28 61 63 6f 6d 70 20 20 20 20 20 20 20 (acomp
5520: 28 6f 72 20 63 6f 6d 70 20 3e 29 29 29 0a 20 20 (or comp >))).
5530: 20 20 28 73 6f 72 74 20 69 74 65 6d 73 0a 20 20 (sort items.
5540: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 61 (lambda (a
5550: 20 62 29 0a 20 20 20 20 20 20 20 20 20 20 28 6c b). (l
5560: 65 74 20 28 28 61 2d 6e 75 6d 20 28 63 61 64 72 et ((a-num (cadr
5570: 20 28 6f 72 20 28 61 73 73 6f 63 20 61 20 69 74 (or (assoc a it
5580: 65 6d 73 2d 6f 72 64 65 72 29 20 27 28 30 20 30 ems-order) '(0 0
5590: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
55a0: 20 20 20 20 20 28 62 2d 6e 75 6d 20 28 63 61 64 (b-num (cad
55b0: 72 20 28 6f 72 20 28 61 73 73 6f 63 20 62 20 69 r (or (assoc b i
55c0: 74 65 6d 73 2d 6f 72 64 65 72 29 20 27 28 30 20 tems-order) '(0
55d0: 30 29 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 0))))).
55e0: 20 20 20 28 61 63 6f 6d 70 20 61 2d 6e 75 6d 20 (acomp a-num
55f0: 62 2d 6e 75 6d 29 29 29 29 29 29 0a 0a 3b 3b 20 b-num))))))..;;
5600: 3b 3b 20 67 69 76 65 6e 20 61 20 74 6f 70 6c 65 ;; given a tople
5610: 76 65 6c 20 77 69 74 68 20 63 75 72 72 73 74 61 vel with currsta
5620: 74 65 2c 20 63 75 72 72 73 74 61 74 75 73 20 61 te, currstatus a
5630: 70 70 6c 79 20 73 74 61 74 65 20 61 6e 64 20 73 pply state and s
5640: 74 61 74 75 73 0a 3b 3b 20 3b 3b 20 20 3d 3e 20 tatus.;; ;; =>
5650: 28 6e 65 77 73 74 61 74 65 20 2e 20 6e 65 77 73 (newstate . news
5660: 74 61 74 75 73 29 0a 3b 3b 20 28 64 65 66 69 6e tatus).;; (defin
5670: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 70 70 6c 79 2d e (common:apply-
5680: 73 74 61 74 65 2d 73 74 61 74 75 73 20 63 75 72 state-status cur
5690: 72 73 74 61 74 65 20 63 75 72 72 73 74 61 74 75 rstate currstatu
56a0: 73 20 73 74 61 74 65 20 73 74 61 74 75 73 29 0a s state status).
56b0: 3b 3b 20 20 20 28 6c 65 74 2a 20 28 28 63 73 74 ;; (let* ((cst
56c0: 61 74 65 20 20 28 73 74 72 69 6e 67 2d 3e 73 79 ate (string->sy
56d0: 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 mbol (string-dow
56e0: 6e 63 61 73 65 20 63 75 72 72 73 74 61 74 65 29 ncase currstate)
56f0: 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 28 )).;; (
5700: 63 73 74 61 74 75 73 20 28 73 74 72 69 6e 67 2d cstatus (string-
5710: 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d >symbol (string-
5720: 64 6f 77 6e 63 61 73 65 20 63 75 72 72 73 74 61 downcase currsta
5730: 74 75 73 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 tus))).;;
5740: 20 20 20 28 73 73 74 61 74 65 20 20 28 73 74 72 (sstate (str
5750: 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 ing->symbol (str
5760: 69 6e 67 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 ing-downcase sta
5770: 74 65 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 te))).;;
5780: 20 20 28 73 73 74 61 74 75 73 20 28 73 74 72 69 (sstatus (stri
5790: 6e 67 2d 3e 73 79 6d 62 6f 6c 20 28 73 74 72 69 ng->symbol (stri
57a0: 6e 67 2d 64 6f 77 6e 63 61 73 65 20 73 74 61 74 ng-downcase stat
57b0: 75 73 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 us))).;;
57c0: 20 20 28 6e 73 74 61 74 65 20 20 23 66 29 0a 3b (nstate #f).;
57d0: 3b 20 20 20 20 20 20 20 20 20 20 28 6e 73 74 61 ; (nsta
57e0: 74 75 73 20 23 66 29 29 0a 3b 3b 20 20 20 20 20 tus #f)).;;
57f0: 28 73 65 74 21 20 6e 73 74 61 74 65 0a 3b 3b 20 (set! nstate.;;
5800: 20 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 (case
5810: 63 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 cstate.;;
5820: 20 20 20 20 20 20 28 28 63 6f 6d 70 6c 65 74 65 ((complete
5830: 64 20 6e 6f 74 5f 73 74 61 72 74 65 64 20 6b 69 d not_started ki
5840: 6c 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 lled killreq stu
5850: 63 6b 20 61 72 63 68 69 76 65 64 29 20 0a 3b 3b ck archived) .;;
5860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 (c
5870: 61 73 65 20 73 73 74 61 74 65 20 3b 3b 20 63 6f ase sstate ;; co
5880: 6d 70 6c 65 74 65 64 20 2d 3e 20 73 73 74 61 74 mpleted -> sstat
5890: 65 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 e.;;
58a0: 20 20 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 ((completed
58b0: 6b 69 6c 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 killed killreq s
58c0: 74 75 63 6b 20 61 72 63 68 69 76 65 64 29 20 63 tuck archived) c
58d0: 6f 6d 70 6c 65 74 65 64 29 0a 3b 3b 20 20 20 20 ompleted).;;
58e0: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 72 75 ((ru
58f0: 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 6f 73 74 nning remotehost
5900: 73 74 61 72 74 20 6c 61 75 6e 63 68 65 64 29 20 start launched)
5910: 20 20 20 20 20 20 20 72 75 6e 6e 69 6e 67 29 0a running).
5920: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5930: 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 (else
5940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5950: 20 20 20 20 20 20 20 20 20 20 20 20 20 75 6e 6b unk
5960: 6e 6f 77 6e 2d 65 72 72 6f 72 2d 31 29 29 29 0a nown-error-1))).
5970: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ;; (
5980: 28 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 68 (running remoteh
5990: 6f 73 74 73 74 61 72 74 20 6c 61 75 6e 63 68 65 oststart launche
59a0: 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 d).;;
59b0: 20 20 20 28 63 61 73 65 20 73 73 74 61 74 65 0a (case sstate.
59c0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
59d0: 20 20 28 28 63 6f 6d 70 6c 65 74 65 64 20 6b 69 ((completed ki
59e0: 6c 6c 65 64 20 6b 69 6c 6c 72 65 71 20 73 74 75 lled killreq stu
59f0: 63 6b 20 61 72 63 68 69 76 65 64 29 20 23 66 29 ck archived) #f)
5a00: 20 3b 3b 20 6e 65 65 64 20 74 6f 20 6c 6f 6f 6b ;; need to look
5a10: 20 61 74 20 61 6c 6c 20 69 74 65 6d 73 0a 3b 3b at all items.;;
5a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a30: 28 28 72 75 6e 6e 69 6e 67 20 72 65 6d 6f 74 65 ((running remote
5a40: 68 6f 73 74 73 74 61 72 74 20 6c 61 75 6e 63 68 hoststart launch
5a50: 65 64 29 20 20 20 20 20 20 20 20 72 75 6e 6e 69 ed) runni
5a60: 6e 67 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ng).;;
5a70: 20 20 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 (else
5a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5a90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5aa0: 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 32 unknown-error-2
5ab0: 29 29 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 ))).;;
5ac0: 20 20 20 28 65 6c 73 65 20 75 6e 6b 6e 6f 77 6e (else unknown
5ad0: 2d 65 72 72 6f 72 2d 33 29 29 29 0a 3b 3b 20 20 -error-3))).;;
5ae0: 20 20 20 28 73 65 74 21 20 6e 73 74 61 74 75 73 (set! nstatus
5af0: 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 28 63 .;; (c
5b00: 61 73 65 20 73 73 74 61 74 75 73 0a 3b 3b 20 20 ase sstatus.;;
5b10: 20 20 20 20 20 20 20 20 20 20 20 28 28 70 61 73 ((pas
5b20: 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 s).;;
5b30: 20 20 20 28 63 61 73 65 20 6e 73 74 61 74 65 0a (case nstate.
5b40: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5b50: 20 20 28 28 70 61 73 73 20 6e 2f 61 20 64 65 6c ((pass n/a del
5b60: 65 74 65 64 29 20 20 20 20 20 70 61 73 73 29 0a eted) pass).
5b70: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5b80: 20 20 28 28 77 61 72 6e 29 20 20 20 20 20 20 20 ((warn)
5b90: 20 20 20 20 20 20 20 20 20 20 77 61 72 6e 29 0a warn).
5ba0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5bb0: 20 20 28 28 66 61 69 6c 29 20 20 20 20 20 20 20 ((fail)
5bc0: 20 20 20 20 20 20 20 20 20 20 66 61 69 6c 29 0a fail).
5bd0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5be0: 20 20 28 28 63 68 65 63 6b 29 20 20 20 20 20 20 ((check)
5bf0: 20 20 20 20 20 20 20 20 20 63 68 65 63 6b 29 0a check).
5c00: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5c10: 20 20 28 28 77 61 69 76 65 64 29 20 20 20 20 20 ((waived)
5c20: 20 20 20 20 20 20 20 20 77 61 69 76 65 64 29 0a waived).
5c30: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5c40: 20 20 28 28 73 6b 69 70 29 20 20 20 20 20 20 20 ((skip)
5c50: 20 20 20 20 20 20 20 20 20 20 73 6b 69 70 29 0a skip).
5c60: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5c70: 20 20 28 28 73 74 75 63 6b 2f 64 65 61 64 29 20 ((stuck/dead)
5c80: 20 20 20 20 20 20 20 20 20 73 74 75 63 6b 29 0a stuck).
5c90: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5ca0: 20 20 28 28 61 62 6f 72 74 29 20 20 20 20 20 20 ((abort)
5cb0: 20 20 20 20 20 20 20 20 20 61 62 6f 72 74 29 0a abort).
5cc0: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5cd0: 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 75 (else u
5ce0: 6e 6b 6e 6f 77 6e 2d 65 72 72 6f 72 2d 34 29 29 nknown-error-4))
5cf0: 29 0a 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ).;;
5d00: 20 28 28 77 61 72 6e 29 0a 3b 3b 20 20 20 20 20 ((warn).;;
5d10: 20 20 20 20 20 20 20 20 20 28 63 61 73 65 20 6e (case n
5d20: 73 74 61 74 65 0a 3b 3b 20 20 20 20 20 20 20 20 state.;;
5d30: 20 20 20 20 20 20 20 20 28 28 70 61 73 73 20 77 ((pass w
5d40: 61 72 6e 20 6e 2f 61 20 73 6b 69 70 20 64 65 6c arn n/a skip del
5d50: 65 74 65 64 29 20 20 20 77 61 72 6e 29 0a 3b 3b eted) warn).;;
5d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d70: 28 28 66 61 69 6c 29 20 20 20 20 20 20 20 20 20 ((fail)
5d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5d90: 66 61 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 fail).;;
5da0: 20 20 20 20 20 20 20 20 28 28 63 68 65 63 6b 29 ((check)
5db0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5dc0: 20 20 20 20 20 20 20 63 68 65 63 6b 29 0a 3b 3b check).;;
5dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5de0: 28 28 77 61 69 76 65 64 29 20 20 20 20 20 20 20 ((waived)
5df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 77 61 wa
5e00: 69 76 65 64 29 0a 3b 3b 20 20 20 20 20 20 20 20 ived).;;
5e10: 20 20 20 20 20 20 20 20 28 28 73 74 75 63 6b 2f ((stuck/
5e20: 64 65 61 64 29 20 20 20 20 20 20 20 20 20 20 20 dead)
5e30: 20 20 20 20 20 20 20 73 74 75 63 6b 29 0a 3b 3b stuck).;;
5e40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5e50: 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 20 20 (else
5e60: 20 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 unknown-err
5e70: 6f 72 2d 35 29 29 29 0a 3b 3b 20 20 20 20 20 20 or-5))).;;
5e80: 20 20 20 20 20 20 20 28 28 66 61 69 6c 29 0a 3b ((fail).;
5e90: 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ; (
5ea0: 63 61 73 65 20 6e 73 74 61 74 65 0a 3b 3b 20 20 case nstate.;;
5eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 28 ((
5ec0: 70 61 73 73 20 77 61 72 6e 20 66 61 69 6c 20 63 pass warn fail c
5ed0: 68 65 63 6b 20 6e 2f 61 20 77 61 69 76 65 64 20 heck n/a waived
5ee0: 73 6b 69 70 20 64 65 6c 65 74 65 64 20 73 74 75 skip deleted stu
5ef0: 63 6b 2f 64 65 61 64 20 73 74 75 63 6b 29 20 20 ck/dead stuck)
5f00: 66 61 69 6c 29 0a 3b 3b 20 20 20 20 20 20 20 20 fail).;;
5f10: 20 20 20 20 20 20 20 20 28 28 61 62 6f 72 74 29 ((abort)
5f20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
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 61 62 6f 72 74 29 0a abort).
5f60: 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ;;
5f70: 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 20 20 (else
5f80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5f90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
5fa0: 20 20 20 20 20 20 20 20 20 75 6e 6b 6e 6f 77 6e unknown
5fb0: 2d 65 72 72 6f 72 2d 36 29 29 29 0a 3b 3b 20 20 -error-6))).;;
5fc0: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
5fd0: 20 20 20 20 75 6e 6b 6e 6f 77 6e 2d 65 72 72 6f unknown-erro
5fe0: 72 2d 37 29 29 29 0a 3b 3b 20 20 20 20 20 28 63 r-7))).;; (c
5ff0: 6f 6e 73 20 0a 3b 3b 20 20 20 20 20 20 28 69 66 ons .;; (if
6000: 20 6e 73 74 61 74 65 20 20 28 73 79 6d 62 6f 6c nstate (symbol
6010: 2d 3e 73 74 72 69 6e 67 20 6e 73 74 61 74 65 29 ->string nstate)
6020: 20 20 6e 73 74 61 74 65 29 0a 3b 3b 20 20 20 20 nstate).;;
6030: 20 20 28 69 66 20 6e 73 74 61 74 75 73 20 28 73 (if nstatus (s
6040: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 6e 73 ymbol->string ns
6050: 74 61 74 75 73 29 20 6e 73 74 61 74 75 73 29 29 tatus) nstatus))
6060: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
6070: 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;===========
6080: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6090: 3d 3d 3d 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 0a 3b 3b 20 44 ===========.;; D
60c0: 20 45 20 42 20 55 20 47 20 47 20 49 20 4e 20 47 E B U G G I N G
60d0: 20 20 20 53 20 54 20 55 20 46 20 46 20 0a 3b 3b S T U F F .;;
60e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
60f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
6130: 2a 76 65 72 62 6f 73 69 74 79 2a 20 20 20 20 20 *verbosity*
6140: 20 20 20 20 31 29 0a 28 64 65 66 69 6e 65 20 2a 1).(define *
6150: 6c 6f 67 67 69 6e 67 2a 20 20 20 20 20 20 20 20 logging*
6160: 20 20 20 23 66 29 0a 0a 28 64 65 66 69 6e 65 20 #f)..(define
6170: 28 67 65 74 2d 77 69 74 68 2d 64 65 66 61 75 6c (get-with-defaul
6180: 74 20 76 61 6c 20 64 65 66 61 75 6c 74 29 0a 20 t val default).
6190: 20 28 6c 65 74 20 28 28 76 61 6c 20 28 61 72 67 (let ((val (arg
61a0: 73 3a 67 65 74 2d 61 72 67 20 76 61 6c 29 29 29 s:get-arg val)))
61b0: 0a 20 20 20 20 28 69 66 20 76 61 6c 20 76 61 6c . (if val val
61c0: 20 64 65 66 61 75 6c 74 29 29 29 0a 0a 28 64 65 default)))..(de
61d0: 66 69 6e 65 20 28 61 73 73 6f 63 2f 64 65 66 61 fine (assoc/defa
61e0: 75 6c 74 20 6b 65 79 20 6c 73 74 20 2e 20 64 65 ult key lst . de
61f0: 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 fault). (let ((
6200: 72 65 73 20 28 61 73 73 6f 63 20 6b 65 79 20 6c res (assoc key l
6210: 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 72 65 st))). (if re
6220: 73 20 28 63 61 64 72 20 72 65 73 29 28 69 66 20 s (cadr res)(if
6230: 28 6e 75 6c 6c 3f 20 64 65 66 61 75 6c 74 29 20 (null? default)
6240: 23 66 20 28 63 61 72 20 64 65 66 61 75 6c 74 29 #f (car default)
6250: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
6260: 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 75 ommon:get-testsu
6270: 69 74 65 2d 6e 61 6d 65 29 0a 20 20 28 6f 72 20 ite-name). (or
6280: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
6290: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
62a0: 75 70 22 20 22 61 72 65 61 2d 6e 61 6d 65 22 29 up" "area-name")
62b0: 20 3b 3b 20 6d 65 67 61 74 65 73 74 20 69 73 20 ;; megatest is
62c0: 61 20 66 6c 65 78 69 62 6c 65 20 74 6f 6f 6c 2c a flexible tool,
62d0: 20 74 65 73 74 73 75 69 74 65 20 69 73 20 74 6f testsuite is to
62e0: 6f 20 6c 69 6d 69 74 69 6e 67 20 61 20 64 65 73 o limiting a des
62f0: 63 72 69 70 74 69 6f 6e 2e 0a 20 20 20 20 20 20 cription..
6300: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
6310: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
6320: 75 70 22 20 22 74 65 73 74 73 75 69 74 65 22 20 up" "testsuite"
6330: 29 0a 20 20 20 20 20 20 28 67 65 74 65 6e 76 20 ). (getenv
6340: 22 4d 54 5f 54 45 53 54 53 55 49 54 45 5f 4e 41 "MT_TESTSUITE_NA
6350: 4d 45 22 29 0a 20 20 20 20 20 20 28 69 66 20 28 ME"). (if (
6360: 73 74 72 69 6e 67 3f 20 2a 74 6f 70 70 61 74 68 string? *toppath
6370: 2a 20 29 0a 20 20 20 20 20 20 20 20 20 20 28 70 * ). (p
6380: 61 74 68 6e 61 6d 65 2d 66 69 6c 65 20 2a 74 6f athname-file *to
6390: 70 70 61 74 68 2a 29 0a 20 20 20 20 20 20 20 20 ppath*).
63a0: 20 20 23 66 29 29 29 20 3b 3b 20 28 70 61 74 68 #f))) ;; (path
63b0: 6e 61 6d 65 2d 66 69 6c 65 20 28 63 75 72 72 65 name-file (curre
63c0: 6e 74 2d 64 69 72 65 63 74 6f 72 79 29 29 29 29 nt-directory))))
63d0: 29 0a 0a 28 64 65 66 69 6e 65 20 63 6f 6d 6d 6f )..(define commo
63e0: 6e 3a 67 65 74 2d 61 72 65 61 2d 6e 61 6d 65 20 n:get-area-name
63f0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 74 73 common:get-tests
6400: 75 69 74 65 2d 6e 61 6d 65 29 0a 0a 3b 3b 20 57 uite-name)..;; W
6410: 41 52 4e 49 4e 47 3a 20 54 68 69 73 20 63 6f 64 ARNING: This cod
6420: 65 20 66 61 6c 6c 73 20 62 61 63 6b 20 74 6f 20 e falls back to
6430: 75 73 69 6e 67 20 74 68 65 20 67 6c 6f 62 61 6c using the global
6440: 20 4d 65 67 61 74 65 73 74 0a 3b 3b 20 20 20 20 Megatest.;;
6450: 20 20 20 20 20 20 76 61 72 69 61 62 6c 65 20 2a variable *
6460: 74 6f 70 70 61 74 68 2a 0a 3b 3b 20 0a 28 64 65 toppath*.;; .(de
6470: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
6480: 2d 64 62 2d 74 6d 70 2d 61 72 65 61 20 23 21 6b -db-tmp-area #!k
6490: 65 79 20 28 64 62 73 74 72 75 63 74 20 23 66 29 ey (dbstruct #f)
64a0: 29 0a 20 20 28 69 66 20 28 61 6e 64 20 64 62 73 ). (if (and dbs
64b0: 74 72 75 63 74 20 28 64 62 72 3a 64 62 73 74 72 truct (dbr:dbstr
64c0: 75 63 74 2d 74 6d 70 64 62 2d 70 61 74 68 20 64 uct-tmpdb-path d
64d0: 62 73 74 72 75 63 74 29 29 20 3b 3b 20 2a 64 62 bstruct)) ;; *db
64e0: 2d 63 61 63 68 65 2d 70 61 74 68 2a 0a 20 20 20 -cache-path*.
64f0: 20 20 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 (dbr:dbstruct
6500: 2d 74 6d 70 64 62 2d 70 61 74 68 20 64 62 73 74 -tmpdb-path dbst
6510: 72 75 63 74 29 20 3b 3b 20 2a 64 62 2d 63 61 63 ruct) ;; *db-cac
6520: 68 65 2d 70 61 74 68 2a 0a 20 20 20 20 20 20 28 he-path*. (
6530: 6c 65 74 20 28 28 74 6f 70 70 61 74 68 20 28 6f let ((toppath (o
6540: 72 20 28 61 6e 64 20 64 62 73 74 72 75 63 74 20 r (and dbstruct
6550: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 61 72 (dbr:dbstruct-ar
6560: 65 61 2d 70 61 74 68 20 64 62 73 74 72 75 63 74 ea-path dbstruct
6570: 29 29 20 2a 74 6f 70 70 61 74 68 2a 29 29 0a 09 )) *toppath*))..
6580: 20 20 20 20 28 74 73 6e 61 6d 65 20 20 28 6f 72 (tsname (or
6590: 20 28 61 6e 64 20 64 62 73 74 72 75 63 74 20 28 (and dbstruct (
65a0: 64 62 72 3a 64 62 73 74 72 75 63 74 2d 61 72 65 dbr:dbstruct-are
65b0: 61 2d 6e 61 6d 65 20 64 62 73 74 72 75 63 74 29 a-name dbstruct)
65c0: 29 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 74 65 73 )(common:get-tes
65d0: 74 73 75 69 74 65 2d 6e 61 6d 65 29 29 29 29 0a tsuite-name)))).
65e0: 09 28 69 66 20 74 6f 70 70 61 74 68 20 3b 3b 20 .(if toppath ;;
65f0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 72 65 61 74 common:get-creat
6600: 65 2d 77 72 69 74 65 61 62 6c 65 2d 64 69 72 0a e-writeable-dir.
6610: 09 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 . (handle-exc
6620: 65 70 74 69 6f 6e 73 0a 09 09 65 78 6e 0a 09 09 eptions...exn...
6630: 28 62 65 67 69 6e 0a 09 09 20 20 28 64 65 62 75 (begin... (debu
6640: 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 20 30 20 g:print-error 0
6650: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6660: 74 2a 20 22 43 6f 75 6c 64 6e 27 74 20 63 72 65 t* "Couldn't cre
6670: 61 74 65 20 70 61 74 68 20 74 6f 20 22 20 64 62 ate path to " db
6680: 64 69 72 29 0a 09 09 20 20 28 65 78 69 74 20 31 dir)... (exit 1
6690: 29 29 0a 09 20 20 20 20 20 20 28 6c 65 74 20 28 )).. (let (
66a0: 28 64 62 70 61 74 68 20 28 63 6f 6d 6d 6f 6e 3a (dbpath (common:
66b0: 67 65 74 2d 63 72 65 61 74 65 2d 77 72 69 74 65 get-create-write
66c0: 61 62 6c 65 2d 64 69 72 0a 09 09 09 20 20 20 20 able-dir....
66d0: 20 28 6c 69 73 74 20 28 63 6f 6e 63 20 22 2f 74 (list (conc "/t
66e0: 6d 70 2f 22 20 28 63 75 72 72 65 6e 74 2d 75 73 mp/" (current-us
66f0: 65 72 2d 6e 61 6d 65 29 0a 09 09 09 09 09 20 22 er-name)...... "
6700: 2f 6d 65 67 61 74 65 73 74 5f 6c 6f 63 61 6c 64 /megatest_locald
6710: 62 2f 22 0a 09 09 09 09 09 20 74 73 6e 61 6d 65 b/"...... tsname
6720: 20 22 2f 22 0a 09 09 09 09 09 20 28 73 74 72 69 "/"...... (stri
6730: 6e 67 2d 74 72 61 6e 73 6c 61 74 65 20 74 6f 70 ng-translate top
6740: 70 61 74 68 20 22 2f 22 20 22 2e 22 29 29 29 29 path "/" "."))))
6750: 29 29 20 3b 3b 20 20 23 74 29 29 29 29 0a 09 09 )) ;; #t))))...
6760: 3b 3b 20 28 73 65 74 21 20 2a 64 62 2d 63 61 63 ;; (set! *db-cac
6770: 68 65 2d 70 61 74 68 2a 20 64 62 70 61 74 68 29 he-path* dbpath)
6780: 0a 09 09 28 69 66 20 64 62 73 74 72 75 63 74 20 ...(if dbstruct
6790: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 74 6d (dbr:dbstruct-tm
67a0: 70 64 62 2d 70 61 74 68 2d 73 65 74 21 20 64 62 pdb-path-set! db
67b0: 73 74 72 75 63 74 20 64 62 70 61 74 68 29 29 0a struct dbpath)).
67c0: 09 09 64 62 70 61 74 68 29 29 0a 09 20 20 20 20 ..dbpath))..
67d0: 23 66 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f))))..(define
67e0: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 61 72 65 61 (common:get-area
67f0: 2d 70 61 74 68 2d 73 69 67 6e 61 74 75 72 65 29 -path-signature)
6800: 0a 20 20 28 6d 65 73 73 61 67 65 2d 64 69 67 65 . (message-dige
6810: 73 74 2d 73 74 72 69 6e 67 20 28 6d 64 35 2d 70 st-string (md5-p
6820: 72 69 6d 69 74 69 76 65 29 20 2a 74 6f 70 70 61 rimitive) *toppa
6830: 74 68 2a 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 th*))..(define (
6840: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 73 69 67 6e 61 common:get-signa
6850: 74 75 72 65 20 73 74 72 29 0a 20 20 28 6d 65 73 ture str). (mes
6860: 73 61 67 65 2d 64 69 67 65 73 74 2d 73 74 72 69 sage-digest-stri
6870: 6e 67 20 28 6d 64 35 2d 70 72 69 6d 69 74 69 76 ng (md5-primitiv
6880: 65 29 20 73 74 72 29 29 0a 0a 3b 3b 3d 3d 3d 3d e) str))..;;====
6890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
68d0: 3d 3d 0a 3b 3b 20 45 20 58 20 49 20 54 20 20 20 ==.;; E X I T
68e0: 48 20 41 20 4e 20 44 20 4c 20 49 20 4e 20 47 0a H A N D L I N G.
68f0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
6900: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6910: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6920: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
6930: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e ========..(defin
6940: 65 20 28 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 e (common:run-sy
6950: 6e 63 3f 29 0a 20 20 20 20 28 61 6e 64 20 28 63 nc?). (and (c
6960: 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 ommon:on-homehos
6970: 74 3f 29 0a 09 20 28 61 72 67 73 3a 67 65 74 2d t?).. (args:get-
6980: 61 72 67 20 22 2d 73 65 72 76 65 72 22 29 29 29 arg "-server")))
6990: 0a 0a 3b 3b 20 20 20 28 6c 65 74 20 28 28 6f 68 ..;; (let ((oh
69a0: 68 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d h (common:on-hom
69b0: 65 68 6f 73 74 3f 29 29 0a 3b 3b 20 09 28 73 72 ehost?)).;; .(sr
69c0: 76 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 v (args:get-arg
69d0: 22 2d 73 65 72 76 65 72 22 29 29 29 0a 3b 3b 20 "-server"))).;;
69e0: 20 20 20 20 28 61 6e 64 20 6f 68 68 20 73 72 76 (and ohh srv
69f0: 29 29 29 0a 20 20 20 20 3b 3b 20 28 64 65 62 75 ))). ;; (debu
6a00: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
6a10: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
6a20: 2a 20 22 63 6f 6d 6d 6f 6e 3a 72 75 6e 2d 73 79 * "common:run-sy
6a30: 6e 63 3f 20 6f 68 68 3d 22 20 6f 68 68 20 22 2c nc? ohh=" ohh ",
6a40: 20 73 72 76 3d 22 20 73 72 76 29 0a 0a 0a 0a 28 srv=" srv)....(
6a50: 64 65 66 69 6e 65 20 2a 77 64 6e 75 6d 2a 20 30 define *wdnum* 0
6a60: 29 0a 28 64 65 66 69 6e 65 20 2a 77 64 6e 75 6d ).(define *wdnum
6a70: 2a 6d 75 74 65 78 20 28 6d 61 6b 65 2d 6d 75 74 *mutex (make-mut
6a80: 65 78 29 29 0a 3b 3b 20 63 75 72 72 65 6e 74 6c ex)).;; currentl
6a90: 79 20 74 68 65 20 70 72 69 6d 61 72 79 20 6a 6f y the primary jo
6aa0: 62 20 6f 66 20 74 68 65 20 77 61 74 63 68 64 6f b of the watchdo
6ab0: 67 20 69 73 20 74 6f 20 72 75 6e 20 74 68 65 20 g is to run the
6ac0: 73 79 6e 63 20 62 61 63 6b 20 74 6f 20 6d 65 67 sync back to meg
6ad0: 61 74 65 73 74 2e 64 62 20 66 72 6f 6d 20 74 68 atest.db from th
6ae0: 65 20 64 62 20 69 6e 20 2f 74 6d 70 0a 3b 3b 20 e db in /tmp.;;
6af0: 69 66 20 77 65 20 61 72 65 20 6f 6e 20 74 68 65 if we are on the
6b00: 20 68 6f 6d 65 68 6f 73 74 20 61 6e 64 20 77 65 homehost and we
6b10: 20 61 72 65 20 61 20 73 65 72 76 65 72 20 28 62 are a server (b
6b20: 79 20 64 65 66 69 6e 69 74 69 6f 6e 20 77 65 20 y definition we
6b30: 61 72 65 20 6f 6e 20 74 68 65 20 68 6f 6d 65 68 are on the homeh
6b40: 6f 73 74 20 69 66 20 77 65 20 61 72 65 20 61 20 ost if we are a
6b50: 73 65 72 76 65 72 29 0a 3b 3b 0a 0a 0a 28 64 65 server).;;...(de
6b60: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 72 65 61 fine (common:rea
6b70: 64 6f 6e 6c 79 2d 77 61 74 63 68 64 6f 67 20 64 donly-watchdog d
6b80: 62 73 74 72 75 63 74 29 0a 20 20 28 74 68 72 65 bstruct). (thre
6b90: 61 64 2d 73 6c 65 65 70 21 20 30 2e 30 35 29 20 ad-sleep! 0.05)
6ba0: 3b 3b 20 64 65 6c 61 79 20 66 6f 72 20 73 74 61 ;; delay for sta
6bb0: 72 74 75 70 0a 20 20 28 64 65 62 75 67 3a 70 72 rtup. (debug:pr
6bc0: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
6bd0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6be0: 63 6f 6d 6d 6f 6e 3a 72 65 61 64 6f 6e 6c 79 2d common:readonly-
6bf0: 77 61 74 63 68 64 6f 67 20 65 6e 74 65 72 65 64 watchdog entered
6c00: 2e 22 29 0a 20 20 3b 3b 20 73 79 6e 63 20 6d 65 ."). ;; sync me
6c10: 67 61 74 65 73 74 2e 64 62 20 74 6f 20 2f 74 6d gatest.db to /tm
6c20: 70 2f 2e 2e 2e 2f 6d 65 67 61 74 73 74 2e 64 62 p/.../megatst.db
6c30: 0a 20 20 28 6c 65 74 2a 20 28 28 73 79 6e 63 2d . (let* ((sync-
6c40: 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 6f cool-off-duratio
6c50: 6e 20 20 20 33 29 0a 20 20 20 20 20 20 20 20 28 n 3). (
6c60: 67 6f 6c 64 65 6e 2d 6d 74 64 62 20 20 20 20 20 golden-mtdb
6c70: 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 6d 74 (dbr:dbstruct-mt
6c80: 64 62 20 64 62 73 74 72 75 63 74 29 29 0a 20 20 db dbstruct)).
6c90: 20 20 20 20 20 20 28 67 6f 6c 64 65 6e 2d 6d 74 (golden-mt
6ca0: 70 61 74 68 20 20 20 28 64 62 3a 64 62 64 61 74 path (db:dbdat
6cb0: 2d 67 65 74 2d 70 61 74 68 20 67 6f 6c 64 65 6e -get-path golden
6cc0: 2d 6d 74 64 62 29 29 0a 20 20 20 20 20 20 20 20 -mtdb)).
6cd0: 28 74 6d 70 2d 6d 74 64 62 20 20 20 20 20 20 20 (tmp-mtdb
6ce0: 20 28 64 62 72 3a 64 62 73 74 72 75 63 74 2d 74 (dbr:dbstruct-t
6cf0: 6d 70 64 62 20 64 62 73 74 72 75 63 74 29 29 0a mpdb dbstruct)).
6d00: 20 20 20 20 20 20 20 20 28 74 6d 70 2d 6d 74 70 (tmp-mtp
6d10: 61 74 68 20 20 20 20 20 20 28 64 62 3a 64 62 64 ath (db:dbd
6d20: 61 74 2d 67 65 74 2d 70 61 74 68 20 74 6d 70 2d at-get-path tmp-
6d30: 6d 74 64 62 29 29 29 0a 20 20 20 20 28 64 65 62 mtdb))). (deb
6d40: 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 ug:print-info 0
6d50: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
6d60: 74 2a 20 22 52 65 61 64 2d 6f 6e 6c 79 20 70 65 t* "Read-only pe
6d70: 72 69 6f 64 69 63 20 73 79 6e 63 20 74 68 72 65 riodic sync thre
6d80: 61 64 20 73 74 61 72 74 65 64 2e 22 29 0a 20 20 ad started.").
6d90: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 6c 61 (let loop ((la
6da0: 73 74 2d 73 79 6e 63 2d 74 69 6d 65 20 30 29 29 st-sync-time 0))
6db0: 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
6dc0: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
6dd0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
6de0: 6c 6f 6f 70 20 74 6f 70 20 74 6d 70 2d 6d 74 70 loop top tmp-mtp
6df0: 61 74 68 3d 22 74 6d 70 2d 6d 74 70 61 74 68 22 ath="tmp-mtpath"
6e00: 20 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 3d 22 golden-mtpath="
6e10: 67 6f 6c 64 65 6e 2d 6d 74 70 61 74 68 29 0a 20 golden-mtpath).
6e20: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 64 75 72 (let* ((dur
6e30: 61 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 ation-since-last
6e40: 2d 73 79 6e 63 20 28 2d 20 28 63 75 72 72 65 6e -sync (- (curren
6e50: 74 2d 73 65 63 6f 6e 64 73 29 20 6c 61 73 74 2d t-seconds) last-
6e60: 73 79 6e 63 2d 74 69 6d 65 29 29 29 0a 20 20 20 sync-time))).
6e70: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
6e80: 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 t-info 13 *defau
6e90: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 64 75 lt-log-port* "du
6ea0: 72 61 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 ration-since-las
6eb0: 74 2d 73 79 6e 63 3d 22 64 75 72 61 74 69 6f 6e t-sync="duration
6ec0: 2d 73 69 6e 63 65 2d 6c 61 73 74 2d 73 79 6e 63 -since-last-sync
6ed0: 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 61 ). (if (a
6ee0: 6e 64 20 28 6e 6f 74 20 2a 74 69 6d 65 2d 74 6f nd (not *time-to
6ef0: 2d 65 78 69 74 2a 29 0a 20 20 20 20 20 20 20 20 -exit*).
6f00: 20 20 20 20 20 20 20 20 20 28 3c 20 64 75 72 61 (< dura
6f10: 74 69 6f 6e 2d 73 69 6e 63 65 2d 6c 61 73 74 2d tion-since-last-
6f20: 73 79 6e 63 20 73 79 6e 63 2d 63 6f 6f 6c 2d 6f sync sync-cool-o
6f30: 66 66 2d 64 75 72 61 74 69 6f 6e 29 29 0a 20 20 ff-duration)).
6f40: 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 61 (threa
6f50: 64 2d 73 6c 65 65 70 21 20 28 2d 20 73 79 6e 63 d-sleep! (- sync
6f60: 2d 63 6f 6f 6c 2d 6f 66 66 2d 64 75 72 61 74 69 -cool-off-durati
6f70: 6f 6e 20 64 75 72 61 74 69 6f 6e 2d 73 69 6e 63 on duration-sinc
6f80: 65 2d 6c 61 73 74 2d 73 79 6e 63 29 29 29 0a 20 e-last-sync))).
6f90: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
6fa0: 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 0a *time-to-exit*).
6fb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
6fc0: 20 28 28 67 6f 6c 64 65 6e 2d 6d 74 64 62 2d 6d ((golden-mtdb-m
6fd0: 74 69 6d 65 20 28 66 69 6c 65 2d 6d 6f 64 69 66 time (file-modif
6fe0: 69 63 61 74 69 6f 6e 2d 74 69 6d 65 20 67 6f 6c ication-time gol
6ff0: 64 65 6e 2d 6d 74 70 61 74 68 29 29 0a 20 20 20 den-mtpath)).
7000: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
7010: 74 6d 70 2d 6d 74 64 62 2d 6d 74 69 6d 65 20 20 tmp-mtdb-mtime
7020: 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 63 61 (file-modifica
7030: 74 69 6f 6e 2d 74 69 6d 65 20 74 6d 70 2d 6d 74 tion-time tmp-mt
7040: 70 61 74 68 29 29 29 0a 09 20 20 20 20 20 20 28 path))).. (
7050: 69 66 20 28 3e 20 67 6f 6c 64 65 6e 2d 6d 74 64 if (> golden-mtd
7060: 62 2d 6d 74 69 6d 65 20 74 6d 70 2d 6d 74 64 62 b-mtime tmp-mtdb
7070: 2d 6d 74 69 6d 65 29 0a 09 09 20 20 28 69 66 20 -mtime)... (if
7080: 28 3c 20 67 6f 6c 64 65 6e 2d 6d 74 64 62 2d 6d (< golden-mtdb-m
7090: 74 69 6d 65 20 28 2d 20 28 63 75 72 72 65 6e 74 time (- (current
70a0: 2d 73 65 63 6f 6e 64 73 29 20 33 29 29 20 3b 3b -seconds) 3)) ;;
70b0: 20 66 69 6c 65 20 68 61 73 20 4e 4f 54 20 62 65 file has NOT be
70c0: 65 6e 20 74 6f 75 63 68 65 64 20 69 6e 20 70 61 en touched in pa
70d0: 73 74 20 74 68 72 65 65 20 73 65 63 6f 6e 64 73 st three seconds
70e0: 2c 20 74 68 69 73 20 77 61 79 20 6d 75 6c 74 69 , this way multi
70f0: 70 6c 65 20 73 65 72 76 65 72 73 20 77 6f 6e 27 ple servers won'
7100: 74 20 66 69 67 68 74 20 74 6f 20 73 79 6e 63 20 t fight to sync
7110: 62 61 63 6b 0a 09 09 20 20 20 20 20 20 28 6c 65 back... (le
7120: 74 20 28 28 72 65 73 20 28 64 62 3a 6d 75 6c 74 t ((res (db:mult
7130: 69 2d 64 62 2d 73 79 6e 63 20 64 62 73 74 72 75 i-db-sync dbstru
7140: 63 74 20 27 6f 6c 64 32 6e 65 77 29 29 29 0a 09 ct 'old2new)))..
7150: 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
7160: 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d nfo 13 *default-
7170: 6c 6f 67 2d 70 6f 72 74 2a 20 22 72 6f 73 79 6e log-port* "rosyn
7180: 63 20 63 61 6c 6c 65 64 2c 20 22 20 72 65 73 20 c called, " res
7190: 22 20 72 65 63 6f 72 64 73 20 74 72 61 6e 73 66 " records transf
71a0: 65 72 72 65 64 2e 22 29 29 29 29 0a 20 20 20 20 erred.")))).
71b0: 20 20 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 (loop
71c0: 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
71d0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
71e0: 23 74 29 29 29 0a 20 20 20 20 28 64 65 62 75 67 #t))). (debug
71f0: 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 :print-info 0 *d
7200: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
7210: 20 22 45 78 69 74 69 6e 67 20 72 65 61 64 6f 6e "Exiting readon
7220: 6c 79 2d 77 61 74 63 68 64 6f 67 20 74 69 6d 65 ly-watchdog time
7230: 72 2c 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 r, *time-to-exit
7240: 2a 20 3d 20 22 20 2a 74 69 6d 65 2d 74 6f 2d 65 * = " *time-to-e
7250: 78 69 74 2a 22 20 70 69 64 3d 22 28 63 75 72 72 xit*" pid="(curr
7260: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 22 ent-process-id)"
7270: 20 6d 74 70 61 74 68 3d 22 67 6f 6c 64 65 6e 2d mtpath="golden-
7280: 6d 74 70 61 74 68 29 29 29 0a 0a 3b 3b 20 54 4f mtpath)))..;; TO
7290: 44 4f 3a 20 66 6f 72 20 6d 75 6c 74 69 70 6c 65 DO: for multiple
72a0: 20 61 72 65 61 73 2c 20 77 65 20 77 69 6c 6c 20 areas, we will
72b0: 68 61 76 65 20 6d 75 6c 74 69 70 6c 65 20 77 61 have multiple wa
72c0: 74 63 68 64 6f 67 73 3b 20 61 6e 64 20 6d 75 6c tchdogs; and mul
72d0: 74 69 70 6c 65 20 74 68 72 65 61 64 73 20 74 6f tiple threads to
72e0: 20 6d 61 6e 61 67 65 0a 28 64 65 66 69 6e 65 20 manage.(define
72f0: 28 63 6f 6d 6d 6f 6e 3a 77 61 74 63 68 64 6f 67 (common:watchdog
7300: 29 0a 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 ). (debug:print
7310: 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c -info 13 *defaul
7320: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 63 6f 6d t-log-port* "com
7330: 6d 6f 6e 3a 77 61 74 63 68 64 6f 67 20 65 6e 74 mon:watchdog ent
7340: 65 72 65 64 2e 22 29 0a 20 20 28 69 66 20 28 6c ered."). (if (l
7350: 61 75 6e 63 68 3a 73 65 74 75 70 29 0a 20 20 20 aunch:setup).
7360: 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6f (if (common:o
7370: 6e 2d 68 6f 6d 65 68 6f 73 74 3f 29 0a 09 20 20 n-homehost?)..
7380: 28 6c 65 74 20 28 28 64 62 73 74 72 75 63 74 20 (let ((dbstruct
7390: 28 64 62 3a 73 65 74 75 70 20 23 74 29 29 29 0a (db:setup #t))).
73a0: 09 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e . (debug:prin
73b0: 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 t-info 13 *defau
73c0: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 61 66 lt-log-port* "af
73d0: 74 65 72 20 64 62 3a 73 65 74 75 70 20 77 69 74 ter db:setup wit
73e0: 68 20 64 62 73 74 72 75 63 74 3d 22 20 64 62 73 h dbstruct=" dbs
73f0: 74 72 75 63 74 29 0a 09 20 20 20 20 28 63 6f 6e truct).. (con
7400: 64 0a 09 20 20 20 20 20 28 28 64 62 72 3a 64 62 d.. ((dbr:db
7410: 73 74 72 75 63 74 2d 72 65 61 64 2d 6f 6e 6c 79 struct-read-only
7420: 20 64 62 73 74 72 75 63 74 29 0a 09 20 20 20 20 dbstruct)..
7430: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
7440: 6e 66 6f 20 31 33 20 2a 64 65 66 61 75 6c 74 2d nfo 13 *default-
7450: 6c 6f 67 2d 70 6f 72 74 2a 20 22 6c 6f 61 64 69 log-port* "loadi
7460: 6e 67 20 72 65 61 64 2d 6f 6e 6c 79 20 77 61 74 ng read-only wat
7470: 63 68 64 6f 67 22 29 0a 09 20 20 20 20 20 20 28 chdog").. (
7480: 63 6f 6d 6d 6f 6e 3a 72 65 61 64 6f 6e 6c 79 2d common:readonly-
7490: 77 61 74 63 68 64 6f 67 20 64 62 73 74 72 75 63 watchdog dbstruc
74a0: 74 29 29 0a 09 20 20 20 20 20 28 65 6c 73 65 0a t)).. (else.
74b0: 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 . (debug:pr
74c0: 69 6e 74 2d 69 6e 66 6f 20 31 33 20 2a 64 65 66 int-info 13 *def
74d0: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
74e0: 6c 6f 61 64 69 6e 67 20 77 72 69 74 61 62 6c 65 loading writable
74f0: 2d 77 61 74 63 68 64 6f 67 2e 22 29 0a 09 20 20 -watchdog.")..
7500: 20 20 20 20 28 73 65 72 76 65 72 3a 77 72 69 74 (server:writ
7510: 61 62 6c 65 2d 77 61 74 63 68 64 6f 67 20 64 62 able-watchdog db
7520: 73 74 72 75 63 74 29 29 29 0a 09 20 20 20 20 28 struct))).. (
7530: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7540: 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 13 *default-log
7550: 2d 70 6f 72 74 2a 20 22 77 61 74 63 68 64 6f 67 -port* "watchdog
7560: 20 64 6f 6e 65 2e 22 29 29 0a 09 20 20 28 64 65 done.")).. (de
7570: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
7580: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
7590: 6f 72 74 2a 20 22 6e 6f 20 6e 65 65 64 20 66 6f ort* "no need fo
75a0: 72 20 77 61 74 63 68 64 6f 67 20 6f 6e 20 6e 6f r watchdog on no
75b0: 6e 2d 68 6f 6d 65 68 6f 73 74 22 29 29 29 29 0a n-homehost")))).
75c0: 0a 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d 65 ..(define (std-e
75d0: 78 69 74 2d 70 72 6f 63 65 64 75 72 65 29 0a 20 xit-procedure).
75e0: 20 28 6f 6e 2d 65 78 69 74 20 28 6c 61 6d 62 64 (on-exit (lambd
75f0: 61 20 28 29 20 30 29 29 0a 20 20 3b 3b 28 64 65 a () 0)). ;;(de
7600: 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 bug:print-info 1
7610: 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 3 *default-log-p
7620: 6f 72 74 2a 20 22 73 74 64 2d 65 78 69 74 2d 70 ort* "std-exit-p
7630: 72 6f 63 65 64 75 72 65 20 63 61 6c 6c 65 64 3b rocedure called;
7640: 20 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 3d *time-to-exit*=
7650: 22 2a 74 69 6d 65 2d 74 6f 2d 65 78 69 74 2a 29 "*time-to-exit*)
7660: 0a 20 20 28 6c 65 74 20 28 28 6e 6f 2d 68 75 72 . (let ((no-hur
7670: 72 79 20 20 28 69 66 20 2a 74 69 6d 65 2d 74 6f ry (if *time-to
7680: 2d 65 78 69 74 2a 20 3b 3b 20 68 75 72 72 79 20 -exit* ;; hurry
7690: 75 70 0a 09 09 20 20 20 20 20 20 20 23 66 0a 09 up... #f..
76a0: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
76b0: 09 09 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 .. (set! *time-t
76c0: 6f 2d 65 78 69 74 2a 20 23 74 29 0a 09 09 09 20 o-exit* #t)....
76d0: 23 74 29 29 29 29 0a 20 20 20 20 28 64 65 62 75 #t)))). (debu
76e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 34 20 2a g:print-info 4 *
76f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7700: 2a 20 22 73 74 61 72 74 69 6e 67 20 65 78 69 74 * "starting exit
7710: 20 70 72 6f 63 65 73 73 2c 20 66 69 6e 61 6c 69 process, finali
7720: 7a 69 6e 67 20 64 61 74 61 62 61 73 65 73 2e 22 zing databases."
7730: 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 20 6e ). (if (and n
7740: 6f 2d 68 75 72 72 79 20 28 64 65 62 75 67 3a 64 o-hurry (debug:d
7750: 65 62 75 67 2d 6d 6f 64 65 20 31 38 29 29 0a 09 ebug-mode 18))..
7760: 28 72 6d 74 3a 70 72 69 6e 74 2d 64 62 2d 73 74 (rmt:print-db-st
7770: 61 74 73 29 29 0a 20 20 20 20 28 6c 65 74 20 28 ats)). (let (
7780: 28 74 68 31 20 28 6d 61 6b 65 2d 74 68 72 65 61 (th1 (make-threa
7790: 64 20 28 6c 61 6d 62 64 61 20 28 29 20 3b 3b 20 d (lambda () ;;
77a0: 74 68 72 65 61 64 20 66 6f 72 20 63 6c 65 61 6e thread for clean
77b0: 69 6e 67 20 75 70 2c 20 67 69 76 65 20 69 74 20 ing up, give it
77c0: 66 69 76 65 20 73 65 63 6f 6e 64 73 0a 20 20 20 five seconds.
77d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
77e0: 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 2a (if *
77f0: 64 62 73 74 72 75 63 74 2d 64 62 2a 20 28 64 62 dbstruct-db* (db
7800: 3a 63 6c 6f 73 65 2d 61 6c 6c 20 2a 64 62 73 74 :close-all *dbst
7810: 72 75 63 74 2d 64 62 2a 29 29 20 3b 3b 20 6f 6e ruct-db*)) ;; on
7820: 65 20 73 65 63 6f 6e 64 20 61 6c 6c 6f 63 61 74 e second allocat
7830: 65 64 0a 09 09 09 20 20 20 20 20 20 28 69 66 20 ed.... (if
7840: 2a 74 61 73 6b 2d 64 62 2a 20 20 20 20 0a 09 09 *task-db* ...
7850: 09 09 20 20 28 6c 65 74 20 28 28 64 62 20 28 63 .. (let ((db (c
7860: 64 72 20 2a 74 61 73 6b 2d 64 62 2a 29 29 29 0a dr *task-db*))).
7870: 09 09 09 09 20 20 20 20 28 69 66 20 28 73 71 6c .... (if (sql
7880: 69 74 65 33 3a 64 61 74 61 62 61 73 65 3f 20 64 ite3:database? d
7890: 62 29 0a 09 09 09 09 09 28 62 65 67 69 6e 0a 09 b)......(begin..
78a0: 09 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 69 .... (sqlite3:i
78b0: 6e 74 65 72 72 75 70 74 21 20 64 62 29 0a 09 09 nterrupt! db)...
78c0: 09 09 09 20 20 28 73 71 6c 69 74 65 33 3a 66 69 ... (sqlite3:fi
78d0: 6e 61 6c 69 7a 65 21 20 64 62 20 23 74 29 0a 09 nalize! db #t)..
78e0: 09 09 09 09 20 20 3b 3b 20 28 76 65 63 74 6f 72 .... ;; (vector
78f0: 2d 73 65 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 -set! *task-db*
7900: 30 20 23 66 29 0a 09 09 09 09 09 20 20 28 73 65 0 #f)...... (se
7910: 74 21 20 2a 74 61 73 6b 2d 64 62 2a 20 23 66 29 t! *task-db* #f)
7920: 29 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 )))).
7930: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7940: 20 20 20 28 68 74 74 70 2d 63 6c 69 65 6e 74 23 (http-client#
7950: 63 6c 6f 73 65 2d 61 6c 6c 2d 63 6f 6e 6e 65 63 close-all-connec
7960: 74 69 6f 6e 73 21 29 0a 20 20 20 20 20 20 20 20 tions!).
7970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7980: 20 20 20 20 20 20 3b 3b 20 28 69 66 20 28 61 6e ;; (if (an
7990: 64 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 0a 20 20 d *runremote*.
79a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
79b0: 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 20 20 ;;
79c0: 20 20 20 20 20 20 20 20 28 72 65 6d 6f 74 65 2d (remote-
79d0: 63 6f 6e 6e 64 61 74 20 2a 72 75 6e 72 65 6d 6f conndat *runremo
79e0: 74 65 2a 29 29 0a 20 20 20 20 20 20 20 20 20 20 te*)).
79f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a00: 20 20 20 20 3b 3b 20 20 20 20 20 28 62 65 67 69 ;; (begi
7a10: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
7a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a30: 3b 3b 20 20 20 20 20 20 20 28 68 74 74 70 2d 63 ;; (http-c
7a40: 6c 69 65 6e 74 23 63 6c 6f 73 65 2d 61 6c 6c 2d lient#close-all-
7a50: 63 6f 6e 6e 65 63 74 69 6f 6e 73 21 29 29 29 20 connections!)))
7a60: 3b 3b 20 66 6f 72 20 68 74 74 70 2d 63 6c 69 65 ;; for http-clie
7a70: 6e 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 nt.
7a80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7a90: 20 28 69 66 20 28 6e 6f 74 20 28 65 71 3f 20 2a (if (not (eq? *
7aa0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7ab0: 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 72 6f 72 * (current-error
7ac0: 2d 70 6f 72 74 29 29 29 0a 20 20 20 20 20 20 20 -port))).
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 63 6c 6f 73 (clos
7af0: 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 2a 64 e-output-port *d
7b00: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
7b10: 29 29 0a 09 09 09 20 20 20 20 20 20 28 73 65 74 )).... (set
7b20: 21 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 ! *default-log-p
7b30: 6f 72 74 2a 20 28 63 75 72 72 65 6e 74 2d 65 72 ort* (current-er
7b40: 72 6f 72 2d 70 6f 72 74 29 29 29 20 22 43 6c 65 ror-port))) "Cle
7b50: 61 6e 75 70 20 64 62 20 65 78 69 74 20 74 68 72 anup db exit thr
7b60: 65 61 64 22 29 29 0a 09 20 20 28 74 68 32 20 28 ead")).. (th2 (
7b70: 6d 61 6b 65 2d 74 68 72 65 61 64 20 28 6c 61 6d make-thread (lam
7b80: 62 64 61 20 28 29 0a 09 09 09 20 20 20 20 20 20 bda ()....
7b90: 28 64 65 62 75 67 3a 70 72 69 6e 74 20 34 20 2a (debug:print 4 *
7ba0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
7bb0: 2a 20 22 41 74 74 65 6d 70 74 69 6e 67 20 63 6c * "Attempting cl
7bc0: 65 61 6e 20 65 78 69 74 2e 20 50 6c 65 61 73 65 ean exit. Please
7bd0: 20 62 65 20 70 61 74 69 65 6e 74 20 61 6e 64 20 be patient and
7be0: 77 61 69 74 20 61 20 66 65 77 20 73 65 63 6f 6e wait a few secon
7bf0: 64 73 2e 2e 2e 22 29 0a 09 09 09 20 20 20 20 20 ds...")....
7c00: 20 28 69 66 20 6e 6f 2d 68 75 72 72 79 0a 20 20 (if no-hurry.
7c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c30: 28 62 65 67 69 6e 0a 20 20 20 20 20 20 20 20 20 (begin.
7c40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7c50: 20 20 20 20 20 20 20 20 20 20 20 28 74 68 72 65 (thre
7c60: 61 64 2d 73 6c 65 65 70 21 20 35 29 29 20 3b 3b ad-sleep! 5)) ;;
7c70: 20 67 69 76 65 20 74 68 65 20 63 6c 65 61 6e 20 give the clean
7c80: 75 70 20 66 65 77 20 73 65 63 6f 6e 64 73 20 74 up few seconds t
7c90: 6f 20 64 6f 20 69 74 27 73 20 73 74 75 66 66 0a o do it's stuff.
7ca0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
7cc0: 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 20 09 (begin. .
7cd0: 09 09 09 20 20 28 74 68 72 65 61 64 2d 73 6c 65 ... (thread-sle
7ce0: 65 70 21 20 32 29 29 29 0a 20 20 20 20 20 20 09 ep! 2))). .
7cf0: 09 09 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 .. (debug:p
7d00: 72 69 6e 74 20 34 20 2a 64 65 66 61 75 6c 74 2d rint 4 *default-
7d10: 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 2e 2e 2e 20 log-port* " ...
7d20: 64 6f 6e 65 22 29 0a 20 20 20 20 20 20 09 09 09 done"). ...
7d30: 20 20 20 20 20 20 29 0a 09 09 09 20 20 20 20 22 ).... "
7d40: 63 6c 65 61 6e 20 65 78 69 74 22 29 29 29 0a 20 clean exit"))).
7d50: 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 74 61 (thread-sta
7d60: 72 74 21 20 74 68 31 29 0a 20 20 20 20 20 20 28 rt! th1). (
7d70: 74 68 72 65 61 64 2d 73 74 61 72 74 21 20 74 68 thread-start! th
7d80: 32 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2). (thread
7d90: 2d 6a 6f 69 6e 21 20 74 68 31 29 0a 20 20 20 20 -join! th1).
7da0: 20 20 29 0a 20 20 20 20 29 0a 0a 20 20 30 29 0a ). ).. 0).
7db0: 0a 28 64 65 66 69 6e 65 20 28 73 74 64 2d 73 69 .(define (std-si
7dc0: 67 6e 61 6c 2d 68 61 6e 64 6c 65 72 20 73 69 67 gnal-handler sig
7dd0: 6e 75 6d 29 0a 20 20 3b 3b 20 28 73 69 67 6e 61 num). ;; (signa
7de0: 6c 2d 6d 61 73 6b 21 20 73 69 67 6e 75 6d 29 0a l-mask! signum).
7df0: 20 20 28 73 65 74 21 20 2a 74 69 6d 65 2d 74 6f (set! *time-to
7e00: 2d 65 78 69 74 2a 20 23 74 29 0a 20 20 3b 3b 28 -exit* #t). ;;(
7e10: 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f debug:print-info
7e20: 20 31 33 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 13 *default-log
7e30: 2d 70 6f 72 74 2a 20 22 67 6f 74 20 73 69 67 6e -port* "got sign
7e40: 61 6c 20 22 73 69 67 6e 75 6d 29 0a 20 20 28 64 al "signum). (d
7e50: 65 62 75 67 3a 70 72 69 6e 74 2d 65 72 72 6f 72 ebug:print-error
7e60: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
7e70: 70 6f 72 74 2a 20 22 52 65 63 65 69 76 65 64 20 port* "Received
7e80: 73 69 67 6e 61 6c 20 22 20 73 69 67 6e 75 6d 20 signal " signum
7e90: 22 20 65 78 69 74 69 6e 67 20 70 72 6f 6d 70 74 " exiting prompt
7ea0: 6c 79 22 29 0a 20 20 3b 3b 20 28 73 74 64 2d 65 ly"). ;; (std-e
7eb0: 78 69 74 2d 70 72 6f 63 65 64 75 72 65 29 20 3b xit-procedure) ;
7ec0: 3b 20 73 68 6f 75 6c 64 6e 27 74 20 6e 65 65 64 ; shouldn't need
7ed0: 20 74 68 69 73 20 73 69 6e 63 65 20 77 65 20 61 this since we a
7ee0: 72 65 20 65 78 69 74 69 6e 67 20 61 6e 64 20 69 re exiting and i
7ef0: 74 20 77 69 6c 6c 20 62 65 20 63 61 6c 6c 65 64 t will be called
7f00: 20 61 6e 79 77 61 79 0a 20 20 28 65 78 69 74 29 anyway. (exit)
7f10: 29 0a 0a 28 73 65 74 2d 73 69 67 6e 61 6c 2d 68 )..(set-signal-h
7f20: 61 6e 64 6c 65 72 21 20 73 69 67 6e 61 6c 2f 69 andler! signal/i
7f30: 6e 74 20 20 73 74 64 2d 73 69 67 6e 61 6c 2d 68 nt std-signal-h
7f40: 61 6e 64 6c 65 72 29 20 20 3b 3b 20 5e 43 0a 28 andler) ;; ^C.(
7f50: 73 65 74 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c set-signal-handl
7f60: 65 72 21 20 73 69 67 6e 61 6c 2f 74 65 72 6d 20 er! signal/term
7f70: 73 74 64 2d 73 69 67 6e 61 6c 2d 68 61 6e 64 6c std-signal-handl
7f80: 65 72 29 0a 3b 3b 20 28 73 65 74 2d 73 69 67 6e er).;; (set-sign
7f90: 61 6c 2d 68 61 6e 64 6c 65 72 21 20 73 69 67 6e al-handler! sign
7fa0: 61 6c 2f 73 74 6f 70 20 73 74 64 2d 73 69 67 6e al/stop std-sign
7fb0: 61 6c 2d 68 61 6e 64 6c 65 72 29 20 20 3b 3b 20 al-handler) ;;
7fc0: 5e 5a 20 4e 4f 2c 20 64 6f 20 4e 4f 54 20 68 61 ^Z NO, do NOT ha
7fd0: 6e 64 6c 65 20 5e 5a 21 0a 0a 3b 3b 3d 3d 3d 3d ndle ^Z!..;;====
7fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
7ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8010: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8020: 3d 3d 0a 3b 3b 20 4d 20 49 20 53 20 43 20 20 20 ==.;; M I S C
8030: 55 20 54 20 49 20 4c 20 53 0a 3b 3b 3d 3d 3d 3d U T I L S.;;====
8040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8080: 3d 3d 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 20 73 ==..;; convert s
8090: 74 75 66 66 20 74 6f 20 61 20 6e 75 6d 62 65 72 tuff to a number
80a0: 20 69 66 20 70 6f 73 73 69 62 6c 65 0a 28 64 65 if possible.(de
80b0: 66 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 fine (any->numbe
80c0: 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 20 0a r val). (cond .
80d0: 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 61 6c ((number? val
80e0: 29 20 76 61 6c 29 0a 20 20 20 28 28 73 74 72 69 ) val). ((stri
80f0: 6e 67 3f 20 76 61 6c 29 20 28 73 74 72 69 6e 67 ng? val) (string
8100: 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 0a 20 ->number val)).
8110: 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 6c 29 ((symbol? val)
8120: 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 28 73 (any->number (s
8130: 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 76 61 ymbol->string va
8140: 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 20 23 66 l))). (else #f
8150: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 61 6e )))..(define (an
8160: 79 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 6f 73 y->number-if-pos
8170: 73 69 62 6c 65 20 76 61 6c 29 0a 20 20 28 6c 65 sible val). (le
8180: 74 20 28 28 6e 75 6d 20 28 61 6e 79 2d 3e 6e 75 t ((num (any->nu
8190: 6d 62 65 72 20 76 61 6c 29 29 29 0a 20 20 20 20 mber val))).
81a0: 28 69 66 20 6e 75 6d 20 6e 75 6d 20 76 61 6c 29 (if num num val)
81b0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 61 74 ))..(define (pat
81c0: 74 2d 6c 69 73 74 2d 6d 61 74 63 68 20 69 74 65 t-list-match ite
81d0: 6d 20 70 61 74 74 73 29 0a 20 20 28 64 65 62 75 m patts). (debu
81e0: 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 38 20 2a g:print-info 8 *
81f0: 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
8200: 2a 20 22 70 61 74 74 2d 6c 69 73 74 2d 6d 61 74 * "patt-list-mat
8210: 63 68 20 69 74 65 6d 3d 22 20 69 74 65 6d 20 22 ch item=" item "
8220: 20 70 61 74 74 73 3d 22 20 70 61 74 74 73 29 0a patts=" patts).
8230: 20 20 28 69 66 20 28 61 6e 64 20 69 74 65 6d 20 (if (and item
8240: 70 61 74 74 73 29 20 20 3b 3b 20 68 65 72 65 20 patts) ;; here
8250: 77 65 20 61 72 65 20 66 69 6c 74 65 72 69 6e 67 we are filtering
8260: 20 66 6f 72 20 6d 61 74 63 68 65 73 20 77 69 74 for matches wit
8270: 68 20 69 74 65 6d 20 70 61 74 74 65 72 6e 73 0a h item patterns.
8280: 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 73 (let ((res
8290: 20 23 66 29 29 20 20 20 3b 3b 20 6c 6f 6f 6b 20 #f)) ;; look
82a0: 74 68 72 6f 75 67 68 20 61 6c 6c 20 74 68 65 20 through all the
82b0: 69 74 65 6d 2d 70 61 74 74 73 20 69 66 20 64 65 item-patts if de
82c0: 66 69 6e 65 64 2c 20 66 6f 72 6d 61 74 20 69 73 fined, format is
82d0: 20 70 61 74 74 31 2c 70 61 74 74 32 2c 70 61 74 patt1,patt2,pat
82e0: 74 33 20 2e 2e 2e 20 77 69 6c 64 63 61 72 64 20 t3 ... wildcard
82f0: 69 73 20 25 0a 09 28 66 6f 72 2d 65 61 63 68 20 is %..(for-each
8300: 0a 09 20 28 6c 61 6d 62 64 61 20 28 70 61 74 74 .. (lambda (patt
8310: 29 0a 09 20 20 20 28 6c 65 74 20 28 28 6d 6f 64 ).. (let ((mod
8320: 70 61 74 74 20 28 73 74 72 69 6e 67 2d 73 75 62 patt (string-sub
8330: 73 74 69 74 75 74 65 20 22 25 22 20 22 2e 2a 22 stitute "%" ".*"
8340: 20 70 61 74 74 20 23 74 29 29 29 0a 09 20 20 20 patt #t)))..
8350: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
8360: 6e 66 6f 20 31 30 20 2a 64 65 66 61 75 6c 74 2d nfo 10 *default-
8370: 6c 6f 67 2d 70 6f 72 74 2a 20 22 70 61 74 74 20 log-port* "patt
8380: 22 20 70 61 74 74 20 22 20 6d 6f 64 70 61 74 74 " patt " modpatt
8390: 20 22 20 6d 6f 64 70 61 74 74 29 0a 09 20 20 20 " modpatt)..
83a0: 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
83b0: 74 63 68 20 28 72 65 67 65 78 70 20 6d 6f 64 70 tch (regexp modp
83c0: 61 74 74 29 20 69 74 65 6d 29 0a 09 09 20 28 73 att) item)... (s
83d0: 65 74 21 20 72 65 73 20 23 74 29 29 29 29 0a 09 et! res #t))))..
83e0: 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 70 (string-split p
83f0: 61 74 74 73 20 22 2c 22 29 29 0a 09 72 65 73 29 atts ","))..res)
8400: 0a 20 20 20 20 20 20 23 74 29 29 0a 0a 3b 3b 20 . #t))..;;
8410: 27 28 70 72 69 6e 74 20 28 73 74 72 69 6e 67 2d '(print (string-
8420: 69 6e 74 65 72 73 70 65 72 73 65 20 28 6d 61 70 intersperse (map
8430: 20 63 61 64 72 20 28 68 61 73 68 2d 74 61 62 6c cadr (hash-tabl
8440: 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 28 72 e-ref/default (r
8450: 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d 65 67 61 ead-config "mega
8460: 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 5c 23 66 test.config" \#f
8470: 20 5c 23 74 29 20 22 64 69 73 6b 73 22 20 27 22 \#t) "disks" '"
8480: 27 22 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 29 '"'("none" "")))
8490: 20 22 5c 6e 22 29 29 27 0a 28 64 65 66 69 6e 65 "\n"))'.(define
84a0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 (common:get-dis
84b0: 6b 73 20 23 21 6b 65 79 20 28 63 6f 6e 66 69 67 ks #!key (config
84c0: 66 20 23 66 29 29 0a 20 20 28 68 61 73 68 2d 74 f #f)). (hash-t
84d0: 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
84e0: 20 0a 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 . (or configf
84f0: 20 28 72 65 61 64 2d 63 6f 6e 66 69 67 20 22 6d (read-config "m
8500: 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 22 20 egatest.config"
8510: 23 66 20 23 74 29 29 0a 20 20 20 22 64 69 73 6b #f #t)). "disk
8520: 73 22 20 27 28 22 6e 6f 6e 65 22 20 22 22 29 29 s" '("none" ""))
8530: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 )..;; return fir
8540: 73 74 20 63 6f 6d 6d 61 6e 64 20 74 68 61 74 20 st command that
8550: 65 78 69 73 74 73 2c 20 65 6c 73 65 20 23 66 0a exists, else #f.
8560: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
8570: 6f 6e 3a 77 68 69 63 68 20 63 6d 64 73 29 0a 20 on:which cmds).
8580: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 63 6d 64 73 (if (null? cmds
8590: 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 20 ). #f.
85a0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 64 (let loop ((hed
85b0: 20 28 63 61 72 20 63 6d 64 73 29 29 0a 09 09 20 (car cmds))...
85c0: 28 74 61 6c 20 28 63 64 72 20 63 6d 64 73 29 29 (tal (cdr cmds))
85d0: 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 77 )..(let ((res (w
85e0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
85f0: 69 70 65 20 28 63 6f 6e 63 20 22 77 68 69 63 68 ipe (conc "which
8600: 20 22 20 68 65 64 29 20 72 65 61 64 2d 6c 69 6e " hed) read-lin
8610: 65 29 29 29 0a 09 20 20 28 69 66 20 28 61 6e 64 e))).. (if (and
8620: 20 28 73 74 72 69 6e 67 3f 20 72 65 73 29 0a 09 (string? res)..
8630: 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 . (common:file
8640: 2d 65 78 69 73 74 73 3f 20 72 65 73 29 29 0a 09 -exists? res))..
8650: 20 20 20 20 20 20 72 65 73 0a 09 20 20 20 20 20 res..
8660: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (if (null? tal)
8670: 0a 09 09 20 20 23 66 0a 09 09 20 20 28 6c 6f 6f ... #f... (loo
8680: 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
8690: 74 61 6c 29 29 29 29 29 29 29 29 0a 20 20 0a 28 tal)))))))). .(
86a0: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
86b0: 65 74 2d 69 6e 73 74 61 6c 6c 2d 61 72 65 61 29 et-install-area)
86c0: 0a 20 20 28 6c 65 74 20 28 28 65 78 65 2d 70 61 . (let ((exe-pa
86d0: 74 68 20 28 63 61 72 20 28 61 72 67 76 29 29 29 th (car (argv)))
86e0: 29 0a 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f ). (if (commo
86f0: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 65 n:file-exists? e
8700: 78 65 2d 70 61 74 68 29 0a 09 28 68 61 6e 64 6c xe-path)..(handl
8710: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 20 65 e-exceptions.. e
8720: 78 6e 0a 09 20 23 66 0a 09 20 28 70 61 74 68 6e xn.. #f.. (pathn
8730: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 0a 09 20 ame-directory..
8740: 20 28 70 61 74 68 6e 61 6d 65 2d 64 69 72 65 63 (pathname-direc
8750: 74 6f 72 79 20 0a 09 20 20 20 28 70 61 74 68 6e tory .. (pathn
8760: 61 6d 65 2d 64 69 72 65 63 74 6f 72 79 20 65 78 ame-directory ex
8770: 65 2d 70 61 74 68 29 29 29 29 0a 09 23 66 29 29 e-path))))..#f))
8780: 29 0a 0a 3b 3b 20 72 65 74 75 72 6e 20 66 69 72 )..;; return fir
8790: 73 74 20 70 61 74 68 20 74 68 61 74 20 63 61 6e st path that can
87a0: 20 62 65 20 63 72 65 61 74 65 64 20 6f 72 20 61 be created or a
87b0: 6c 72 65 61 64 79 20 65 78 69 73 74 73 20 61 6e lready exists an
87c0: 64 20 69 73 20 77 72 69 74 61 62 6c 65 0a 3b 3b d is writable.;;
87d0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
87e0: 3a 67 65 74 2d 63 72 65 61 74 65 2d 77 72 69 74 :get-create-writ
87f0: 65 61 62 6c 65 2d 64 69 72 20 64 69 72 73 29 0a eable-dir dirs).
8800: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 69 72 (if (null? dir
8810: 73 29 0a 20 20 20 20 20 20 23 66 0a 20 20 20 20 s). #f.
8820: 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 68 65 (let loop ((he
8830: 64 20 28 63 61 72 20 64 69 72 73 29 29 0a 09 09 d (car dirs))...
8840: 20 28 74 61 6c 20 28 63 64 72 20 64 69 72 73 29 (tal (cdr dirs)
8850: 29 29 0a 09 28 6c 65 74 20 28 28 72 65 73 20 28 ))..(let ((res (
8860: 6f 72 20 28 61 6e 64 20 28 64 69 72 65 63 74 6f or (and (directo
8870: 72 79 3f 20 68 65 64 29 0a 09 09 09 20 20 20 20 ry? hed)....
8880: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
8890: 73 73 3f 20 68 65 64 29 0a 09 09 09 20 20 20 20 ss? hed)....
88a0: 68 65 64 29 0a 09 09 20 20 20 20 20 20 20 28 68 hed)... (h
88b0: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
88c0: 0a 09 09 09 65 78 6e 0a 09 09 09 23 66 0a 09 09 ....exn....#f...
88d0: 09 28 63 72 65 61 74 65 2d 64 69 72 65 63 74 6f .(create-directo
88e0: 72 79 20 68 65 64 20 23 74 29 29 29 29 29 0a 09 ry hed #t)))))..
88f0: 20 20 28 69 66 20 28 61 6e 64 20 28 73 74 72 69 (if (and (stri
8900: 6e 67 3f 20 72 65 73 29 0a 09 09 20 20 20 28 64 ng? res)... (d
8910: 69 72 65 63 74 6f 72 79 3f 20 72 65 73 29 29 0a irectory? res)).
8920: 09 20 20 20 20 20 20 72 65 73 0a 09 20 20 20 20 . res..
8930: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c (if (null? tal
8940: 29 0a 09 09 20 20 23 66 0a 09 09 20 20 28 6c 6f )... #f... (lo
8950: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
8960: 20 74 61 6c 29 29 29 29 29 29 29 29 0a 0a 3b 3b tal))))))))..;;
8970: 20 72 65 74 75 72 6e 20 74 68 65 20 79 6f 75 6e return the youn
8980: 67 65 73 74 20 74 69 6d 65 73 74 61 6d 70 20 2e gest timestamp .
8990: 20 66 69 6c 65 6e 61 6d 65 0a 3b 3b 0a 28 64 65 filename.;;.(de
89a0: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 fine (common:get
89b0: 2d 79 6f 75 6e 67 65 73 74 20 67 6c 6f 62 2d 6c -youngest glob-l
89c0: 69 73 74 29 0a 20 20 28 6c 65 74 20 28 28 61 6c ist). (let ((al
89d0: 6c 2d 66 69 6c 65 73 20 28 61 70 70 6c 79 20 61 l-files (apply a
89e0: 70 70 65 6e 64 0a 09 09 09 20 20 28 6d 61 70 20 ppend.... (map
89f0: 28 6c 61 6d 62 64 61 20 28 70 61 74 74 29 0a 09 (lambda (patt)..
8a00: 09 09 09 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ... (handle-exce
8a10: 70 74 69 6f 6e 73 0a 09 09 09 09 20 20 20 20 20 ptions.....
8a20: 65 78 6e 0a 09 09 09 09 20 20 20 20 20 27 28 29 exn..... '()
8a30: 0a 09 09 09 09 20 20 20 28 67 6c 6f 62 20 70 61 ..... (glob pa
8a40: 74 74 29 29 29 0a 09 09 09 20 20 20 20 20 20 20 tt)))....
8a50: 67 6c 6f 62 2d 6c 69 73 74 29 29 29 29 0a 20 20 glob-list)))).
8a60: 20 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 (fold (lambda
8a70: 28 66 6e 61 6d 65 20 72 65 73 29 0a 09 20 20 20 (fname res)..
8a80: 20 28 6c 65 74 20 28 28 6c 61 73 74 2d 6d 6f 64 (let ((last-mod
8a90: 20 28 63 61 72 20 72 65 73 29 29 0a 09 09 20 20 (car res))...
8aa0: 28 63 75 72 6d 6f 64 20 20 20 28 68 61 6e 64 6c (curmod (handl
8ab0: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 09 09 e-exceptions....
8ac0: 09 65 78 6e 0a 09 09 09 09 30 0a 09 09 09 20 20 .exn.....0....
8ad0: 20 20 20 20 28 66 69 6c 65 2d 6d 6f 64 69 66 69 (file-modifi
8ae0: 63 61 74 69 6f 6e 2d 74 69 6d 65 20 66 6e 61 6d cation-time fnam
8af0: 65 29 29 29 29 0a 09 20 20 20 20 20 20 28 69 66 e)))).. (if
8b00: 20 28 3e 20 63 75 72 6d 6f 64 20 6c 61 73 74 2d (> curmod last-
8b10: 6d 6f 64 29 0a 09 09 20 20 28 6c 69 73 74 20 63 mod)... (list c
8b20: 75 72 6d 6f 64 20 66 6e 61 6d 65 29 0a 09 09 20 urmod fname)...
8b30: 20 72 65 73 29 29 29 0a 09 20 20 27 28 30 20 22 res))).. '(0 "
8b40: 6e 2f 61 22 29 0a 09 20 20 61 6c 6c 2d 66 69 6c n/a").. all-fil
8b50: 65 73 29 29 29 0a 0a 3b 3b 20 75 73 65 20 62 61 es)))..;; use ba
8b60: 73 68 20 74 6f 20 65 78 70 61 6e 64 20 61 20 67 sh to expand a g
8b70: 6c 6f 62 2e 20 44 6f 65 73 20 4e 4f 54 20 68 61 lob. Does NOT ha
8b80: 6e 64 6c 65 20 70 61 74 68 73 20 77 69 74 68 20 ndle paths with
8b90: 73 70 61 63 65 73 21 0a 3b 3b 0a 28 64 65 66 69 spaces!.;;.(defi
8ba0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 62 61 73 68 2d ne (common:bash-
8bb0: 67 6c 6f 62 20 69 6e 73 74 72 29 0a 20 20 28 73 glob instr). (s
8bc0: 74 72 69 6e 67 2d 73 70 6c 69 74 0a 20 20 20 28 tring-split. (
8bd0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
8be0: 70 69 70 65 0a 20 20 20 20 20 20 20 28 63 6f 6e pipe. (con
8bf0: 63 20 22 2f 62 69 6e 2f 62 61 73 68 20 2d 63 20 c "/bin/bash -c
8c00: 5c 22 65 63 68 6f 20 22 20 69 6e 73 74 72 20 22 \"echo " instr "
8c10: 5c 22 22 29 0a 20 20 20 20 20 72 65 61 64 2d 6c \""). read-l
8c20: 69 6e 65 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d ine))). .;;====
8c30: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c40: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c50: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c60: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8c70: 3d 3d 0a 3b 3b 20 54 20 41 20 52 20 47 20 45 20 ==.;; T A R G E
8c80: 54 20 53 20 20 2c 20 20 20 53 20 54 20 41 20 54 T S , S T A T
8c90: 20 45 20 2c 20 20 20 53 20 54 20 41 20 54 20 55 E , S T A T U
8ca0: 20 53 20 2c 20 20 20 0a 3b 3b 20 20 20 20 20 20 S , .;;
8cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 52 20 R
8cc0: 55 20 4e 20 4e 20 41 20 4d 20 45 20 20 20 20 41 U N N A M E A
8cd0: 20 4e 20 44 20 20 20 54 20 45 20 53 20 54 20 50 N D T E S T P
8ce0: 20 41 20 54 20 54 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d A T T.;;=======
8cf0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d00: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d10: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
8d20: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
8d30: 0a 3b 3b 20 28 6d 61 70 20 70 72 69 6e 74 20 28 .;; (map print (
8d40: 6d 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 map car (hash-ta
8d50: 62 6c 65 2d 3e 61 6c 69 73 74 20 28 72 65 61 64 ble->alist (read
8d60: 2d 63 6f 6e 66 69 67 20 22 72 75 6e 63 6f 6e 66 -config "runconf
8d70: 69 67 73 2e 63 6f 6e 66 69 67 22 20 23 66 20 23 igs.config" #f #
8d80: 74 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 t)))).;;.(define
8d90: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 72 75 6e (common:get-run
8da0: 63 6f 6e 66 69 67 2d 74 61 72 67 65 74 73 20 23 config-targets #
8db0: 21 6b 65 79 20 28 63 6f 6e 66 69 67 66 20 23 66 !key (configf #f
8dc0: 29 29 0a 20 20 28 6c 65 74 20 28 28 74 61 72 67 )). (let ((targ
8dd0: 73 20 20 20 20 20 20 20 28 73 6f 72 74 20 28 6d s (sort (m
8de0: 61 70 20 63 61 72 20 28 68 61 73 68 2d 74 61 62 ap car (hash-tab
8df0: 6c 65 2d 3e 61 6c 69 73 74 0a 09 09 09 09 20 20 le->alist.....
8e00: 20 20 20 28 6f 72 20 63 6f 6e 66 69 67 66 20 3b (or configf ;
8e10: 3b 20 4e 4f 54 45 3a 20 54 68 65 72 65 20 69 73 ; NOTE: There is
8e20: 20 6e 6f 20 76 61 6c 75 65 20 69 6e 20 75 73 69 no value in usi
8e30: 6e 67 20 72 75 6e 63 6f 6e 66 69 67 3a 72 65 61 ng runconfig:rea
8e40: 64 20 68 65 72 65 2e 0a 09 09 09 09 09 20 28 72 d here....... (r
8e50: 65 61 64 2d 63 6f 6e 66 69 67 20 28 63 6f 6e 63 ead-config (conc
8e60: 20 2a 74 6f 70 70 61 74 68 2a 20 22 2f 72 75 6e *toppath* "/run
8e70: 63 6f 6e 66 69 67 73 2e 63 6f 6e 66 69 67 22 29 configs.config")
8e80: 0a 09 09 09 09 09 09 20 20 20 20 20 20 23 66 20 ....... #f
8e90: 23 74 29 0a 09 09 09 09 09 20 28 6d 61 6b 65 2d #t)...... (make-
8ea0: 68 61 73 68 2d 74 61 62 6c 65 29 29 29 29 0a 09 hash-table))))..
8eb0: 09 09 20 20 20 73 74 72 69 6e 67 3c 3f 29 29 0a .. string<?)).
8ec0: 09 28 74 61 72 67 65 74 2d 70 61 74 74 20 28 61 .(target-patt (a
8ed0: 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 rgs:get-arg "-ta
8ee0: 72 67 65 74 22 29 29 29 0a 20 20 20 20 28 69 66 rget"))). (if
8ef0: 20 74 61 72 67 65 74 2d 70 61 74 74 0a 09 28 66 target-patt..(f
8f00: 69 6c 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 ilter (lambda (x
8f10: 29 0a 09 09 20 20 28 70 61 74 74 2d 6c 69 73 74 )... (patt-list
8f20: 2d 6d 61 74 63 68 20 78 20 74 61 72 67 65 74 2d -match x target-
8f30: 70 61 74 74 29 29 0a 09 09 74 61 72 67 73 29 0a patt))...targs).
8f40: 09 74 61 72 67 73 29 29 29 0a 0a 3b 3b 20 4c 6f .targs)))..;; Lo
8f50: 6f 6b 75 70 20 61 20 76 61 6c 75 65 20 69 6e 20 okup a value in
8f60: 72 75 6e 63 6f 6e 66 69 67 73 20 62 61 73 65 64 runconfigs based
8f70: 20 6f 6e 20 2d 72 65 71 74 61 72 67 20 6f 72 20 on -reqtarg or
8f80: 2d 74 61 72 67 65 74 0a 3b 3b 20 0a 28 64 65 66 -target.;; .(def
8f90: 69 6e 65 20 28 72 75 6e 63 6f 6e 66 69 67 73 2d ine (runconfigs-
8fa0: 67 65 74 20 63 6f 6e 66 69 67 20 76 61 72 29 0a get config var).
8fb0: 20 20 28 6c 65 74 20 28 28 74 61 72 67 20 28 63 (let ((targ (c
8fc0: 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 ommon:args-get-t
8fd0: 61 72 67 65 74 29 29 29 20 3b 3b 20 28 6f 72 20 arget))) ;; (or
8fe0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d (args:get-arg "-
8ff0: 72 65 71 74 61 72 67 22 29 28 61 72 67 73 3a 67 reqtarg")(args:g
9000: 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 74 22 et-arg "-target"
9010: 29 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 41 52 )(getenv "MT_TAR
9020: 47 45 54 22 29 29 29 29 0a 20 20 20 20 28 69 66 GET")))). (if
9030: 20 74 61 72 67 0a 09 28 6f 72 20 28 63 6f 6e 66 targ..(or (conf
9040: 69 67 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 igf:lookup confi
9050: 67 20 74 61 72 67 20 76 61 72 29 0a 09 20 20 20 g targ var)..
9060: 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
9070: 20 63 6f 6e 66 69 67 20 22 64 65 66 61 75 6c 74 config "default
9080: 22 20 76 61 72 29 29 0a 09 28 63 6f 6e 66 69 67 " var))..(config
9090: 66 3a 6c 6f 6f 6b 75 70 20 63 6f 6e 66 69 67 20 f:lookup config
90a0: 22 64 65 66 61 75 6c 74 22 20 76 61 72 29 29 29 "default" var)))
90b0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
90c0: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 73 74 61 74 on:args-get-stat
90d0: 65 29 0a 20 20 28 6f 72 20 28 61 72 67 73 3a 67 e). (or (args:g
90e0: 65 74 2d 61 72 67 20 22 2d 73 74 61 74 65 22 29 et-arg "-state")
90f0: 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 3a (args:get-arg ":
9100: 73 74 61 74 65 22 29 29 29 0a 0a 28 64 65 66 69 state")))..(defi
9110: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d ne (common:args-
9120: 67 65 74 2d 73 74 61 74 75 73 29 0a 20 20 28 6f get-status). (o
9130: 72 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 r (args:get-arg
9140: 22 2d 73 74 61 74 75 73 22 29 28 61 72 67 73 3a "-status")(args:
9150: 67 65 74 2d 61 72 67 20 22 3a 73 74 61 74 75 73 get-arg ":status
9160: 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ")))..(define (c
9170: 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 ommon:args-get-t
9180: 65 73 74 70 61 74 74 20 72 63 6f 6e 66 29 0a 20 estpatt rconf).
9190: 20 28 6c 65 74 2a 20 28 3b 3b 20 28 74 61 67 65 (let* (;; (tage
91a0: 78 70 72 20 20 20 20 20 20 20 28 61 72 67 73 3a xpr (args:
91b0: 67 65 74 2d 61 72 67 20 22 2d 74 61 67 65 78 70 get-arg "-tagexp
91c0: 72 22 29 29 0a 20 20 20 20 20 20 20 20 20 3b 3b r")). ;;
91d0: 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 20 (tags-testpatt
91e0: 28 69 66 20 74 61 67 65 78 70 72 20 28 73 74 72 (if tagexpr (str
91f0: 69 6e 67 2d 6a 6f 69 6e 20 28 72 75 6e 73 3a 67 ing-join (runs:g
9200: 65 74 2d 74 65 73 74 73 2d 6d 61 74 63 68 69 6e et-tests-matchin
9210: 67 2d 74 61 67 73 20 74 61 67 65 78 70 72 29 20 g-tags tagexpr)
9220: 22 2c 22 29 20 23 66 29 29 0a 20 20 20 20 20 20 ",") #f)).
9230: 20 20 20 28 74 65 73 74 70 61 74 74 2d 6b 65 79 (testpatt-key
9240: 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 74 2d (if (args:get-
9250: 61 72 67 20 22 2d 2d 6d 6f 64 65 70 61 74 74 22 arg "--modepatt"
9260: 29 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ) (args:get-arg
9270: 22 2d 2d 6d 6f 64 65 70 61 74 74 22 29 20 22 54 "--modepatt") "T
9280: 45 53 54 50 41 54 54 22 29 29 0a 20 20 20 20 20 ESTPATT")).
9290: 20 20 20 20 28 61 72 67 73 2d 74 65 73 74 70 61 (args-testpa
92a0: 74 74 20 28 6f 72 20 28 61 72 67 73 3a 67 65 74 tt (or (args:get
92b0: 2d 61 72 67 20 22 2d 74 65 73 74 70 61 74 74 22 -arg "-testpatt"
92c0: 29 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 20 ) (args:get-arg
92d0: 22 2d 72 75 6e 74 65 73 74 73 22 29 20 22 25 22 "-runtests") "%"
92e0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 74 65 )). (rte
92f0: 73 74 70 61 74 74 20 20 20 20 20 28 69 66 20 72 stpatt (if r
9300: 63 6f 6e 66 20 28 72 75 6e 63 6f 6e 66 69 67 73 conf (runconfigs
9310: 2d 67 65 74 20 72 63 6f 6e 66 20 74 65 73 74 70 -get rconf testp
9320: 61 74 74 2d 6b 65 79 29 20 23 66 29 29 29 0a 20 att-key) #f))).
9330: 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 28 28 (cond. ((
9340: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 2d args:get-arg "--
9350: 6d 6f 64 65 70 61 74 74 22 29 20 3b 3b 20 6d 6f modepatt") ;; mo
9360: 64 65 70 61 74 74 20 69 73 20 61 20 66 6f 72 63 depatt is a forc
9370: 65 64 20 73 65 74 74 69 6e 67 2c 20 77 68 65 6e ed setting, when
9380: 20 73 65 74 20 69 74 20 4d 55 53 54 20 72 65 66 set it MUST ref
9390: 65 72 20 74 6f 20 61 6e 20 65 78 69 73 74 69 6e er to an existin
93a0: 67 20 50 41 54 54 20 69 6e 20 74 68 65 20 72 75 g PATT in the ru
93b0: 6e 63 6f 6e 66 69 67 0a 20 20 20 20 20 20 28 69 nconfig. (i
93c0: 66 20 72 63 6f 6e 66 0a 09 20 20 28 72 75 6e 63 f rconf.. (runc
93d0: 6f 6e 66 69 67 73 2d 67 65 74 20 72 63 6f 6e 66 onfigs-get rconf
93e0: 20 74 65 73 74 70 61 74 74 2d 6b 65 79 29 0a 09 testpatt-key)..
93f0: 20 20 23 66 29 29 20 20 20 20 20 3b 3b 20 57 65 #f)) ;; We
9400: 20 64 6f 20 4e 4f 54 20 66 61 6c 6c 20 62 61 63 do NOT fall bac
9410: 6b 20 74 6f 20 22 25 22 0a 20 20 20 20 20 3b 3b k to "%". ;;
9420: 20 28 74 61 67 73 2d 74 65 73 74 70 61 74 74 0a (tags-testpatt.
9430: 20 20 20 20 20 3b 3b 20 20 28 64 65 62 75 67 3a ;; (debug:
9440: 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 print-info 0 *de
9450: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
9460: 22 2d 74 61 67 65 78 70 72 20 22 74 61 67 65 78 "-tagexpr "tagex
9470: 70 72 22 20 73 65 6c 65 63 74 73 20 74 65 73 74 pr" selects test
9480: 70 61 74 74 20 22 74 61 67 73 2d 74 65 73 74 70 patt "tags-testp
9490: 61 74 74 29 0a 20 20 20 20 20 3b 3b 20 20 74 61 att). ;; ta
94a0: 67 73 2d 74 65 73 74 70 61 74 74 29 0a 20 20 20 gs-testpatt).
94b0: 20 20 28 28 61 6e 64 20 28 65 71 75 61 6c 3f 20 ((and (equal?
94c0: 61 72 67 73 2d 74 65 73 74 70 61 74 74 20 22 25 args-testpatt "%
94d0: 22 29 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 ") rtestpatt).
94e0: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
94f0: 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 -info 0 *default
9500: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 74 65 73 74 -log-port* "test
9510: 70 61 74 74 20 64 65 66 69 6e 65 64 20 69 6e 20 patt defined in
9520: 22 74 65 73 74 70 61 74 74 2d 6b 65 79 22 20 66 "testpatt-key" f
9530: 72 6f 6d 20 72 75 6e 63 6f 6e 66 69 67 73 3a 20 rom runconfigs:
9540: 22 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 20 " rtestpatt).
9550: 20 20 20 72 74 65 73 74 70 61 74 74 29 0a 20 20 rtestpatt).
9560: 20 20 20 28 65 6c 73 65 20 61 72 67 73 2d 74 65 (else args-te
9570: 73 74 70 61 74 74 29 29 29 29 0a 0a 0a 0a 28 64 stpatt))))....(d
9580: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 61 efine (common:fa
9590: 6c 73 65 2d 6f 6e 2d 65 78 63 65 70 74 69 6f 6e lse-on-exception
95a0: 20 74 68 75 6e 6b 20 23 21 6b 65 79 20 28 6d 65 thunk #!key (me
95b0: 73 73 61 67 65 20 23 66 29 29 0a 20 20 28 68 61 ssage #f)). (ha
95c0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 20 ndle-exceptions
95d0: 65 78 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 exn.
95e0: 20 20 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a (begin.
95f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9600: 20 20 20 20 20 20 20 28 69 66 20 6d 65 73 73 61 (if messa
9610: 67 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 ge.
9620: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 64 (d
9630: 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 ebug:print-info
9640: 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 0 *default-log-p
9650: 6f 72 74 2a 20 6d 65 73 73 61 67 65 29 29 0a 20 ort* message)).
9660: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
9670: 20 20 20 20 20 20 23 66 29 20 28 74 68 75 6e 6b #f) (thunk
9680: 29 20 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ) ))..(define (c
9690: 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 69 73 74 ommon:file-exist
96a0: 73 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 20 23 s? path-string #
96b0: 21 6b 65 79 20 28 71 75 69 65 74 2d 6d 6f 64 65 !key (quiet-mode
96c0: 20 23 66 29 29 0a 20 20 3b 3b 20 74 68 69 73 20 #f)). ;; this
96d0: 61 76 6f 69 64 73 20 73 74 61 63 6b 20 64 75 6d avoids stack dum
96e0: 70 73 20 69 6e 20 74 68 65 20 63 61 73 65 20 77 ps in the case w
96f0: 68 65 72 65 20 0a 0a 20 20 3b 3b 3b 3b 20 54 4f here .. ;;;; TO
9700: 44 4f 3a 20 63 61 74 63 68 20 70 65 72 6d 69 73 DO: catch permis
9710: 73 69 6f 6e 20 64 65 6e 69 65 64 20 65 78 63 65 sion denied exce
9720: 70 74 69 6f 6e 73 20 61 6e 64 20 65 6d 69 74 20 ptions and emit
9730: 61 70 70 72 6f 70 72 69 61 74 65 20 77 61 72 6e appropriate warn
9740: 69 6e 67 73 2c 20 65 67 3a 20 20 73 79 73 74 65 ings, eg: syste
9750: 6d 20 65 72 72 6f 72 20 77 68 69 6c 65 20 74 72 m error while tr
9760: 79 69 6e 67 20 74 6f 20 61 63 63 65 73 73 20 66 ying to access f
9770: 69 6c 65 3a 20 22 2f 6e 66 73 2f 70 64 78 2f 64 ile: "/nfs/pdx/d
9780: 69 73 6b 73 2f 69 63 66 5f 65 6e 76 5f 64 69 73 isks/icf_env_dis
9790: 6b 30 30 31 2f 62 6a 62 61 72 63 6c 61 2f 67 77 k001/bjbarcla/gw
97a0: 61 2f 69 73 73 75 65 73 2f 6d 74 64 65 76 2f 72 a/issues/mtdev/r
97b0: 61 6e 64 79 2d 73 6c 6f 77 2f 72 65 70 72 6f 64 andy-slow/reprod
97c0: 75 63 65 2f 71 2e 2e 2e 0a 20 20 28 63 6f 6d 6d uce/q.... (comm
97d0: 6f 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 78 63 65 on:false-on-exce
97e0: 70 74 69 6f 6e 0a 20 20 20 28 6c 61 6d 62 64 61 ption. (lambda
97f0: 20 28 29 20 28 66 69 6c 65 2d 65 78 69 73 74 73 () (file-exists
9800: 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 29 29 0a ? path-string)).
9810: 20 20 20 6d 65 73 73 61 67 65 3a 20 28 69 66 20 message: (if
9820: 71 75 69 65 74 2d 6d 6f 64 65 0a 09 09 23 66 0a quiet-mode...#f.
9830: 09 09 28 63 6f 6e 63 20 22 55 6e 61 62 6c 65 20 ..(conc "Unable
9840: 74 6f 20 61 63 63 65 73 73 20 70 61 74 68 3a 20 to access path:
9850: 22 20 70 61 74 68 2d 73 74 72 69 6e 67 29 29 29 " path-string)))
9860: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
9870: 6f 6e 3a 64 69 72 65 63 74 6f 72 79 2d 65 78 69 on:directory-exi
9880: 73 74 73 3f 20 70 61 74 68 2d 73 74 72 69 6e 67 sts? path-string
9890: 20 23 21 6b 65 79 20 28 71 75 69 65 74 2d 6d 6f #!key (quiet-mo
98a0: 64 65 20 23 66 29 29 0a 20 20 3b 3b 3b 3b 20 54 de #f)). ;;;; T
98b0: 4f 44 4f 3a 20 63 61 74 63 68 20 70 65 72 6d 69 ODO: catch permi
98c0: 73 73 69 6f 6e 20 64 65 6e 69 65 64 20 65 78 63 ssion denied exc
98d0: 65 70 74 69 6f 6e 73 20 61 6e 64 20 65 6d 69 74 eptions and emit
98e0: 20 61 70 70 72 6f 70 72 69 61 74 65 20 77 61 72 appropriate war
98f0: 6e 69 6e 67 73 2c 20 65 67 3a 20 20 73 79 73 74 nings, eg: syst
9900: 65 6d 20 65 72 72 6f 72 20 77 68 69 6c 65 20 74 em error while t
9910: 72 79 69 6e 67 20 74 6f 20 61 63 63 65 73 73 20 rying to access
9920: 66 69 6c 65 3a 20 22 2f 6e 66 73 2f 70 64 78 2f file: "/nfs/pdx/
9930: 64 69 73 6b 73 2f 69 63 66 5f 65 6e 76 5f 64 69 disks/icf_env_di
9940: 73 6b 30 30 31 2f 62 6a 62 61 72 63 6c 61 2f 67 sk001/bjbarcla/g
9950: 77 61 2f 69 73 73 75 65 73 2f 6d 74 64 65 76 2f wa/issues/mtdev/
9960: 72 61 6e 64 79 2d 73 6c 6f 77 2f 72 65 70 72 6f randy-slow/repro
9970: 64 75 63 65 2f 71 2e 2e 2e 0a 20 20 28 63 6f 6d duce/q.... (com
9980: 6d 6f 6e 3a 66 61 6c 73 65 2d 6f 6e 2d 65 78 63 mon:false-on-exc
9990: 65 70 74 69 6f 6e 0a 20 20 20 28 6c 61 6d 62 64 eption. (lambd
99a0: 61 20 28 29 20 28 64 69 72 65 63 74 6f 72 79 2d a () (directory-
99b0: 65 78 69 73 74 73 3f 20 70 61 74 68 2d 73 74 72 exists? path-str
99c0: 69 6e 67 29 29 0a 20 20 20 6d 65 73 73 61 67 65 ing)). message
99d0: 3a 20 28 69 66 20 71 75 69 65 74 2d 6d 6f 64 65 : (if quiet-mode
99e0: 0a 09 09 23 66 0a 09 09 28 63 6f 6e 63 20 22 55 ...#f...(conc "U
99f0: 6e 61 62 6c 65 20 74 6f 20 61 63 63 65 73 73 20 nable to access
9a00: 70 61 74 68 3a 20 22 20 70 61 74 68 2d 73 74 72 path: " path-str
9a10: 69 6e 67 29 29 29 29 0a 0a 3b 3b 20 64 6f 65 73 ing))))..;; does
9a20: 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 20 65 the directory e
9a30: 78 69 73 74 20 61 6e 64 20 64 6f 20 77 65 20 68 xist and do we h
9a40: 61 76 65 20 77 72 69 74 65 20 61 63 63 65 73 73 ave write access
9a50: 3f 0a 3b 3b 0a 3b 3b 20 20 20 20 72 65 74 75 72 ?.;;.;; retur
9a60: 6e 73 20 74 68 65 20 64 69 72 65 63 74 6f 72 79 ns the directory
9a70: 20 6f 72 20 23 66 0a 3b 3b 0a 28 64 65 66 69 6e or #f.;;.(defin
9a80: 65 20 28 63 6f 6d 6d 6f 6e 3a 64 69 72 65 63 74 e (common:direct
9a90: 6f 72 79 2d 77 72 69 74 61 62 6c 65 3f 20 70 61 ory-writable? pa
9aa0: 74 68 2d 73 74 72 69 6e 67 29 0a 20 20 28 68 61 th-string). (ha
9ab0: 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a ndle-exceptions.
9ac0: 20 20 20 65 78 6e 0a 20 20 20 23 66 0a 20 20 20 exn. #f.
9ad0: 28 69 66 20 28 61 6e 64 20 28 64 69 72 65 63 74 (if (and (direct
9ae0: 6f 72 79 2d 65 78 69 73 74 73 3f 20 70 61 74 68 ory-exists? path
9af0: 2d 73 74 72 69 6e 67 29 0a 20 20 20 20 20 20 20 -string).
9b00: 20 20 20 20 20 28 66 69 6c 65 2d 77 72 69 74 65 (file-write
9b10: 2d 61 63 63 65 73 73 3f 20 70 61 74 68 2d 73 74 -access? path-st
9b20: 72 69 6e 67 29 29 0a 20 20 20 20 20 20 20 70 61 ring)). pa
9b30: 74 68 2d 73 74 72 69 6e 67 0a 20 20 20 20 20 20 th-string.
9b40: 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f)))..(define
9b50: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 69 6e 6b (common:get-link
9b60: 74 72 65 65 29 0a 20 20 28 6f 72 20 28 67 65 74 tree). (or (get
9b70: 65 6e 76 20 22 4d 54 5f 4c 49 4e 4b 54 52 45 45 env "MT_LINKTREE
9b80: 22 29 0a 20 20 20 20 20 20 28 69 66 20 2a 63 6f "). (if *co
9b90: 6e 66 69 67 64 61 74 2a 0a 09 20 20 28 63 6f 6e nfigdat*.. (con
9ba0: 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e figf:lookup *con
9bb0: 66 69 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 figdat* "setup"
9bc0: 22 6c 69 6e 6b 74 72 65 65 22 29 0a 09 20 20 28 "linktree").. (
9bd0: 69 66 20 2a 74 6f 70 70 61 74 68 2a 0a 09 20 20 if *toppath*..
9be0: 20 20 20 20 28 63 6f 6e 63 20 2a 74 6f 70 70 61 (conc *toppa
9bf0: 74 68 2a 20 22 2f 6c 74 22 29 0a 09 20 20 20 20 th* "/lt")..
9c00: 20 20 23 66 29 29 29 29 0a 0a 28 64 65 66 69 6e #f))))..(defin
9c10: 65 20 28 63 6f 6d 6d 6f 6e 3a 61 72 67 73 2d 67 e (common:args-g
9c20: 65 74 2d 72 75 6e 6e 61 6d 65 29 0a 20 20 28 6c et-runname). (l
9c30: 65 74 20 28 28 72 65 73 20 28 6f 72 20 28 61 72 et ((res (or (ar
9c40: 67 73 3a 67 65 74 2d 61 72 67 20 22 2d 72 75 6e gs:get-arg "-run
9c50: 6e 61 6d 65 22 29 0a 09 09 20 28 61 72 67 73 3a name")... (args:
9c60: 67 65 74 2d 61 72 67 20 22 3a 72 75 6e 6e 61 6d get-arg ":runnam
9c70: 65 22 29 0a 09 09 20 28 67 65 74 65 6e 76 20 22 e")... (getenv "
9c80: 4d 54 5f 52 55 4e 4e 41 4d 45 22 29 29 29 29 0a MT_RUNNAME")))).
9c90: 20 20 20 20 3b 3b 20 28 69 66 20 72 65 73 20 28 ;; (if res (
9ca0: 73 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d set-environment-
9cb0: 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 52 55 4e variable "MT_RUN
9cc0: 4e 41 4d 45 22 20 72 65 73 29 29 20 3b 3b 20 6e NAME" res)) ;; n
9cd0: 6f 74 20 73 75 72 65 20 69 66 20 74 68 69 73 20 ot sure if this
9ce0: 69 73 20 61 20 67 6f 6f 64 20 69 64 65 61 2e 20 is a good idea.
9cf0: 73 69 64 65 20 65 66 66 65 63 74 20 61 6e 64 20 side effect and
9d00: 61 6c 6c 20 2e 2e 2e 0a 20 20 20 20 72 65 73 29 all .... res)
9d10: 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
9d20: 6f 6e 3a 61 72 67 73 2d 67 65 74 2d 74 61 72 67 on:args-get-targ
9d30: 65 74 20 23 21 6b 65 79 20 28 73 70 6c 69 74 20 et #!key (split
9d40: 23 66 29 28 65 78 69 74 2d 69 66 2d 62 61 64 20 #f)(exit-if-bad
9d50: 23 66 29 29 0a 20 20 28 6c 65 74 2a 20 28 28 6b #f)). (let* ((k
9d60: 65 79 73 20 20 20 20 28 69 66 20 28 68 61 73 68 eys (if (hash
9d70: 2d 74 61 62 6c 65 3f 20 2a 63 6f 6e 66 69 67 64 -table? *configd
9d80: 61 74 2a 29 20 28 6b 65 79 73 3a 63 6f 6e 66 69 at*) (keys:confi
9d90: 67 2d 67 65 74 2d 66 69 65 6c 64 73 20 2a 63 6f g-get-fields *co
9da0: 6e 66 69 67 64 61 74 2a 29 20 27 28 29 29 29 0a nfigdat*) '())).
9db0: 09 20 28 6e 75 6d 6b 65 79 73 20 28 6c 65 6e 67 . (numkeys (leng
9dc0: 74 68 20 6b 65 79 73 29 29 0a 09 20 28 74 61 72 th keys)).. (tar
9dd0: 67 65 74 20 20 28 6f 72 20 28 61 72 67 73 3a 67 get (or (args:g
9de0: 65 74 2d 61 72 67 20 22 2d 72 65 71 74 61 72 67 et-arg "-reqtarg
9df0: 22 29 0a 09 09 20 20 20 20 20 20 28 61 72 67 73 ")... (args
9e00: 3a 67 65 74 2d 61 72 67 20 22 2d 74 61 72 67 65 :get-arg "-targe
9e10: 74 22 29 0a 09 09 20 20 20 20 20 20 28 67 65 74 t")... (get
9e20: 65 6e 76 20 22 4d 54 5f 54 41 52 47 45 54 22 29 env "MT_TARGET")
9e30: 29 29 0a 09 20 28 74 6c 69 73 74 20 20 20 28 69 )).. (tlist (i
9e40: 66 20 74 61 72 67 65 74 20 28 73 74 72 69 6e 67 f target (string
9e50: 2d 73 70 6c 69 74 20 74 61 72 67 65 74 20 22 2f -split target "/
9e60: 22 20 23 74 29 20 27 28 29 29 29 0a 09 20 28 76 " #t) '())).. (v
9e70: 61 6c 69 64 20 20 20 28 69 66 20 74 61 72 67 65 alid (if targe
9e80: 74 0a 09 09 20 20 20 20 20 20 28 6f 72 20 28 6e t... (or (n
9e90: 75 6c 6c 3f 20 6b 65 79 73 29 20 3b 3b 20 70 72 ull? keys) ;; pr
9ea0: 6f 62 61 62 6c 79 20 64 6f 6e 27 74 20 6b 6e 6f obably don't kno
9eb0: 77 20 6f 75 72 20 6b 65 79 73 20 79 65 74 0a 09 w our keys yet..
9ec0: 09 09 20 20 28 61 6e 64 20 28 6e 6f 74 20 28 6e .. (and (not (n
9ed0: 75 6c 6c 3f 20 74 6c 69 73 74 29 29 0a 09 09 09 ull? tlist))....
9ee0: 20 20 20 20 20 20 20 28 65 71 3f 20 6e 75 6d 6b (eq? numk
9ef0: 65 79 73 20 28 6c 65 6e 67 74 68 20 74 6c 69 73 eys (length tlis
9f00: 74 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e t)).... (n
9f10: 75 6c 6c 3f 20 28 66 69 6c 74 65 72 20 73 74 72 ull? (filter str
9f20: 69 6e 67 2d 6e 75 6c 6c 3f 20 74 6c 69 73 74 29 ing-null? tlist)
9f30: 29 29 29 0a 09 09 20 20 20 20 20 20 23 66 29 29 )))... #f))
9f40: 29 0a 20 20 20 20 28 69 66 20 76 61 6c 69 64 0a ). (if valid.
9f50: 09 28 69 66 20 73 70 6c 69 74 0a 09 20 20 20 20 .(if split..
9f60: 74 6c 69 73 74 0a 09 20 20 20 20 74 61 72 67 65 tlist.. targe
9f70: 74 29 0a 09 28 69 66 20 74 61 72 67 65 74 0a 09 t)..(if target..
9f80: 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 (begin..
9f90: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 65 (debug:print-e
9fa0: 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c 74 2d rror 0 *default-
9fb0: 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 76 61 6c log-port* "Inval
9fc0: 69 64 20 74 61 72 67 65 74 2c 20 73 70 61 63 65 id target, space
9fd0: 73 20 6f 72 20 62 6c 61 6e 6b 73 20 6e 6f 74 20 s or blanks not
9fe0: 61 6c 6c 6f 77 65 64 20 5c 22 22 20 74 61 72 67 allowed \"" targ
9ff0: 65 74 20 22 5c 22 2c 20 74 61 72 67 65 74 20 73 et "\", target s
a000: 68 6f 75 6c 64 20 62 65 3a 20 22 20 28 73 74 72 hould be: " (str
a010: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
a020: 6b 65 79 73 20 22 2f 22 29 20 22 2c 20 68 61 76 keys "/") ", hav
a030: 65 20 22 20 74 6c 69 73 74 20 22 20 66 6f 72 20 e " tlist " for
a040: 65 6c 65 6d 65 6e 74 73 22 29 0a 09 20 20 20 20 elements")..
a050: 20 20 28 69 66 20 65 78 69 74 2d 69 66 2d 62 61 (if exit-if-ba
a060: 64 20 28 65 78 69 74 20 31 29 29 0a 09 20 20 20 d (exit 1))..
a070: 20 20 20 23 66 29 0a 09 20 20 20 20 23 66 29 29 #f).. #f))
a080: 29 29 0a 0a 3b 3b 20 6c 6f 6f 6b 69 6e 67 20 6f ))..;; looking o
a090: 6e 6c 79 20 28 61 74 20 6c 65 61 73 74 20 66 6f nly (at least fo
a0a0: 72 20 6e 6f 77 29 20 61 74 20 74 68 65 20 4d 54 r now) at the MT
a0b0: 5f 20 76 61 72 69 61 62 6c 65 73 20 63 72 61 66 _ variables craf
a0c0: 74 20 74 68 65 20 66 75 6c 6c 20 74 65 73 74 6e t the full testn
a0d0: 61 6d 65 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ame.;;.(define (
a0e0: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 66 75 6c 6c 2d common:get-full-
a0f0: 74 65 73 74 2d 6e 61 6d 65 29 0a 20 20 28 69 66 test-name). (if
a100: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 53 (getenv "MT_TES
a110: 54 5f 4e 41 4d 45 22 29 0a 20 20 20 20 20 20 28 T_NAME"). (
a120: 69 66 20 28 61 6e 64 20 28 67 65 74 65 6e 76 20 if (and (getenv
a130: 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 29 0a 20 "MT_ITEMPATH").
a140: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6e (n
a150: 6f 74 20 28 65 71 75 61 6c 3f 20 28 67 65 74 65 ot (equal? (gete
a160: 6e 76 20 22 4d 54 5f 49 54 45 4d 50 41 54 48 22 nv "MT_ITEMPATH"
a170: 29 20 22 22 29 29 29 0a 20 20 20 20 20 20 20 20 ) ""))).
a180: 20 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 54 45 (getenv "MT_TE
a190: 53 54 5f 4e 41 4d 45 22 29 0a 20 20 20 20 20 20 ST_NAME").
a1a0: 20 20 20 20 28 63 6f 6e 63 20 28 67 65 74 65 6e (conc (geten
a1b0: 76 20 22 4d 54 5f 54 45 53 54 5f 4e 41 4d 45 22 v "MT_TEST_NAME"
a1c0: 29 20 22 2f 22 20 28 67 65 74 65 6e 76 20 22 4d ) "/" (getenv "M
a1d0: 54 5f 49 54 45 4d 50 41 54 48 22 29 29 29 0a 20 T_ITEMPATH"))).
a1e0: 20 20 20 20 20 23 66 29 29 0a 0a 3b 3b 20 6c 6f #f))..;; lo
a1f0: 67 69 63 20 66 6f 72 20 67 65 74 74 69 6e 67 20 gic for getting
a200: 68 6f 6d 65 68 6f 73 74 2e 20 52 65 74 75 72 6e homehost. Return
a210: 73 20 28 68 6f 73 74 20 2e 20 61 74 2d 68 6f 6d s (host . at-hom
a220: 65 29 0a 3b 3b 20 49 46 20 2a 74 6f 70 70 61 74 e).;; IF *toppat
a230: 68 2a 20 69 73 20 6e 6f 74 20 73 65 74 2c 20 77 h* is not set, w
a240: 61 69 74 20 75 70 20 74 6f 20 66 69 76 65 20 73 ait up to five s
a250: 65 63 6f 6e 64 73 20 74 72 79 69 6e 67 20 65 76 econds trying ev
a260: 65 72 79 20 74 77 6f 20 73 65 63 6f 6e 64 73 0a ery two seconds.
a270: 3b 3b 20 28 74 68 69 73 20 69 73 20 74 6f 20 61 ;; (this is to a
a280: 63 63 6f 6d 6f 64 61 74 65 20 74 68 65 20 77 61 ccomodate the wa
a290: 74 63 68 64 6f 67 29 0a 3b 3b 0a 28 64 65 66 69 tchdog).;;.(defi
a2a0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 ne (common:get-h
a2b0: 6f 6d 65 68 6f 73 74 20 23 21 6b 65 79 20 28 74 omehost #!key (t
a2c0: 72 79 6e 75 6d 20 35 29 29 0a 20 20 3b 3b 20 63 rynum 5)). ;; c
a2d0: 61 6c 6c 65 64 20 6f 66 74 65 6e 20 65 73 70 65 alled often espe
a2e0: 63 69 61 6c 6c 79 20 61 74 20 73 74 61 72 74 20 cially at start
a2f0: 75 70 2e 20 75 73 65 20 6d 75 74 65 78 20 74 6f up. use mutex to
a300: 20 65 6c 69 6d 69 6e 61 74 65 20 63 6f 6c 6c 69 eliminate colli
a310: 73 69 6f 6e 73 0a 20 20 28 6d 75 74 65 78 2d 6c sions. (mutex-l
a320: 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d ock! *homehost-m
a330: 75 74 65 78 2a 29 0a 20 20 28 63 6f 6e 64 0a 20 utex*). (cond.
a340: 20 20 28 2a 68 6f 6d 65 2d 68 6f 73 74 2a 0a 20 (*home-host*.
a350: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
a360: 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 ! *homehost-mute
a370: 78 2a 29 0a 20 20 20 20 2a 68 6f 6d 65 2d 68 6f x*). *home-ho
a380: 73 74 2a 29 0a 20 20 20 28 28 6e 6f 74 20 2a 74 st*). ((not *t
a390: 6f 70 70 61 74 68 2a 29 0a 20 20 20 20 28 6d 75 oppath*). (mu
a3a0: 74 65 78 2d 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d tex-unlock! *hom
a3b0: 65 68 6f 73 74 2d 6d 75 74 65 78 2a 29 0a 20 20 ehost-mutex*).
a3c0: 20 20 28 6c 61 75 6e 63 68 3a 73 65 74 75 70 29 (launch:setup)
a3d0: 20 3b 3b 20 73 61 66 65 6c 79 20 6d 75 74 65 78 ;; safely mutex
a3e0: 65 64 20 6e 6f 77 0a 20 20 20 20 28 69 66 20 28 ed now. (if (
a3f0: 3e 20 74 72 79 6e 75 6d 20 30 29 0a 09 28 62 65 > trynum 0)..(be
a400: 67 69 6e 0a 09 20 20 28 74 68 72 65 61 64 2d 73 gin.. (thread-s
a410: 6c 65 65 70 21 20 32 29 0a 09 20 20 28 63 6f 6d leep! 2).. (com
a420: 6d 6f 6e 3a 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mon:get-homehost
a430: 20 74 72 79 6e 75 6d 3a 20 28 2d 20 74 72 79 6e trynum: (- tryn
a440: 75 6d 20 31 29 29 29 0a 09 23 66 29 29 0a 20 20 um 1)))..#f)).
a450: 20 28 65 6c 73 65 0a 20 20 20 20 28 6c 65 74 2a (else. (let*
a460: 20 28 28 63 75 72 72 68 6f 73 74 20 28 67 65 74 ((currhost (get
a470: 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 20 -host-name))..
a480: 20 28 62 65 73 74 61 64 72 73 20 28 73 65 72 76 (bestadrs (serv
a490: 65 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 er:get-best-gues
a4a0: 73 2d 61 64 64 72 65 73 73 20 63 75 72 72 68 6f s-address currho
a4b0: 73 74 29 29 0a 09 20 20 20 3b 3b 20 66 69 72 73 st)).. ;; firs
a4c0: 74 20 6c 6f 6f 6b 20 69 6e 20 63 6f 6e 66 69 67 t look in config
a4d0: 2c 20 74 68 65 6e 20 6c 6f 6f 6b 20 69 6e 20 66 , then look in f
a4e0: 69 6c 65 20 2e 68 6f 6d 65 68 6f 73 74 2c 20 63 ile .homehost, c
a4f0: 72 65 61 74 65 20 69 74 20 69 66 20 6e 6f 74 20 reate it if not
a500: 66 6f 75 6e 64 0a 09 20 20 20 28 68 6f 6d 65 68 found.. (homeh
a510: 6f 73 74 20 28 6f 72 20 28 63 6f 6e 66 69 67 66 ost (or (configf
a520: 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 :lookup *configd
a530: 61 74 2a 20 22 73 65 72 76 65 72 22 20 22 68 6f at* "server" "ho
a540: 6d 65 68 6f 73 74 22 20 29 0a 09 09 09 20 28 68 mehost" ).... (h
a550: 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 andle-exceptions
a560: 0a 09 09 09 20 20 20 20 20 65 78 6e 0a 09 09 09 .... exn....
a570: 20 20 20 20 20 28 69 66 20 28 3e 20 74 72 79 6e (if (> tryn
a580: 75 6d 20 30 29 0a 09 09 09 09 20 28 6c 65 74 20 um 0)..... (let
a590: 28 28 64 65 6c 61 79 2d 74 69 6d 65 20 28 2a 20 ((delay-time (*
a5a0: 28 2d 20 35 20 74 72 79 6e 75 6d 29 20 35 29 29 (- 5 trynum) 5))
a5b0: 29 0a 09 09 09 09 20 20 20 28 6d 75 74 65 78 2d )..... (mutex-
a5c0: 75 6e 6c 6f 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 unlock! *homehos
a5d0: 74 2d 6d 75 74 65 78 2a 29 0a 09 09 09 09 20 20 t-mutex*).....
a5e0: 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 (debug:print 0
a5f0: 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
a600: 74 2a 20 22 45 52 52 4f 52 3a 20 46 61 69 6c 65 t* "ERROR: Faile
a610: 64 20 74 6f 20 72 65 61 64 20 2e 68 6f 6d 65 68 d to read .homeh
a620: 6f 73 74 20 66 69 6c 65 2c 20 64 65 6c 61 79 69 ost file, delayi
a630: 6e 67 20 22 20 64 65 6c 61 79 2d 74 69 6d 65 20 ng " delay-time
a640: 22 20 73 65 63 6f 6e 64 73 20 61 6e 64 20 74 72 " seconds and tr
a650: 79 69 6e 67 20 61 67 61 69 6e 2c 20 6d 65 73 73 ying again, mess
a660: 61 67 65 3a 20 22 20 20 28 28 63 6f 6e 64 69 74 age: " ((condit
a670: 69 6f 6e 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 ion-property-acc
a680: 65 73 73 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 essor 'exn 'mess
a690: 61 67 65 29 20 65 78 6e 29 29 0a 09 09 09 09 20 age) exn)).....
a6a0: 20 20 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 (thread-sleep!
a6b0: 20 64 65 6c 61 79 2d 74 69 6d 65 29 0a 09 09 09 delay-time)....
a6c0: 09 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d . (common:get-
a6d0: 68 6f 6d 65 68 6f 73 74 20 74 72 79 6e 75 6d 3a homehost trynum:
a6e0: 20 28 2d 20 74 72 79 6e 75 6d 20 31 29 29 29 0a (- trynum 1))).
a6f0: 09 09 09 09 20 28 62 65 67 69 6e 0a 09 09 09 09 .... (begin.....
a700: 20 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b (mutex-unlock
a710: 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 ! *homehost-mute
a720: 78 2a 29 0a 09 09 09 09 20 20 20 28 64 65 62 75 x*)..... (debu
a730: 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 g:print 0 *defau
a740: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 45 52 lt-log-port* "ER
a750: 52 4f 52 3a 20 46 61 69 6c 65 64 20 74 6f 20 72 ROR: Failed to r
a760: 65 61 64 20 2e 68 6f 6d 65 68 6f 73 74 20 66 69 ead .homehost fi
a770: 6c 65 20 61 66 74 65 72 20 74 72 79 69 6e 67 20 le after trying
a780: 66 69 76 65 20 74 69 6d 65 73 2e 20 47 69 76 69 five times. Givi
a790: 6e 67 20 75 70 20 61 6e 64 20 65 78 69 74 69 6e ng up and exitin
a7a0: 67 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 20 28 g, message: " (
a7b0: 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 (condition-prope
a7c0: 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 rty-accessor 'ex
a7d0: 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 n 'message) exn)
a7e0: 29 0a 09 09 09 09 20 20 20 28 65 78 69 74 20 31 )..... (exit 1
a7f0: 29 29 29 0a 09 09 09 20 20 20 28 6c 65 74 20 28 ))).... (let (
a800: 28 68 68 66 20 28 63 6f 6e 63 20 2a 74 6f 70 70 (hhf (conc *topp
a810: 61 74 68 2a 20 22 2f 2e 68 6f 6d 65 68 6f 73 74 ath* "/.homehost
a820: 22 29 29 29 0a 09 09 09 20 20 20 20 20 28 69 66 "))).... (if
a830: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
a840: 69 73 74 73 3f 20 68 68 66 29 0a 09 09 09 09 20 ists? hhf).....
a850: 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d (with-input-from
a860: 2d 66 69 6c 65 20 68 68 66 20 72 65 61 64 2d 6c -file hhf read-l
a870: 69 6e 65 29 0a 09 09 09 09 20 28 69 66 20 28 66 ine)..... (if (f
a880: 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 73 73 ile-write-access
a890: 3f 20 2a 74 6f 70 70 61 74 68 2a 29 0a 09 09 09 ? *toppath*)....
a8a0: 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 09 09 . (begin....
a8b0: 09 20 20 20 20 20 20 20 28 77 69 74 68 2d 6f 75 . (with-ou
a8c0: 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 68 68 66 tput-to-file hhf
a8d0: 0a 09 09 09 09 09 20 28 6c 61 6d 62 64 61 20 28 ...... (lambda (
a8e0: 29 0a 09 09 09 09 09 20 20 20 28 70 72 69 6e 74 )...... (print
a8f0: 20 62 65 73 74 61 64 72 73 29 29 29 0a 09 09 09 bestadrs)))....
a900: 09 20 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 . (begin..
a910: 09 09 09 09 20 28 6d 75 74 65 78 2d 75 6e 6c 6f .... (mutex-unlo
a920: 63 6b 21 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 ck! *homehost-mu
a930: 74 65 78 2a 29 0a 09 09 09 09 09 20 28 63 61 72 tex*)...... (car
a940: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 6d (common:get-hom
a950: 65 68 6f 73 74 29 29 29 29 0a 09 09 09 09 20 20 ehost)))).....
a960: 20 20 20 23 66 29 29 29 29 29 29 0a 09 20 20 20 #f))))))..
a970: 28 61 74 2d 68 6f 6d 65 20 20 28 6f 72 20 28 65 (at-home (or (e
a980: 71 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 63 qual? homehost c
a990: 75 72 72 68 6f 73 74 29 0a 09 09 09 20 28 65 71 urrhost).... (eq
a9a0: 75 61 6c 3f 20 68 6f 6d 65 68 6f 73 74 20 62 65 ual? homehost be
a9b0: 73 74 61 64 72 73 29 29 29 29 0a 20 20 20 20 20 stadrs)))).
a9c0: 20 28 73 65 74 21 20 2a 68 6f 6d 65 2d 68 6f 73 (set! *home-hos
a9d0: 74 2a 20 28 63 6f 6e 73 20 68 6f 6d 65 68 6f 73 t* (cons homehos
a9e0: 74 20 61 74 2d 68 6f 6d 65 29 29 0a 20 20 20 20 t at-home)).
a9f0: 20 20 28 6d 75 74 65 78 2d 75 6e 6c 6f 63 6b 21 (mutex-unlock!
aa00: 20 2a 68 6f 6d 65 68 6f 73 74 2d 6d 75 74 65 78 *homehost-mutex
aa10: 2a 29 0a 20 20 20 20 20 20 2a 68 6f 6d 65 2d 68 *). *home-h
aa20: 6f 73 74 2a 29 29 29 29 0a 0a 3b 3b 20 67 65 74 ost*))))..;; get
aa30: 20 68 6f 6d 65 68 6f 73 74 20 69 6e 66 6f 20 66 homehost info f
aa40: 6f 72 20 61 20 67 69 76 65 6e 20 61 72 65 61 20 or a given area
aa50: 2d 20 62 75 74 20 6f 6e 6c 79 20 69 66 20 2e 68 - but only if .h
aa60: 6f 6d 65 68 6f 73 74 20 66 69 6c 65 20 61 6c 72 omehost file alr
aa70: 65 61 64 79 20 65 78 69 73 74 73 0a 28 64 65 66 eady exists.(def
aa80: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d 69 6e 69 ine (common:mini
aa90: 6d 61 6c 2d 67 65 74 2d 68 6f 6d 65 68 6f 73 74 mal-get-homehost
aaa0: 20 74 6f 70 70 61 74 68 29 0a 20 20 28 6c 65 74 toppath). (let
aab0: 20 28 28 68 68 2d 66 69 6c 65 20 28 63 6f 6e 63 ((hh-file (conc
aac0: 20 74 6f 70 70 61 74 68 20 22 2f 2e 68 6f 6d 65 toppath "/.home
aad0: 68 6f 73 74 22 29 29 29 0a 20 20 20 20 28 69 66 host"))). (if
aae0: 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d 65 78 (common:file-ex
aaf0: 69 73 74 73 3f 20 68 68 2d 66 69 6c 65 20 71 75 ists? hh-file qu
ab00: 69 65 74 2d 6d 6f 64 65 3a 20 23 74 29 0a 09 28 iet-mode: #t)..(
ab10: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
ab20: 66 69 6c 65 20 68 68 2d 66 69 6c 65 20 72 65 61 file hh-file rea
ab30: 64 2d 6c 69 6e 65 29 0a 09 23 66 29 29 29 0a 0a d-line)..#f)))..
ab40: 3b 3b 20 61 72 65 20 77 65 20 6f 6e 20 74 68 65 ;; are we on the
ab50: 20 67 69 76 65 6e 20 68 6f 73 74 3f 0a 28 64 65 given host?.(de
ab60: 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d fine (common:on-
ab70: 68 6f 73 74 3f 20 68 68 29 0a 20 20 28 6c 65 74 host? hh). (let
ab80: 2a 20 28 28 63 75 72 72 68 6f 73 74 20 28 67 65 * ((currhost (ge
ab90: 74 2d 68 6f 73 74 2d 6e 61 6d 65 29 29 0a 09 20 t-host-name))..
aba0: 28 62 65 73 74 61 64 72 73 20 28 73 65 72 76 65 (bestadrs (serve
abb0: 72 3a 67 65 74 2d 62 65 73 74 2d 67 75 65 73 73 r:get-best-guess
abc0: 2d 61 64 64 72 65 73 73 20 63 75 72 72 68 6f 73 -address currhos
abd0: 74 29 29 29 0a 20 20 20 20 28 6f 72 20 28 65 71 t))). (or (eq
abe0: 75 61 6c 3f 20 68 68 20 63 75 72 72 68 6f 73 74 ual? hh currhost
abf0: 29 0a 09 28 65 71 75 61 6c 3f 20 68 68 20 62 65 )..(equal? hh be
ac00: 73 74 61 64 72 73 29 29 29 29 0a 20 20 20 20 0a stadrs)))). .
ac10: 3b 3b 20 61 6d 20 49 20 6f 6e 20 74 68 65 20 68 ;; am I on the h
ac20: 6f 6d 65 68 6f 73 74 3f 0a 3b 3b 0a 28 64 65 66 omehost?.;;.(def
ac30: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6f 6e 2d 68 ine (common:on-h
ac40: 6f 6d 65 68 6f 73 74 3f 29 0a 20 20 28 6c 65 74 omehost?). (let
ac50: 20 28 28 68 68 20 28 63 6f 6d 6d 6f 6e 3a 67 65 ((hh (common:ge
ac60: 74 2d 68 6f 6d 65 68 6f 73 74 29 29 29 0a 20 20 t-homehost))).
ac70: 20 20 28 69 66 20 68 68 0a 09 28 63 64 72 20 68 (if hh..(cdr h
ac80: 68 29 0a 09 23 66 29 29 29 0a 0a 3b 3b 20 6d 69 h)..#f)))..;; mi
ac90: 6e 69 6d 61 6c 20 6c 6f 61 64 69 6e 67 20 6f 66 nimal loading of
aca0: 20 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 67 megatest.config
acb0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
acc0: 6d 6f 6e 3a 73 69 6d 70 6c 65 2d 73 65 74 75 70 mon:simple-setup
acd0: 20 74 6f 70 70 61 74 68 20 23 21 6b 65 79 20 28 toppath #!key (
ace0: 63 66 67 66 2d 6f 76 72 64 20 23 66 29 29 0a 20 cfgf-ovrd #f)).
acf0: 20 28 6c 65 74 2a 20 28 28 6d 74 63 6f 6e 66 69 (let* ((mtconfi
ad00: 67 66 20 28 6f 72 20 63 66 67 66 2d 6f 76 72 64 gf (or cfgf-ovrd
ad10: 20 22 6d 65 67 61 74 65 73 74 2e 63 6f 6e 66 69 "megatest.confi
ad20: 67 22 29 29 0a 09 20 28 6d 74 63 6f 6e 66 64 61 g")).. (mtconfda
ad30: 74 20 28 66 69 6e 64 2d 61 6e 64 2d 72 65 61 64 t (find-and-read
ad40: 2d 63 6f 6e 66 69 67 0a 09 09 20 20 20 20 20 6d -config... m
ad50: 74 63 6f 6e 66 69 67 66 0a 09 09 20 20 20 20 20 tconfigf...
ad60: 3b 3b 20 65 6e 76 69 72 6f 6e 2d 70 61 74 74 3a ;; environ-patt:
ad70: 20 22 65 6e 76 2d 6f 76 65 72 72 69 64 65 22 0a "env-override".
ad80: 09 09 20 20 20 20 20 67 69 76 65 6e 2d 74 6f 70 .. given-top
ad90: 70 61 74 68 3a 20 74 6f 70 70 61 74 68 0a 09 09 path: toppath...
ada0: 20 20 20 20 20 3b 3b 20 70 61 74 68 65 6e 76 76 ;; pathenvv
adb0: 61 72 3a 20 22 4d 54 5f 52 55 4e 5f 41 52 45 41 ar: "MT_RUN_AREA
adc0: 5f 48 4f 4d 45 22 0a 09 09 20 20 20 20 20 29 29 _HOME"... ))
add0: 0a 09 20 28 6d 74 63 6f 6e 66 20 20 20 20 28 69 .. (mtconf (i
ade0: 66 20 6d 74 63 6f 6e 66 64 61 74 20 28 63 61 72 f mtconfdat (car
adf0: 20 6d 74 63 6f 6e 66 64 61 74 29 20 23 66 29 29 mtconfdat) #f))
ae00: 29 0a 20 20 20 20 28 69 66 20 6d 74 63 6f 6e 66 ). (if mtconf
ae10: 0a 09 28 63 6f 6e 66 69 67 66 3a 73 65 63 74 69 ..(configf:secti
ae20: 6f 6e 2d 76 61 72 2d 73 65 74 21 20 6d 74 63 6f on-var-set! mtco
ae30: 6e 66 20 22 64 79 6e 64 61 74 22 20 22 74 6f 70 nf "dyndat" "top
ae40: 70 61 74 68 22 20 74 6f 70 70 61 74 68 29 29 0a path" toppath)).
ae50: 20 20 20 20 6d 74 63 6f 6e 66 64 61 74 29 29 0a mtconfdat)).
ae60: 0a 3b 3b 20 64 6f 20 77 65 20 68 6f 6e 6f 72 20 .;; do we honor
ae70: 74 68 65 20 63 61 63 68 65 73 20 6f 66 20 74 68 the caches of th
ae80: 65 20 63 6f 6e 66 69 67 20 66 69 6c 65 73 3f 0a e config files?.
ae90: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
aea0: 6f 6e 3a 75 73 65 2d 63 61 63 68 65 3f 29 0a 20 on:use-cache?).
aeb0: 20 28 6c 65 74 20 28 28 72 65 73 20 23 74 29 29 (let ((res #t))
aec0: 20 3b 3b 20 70 72 69 6f 72 69 74 79 20 62 79 20 ;; priority by
aed0: 6f 72 64 65 72 20 6f 66 20 65 76 61 6c 75 61 74 order of evaluat
aee0: 69 6f 6e 0a 20 20 20 20 28 69 66 20 2a 63 6f 6e ion. (if *con
aef0: 66 69 67 64 61 74 2a 20 3b 3b 20 73 69 6c 6c 79 figdat* ;; silly
af00: 6e 65 73 73 20 68 65 72 65 2e 20 63 61 6e 27 74 ness here. can't
af10: 20 75 73 65 20 73 65 74 75 70 2f 75 73 65 2d 63 use setup/use-c
af20: 61 63 68 65 20 74 6f 20 6b 6e 6f 77 20 69 66 20 ache to know if
af30: 77 65 20 63 61 6e 20 75 73 65 20 74 68 65 20 63 we can use the c
af40: 61 63 68 65 64 20 66 69 6c 65 73 21 0a 09 28 69 ached files!..(i
af50: 66 20 28 65 71 75 61 6c 3f 20 28 63 6f 6e 66 69 f (equal? (confi
af60: 67 66 3a 6c 6f 6f 6b 75 70 20 2a 63 6f 6e 66 69 gf:lookup *confi
af70: 67 64 61 74 2a 20 22 73 65 74 75 70 22 20 22 75 gdat* "setup" "u
af80: 73 65 2d 63 61 63 68 65 22 29 20 22 6e 6f 22 29 se-cache") "no")
af90: 0a 09 20 20 20 20 28 73 65 74 21 20 72 65 73 20 .. (set! res
afa0: 23 66 29 0a 09 20 20 20 20 28 69 66 20 28 65 71 #f).. (if (eq
afb0: 75 61 6c 3f 20 28 63 6f 6e 66 69 67 66 3a 6c 6f ual? (configf:lo
afc0: 6f 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a okup *configdat*
afd0: 20 22 73 65 74 75 70 22 20 22 75 73 65 2d 63 61 "setup" "use-ca
afe0: 63 68 65 22 29 20 22 79 65 73 22 29 0a 09 09 28 che") "yes")...(
aff0: 73 65 74 21 20 72 65 73 20 23 74 29 29 29 29 0a set! res #t)))).
b000: 20 20 20 20 28 69 66 20 28 61 72 67 73 3a 67 65 (if (args:ge
b010: 74 2d 61 72 67 20 22 2d 6e 6f 2d 63 61 63 68 65 t-arg "-no-cache
b020: 22 29 28 73 65 74 21 20 72 65 73 20 23 66 29 29 ")(set! res #f))
b030: 20 3b 3b 20 6f 76 65 72 72 69 64 65 73 20 73 65 ;; overrides se
b040: 74 74 69 6e 67 20 69 6e 20 22 73 65 74 75 70 22 tting in "setup"
b050: 0a 20 20 20 20 28 69 66 20 28 67 65 74 65 6e 76 . (if (getenv
b060: 20 22 4d 54 5f 55 53 45 5f 43 41 43 48 45 22 29 "MT_USE_CACHE")
b070: 0a 09 28 69 66 20 28 65 71 75 61 6c 3f 20 28 67 ..(if (equal? (g
b080: 65 74 65 6e 76 20 22 4d 54 5f 55 53 45 5f 43 41 etenv "MT_USE_CA
b090: 43 48 45 22 29 20 22 79 65 73 22 29 0a 09 20 20 CHE") "yes")..
b0a0: 20 20 28 73 65 74 21 20 72 65 73 20 23 74 29 0a (set! res #t).
b0b0: 09 20 20 20 20 28 69 66 20 28 65 71 75 61 6c 3f . (if (equal?
b0c0: 20 28 67 65 74 65 6e 76 20 22 4d 54 5f 55 53 45 (getenv "MT_USE
b0d0: 5f 43 41 43 48 45 22 29 20 22 6e 6f 22 29 0a 09 _CACHE") "no")..
b0e0: 09 28 73 65 74 21 20 72 65 73 20 23 66 29 29 29 .(set! res #f)))
b0f0: 29 20 20 20 20 3b 3b 20 6f 76 65 72 72 69 64 65 ) ;; override
b100: 73 20 2d 6e 6f 2d 63 61 63 68 65 20 73 77 69 74 s -no-cache swit
b110: 63 68 0a 20 20 20 20 72 65 73 29 29 0a 20 20 0a ch. res)). .
b120: 3b 3b 20 66 6f 72 63 65 20 75 73 65 20 6f 66 20 ;; force use of
b130: 73 65 72 76 65 72 3f 0a 3b 3b 0a 28 64 65 66 69 server?.;;.(defi
b140: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 6f 72 63 65 ne (common:force
b150: 2d 73 65 72 76 65 72 3f 29 0a 20 20 28 6c 65 74 -server?). (let
b160: 2a 20 28 28 66 6f 72 63 65 2d 73 65 74 74 69 6e * ((force-settin
b170: 67 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 g (configf:looku
b180: 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 p *configdat* "s
b190: 65 72 76 65 72 22 20 22 66 6f 72 63 65 22 29 29 erver" "force"))
b1a0: 0a 09 20 28 66 6f 72 63 65 2d 74 79 70 65 20 20 .. (force-type
b1b0: 20 20 28 69 66 20 66 6f 72 63 65 2d 73 65 74 74 (if force-sett
b1c0: 69 6e 67 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d ing (string->sym
b1d0: 62 6f 6c 20 66 6f 72 63 65 2d 73 65 74 74 69 6e bol force-settin
b1e0: 67 29 20 23 66 29 29 0a 09 20 28 66 6f 72 63 65 g) #f)).. (force
b1f0: 2d 72 65 73 75 6c 74 20 20 28 63 61 73 65 20 66 -result (case f
b200: 6f 72 63 65 2d 74 79 70 65 0a 09 09 09 20 20 28 orce-type.... (
b210: 28 23 66 29 20 20 20 20 20 23 66 29 0a 09 09 09 (#f) #f)....
b220: 20 20 28 28 61 6c 77 61 79 73 29 20 23 74 29 0a ((always) #t).
b230: 09 09 09 20 20 28 28 74 65 73 74 29 20 20 20 28 ... ((test) (
b240: 69 66 20 28 61 72 67 73 3a 67 65 74 2d 61 72 67 if (args:get-arg
b250: 20 22 2d 65 78 65 63 75 74 65 22 29 20 3b 3b 20 "-execute") ;;
b260: 77 65 20 61 72 65 20 69 6e 20 61 20 74 65 73 74 we are in a test
b270: 0a 09 09 09 09 09 23 74 0a 09 09 09 09 09 23 66 ......#t......#f
b280: 29 29 0a 09 09 09 20 20 28 65 6c 73 65 0a 09 09 )).... (else...
b290: 09 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 . (debug:print
b2a0: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
b2b0: 70 6f 72 74 2a 20 22 45 52 52 4f 52 3a 20 42 61 port* "ERROR: Ba
b2c0: 64 20 73 65 72 76 65 72 20 66 6f 72 63 65 20 73 d server force s
b2d0: 65 74 74 69 6e 67 20 22 20 66 6f 72 63 65 2d 73 etting " force-s
b2e0: 65 74 74 69 6e 67 20 22 2c 20 66 6f 72 63 69 6e etting ", forcin
b2f0: 67 20 73 65 72 76 65 72 2e 22 29 0a 09 09 09 20 g server.")....
b300: 20 20 23 74 29 29 29 29 20 3b 3b 20 64 65 66 61 #t)))) ;; defa
b310: 75 6c 74 20 74 6f 20 72 65 71 75 69 72 69 6e 67 ult to requiring
b320: 20 73 65 72 76 65 72 0a 20 20 20 20 28 69 66 20 server. (if
b330: 66 6f 72 63 65 2d 72 65 73 75 6c 74 0a 09 28 62 force-result..(b
b340: 65 67 69 6e 0a 09 20 20 28 64 65 62 75 67 3a 70 egin.. (debug:p
b350: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
b360: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
b370: 66 6f 72 63 69 6e 67 20 75 73 65 20 6f 66 20 73 forcing use of s
b380: 65 72 76 65 72 2c 20 66 6f 72 63 65 20 73 65 74 erver, force set
b390: 74 69 6e 67 20 69 73 20 5c 22 22 20 66 6f 72 63 ting is \"" forc
b3a0: 65 2d 73 65 74 74 69 6e 67 20 22 5c 22 2e 22 29 e-setting "\".")
b3b0: 0a 09 20 20 23 74 29 0a 09 23 66 29 29 29 0a 0a .. #t)..#f)))..
b3c0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
b3d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b3f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b400: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 49 20 ========.;; M I
b410: 53 20 43 20 20 20 4c 20 49 20 53 20 54 20 53 0a S C L I S T S.
b420: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
b430: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
b460: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 69 74 65 ========..;; ite
b470: 6d 73 20 69 6e 20 6c 69 73 74 61 20 61 72 65 20 ms in lista are
b480: 6d 61 74 63 68 65 64 20 76 61 6c 75 65 20 61 6e matched value an
b490: 64 20 70 6f 73 69 74 69 6f 6e 20 69 6e 20 6c 69 d position in li
b4a0: 73 74 62 0a 3b 3b 20 72 65 74 75 72 6e 20 74 68 stb.;; return th
b4b0: 65 20 72 65 6d 61 69 6e 69 6e 67 20 69 74 65 6d e remaining item
b4c0: 73 20 69 6e 20 6c 69 73 74 62 20 6f 72 20 23 66 s in listb or #f
b4d0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d .;;.(define (com
b4e0: 6d 6f 6e 3a 6c 69 73 74 2d 69 73 2d 73 75 62 6c mon:list-is-subl
b4f0: 69 73 74 20 6c 69 73 74 61 20 6c 69 73 74 62 29 ist lista listb)
b500: 0a 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 69 . (if (null? li
b510: 73 74 61 29 0a 20 20 20 20 20 20 6c 69 73 74 62 sta). listb
b520: 20 3b 3b 20 61 6c 6c 20 69 74 65 6d 73 20 69 6e ;; all items in
b530: 20 6c 69 73 74 62 20 61 72 65 20 22 72 65 6d 61 listb are "rema
b540: 69 6e 69 6e 67 22 0a 20 20 20 20 20 20 28 69 66 ining". (if
b550: 20 28 3e 20 28 6c 65 6e 67 74 68 20 6c 69 73 74 (> (length list
b560: 61 29 28 6c 65 6e 67 74 68 20 6c 69 73 74 62 29 a)(length listb)
b570: 29 20 0a 09 20 20 23 66 0a 09 20 20 28 6c 65 74 ) .. #f.. (let
b580: 20 6c 6f 6f 70 20 28 28 68 65 64 61 20 28 63 61 loop ((heda (ca
b590: 72 20 6c 69 73 74 61 29 29 0a 09 09 20 20 20 20 r lista))...
b5a0: 20 28 74 61 6c 61 20 28 63 64 72 20 6c 69 73 74 (tala (cdr list
b5b0: 61 29 29 0a 09 09 20 20 20 20 20 28 68 65 64 62 a))... (hedb
b5c0: 20 28 63 61 72 20 6c 69 73 74 62 29 29 0a 09 09 (car listb))...
b5d0: 20 20 20 20 20 28 74 61 6c 62 20 28 63 64 72 20 (talb (cdr
b5e0: 6c 69 73 74 62 29 29 29 0a 09 20 20 20 20 28 69 listb))).. (i
b5f0: 66 20 28 65 71 75 61 6c 3f 20 68 65 64 61 20 68 f (equal? heda h
b600: 65 64 62 29 0a 09 09 28 69 66 20 28 6e 75 6c 6c edb)...(if (null
b610: 3f 20 74 61 6c 61 29 20 3b 3b 20 77 65 20 61 72 ? tala) ;; we ar
b620: 65 20 64 6f 6e 65 0a 09 09 20 20 20 20 74 61 6c e done... tal
b630: 62 0a 09 09 20 20 20 20 28 6c 6f 6f 70 20 28 63 b... (loop (c
b640: 61 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 ar tala).... (c
b650: 64 72 20 74 61 6c 61 29 0a 09 09 09 20 20 28 63 dr tala).... (c
b660: 61 72 20 74 61 6c 62 29 0a 09 09 09 20 20 0a 09 ar talb).... ..
b670: 09 09 20 20 28 63 64 72 20 74 61 6c 62 29 29 29 .. (cdr talb)))
b680: 0a 09 09 23 66 29 29 29 29 29 0a 0a 3b 3b 20 4e ...#f)))))..;; N
b690: 65 65 64 65 64 20 66 6f 72 20 6c 6f 6e 67 20 6c eeded for long l
b6a0: 69 73 74 73 20 74 6f 20 62 65 20 73 6f 72 74 65 ists to be sorte
b6b0: 64 20 77 68 65 72 65 20 28 61 70 70 6c 79 20 6d d where (apply m
b6c0: 61 78 20 2e 2e 2e 20 29 20 64 69 65 73 0a 3b 3b ax ... ) dies.;;
b6d0: 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
b6e0: 3a 6d 61 78 20 69 6e 6c 73 74 29 0a 20 20 28 6c :max inlst). (l
b6f0: 65 74 20 6c 6f 6f 70 20 28 28 6d 61 78 2d 76 61 et loop ((max-va
b700: 6c 20 28 63 61 72 20 69 6e 6c 73 74 29 29 0a 09 l (car inlst))..
b710: 20 20 20 20 20 28 68 65 64 20 20 20 20 20 28 63 (hed (c
b720: 61 72 20 69 6e 6c 73 74 29 29 0a 09 20 20 20 20 ar inlst))..
b730: 20 28 74 61 6c 20 20 20 20 20 28 63 64 72 20 69 (tal (cdr i
b740: 6e 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 nlst))). (if
b750: 28 6e 6f 74 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 (not (null? tal)
b760: 29 0a 09 28 6c 6f 6f 70 20 28 6d 61 78 20 68 65 )..(loop (max he
b770: 64 20 6d 61 78 2d 76 61 6c 29 0a 09 20 20 20 20 d max-val)..
b780: 20 20 28 63 61 72 20 74 61 6c 29 0a 09 20 20 20 (car tal)..
b790: 20 20 20 28 63 64 72 20 74 61 6c 29 29 0a 09 28 (cdr tal))..(
b7a0: 6d 61 78 20 68 65 64 20 6d 61 78 2d 76 61 6c 29 max hed max-val)
b7b0: 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e 20 )))..;; get min
b7c0: 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 6f or max, use > fo
b7d0: 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 20 r max and < for
b7e0: 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 20 min, this works
b7f0: 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 74 around the limit
b800: 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 64 s on apply.;;.(d
b810: 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 6d 69 efine (common:mi
b820: 6e 2d 6d 61 78 20 63 6f 6d 70 20 6c 73 74 29 0a n-max comp lst).
b830: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 73 74 (if (null? lst
b840: 29 0a 20 20 20 20 20 20 23 66 20 3b 3b 20 62 65 ). #f ;; be
b850: 74 74 65 72 20 74 68 61 6e 20 61 6e 20 65 78 63 tter than an exc
b860: 65 70 74 69 6f 6e 20 66 6f 72 20 6d 79 20 6e 65 eption for my ne
b870: 65 64 73 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 eds. (fold
b880: 28 6c 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 (lambda (a b)..
b890: 20 20 20 20 20 28 69 66 20 28 63 6f 6d 70 20 61 (if (comp a
b8a0: 20 62 29 20 61 20 62 29 29 0a 09 20 20 20 20 28 b) a b)).. (
b8b0: 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 6c 73 car lst).. ls
b8c0: 74 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6d 69 6e t)))..;; get min
b8d0: 20 6f 72 20 6d 61 78 2c 20 75 73 65 20 3e 20 66 or max, use > f
b8e0: 6f 72 20 6d 61 78 20 61 6e 64 20 3c 20 66 6f 72 or max and < for
b8f0: 20 6d 69 6e 2c 20 74 68 69 73 20 77 6f 72 6b 73 min, this works
b900: 20 61 72 6f 75 6e 64 20 74 68 65 20 6c 69 6d 69 around the limi
b910: 74 73 20 6f 6e 20 61 70 70 6c 79 0a 3b 3b 0a 28 ts on apply.;;.(
b920: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 define (common:s
b930: 75 6d 20 6c 73 74 29 0a 20 20 28 69 66 20 28 6e um lst). (if (n
b940: 75 6c 6c 3f 20 6c 73 74 29 0a 20 20 20 20 20 20 ull? lst).
b950: 30 0a 20 20 20 20 20 20 28 66 6f 6c 64 20 28 6c 0. (fold (l
b960: 61 6d 62 64 61 20 28 61 20 62 29 0a 09 20 20 20 ambda (a b)..
b970: 20 20 20 28 2b 20 61 20 62 29 29 0a 09 20 20 20 (+ a b))..
b980: 20 28 63 61 72 20 6c 73 74 29 0a 09 20 20 20 20 (car lst)..
b990: 6c 73 74 29 29 29 0a 0a 3b 3b 20 70 61 74 68 20 lst)))..;; path
b9a0: 6c 69 73 74 20 74 6f 20 68 61 73 68 2d 74 61 62 list to hash-tab
b9b0: 6c 65 20 74 72 65 65 0a 3b 3b 20 20 20 28 28 61 le tree.;; ((a
b9c0: 20 62 20 63 29 28 61 20 62 20 64 29 28 65 20 62 b c)(a b d)(e b
b9d0: 20 63 29 29 20 3d 3e 20 28 28 61 20 28 62 20 28 c)) => ((a (b (
b9e0: 64 29 20 28 63 29 29 29 20 28 65 20 28 62 20 28 d) (c))) (e (b (
b9f0: 63 29 29 29 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 c)))).;;.(define
ba00: 20 28 63 6f 6d 6d 6f 6e 3a 6c 69 73 74 2d 3e 68 (common:list->h
ba10: 74 72 65 65 20 6c 73 74 29 0a 20 20 28 6c 65 74 tree lst). (let
ba20: 20 28 28 72 65 73 68 20 28 6d 61 6b 65 2d 68 61 ((resh (make-ha
ba30: 73 68 2d 74 61 62 6c 65 29 29 29 0a 20 20 20 20 sh-table))).
ba40: 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 20 28 (for-each. (
ba50: 6c 61 6d 62 64 61 20 28 69 6e 6c 73 74 29 0a 20 lambda (inlst).
ba60: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
ba70: 28 28 68 74 20 20 72 65 73 68 29 0a 09 09 20 20 ((ht resh)...
ba80: 28 68 65 64 20 28 63 61 72 20 69 6e 6c 73 74 29 (hed (car inlst)
ba90: 29 0a 09 09 20 20 28 74 61 6c 20 28 63 64 72 20 )... (tal (cdr
baa0: 69 6e 6c 73 74 29 29 29 0a 09 20 28 69 66 20 28 inlst))).. (if (
bab0: 68 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 hash-table-ref/d
bac0: 65 66 61 75 6c 74 20 68 74 20 68 65 64 20 23 66 efault ht hed #f
bad0: 29 0a 09 20 20 20 20 20 28 69 66 20 28 6e 6f 74 ).. (if (not
bae0: 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 29 0a 09 09 (null? tal))...
baf0: 20 28 6c 6f 6f 70 20 28 68 61 73 68 2d 74 61 62 (loop (hash-tab
bb00: 6c 65 2d 72 65 66 20 68 74 20 68 65 64 29 0a 09 le-ref ht hed)..
bb10: 09 20 20 20 20 20 20 20 28 63 61 72 20 74 61 6c . (car tal
bb20: 29 0a 09 09 20 20 20 20 20 20 20 28 63 64 72 20 )... (cdr
bb30: 74 61 6c 29 29 29 0a 09 20 20 20 20 20 28 62 65 tal))).. (be
bb40: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 68 61 73 gin.. (has
bb50: 68 2d 74 61 62 6c 65 2d 73 65 74 21 20 68 74 20 h-table-set! ht
bb60: 68 65 64 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 hed (make-hash-t
bb70: 61 62 6c 65 29 29 0a 09 20 20 20 20 20 20 20 28 able)).. (
bb80: 6c 6f 6f 70 20 68 74 20 68 65 64 20 74 61 6c 29 loop ht hed tal)
bb90: 29 29 29 29 0a 20 20 20 20 20 6c 73 74 29 0a 20 )))). lst).
bba0: 20 20 20 72 65 73 68 29 29 0a 0a 3b 3b 20 68 61 resh))..;; ha
bbb0: 73 68 2d 74 61 62 6c 65 20 74 72 65 65 20 74 6f sh-table tree to
bbc0: 20 68 74 6d 6c 20 6c 69 73 74 20 74 72 65 65 0a html list tree.
bbd0: 3b 3b 0a 3b 3b 20 20 20 74 69 70 66 75 6e 63 20 ;;.;; tipfunc
bbe0: 74 61 6b 65 73 20 74 77 6f 20 70 61 72 61 6d 65 takes two parame
bbf0: 74 65 72 73 3a 20 79 20 74 68 65 20 74 69 70 20 ters: y the tip
bc00: 76 61 6c 75 65 20 61 6e 64 20 70 61 74 68 20 74 value and path t
bc10: 68 65 20 70 61 74 68 20 74 6f 20 74 68 61 74 20 he path to that
bc20: 70 6f 69 6e 74 0a 3b 3b 0a 28 64 65 66 69 6e 65 point.;;.(define
bc30: 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 65 2d 3e (common:htree->
bc40: 68 74 6d 6c 20 68 74 20 70 61 74 68 20 74 69 70 html ht path tip
bc50: 66 75 6e 63 29 0a 20 20 28 6c 65 74 20 28 28 64 func). (let ((d
bc60: 61 74 6c 69 73 74 20 09 28 73 6f 72 74 20 28 68 atlist .(sort (h
bc70: 61 73 68 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 ash-table->alist
bc80: 20 68 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 ht).
bc90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bca0: 20 20 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 (lambda (a b)
bcb0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
bcc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
bcd0: 20 28 73 74 72 69 6e 67 3c 20 28 63 61 72 20 61 (string< (car a
bce0: 29 28 63 61 72 20 62 29 29 29 29 29 29 0a 20 20 )(car b)))))).
bcf0: 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 64 61 74 (if (null? dat
bd00: 6c 69 73 74 29 0a 20 20 20 20 09 28 74 69 70 66 list). .(tipf
bd10: 75 6e 63 20 23 66 20 70 61 74 68 29 20 3b 3b 20 unc #f path) ;;
bd20: 72 65 61 6c 6c 79 20 73 68 6f 75 6c 64 6e 27 74 really shouldn't
bd30: 20 67 65 74 20 68 65 72 65 0a 09 28 73 3a 75 6c get here..(s:ul
bd40: 0a 09 20 28 6d 61 70 20 28 6c 61 6d 62 64 61 20 .. (map (lambda
bd50: 28 78 29 0a 09 09 28 6c 65 74 2a 20 28 28 6c 65 (x)...(let* ((le
bd60: 76 65 6c 6e 61 6d 65 20 28 63 61 72 20 78 29 29 velname (car x))
bd70: 0a 09 09 20 20 20 20 20 20 20 28 79 20 20 20 20 ... (y
bd80: 20 20 20 20 20 28 63 64 72 20 78 29 29 0a 09 09 (cdr x))...
bd90: 20 20 20 20 20 20 20 28 6e 65 77 70 61 74 68 20 (newpath
bda0: 20 20 28 61 70 70 65 6e 64 20 70 61 74 68 20 28 (append path (
bdb0: 6c 69 73 74 20 6c 65 76 65 6c 6e 61 6d 65 29 29 list levelname))
bdc0: 29 0a 09 09 20 20 20 20 20 20 20 28 6c 65 61 66 )... (leaf
bdd0: 20 20 20 20 20 20 28 6f 72 20 28 6e 6f 74 20 28 (or (not (
bde0: 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 29 29 0a hash-table? y)).
bdf0: 09 09 09 09 20 20 20 20 20 20 28 6e 75 6c 6c 3f .... (null?
be00: 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 (hash-table-key
be10: 73 20 79 29 29 29 29 29 0a 09 09 20 20 28 69 66 s y)))))... (if
be20: 20 6c 65 61 66 0a 09 09 20 20 20 20 20 20 28 73 leaf... (s
be30: 3a 6c 69 20 28 74 69 70 66 75 6e 63 20 79 20 6e :li (tipfunc y n
be40: 65 77 70 61 74 68 29 29 0a 09 09 20 20 20 20 20 ewpath))...
be50: 20 28 73 3a 6c 69 0a 09 09 20 20 20 20 20 20 20 (s:li...
be60: 28 6c 69 73 74 20 0a 09 09 09 6c 65 76 65 6c 6e (list ....leveln
be70: 61 6d 65 0a 09 09 09 28 63 6f 6d 6d 6f 6e 3a 68 ame....(common:h
be80: 74 72 65 65 2d 3e 68 74 6d 6c 20 79 20 6e 65 77 tree->html y new
be90: 70 61 74 68 20 74 69 70 66 75 6e 63 29 29 29 29 path tipfunc))))
bea0: 29 29 0a 09 20 20 20 20 20 20 64 61 74 6c 69 73 )).. datlis
beb0: 74 29 29 29 29 29 0a 0a 3b 3b 20 68 61 73 68 2d t)))))..;; hash-
bec0: 74 61 62 6c 65 20 74 72 65 65 20 74 6f 20 61 6c table tree to al
bed0: 69 73 74 20 74 72 65 65 0a 3b 3b 0a 28 64 65 66 ist tree.;;.(def
bee0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 68 74 72 65 ine (common:htre
bef0: 65 2d 3e 61 74 72 65 65 20 68 74 29 0a 20 20 28 e->atree ht). (
bf00: 6d 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a map (lambda (x).
bf10: 09 20 28 63 6f 6e 73 20 28 63 61 72 20 78 29 0a . (cons (car x).
bf20: 09 20 20 20 20 20 20 20 28 6c 65 74 20 28 28 79 . (let ((y
bf30: 20 28 63 64 72 20 78 29 29 29 0a 09 09 20 28 69 (cdr x)))... (i
bf40: 66 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 79 f (hash-table? y
bf50: 29 0a 09 09 20 20 20 20 20 28 63 6f 6d 6d 6f 6e )... (common
bf60: 3a 68 74 72 65 65 2d 3e 61 74 72 65 65 20 79 29 :htree->atree y)
bf70: 0a 09 09 20 20 20 20 20 79 29 29 29 29 0a 20 20 ... y)))).
bf80: 20 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 (hash-table
bf90: 2d 3e 61 6c 69 73 74 20 68 74 29 29 29 0a 0a 3b ->alist ht)))..;
bfa0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
bfb0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bfc0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bfd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
bfe0: 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4d 20 55 20 4e =======.;; M U N
bff0: 20 47 20 45 20 20 20 44 20 41 20 54 20 41 20 20 G E D A T A
c000: 20 49 20 4e 20 54 20 4f 20 20 20 4e 20 49 20 43 I N T O N I C
c010: 20 45 20 20 20 46 20 4f 20 52 20 4d 20 53 0a 3b E F O R M S.;
c020: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
c030: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c060: 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 47 65 6e 65 =======..;; Gene
c070: 72 61 74 65 20 61 6e 20 69 6e 64 65 78 20 66 6f rate an index fo
c080: 72 20 61 20 73 70 61 72 73 65 20 6c 69 73 74 20 r a sparse list
c090: 6f 66 20 6b 65 79 20 76 61 6c 75 65 73 0a 3b 3b of key values.;;
c0a0: 20 20 20 28 20 28 72 6f 77 6e 61 6d 65 31 20 63 ( (rowname1 c
c0b0: 6f 6c 6e 61 6d 65 31 20 76 61 6c 31 29 28 72 6f olname1 val1)(ro
c0c0: 77 6e 61 6d 65 32 20 63 6f 6c 6e 61 6d 65 32 20 wname2 colname2
c0d0: 76 61 6c 32 29 20 29 0a 3b 3b 0a 3b 3b 20 3d 3e val2) ).;;.;; =>
c0e0: 20 0a 3b 3b 0a 3b 3b 20 20 20 28 20 28 72 6f 77 .;;.;; ( (row
c0f0: 6e 61 6d 65 31 20 30 29 28 72 6f 77 6e 61 6d 65 name1 0)(rowname
c100: 32 20 31 29 29 20 20 20 20 3b 3b 20 72 6f 77 6e 2 1)) ;; rown
c110: 61 6d 65 73 20 2d 3e 20 6e 75 6d 0a 3b 3b 20 20 ames -> num.;;
c120: 20 20 20 28 63 6f 6c 6e 61 6d 65 31 20 30 29 28 (colname1 0)(
c130: 63 6f 6c 6e 61 6d 65 32 20 31 29 29 20 29 20 20 colname2 1)) )
c140: 3b 3b 20 63 6f 6c 6e 61 6d 65 73 20 2d 3e 20 6e ;; colnames -> n
c150: 75 6d 0a 3b 3b 20 0a 3b 3b 20 6f 70 74 69 6f 6e um.;; .;; option
c160: 61 6c 20 61 70 70 6c 79 20 70 72 6f 63 20 74 6f al apply proc to
c170: 20 72 6f 77 6e 75 6d 20 63 6f 6c 6e 75 6d 20 76 rownum colnum v
c180: 61 6c 75 65 0a 28 64 65 66 69 6e 65 20 28 63 6f alue.(define (co
c190: 6d 6d 6f 6e 3a 73 70 61 72 73 65 2d 6c 69 73 74 mmon:sparse-list
c1a0: 2d 67 65 6e 65 72 61 74 65 2d 69 6e 64 65 78 20 -generate-index
c1b0: 64 61 74 61 20 23 21 6b 65 79 20 28 70 72 6f 63 data #!key (proc
c1c0: 20 23 66 29 29 0a 20 20 28 69 66 20 28 6e 75 6c #f)). (if (nul
c1d0: 6c 3f 20 64 61 74 61 29 0a 20 20 20 20 20 20 28 l? data). (
c1e0: 6c 69 73 74 20 27 28 29 20 27 28 29 29 0a 20 20 list '() '()).
c1f0: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
c200: 68 65 64 20 28 63 61 72 20 64 61 74 61 29 29 0a hed (car data)).
c210: 09 09 20 28 74 61 6c 20 28 63 64 72 20 64 61 74 .. (tal (cdr dat
c220: 61 29 29 0a 09 09 20 28 72 6f 77 6e 61 6d 65 73 a))... (rownames
c230: 20 27 28 29 29 0a 09 09 20 28 63 6f 6c 6e 61 6d '())... (colnam
c240: 65 73 20 27 28 29 29 0a 09 09 20 28 72 6f 77 6e es '())... (rown
c250: 75 6d 20 20 20 30 29 0a 09 09 20 28 63 6f 6c 6e um 0)... (coln
c260: 75 6d 20 20 20 30 29 29 0a 09 28 6c 65 74 2a 20 um 0))..(let*
c270: 28 28 72 6f 77 6b 65 79 20 20 20 20 20 20 20 20 ((rowkey
c280: 20 20 28 63 61 72 20 20 20 68 65 64 29 29 0a 09 (car hed))..
c290: 20 20 20 20 20 20 20 28 63 6f 6c 6b 65 79 20 20 (colkey
c2a0: 20 20 20 20 20 20 20 20 28 63 61 64 72 20 20 68 (cadr h
c2b0: 65 64 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 ed)).. (va
c2c0: 6c 75 65 20 20 20 20 20 20 20 20 20 20 20 28 63 lue (c
c2d0: 61 64 64 72 20 68 65 64 29 29 0a 09 20 20 20 20 addr hed))..
c2e0: 20 20 20 28 65 78 69 73 74 69 6e 67 2d 72 6f 77 (existing-row
c2f0: 64 61 74 20 28 61 73 73 6f 63 20 72 6f 77 6b 65 dat (assoc rowke
c300: 79 20 72 6f 77 6e 61 6d 65 73 29 29 0a 09 20 20 y rownames))..
c310: 20 20 20 20 20 28 65 78 69 73 74 69 6e 67 2d 63 (existing-c
c320: 6f 6c 64 61 74 20 28 61 73 73 6f 63 20 63 6f 6c oldat (assoc col
c330: 6b 65 79 20 63 6f 6c 6e 61 6d 65 73 29 29 0a 09 key colnames))..
c340: 20 20 20 20 20 20 20 28 63 75 72 72 2d 72 6f 77 (curr-row
c350: 6e 75 6d 20 20 20 20 20 28 69 66 20 65 78 69 73 num (if exis
c360: 74 69 6e 67 2d 72 6f 77 64 61 74 20 72 6f 77 6e ting-rowdat rown
c370: 75 6d 20 28 2b 20 72 6f 77 6e 75 6d 20 31 29 29 um (+ rownum 1))
c380: 29 0a 09 20 20 20 20 20 20 20 28 63 75 72 72 2d ).. (curr-
c390: 63 6f 6c 6e 75 6d 20 20 20 20 20 28 69 66 20 65 colnum (if e
c3a0: 78 69 73 74 69 6e 67 2d 63 6f 6c 64 61 74 20 63 xisting-coldat c
c3b0: 6f 6c 6e 75 6d 20 28 2b 20 63 6f 6c 6e 75 6d 20 olnum (+ colnum
c3c0: 31 29 29 29 0a 09 20 20 20 20 20 20 20 28 6e 65 1))).. (ne
c3d0: 77 2d 72 6f 77 6e 61 6d 65 73 20 20 20 20 28 69 w-rownames (i
c3e0: 66 20 65 78 69 73 74 69 6e 67 2d 72 6f 77 64 61 f existing-rowda
c3f0: 74 20 72 6f 77 6e 61 6d 65 73 20 28 63 6f 6e 73 t rownames (cons
c400: 20 28 6c 69 73 74 20 72 6f 77 6b 65 79 20 63 75 (list rowkey cu
c410: 72 72 2d 72 6f 77 6e 75 6d 29 20 72 6f 77 6e 61 rr-rownum) rowna
c420: 6d 65 73 29 29 29 0a 09 20 20 20 20 20 20 20 28 mes))).. (
c430: 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 20 20 20 20 new-colnames
c440: 28 69 66 20 65 78 69 73 74 69 6e 67 2d 63 6f 6c (if existing-col
c450: 64 61 74 20 63 6f 6c 6e 61 6d 65 73 20 28 63 6f dat colnames (co
c460: 6e 73 20 28 6c 69 73 74 20 63 6f 6c 6b 65 79 20 ns (list colkey
c470: 63 75 72 72 2d 63 6f 6c 6e 75 6d 29 20 63 6f 6c curr-colnum) col
c480: 6e 61 6d 65 73 29 29 29 29 0a 09 20 20 3b 3b 20 names)))).. ;;
c490: 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 (debug:print-inf
c4a0: 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 o 0 *default-log
c4b0: 2d 70 6f 72 74 2a 20 22 50 72 6f 63 65 73 73 69 -port* "Processi
c4c0: 6e 67 20 72 65 63 6f 72 64 3a 20 22 20 68 65 64 ng record: " hed
c4d0: 20 29 0a 09 20 20 28 69 66 20 70 72 6f 63 20 28 ).. (if proc (
c4e0: 70 72 6f 63 20 63 75 72 72 2d 72 6f 77 6e 75 6d proc curr-rownum
c4f0: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 72 6f 77 curr-colnum row
c500: 6b 65 79 20 63 6f 6c 6b 65 79 20 76 61 6c 75 65 key colkey value
c510: 29 29 0a 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f )).. (if (null?
c520: 20 74 61 6c 29 0a 09 20 20 20 20 20 20 28 6c 69 tal).. (li
c530: 73 74 20 6e 65 77 2d 72 6f 77 6e 61 6d 65 73 20 st new-rownames
c540: 6e 65 77 2d 63 6f 6c 6e 61 6d 65 73 29 0a 09 20 new-colnames)..
c550: 20 20 20 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 (loop (car
c560: 74 61 6c 29 0a 09 09 20 20 20 20 28 63 64 72 20 tal)... (cdr
c570: 74 61 6c 29 0a 09 09 20 20 20 20 6e 65 77 2d 72 tal)... new-r
c580: 6f 77 6e 61 6d 65 73 0a 09 09 20 20 20 20 6e 65 ownames... ne
c590: 77 2d 63 6f 6c 6e 61 6d 65 73 0a 09 09 20 20 20 w-colnames...
c5a0: 20 28 69 66 20 28 3e 20 63 75 72 72 2d 72 6f 77 (if (> curr-row
c5b0: 6e 75 6d 20 72 6f 77 6e 75 6d 29 20 63 75 72 72 num rownum) curr
c5c0: 2d 72 6f 77 6e 75 6d 20 72 6f 77 6e 75 6d 29 0a -rownum rownum).
c5d0: 09 09 20 20 20 20 28 69 66 20 28 3e 20 63 75 72 .. (if (> cur
c5e0: 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c 6e 75 6d 29 r-colnum colnum)
c5f0: 20 63 75 72 72 2d 63 6f 6c 6e 75 6d 20 63 6f 6c curr-colnum col
c600: 6e 75 6d 29 0a 09 09 20 20 20 20 29 29 29 29 29 num)... )))))
c610: 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
c620: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c630: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c640: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 53 ===========.;; S
c660: 20 59 20 53 20 54 20 45 20 4d 20 20 20 53 20 54 Y S T E M S T
c670: 20 55 20 46 20 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d U F F.;;=======
c680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c690: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c6a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
c6b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
c6c0: 0a 3b 3b 20 6c 61 7a 79 2d 73 61 66 65 20 67 65 .;; lazy-safe ge
c6d0: 74 20 66 69 6c 65 20 6d 6f 64 20 74 69 6d 65 2e t file mod time.
c6e0: 20 6f 6e 20 61 6e 79 20 65 72 72 6f 72 20 28 66 on any error (f
c6f0: 69 6c 65 20 6e 6f 74 20 65 78 69 73 74 69 6e 67 ile not existing
c700: 20 65 74 63 2e 29 20 72 65 74 75 72 6e 20 30 0a etc.) return 0.
c710: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
c720: 6f 6e 3a 6c 61 7a 79 2d 6d 6f 64 69 66 69 63 61 on:lazy-modifica
c730: 74 69 6f 6e 2d 74 69 6d 65 20 66 70 61 74 68 29 tion-time fpath)
c740: 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 . (handle-excep
c750: 74 69 6f 6e 73 0a 20 20 20 20 20 20 65 78 6e 0a tions. exn.
c760: 20 20 20 20 20 20 30 0a 20 20 20 20 28 66 69 6c 0. (fil
c770: 65 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 e-modification-t
c780: 69 6d 65 20 66 70 61 74 68 29 29 29 0a 0a 3b 3b ime fpath)))..;;
c790: 20 66 69 6e 64 20 74 69 6d 65 73 74 61 6d 70 20 find timestamp
c7a0: 6f 66 20 6e 65 77 65 73 74 20 66 69 6c 65 20 61 of newest file a
c7b0: 73 73 6f 63 69 61 74 65 64 20 77 69 74 68 20 61 ssociated with a
c7c0: 20 73 71 6c 69 74 65 20 64 62 20 66 69 6c 65 0a sqlite db file.
c7d0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
c7e0: 6c 61 7a 79 2d 73 71 6c 69 74 65 2d 64 62 2d 6d lazy-sqlite-db-m
c7f0: 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 6d 65 odification-time
c800: 20 66 70 61 74 68 29 0a 20 20 28 6c 65 74 2a 20 fpath). (let*
c810: 28 28 67 6c 6f 62 2d 6c 69 73 74 20 28 68 61 6e ((glob-list (han
c820: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 09 dle-exceptions..
c830: 09 09 65 78 6e 0a 09 09 09 60 28 2c 28 63 6f 6e ..exn....`(,(con
c840: 63 20 22 2f 6e 6f 2f 73 75 63 68 2f 66 69 6c 65 c "/no/such/file
c850: 2c 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 63 , message: " ((c
c860: 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 74 ondition-propert
c870: 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e 20 y-accessor 'exn
c880: 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 29 'message) exn)))
c890: 0a 09 09 20 20 20 20 20 20 28 67 6c 6f 62 20 28 ... (glob (
c8a0: 63 6f 6e 63 20 66 70 61 74 68 20 22 2a 22 29 29 conc fpath "*"))
c8b0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 66 69 6c )). (fil
c8c0: 65 2d 6c 69 73 74 20 28 69 66 20 28 65 71 3f 20 e-list (if (eq?
c8d0: 30 20 28 6c 65 6e 67 74 68 20 67 6c 6f 62 2d 6c 0 (length glob-l
c8e0: 69 73 74 29 29 0a 09 09 09 27 28 22 2f 6e 6f 2f ist))....'("/no/
c8f0: 73 75 63 68 2f 66 69 6c 65 22 29 0a 09 09 09 67 such/file")....g
c900: 6c 6f 62 2d 6c 69 73 74 29 29 29 0a 20 20 28 61 lob-list))). (a
c910: 70 70 6c 79 20 6d 61 78 0a 20 20 20 28 6d 61 70 pply max. (map
c920: 0a 20 20 20 20 63 6f 6d 6d 6f 6e 3a 6c 61 7a 79 . common:lazy
c930: 2d 6d 6f 64 69 66 69 63 61 74 69 6f 6e 2d 74 69 -modification-ti
c940: 6d 65 20 0a 20 20 20 20 66 69 6c 65 2d 6c 69 73 me . file-lis
c950: 74 29 29 29 29 0a 0a 3b 3b 20 72 65 74 75 72 6e t))))..;; return
c960: 20 61 20 6e 69 63 65 20 63 6c 65 61 6e 20 70 61 a nice clean pa
c970: 74 68 6e 61 6d 65 20 6d 61 64 65 20 61 62 73 6f thname made abso
c980: 6c 75 74 65 0a 28 64 65 66 69 6e 65 20 28 63 6f lute.(define (co
c990: 6d 6d 6f 6e 3a 6e 69 63 65 2d 70 61 74 68 20 64 mmon:nice-path d
c9a0: 69 72 29 0a 20 20 28 6c 65 74 20 28 28 6d 61 74 ir). (let ((mat
c9b0: 63 68 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 ch (string-match
c9c0: 20 22 5e 28 7e 5b 5e 5c 5c 2f 5d 2a 29 28 5c 5c "^(~[^\\/]*)(\\
c9d0: 2f 2e 2a 7c 29 24 22 20 64 69 72 29 29 29 0a 20 /.*|)$" dir))).
c9e0: 20 20 20 28 69 66 20 6d 61 74 63 68 20 3b 3b 20 (if match ;;
c9f0: 75 73 69 6e 67 20 7e 20 66 6f 72 20 68 6f 6d 65 using ~ for home
ca00: 3f 0a 09 28 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 2d ?..(common:nice-
ca10: 70 61 74 68 20 28 63 6f 6e 63 20 28 63 6f 6d 6d path (conc (comm
ca20: 6f 6e 3a 72 65 61 64 2d 6c 69 6e 6b 2d 66 20 28 on:read-link-f (
ca30: 63 61 64 72 20 6d 61 74 63 68 29 29 20 22 2f 22 cadr match)) "/"
ca40: 20 28 63 61 64 64 72 20 6d 61 74 63 68 29 29 29 (caddr match)))
ca50: 0a 09 28 6e 6f 72 6d 61 6c 69 7a 65 2d 70 61 74 ..(normalize-pat
ca60: 68 6e 61 6d 65 20 28 69 66 20 28 61 62 73 6f 6c hname (if (absol
ca70: 75 74 65 2d 70 61 74 68 6e 61 6d 65 3f 20 64 69 ute-pathname? di
ca80: 72 29 0a 09 09 09 09 64 69 72 0a 09 09 09 09 28 r).....dir.....(
ca90: 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 2d 64 69 conc (current-di
caa0: 72 65 63 74 6f 72 79 29 20 22 2f 22 20 64 69 72 rectory) "/" dir
cab0: 29 29 29 29 29 29 0a 0a 3b 3b 20 6d 61 6b 65 20 ))))))..;; make
cac0: 22 6e 69 63 65 2d 70 61 74 68 22 20 61 76 61 69 "nice-path" avai
cad0: 6c 61 62 6c 65 20 69 6e 20 63 6f 6e 66 69 67 20 lable in config
cae0: 66 69 6c 65 73 20 61 6e 64 20 74 68 65 20 72 65 files and the re
caf0: 70 6c 0a 28 64 65 66 69 6e 65 20 6e 69 63 65 2d pl.(define nice-
cb00: 70 61 74 68 20 63 6f 6d 6d 6f 6e 3a 6e 69 63 65 path common:nice
cb10: 2d 70 61 74 68 29 0a 0a 28 64 65 66 69 6e 65 20 -path)..(define
cb20: 28 63 6f 6d 6d 6f 6e 3a 72 65 61 64 2d 6c 69 6e (common:read-lin
cb30: 6b 2d 66 20 70 61 74 68 29 0a 20 20 28 68 61 6e k-f path). (han
cb40: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 20 dle-exceptions.
cb50: 20 20 20 20 20 65 78 6e 0a 20 20 20 20 20 20 28 exn. (
cb60: 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 72 begin..(debug:pr
cb70: 69 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 int-error 0 *def
cb80: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
cb90: 63 6f 6d 6d 61 6e 64 20 5c 22 2f 62 69 6e 2f 72 command \"/bin/r
cba0: 65 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 eadlink -f " pat
cbb0: 68 20 22 5c 22 20 66 61 69 6c 65 64 2e 22 29 0a h "\" failed.").
cbc0: 09 70 61 74 68 29 20 3b 3b 20 6a 75 73 74 20 67 .path) ;; just g
cbd0: 69 76 65 20 75 70 0a 20 20 20 20 28 77 69 74 68 ive up. (with
cbe0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
cbf0: 0a 09 28 63 6f 6e 63 20 22 2f 62 69 6e 2f 72 65 ..(conc "/bin/re
cc00: 61 64 6c 69 6e 6b 20 2d 66 20 22 20 70 61 74 68 adlink -f " path
cc10: 29 0a 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 ). (lambda
cc20: 28 29 0a 09 28 72 65 61 64 2d 6c 69 6e 65 29 29 ()..(read-line))
cc30: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 )))..(define (ge
cc40: 74 2d 63 70 75 2d 6c 6f 61 64 20 23 21 6b 65 79 t-cpu-load #!key
cc50: 20 28 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 (remote-host #f
cc60: 29 29 0a 20 20 28 63 61 72 20 28 63 6f 6d 6d 6f )). (car (commo
cc70: 6e 3a 67 65 74 2d 63 70 75 2d 6c 6f 61 64 20 72 n:get-cpu-load r
cc80: 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 3b 3b emote-host))).;;
cc90: 20 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d (let* ((load-
cca0: 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 res (process:cmd
ccb0: 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 69 -run->list "upti
ccc0: 6d 65 22 29 29 0a 3b 3b 20 09 20 28 6c 6f 61 64 me")).;; . (load
ccd0: 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 6c 6f -rx (regexp "lo
cce0: 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 ad average:\\s+(
ccf0: 5c 5c 64 2b 29 22 29 29 0a 3b 3b 20 09 20 28 63 \\d+)")).;; . (c
cd00: 70 75 2d 6c 6f 61 64 20 23 66 29 29 0a 3b 3b 20 pu-load #f)).;;
cd10: 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c (for-each (l
cd20: 61 6d 62 64 61 20 28 6c 29 0a 3b 3b 20 09 09 28 ambda (l).;; ..(
cd30: 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 72 let ((match (str
cd40: 69 6e 67 2d 73 65 61 72 63 68 20 6c 6f 61 64 2d ing-search load-
cd50: 72 78 20 6c 29 29 29 0a 3b 3b 20 09 09 20 20 28 rx l))).;; .. (
cd60: 69 66 20 6d 61 74 63 68 0a 3b 3b 20 09 09 20 20 if match.;; ..
cd70: 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 61 (let ((newva
cd80: 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 l (string->numbe
cd90: 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 r (cadr match)))
cda0: 29 0a 3b 3b 20 09 09 09 28 69 66 20 28 6e 75 6d ).;; ...(if (num
cdb0: 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 3b 3b 20 ber? newval).;;
cdc0: 09 09 09 20 20 20 20 28 73 65 74 21 20 63 70 75 ... (set! cpu
cdd0: 2d 6c 6f 61 64 20 6e 65 77 76 61 6c 29 29 29 29 -load newval))))
cde0: 29 29 0a 3b 3b 20 09 20 20 20 20 20 20 28 63 61 )).;; . (ca
cdf0: 72 20 6c 6f 61 64 2d 72 65 73 29 29 0a 3b 3b 20 r load-res)).;;
ce00: 20 20 20 20 63 70 75 2d 6c 6f 61 64 29 29 0a 0a cpu-load))..
ce10: 3b 3b 20 67 65 74 20 63 70 75 20 6c 6f 61 64 20 ;; get cpu load
ce20: 62 79 20 72 65 61 64 69 6e 67 20 66 72 6f 6d 20 by reading from
ce30: 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 2c 20 72 /proc/loadavg, r
ce40: 65 74 75 72 6e 20 61 6c 6c 20 74 68 72 65 65 20 eturn all three
ce50: 76 61 6c 75 65 73 0a 3b 3b 0a 28 64 65 66 69 6e values.;;.(defin
ce60: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 70 e (common:get-cp
ce70: 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 6f u-load remote-ho
ce80: 73 74 29 0a 20 20 28 69 66 20 72 65 6d 6f 74 65 st). (if remote
ce90: 2d 68 6f 73 74 0a 20 20 20 20 20 20 28 6d 61 70 -host. (map
cea0: 20 28 6c 61 6d 62 64 61 20 28 72 65 73 29 0a 09 (lambda (res)..
ceb0: 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 (if (eof-ob
cec0: 6a 65 63 74 3f 20 72 65 73 29 20 39 65 39 39 20 ject? res) 9e99
ced0: 72 65 73 29 29 0a 09 20 20 20 28 77 69 74 68 2d res)).. (with-
cee0: 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 input-from-pipe
cef0: 0a 09 20 20 20 20 28 63 6f 6e 63 20 22 73 73 68 .. (conc "ssh
cf00: 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 " remote-host "
cf10: 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 cat /proc/loada
cf20: 76 67 22 29 0a 09 20 20 20 20 28 6c 61 6d 62 64 vg").. (lambd
cf30: 61 20 28 29 28 6c 69 73 74 20 28 72 65 61 64 29 a ()(list (read)
cf40: 28 72 65 61 64 29 28 72 65 61 64 29 29 29 29 29 (read)(read)))))
cf50: 0a 20 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 . (with-inp
cf60: 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 22 2f 70 ut-from-file "/p
cf70: 72 6f 63 2f 6c 6f 61 64 61 76 67 22 20 0a 09 28 roc/loadavg" ..(
cf80: 6c 61 6d 62 64 61 20 28 29 28 6c 69 73 74 20 28 lambda ()(list (
cf90: 72 65 61 64 29 28 72 65 61 64 29 28 72 65 61 64 read)(read)(read
cfa0: 29 29 29 29 29 29 0a 0a 3b 3b 20 67 65 74 20 6e ))))))..;; get n
cfb0: 6f 72 6d 61 6c 69 7a 65 64 20 63 70 75 20 6c 6f ormalized cpu lo
cfc0: 61 64 20 62 79 20 72 65 61 64 69 6e 67 20 66 72 ad by reading fr
cfd0: 6f 6d 20 2f 70 72 6f 63 2f 6c 6f 61 64 61 76 67 om /proc/loadavg
cfe0: 20 61 6e 64 20 2f 70 72 6f 63 2f 63 70 75 69 6e and /proc/cpuin
cff0: 66 6f 20 72 65 74 75 72 6e 20 61 6c 6c 20 74 68 fo return all th
d000: 72 65 65 20 76 61 6c 75 65 73 20 61 6e 64 20 74 ree values and t
d010: 68 65 20 6e 75 6d 62 65 72 20 6f 66 20 72 65 61 he number of rea
d020: 6c 20 63 70 75 73 20 61 6e 64 20 74 68 65 20 6e l cpus and the n
d030: 75 6d 62 65 72 20 6f 66 20 74 68 72 65 61 64 73 umber of threads
d040: 0a 3b 3b 20 72 65 74 75 72 6e 73 20 61 6c 69 73 .;; returns alis
d050: 74 20 27 28 28 61 64 6a 2d 63 70 75 2d 6c 6f 61 t '((adj-cpu-loa
d060: 64 20 2e 20 6e 6f 72 6d 61 6c 69 7a 65 64 2d 70 d . normalized-p
d070: 72 6f 63 2d 6c 6f 61 64 29 20 2e 2e 2e 20 65 74 roc-load) ... et
d080: 63 2e 0a 3b 3b 20 20 6b 65 79 73 3a 20 61 64 6a c..;; keys: adj
d090: 2d 70 72 6f 63 2d 6c 6f 61 64 2c 20 61 64 6a 2d -proc-load, adj-
d0a0: 63 6f 72 65 2d 6c 6f 61 64 2c 20 31 6d 2d 6c 6f core-load, 1m-lo
d0b0: 61 64 2c 20 35 6d 2d 6c 6f 61 64 2c 20 31 35 6d ad, 5m-load, 15m
d0c0: 2d 6c 6f 61 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 -load.;;.(define
d0d0: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e 6f 72 (common:get-nor
d0e0: 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f 61 64 malized-cpu-load
d0f0: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 0a 20 20 remote-host).
d100: 28 6c 65 74 20 28 28 64 61 74 61 20 28 69 66 20 (let ((data (if
d110: 72 65 6d 6f 74 65 2d 68 6f 73 74 0a 20 20 20 20 remote-host.
d120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 77 (w
d130: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
d140: 69 70 65 20 0a 20 20 20 20 20 20 20 20 20 20 20 ipe .
d150: 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 73 (conc "s
d160: 73 68 20 22 20 72 65 6d 6f 74 65 2d 68 6f 73 74 sh " remote-host
d170: 20 22 20 63 61 74 20 2f 70 72 6f 63 2f 6c 6f 61 " cat /proc/loa
d180: 64 61 76 67 3b 63 61 74 20 2f 70 72 6f 63 2f 63 davg;cat /proc/c
d190: 70 75 69 6e 66 6f 3b 65 63 68 6f 20 65 6e 64 22 puinfo;echo end"
d1a0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
d1b0: 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 read-lines)
d1c0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d1d0: 20 20 20 28 61 70 70 65 6e 64 20 0a 20 20 20 20 (append .
d1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d1f0: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
d200: 66 69 6c 65 20 22 2f 70 72 6f 63 2f 6c 6f 61 64 file "/proc/load
d210: 61 76 67 22 20 0a 20 20 20 20 20 20 20 20 20 20 avg" .
d220: 20 20 20 20 20 20 20 20 20 20 20 72 65 61 64 2d read-
d230: 6c 69 6e 65 73 29 0a 20 20 20 20 20 20 20 20 20 lines).
d240: 20 20 20 20 20 20 20 20 20 20 28 77 69 74 68 2d (with-
d250: 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c 65 20 input-from-file
d260: 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f 22 0a "/proc/cpuinfo".
d270: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d280: 20 20 20 20 20 72 65 61 64 2d 6c 69 6e 65 73 29 read-lines)
d290: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d2a0: 20 20 20 20 28 6c 69 73 74 20 22 65 6e 64 22 29 (list "end")
d2b0: 29 29 29 0a 20 20 20 20 20 20 20 20 28 6c 6f 61 ))). (loa
d2c0: 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e d-rx (regexp "^
d2d0: 28 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 ([\\d\\.]+)\\s+(
d2e0: 5b 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 28 5b [\\d\\.]+)\\s+([
d2f0: 5c 5c 64 5c 5c 2e 5d 2b 29 5c 5c 73 2b 2e 2a 24 \\d\\.]+)\\s+.*$
d300: 22 29 29 0a 20 20 20 20 20 20 20 20 28 70 72 6f ")). (pro
d310: 63 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 5e c-rx (regexp "^
d320: 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a 5c 5c processor\\s+:\\
d330: 73 2b 28 5c 5c 64 2b 29 5c 5c 73 2a 24 22 29 29 s+(\\d+)\\s*$"))
d340: 0a 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d 72 . (core-r
d350: 78 20 20 28 72 65 67 65 78 70 20 22 5e 63 6f 72 x (regexp "^cor
d360: 65 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c e id\\s+:\\s+(\\
d370: 64 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 d+)\\s*$")).
d380: 20 20 20 20 28 70 68 79 73 2d 72 78 20 20 28 72 (phys-rx (r
d390: 65 67 65 78 70 20 22 5e 70 68 79 73 69 63 61 6c egexp "^physical
d3a0: 20 69 64 5c 5c 73 2b 3a 5c 5c 73 2b 28 5c 5c 64 id\\s+:\\s+(\\d
d3b0: 2b 29 5c 5c 73 2a 24 22 29 29 0a 20 20 20 20 20 +)\\s*$")).
d3c0: 20 20 20 28 6d 61 78 2d 6e 75 6d 20 20 28 6c 61 (max-num (la
d3d0: 6d 62 64 61 20 28 70 20 6e 29 28 6d 61 78 20 28 mbda (p n)(max (
d3e0: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 70 string->number p
d3f0: 29 20 6e 29 29 29 29 0a 20 20 20 20 3b 3b 20 28 ) n)))). ;; (
d400: 70 72 69 6e 74 20 22 64 61 74 61 3d 22 20 64 61 print "data=" da
d410: 74 61 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c ta). (if (nul
d420: 6c 3f 20 64 61 74 61 29 20 3b 3b 20 73 6f 6d 65 l? data) ;; some
d430: 74 68 69 6e 67 20 77 65 6e 74 20 77 72 6f 6e 67 thing went wrong
d440: 0a 20 20 20 20 20 20 20 20 23 66 0a 20 20 20 20 . #f.
d450: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
d460: 68 65 64 20 20 20 20 20 20 28 63 61 72 20 64 61 hed (car da
d470: 74 61 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 ta)).
d480: 20 20 20 20 20 20 20 20 28 74 61 6c 20 20 20 20 (tal
d490: 20 20 28 63 64 72 20 64 61 74 61 29 29 0a 20 20 (cdr data)).
d4a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4b0: 20 28 6c 6f 61 64 73 20 20 20 20 23 66 29 0a 20 (loads #f).
d4c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d4d0: 20 20 28 70 72 6f 63 2d 6e 75 6d 20 30 29 20 20 (proc-num 0)
d4e0: 3b 3b 20 70 72 6f 63 65 73 73 6f 72 20 69 6e 63 ;; processor inc
d4f0: 6c 75 64 65 73 20 74 68 72 65 61 64 73 0a 20 20 ludes threads.
d500: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d510: 20 28 70 68 79 73 2d 6e 75 6d 20 30 29 20 20 3b (phys-num 0) ;
d520: 3b 20 70 68 79 73 69 63 61 6c 20 63 68 69 70 20 ; physical chip
d530: 6f 6e 20 6d 6f 74 68 65 72 62 6f 61 72 64 0a 20 on motherboard.
d540: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d550: 20 20 28 63 6f 72 65 2d 6e 75 6d 20 30 29 29 20 (core-num 0))
d560: 3b 3b 20 63 6f 72 65 0a 20 20 20 20 20 20 20 20 ;; core.
d570: 20 20 3b 3b 20 28 70 72 69 6e 74 20 68 65 64 20 ;; (print hed
d580: 22 2c 20 22 20 6c 6f 61 64 73 20 22 2c 20 22 20 ", " loads ", "
d590: 70 72 6f 63 2d 6e 75 6d 20 22 2c 20 22 20 70 68 proc-num ", " ph
d5a0: 79 73 2d 6e 75 6d 20 22 2c 20 22 20 63 6f 72 65 ys-num ", " core
d5b0: 2d 6e 75 6d 29 0a 20 20 20 20 20 20 20 20 20 20 -num).
d5c0: 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 20 (if (null? tal)
d5d0: 3b 3b 20 68 61 76 65 20 61 6c 6c 20 6f 75 72 20 ;; have all our
d5e0: 64 61 74 61 2c 20 63 61 6c 63 75 6c 61 74 65 20 data, calculate
d5f0: 6e 6f 72 6d 61 6c 69 7a 65 64 20 6c 6f 61 64 20 normalized load
d600: 61 6e 64 20 72 65 74 75 72 6e 20 72 65 73 75 6c and return resul
d610: 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 t.
d620: 28 6c 65 74 2a 20 28 28 61 63 74 2d 70 72 6f 63 (let* ((act-proc
d630: 20 28 2b 20 70 72 6f 63 2d 6e 75 6d 20 31 29 29 (+ proc-num 1))
d640: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d650: 20 20 20 20 20 20 28 61 63 74 2d 70 68 79 73 20 (act-phys
d660: 28 2b 20 70 68 79 73 2d 6e 75 6d 20 31 29 29 0a (+ phys-num 1)).
d670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d680: 20 20 20 20 20 28 61 63 74 2d 63 6f 72 65 20 28 (act-core (
d690: 2b 20 63 6f 72 65 2d 6e 75 6d 20 31 29 29 0a 20 + core-num 1)).
d6a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6b0: 20 20 20 20 28 61 64 6a 2d 70 72 6f 63 2d 6c 6f (adj-proc-lo
d6c0: 61 64 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 ad (/ (car loads
d6d0: 29 20 61 63 74 2d 70 72 6f 63 29 29 0a 20 20 20 ) act-proc)).
d6e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d6f0: 20 20 28 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 (adj-core-load
d700: 20 28 2f 20 28 63 61 72 20 6c 6f 61 64 73 29 20 (/ (car loads)
d710: 61 63 74 2d 63 6f 72 65 29 29 29 0a 20 20 20 20 act-core))).
d720: 20 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 (app
d730: 65 6e 64 20 28 6c 69 73 74 20 28 63 6f 6e 73 20 end (list (cons
d740: 27 61 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 20 61 'adj-proc-load a
d750: 64 6a 2d 70 72 6f 63 2d 6c 6f 61 64 29 0a 20 20 dj-proc-load).
d760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d770: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e (con
d780: 73 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 s 'adj-core-load
d790: 20 61 64 6a 2d 63 6f 72 65 2d 6c 6f 61 64 29 29 adj-core-load))
d7a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
d7b0: 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 20 28 (list (
d7c0: 63 6f 6e 73 20 27 31 6d 2d 6c 6f 61 64 20 28 63 cons '1m-load (c
d7d0: 61 72 20 6c 6f 61 64 73 29 29 0a 20 20 20 20 20 ar loads)).
d7e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d7f0: 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 27 (cons '
d800: 35 6d 2d 6c 6f 61 64 20 28 63 61 64 72 20 6c 6f 5m-load (cadr lo
d810: 61 64 73 29 29 0a 20 20 20 20 20 20 20 20 20 20 ads)).
d820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d830: 20 20 20 20 28 63 6f 6e 73 20 27 31 35 6d 2d 6c (cons '15m-l
d840: 6f 61 64 20 28 63 61 64 64 72 20 6c 6f 61 64 73 oad (caddr loads
d850: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
d860: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 (lis
d870: 74 20 28 63 6f 6e 73 20 27 70 72 6f 63 20 61 63 t (cons 'proc ac
d880: 74 2d 70 72 6f 63 29 0a 20 20 20 20 20 20 20 20 t-proc).
d890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8a0: 20 20 20 20 20 20 28 63 6f 6e 73 20 27 63 6f 72 (cons 'cor
d8b0: 65 20 61 63 74 2d 63 6f 72 65 29 0a 20 20 20 20 e act-core).
d8c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
d8d0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 73 20 (cons
d8e0: 27 70 68 79 73 20 61 63 74 2d 70 68 79 73 29 29 'phys act-phys))
d8f0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
d900: 20 28 72 65 67 65 78 2d 63 61 73 65 0a 20 20 20 (regex-case.
d910: 20 20 20 20 20 20 20 20 20 20 20 20 68 65 64 0a hed.
d920: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
d930: 6c 6f 61 64 2d 72 78 20 20 28 20 78 20 6c 31 20 load-rx ( x l1
d940: 6c 35 20 6c 31 35 20 29 20 28 6c 6f 6f 70 20 28 l5 l15 ) (loop (
d950: 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c car tal)(cdr tal
d960: 29 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e 75 )(map string->nu
d970: 6d 62 65 72 20 28 6c 69 73 74 20 6c 31 20 6c 35 mber (list l1 l5
d980: 20 6c 31 35 29 29 20 70 72 6f 63 2d 6e 75 6d 20 l15)) proc-num
d990: 70 68 79 73 2d 6e 75 6d 20 63 6f 72 65 2d 6e 75 phys-num core-nu
d9a0: 6d 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 m)).
d9b0: 20 20 20 28 70 72 6f 63 2d 72 78 20 20 28 20 78 (proc-rx ( x
d9c0: 20 70 20 20 20 20 20 20 20 20 20 29 20 28 6c 6f p ) (lo
d9d0: 6f 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 op (car tal)(cdr
d9e0: 20 74 61 6c 29 20 6c 6f 61 64 73 20 20 20 20 20 tal) loads
d9f0: 20 20 20 20 20 20 28 6d 61 78 2d 6e 75 6d 20 70 (max-num p
da00: 20 70 72 6f 63 2d 6e 75 6d 29 20 70 68 79 73 2d proc-num) phys-
da10: 6e 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 0a 20 num core-num)).
da20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 70 (p
da30: 68 79 73 2d 72 78 20 20 28 20 78 20 70 20 20 20 hys-rx ( x p
da40: 20 20 20 20 20 20 29 20 28 6c 6f 6f 70 20 28 63 ) (loop (c
da50: 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 6c 29 ar tal)(cdr tal)
da60: 20 6c 6f 61 64 73 20 20 20 20 20 20 20 20 20 20 loads
da70: 20 70 72 6f 63 2d 6e 75 6d 20 28 6d 61 78 2d 6e proc-num (max-n
da80: 75 6d 20 70 20 70 68 79 73 2d 6e 75 6d 29 20 63 um p phys-num) c
da90: 6f 72 65 2d 6e 75 6d 29 29 0a 20 20 20 20 20 20 ore-num)).
daa0: 20 20 20 20 20 20 20 20 20 28 63 6f 72 65 2d 72 (core-r
dab0: 78 20 20 28 20 78 20 63 20 20 20 20 20 20 20 20 x ( x c
dac0: 20 29 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 ) (loop (car ta
dad0: 6c 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 l)(cdr tal) load
dae0: 73 20 20 20 20 20 20 20 20 20 20 20 70 72 6f 63 s proc
daf0: 2d 6e 75 6d 20 70 68 79 73 2d 6e 75 6d 20 28 6d -num phys-num (m
db00: 61 78 2d 6e 75 6d 20 63 20 63 6f 72 65 2d 6e 75 ax-num c core-nu
db10: 6d 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 m))).
db20: 20 20 20 20 28 65 6c 73 65 20 0a 20 20 20 20 20 (else .
db30: 20 20 20 20 20 20 20 20 20 20 20 28 62 65 67 69 (begi
db40: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 n.
db50: 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 4e ;; (print "N
db60: 4f 20 4d 41 54 43 48 3a 20 22 20 68 65 64 29 0a O MATCH: " hed).
db70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
db80: 20 20 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c (loop (car tal
db90: 29 28 63 64 72 20 74 61 6c 29 20 6c 6f 61 64 73 )(cdr tal) loads
dba0: 20 70 72 6f 63 2d 6e 75 6d 20 70 68 79 73 2d 6e proc-num phys-n
dbb0: 75 6d 20 63 6f 72 65 2d 6e 75 6d 29 29 29 29 29 um core-num)))))
dbc0: 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 ))))..(define (c
dbd0: 6f 6d 6d 6f 6e 3a 75 6e 69 78 2d 70 69 6e 67 20 ommon:unix-ping
dbe0: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 hostname). (let
dbf0: 20 28 28 72 65 73 20 28 73 79 73 74 65 6d 20 28 ((res (system (
dc00: 63 6f 6e 63 20 22 70 69 6e 67 20 2d 63 20 31 20 conc "ping -c 1
dc10: 22 20 68 6f 73 74 6e 61 6d 65 20 22 20 3e 20 2f " hostname " > /
dc20: 64 65 76 2f 6e 75 6c 6c 22 29 29 29 29 0a 20 20 dev/null")))).
dc30: 20 20 28 65 71 3f 20 72 65 73 20 30 29 29 29 0a (eq? res 0))).
dc40: 0a 3b 3b 20 69 64 65 61 6c 6c 79 20 70 75 74 20 .;; ideally put
dc50: 61 6c 6c 20 74 68 69 73 20 69 6e 66 6f 20 69 6e all this info in
dc60: 74 6f 20 74 68 65 20 64 62 2c 20 6e 6f 20 6e 65 to the db, no ne
dc70: 65 64 20 74 6f 20 70 72 65 73 65 72 76 65 20 69 ed to preserve i
dc80: 74 20 61 63 72 6f 73 73 20 6d 6f 76 69 6e 67 20 t across moving
dc90: 68 6f 6d 65 68 6f 73 74 0a 3b 3b 0a 3b 3b 20 72 homehost.;;.;; r
dca0: 65 74 75 72 6e 20 6c 69 73 74 20 6f 66 0a 3b 3b eturn list of.;;
dcb0: 20 20 28 20 72 65 61 63 68 61 62 6c 65 3f 20 63 ( reachable? c
dcc0: 70 75 6c 6f 61 64 20 75 70 64 61 74 65 2d 74 69 puload update-ti
dcd0: 6d 65 20 29 0a 28 64 65 66 69 6e 65 20 28 63 6f me ).(define (co
dce0: 6d 6d 6f 6e 3a 67 65 74 2d 68 6f 73 74 2d 69 6e mmon:get-host-in
dcf0: 66 6f 20 68 6f 73 74 6e 61 6d 65 29 0a 20 20 28 fo hostname). (
dd00: 6c 65 74 2a 20 28 28 6c 6f 61 64 69 6e 66 6f 20 let* ((loadinfo
dd10: 28 72 6d 74 3a 67 65 74 2d 6c 61 74 65 73 74 2d (rmt:get-latest-
dd20: 68 6f 73 74 2d 6c 6f 61 64 20 68 6f 73 74 6e 61 host-load hostna
dd30: 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c me)). (l
dd40: 6f 61 64 20 28 63 61 72 20 6c 6f 61 64 69 6e 66 oad (car loadinf
dd50: 6f 29 29 0a 20 20 20 20 20 20 20 20 20 28 6c 6f o)). (lo
dd60: 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 20 28 ad-sample-time (
dd70: 63 64 72 20 6c 6f 61 64 69 6e 66 6f 29 29 0a 20 cdr loadinfo)).
dd80: 20 20 20 20 20 20 20 20 28 6c 6f 61 64 2d 73 61 (load-sa
dd90: 6d 70 6c 65 2d 61 67 65 20 28 2d 20 28 63 75 72 mple-age (- (cur
dda0: 72 65 6e 74 2d 73 65 63 6f 6e 64 73 29 20 6c 6f rent-seconds) lo
ddb0: 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 29 29 ad-sample-time))
ddc0: 0a 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 69 . (loadi
ddd0: 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f nfo-timeout-seco
dde0: 6e 64 73 20 32 30 29 0a 20 20 20 20 20 20 20 20 nds 20).
ddf0: 20 28 68 6f 73 74 2d 6c 61 73 74 2d 75 70 64 61 (host-last-upda
de00: 74 65 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f 6e te-timeout-secon
de10: 64 73 20 31 30 29 0a 20 20 20 20 20 20 20 20 20 ds 10).
de20: 28 68 6f 73 74 2d 72 65 63 20 28 68 61 73 68 2d (host-rec (hash-
de30: 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c table-ref/defaul
de40: 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 68 t *host-loads* h
de50: 6f 73 74 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 ostname #f)).
de60: 20 20 20 20 20 20 29 0a 20 20 20 20 28 63 6f 6e ). (con
de70: 64 0a 20 20 20 20 20 28 28 3c 20 6c 6f 61 64 2d d. ((< load-
de80: 73 61 6d 70 6c 65 2d 61 67 65 20 6c 6f 61 64 69 sample-age loadi
de90: 6e 66 6f 2d 74 69 6d 65 6f 75 74 2d 73 65 63 6f nfo-timeout-seco
dea0: 6e 64 73 29 0a 20 20 20 20 20 20 28 6c 69 73 74 nds). (list
deb0: 20 23 74 0a 20 20 20 20 20 20 20 20 20 20 20 20 #t.
dec0: 6c 6f 61 64 2d 73 61 6d 70 6c 65 2d 74 69 6d 65 load-sample-time
ded0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 6c 6f 61 . loa
dee0: 64 29 29 0a 20 20 20 20 20 28 28 61 6e 64 20 68 d)). ((and h
def0: 6f 73 74 2d 72 65 63 0a 20 20 20 20 20 20 20 20 ost-rec.
df00: 20 20 20 28 3c 20 28 63 75 72 72 65 6e 74 2d 73 (< (current-s
df10: 65 63 6f 6e 64 73 29 20 28 2b 20 28 68 6f 73 74 econds) (+ (host
df20: 2d 6c 61 73 74 2d 75 70 64 61 74 65 20 68 6f 73 -last-update hos
df30: 74 2d 72 65 63 29 20 68 6f 73 74 2d 6c 61 73 74 t-rec) host-last
df40: 2d 75 70 64 61 74 65 2d 74 69 6d 65 6f 75 74 2d -update-timeout-
df50: 73 65 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 20 seconds))).
df60: 20 28 6c 69 73 74 20 23 74 0a 20 20 20 20 20 20 (list #t.
df70: 20 20 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 (host-last
df80: 2d 75 70 64 61 74 65 20 68 6f 73 74 2d 72 65 63 -update host-rec
df90: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 68 ). (h
dfa0: 6f 73 74 2d 6c 61 73 74 2d 63 70 75 6c 6f 61 64 ost-last-cpuload
dfb0: 20 68 6f 73 74 2d 72 65 63 20 29 29 29 0a 20 20 host-rec ))).
dfc0: 20 20 20 28 28 63 6f 6d 6d 6f 6e 3a 75 6e 69 78 ((common:unix
dfd0: 2d 70 69 6e 67 20 68 6f 73 74 6e 61 6d 65 29 0a -ping hostname).
dfe0: 20 20 20 20 20 20 28 6c 69 73 74 20 23 74 0a 20 (list #t.
dff0: 20 20 20 20 20 20 20 20 20 20 20 28 63 75 72 72 (curr
e000: 65 6e 74 2d 73 65 63 6f 6e 64 73 29 0a 20 20 20 ent-seconds).
e010: 20 20 20 20 20 20 20 20 20 28 61 6c 69 73 74 2d (alist-
e020: 72 65 66 20 27 61 64 6a 2d 63 6f 72 65 2d 6c 6f ref 'adj-core-lo
e030: 61 64 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6e ad (common:get-n
e040: 6f 72 6d 61 6c 69 7a 65 64 2d 63 70 75 2d 6c 6f ormalized-cpu-lo
e050: 61 64 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a ad hostname)))).
e060: 20 20 20 20 20 28 65 6c 73 65 0a 20 20 20 20 20 (else.
e070: 20 28 6c 69 73 74 20 23 66 20 30 20 2d 31 29 29 (list #f 0 -1))
e080: 29 29 29 0a 20 20 20 20 0a 28 64 65 66 69 6e 65 ))). .(define
e090: 20 28 63 6f 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d (common:update-
e0a0: 68 6f 73 74 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 host-loads-table
e0b0: 20 68 6f 73 74 73 2d 72 61 77 29 0a 20 20 28 6c hosts-raw). (l
e0c0: 65 74 2a 20 28 28 68 6f 73 74 73 20 28 66 69 6c et* ((hosts (fil
e0d0: 74 65 72 20 28 6c 61 6d 62 64 61 20 28 78 29 0a ter (lambda (x).
e0e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e0f0: 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e (strin
e100: 67 2d 6d 61 74 63 68 20 28 72 65 67 65 78 70 20 g-match (regexp
e110: 22 5e 5c 5c 53 2b 24 22 29 20 78 29 29 0a 20 20 "^\\S+$") x)).
e120: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e130: 20 20 20 20 20 20 68 6f 73 74 73 2d 72 61 77 29 hosts-raw)
e140: 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
e150: 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 68 . (lambda (h
e160: 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 20 ostname).
e170: 28 6c 65 74 2a 20 28 28 72 65 63 20 20 20 20 20 (let* ((rec
e180: 20 20 28 6c 65 74 20 28 28 68 20 28 68 61 73 68 (let ((h (hash
e190: 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
e1a0: 6c 74 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 2a 20 lt *host-loads*
e1b0: 68 6f 73 74 6e 61 6d 65 20 23 66 29 29 29 0a 20 hostname #f))).
e1c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1d0: 20 20 20 20 20 20 20 20 20 28 69 66 20 68 0a 20 (if h.
e1e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e1f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 68 0a 20 h.
e200: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e210: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
e220: 74 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 t ((h (make-host
e230: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
e240: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e250: 20 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d (hash-table-
e260: 73 65 74 21 20 2a 68 6f 73 74 2d 6c 6f 61 64 73 set! *host-loads
e270: 2a 20 68 6f 73 74 6e 61 6d 65 20 68 29 0a 20 20 * hostname h).
e280: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e290: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 68 29 h)
e2a0: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
e2b0: 20 20 28 68 6f 73 74 2d 69 6e 66 6f 20 20 20 20 (host-info
e2c0: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
e2d0: 2d 68 6f 73 74 2d 69 6e 66 6f 20 68 6f 73 74 6e -host-info hostn
e2e0: 61 6d 65 29 29 0a 20 20 20 20 20 20 20 20 20 20 ame)).
e2f0: 20 20 20 20 28 69 73 2d 72 65 61 63 68 61 62 6c (is-reachabl
e300: 65 20 20 20 20 20 20 28 63 61 72 20 68 6f 73 74 e (car host
e310: 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 20 20 20 -info)).
e320: 20 20 20 20 20 20 28 6c 61 73 74 2d 72 65 61 63 (last-reac
e330: 68 65 64 2d 74 69 6d 65 20 28 63 61 64 72 20 68 hed-time (cadr h
e340: 6f 73 74 2d 69 6e 66 6f 29 29 0a 20 20 20 20 20 ost-info)).
e350: 20 20 20 20 20 20 20 20 20 28 6c 6f 61 64 20 20 (load
e360: 20 20 20 20 20 20 20 20 20 20 20 20 28 63 61 64 (cad
e370: 64 72 20 68 6f 73 74 2d 69 6e 66 6f 29 29 29 0a dr host-info))).
e380: 20 20 20 20 20 20 20 20 20 28 68 6f 73 74 2d 72 (host-r
e390: 65 61 63 68 61 62 6c 65 2d 73 65 74 21 20 20 20 eachable-set!
e3a0: 20 72 65 63 20 69 73 2d 72 65 61 63 68 61 62 6c rec is-reachabl
e3b0: 65 29 0a 20 20 20 20 20 20 20 20 20 28 68 6f 73 e). (hos
e3c0: 74 2d 6c 61 73 74 2d 75 70 64 61 74 65 2d 73 65 t-last-update-se
e3d0: 74 21 20 20 72 65 63 20 6c 61 73 74 2d 72 65 61 t! rec last-rea
e3e0: 63 68 65 64 2d 74 69 6d 65 29 0a 20 20 20 20 20 ched-time).
e3f0: 20 20 20 20 28 68 6f 73 74 2d 6c 61 73 74 2d 63 (host-last-c
e400: 70 75 6c 6f 61 64 2d 73 65 74 21 20 72 65 63 20 puload-set! rec
e410: 6c 6f 61 64 29 29 29 0a 20 20 20 20 20 68 6f 73 load))). hos
e420: 74 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 ts)))..(define (
e430: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c 65 61 73 74 common:get-least
e440: 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 20 68 6f 73 -loaded-host hos
e450: 74 73 2d 72 61 77 29 0a 20 20 28 6c 65 74 2a 20 ts-raw). (let*
e460: 28 28 68 6f 73 74 73 20 28 66 69 6c 74 65 72 20 ((hosts (filter
e470: 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 20 20 20 (lambda (x).
e480: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e490: 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 6d 61 (string-ma
e4a0: 74 63 68 20 28 72 65 67 65 78 70 20 22 5e 5c 5c tch (regexp "^\\
e4b0: 53 2b 24 22 29 20 78 29 29 0a 20 20 20 20 20 20 S+$") x)).
e4c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e4d0: 20 20 68 6f 73 74 73 2d 72 61 77 29 29 0a 20 20 hosts-raw)).
e4e0: 20 20 20 20 20 20 20 28 62 65 73 74 2d 68 6f 73 (best-hos
e4f0: 74 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 28 t #f). (
e500: 62 65 73 74 2d 6c 6f 61 64 20 39 39 39 39 39 29 best-load 99999)
e510: 0a 20 20 20 20 20 20 20 20 20 28 63 75 72 72 2d . (curr-
e520: 74 69 6d 65 20 28 63 75 72 72 65 6e 74 2d 73 65 time (current-se
e530: 63 6f 6e 64 73 29 29 29 0a 20 20 20 20 28 63 6f conds))). (co
e540: 6d 6d 6f 6e 3a 75 70 64 61 74 65 2d 68 6f 73 74 mmon:update-host
e550: 2d 6c 6f 61 64 73 2d 74 61 62 6c 65 20 68 6f 73 -loads-table hos
e560: 74 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ts). (for-eac
e570: 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 h. (lambda (
e580: 68 6f 73 74 6e 61 6d 65 29 0a 20 20 20 20 20 20 hostname).
e590: 20 28 6c 65 74 2a 20 28 28 72 65 63 0a 20 20 20 (let* ((rec.
e5a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
e5b0: 20 28 28 68 20 28 68 61 73 68 2d 74 61 62 6c 65 ((h (hash-table
e5c0: 2d 72 65 66 2f 64 65 66 61 75 6c 74 20 2a 68 6f -ref/default *ho
e5d0: 73 74 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 st-loads* hostna
e5e0: 6d 65 20 23 66 29 29 29 0a 20 20 20 20 20 20 20 me #f))).
e5f0: 20 20 20 20 20 20 20 20 20 20 28 69 66 20 68 0a (if h.
e600: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
e610: 20 20 20 20 20 68 0a 20 20 20 20 20 20 20 20 20 h.
e620: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
e630: 20 28 28 68 20 28 6d 61 6b 65 2d 68 6f 73 74 29 ((h (make-host)
e640: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
e650: 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 2d (hash-
e660: 74 61 62 6c 65 2d 73 65 74 21 20 2a 68 6f 73 74 table-set! *host
e670: 2d 6c 6f 61 64 73 2a 20 68 6f 73 74 6e 61 6d 65 -loads* hostname
e680: 20 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 h).
e690: 20 20 20 20 20 20 20 20 20 20 20 68 29 29 29 29 h))))
e6a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 . (
e6b0: 72 65 61 63 68 61 62 6c 65 20 28 68 6f 73 74 2d reachable (host-
e6c0: 72 65 61 63 68 61 62 6c 65 20 72 65 63 29 29 0a reachable rec)).
e6d0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
e6e0: 6f 61 64 20 20 20 20 20 20 28 68 6f 73 74 2d 6c oad (host-l
e6f0: 61 73 74 2d 63 70 75 6c 6f 61 64 20 20 20 72 65 ast-cpuload re
e700: 63 29 29 29 0a 20 20 20 20 20 20 20 20 20 28 63 c))). (c
e710: 6f 6e 64 0a 20 20 20 20 20 20 20 20 20 20 28 28 ond. ((
e720: 6e 6f 74 20 72 65 61 63 68 61 62 6c 65 29 20 23 not reachable) #
e730: 66 29 0a 20 20 20 20 20 20 20 20 20 20 28 28 3c f). ((<
e740: 20 28 2b 20 6c 6f 61 64 20 28 2f 20 28 72 61 6e (+ load (/ (ran
e750: 64 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 dom 250) 1000))
e760: 20 20 20 20 20 20 20 20 3b 3b 20 61 64 64 20 61 ;; add a
e770: 20 72 61 6e 64 6f 6d 20 66 61 63 74 6f 72 20 74 random factor t
e780: 6f 20 6b 65 65 70 20 66 72 6f 6d 20 67 65 74 74 o keep from gett
e790: 69 6e 67 20 69 6e 20 61 20 72 75 74 0a 20 20 20 ing in a rut.
e7a0: 20 20 20 20 20 20 20 20 20 20 20 28 2b 20 62 65 (+ be
e7b0: 73 74 2d 6c 6f 61 64 20 28 2f 20 28 72 61 6e 64 st-load (/ (rand
e7c0: 6f 6d 20 32 35 30 29 20 31 30 30 30 29 29 20 20 om 250) 1000))
e7d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 65 ). (se
e7e0: 74 21 20 62 65 73 74 2d 6c 6f 61 64 20 6c 6f 61 t! best-load loa
e7f0: 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 28 73 d). (s
e800: 65 74 21 20 62 65 73 74 2d 68 6f 73 74 20 68 6f et! best-host ho
e810: 73 74 6e 61 6d 65 29 29 29 29 29 0a 20 20 20 20 stname))))).
e820: 20 68 6f 73 74 73 29 0a 20 20 20 20 62 65 73 74 hosts). best
e830: 2d 68 6f 73 74 29 29 0a 0a 28 64 65 66 69 6e 65 -host))..(define
e840: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
e850: 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 r-cpuload maxloa
e860: 64 20 6e 75 6d 63 70 75 73 20 77 61 69 74 64 65 d numcpus waitde
e870: 6c 61 79 20 23 21 6b 65 79 20 28 63 6f 75 6e 74 lay #!key (count
e880: 20 31 30 30 30 29 20 28 6d 73 67 20 23 66 29 28 1000) (msg #f)(
e890: 72 65 6d 6f 74 65 2d 68 6f 73 74 20 23 66 29 29 remote-host #f))
e8a0: 0a 20 20 28 6c 65 74 2a 20 28 28 6c 6f 61 64 61 . (let* ((loada
e8b0: 76 67 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 vg (common:get-c
e8c0: 70 75 2d 6c 6f 61 64 20 72 65 6d 6f 74 65 2d 68 pu-load remote-h
e8d0: 6f 73 74 29 29 0a 09 20 28 66 69 72 73 74 20 20 ost)).. (first
e8e0: 20 28 63 61 72 20 6c 6f 61 64 61 76 67 29 29 0a (car loadavg)).
e8f0: 09 20 28 6e 65 78 74 20 20 20 20 28 63 61 64 72 . (next (cadr
e900: 20 6c 6f 61 64 61 76 67 29 29 0a 09 20 28 61 64 loadavg)).. (ad
e910: 6a 6c 6f 61 64 20 28 2a 20 6d 61 78 6c 6f 61 64 jload (* maxload
e920: 20 6e 75 6d 63 70 75 73 29 29 0a 09 20 28 6c 6f numcpus)).. (lo
e930: 61 64 6a 6d 70 20 28 2d 20 66 69 72 73 74 20 6e adjmp (- first n
e940: 65 78 74 29 29 29 0a 20 20 20 20 28 63 6f 6e 64 ext))). (cond
e950: 0a 20 20 20 20 20 28 28 61 6e 64 20 28 3e 20 66 . ((and (> f
e960: 69 72 73 74 20 61 64 6a 6c 6f 61 64 29 0a 09 20 irst adjload)..
e970: 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 29 0a 20 (> count 0)).
e980: 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e (debug:prin
e990: 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c t-info 0 *defaul
e9a0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 73 65 72 t-log-port* "ser
e9b0: 76 65 72 20 73 74 61 72 74 20 64 65 6c 61 79 65 ver start delaye
e9c0: 64 20 22 20 77 61 69 74 64 65 6c 61 79 20 22 20 d " waitdelay "
e9d0: 73 65 63 6f 6e 64 73 20 64 75 65 20 74 6f 20 6c seconds due to l
e9e0: 6f 61 64 20 22 20 66 69 72 73 74 20 22 20 65 78 oad " first " ex
e9f0: 63 65 65 64 69 6e 67 20 6d 61 78 20 6f 66 20 22 ceeding max of "
ea00: 20 61 64 6a 6c 6f 61 64 20 22 20 6f 6e 20 73 65 adjload " on se
ea10: 72 76 65 72 20 22 20 28 6f 72 20 72 65 6d 6f 74 rver " (or remot
ea20: 65 2d 68 6f 73 74 20 28 67 65 74 2d 68 6f 73 74 e-host (get-host
ea30: 2d 6e 61 6d 65 29 29 20 22 20 28 6e 6f 72 6d 61 -name)) " (norma
ea40: 6c 69 7a 65 64 20 6c 6f 61 64 2d 6c 69 6d 69 74 lized load-limit
ea50: 3a 20 22 20 6d 61 78 6c 6f 61 64 20 22 29 20 22 : " maxload ") "
ea60: 20 28 69 66 20 6d 73 67 20 6d 73 67 20 22 22 29 (if msg msg "")
ea70: 29 0a 20 20 20 20 20 20 28 74 68 72 65 61 64 2d ). (thread-
ea80: 73 6c 65 65 70 21 20 77 61 69 74 64 65 6c 61 79 sleep! waitdelay
ea90: 29 0a 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a ). (common:
eaa0: 77 61 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 wait-for-cpuload
eab0: 20 6d 61 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 maxload numcpus
eac0: 20 77 61 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 waitdelay count
ead0: 3a 20 28 2d 20 63 6f 75 6e 74 20 31 29 20 6d 73 : (- count 1) ms
eae0: 67 3a 20 6d 73 67 20 72 65 6d 6f 74 65 2d 68 6f g: msg remote-ho
eaf0: 73 74 3a 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 st: remote-host)
eb00: 29 0a 20 20 20 20 20 28 28 61 6e 64 20 28 3e 20 ). ((and (>
eb10: 6c 6f 61 64 6a 6d 70 20 6e 75 6d 63 70 75 73 29 loadjmp numcpus)
eb20: 0a 09 20 20 20 28 3e 20 63 6f 75 6e 74 20 30 29 .. (> count 0)
eb30: 29 0a 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 ). (debug:p
eb40: 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 rint-info 0 *def
eb50: 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 ault-log-port* "
eb60: 77 61 69 74 69 6e 67 20 22 20 77 61 69 74 64 65 waiting " waitde
eb70: 6c 61 79 20 22 20 73 65 63 6f 6e 64 73 20 64 75 lay " seconds du
eb80: 65 20 74 6f 20 6c 6f 61 64 20 6a 75 6d 70 20 22 e to load jump "
eb90: 20 6c 6f 61 64 6a 6d 70 20 22 20 3e 20 6e 75 6d loadjmp " > num
eba0: 63 70 75 73 20 22 20 6e 75 6d 63 70 75 73 20 28 cpus " numcpus (
ebb0: 69 66 20 6d 73 67 20 6d 73 67 20 22 22 29 29 0a if msg msg "")).
ebc0: 20 20 20 20 20 20 28 74 68 72 65 61 64 2d 73 6c (thread-sl
ebd0: 65 65 70 21 20 77 61 69 74 64 65 6c 61 79 29 0a eep! waitdelay).
ebe0: 20 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 77 61 (common:wa
ebf0: 69 74 2d 66 6f 72 2d 63 70 75 6c 6f 61 64 20 6d it-for-cpuload m
ec00: 61 78 6c 6f 61 64 20 6e 75 6d 63 70 75 73 20 77 axload numcpus w
ec10: 61 69 74 64 65 6c 61 79 20 63 6f 75 6e 74 3a 20 aitdelay count:
ec20: 28 2d 20 63 6f 75 6e 74 20 31 29 20 6d 73 67 3a (- count 1) msg:
ec30: 20 6d 73 67 20 72 65 6d 6f 74 65 2d 68 6f 73 74 msg remote-host
ec40: 3a 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 29 29 : remote-host)))
ec50: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d ))..(define (com
ec60: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 68 6f 6d mon:wait-for-hom
ec70: 65 68 6f 73 74 2d 6c 6f 61 64 20 6d 61 78 6c 6f ehost-load maxlo
ec80: 61 64 20 6d 73 67 29 0a 20 20 28 6c 65 74 2a 20 ad msg). (let*
ec90: 28 28 68 68 2d 64 61 74 20 28 69 66 20 28 63 6f ((hh-dat (if (co
eca0: 6d 6d 6f 6e 3a 6f 6e 2d 68 6f 6d 65 68 6f 73 74 mmon:on-homehost
ecb0: 3f 29 20 3b 3b 20 69 66 20 77 65 20 61 72 65 20 ?) ;; if we are
ecc0: 6f 6e 20 74 68 65 20 68 6f 6d 65 68 6f 73 74 20 on the homehost
ecd0: 74 68 65 6e 20 70 61 73 73 20 69 6e 20 23 66 20 then pass in #f
ece0: 73 6f 20 74 68 65 20 63 61 6c 6c 73 20 61 72 65 so the calls are
ecf0: 20 6c 6f 63 61 6c 2e 0a 20 20 20 20 20 20 20 20 local..
ed00: 20 20 20 20 20 20 20 20 20 20 20 20 20 23 66 0a #f.
ed10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
ed20: 20 20 20 20 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 (common:get
ed30: 2d 68 6f 6d 65 68 6f 73 74 29 29 29 0a 20 20 20 -homehost))).
ed40: 20 20 20 20 20 20 28 68 68 20 20 20 20 20 28 69 (hh (i
ed50: 66 20 68 68 2d 64 61 74 20 28 63 61 72 20 68 68 f hh-dat (car hh
ed60: 2d 64 61 74 29 20 23 66 29 29 0a 20 20 20 20 20 -dat) #f)).
ed70: 20 20 20 20 28 6e 75 6d 63 70 75 73 20 28 63 6f (numcpus (co
ed80: 6d 6d 6f 6e 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 mmon:get-num-cpu
ed90: 73 20 68 68 29 29 29 0a 20 20 20 20 28 63 6f 6d s hh))). (com
eda0: 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f 72 mon:wait-for-nor
edb0: 6d 61 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 78 malized-load max
edc0: 6c 6f 61 64 20 6d 73 67 20 68 68 29 29 29 0a 0a load msg hh)))..
edd0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
ede0: 67 65 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 6d get-num-cpus rem
edf0: 6f 74 65 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 ote-host). (let
ee00: 20 28 28 70 72 6f 63 20 28 6c 61 6d 62 64 61 20 ((proc (lambda
ee10: 28 29 0a 09 09 28 6c 65 74 20 6c 6f 6f 70 20 28 ()...(let loop (
ee20: 28 6e 75 6d 63 70 75 20 30 29 0a 09 09 09 20 20 (numcpu 0)....
ee30: 20 28 69 6e 6c 20 20 20 20 28 72 65 61 64 2d 6c (inl (read-l
ee40: 69 6e 65 29 29 29 0a 09 09 20 20 28 69 66 20 28 ine)))... (if (
ee50: 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 eof-object? inl)
ee60: 0a 09 09 20 20 20 20 20 20 6e 75 6d 63 70 75 0a ... numcpu.
ee70: 09 09 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 69 .. (loop (i
ee80: 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 63 68 20 f (string-match
ee90: 22 5e 70 72 6f 63 65 73 73 6f 72 5c 5c 73 2b 3a "^processor\\s+:
eea0: 5c 5c 73 2b 5c 5c 64 2b 24 22 20 69 6e 6c 29 0a \\s+\\d+$" inl).
eeb0: 09 09 09 09 28 2b 20 6e 75 6d 63 70 75 20 31 29 ....(+ numcpu 1)
eec0: 0a 09 09 09 09 6e 75 6d 63 70 75 29 0a 09 09 09 .....numcpu)....
eed0: 20 20 20 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 (read-line))
eee0: 29 29 29 29 29 0a 20 20 20 20 28 69 66 20 72 65 ))))). (if re
eef0: 6d 6f 74 65 2d 68 6f 73 74 0a 09 28 77 69 74 68 mote-host..(with
ef00: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
ef10: 20 0a 09 20 28 63 6f 6e 63 20 22 73 73 68 20 22 .. (conc "ssh "
ef20: 20 72 65 6d 6f 74 65 2d 68 6f 73 74 20 22 20 63 remote-host " c
ef30: 61 74 20 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f at /proc/cpuinfo
ef40: 22 29 0a 09 20 70 72 6f 63 29 0a 09 28 77 69 74 ").. proc)..(wit
ef50: 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 66 69 6c h-input-from-fil
ef60: 65 20 22 2f 70 72 6f 63 2f 63 70 75 69 6e 66 6f e "/proc/cpuinfo
ef70: 22 20 70 72 6f 63 29 29 29 29 0a 0a 3b 3b 20 77 " proc))))..;; w
ef80: 61 69 74 20 66 6f 72 20 6e 6f 72 6d 61 6c 69 7a ait for normaliz
ef90: 65 64 20 63 70 75 20 6c 6f 61 64 20 74 6f 20 64 ed cpu load to d
efa0: 72 6f 70 20 62 65 6c 6f 77 20 6d 61 78 6c 6f 61 rop below maxloa
efb0: 64 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f d.;;.(define (co
efc0: 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f 72 2d 6e 6f mmon:wait-for-no
efd0: 72 6d 61 6c 69 7a 65 64 2d 6c 6f 61 64 20 6d 61 rmalized-load ma
efe0: 78 6c 6f 61 64 20 6d 73 67 20 72 65 6d 6f 74 65 xload msg remote
eff0: 2d 68 6f 73 74 29 0a 20 20 28 6c 65 74 20 28 28 -host). (let ((
f000: 6e 75 6d 2d 63 70 75 73 20 28 63 6f 6d 6d 6f 6e num-cpus (common
f010: 3a 67 65 74 2d 6e 75 6d 2d 63 70 75 73 20 72 65 :get-num-cpus re
f020: 6d 6f 74 65 2d 68 6f 73 74 29 29 29 0a 20 20 20 mote-host))).
f030: 20 28 63 6f 6d 6d 6f 6e 3a 77 61 69 74 2d 66 6f (common:wait-fo
f040: 72 2d 63 70 75 6c 6f 61 64 20 6d 61 78 6c 6f 61 r-cpuload maxloa
f050: 64 20 6e 75 6d 2d 63 70 75 73 20 31 35 20 6d 73 d num-cpus 15 ms
f060: 67 3a 20 6d 73 67 20 72 65 6d 6f 74 65 2d 68 6f g: msg remote-ho
f070: 73 74 3a 20 72 65 6d 6f 74 65 2d 68 6f 73 74 29 st: remote-host)
f080: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 ))..(define (get
f090: 2d 75 6e 61 6d 65 20 2e 20 70 61 72 61 6d 73 29 -uname . params)
f0a0: 0a 20 20 28 6c 65 74 2a 20 28 28 75 6e 61 6d 65 . (let* ((uname
f0b0: 2d 72 65 73 20 28 70 72 6f 63 65 73 73 3a 63 6d -res (process:cm
f0c0: 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f 6e d-run->list (con
f0d0: 63 20 22 75 6e 61 6d 65 20 22 20 28 69 66 20 28 c "uname " (if (
f0e0: 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 20 22 2d null? params) "-
f0f0: 61 22 20 28 63 61 72 20 70 61 72 61 6d 73 29 29 a" (car params))
f100: 29 29 29 0a 09 20 28 75 6e 61 6d 65 20 23 66 29 ))).. (uname #f)
f110: 29 0a 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f ). (if (null?
f120: 20 28 63 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 (car uname-res)
f130: 29 0a 09 22 75 6e 6b 6e 6f 77 6e 22 0a 09 28 63 ).."unknown"..(c
f140: 61 61 72 20 75 6e 61 6d 65 2d 72 65 73 29 29 29 aar uname-res)))
f150: 29 0a 0a 3b 3b 20 66 6f 72 20 72 65 61 73 6f 6e )..;; for reason
f160: 73 20 49 20 64 6f 6e 27 74 20 75 6e 64 65 72 73 s I don't unders
f170: 74 61 6e 64 20 6d 75 6c 74 69 70 6c 65 20 63 61 tand multiple ca
f180: 6c 6c 73 20 74 6f 20 72 65 61 6c 2d 70 61 74 68 lls to real-path
f190: 20 69 6e 20 70 61 72 61 6c 6c 65 6c 20 74 68 72 in parallel thr
f1a0: 65 61 64 73 0a 3b 3b 20 6d 75 73 74 20 62 65 20 eads.;; must be
f1b0: 70 72 6f 74 65 63 74 65 64 20 62 79 20 6d 75 74 protected by mut
f1c0: 65 78 65 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 exes.;;.(define
f1d0: 28 63 6f 6d 6d 6f 6e 3a 72 65 61 6c 2d 70 61 74 (common:real-pat
f1e0: 68 20 69 6e 70 61 74 68 29 0a 20 20 3b 3b 20 28 h inpath). ;; (
f1f0: 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d process:cmd-run-
f200: 77 69 74 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 with-stderr->lis
f210: 74 20 22 72 65 61 64 6c 69 6e 6b 22 20 22 2d 66 t "readlink" "-f
f220: 22 20 69 6e 70 61 74 68 29 29 20 3b 3b 20 63 6d " inpath)) ;; cm
f230: 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b d . params). ;;
f240: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 0a 20 20 (let-values .
f250: 3b 3b 20 20 28 28 28 69 6e 70 20 6f 75 70 20 70 ;; (((inp oup p
f260: 69 64 29 20 28 70 72 6f 63 65 73 73 20 22 72 65 id) (process "re
f270: 61 64 6c 69 6e 6b 22 20 28 6c 69 73 74 20 22 2d adlink" (list "-
f280: 66 22 20 69 6e 70 61 74 68 29 29 29 29 0a 20 20 f" inpath)))).
f290: 3b 3b 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ;; (with-input-
f2a0: 66 72 6f 6d 2d 70 6f 72 74 20 69 6e 70 0a 20 20 from-port inp.
f2b0: 3b 3b 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 ;; (let loop
f2c0: 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c 69 6e 65 ((inl (read-line
f2d0: 29 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 09 28 )). ;; .(
f2e0: 72 65 73 20 23 66 29 29 0a 20 20 3b 3b 20 20 20 res #f)). ;;
f2f0: 20 20 20 28 70 72 69 6e 74 20 22 69 6e 6c 3d 22 (print "inl="
f300: 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 inl). ;;
f310: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
f320: 20 69 6e 6c 29 0a 20 20 3b 3b 20 20 20 20 20 20 inl). ;;
f330: 20 20 20 20 28 62 65 67 69 6e 0a 20 20 3b 3b 20 (begin. ;;
f340: 20 20 20 20 20 20 20 20 20 20 20 28 63 6c 6f 73 (clos
f350: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 69 6e 70 e-input-port inp
f360: 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 ). ;;
f370: 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d (close-output-
f380: 70 6f 72 74 20 6f 75 70 29 0a 20 20 3b 3b 20 20 port oup). ;;
f390: 20 20 20 20 20 20 20 20 20 20 3b 3b 20 28 70 72 ;; (pr
f3a0: 6f 63 65 73 73 2d 77 61 69 74 20 70 69 64 29 0a ocess-wait pid).
f3b0: 20 20 3b 3b 20 20 20 20 20 20 20 20 20 20 20 20 ;;
f3c0: 72 65 73 29 0a 20 20 3b 3b 20 20 20 20 20 20 20 res). ;;
f3d0: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c (loop (read-l
f3e0: 69 6e 65 29 20 69 6e 6c 29 29 29 29 29 29 0a 20 ine) inl)))))).
f3f0: 20 28 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f (with-input-fro
f400: 6d 2d 70 69 70 65 20 28 63 6f 6e 63 20 22 72 65 m-pipe (conc "re
f410: 61 64 6c 69 6e 6b 20 2d 66 20 22 20 69 6e 70 61 adlink -f " inpa
f420: 74 68 29 20 72 65 61 64 2d 6c 69 6e 65 29 29 0a th) read-line)).
f430: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
f440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f450: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f460: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f470: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 49 =========.;; D I
f480: 20 53 20 4b 20 20 20 53 20 50 20 41 20 43 20 45 S K S P A C E
f490: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
f4a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f4b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f4c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
f4d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
f4e0: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
f4f0: 64 69 73 6b 2d 73 70 61 63 65 2d 75 73 65 64 20 disk-space-used
f500: 66 70 61 74 68 29 0a 20 20 28 77 69 74 68 2d 69 fpath). (with-i
f510: 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 20 28 nput-from-pipe (
f520: 63 6f 6e 63 20 22 2f 75 73 72 2f 62 69 6e 2f 64 conc "/usr/bin/d
f530: 75 20 2d 73 20 22 20 66 70 61 74 68 29 20 72 65 u -s " fpath) re
f540: 61 64 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 70 ad))..;; given p
f550: 61 74 68 20 67 65 74 20 66 72 65 65 20 73 70 61 ath get free spa
f560: 63 65 2c 20 61 6c 6c 6f 77 73 20 6f 76 65 72 72 ce, allows overr
f570: 69 64 65 20 69 6e 20 5b 73 65 74 75 70 5d 0a 3b ide in [setup].;
f580: 3b 20 77 69 74 68 20 66 72 65 65 2d 73 70 61 63 ; with free-spac
f590: 65 2d 73 63 72 69 70 74 20 2f 70 61 74 68 2f 74 e-script /path/t
f5a0: 6f 2f 73 6f 6d 65 2f 73 63 72 69 70 74 2e 73 68 o/some/script.sh
f5b0: 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 67 65 74 .;;.(define (get
f5c0: 2d 64 66 20 70 61 74 68 29 0a 20 20 28 69 66 20 -df path). (if
f5d0: 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 20 (configf:lookup
f5e0: 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 73 65 74 *configdat* "set
f5f0: 75 70 22 20 22 66 72 65 65 2d 73 70 61 63 65 2d up" "free-space-
f600: 73 63 72 69 70 74 22 29 0a 20 20 20 20 20 20 28 script"). (
f610: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
f620: 70 69 70 65 20 0a 20 20 20 20 20 20 20 28 63 6f pipe . (co
f630: 6e 63 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b nc (configf:look
f640: 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 22 up *configdat* "
f650: 73 65 74 75 70 22 20 22 66 72 65 65 2d 73 70 61 setup" "free-spa
f660: 63 65 2d 73 63 72 69 70 74 22 29 20 22 20 22 20 ce-script") " "
f670: 70 61 74 68 29 0a 20 20 20 20 20 20 20 28 6c 61 path). (la
f680: 6d 62 64 61 20 28 29 0a 09 20 28 6c 65 74 20 28 mbda ().. (let (
f690: 28 72 65 73 20 28 72 65 61 64 2d 6c 69 6e 65 29 (res (read-line)
f6a0: 29 29 0a 09 20 20 20 28 69 66 20 28 73 74 72 69 )).. (if (stri
f6b0: 6e 67 3f 20 72 65 73 29 0a 09 20 20 20 20 20 20 ng? res)..
f6c0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
f6d0: 20 72 65 73 29 29 29 29 29 0a 20 20 20 20 20 20 res))))).
f6e0: 28 67 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 (get-unix-df pat
f6f0: 68 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 h)))..(define (g
f700: 65 74 2d 75 6e 69 78 2d 64 66 20 70 61 74 68 29 et-unix-df path)
f710: 0a 20 20 28 6c 65 74 2a 20 28 28 64 66 2d 72 65 . (let* ((df-re
f720: 73 75 6c 74 73 20 28 70 72 6f 63 65 73 73 3a 63 sults (process:c
f730: 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 28 63 6f md-run->list (co
f740: 6e 63 20 22 64 66 20 22 20 70 61 74 68 29 29 29 nc "df " path)))
f750: 0a 09 20 28 73 70 61 63 65 2d 72 78 20 20 20 28 .. (space-rx (
f760: 72 65 67 65 78 70 20 22 28 5b 30 2d 39 5d 2b 29 regexp "([0-9]+)
f770: 5c 5c 73 2b 28 5b 30 2d 39 5d 2b 29 25 22 29 29 \\s+([0-9]+)%"))
f780: 0a 09 20 28 66 72 65 65 73 70 63 20 20 20 20 23 .. (freespc #
f790: 66 29 29 0a 20 20 20 20 3b 3b 20 28 77 72 69 74 f)). ;; (writ
f7a0: 65 20 64 66 2d 72 65 73 75 6c 74 73 29 0a 20 20 e df-results).
f7b0: 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
f7c0: 62 64 61 20 28 6c 29 0a 09 09 28 6c 65 74 20 28 bda (l)...(let (
f7d0: 28 6d 61 74 63 68 20 28 73 74 72 69 6e 67 2d 73 (match (string-s
f7e0: 65 61 72 63 68 20 73 70 61 63 65 2d 72 78 20 6c earch space-rx l
f7f0: 29 29 29 0a 09 09 20 20 28 69 66 20 6d 61 74 63 )))... (if matc
f800: 68 20 0a 09 09 20 20 20 20 20 20 28 6c 65 74 20 h ... (let
f810: 28 28 6e 65 77 76 61 6c 20 28 73 74 72 69 6e 67 ((newval (string
f820: 2d 3e 6e 75 6d 62 65 72 20 28 63 61 64 72 20 6d ->number (cadr m
f830: 61 74 63 68 29 29 29 29 0a 09 09 09 28 69 66 20 atch))))....(if
f840: 28 6e 75 6d 62 65 72 3f 20 6e 65 77 76 61 6c 29 (number? newval)
f850: 0a 09 09 09 20 20 20 20 28 73 65 74 21 20 66 72 .... (set! fr
f860: 65 65 73 70 63 20 6e 65 77 76 61 6c 29 29 29 29 eespc newval))))
f870: 29 29 0a 09 20 20 20 20 20 20 28 63 61 72 20 64 )).. (car d
f880: 66 2d 72 65 73 75 6c 74 73 29 29 0a 20 20 20 20 f-results)).
f890: 66 72 65 65 73 70 63 29 29 0a 0a 28 64 65 66 69 freespc))..(defi
f8a0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b ne (common:check
f8b0: 2d 73 70 61 63 65 2d 69 6e 2d 64 69 72 20 64 69 -space-in-dir di
f8c0: 72 70 61 74 68 20 72 65 71 75 69 72 65 64 29 0a rpath required).
f8d0: 20 20 28 6c 65 74 2a 20 28 28 64 62 73 70 61 63 (let* ((dbspac
f8e0: 65 20 20 28 69 66 20 28 64 69 72 65 63 74 6f 72 e (if (director
f8f0: 79 3f 20 64 69 72 70 61 74 68 29 0a 09 09 20 20 y? dirpath)...
f900: 20 20 20 20 20 28 67 65 74 2d 64 66 20 64 69 72 (get-df dir
f910: 70 61 74 68 29 0a 09 09 20 20 20 20 20 20 20 30 path)... 0
f920: 29 29 29 0a 20 20 20 20 28 6c 69 73 74 20 28 3e ))). (list (>
f930: 20 64 62 73 70 61 63 65 20 72 65 71 75 69 72 65 dbspace require
f940: 64 29 0a 09 20 20 64 62 73 70 61 63 65 0a 09 20 d).. dbspace..
f950: 20 72 65 71 75 69 72 65 64 0a 09 20 20 64 69 72 required.. dir
f960: 70 61 74 68 29 29 29 0a 0a 3b 3b 20 63 68 65 63 path)))..;; chec
f970: 6b 20 73 70 61 63 65 20 69 6e 20 64 62 64 69 72 k space in dbdir
f980: 20 61 6e 64 20 69 6e 20 6d 65 67 61 74 65 73 74 and in megatest
f990: 20 64 69 72 0a 3b 3b 20 72 65 74 75 72 6e 73 3a dir.;; returns:
f9a0: 20 6f 6b 2f 6e 6f 74 20 64 62 73 70 61 63 65 20 ok/not dbspace
f9b0: 72 65 71 75 69 72 65 64 2d 73 70 61 63 65 0a 3b required-space.;
f9c0: 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f ;.(define (commo
f9d0: 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d 73 n:check-db-dir-s
f9e0: 70 61 63 65 29 0a 20 20 28 6c 65 74 2a 20 28 28 pace). (let* ((
f9f0: 72 65 71 75 69 72 65 64 20 28 73 74 72 69 6e 67 required (string
fa00: 2d 3e 6e 75 6d 62 65 72 20 0a 09 09 20 20 20 20 ->number ...
fa10: 28 6f 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f (or (configf:loo
fa20: 6b 75 70 20 2a 63 6f 6e 66 69 67 64 61 74 2a 20 kup *configdat*
fa30: 22 73 65 74 75 70 22 20 22 64 62 64 69 72 2d 73 "setup" "dbdir-s
fa40: 70 61 63 65 2d 72 65 71 75 69 72 65 64 22 29 0a pace-required").
fa50: 09 09 09 22 31 30 30 30 30 30 22 29 29 29 0a 09 ..."100000")))..
fa60: 20 28 64 62 64 69 72 20 20 20 20 28 63 6f 6d 6d (dbdir (comm
fa70: 6f 6e 3a 67 65 74 2d 64 62 2d 74 6d 70 2d 61 72 on:get-db-tmp-ar
fa80: 65 61 20 23 66 29 29 20 3b 3b 20 28 64 62 3a 67 ea #f)) ;; (db:g
fa90: 65 74 2d 64 62 64 69 72 29 29 0a 09 20 28 74 64 et-dbdir)).. (td
faa0: 62 73 70 61 63 65 20 28 63 6f 6d 6d 6f 6e 3a 63 bspace (common:c
fab0: 68 65 63 6b 2d 73 70 61 63 65 2d 69 6e 2d 64 69 heck-space-in-di
fac0: 72 20 64 62 64 69 72 20 72 65 71 75 69 72 65 64 r dbdir required
fad0: 29 29 0a 09 20 28 6d 64 62 73 70 61 63 65 20 28 )).. (mdbspace (
fae0: 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d 73 70 61 common:check-spa
faf0: 63 65 2d 69 6e 2d 64 69 72 20 2a 74 6f 70 70 61 ce-in-dir *toppa
fb00: 74 68 2a 20 72 65 71 75 69 72 65 64 29 29 29 0a th* required))).
fb10: 20 20 20 20 28 73 6f 72 74 20 28 6c 69 73 74 20 (sort (list
fb20: 74 64 62 73 70 61 63 65 20 6d 64 62 73 70 61 63 tdbspace mdbspac
fb30: 65 29 20 28 6c 61 6d 62 64 61 20 28 61 20 62 29 e) (lambda (a b)
fb40: 0a 09 09 09 09 20 20 20 20 20 28 3c 20 28 63 61 ..... (< (ca
fb50: 64 72 20 61 29 28 63 61 64 72 20 62 29 29 29 29 dr a)(cadr b))))
fb60: 29 29 0a 20 20 20 20 0a 3b 3b 20 63 68 65 63 6b )). .;; check
fb70: 20 61 76 61 69 6c 61 62 6c 65 20 73 70 61 63 65 available space
fb80: 20 69 6e 20 64 62 64 69 72 2c 20 65 78 69 74 20 in dbdir, exit
fb90: 69 66 20 69 6e 73 75 66 66 69 63 69 65 6e 74 0a if insufficient.
fba0: 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d ;;.(define (comm
fbb0: 6f 6e 3a 63 68 65 63 6b 2d 64 62 2d 64 69 72 2d on:check-db-dir-
fbc0: 61 6e 64 2d 65 78 69 74 2d 69 66 2d 69 6e 73 75 and-exit-if-insu
fbd0: 66 66 69 63 69 65 6e 74 29 0a 20 20 28 6c 65 74 fficient). (let
fbe0: 2a 20 28 28 73 70 61 63 65 64 61 74 20 28 63 61 * ((spacedat (ca
fbf0: 72 20 28 63 6f 6d 6d 6f 6e 3a 63 68 65 63 6b 2d r (common:check-
fc00: 64 62 2d 64 69 72 2d 73 70 61 63 65 29 29 29 20 db-dir-space)))
fc10: 3b 3b 20 6c 6f 6f 6b 20 6f 6e 6c 79 20 61 74 20 ;; look only at
fc20: 77 6f 72 73 74 20 66 6f 72 20 6e 6f 77 0a 09 20 worst for now..
fc30: 28 69 73 2d 6f 6b 20 20 20 20 28 63 61 72 20 73 (is-ok (car s
fc40: 70 61 63 65 64 61 74 29 29 0a 09 20 28 64 62 73 pacedat)).. (dbs
fc50: 70 61 63 65 20 20 28 63 61 64 72 20 73 70 61 63 pace (cadr spac
fc60: 65 64 61 74 29 29 0a 09 20 28 72 65 71 75 69 72 edat)).. (requir
fc70: 65 64 20 28 63 61 64 64 72 20 73 70 61 63 65 64 ed (caddr spaced
fc80: 61 74 29 29 0a 09 20 28 64 62 64 69 72 20 20 20 at)).. (dbdir
fc90: 20 28 63 61 64 64 64 72 20 73 70 61 63 65 64 61 (cadddr spaceda
fca0: 74 29 29 29 0a 20 20 20 20 28 69 66 20 28 6e 6f t))). (if (no
fcb0: 74 20 69 73 2d 6f 6b 29 0a 09 28 62 65 67 69 6e t is-ok)..(begin
fcc0: 0a 09 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 .. (debug:print
fcd0: 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 75 6c -error 0 *defaul
fce0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 49 6e 73 t-log-port* "Ins
fcf0: 75 66 66 69 63 69 65 6e 74 20 73 70 61 63 65 20 ufficient space
fd00: 69 6e 20 22 20 64 62 64 69 72 20 22 2c 20 72 65 in " dbdir ", re
fd10: 71 75 69 72 65 20 22 20 72 65 71 75 69 72 65 64 quire " required
fd20: 20 22 2c 20 68 61 76 65 20 22 20 64 62 73 70 61 ", have " dbspa
fd30: 63 65 20 20 22 2c 20 65 78 69 74 69 6e 67 20 6e ce ", exiting n
fd40: 6f 77 2e 22 29 0a 09 20 20 28 65 78 69 74 20 31 ow.").. (exit 1
fd50: 29 29 29 29 29 0a 20 20 0a 3b 3b 20 70 61 74 68 ))))). .;; path
fd60: 73 20 69 73 20 6c 69 73 74 20 6f 66 20 6c 69 73 s is list of lis
fd70: 74 73 20 28 28 6e 61 6d 65 20 70 61 74 68 29 20 ts ((name path)
fd80: 2e 2e 2e 20 29 0a 3b 3b 0a 28 64 65 66 69 6e 65 ... ).;;.(define
fd90: 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 64 69 73 (common:get-dis
fda0: 6b 2d 77 69 74 68 2d 6d 6f 73 74 2d 66 72 65 65 k-with-most-free
fdb0: 2d 73 70 61 63 65 20 64 69 73 6b 73 20 6d 69 6e -space disks min
fdc0: 73 69 7a 65 29 0a 20 20 28 6c 65 74 20 28 28 62 size). (let ((b
fdd0: 65 73 74 20 20 20 20 20 23 66 29 0a 09 28 62 65 est #f)..(be
fde0: 73 74 73 69 7a 65 20 30 29 29 0a 20 20 20 20 28 stsize 0)). (
fdf0: 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
fe00: 6c 61 6d 62 64 61 20 28 64 69 73 6b 2d 6e 75 6d lambda (disk-num
fe10: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 ). (let* (
fe20: 28 64 69 72 70 61 74 68 20 20 20 20 28 63 61 64 (dirpath (cad
fe30: 72 20 28 61 73 73 6f 63 20 64 69 73 6b 2d 6e 75 r (assoc disk-nu
fe40: 6d 20 64 69 73 6b 73 29 29 29 0a 09 20 20 20 20 m disks)))..
fe50: 20 20 28 66 72 65 65 73 70 63 20 20 20 20 28 63 (freespc (c
fe60: 6f 6e 64 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 ond.... ((not
fe70: 28 64 69 72 65 63 74 6f 72 79 3f 20 64 69 72 70 (directory? dirp
fe80: 61 74 68 29 29 0a 09 09 09 20 20 20 20 28 69 66 ath)).... (if
fe90: 20 28 63 6f 6d 6d 6f 6e 3a 6c 6f 77 2d 6e 6f 69 (common:low-noi
fea0: 73 65 2d 70 72 69 6e 74 20 33 30 30 20 22 64 69 se-print 300 "di
feb0: 73 6b 73 20 6e 6f 74 20 61 20 64 69 72 20 22 20 sks not a dir "
fec0: 64 69 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 disk-num).....(d
fed0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
fee0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
fef0: 22 57 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 "WARNING: disk "
ff00: 20 64 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 disk-num " at p
ff10: 61 74 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 ath \"" dirpath
ff20: 22 5c 22 20 69 73 20 6e 6f 74 20 61 20 64 69 72 "\" is not a dir
ff30: 65 63 74 6f 72 79 20 2d 20 69 67 6e 6f 72 69 6e ectory - ignorin
ff40: 67 20 69 74 2e 22 29 29 0a 09 09 09 20 20 20 20 g it."))....
ff50: 2d 31 29 0a 09 09 09 20 20 20 28 28 6e 6f 74 20 -1).... ((not
ff60: 28 66 69 6c 65 2d 77 72 69 74 65 2d 61 63 63 65 (file-write-acce
ff70: 73 73 3f 20 64 69 72 70 61 74 68 29 29 0a 09 09 ss? dirpath))...
ff80: 09 20 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e . (if (common
ff90: 3a 6c 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 :low-noise-print
ffa0: 20 33 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 300 "disks not
ffb0: 77 72 69 74 65 61 62 6c 65 20 22 20 64 69 73 6b writeable " disk
ffc0: 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 75 67 -num).....(debug
ffd0: 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c :print 0 *defaul
ffe0: 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 52 t-log-port* "WAR
fff0: 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 69 73 NING: disk " dis
10000 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 68 20 k-num " at path
10010 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c 22 20 \"" dirpath "\"
10020 69 73 20 6e 6f 74 20 77 72 69 74 65 61 62 6c 65 is not writeable
10030 20 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 - ignoring it."
10040 29 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 )).... -1)...
10050 09 20 20 20 28 28 6e 6f 74 20 28 65 71 3f 20 28 . ((not (eq? (
10060 73 74 72 69 6e 67 2d 72 65 66 20 64 69 72 70 61 string-ref dirpa
10070 74 68 20 30 29 20 23 5c 2f 29 29 0a 09 09 09 20 th 0) #\/))....
10080 20 20 20 28 69 66 20 28 63 6f 6d 6d 6f 6e 3a 6c (if (common:l
10090 6f 77 2d 6e 6f 69 73 65 2d 70 72 69 6e 74 20 33 ow-noise-print 3
100a0 30 30 20 22 64 69 73 6b 73 20 6e 6f 74 20 61 20 00 "disks not a
100b0 70 72 6f 70 65 72 20 70 61 74 68 20 22 20 64 69 proper path " di
100c0 73 6b 2d 6e 75 6d 29 0a 09 09 09 09 28 64 65 62 sk-num).....(deb
100d0 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
100e0 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 ult-log-port* "W
100f0 41 52 4e 49 4e 47 3a 20 64 69 73 6b 20 22 20 64 ARNING: disk " d
10100 69 73 6b 2d 6e 75 6d 20 22 20 61 74 20 70 61 74 isk-num " at pat
10110 68 20 5c 22 22 20 64 69 72 70 61 74 68 20 22 5c h \"" dirpath "\
10120 22 20 69 73 20 6e 6f 74 20 61 20 66 75 6c 6c 79 " is not a fully
10130 20 71 75 61 6c 69 66 69 65 64 20 70 61 74 68 20 qualified path
10140 2d 20 69 67 6e 6f 72 69 6e 67 20 69 74 2e 22 29 - ignoring it.")
10150 29 0a 09 09 09 20 20 20 20 2d 31 29 0a 09 09 09 ).... -1)....
10160 20 20 20 28 65 6c 73 65 0a 09 09 09 20 20 20 20 (else....
10170 28 67 65 74 2d 64 66 20 64 69 72 70 61 74 68 29 (get-df dirpath)
10180 29 29 29 29 0a 09 20 28 69 66 20 28 3e 20 66 72 )))).. (if (> fr
10190 65 65 73 70 63 20 62 65 73 74 73 69 7a 65 29 0a eespc bestsize).
101a0 09 20 20 20 20 20 28 62 65 67 69 6e 0a 09 20 20 . (begin..
101b0 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 20 (set! best
101c0 20 20 20 20 28 63 6f 6e 73 20 64 69 73 6b 2d 6e (cons disk-n
101d0 75 6d 20 64 69 72 70 61 74 68 29 29 0a 09 20 20 um dirpath))..
101e0 20 20 20 20 20 28 73 65 74 21 20 62 65 73 74 73 (set! bests
101f0 69 7a 65 20 66 72 65 65 73 70 63 29 29 29 29 29 ize freespc)))))
10200 0a 20 20 20 20 20 28 6d 61 70 20 63 61 72 20 64 . (map car d
10210 69 73 6b 73 29 29 0a 20 20 20 20 28 69 66 20 28 isks)). (if (
10220 61 6e 64 20 62 65 73 74 20 28 3e 20 62 65 73 74 and best (> best
10230 73 69 7a 65 20 6d 69 6e 73 69 7a 65 29 29 0a 09 size minsize))..
10240 62 65 73 74 0a 09 23 66 29 29 29 20 3b 3b 20 23 best..#f))) ;; #
10250 66 20 6d 65 61 6e 73 20 6e 6f 20 64 69 73 6b 20 f means no disk
10260 63 61 6e 64 69 64 61 74 65 20 66 6f 75 6e 64 0a candidate found.
10270 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
10280 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10290 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 45 20 4e =========.;; E N
102c0 20 56 20 49 20 52 20 4f 20 4e 20 4d 20 45 20 4e V I R O N M E N
102d0 20 54 20 20 20 56 20 41 20 52 20 53 0a 3b 3b 3d T V A R S.;;=
102e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
102f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10300 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10310 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10320 3d 3d 3d 3d 3d 0a 28 64 65 66 69 6e 65 20 28 62 =====.(define (b
10330 62 2d 63 68 65 63 6b 2d 70 61 74 68 20 23 21 6b b-check-path #!k
10340 65 79 20 28 6d 73 67 20 22 63 68 65 63 6b 2d 70 ey (msg "check-p
10350 61 74 68 3a 20 22 29 29 0a 20 20 28 6c 65 74 20 ath: ")). (let
10360 28 28 70 61 74 68 20 28 6f 72 20 28 67 65 74 2d ((path (or (get-
10370 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
10380 61 62 6c 65 20 22 50 41 54 48 22 29 20 22 6e 6f able "PATH") "no
10390 6e 65 22 29 29 29 0a 20 20 20 20 28 64 65 62 75 ne"))). (debu
103a0 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 20 2a g:print-info 0 *
103b0 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 default-log-port
103c0 2a 20 28 63 6f 6e 63 20 6d 73 67 22 20 3a 20 24 * (conc msg" : $
103d0 50 41 54 48 3d 22 70 61 74 68 29 29 0a 20 20 20 PATH="path)).
103e0 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 74 (if (string-mat
103f0 63 68 20 22 5e 2e 2a 2f 69 73 6f 65 6e 76 2d 63 ch "^.*/isoenv-c
10400 6f 72 65 2f 2e 2a 22 20 70 61 74 68 29 0a 20 20 ore/.*" path).
10410 20 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 (debug:pri
10420 6e 74 2d 65 72 72 6f 72 20 30 20 2a 64 65 66 61 nt-error 0 *defa
10430 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 28 63 ult-log-port* (c
10440 6f 6e 63 20 6d 73 67 22 20 3a 20 21 21 49 53 4f onc msg" : !!ISO
10450 45 4e 56 20 50 52 45 53 45 4e 54 21 21 22 29 29 ENV PRESENT!!"))
10460 20 3b 3b 20 72 65 6d 6f 76 65 20 66 6f 72 20 70 ;; remove for p
10470 72 6f 64 0a 20 20 20 20 20 20 20 20 28 64 65 62 rod. (deb
10480 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 31 20 ug:print-info 1
10490 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 *default-log-por
104a0 74 2a 20 28 63 6f 6e 63 20 6d 73 67 22 20 3a 20 t* (conc msg" :
104b0 2a 2a 6e 6f 20 69 73 6f 65 6e 76 20 70 72 65 73 **no isoenv pres
104c0 65 6e 74 2a 2a 22 29 29 29 29 29 0a 0a 09 20 20 ent**")))))...
104d0 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 73 61 .(define (sa
104e0 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 ve-environment-a
104f0 73 2d 66 69 6c 65 73 20 66 6e 61 6d 65 20 23 21 s-files fname #!
10500 6b 65 79 20 28 69 67 6e 6f 72 65 76 61 72 73 20 key (ignorevars
10510 28 6c 69 73 74 20 22 55 53 45 52 22 20 22 48 4f (list "USER" "HO
10520 4d 45 22 20 22 44 49 53 50 4c 41 59 22 20 22 4c ME" "DISPLAY" "L
10530 53 5f 43 4f 4c 4f 52 53 22 20 22 58 4b 45 59 53 S_COLORS" "XKEYS
10540 59 4d 44 42 22 20 22 45 44 49 54 4f 52 22 20 22 YMDB" "EDITOR" "
10550 4d 41 4b 45 46 4c 41 47 53 22 20 22 4d 41 4b 45 MAKEFLAGS" "MAKE
10560 46 22 20 22 4d 41 4b 45 4f 56 45 52 52 49 44 45 F" "MAKEOVERRIDE
10570 53 22 29 29 29 0a 20 20 3b 3b 28 62 62 2d 63 68 S"))). ;;(bb-ch
10580 65 63 6b 2d 70 61 74 68 20 6d 73 67 3a 20 22 73 eck-path msg: "s
10590 61 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d ave-environment-
105a0 61 73 2d 66 69 6c 65 73 20 65 6e 74 72 79 22 29 as-files entry")
105b0 0a 20 20 28 6c 65 74 20 28 28 65 6e 76 76 61 72 . (let ((envvar
105c0 73 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 s (get-environme
105d0 6e 74 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 nt-variables)).
105e0 20 20 20 20 20 20 20 28 77 68 69 74 65 73 70 20 (whitesp
105f0 28 72 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d (regexp "[^a-zA-
10600 5a 30 2d 39 5f 5c 5c 2d 3a 2c 2e 5c 5c 2f 25 24 Z0-9_\\-:,.\\/%$
10610 5d 22 29 29 0a 09 28 6d 75 6e 67 65 76 61 6c 20 ]"))..(mungeval
10620 28 6c 61 6d 62 64 61 20 28 76 61 6c 29 0a 09 09 (lambda (val)...
10630 20 20 20 20 28 63 6f 6e 64 0a 09 09 20 20 20 20 (cond...
10640 20 28 28 65 71 3f 20 76 61 6c 20 23 74 29 20 22 ((eq? val #t) "
10650 22 29 20 3b 3b 20 63 6f 6e 76 65 72 74 20 23 74 ") ;; convert #t
10660 20 74 6f 20 65 6d 70 74 79 20 73 74 72 69 6e 67 to empty string
10670 0a 09 09 20 20 20 20 20 28 28 65 71 3f 20 76 61 ... ((eq? va
10680 6c 20 23 66 29 20 23 66 29 20 3b 3b 20 63 6f 6e l #f) #f) ;; con
10690 76 65 72 74 20 23 66 20 74 6f 20 69 74 73 65 6c vert #f to itsel
106a0 66 20 28 73 74 69 6c 6c 20 74 68 69 6e 6b 69 6e f (still thinkin
106b0 67 20 61 62 6f 75 74 20 74 68 69 73 20 6f 6e 65 g about this one
106c0 0a 09 09 20 20 20 20 20 28 65 6c 73 65 20 76 61 ... (else va
106d0 6c 29 29 29 29 29 0a 20 20 20 20 28 77 69 74 68 l))))). (with
106e0 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 -output-to-file
106f0 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 73 (conc fname ".cs
10700 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 h"). (lamb
10710 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 da ().
10720 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
10730 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 20 20 a (keyval)...
10740 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 20 20 (let* ((key
10750 20 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 (car keyval))..
10760 09 09 20 20 20 20 20 28 76 61 6c 20 20 20 28 63 .. (val (c
10770 64 72 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 dr keyval))....
10780 20 20 20 20 28 64 65 6c 69 6d 20 28 69 66 20 28 (delim (if (
10790 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 string-search wh
107a0 69 74 65 73 70 20 76 61 6c 29 20 0a 09 09 09 09 itesp val) .....
107b0 09 22 5c 22 22 0a 09 09 09 09 09 22 22 29 29 29 ."\""......"")))
107c0 0a 09 09 09 28 70 72 69 6e 74 20 28 69 66 20 28 ....(print (if (
107d0 6f 72 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 or (member key i
107e0 67 6e 6f 72 65 76 61 72 73 29 0a 09 09 09 09 20 gnorevars).....
107f0 20 20 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 (string-se
10800 61 72 63 68 20 77 68 69 74 65 73 70 20 6b 65 79 arch whitesp key
10810 29 29 0a 09 09 09 09 20 20 20 22 23 20 73 65 74 ))..... "# set
10820 65 6e 76 20 22 0a 09 09 09 09 20 20 20 22 73 65 env "..... "se
10830 74 65 6e 76 20 22 29 0a 09 09 09 20 20 20 20 20 tenv ")....
10840 20 20 6b 65 79 20 22 20 22 20 64 65 6c 69 6d 20 key " " delim
10850 28 6d 75 6e 67 65 76 61 6c 20 76 61 6c 29 20 64 (mungeval val) d
10860 65 6c 69 6d 29 29 29 0a 09 09 20 20 20 20 65 6e elim)))... en
10870 76 76 61 72 73 29 29 29 0a 20 20 20 20 20 28 77 vvars))). (w
10880 69 74 68 2d 6f 75 74 70 75 74 2d 74 6f 2d 66 69 ith-output-to-fi
10890 6c 65 20 28 63 6f 6e 63 20 66 6e 61 6d 65 20 22 le (conc fname "
108a0 2e 73 68 22 29 0a 20 20 20 20 20 20 20 28 6c 61 .sh"). (la
108b0 6d 62 64 61 20 28 29 0a 20 20 20 20 20 20 20 20 mbda ().
108c0 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d (for-each (lam
108d0 62 64 61 20 28 6b 65 79 76 61 6c 29 0a 09 09 20 bda (keyval)...
108e0 20 20 20 20 20 28 6c 65 74 2a 20 28 28 6b 65 79 (let* ((key
108f0 20 28 63 61 72 20 6b 65 79 76 61 6c 29 29 0a 09 (car keyval))..
10900 09 09 20 20 20 20 20 28 76 61 6c 20 28 63 64 72 .. (val (cdr
10910 20 6b 65 79 76 61 6c 29 29 0a 09 09 09 20 20 20 keyval))....
10920 20 20 28 64 65 6c 69 6d 20 28 69 66 20 28 73 74 (delim (if (st
10930 72 69 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 ring-search whit
10940 65 73 70 20 76 61 6c 29 20 0a 09 09 09 09 09 22 esp val) ......"
10950 5c 22 22 0a 09 09 09 09 09 22 22 29 29 29 0a 09 \""......"")))..
10960 09 09 28 70 72 69 6e 74 20 28 69 66 20 28 6f 72 ..(print (if (or
10970 20 28 6d 65 6d 62 65 72 20 6b 65 79 20 69 67 6e (member key ign
10980 6f 72 65 76 61 72 73 29 0a 09 09 09 09 20 20 20 orevars).....
10990 20 20 20 20 28 73 74 72 69 6e 67 2d 73 65 61 72 (string-sear
109a0 63 68 20 77 68 69 74 65 73 70 20 6b 65 79 29 0a ch whitesp key).
109b0 09 09 09 09 20 20 20 20 20 20 20 28 73 74 72 69 .... (stri
109c0 6e 67 2d 73 65 61 72 63 68 20 22 3a 22 20 6b 65 ng-search ":" ke
109d0 79 29 29 20 3b 3b 20 69 6e 74 65 72 6e 61 6c 20 y)) ;; internal
109e0 6f 6e 6c 79 20 76 61 6c 75 65 73 20 74 6f 20 62 only values to b
109f0 65 20 73 6b 69 70 70 65 64 2e 0a 09 09 09 09 20 e skipped......
10a00 20 20 22 23 20 65 78 70 6f 72 74 20 22 0a 09 09 "# export "...
10a10 09 09 20 20 20 22 65 78 70 6f 72 74 20 22 29 0a .. "export ").
10a20 09 09 09 20 20 20 20 20 20 20 6b 65 79 20 22 3d ... key "=
10a30 22 20 64 65 6c 69 6d 20 28 6d 75 6e 67 65 76 61 " delim (mungeva
10a40 6c 20 76 61 6c 29 20 64 65 6c 69 6d 29 29 29 0a l val) delim))).
10a50 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
10a60 20 20 20 20 65 6e 76 76 61 72 73 29 29 29 29 29 envvars)))))
10a70 0a 0a 3b 3b 20 73 65 74 20 73 6f 6d 65 20 65 6e ..;; set some en
10a80 76 20 76 61 72 73 20 66 72 6f 6d 20 61 6e 20 61 v vars from an a
10a90 6c 69 73 74 2c 20 72 65 74 75 72 6e 20 61 6e 20 list, return an
10aa0 61 6c 69 73 74 20 77 69 74 68 20 6f 72 69 67 69 alist with origi
10ab0 6e 61 6c 20 76 61 6c 75 65 73 0a 3b 3b 20 28 28 nal values.;; ((
10ac0 22 56 41 52 22 20 22 76 61 6c 75 65 22 29 20 2e "VAR" "value") .
10ad0 2e 2e 29 0a 28 64 65 66 69 6e 65 20 28 61 6c 69 ..).(define (ali
10ae0 73 74 2d 3e 65 6e 76 2d 76 61 72 73 20 6c 73 74 st->env-vars lst
10af0 29 0a 20 20 28 69 66 20 28 6c 69 73 74 3f 20 6c ). (if (list? l
10b00 73 74 29 0a 20 20 20 20 20 20 28 6c 65 74 20 28 st). (let (
10b10 28 72 65 73 20 27 28 29 29 29 0a 09 28 66 6f 72 (res '()))..(for
10b20 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 -each (lambda (p
10b30 29 0a 09 09 20 20 20 20 28 6c 65 74 2a 20 28 28 )... (let* ((
10b40 76 61 72 20 28 63 61 72 20 20 70 29 29 0a 09 09 var (car p))...
10b50 09 20 20 20 28 76 61 6c 20 28 63 61 64 72 20 70 . (val (cadr p
10b60 29 29 0a 09 09 09 20 20 20 28 70 72 76 20 28 67 )).... (prv (g
10b70 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 et-environment-v
10b80 61 72 69 61 62 6c 65 20 76 61 72 29 29 29 0a 09 ariable var)))..
10b90 09 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 . (set! res
10ba0 20 28 63 6f 6e 73 20 28 6c 69 73 74 20 76 61 72 (cons (list var
10bb0 20 70 72 76 29 20 72 65 73 29 29 0a 09 09 20 20 prv) res))...
10bc0 20 20 20 20 28 69 66 20 76 61 6c 20 0a 09 09 09 (if val ....
10bd0 20 20 28 73 61 66 65 2d 73 65 74 65 6e 76 20 76 (safe-setenv v
10be0 61 72 20 28 2d 3e 73 74 72 69 6e 67 20 76 61 6c ar (->string val
10bf0 29 29 0a 09 09 09 20 20 28 75 6e 73 65 74 65 6e )).... (unseten
10c00 76 20 76 61 72 29 29 29 29 0a 09 09 20 20 6c 73 v var))))... ls
10c10 74 29 0a 09 72 65 73 29 0a 20 20 20 20 20 20 27 t)..res). '
10c20 28 29 29 29 0a 0a 3b 3b 20 63 6c 65 61 72 20 76 ()))..;; clear v
10c30 61 72 73 20 6d 61 74 63 68 69 6e 67 20 70 61 74 ars matching pat
10c40 74 65 72 6e 2c 20 72 75 6e 20 70 72 6f 63 2c 20 tern, run proc,
10c50 73 65 74 20 76 61 72 73 20 62 61 63 6b 0a 3b 3b set vars back.;;
10c60 20 69 66 20 70 72 6f 63 20 69 73 20 61 20 73 74 if proc is a st
10c70 72 69 6e 67 20 72 75 6e 20 74 68 61 74 20 73 74 ring run that st
10c80 72 69 6e 67 20 61 73 20 61 20 63 6f 6d 6d 61 6e ring as a comman
10c90 64 20 77 69 74 68 0a 3b 3b 20 73 79 73 74 65 6d d with.;; system
10ca0 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f ..;;.(define (co
10cb0 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 mmon:without-var
10cc0 73 20 70 72 6f 63 20 2e 20 76 61 72 2d 70 61 74 s proc . var-pat
10cd0 74 73 29 0a 20 20 28 6c 65 74 20 28 28 76 61 72 ts). (let ((var
10ce0 73 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 s (make-hash-tab
10cf0 6c 65 29 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 le))). (for-e
10d00 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
10d10 20 28 76 61 72 64 61 74 29 20 3b 3b 20 65 61 63 (vardat) ;; eac
10d20 68 20 65 6e 76 20 76 61 72 0a 20 20 20 20 20 20 h env var.
10d30 20 28 66 6f 72 2d 65 61 63 68 0a 09 28 6c 61 6d (for-each..(lam
10d40 62 64 61 20 28 76 61 72 2d 70 61 74 74 29 0a 09 bda (var-patt)..
10d50 20 20 28 69 66 20 28 73 74 72 69 6e 67 2d 6d 61 (if (string-ma
10d60 74 63 68 20 76 61 72 2d 70 61 74 74 20 28 63 61 tch var-patt (ca
10d70 72 20 76 61 72 64 61 74 29 29 0a 09 20 20 20 20 r vardat))..
10d80 20 20 28 6c 65 74 20 28 28 76 61 72 20 28 63 61 (let ((var (ca
10d90 72 20 76 61 72 64 61 74 29 29 0a 09 09 20 20 20 r vardat))...
10da0 20 28 76 61 6c 20 28 63 64 72 20 76 61 72 64 61 (val (cdr varda
10db0 74 29 29 29 0a 09 09 28 68 61 73 68 2d 74 61 62 t)))...(hash-tab
10dc0 6c 65 2d 73 65 74 21 20 76 61 72 73 20 76 61 72 le-set! vars var
10dd0 20 76 61 6c 29 0a 09 09 28 75 6e 73 65 74 65 6e val)...(unseten
10de0 76 20 76 61 72 29 29 29 29 0a 09 76 61 72 2d 70 v var))))..var-p
10df0 61 74 74 73 29 29 0a 20 20 20 20 20 28 67 65 74 atts)). (get
10e00 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
10e10 69 61 62 6c 65 73 29 29 0a 20 20 20 20 28 63 6f iables)). (co
10e20 6e 64 0a 20 20 20 20 20 28 28 73 74 72 69 6e 67 nd. ((string
10e30 3f 20 70 72 6f 63 29 28 73 79 73 74 65 6d 20 70 ? proc)(system p
10e40 72 6f 63 29 29 0a 20 20 20 20 20 28 70 72 6f 63 roc)). (proc
10e50 20 20 20 20 20 20 20 20 20 20 28 70 72 6f 63 29 (proc)
10e60 29 29 0a 20 20 20 20 28 68 61 73 68 2d 74 61 62 )). (hash-tab
10e70 6c 65 2d 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 le-for-each.
10e80 20 76 61 72 73 0a 20 20 20 20 20 28 6c 61 6d 62 vars. (lamb
10e90 64 61 20 28 76 61 72 20 76 61 6c 29 0a 20 20 20 da (var val).
10ea0 20 20 20 20 28 73 65 74 65 6e 76 20 76 61 72 20 (setenv var
10eb0 76 61 6c 29 29 29 0a 20 20 20 20 76 61 72 73 29 val))). vars)
10ec0 29 0a 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d )..(define (comm
10ed0 6f 6e 3a 72 75 6e 2d 61 2d 63 6f 6d 6d 61 6e 64 on:run-a-command
10ee0 20 63 6d 64 20 23 21 6b 65 79 20 28 77 69 74 68 cmd #!key (with
10ef0 2d 76 61 72 73 20 23 66 29 29 0a 20 20 28 6c 65 -vars #f)). (le
10f00 74 2a 20 28 28 70 72 65 2d 63 6d 64 20 20 28 64 t* ((pre-cmd (d
10f10 74 65 73 74 73 3a 67 65 74 2d 70 72 65 2d 63 6f tests:get-pre-co
10f20 6d 6d 61 6e 64 29 29 0a 20 20 20 20 20 20 20 20 mmand)).
10f30 20 28 70 6f 73 74 2d 63 6d 64 20 28 64 74 65 73 (post-cmd (dtes
10f40 74 73 3a 67 65 74 2d 70 6f 73 74 2d 63 6f 6d 6d ts:get-post-comm
10f50 61 6e 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 and)). (
10f60 66 75 6c 6c 63 6d 64 20 20 28 69 66 20 28 6f 72 fullcmd (if (or
10f70 20 70 72 65 2d 63 6d 64 20 70 6f 73 74 2d 63 6d pre-cmd post-cm
10f80 64 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 d).
10f90 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 63 20 (conc
10fa0 70 72 65 2d 63 6d 64 20 63 6d 64 20 70 6f 73 74 pre-cmd cmd post
10fb0 2d 63 6d 64 29 0a 20 20 20 20 20 20 20 20 20 20 -cmd).
10fc0 20 20 20 20 20 20 20 20 20 20 20 20 20 28 63 6f (co
10fd0 6e 63 20 22 76 69 65 77 73 63 72 65 65 6e 20 22 nc "viewscreen "
10fe0 20 63 6d 64 29 29 29 29 0a 20 20 20 20 28 64 65 cmd)))). (de
10ff0 62 75 67 3a 70 72 69 6e 74 2d 69 6e 66 6f 20 30 bug:print-info 0
11000 32 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 2 *default-log-p
11010 6f 72 74 2a 20 22 52 75 6e 6e 69 6e 67 20 63 6f ort* "Running co
11020 6d 6d 61 6e 64 3a 20 22 20 66 75 6c 6c 63 6d 64 mmand: " fullcmd
11030 29 0a 20 20 20 20 28 69 66 20 77 69 74 68 2d 76 ). (if with-v
11040 61 72 73 0a 20 20 20 20 20 20 20 20 28 63 6f 6d ars. (com
11050 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 72 73 mon:without-vars
11060 20 63 6d 64 29 0a 20 20 20 20 20 20 20 20 28 63 cmd). (c
11070 6f 6d 6d 6f 6e 3a 77 69 74 68 6f 75 74 2d 76 61 ommon:without-va
11080 72 73 20 66 75 6c 6c 63 6d 64 20 22 4d 54 5f 2e rs fullcmd "MT_.
11090 2a 22 29 29 29 29 0a 09 09 20 20 0a 3b 3b 3d 3d *"))))... .;;==
110a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
110b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
110c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
110d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
110e0 3d 3d 3d 3d 0a 3b 3b 20 54 20 49 20 4d 20 45 20 ====.;; T I M E
110f0 20 20 41 20 4e 20 44 20 20 20 44 20 41 20 54 20 A N D D A T
11100 45 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d E.;;============
11110 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11120 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11130 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11140 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 43 ==========..;; C
11150 6f 6e 76 65 72 74 20 73 74 72 69 6e 67 73 20 6c onvert strings l
11160 69 6b 65 20 22 35 73 20 32 68 20 33 6d 22 20 3d ike "5s 2h 3m" =
11170 3e 20 36 30 78 36 30 78 32 20 2b 20 33 78 36 30 > 60x60x2 + 3x60
11180 20 2b 20 35 0a 28 64 65 66 69 6e 65 20 28 63 6f + 5.(define (co
11190 6d 6d 6f 6e 3a 68 6d 73 2d 73 74 72 69 6e 67 2d mmon:hms-string-
111a0 3e 73 65 63 6f 6e 64 73 20 74 73 74 72 29 0a 20 >seconds tstr).
111b0 20 28 6c 65 74 20 28 28 70 61 72 74 73 20 20 20 (let ((parts
111c0 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 (string-split
111d0 74 73 74 72 29 29 0a 09 28 74 69 6d 65 2d 73 65 tstr))..(time-se
111e0 63 73 20 30 29 0a 09 3b 3b 20 73 3d 73 65 63 6f cs 0)..;; s=seco
111f0 6e 64 73 2c 20 6d 3d 6d 69 6e 75 74 65 73 2c 20 nds, m=minutes,
11200 68 3d 68 6f 75 72 73 2c 20 64 3d 64 61 79 73 0a h=hours, d=days.
11210 09 28 74 72 78 20 20 20 20 20 20 20 28 72 65 67 .(trx (reg
11220 65 78 70 20 22 28 5c 5c 64 2b 29 28 5b 73 6d 68 exp "(\\d+)([smh
11230 64 5d 29 22 29 29 29 0a 20 20 20 20 28 66 6f 72 d])"))). (for
11240 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 70 -each (lambda (p
11250 61 72 74 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 art)...(let ((ma
11260 74 63 68 20 20 28 73 74 72 69 6e 67 2d 6d 61 74 tch (string-mat
11270 63 68 20 74 72 78 20 70 61 72 74 29 29 29 0a 09 ch trx part)))..
11280 09 20 20 28 69 66 20 6d 61 74 63 68 0a 09 09 20 . (if match...
11290 20 20 20 20 20 28 6c 65 74 20 28 28 76 61 6c 20 (let ((val
112a0 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 (string->number
112b0 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 0a 09 (cadr match)))..
112c0 09 09 20 20 20 20 28 75 6e 74 20 28 63 61 64 64 .. (unt (cadd
112d0 72 20 6d 61 74 63 68 29 29 29 0a 09 09 09 28 69 r match)))....(i
112e0 66 20 76 61 6c 20 0a 09 09 09 20 20 20 20 28 73 f val .... (s
112f0 65 74 21 20 74 69 6d 65 2d 73 65 63 73 20 28 2b et! time-secs (+
11300 20 74 69 6d 65 2d 73 65 63 73 20 28 2a 20 76 61 time-secs (* va
11310 6c 0a 09 09 09 09 09 09 09 20 20 20 20 28 63 61 l........ (ca
11320 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 se (string->symb
11330 6f 6c 20 75 6e 74 29 0a 09 09 09 09 09 09 09 20 ol unt)........
11340 20 20 20 20 20 28 28 73 29 20 31 29 0a 09 09 09 ((s) 1)....
11350 09 09 09 09 20 20 20 20 20 20 28 28 6d 29 20 36 .... ((m) 6
11360 30 29 0a 09 09 09 09 09 09 09 20 20 20 20 20 20 0)........
11370 28 28 68 29 20 28 2a 20 36 30 20 36 30 29 29 0a ((h) (* 60 60)).
11380 09 09 09 09 09 09 09 20 20 20 20 20 20 28 28 64 ....... ((d
11390 29 20 28 2a 20 32 34 20 36 30 20 36 30 29 29 0a ) (* 24 60 60)).
113a0 09 09 09 09 09 09 09 20 20 20 20 20 20 28 65 6c ....... (el
113b0 73 65 20 30 29 29 29 29 29 29 29 29 29 29 0a 09 se 0))))))))))..
113c0 20 20 20 20 20 20 70 61 72 74 73 29 0a 20 20 20 parts).
113d0 20 74 69 6d 65 2d 73 65 63 73 29 29 0a 09 09 20 time-secs))...
113e0 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 .(define (
113f0 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d seconds->hr-min-
11400 73 65 63 20 73 65 63 73 29 0a 20 20 28 6c 65 74 sec secs). (let
11410 2a 20 28 28 68 72 73 20 28 71 75 6f 74 69 65 6e * ((hrs (quotien
11420 74 20 73 65 63 73 20 33 36 30 30 29 29 0a 09 20 t secs 3600))..
11430 28 6d 69 6e 20 28 71 75 6f 74 69 65 6e 74 20 28 (min (quotient (
11440 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 33 36 - secs (* hrs 36
11450 30 30 29 29 20 36 30 29 29 0a 09 20 28 73 65 63 00)) 60)).. (sec
11460 20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 (- secs (* hrs
11470 33 36 30 30 29 28 2a 20 6d 69 6e 20 36 30 29 29 3600)(* min 60))
11480 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 69 66 )). (conc (if
11490 20 28 3e 20 68 72 73 20 30 29 28 63 6f 6e 63 20 (> hrs 0)(conc
114a0 68 72 73 20 22 68 72 20 22 29 20 22 22 29 0a 09 hrs "hr ") "")..
114b0 20 20 28 69 66 20 28 3e 20 6d 69 6e 20 30 29 28 (if (> min 0)(
114c0 63 6f 6e 63 20 6d 69 6e 20 22 6d 20 22 29 20 20 conc min "m ")
114d0 22 22 29 0a 09 20 20 73 65 63 20 22 73 22 29 29 "").. sec "s"))
114e0 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f )..(define (seco
114f0 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 nds->time-string
11500 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 sec). (time->s
11510 74 72 69 6e 67 20 0a 20 20 20 28 73 65 63 6f 6e tring . (secon
11520 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 ds->local-time s
11530 65 63 29 20 22 25 48 3a 25 4d 3a 25 53 22 29 29 ec) "%H:%M:%S"))
11540 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e ..(define (secon
11550 64 73 2d 3e 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 ds->work-week/da
11560 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 y-time sec). (t
11570 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 ime->string. (
11580 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
11590 69 6d 65 20 73 65 63 29 20 22 77 77 25 56 2e 25 ime sec) "ww%V.%
115a0 75 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 66 u %H:%M"))..(def
115b0 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 77 6f ine (seconds->wo
115c0 72 6b 2d 77 65 65 6b 2f 64 61 79 20 73 65 63 29 rk-week/day sec)
115d0 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 . (time->string
115e0 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f . (seconds->lo
115f0 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 77 cal-time sec) "w
11600 77 25 56 2e 25 75 22 29 29 0a 0a 28 64 65 66 69 w%V.%u"))..(defi
11610 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 79 65 61 ne (seconds->yea
11620 72 2d 77 6f 72 6b 2d 77 65 65 6b 2f 64 61 79 20 r-work-week/day
11630 73 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 sec). (time->st
11640 72 69 6e 67 0a 20 20 20 28 73 65 63 6f 6e 64 73 ring. (seconds
11650 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
11660 29 20 22 25 79 77 77 25 56 2e 25 77 22 29 29 0a ) "%yww%V.%w")).
11670 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
11680 73 2d 3e 79 65 61 72 2d 77 6f 72 6b 2d 77 65 65 s->year-work-wee
11690 6b 2f 64 61 79 2d 74 69 6d 65 20 73 65 63 29 0a k/day-time sec).
116a0 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 0a (time->string.
116b0 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 (seconds->loc
116c0 61 6c 2d 74 69 6d 65 20 73 65 63 29 20 22 25 59 al-time sec) "%Y
116d0 77 77 25 56 2e 25 77 20 25 48 3a 25 4d 22 29 29 ww%V.%w %H:%M"))
116e0 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e ..(define (secon
116f0 64 73 2d 3e 79 65 61 72 2d 77 65 65 6b 2f 64 61 ds->year-week/da
11700 79 2d 74 69 6d 65 20 73 65 63 29 0a 20 20 28 74 y-time sec). (t
11710 69 6d 65 2d 3e 73 74 72 69 6e 67 0a 20 20 20 28 ime->string. (
11720 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 seconds->local-t
11730 69 6d 65 20 73 65 63 29 20 22 25 59 77 25 56 2e ime sec) "%Yw%V.
11740 25 77 20 25 48 3a 25 4d 22 29 29 0a 0a 28 64 65 %w %H:%M"))..(de
11750 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 2d 3e 71 fine (seconds->q
11760 75 61 72 74 65 72 20 73 65 63 29 0a 20 20 28 63 uarter sec). (c
11770 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d ase (string->num
11780 62 65 72 0a 09 20 28 74 69 6d 65 2d 3e 73 74 72 ber.. (time->str
11790 69 6e 67 20 0a 09 20 20 28 73 65 63 6f 6e 64 73 ing .. (seconds
117a0 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
117b0 29 0a 09 20 20 22 25 6d 22 29 29 0a 20 20 20 20 ).. "%m")).
117c0 28 28 31 20 32 20 33 29 20 31 29 0a 20 20 20 20 ((1 2 3) 1).
117d0 28 28 34 20 35 20 36 29 20 32 29 0a 20 20 20 20 ((4 5 6) 2).
117e0 28 28 37 20 38 20 39 29 20 33 29 0a 20 20 20 20 ((7 8 9) 3).
117f0 28 28 31 30 20 31 31 20 31 32 29 20 34 29 0a 20 ((10 11 12) 4).
11800 20 20 20 28 65 6c 73 65 20 23 66 29 29 29 0a 0a (else #f)))..
11810 3b 3b 20 62 61 73 69 63 20 49 53 4f 38 36 30 31 ;; basic ISO8601
11820 20 66 6f 72 6d 61 74 20 28 65 2e 67 2e 20 22 32 format (e.g. "2
11830 30 31 37 2d 30 32 2d 32 38 20 30 36 3a 30 32 3a 017-02-28 06:02:
11840 35 34 22 29 20 64 61 74 65 20 74 69 6d 65 20 3d 54") date time =
11850 3e 20 55 6e 69 78 20 65 70 6f 63 68 0a 3b 3b 0a > Unix epoch.;;.
11860 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
11870 64 61 74 65 2d 74 69 6d 65 2d 3e 73 65 63 6f 6e date-time->secon
11880 64 73 20 64 61 74 65 74 69 6d 65 29 0a 20 20 28 ds datetime). (
11890 6c 6f 63 61 6c 2d 74 69 6d 65 2d 3e 73 65 63 6f local-time->seco
118a0 6e 64 73 20 28 73 74 72 69 6e 67 2d 3e 74 69 6d nds (string->tim
118b0 65 20 64 61 74 65 74 69 6d 65 20 22 25 59 2d 25 e datetime "%Y-%
118c0 6d 2d 25 64 20 25 48 3a 25 4d 3a 25 53 22 29 29 m-%d %H:%M:%S"))
118d0 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 73 70 61 6e )..;; given span
118e0 20 6f 66 20 73 65 63 6f 6e 64 73 20 74 73 74 61 of seconds tsta
118f0 72 74 20 74 6f 20 74 65 6e 64 0a 3b 3b 20 66 69 rt to tend.;; fi
11900 6e 64 20 73 74 61 72 74 20 74 69 6d 65 20 74 6f nd start time to
11910 20 6d 61 72 6b 20 61 6e 64 20 6d 61 72 6b 20 64 mark and mark d
11920 65 6c 74 61 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 elta.;;.(define
11930 28 63 6f 6d 6d 6f 6e 3a 66 69 6e 64 2d 73 74 61 (common:find-sta
11940 72 74 2d 6d 61 72 6b 2d 61 6e 64 2d 6d 61 72 6b rt-mark-and-mark
11950 2d 64 65 6c 74 61 20 74 73 74 61 72 74 20 74 65 -delta tstart te
11960 6e 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 65 nd). (let* ((de
11970 6c 74 61 74 20 20 20 28 2d 20 28 6d 61 78 20 74 ltat (- (max t
11980 65 6e 64 20 28 2b 20 74 65 6e 64 20 31 30 29 29 end (+ tend 10))
11990 20 74 73 74 61 72 74 29 29 20 3b 3b 20 63 61 6e tstart)) ;; can
119a0 27 74 20 68 61 6e 64 6c 65 20 72 75 6e 73 20 6f 't handle runs o
119b0 66 20 6c 65 73 73 20 74 68 61 6e 20 34 20 73 65 f less than 4 se
119c0 63 6f 6e 64 73 2e 20 50 61 64 20 69 74 20 74 6f conds. Pad it to
119d0 20 31 30 20 73 65 63 6f 6e 64 73 20 2e 2e 2e 0a 10 seconds ....
119e0 09 20 28 72 65 73 75 6c 74 20 20 20 23 66 29 0a . (result #f).
119f0 09 20 28 6d 69 6e 20 20 20 20 20 20 36 30 29 0a . (min 60).
11a00 09 20 28 68 72 20 20 20 20 20 20 20 28 2a 20 36 . (hr (* 6
11a10 30 20 36 30 29 29 0a 09 20 28 64 61 79 20 20 20 0 60)).. (day
11a20 20 20 20 28 2a 20 32 34 20 68 72 29 29 0a 09 20 (* 24 hr))..
11a30 28 79 72 20 20 20 20 20 20 20 28 2a 20 33 36 35 (yr (* 365
11a40 20 64 61 79 29 29 20 3b 3b 20 79 65 61 72 0a 09 day)) ;; year..
11a50 20 28 6d 6f 20 20 20 20 20 20 20 28 2f 20 79 72 (mo (/ yr
11a60 20 31 32 29 29 0a 09 20 28 77 6b 20 20 20 20 20 12)).. (wk
11a70 20 20 28 2a 20 64 61 79 20 37 29 29 29 0a 20 20 (* day 7))).
11a80 20 20 28 66 6f 72 2d 65 61 63 68 0a 20 20 20 20 (for-each.
11a90 20 28 6c 61 6d 62 64 61 20 28 6d 61 78 2d 62 6c (lambda (max-bl
11aa0 6b 73 29 0a 20 20 20 20 20 20 20 28 66 6f 72 2d ks). (for-
11ab0 65 61 63 68 0a 09 28 6c 61 6d 62 64 61 20 28 73 each..(lambda (s
11ac0 70 61 6e 29 20 3b 3b 20 35 20 32 20 31 0a 09 20 pan) ;; 5 2 1..
11ad0 20 28 69 66 20 28 6e 6f 74 20 72 65 73 75 6c 74 (if (not result
11ae0 29 0a 09 20 20 20 20 20 20 28 66 6f 72 2d 65 61 ).. (for-ea
11af0 63 68 20 0a 09 20 20 20 20 20 20 20 28 6c 61 6d ch .. (lam
11b00 62 64 61 20 28 74 69 6d 65 75 6e 69 74 20 74 69 bda (timeunit ti
11b10 6d 65 73 79 6d 29 20 3b 3b 20 79 65 61 72 20 6d mesym) ;; year m
11b20 6f 6e 74 68 20 64 61 79 20 68 72 20 6d 69 6e 20 onth day hr min
11b30 73 65 63 0a 09 09 20 28 69 66 20 28 6e 6f 74 20 sec... (if (not
11b40 72 65 73 75 6c 74 29 0a 09 09 20 20 20 20 20 28 result)... (
11b50 6c 65 74 2a 20 28 28 74 69 6d 65 2d 62 6c 6b 20 let* ((time-blk
11b60 28 2a 20 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 (* span timeunit
11b70 29 29 0a 09 09 09 20 20 20 20 28 6e 75 6d 2d 62 )).... (num-b
11b80 6c 6b 73 20 28 71 75 6f 74 69 65 6e 74 20 64 65 lks (quotient de
11b90 6c 74 61 74 20 74 69 6d 65 2d 62 6c 6b 29 29 29 ltat time-blk)))
11ba0 0a 09 09 20 20 20 20 20 20 20 28 69 66 20 28 61 ... (if (a
11bb0 6e 64 20 28 3e 20 6e 75 6d 2d 62 6c 6b 73 20 34 nd (> num-blks 4
11bc0 29 28 3c 20 6e 75 6d 2d 62 6c 6b 73 20 6d 61 78 )(< num-blks max
11bd0 2d 62 6c 6b 73 29 29 0a 09 09 09 20 20 20 28 6c -blks)).... (l
11be0 65 74 20 28 28 66 69 72 73 74 20 28 2a 20 28 71 et ((first (* (q
11bf0 75 6f 74 69 65 6e 74 20 74 73 74 61 72 74 20 74 uotient tstart t
11c00 69 6d 65 2d 62 6c 6b 29 20 74 69 6d 65 2d 62 6c ime-blk) time-bl
11c10 6b 29 29 29 0a 09 09 09 20 20 20 20 20 28 73 65 k))).... (se
11c20 74 21 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 t! result (list
11c30 73 70 61 6e 20 74 69 6d 65 75 6e 69 74 20 74 69 span timeunit ti
11c40 6d 65 2d 62 6c 6b 20 66 69 72 73 74 20 74 69 6d me-blk first tim
11c50 65 73 79 6d 29 29 0a 09 09 09 20 20 20 20 20 29 esym)).... )
11c60 29 29 29 29 0a 09 20 20 20 20 20 20 20 28 6c 69 )))).. (li
11c70 73 74 20 79 72 20 6d 6f 20 77 6b 20 64 61 79 20 st yr mo wk day
11c80 68 72 20 6d 69 6e 20 31 29 0a 09 20 20 20 20 20 hr min 1)..
11c90 20 20 27 28 20 20 20 20 20 79 20 20 6d 6f 20 77 '( y mo w
11ca0 20 20 64 20 20 20 68 20 20 6d 20 20 20 73 29 29 d h m s))
11cb0 29 29 0a 09 28 6c 69 73 74 20 38 20 36 20 35 20 ))..(list 8 6 5
11cc0 32 20 31 29 29 29 0a 20 20 20 20 20 27 28 35 20 2 1))). '(5
11cd0 31 30 20 31 35 20 32 30 20 33 30 20 34 30 20 35 10 15 20 30 40 5
11ce0 30 20 35 30 30 29 29 0a 20 20 20 20 28 69 66 20 0 500)). (if
11cf0 76 61 6c 75 65 73 0a 09 28 61 70 70 6c 79 20 76 values..(apply v
11d00 61 6c 75 65 73 20 72 65 73 75 6c 74 29 0a 09 28 alues result)..(
11d10 76 61 6c 75 65 73 20 30 20 64 61 79 20 31 20 30 values 0 day 1 0
11d20 20 27 64 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 'd))))..;; give
11d30 6e 20 78 20 79 20 6c 69 6d 20 72 65 74 75 72 6e n x y lim return
11d40 20 74 68 65 20 63 72 6f 6e 20 65 78 70 61 6e 73 the cron expans
11d50 69 6f 6e 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 ion.;;.(define (
11d60 63 6f 6d 6d 6f 6e 3a 65 78 70 61 6e 64 2d 63 72 common:expand-cr
11d70 6f 6e 2d 73 6c 61 73 68 20 78 20 79 20 6c 69 6d on-slash x y lim
11d80 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 ). (let loop ((
11d90 63 75 72 72 20 78 29 0a 09 20 20 20 20 20 28 72 curr x).. (r
11da0 65 73 20 20 60 28 29 29 29 0a 20 20 20 20 28 69 es `())). (i
11db0 66 20 28 3c 20 63 75 72 72 20 6c 69 6d 29 0a 09 f (< curr lim)..
11dc0 28 6c 6f 6f 70 20 28 2b 20 63 75 72 72 20 79 29 (loop (+ curr y)
11dd0 20 28 63 6f 6e 73 20 63 75 72 72 20 72 65 73 29 (cons curr res)
11de0 29 0a 09 28 72 65 76 65 72 73 65 20 72 65 73 29 )..(reverse res)
11df0 29 29 29 0a 0a 3b 3b 20 65 78 70 61 6e 64 20 61 )))..;; expand a
11e00 20 63 6f 6d 70 6c 65 78 20 63 72 6f 6e 20 73 74 complex cron st
11e10 72 69 6e 67 20 74 6f 20 61 20 6c 69 73 74 20 6f ring to a list o
11e20 66 20 63 72 6f 6e 20 73 74 72 69 6e 67 73 0a 3b f cron strings.;
11e30 3b 0a 3b 3b 20 20 78 2f 79 20 20 20 3d 3e 20 78 ;.;; x/y => x
11e40 2c 20 78 2b 79 2c 20 78 2b 32 79 2c 20 78 2b 33 , x+y, x+2y, x+3
11e50 79 20 77 68 69 6c 65 20 78 2b 4e 79 3c 6d 61 78 y while x+Ny<max
11e60 5f 66 6f 72 5f 66 69 65 6c 64 0a 3b 3b 20 20 61 _for_field.;; a
11e70 2c 62 2c 63 20 3d 3e 20 61 2c 20 62 20 2c 63 0a ,b,c => a, b ,c.
11e80 3b 3b 0a 3b 3b 20 20 20 4e 4f 54 45 3a 20 77 69 ;;.;; NOTE: wi
11e90 74 68 20 66 6c 61 74 74 65 6e 20 61 20 6c 6f 74 th flatten a lot
11ea0 20 6f 66 20 74 68 65 20 63 72 75 64 20 62 65 6c of the crud bel
11eb0 6f 77 20 63 61 6e 20 62 65 20 66 61 63 74 6f 72 ow can be factor
11ec0 65 64 20 64 6f 77 6e 2e 0a 3b 3b 0a 28 64 65 66 ed down..;;.(def
11ed0 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e ine (common:cron
11ee0 2d 65 78 70 61 6e 64 20 63 72 6f 6e 2d 73 74 72 -expand cron-str
11ef0 29 0a 20 20 28 69 66 20 28 6c 69 73 74 3f 20 63 ). (if (list? c
11f00 72 6f 6e 2d 73 74 72 29 0a 20 20 20 20 20 20 28 ron-str). (
11f10 66 6c 61 74 74 65 6e 0a 20 20 20 20 20 20 20 28 flatten. (
11f20 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 78 20 fold (lambda (x
11f30 72 65 73 29 0a 09 20 20 20 20 20 20 20 28 69 66 res).. (if
11f40 20 28 6c 69 73 74 3f 20 78 29 0a 09 09 20 20 20 (list? x)...
11f50 28 6c 65 74 20 28 28 6e 65 77 72 65 73 20 28 6d (let ((newres (m
11f60 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 ap common:cron-e
11f70 78 70 61 6e 64 20 78 29 29 29 0a 09 09 20 20 20 xpand x)))...
11f80 20 20 28 61 70 70 65 6e 64 20 78 20 6e 65 77 72 (append x newr
11f90 65 73 29 29 0a 09 09 20 20 20 28 63 6f 6e 73 20 es))... (cons
11fa0 78 20 72 65 73 29 29 29 0a 09 20 20 20 20 20 27 x res))).. '
11fb0 28 29 0a 09 20 20 20 20 20 63 72 6f 6e 2d 73 74 ().. cron-st
11fc0 72 29 29 20 3b 3b 20 28 6d 61 70 20 63 6f 6d 6d r)) ;; (map comm
11fd0 6f 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 63 on:cron-expand c
11fe0 72 6f 6e 2d 73 74 72 29 29 0a 20 20 20 20 20 20 ron-str)).
11ff0 28 6c 65 74 20 28 28 63 72 6f 6e 2d 69 74 65 6d (let ((cron-item
12000 73 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 s (string-split
12010 63 72 6f 6e 2d 73 74 72 29 29 0a 09 20 20 20 20 cron-str))..
12020 28 73 6c 61 73 68 2d 72 78 20 20 20 28 72 65 67 (slash-rx (reg
12030 65 78 70 20 22 28 5c 5c 64 2b 29 2f 28 5c 5c 64 exp "(\\d+)/(\\d
12040 2b 29 22 29 29 0a 09 20 20 20 20 28 63 6f 6d 6d +)")).. (comm
12050 61 2d 72 78 20 20 20 28 72 65 67 65 78 70 20 22 a-rx (regexp "
12060 2e 2a 2c 2e 2a 22 29 29 0a 09 20 20 20 20 28 6d .*,.*")).. (m
12070 61 78 2d 76 61 6c 73 20 20 20 27 28 28 6d 69 6e ax-vals '((min
12080 20 20 20 20 20 20 20 20 2e 20 36 30 29 0a 09 09 . 60)...
12090 09 20 20 28 68 6f 75 72 20 20 20 20 20 20 20 2e . (hour .
120a0 20 32 34 29 0a 09 09 09 20 20 28 64 61 79 6f 66 24).... (dayof
120b0 6d 6f 6e 74 68 20 2e 20 32 38 29 20 3b 3b 3b 20 month . 28) ;;;
120c0 42 55 47 21 21 21 21 20 54 68 69 73 20 77 69 6c BUG!!!! This wil
120d0 6c 20 62 65 20 61 20 62 75 67 20 66 6f 72 20 73 l be a bug for s
120e0 6f 6d 65 20 63 6f 6d 62 69 6e 61 74 69 6f 6e 73 ome combinations
120f0 0a 09 09 09 20 20 28 6d 6f 6e 74 68 20 20 20 20 .... (month
12100 20 20 2e 20 31 32 29 0a 09 09 09 20 20 28 64 61 . 12).... (da
12110 79 6f 66 77 65 65 6b 20 20 2e 20 37 29 29 29 29 yofweek . 7))))
12120 0a 09 28 69 66 20 28 3c 20 28 6c 65 6e 67 74 68 ..(if (< (length
12130 20 63 72 6f 6e 2d 69 74 65 6d 73 29 20 35 29 20 cron-items) 5)
12140 3b 3b 20 62 61 64 20 73 70 65 63 0a 09 20 20 20 ;; bad spec..
12150 20 63 72 6f 6e 2d 73 74 72 20 3b 3b 20 60 28 2c cron-str ;; `(,
12160 63 72 6f 6e 2d 73 74 72 29 20 20 20 20 20 20 20 cron-str)
12170 20 20 20 20 20 20 20 3b 3b 20 6a 75 73 74 20 72 ;; just r
12180 65 74 75 72 6e 20 74 68 65 20 73 74 72 69 6e 67 eturn the string
12190 2c 20 73 6f 6d 65 74 68 69 6e 67 20 64 6f 77 6e , something down
121a0 73 74 72 65 61 6d 20 77 69 6c 6c 20 66 69 78 20 stream will fix
121b0 69 74 0a 09 20 20 20 20 28 6c 65 74 20 6c 6f 6f it.. (let loo
121c0 70 20 28 28 68 65 64 20 20 28 63 61 72 20 63 72 p ((hed (car cr
121d0 6f 6e 2d 69 74 65 6d 73 29 29 0a 09 09 20 20 20 on-items))...
121e0 20 20 20 20 28 74 61 6c 20 20 28 63 64 72 20 63 (tal (cdr c
121f0 72 6f 6e 2d 69 74 65 6d 73 29 29 0a 09 09 20 20 ron-items))...
12200 20 20 20 20 20 28 74 79 70 65 20 27 6d 69 6e 29 (type 'min)
12210 0a 09 09 20 20 20 20 20 20 20 28 74 79 70 65 2d ... (type-
12220 74 61 6c 20 27 28 68 6f 75 72 20 64 61 79 6f 66 tal '(hour dayof
12230 6d 6f 6e 74 68 20 6d 6f 6e 74 68 20 64 61 79 6f month month dayo
12240 66 77 65 65 6b 29 29 0a 09 09 20 20 20 20 20 20 fweek))...
12250 20 28 72 65 73 20 20 27 28 29 29 29 0a 09 20 20 (res '()))..
12260 20 20 20 20 28 72 65 67 65 78 2d 63 61 73 65 0a (regex-case.
12270 09 09 20 20 68 65 64 0a 09 09 28 73 6c 61 73 68 .. hed...(slash
12280 2d 72 78 20 28 20 5f 20 62 61 73 65 20 69 6e 63 -rx ( _ base inc
12290 72 20 29 20 28 6c 65 74 2a 20 28 28 62 61 73 65 r ) (let* ((base
122a0 6e 20 20 20 20 20 20 20 20 20 20 28 73 74 72 69 n (stri
122b0 6e 67 2d 3e 6e 75 6d 62 65 72 20 62 61 73 65 29 ng->number base)
122c0 29 0a 09 09 09 09 09 09 20 28 69 6e 63 72 6e 20 )....... (incrn
122d0 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
122e0 2d 3e 6e 75 6d 62 65 72 20 69 6e 63 72 29 29 0a ->number incr)).
122f0 09 09 09 09 09 09 20 28 65 78 70 61 6e 64 65 64 ...... (expanded
12300 2d 76 61 6c 73 20 20 28 63 6f 6d 6d 6f 6e 3a 65 -vals (common:e
12310 78 70 61 6e 64 2d 63 72 6f 6e 2d 73 6c 61 73 68 xpand-cron-slash
12320 20 62 61 73 65 6e 20 69 6e 63 72 6e 20 28 61 6c basen incrn (al
12330 69 73 74 2d 72 65 66 20 74 79 70 65 20 6d 61 78 ist-ref type max
12340 2d 76 61 6c 73 29 29 29 0a 09 09 09 09 09 09 20 -vals))).......
12350 28 6e 65 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 20 (new-list-crons
12360 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 20 28 78 (fold (lambda (x
12370 20 6d 79 72 65 73 29 0a 09 09 09 09 09 09 09 09 myres).........
12380 09 20 28 63 6f 6e 73 20 28 63 6f 6e 63 20 28 69 . (cons (conc (i
12390 66 20 28 6e 75 6c 6c 3f 20 72 65 73 29 0a 09 09 f (null? res)...
123a0 09 09 09 09 09 09 09 09 09 20 22 22 0a 09 09 09 ......... ""....
123b0 09 09 09 09 09 09 09 09 20 28 63 6f 6e 63 20 28 ........ (conc (
123c0 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 string-intersper
123d0 73 65 20 72 65 73 20 22 20 22 29 20 22 20 22 29 se res " ") " ")
123e0 29 0a 09 09 09 09 09 09 09 09 09 09 20 20 20 20 )...........
123f0 20 78 20 22 20 22 20 28 73 74 72 69 6e 67 2d 69 x " " (string-i
12400 6e 74 65 72 73 70 65 72 73 65 20 74 61 6c 20 22 ntersperse tal "
12410 20 22 29 29 0a 09 09 09 09 09 09 09 09 09 20 20 "))..........
12420 20 20 20 20 20 6d 79 72 65 73 29 29 0a 09 09 09 myres))....
12430 09 09 09 09 09 20 20 20 20 20 20 20 27 28 29 20 ..... '()
12440 65 78 70 61 6e 64 65 64 2d 76 61 6c 73 29 29 29 expanded-vals)))
12450 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 28 70 72 ...... ;; (pr
12460 69 6e 74 20 22 6e 65 77 2d 6c 69 73 74 2d 63 72 int "new-list-cr
12470 6f 6e 73 3a 20 22 20 6e 65 77 2d 6c 69 73 74 2d ons: " new-list-
12480 63 72 6f 6e 73 29 0a 09 09 09 09 09 20 20 20 20 crons)......
12490 3b 3b 20 28 66 6f 6c 64 20 28 6c 61 6d 62 64 61 ;; (fold (lambda
124a0 20 28 78 20 72 65 73 29 0a 09 09 09 09 09 20 20 (x res)......
124b0 20 20 3b 3b 20 09 20 20 20 20 28 69 66 20 28 6c ;; . (if (l
124c0 69 73 74 3f 20 78 29 0a 09 09 09 09 09 20 20 20 ist? x)......
124d0 20 3b 3b 20 09 09 28 6c 65 74 20 28 28 6e 65 77 ;; ..(let ((new
124e0 72 65 73 20 28 6d 61 70 20 63 6f 6d 6d 6f 6e 3a res (map common:
124f0 63 72 6f 6e 2d 65 78 70 61 6e 64 20 78 29 29 29 cron-expand x)))
12500 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 09 09 20 ...... ;; ..
12510 20 28 61 70 70 65 6e 64 20 78 20 6e 65 77 72 65 (append x newre
12520 73 29 29 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 s))...... ;;
12530 09 09 28 63 6f 6e 73 20 78 20 72 65 73 29 29 29 ..(cons x res)))
12540 0a 09 09 09 09 09 20 20 20 20 3b 3b 20 09 20 20 ...... ;; .
12550 27 28 29 0a 09 09 09 09 09 20 20 20 20 28 66 6c '()...... (fl
12560 61 74 74 65 6e 20 28 6d 61 70 20 63 6f 6d 6d 6f atten (map commo
12570 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 6e 65 n:cron-expand ne
12580 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 29 29 29 29 w-list-crons))))
12590 0a 09 09 3b 3b 09 09 09 09 09 20 20 20 20 28 6d ...;;..... (m
125a0 61 70 20 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 ap common:cron-e
125b0 78 70 61 6e 64 20 28 6d 61 70 20 63 6f 6d 6d 6f xpand (map commo
125c0 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 6e 65 n:cron-expand ne
125d0 77 2d 6c 69 73 74 2d 63 72 6f 6e 73 29 29 29 29 w-list-crons))))
125e0 0a 09 09 28 65 6c 73 65 20 28 69 66 20 28 6e 75 ...(else (if (nu
125f0 6c 6c 3f 20 74 61 6c 29 0a 09 09 09 20 20 63 72 ll? tal).... cr
12600 6f 6e 2d 73 74 72 0a 09 09 09 20 20 28 6c 6f 6f on-str.... (loo
12610 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
12620 74 61 6c 29 28 63 61 72 20 74 79 70 65 2d 74 61 tal)(car type-ta
12630 6c 29 28 63 64 72 20 74 79 70 65 2d 74 61 6c 29 l)(cdr type-tal)
12640 28 61 70 70 65 6e 64 20 72 65 73 20 28 6c 69 73 (append res (lis
12650 74 20 68 65 64 29 29 29 29 29 29 29 29 29 29 29 t hed)))))))))))
12660 0a 09 09 20 20 20 20 20 20 0a 09 20 20 20 20 0a ... .. .
12670 3b 3b 20 67 69 76 65 6e 20 61 20 63 72 6f 6e 20 ;; given a cron
12680 73 74 72 69 6e 67 20 61 6e 64 20 74 68 65 20 6c string and the l
12690 61 73 74 20 74 69 6d 65 20 65 76 65 6e 74 20 77 ast time event w
126a0 61 73 20 70 72 6f 63 65 73 73 65 64 20 72 65 74 as processed ret
126b0 75 72 6e 20 23 74 20 74 6f 20 72 75 6e 20 6f 72 urn #t to run or
126c0 20 23 66 20 74 6f 20 6e 6f 74 20 72 75 6e 0a 3b #f to not run.;
126d0 3b 0a 3b 3b 20 20 6d 69 6e 20 20 20 20 68 6f 75 ;.;; min hou
126e0 72 20 20 20 64 61 79 6f 66 6d 6f 6e 74 68 20 6d r dayofmonth m
126f0 6f 6e 74 68 20 20 64 61 79 6f 66 77 65 65 6b 0a onth dayofweek.
12700 3b 3b 20 30 2d 35 39 20 20 20 20 30 2d 32 33 20 ;; 0-59 0-23
12710 20 20 31 2d 33 31 20 20 20 20 20 20 20 31 2d 31 1-31 1-1
12720 32 20 20 20 30 2d 36 20 20 20 20 20 20 20 20 20 2 0-6
12730 20 23 23 23 20 4e 4f 54 45 3a 20 64 61 79 6f 66 ### NOTE: dayof
12740 77 65 65 6b 20 64 6f 65 73 20 6e 6f 74 20 69 6e week does not in
12750 63 6c 75 64 65 20 37 0a 3b 3b 0a 3b 3b 20 20 23 clude 7.;;.;; #
12760 74 20 3d 3e 20 79 65 73 2c 20 72 75 6e 20 74 68 t => yes, run th
12770 65 20 6a 6f 62 0a 3b 3b 20 20 23 66 20 3d 3e 20 e job.;; #f =>
12780 6e 6f 2c 20 64 6f 20 6e 6f 74 20 72 75 6e 20 74 no, do not run t
12790 68 65 20 6a 6f 62 0a 3b 3b 0a 28 64 65 66 69 6e he job.;;.(defin
127a0 65 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d 65 e (common:cron-e
127b0 76 65 6e 74 20 63 72 6f 6e 2d 73 74 72 20 6e 6f vent cron-str no
127c0 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 w-seconds-in las
127d0 74 2d 64 6f 6e 65 29 20 3b 3b 20 72 65 66 2d 73 t-done) ;; ref-s
127e0 65 63 6f 6e 64 73 20 3d 20 23 66 20 69 73 20 4e econds = #f is N
127f0 4f 57 2e 0a 20 20 28 6c 65 74 2a 20 28 28 63 72 OW.. (let* ((cr
12800 6f 6e 2d 69 74 65 6d 73 20 20 20 20 20 28 6d 61 on-items (ma
12810 70 20 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 p string->number
12820 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 20 63 (string-split c
12830 72 6f 6e 2d 73 74 72 29 29 29 0a 09 20 28 6e 6f ron-str))).. (no
12840 77 2d 73 65 63 6f 6e 64 73 20 20 20 20 28 6f 72 w-seconds (or
12850 20 6e 6f 77 2d 73 65 63 6f 6e 64 73 2d 69 6e 20 now-seconds-in
12860 28 63 75 72 72 65 6e 74 2d 73 65 63 6f 6e 64 73 (current-seconds
12870 29 29 29 0a 09 20 28 6e 6f 77 2d 74 69 6d 65 20 ))).. (now-time
12880 20 20 20 20 20 20 28 73 65 63 6f 6e 64 73 2d 3e (seconds->
12890 6c 6f 63 61 6c 2d 74 69 6d 65 20 6e 6f 77 2d 73 local-time now-s
128a0 65 63 6f 6e 64 73 29 29 0a 09 20 28 6c 61 73 74 econds)).. (last
128b0 2d 64 6f 6e 65 2d 74 69 6d 65 20 28 73 65 63 6f -done-time (seco
128c0 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 nds->local-time
128d0 6c 61 73 74 2d 64 6f 6e 65 29 29 0a 09 20 28 61 last-done)).. (a
128e0 6c 6c 2d 74 69 6d 65 73 20 20 20 20 20 20 28 6d ll-times (m
128f0 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 ake-hash-table))
12900 29 0a 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 ). ;; (print
12910 22 63 72 6f 6e 2d 69 74 65 6d 73 3a 20 22 20 63 "cron-items: " c
12920 72 6f 6e 2d 69 74 65 6d 73 20 22 28 6c 65 6e 67 ron-items "(leng
12930 74 68 20 63 72 6f 6e 2d 69 74 65 6d 73 29 3a 20 th cron-items):
12940 22 20 28 6c 65 6e 67 74 68 20 63 72 6f 6e 2d 69 " (length cron-i
12950 74 65 6d 73 29 29 0a 20 20 20 20 28 69 66 20 28 tems)). (if (
12960 6e 6f 74 20 28 65 71 3f 20 28 6c 65 6e 67 74 68 not (eq? (length
12970 20 63 72 6f 6e 2d 69 74 65 6d 73 29 20 35 29 29 cron-items) 5))
12980 20 3b 3b 20 64 6f 6e 27 74 20 65 76 65 6e 20 74 ;; don't even t
12990 72 79 20 74 6f 20 66 69 67 75 72 65 20 6f 75 74 ry to figure out
129a0 20 6a 75 6e 6b 20 73 74 72 69 6e 67 73 0a 09 23 junk strings..#
129b0 66 0a 09 28 6d 61 74 63 68 2d 6c 65 74 20 28 28 f..(match-let ((
129c0 28 20 20 20 20 20 63 6d 69 6e 20 63 68 6f 75 72 ( cmin chour
129d0 20 63 64 61 79 6f 66 6d 6f 6e 74 68 20 63 6d 6f cdayofmonth cmo
129e0 6e 74 68 20 20 20 20 63 64 61 79 6f 66 77 65 65 nth cdayofwee
129f0 6b 29 0a 09 09 20 20 20 20 20 63 72 6f 6e 2d 69 k)... cron-i
12a00 74 65 6d 73 29 0a 09 09 20 20 20 20 3b 3b 20 30 tems)... ;; 0
12a10 20 20 20 20 20 31 20 20 20 20 32 20 20 20 20 20 1 2
12a20 20 20 20 33 20 20 20 20 20 20 20 20 20 34 20 20 3 4
12a30 20 20 35 20 20 20 20 20 20 36 0a 09 09 20 20 20 5 6...
12a40 20 28 28 6e 73 65 63 20 6e 6d 69 6e 20 6e 68 6f ((nsec nmin nho
12a50 75 72 20 6e 64 61 79 6f 66 6d 6f 6e 74 68 20 6e ur ndayofmonth n
12a60 6d 6f 6e 74 68 20 6e 79 72 20 6e 64 61 79 6f 66 month nyr ndayof
12a70 77 65 65 6b 20 6e 37 20 6e 38 20 6e 39 29 0a 09 week n7 n8 n9)..
12a80 09 20 20 20 20 20 28 76 65 63 74 6f 72 2d 3e 6c . (vector->l
12a90 69 73 74 20 6e 6f 77 2d 74 69 6d 65 29 29 0a 09 ist now-time))..
12aa0 09 20 20 20 20 28 28 6c 73 65 63 20 6c 6d 69 6e . ((lsec lmin
12ab0 20 6c 68 6f 75 72 20 6c 64 61 79 6f 66 6d 6f 6e lhour ldayofmon
12ac0 74 68 20 6c 6d 6f 6e 74 68 20 6c 79 72 20 6c 64 th lmonth lyr ld
12ad0 61 79 6f 66 77 65 65 6b 20 6c 37 20 6c 38 20 6c ayofweek l7 l8 l
12ae0 39 29 0a 09 09 20 20 20 20 20 28 76 65 63 74 6f 9)... (vecto
12af0 72 2d 3e 6c 69 73 74 20 6c 61 73 74 2d 64 6f 6e r->list last-don
12b00 65 2d 74 69 6d 65 29 29 29 0a 09 20 20 3b 3b 20 e-time))).. ;;
12b10 63 72 65 61 74 65 20 61 6c 6c 20 70 6f 73 73 69 create all possi
12b20 62 6c 65 20 74 69 6d 65 20 73 6c 6f 74 73 0a 09 ble time slots..
12b30 20 20 3b 3b 20 72 65 6d 6f 76 65 20 69 6e 76 61 ;; remove inva
12b40 6c 69 64 20 73 6c 6f 74 73 20 64 75 65 20 74 6f lid slots due to
12b50 20 28 66 6f 72 20 65 78 61 6d 70 6c 65 29 20 64 (for example) d
12b60 61 79 20 6f 66 20 77 65 65 6b 0a 09 20 20 3b 3b ay of week.. ;;
12b70 20 67 65 74 20 74 68 65 20 73 74 61 72 74 20 61 get the start a
12b80 6e 64 20 65 6e 64 20 65 6e 74 72 69 65 73 20 66 nd end entries f
12b90 6f 72 20 74 68 65 20 72 65 66 2d 73 65 63 6f 6e or the ref-secon
12ba0 64 73 20 28 63 75 72 72 65 6e 74 29 20 74 69 6d ds (current) tim
12bb0 65 0a 09 20 20 3b 3b 20 69 66 20 6c 61 73 74 2d e.. ;; if last-
12bc0 64 6f 6e 65 20 3e 20 72 65 66 2d 73 65 63 6f 6e done > ref-secon
12bd0 64 73 20 3d 3e 20 74 68 69 73 20 69 73 20 61 6e ds => this is an
12be0 20 45 52 52 4f 52 21 0a 09 20 20 3b 3b 20 64 6f ERROR!.. ;; do
12bf0 65 73 20 74 68 65 20 6c 61 73 74 2d 64 6f 6e 65 es the last-done
12c00 20 74 69 6d 65 20 66 61 6c 6c 20 69 6e 20 74 68 time fall in th
12c10 65 20 6c 65 67 69 74 20 72 65 67 69 6f 6e 3f 0a e legit region?.
12c20 09 20 20 3b 3b 20 20 20 20 79 65 73 20 3d 3e 20 . ;; yes =>
12c30 23 66 20 20 64 6f 20 6e 6f 74 20 72 75 6e 20 61 #f do not run a
12c40 67 61 69 6e 20 74 68 69 73 20 63 6f 6d 6d 61 6e gain this comman
12c50 64 0a 09 20 20 3b 3b 20 20 20 20 6e 6f 20 20 3d d.. ;; no =
12c60 3e 20 23 74 20 20 6f 6b 20 74 6f 20 72 75 6e 20 > #t ok to run
12c70 74 68 65 20 63 6f 6d 6d 61 6e 64 0a 09 20 20 28 the command.. (
12c80 66 6f 72 2d 65 61 63 68 20 3b 3b 20 6d 6f 6e 74 for-each ;; mont
12c90 68 0a 09 20 20 20 28 6c 61 6d 62 64 61 20 28 6d h.. (lambda (m
12ca0 6f 6e 74 68 29 0a 09 20 20 20 20 20 28 66 6f 72 onth).. (for
12cb0 2d 65 61 63 68 20 3b 3b 20 64 61 79 6f 66 6d 6f -each ;; dayofmo
12cc0 6e 74 68 0a 09 20 20 20 20 20 20 28 6c 61 6d 62 nth.. (lamb
12cd0 64 61 20 28 64 6f 6d 29 0a 09 09 28 66 6f 72 2d da (dom)...(for-
12ce0 65 61 63 68 0a 09 09 20 28 6c 61 6d 62 64 61 20 each... (lambda
12cf0 28 68 72 29 20 3b 3b 20 68 6f 75 72 0a 09 09 20 (hr) ;; hour...
12d00 20 20 28 66 6f 72 2d 65 61 63 68 0a 09 09 20 20 (for-each...
12d10 20 20 28 6c 61 6d 62 64 61 20 28 6d 69 6e 75 74 (lambda (minut
12d20 65 29 20 3b 3b 20 6d 69 6e 75 74 65 0a 09 09 20 e) ;; minute...
12d30 20 20 20 20 20 28 6c 65 74 20 28 28 63 6f 70 79 (let ((copy
12d40 2d 6e 6f 77 20 28 61 70 70 6c 79 20 76 65 63 74 -now (apply vect
12d50 6f 72 20 28 76 65 63 74 6f 72 2d 3e 6c 69 73 74 or (vector->list
12d60 20 6e 6f 77 2d 74 69 6d 65 29 29 29 29 0a 09 09 now-time))))...
12d70 09 28 76 65 63 74 6f 72 2d 73 65 74 21 20 63 6f .(vector-set! co
12d80 70 79 2d 6e 6f 77 20 30 20 30 29 20 3b 3b 20 66 py-now 0 0) ;; f
12d90 6f 72 63 65 20 73 65 63 6f 6e 64 73 20 74 6f 20 orce seconds to
12da0 7a 65 72 6f 0a 09 09 09 28 76 65 63 74 6f 72 2d zero....(vector-
12db0 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 20 31 20 set! copy-now 1
12dc0 6d 69 6e 75 74 65 29 0a 09 09 09 28 76 65 63 74 minute)....(vect
12dd0 6f 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 or-set! copy-now
12de0 20 32 20 68 72 29 0a 09 09 09 28 76 65 63 74 6f 2 hr)....(vecto
12df0 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 20 r-set! copy-now
12e00 33 20 64 6f 6d 29 20 20 3b 3b 20 64 6f 6d 20 69 3 dom) ;; dom i
12e10 73 20 61 6c 72 65 61 64 79 20 63 6f 72 72 65 63 s already correc
12e20 74 65 64 20 66 6f 72 20 7a 65 72 6f 20 72 65 66 ted for zero ref
12e30 65 72 65 6e 63 65 64 0a 09 09 09 28 76 65 63 74 erenced....(vect
12e40 6f 72 2d 73 65 74 21 20 63 6f 70 79 2d 6e 6f 77 or-set! copy-now
12e50 20 34 20 6d 6f 6e 74 68 29 0a 09 09 09 28 6c 65 4 month)....(le
12e60 74 2a 20 28 28 63 6f 70 79 2d 6e 6f 77 2d 73 65 t* ((copy-now-se
12e70 63 73 20 28 6c 6f 63 61 6c 2d 74 69 6d 65 2d 3e cs (local-time->
12e80 73 65 63 6f 6e 64 73 20 63 6f 70 79 2d 6e 6f 77 seconds copy-now
12e90 29 29 0a 09 09 09 20 20 20 20 20 20 20 28 6e 65 )).... (ne
12ea0 77 2d 63 6f 70 79 20 20 20 20 20 20 28 73 65 63 w-copy (sec
12eb0 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
12ec0 20 63 6f 70 79 2d 6e 6f 77 2d 73 65 63 73 29 29 copy-now-secs))
12ed0 29 20 3b 3b 20 72 65 6d 61 6b 65 20 74 68 65 20 ) ;; remake the
12ee0 74 69 6d 65 20 76 65 63 74 6f 72 0a 09 09 09 20 time vector....
12ef0 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 63 64 (if (or (not cd
12f00 61 79 6f 66 77 65 65 6b 29 0a 09 09 09 09 20 20 ayofweek).....
12f10 28 65 71 75 61 6c 3f 20 28 76 65 63 74 6f 72 2d (equal? (vector-
12f20 72 65 66 20 6e 65 77 2d 63 6f 70 79 20 36 29 0a ref new-copy 6).
12f30 09 09 09 09 09 20 20 63 64 61 79 6f 66 77 65 65 ..... cdayofwee
12f40 6b 29 29 20 3b 3b 20 69 66 20 74 68 65 20 64 61 k)) ;; if the da
12f50 79 20 69 73 20 73 70 65 63 69 66 69 65 64 20 61 y is specified a
12f60 6e 64 20 61 20 6d 61 74 63 68 20 4f 52 20 69 66 nd a match OR if
12f70 20 74 68 65 20 64 61 79 20 69 73 20 4e 4f 54 20 the day is NOT
12f80 73 70 65 63 69 66 69 65 64 0a 09 09 09 20 20 20 specified....
12f90 20 20 20 28 69 66 20 28 6f 72 20 28 6e 6f 74 20 (if (or (not
12fa0 63 64 61 79 6f 66 6d 6f 6e 74 68 29 0a 09 09 09 cdayofmonth)....
12fb0 09 20 20 20 20 20 20 28 65 71 75 61 6c 3f 20 28 . (equal? (
12fc0 76 65 63 74 6f 72 2d 72 65 66 20 6e 65 77 2d 63 vector-ref new-c
12fd0 6f 70 79 20 33 29 0a 09 09 09 09 09 20 20 20 20 opy 3)......
12fe0 20 20 28 2b 20 31 20 63 64 61 79 6f 66 6d 6f 6e (+ 1 cdayofmon
12ff0 74 68 29 29 29 20 3b 3b 20 69 66 20 74 68 65 20 th))) ;; if the
13000 6d 6f 6e 74 68 20 69 73 20 73 70 65 63 69 66 69 month is specifi
13010 65 64 20 61 6e 64 20 61 20 6d 61 74 63 68 20 4f ed and a match O
13020 52 20 69 66 20 74 68 65 20 6d 6f 6e 74 68 20 69 R if the month i
13030 73 20 4e 4f 54 20 73 70 65 63 69 66 69 65 64 0a s NOT specified.
13040 09 09 09 09 20 20 28 68 61 73 68 2d 74 61 62 6c .... (hash-tabl
13050 65 2d 73 65 74 21 20 61 6c 6c 2d 74 69 6d 65 73 e-set! all-times
13060 20 63 6f 70 79 2d 6e 6f 77 2d 73 65 63 73 20 6e copy-now-secs n
13070 65 77 2d 63 6f 70 79 29 29 29 29 29 29 0a 09 09 ew-copy))))))...
13080 20 20 20 20 28 69 66 20 63 6d 69 6e 0a 09 09 09 (if cmin....
13090 60 28 2c 63 6d 69 6e 29 20 20 3b 3b 20 69 66 20 `(,cmin) ;; if
130a0 67 69 76 65 6e 20 63 6d 69 6e 2c 20 68 61 76 65 given cmin, have
130b0 20 74 6f 20 75 73 65 20 69 74 0a 09 09 09 28 6c to use it....(l
130c0 69 73 74 20 28 2d 20 6e 6d 69 6e 20 31 29 20 6e ist (- nmin 1) n
130d0 6d 69 6e 20 28 2b 20 6e 6d 69 6e 20 31 29 29 29 min (+ nmin 1)))
130e0 29 29 20 3b 3b 20 6d 69 6e 75 74 65 0a 09 09 20 )) ;; minute...
130f0 28 69 66 20 63 68 6f 75 72 0a 09 09 20 20 20 20 (if chour...
13100 20 60 28 2c 63 68 6f 75 72 29 0a 09 09 20 20 20 `(,chour)...
13110 20 20 28 6c 69 73 74 20 28 2d 20 6e 68 6f 75 72 (list (- nhour
13120 20 31 29 20 6e 68 6f 75 72 20 28 2b 20 6e 68 6f 1) nhour (+ nho
13130 75 72 20 31 29 29 29 29 29 20 3b 3b 20 68 6f 75 ur 1))))) ;; hou
13140 72 0a 09 20 20 20 20 20 20 28 69 66 20 63 64 61 r.. (if cda
13150 79 6f 66 6d 6f 6e 74 68 0a 09 09 20 20 60 28 2c yofmonth... `(,
13160 63 64 61 79 6f 66 6d 6f 6e 74 68 29 0a 09 09 20 cdayofmonth)...
13170 20 28 6c 69 73 74 20 28 2d 20 6e 64 61 79 6f 66 (list (- ndayof
13180 6d 6f 6e 74 68 20 31 29 20 6e 64 61 79 6f 66 6d month 1) ndayofm
13190 6f 6e 74 68 20 28 2b 20 6e 64 61 79 6f 66 6d 6f onth (+ ndayofmo
131a0 6e 74 68 20 31 29 29 29 29 29 0a 09 20 20 20 28 nth 1))))).. (
131b0 69 66 20 63 6d 6f 6e 74 68 0a 09 20 20 20 20 20 if cmonth..
131c0 20 20 60 28 2c 63 6d 6f 6e 74 68 29 0a 09 20 20 `(,cmonth)..
131d0 20 20 20 20 20 28 6c 69 73 74 20 28 2d 20 6e 6d (list (- nm
131e0 6f 6e 74 68 20 31 29 20 6e 6d 6f 6e 74 68 20 28 onth 1) nmonth (
131f0 2b 20 6e 6d 6f 6e 74 68 20 31 29 29 29 29 0a 09 + nmonth 1))))..
13200 20 20 28 6c 65 74 20 28 28 62 65 66 6f 72 65 20 (let ((before
13210 23 66 29 0a 09 09 28 69 73 2d 69 6e 20 20 23 66 #f)...(is-in #f
13220 29 29 0a 09 20 20 20 20 28 66 6f 72 2d 65 61 63 )).. (for-eac
13230 68 0a 09 20 20 20 20 20 28 6c 61 6d 62 64 61 20 h.. (lambda
13240 28 6d 6f 6d 65 6e 74 29 0a 09 20 20 20 20 20 20 (moment)..
13250 20 28 69 66 20 28 61 6e 64 20 62 65 66 6f 72 65 (if (and before
13260 0a 09 09 09 28 3c 3d 20 62 65 66 6f 72 65 20 6e ....(<= before n
13270 6f 77 2d 73 65 63 6f 6e 64 73 29 0a 09 09 09 28 ow-seconds)....(
13280 3e 3d 20 6d 6f 6d 65 6e 74 20 6e 6f 77 2d 73 65 >= moment now-se
13290 63 6f 6e 64 73 29 29 0a 09 09 20 20 20 28 62 65 conds))... (be
132a0 67 69 6e 0a 09 09 20 20 20 20 20 3b 3b 20 28 70 gin... ;; (p
132b0 72 69 6e 74 29 0a 09 09 20 20 20 20 20 3b 3b 20 rint)... ;;
132c0 28 70 72 69 6e 74 20 22 42 65 66 6f 72 65 3a 20 (print "Before:
132d0 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
132e0 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
132f0 74 69 6d 65 20 62 65 66 6f 72 65 29 29 29 0a 09 time before)))..
13300 09 20 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 . ;; (print
13310 22 4e 6f 77 3a 20 20 20 20 22 20 28 74 69 6d 65 "Now: " (time
13320 2d 3e 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 ->string (second
13330 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6e 6f s->local-time no
13340 77 2d 73 65 63 6f 6e 64 73 29 29 29 0a 09 09 20 w-seconds)))...
13350 20 20 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 41 ;; (print "A
13360 66 74 65 72 3a 20 20 22 20 28 74 69 6d 65 2d 3e fter: " (time->
13370 73 74 72 69 6e 67 20 28 73 65 63 6f 6e 64 73 2d string (seconds-
13380 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 6d 6f 6d 65 >local-time mome
13390 6e 74 29 29 29 0a 09 09 20 20 20 20 20 3b 3b 20 nt)))... ;;
133a0 28 70 72 69 6e 74 20 22 4c 61 73 74 3a 20 20 20 (print "Last:
133b0 22 20 28 74 69 6d 65 2d 3e 73 74 72 69 6e 67 20 " (time->string
133c0 28 73 65 63 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d (seconds->local-
133d0 74 69 6d 65 20 6c 61 73 74 2d 64 6f 6e 65 29 29 time last-done))
133e0 29 0a 09 09 20 20 20 20 20 28 69 66 20 28 3c 20 )... (if (<
133f0 20 6c 61 73 74 2d 64 6f 6e 65 20 62 65 66 6f 72 last-done befor
13400 65 29 0a 09 09 09 20 28 73 65 74 21 20 69 73 2d e).... (set! is-
13410 69 6e 20 62 65 66 6f 72 65 29 29 0a 09 09 20 20 in before))...
13420 20 20 20 29 29 0a 09 20 20 20 20 20 20 20 28 73 )).. (s
13430 65 74 21 20 62 65 66 6f 72 65 20 6d 6f 6d 65 6e et! before momen
13440 74 29 29 0a 09 20 20 20 20 20 28 73 6f 72 74 20 t)).. (sort
13450 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 79 73 (hash-table-keys
13460 20 61 6c 6c 2d 74 69 6d 65 73 29 20 3c 29 29 0a all-times) <)).
13470 09 20 20 20 20 69 73 2d 69 6e 29 29 29 29 29 0a . is-in))))).
13480 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
13490 3a 65 78 74 65 6e 64 65 64 2d 63 72 6f 6e 20 20 :extended-cron
134a0 63 72 6f 6e 2d 73 74 72 20 6e 6f 77 2d 73 65 63 cron-str now-sec
134b0 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 2d 64 6f 6e onds-in last-don
134c0 65 29 0a 20 20 28 6c 65 74 20 28 28 65 78 70 61 e). (let ((expa
134d0 6e 64 65 64 2d 63 72 6f 6e 20 28 63 6f 6d 6d 6f nded-cron (commo
134e0 6e 3a 63 72 6f 6e 2d 65 78 70 61 6e 64 20 63 72 n:cron-expand cr
134f0 6f 6e 2d 73 74 72 29 29 29 0a 20 20 20 20 28 69 on-str))). (i
13500 66 20 28 73 74 72 69 6e 67 3f 20 65 78 70 61 6e f (string? expan
13510 64 65 64 2d 63 72 6f 6e 29 0a 09 28 63 6f 6d 6d ded-cron)..(comm
13520 6f 6e 3a 63 72 6f 6e 2d 65 76 65 6e 74 20 65 78 on:cron-event ex
13530 70 61 6e 64 65 64 2d 63 72 6f 6e 20 6e 6f 77 2d panded-cron now-
13540 73 65 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 2d seconds-in last-
13550 64 6f 6e 65 29 0a 09 28 6c 65 74 20 6c 6f 6f 70 done)..(let loop
13560 20 28 28 68 65 64 20 28 63 61 72 20 65 78 70 61 ((hed (car expa
13570 6e 64 65 64 2d 63 72 6f 6e 29 29 0a 09 09 20 20 nded-cron))...
13580 20 28 74 61 6c 20 28 63 64 72 20 65 78 70 61 6e (tal (cdr expan
13590 64 65 64 2d 63 72 6f 6e 29 29 29 0a 09 20 20 28 ded-cron))).. (
135a0 69 66 20 28 63 6f 6d 6d 6f 6e 3a 63 72 6f 6e 2d if (common:cron-
135b0 65 76 65 6e 74 20 68 65 64 20 6e 6f 77 2d 73 65 event hed now-se
135c0 63 6f 6e 64 73 2d 69 6e 20 6c 61 73 74 2d 64 6f conds-in last-do
135d0 6e 65 29 0a 09 20 20 20 20 20 20 23 74 0a 09 20 ne).. #t..
135e0 20 20 20 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 (if (null?
135f0 74 61 6c 29 0a 09 09 20 20 23 66 0a 09 09 20 20 tal)... #f...
13600 28 6c 6f 6f 70 20 28 63 61 72 20 74 61 6c 29 28 (loop (car tal)(
13610 63 64 72 20 74 61 6c 29 29 29 29 29 29 29 29 0a cdr tal)))))))).
13620 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
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 0a 3b 3b 20 43 20 4f =========.;; C O
13670 20 4c 20 4f 20 52 20 53 0a 3b 3b 3d 3d 3d 3d 3d L O R S.;;=====
13680 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13690 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
136a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
136b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
136c0 3d 0a 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 =. .(define
136d0 20 28 63 6f 6d 6d 6f 6e 3a 6e 61 6d 65 2d 3e 69 (common:name->i
136e0 75 70 2d 63 6f 6c 6f 72 20 6e 61 6d 65 29 0a 20 up-color name).
136f0 20 28 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e (case (string->
13700 73 79 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 symbol (string-d
13710 6f 77 6e 63 61 73 65 20 6e 61 6d 65 29 29 0a 20 owncase name)).
13720 20 20 20 28 28 72 65 64 29 20 20 20 20 22 32 32 ((red) "22
13730 33 20 33 33 20 34 39 22 29 0a 20 20 20 20 28 28 3 33 49"). ((
13740 67 72 65 79 29 20 20 20 22 31 39 32 20 31 39 32 grey) "192 192
13750 20 31 39 32 22 29 0a 20 20 20 20 28 28 6f 72 61 192"). ((ora
13760 6e 67 65 29 20 22 32 35 35 20 31 37 32 20 31 33 nge) "255 172 13
13770 22 29 0a 20 20 20 20 28 28 70 75 72 70 6c 65 29 "). ((purple)
13780 20 22 54 68 69 73 20 69 73 20 75 6e 66 69 6e 69 "This is unfini
13790 73 68 65 64 20 2e 2e 2e 22 29 29 29 0a 0a 3b 3b shed ...")))..;;
137a0 20 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e (define (common
137b0 3a 67 65 74 2d 63 6f 6c 6f 72 2d 66 6f 72 2d 73 :get-color-for-s
137c0 74 61 74 65 2d 73 74 61 74 75 73 20 73 74 61 74 tate-status stat
137d0 65 20 73 74 61 74 75 73 29 0a 3b 3b 20 20 20 28 e status).;; (
137e0 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
137f0 6d 62 6f 6c 20 73 74 61 74 65 29 0a 3b 3b 20 20 mbol state).;;
13800 20 20 20 28 28 43 4f 4d 50 4c 45 54 45 44 29 0a ((COMPLETED).
13810 3b 3b 20 20 20 20 20 20 28 63 61 73 65 20 28 73 ;; (case (s
13820 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 tring->symbol st
13830 61 74 75 73 29 0a 3b 3b 20 20 20 20 20 20 20 20 atus).;;
13840 28 28 50 41 53 53 29 20 20 20 20 20 20 20 20 22 ((PASS) "
13850 37 30 20 20 32 34 39 20 37 33 22 29 0a 3b 3b 20 70 249 73").;;
13860 20 20 20 20 20 20 20 28 28 57 41 52 4e 20 57 41 ((WARN WA
13870 49 56 45 44 29 20 22 32 35 35 20 31 37 32 20 31 IVED) "255 172 1
13880 33 22 29 0a 3b 3b 20 20 20 20 20 20 20 20 28 28 3").;; ((
13890 53 4b 49 50 29 20 20 20 20 20 20 20 20 22 32 33 SKIP) "23
138a0 30 20 32 33 30 20 30 22 29 0a 3b 3b 20 20 20 20 0 230 0").;;
138b0 20 20 20 20 28 65 6c 73 65 20 22 32 32 33 20 33 (else "223 3
138c0 33 20 34 39 22 29 29 29 0a 3b 3b 20 20 20 20 20 3 49"))).;;
138d0 28 28 4c 41 55 4e 43 48 45 44 29 20 20 20 20 20 ((LAUNCHED)
138e0 20 20 20 20 22 31 30 31 20 31 32 33 20 31 34 32 "101 123 142
138f0 22 29 0a 3b 3b 20 20 20 20 20 28 28 43 48 45 43 ").;; ((CHEC
13900 4b 29 20 20 20 20 20 20 20 20 20 20 20 20 22 32 K) "2
13910 35 35 20 31 30 30 20 35 30 22 29 0a 3b 3b 20 20 55 100 50").;;
13920 20 20 20 28 28 52 45 4d 4f 54 45 48 4f 53 54 53 ((REMOTEHOSTS
13930 54 41 52 54 29 20 20 22 35 30 20 20 31 33 30 20 TART) "50 130
13940 31 39 35 22 29 0a 3b 3b 20 20 20 20 20 28 28 52 195").;; ((R
13950 55 4e 4e 49 4e 47 29 20 20 20 20 20 20 20 20 20 UNNING)
13960 20 22 39 20 20 20 31 33 31 20 32 33 32 22 29 0a "9 131 232").
13970 3b 3b 20 20 20 20 20 28 28 4b 49 4c 4c 52 45 51 ;; ((KILLREQ
13980 29 20 20 20 20 20 20 20 20 20 20 22 33 39 20 20 ) "39
13990 38 32 20 20 32 30 36 22 29 0a 3b 3b 20 20 20 20 82 206").;;
139a0 20 28 28 4b 49 4c 4c 45 44 29 20 20 20 20 20 20 ((KILLED)
139b0 20 20 20 20 20 22 32 33 34 20 31 30 31 20 31 37 "234 101 17
139c0 22 29 0a 3b 3b 20 20 20 20 20 28 28 4e 4f 54 5f ").;; ((NOT_
139d0 53 54 41 52 54 45 44 29 20 20 20 20 20 20 22 32 STARTED) "2
139e0 34 30 20 32 34 30 20 32 34 30 22 29 0a 3b 3b 20 40 240 240").;;
139f0 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 (else
13a00 20 20 20 20 20 20 20 20 22 31 39 32 20 31 39 32 "192 192
13a10 20 31 39 32 22 29 29 29 0a 0a 28 64 65 66 69 6e 192")))..(defin
13a20 65 20 28 63 6f 6d 6d 6f 6e 3a 69 75 70 2d 63 6f e (common:iup-co
13a30 6c 6f 72 2d 3e 72 67 62 2d 68 65 78 20 69 6e 73 lor->rgb-hex ins
13a40 74 72 29 0a 20 20 28 73 74 72 69 6e 67 2d 69 6e tr). (string-in
13a50 74 65 72 73 70 65 72 73 65 20 0a 20 20 20 28 6d tersperse . (m
13a60 61 70 20 28 6c 61 6d 62 64 61 20 28 78 29 0a 20 ap (lambda (x).
13a70 20 20 20 20 20 20 20 20 20 28 6e 75 6d 62 65 72 (number
13a80 2d 3e 73 74 72 69 6e 67 20 78 20 31 36 29 29 0a ->string x 16)).
13a90 20 20 20 20 20 20 20 20 28 6d 61 70 20 73 74 72 (map str
13aa0 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 20 20 20 20 ing->number.
13ab0 20 20 20 20 20 20 20 20 20 28 73 74 72 69 6e 67 (string
13ac0 2d 73 70 6c 69 74 20 69 6e 73 74 72 29 29 29 0a -split instr))).
13ad0 20 20 20 22 2f 22 29 29 0a 0a 3b 3b 3d 3d 3d 3d "/"))..;;====
13ae0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13af0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b20 3d 3d 0a 3b 3b 20 4c 20 4f 20 43 20 4b 20 49 20 ==.;; L O C K I
13b30 4e 20 47 20 20 20 4d 20 45 20 43 20 48 20 41 20 N G M E C H A
13b40 4e 20 49 20 53 20 4d 20 53 20 0a 3b 3b 3d 3d 3d N I S M S .;;===
13b50 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b60 3d 3d 3d 3d 3d 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 0a 0a 3b 3b 20 66 61 75 78 2d 6c 6f 63 ===..;; faux-loc
13ba0 6b 20 69 73 20 64 65 70 72 65 63 61 74 65 64 2e k is deprecated.
13bb0 20 50 6c 65 61 73 65 20 75 73 65 20 73 69 6d 70 Please use simp
13bc0 6c 65 2d 6c 6f 63 6b 20 62 65 6c 6f 77 0a 3b 3b le-lock below.;;
13bd0 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e .(define (common
13be0 3a 66 61 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e 61 :faux-lock keyna
13bf0 6d 65 20 23 21 6b 65 79 20 28 77 61 69 74 2d 74 me #!key (wait-t
13c00 69 6d 65 20 38 29 28 61 6c 6c 6f 77 2d 6c 6f 63 ime 8)(allow-loc
13c10 6b 2d 73 74 65 61 6c 20 23 74 29 29 0a 20 20 28 k-steal #t)). (
13c20 69 66 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d if (rmt:no-sync-
13c30 67 65 74 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e get/default keyn
13c40 61 6d 65 20 23 66 29 20 3b 3b 20 64 6f 20 6e 6f ame #f) ;; do no
13c50 74 20 62 65 20 74 65 6d 70 74 65 64 20 74 6f 20 t be tempted to
13c60 63 6f 6d 70 61 72 65 20 74 6f 20 70 69 64 2e 20 compare to pid.
13c70 6c 6f 63 6b 69 6e 67 20 69 73 20 61 20 6f 6e 65 locking is a one
13c80 2d 73 68 6f 74 20 61 63 74 69 6f 6e 2c 20 69 66 -shot action, if
13c90 20 61 6c 72 65 61 64 79 20 6c 6f 63 6b 65 64 20 already locked
13ca0 66 6f 72 20 74 68 69 73 20 70 69 64 20 69 74 20 for this pid it
13cb0 64 6f 65 73 6e 27 74 20 61 63 74 75 61 6c 6c 79 doesn't actually
13cc0 20 63 6f 75 6e 74 0a 20 20 20 20 20 20 28 69 66 count. (if
13cd0 20 28 3e 20 77 61 69 74 2d 74 69 6d 65 20 30 29 (> wait-time 0)
13ce0 0a 09 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 .. (begin..
13cf0 28 74 68 72 65 61 64 2d 73 6c 65 65 70 21 20 31 (thread-sleep! 1
13d00 29 0a 09 20 20 20 20 28 69 66 20 28 65 71 3f 20 ).. (if (eq?
13d10 77 61 69 74 2d 74 69 6d 65 20 31 29 20 3b 3b 20 wait-time 1) ;;
13d20 6f 6e 6c 79 20 6f 6e 65 20 73 65 63 6f 6e 64 20 only one second
13d30 6c 65 66 74 2c 20 73 74 65 61 6c 20 74 68 65 20 left, steal the
13d40 6c 6f 63 6b 0a 09 09 28 62 65 67 69 6e 0a 09 09 lock...(begin...
13d50 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 (debug:print-i
13d60 6e 66 6f 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 0 *default-l
13d70 6f 67 2d 70 6f 72 74 2a 20 22 73 74 65 61 6c 69 og-port* "steali
13d80 6e 67 20 6c 6f 63 6b 20 66 6f 72 20 22 20 6b 65 ng lock for " ke
13d90 79 6e 61 6d 65 29 0a 09 09 20 20 28 63 6f 6d 6d yname)... (comm
13da0 6f 6e 3a 66 61 75 78 2d 75 6e 6c 6f 63 6b 20 6b on:faux-unlock k
13db0 65 79 6e 61 6d 65 20 66 6f 72 63 65 3a 20 23 74 eyname force: #t
13dc0 29 29 29 0a 09 20 20 20 20 28 63 6f 6d 6d 6f 6e ))).. (common
13dd0 3a 66 61 75 78 2d 6c 6f 63 6b 20 6b 65 79 6e 61 :faux-lock keyna
13de0 6d 65 20 77 61 69 74 2d 74 69 6d 65 3a 20 28 2d me wait-time: (-
13df0 20 77 61 69 74 2d 74 69 6d 65 20 31 29 29 29 0a wait-time 1))).
13e00 09 20 20 23 66 29 0a 20 20 20 20 20 20 28 62 65 . #f). (be
13e10 67 69 6e 0a 20 20 20 20 20 20 20 20 28 72 6d 74 gin. (rmt
13e20 3a 6e 6f 2d 73 79 6e 63 2d 73 65 74 20 6b 65 79 :no-sync-set key
13e30 6e 61 6d 65 20 28 63 6f 6e 63 20 28 63 75 72 72 name (conc (curr
13e40 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 ent-process-id))
13e50 29 0a 20 20 20 20 20 20 20 20 28 65 71 75 61 6c ). (equal
13e60 3f 20 28 63 6f 6e 63 20 28 63 75 72 72 65 6e 74 ? (conc (current
13e70 2d 70 72 6f 63 65 73 73 2d 69 64 29 29 20 28 63 -process-id)) (c
13e80 6f 6e 63 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 onc (rmt:no-sync
13e90 2d 67 65 74 2f 64 65 66 61 75 6c 74 20 6b 65 79 -get/default key
13ea0 6e 61 6d 65 20 23 66 29 29 29 29 29 29 0a 0a 28 name #f))))))..(
13eb0 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 66 define (common:f
13ec0 61 75 78 2d 75 6e 6c 6f 63 6b 20 6b 65 79 6e 61 aux-unlock keyna
13ed0 6d 65 20 23 21 6b 65 79 20 28 66 6f 72 63 65 20 me #!key (force
13ee0 23 66 29 29 0a 20 20 28 69 66 20 28 6f 72 20 66 #f)). (if (or f
13ef0 6f 72 63 65 20 28 65 71 75 61 6c 3f 20 28 63 6f orce (equal? (co
13f00 6e 63 20 28 63 75 72 72 65 6e 74 2d 70 72 6f 63 nc (current-proc
13f10 65 73 73 2d 69 64 29 29 20 28 63 6f 6e 63 20 28 ess-id)) (conc (
13f20 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 2f rmt:no-sync-get/
13f30 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 20 default keyname
13f40 23 66 29 29 29 29 0a 20 20 20 20 20 20 28 62 65 #f)))). (be
13f50 67 69 6e 0a 20 20 20 20 20 20 20 20 28 69 66 20 gin. (if
13f60 28 72 6d 74 3a 6e 6f 2d 73 79 6e 63 2d 67 65 74 (rmt:no-sync-get
13f70 2f 64 65 66 61 75 6c 74 20 6b 65 79 6e 61 6d 65 /default keyname
13f80 20 23 66 29 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e #f) (rmt:no-syn
13f90 63 2d 64 65 6c 21 20 6b 65 79 6e 61 6d 65 29 29 c-del! keyname))
13fa0 0a 20 20 20 20 20 20 20 20 23 74 29 0a 20 20 20 . #t).
13fb0 20 20 20 23 66 29 29 0a 0a 3b 3b 20 73 69 6d 70 #f))..;; simp
13fc0 6c 65 20 6c 6f 63 6b 2e 20 69 6d 70 72 6f 76 65 le lock. improve
13fd0 20 61 6e 64 20 63 6f 6e 76 65 72 67 65 20 6f 6e and converge on
13fe0 20 74 68 69 73 20 6f 6e 65 2e 0a 3b 3b 0a 28 64 this one..;;.(d
13ff0 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 73 69 efine (common:si
14000 6d 70 6c 65 2d 6c 6f 63 6b 20 6b 65 79 6e 61 6d mple-lock keynam
14010 65 29 0a 20 20 28 72 6d 74 3a 6e 6f 2d 73 79 6e e). (rmt:no-syn
14020 63 2d 67 65 74 2d 6c 6f 63 6b 20 6b 65 79 6e 61 c-get-lock keyna
14030 6d 65 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d me))..;;========
14040 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14050 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14060 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14070 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
14080 3b 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;.;;============
14090 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
140a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
140b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
140c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
140d0 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 69 6e 2d 72 ine (common:in-r
140e0 75 6e 6e 69 6e 67 2d 74 65 73 74 3f 29 0a 20 20 unning-test?).
140f0 28 61 6e 64 20 28 61 72 67 73 3a 67 65 74 2d 61 (and (args:get-a
14100 72 67 20 22 2d 65 78 65 63 75 74 65 22 29 20 28 rg "-execute") (
14110 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
14120 76 61 72 69 61 62 6c 65 20 22 4d 54 5f 43 4d 44 variable "MT_CMD
14130 49 4e 46 4f 22 29 29 29 0a 0a 28 64 65 66 69 6e INFO")))..(defin
14140 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f e (common:get-co
14150 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 lor-from-status
14160 73 74 61 74 75 73 29 0a 20 20 28 63 6f 6e 64 0a status). (cond.
14170 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
14180 75 73 20 22 50 41 53 53 22 29 20 20 20 20 22 67 us "PASS") "g
14190 72 65 65 6e 22 29 0a 20 20 20 28 28 65 71 75 61 reen"). ((equa
141a0 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 l? status "FAIL"
141b0 29 20 20 20 20 22 72 65 64 22 29 0a 20 20 20 28 ) "red"). (
141c0 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
141d0 57 41 52 4e 22 29 20 20 20 20 22 6f 72 61 6e 67 WARN") "orang
141e0 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
141f0 73 74 61 74 75 73 20 22 4b 49 4c 4c 45 44 22 29 status "KILLED")
14200 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 "orange"). (
14210 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
14220 4b 49 4c 4c 52 45 51 22 29 20 22 70 75 72 70 6c KILLREQ") "purpl
14230 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
14240 73 74 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 status "RUNNING"
14250 29 20 22 62 6c 75 65 22 29 0a 20 20 20 28 28 65 ) "blue"). ((e
14260 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 41 42 qual? status "AB
14270 4f 52 54 22 29 20 20 20 22 62 72 6f 77 6e 22 29 ORT") "brown")
14280 0a 20 20 20 28 65 6c 73 65 20 22 62 6c 61 63 6b . (else "black
14290 22 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d ")))..;;========
142a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
142d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b ==============.;
142e0 3b 20 4e 20 41 20 4e 20 4f 20 4d 20 53 20 47 20 ; N A N O M S G
142f0 20 20 43 20 4c 20 49 20 45 20 4e 20 54 0a 3b 3b C L I E N T.;;
14300 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14310 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14320 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14330 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14340 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 ======..(define
14350 28 73 65 72 76 65 72 3a 67 65 74 2d 62 65 73 74 (server:get-best
14360 2d 67 75 65 73 73 2d 61 64 64 72 65 73 73 20 68 -guess-address h
14370 6f 73 74 6e 61 6d 65 29 0a 20 20 28 6c 65 74 20 ostname). (let
14380 28 28 72 65 73 20 23 66 29 29 0a 20 20 20 20 28 ((res #f)). (
14390 66 6f 72 2d 65 61 63 68 20 0a 20 20 20 20 20 28 for-each . (
143a0 6c 61 6d 62 64 61 20 28 61 64 72 29 0a 20 20 20 lambda (adr).
143b0 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 71 (if (not (eq
143c0 3f 20 28 75 38 76 65 63 74 6f 72 2d 72 65 66 20 ? (u8vector-ref
143d0 61 64 72 20 30 29 20 31 32 37 29 29 0a 09 20 20 adr 0) 127))..
143e0 20 28 73 65 74 21 20 72 65 73 20 61 64 72 29 29 (set! res adr))
143f0 29 0a 20 20 20 20 20 3b 3b 20 4e 4f 54 45 3a 20 ). ;; NOTE:
14400 54 68 69 73 20 63 61 6e 20 66 61 69 6c 20 77 68 This can fail wh
14410 65 6e 20 74 68 65 72 65 20 69 73 20 6e 6f 20 6d en there is no m
14420 65 6e 74 69 6f 6e 20 6f 66 20 74 68 65 20 68 6f ention of the ho
14430 73 74 20 69 6e 20 2f 65 74 63 2f 68 6f 73 74 73 st in /etc/hosts
14440 2e 20 46 49 58 4d 45 0a 20 20 20 20 20 28 76 65 . FIXME. (ve
14450 63 74 6f 72 2d 3e 6c 69 73 74 20 28 68 6f 73 74 ctor->list (host
14460 69 6e 66 6f 2d 61 64 64 72 65 73 73 65 73 20 28 info-addresses (
14470 68 6f 73 74 6e 61 6d 65 2d 3e 68 6f 73 74 69 6e hostname->hostin
14480 66 6f 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 0a fo hostname)))).
14490 20 20 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 (string-inte
144a0 72 73 70 65 72 73 65 20 0a 20 20 20 20 20 28 6d rsperse . (m
144b0 61 70 20 6e 75 6d 62 65 72 2d 3e 73 74 72 69 6e ap number->strin
144c0 67 0a 09 20 20 28 75 38 76 65 63 74 6f 72 2d 3e g.. (u8vector->
144d0 6c 69 73 74 0a 09 20 20 20 28 69 66 20 72 65 73 list.. (if res
144e0 20 72 65 73 20 28 68 6f 73 74 6e 61 6d 65 2d 3e res (hostname->
144f0 69 70 20 68 6f 73 74 6e 61 6d 65 29 29 29 29 20 ip hostname))))
14500 22 2e 22 29 29 29 0a 0a 0a 28 64 65 66 69 6e 65 ".")))...(define
14510 20 28 63 6f 6d 6d 6f 6e 3a 73 65 6e 64 2d 64 62 (common:send-db
14520 6f 61 72 64 2d 6d 61 69 6e 2d 63 68 61 6e 67 65 oard-main-change
14530 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 61 73 d). (let* ((das
14540 68 62 6f 61 72 64 2d 69 70 73 20 28 6d 64 64 62 hboard-ips (mddb
14550 3a 67 65 74 2d 64 61 73 68 62 6f 61 72 64 73 29 :get-dashboards)
14560 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 68 )). (for-each
14570 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 69 . (lambda (i
14580 70 61 64 72 29 0a 20 20 20 20 20 20 20 28 6c 65 padr). (le
14590 74 2a 20 28 28 73 6f 63 20 28 63 6f 6d 6d 6f 6e t* ((soc (common
145a0 3a 6f 70 65 6e 2d 6e 6d 2d 72 65 71 20 28 63 6f :open-nm-req (co
145b0 6e 63 20 22 74 63 70 3a 2f 2f 22 20 69 70 61 64 nc "tcp://" ipad
145c0 72 29 29 29 0a 09 20 20 20 20 20 20 28 6d 73 67 r))).. (msg
145d0 20 28 63 6f 6e 63 20 22 6d 61 69 6e 20 22 20 2a (conc "main " *
145e0 74 6f 70 70 61 74 68 2a 29 29 0a 09 20 20 20 20 toppath*))..
145f0 20 20 28 72 65 73 20 28 63 6f 6d 6d 6f 6e 3a 6e (res (common:n
14600 6d 2d 73 65 6e 64 2d 72 65 63 65 69 76 65 2d 74 m-send-receive-t
14610 69 6d 65 6f 75 74 20 73 6f 63 20 6d 73 67 29 29 imeout soc msg))
14620 29 0a 09 20 28 69 66 20 28 6e 6f 74 20 72 65 73 ).. (if (not res
14630 29 20 3b 3b 20 63 6f 75 6c 64 6e 27 74 20 72 65 ) ;; couldn't re
14640 61 63 68 20 74 68 61 74 20 64 61 73 68 62 6f 61 ach that dashboa
14650 72 64 20 2d 20 72 65 6d 6f 76 65 20 69 74 20 66 rd - remove it f
14660 72 6f 6d 20 64 62 0a 09 20 20 20 20 20 28 70 72 rom db.. (pr
14670 69 6e 74 20 22 45 52 52 4f 52 3a 20 63 6f 75 6c int "ERROR: coul
14680 64 6e 27 74 20 72 65 61 63 68 20 64 61 73 68 62 dn't reach dashb
14690 6f 61 72 64 20 22 20 69 70 61 64 72 29 29 0a 09 oard " ipadr))..
146a0 20 72 65 73 29 29 0a 20 20 20 20 20 64 61 73 68 res)). dash
146b0 62 6f 61 72 64 2d 69 70 73 29 29 29 0a 20 20 20 board-ips))).
146c0 20 0a 20 20 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d . .;;=======
146d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
146e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
146f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14700 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
14710 3b 3b 20 44 20 41 20 53 20 48 20 42 20 4f 20 41 ;; D A S H B O A
14720 20 52 20 44 20 20 20 44 20 42 20 0a 3b 3b 3d 3d R D D B .;;==
14730 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14740 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14750 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14760 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14770 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 6d ====..(define (m
14780 64 64 62 3a 6f 70 65 6e 2d 64 62 29 0a 20 20 28 ddb:open-db). (
14790 6c 65 74 2a 20 28 28 64 62 20 28 6f 70 65 6e 2d let* ((db (open-
147a0 64 61 74 61 62 61 73 65 20 28 63 6f 6e 63 20 28 database (conc (
147b0 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d get-environment-
147c0 76 61 72 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 variable "HOME")
147d0 20 22 2f 2e 64 61 73 68 62 6f 61 72 64 2e 64 62 "/.dashboard.db
147e0 22 29 29 29 29 0a 20 20 20 20 28 73 65 74 2d 62 ")))). (set-b
147f0 75 73 79 2d 68 61 6e 64 6c 65 72 21 20 64 62 20 usy-handler! db
14800 28 62 75 73 79 2d 74 69 6d 65 6f 75 74 20 31 30 (busy-timeout 10
14810 30 30 30 29 29 0a 20 20 20 20 28 66 6f 72 2d 65 000)). (for-e
14820 61 63 68 0a 20 20 20 20 20 28 6c 61 6d 62 64 61 ach. (lambda
14830 20 28 71 72 79 29 0a 20 20 20 20 20 20 20 28 65 (qry). (e
14840 78 65 63 20 28 73 71 6c 20 64 62 20 71 72 79 29 xec (sql db qry)
14850 29 29 0a 20 20 20 20 20 28 6c 69 73 74 20 0a 20 )). (list .
14860 20 20 20 20 20 22 43 52 45 41 54 45 20 54 41 42 "CREATE TAB
14870 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 53 54 53 LE IF NOT EXISTS
14880 20 76 61 72 73 20 20 20 20 20 20 20 28 69 64 20 vars (id
14890 49 4e 54 45 47 45 52 20 50 52 49 4d 41 52 59 20 INTEGER PRIMARY
148a0 4b 45 59 2c 6b 65 79 20 54 45 58 54 2c 20 76 61 KEY,key TEXT, va
148b0 6c 20 54 45 58 54 2c 20 43 4f 4e 53 54 52 41 49 l TEXT, CONSTRAI
148c0 4e 54 20 76 61 72 73 63 6f 6e 73 74 72 61 69 6e NT varsconstrain
148d0 74 20 55 4e 49 51 55 45 20 28 6b 65 79 29 29 3b t UNIQUE (key));
148e0 22 0a 20 20 20 20 20 20 22 43 52 45 41 54 45 20 ". "CREATE
148f0 54 41 42 4c 45 20 49 46 20 4e 4f 54 20 45 58 49 TABLE IF NOT EXI
14900 53 54 53 20 64 61 73 68 62 6f 61 72 64 73 20 28 STS dashboards (
14910 0a 20 20 20 20 20 20 20 20 20 20 69 64 20 20 20 . id
14920 20 20 20 20 20 20 49 4e 54 45 47 45 52 20 50 52 INTEGER PR
14930 49 4d 41 52 59 20 4b 45 59 2c 0a 20 20 20 20 20 IMARY KEY,.
14940 20 20 20 20 20 70 69 64 20 20 20 20 20 20 20 20 pid
14950 49 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 INTEGER,.
14960 20 20 20 75 73 65 72 6e 61 6d 65 20 20 20 54 45 username TE
14970 58 54 2c 0a 20 20 20 20 20 20 20 20 20 20 68 6f XT,. ho
14980 73 74 6e 61 6d 65 20 20 20 54 45 58 54 2c 0a 20 stname TEXT,.
14990 20 20 20 20 20 20 20 20 20 69 70 61 64 64 72 20 ipaddr
149a0 20 20 20 20 54 45 58 54 2c 0a 20 20 20 20 20 20 TEXT,.
149b0 20 20 20 20 70 6f 72 74 6e 75 6d 20 20 20 20 49 portnum I
149c0 4e 54 45 47 45 52 2c 0a 20 20 20 20 20 20 20 20 NTEGER,.
149d0 20 20 73 74 61 72 74 5f 74 69 6d 65 20 54 49 4d start_time TIM
149e0 45 53 54 41 4d 50 20 44 45 46 41 55 4c 54 20 28 ESTAMP DEFAULT (
149f0 73 74 72 66 74 69 6d 65 28 27 25 73 27 2c 27 6e strftime('%s','n
14a00 6f 77 27 29 29 2c 0a 20 20 20 20 20 20 20 20 20 ow')),.
14a10 20 20 20 20 43 4f 4e 53 54 52 41 49 4e 54 20 68 CONSTRAINT h
14a20 6f 73 74 70 6f 72 74 20 55 4e 49 51 55 45 20 28 ostport UNIQUE (
14a30 68 6f 73 74 6e 61 6d 65 2c 70 6f 72 74 6e 75 6d hostname,portnum
14a40 29 0a 20 20 20 20 20 20 20 20 29 3b 22 0a 20 20 ). );".
14a50 20 20 20 20 29 29 0a 20 20 20 20 64 62 29 29 0a )). db)).
14a60 0a 3b 3b 20 72 65 67 69 73 74 65 72 20 61 20 64 .;; register a d
14a70 61 73 68 62 6f 61 72 64 20 0a 3b 3b 0a 28 64 65 ashboard .;;.(de
14a80 66 69 6e 65 20 28 6d 64 64 62 3a 72 65 67 69 73 fine (mddb:regis
14a90 74 65 72 2d 64 61 73 68 62 6f 61 72 64 20 70 6f ter-dashboard po
14aa0 72 74 29 0a 20 20 28 6c 65 74 2a 20 28 28 70 69 rt). (let* ((pi
14ab0 64 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d d (current-
14ac0 70 72 6f 63 65 73 73 2d 69 64 29 29 0a 09 20 28 process-id)).. (
14ad0 68 6f 73 74 6e 61 6d 65 20 28 67 65 74 2d 68 6f hostname (get-ho
14ae0 73 74 2d 6e 61 6d 65 29 29 0a 09 20 28 69 70 61 st-name)).. (ipa
14af0 64 64 72 20 20 20 28 73 65 72 76 65 72 3a 67 65 ddr (server:ge
14b00 74 2d 62 65 73 74 2d 67 75 65 73 73 2d 61 64 64 t-best-guess-add
14b10 72 65 73 73 20 68 6f 73 74 6e 61 6d 65 29 29 0a ress hostname)).
14b20 09 20 28 75 73 65 72 6e 61 6d 65 20 28 63 75 72 . (username (cur
14b30 72 65 6e 74 2d 75 73 65 72 2d 6e 61 6d 65 29 29 rent-user-name))
14b40 20 3b 3b 20 28 63 61 72 20 75 73 65 72 69 6e 66 ;; (car userinf
14b50 6f 29 29 29 0a 09 20 28 64 62 20 20 20 20 20 20 o))).. (db
14b60 28 6d 64 64 62 3a 6f 70 65 6e 2d 64 62 29 29 29 (mddb:open-db)))
14b70 0a 20 20 20 20 28 70 72 69 6e 74 20 22 52 65 67 . (print "Reg
14b80 69 73 74 65 72 20 6d 6f 6e 69 74 6f 72 2c 20 70 ister monitor, p
14b90 69 64 3a 20 22 20 70 69 64 20 22 2c 20 68 6f 73 id: " pid ", hos
14ba0 74 6e 61 6d 65 3a 20 22 20 68 6f 73 74 6e 61 6d tname: " hostnam
14bb0 65 20 22 2c 20 70 6f 72 74 3a 20 22 20 70 6f 72 e ", port: " por
14bc0 74 20 22 2c 20 75 73 65 72 6e 61 6d 65 3a 20 22 t ", username: "
14bd0 20 75 73 65 72 6e 61 6d 65 29 0a 20 20 20 20 28 username). (
14be0 65 78 65 63 20 28 73 71 6c 20 64 62 20 22 49 4e exec (sql db "IN
14bf0 53 45 52 54 20 4f 52 20 52 45 50 4c 41 43 45 20 SERT OR REPLACE
14c00 49 4e 54 4f 20 64 61 73 68 62 6f 61 72 64 73 20 INTO dashboards
14c10 28 70 69 64 2c 75 73 65 72 6e 61 6d 65 2c 68 6f (pid,username,ho
14c20 73 74 6e 61 6d 65 2c 69 70 61 64 64 72 2c 70 6f stname,ipaddr,po
14c30 72 74 6e 75 6d 29 20 56 41 4c 55 45 53 20 28 3f rtnum) VALUES (?
14c40 2c 3f 2c 3f 2c 3f 2c 3f 29 3b 22 29 0a 09 20 20 ,?,?,?,?);")..
14c50 20 70 69 64 20 75 73 65 72 6e 61 6d 65 20 68 6f pid username ho
14c60 73 74 6e 61 6d 65 20 69 70 61 64 64 72 20 70 6f stname ipaddr po
14c70 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 65 2d 64 rt). (close-d
14c80 61 74 61 62 61 73 65 20 64 62 29 29 29 0a 0a 3b atabase db)))..;
14c90 3b 20 75 6e 72 65 67 69 73 74 65 72 20 61 20 6d ; unregister a m
14ca0 6f 6e 69 74 6f 72 0a 3b 3b 0a 28 64 65 66 69 6e onitor.;;.(defin
14cb0 65 20 28 6d 64 64 62 3a 75 6e 72 65 67 69 73 74 e (mddb:unregist
14cc0 65 72 2d 64 61 73 68 62 6f 61 72 64 20 68 6f 73 er-dashboard hos
14cd0 74 20 70 6f 72 74 29 0a 20 20 28 6c 65 74 2a 20 t port). (let*
14ce0 28 28 64 62 20 20 20 20 20 20 28 6d 64 64 62 3a ((db (mddb:
14cf0 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 28 open-db))). (
14d00 70 72 69 6e 74 20 22 52 65 67 69 73 74 65 72 20 print "Register
14d10 75 6e 72 65 67 69 73 74 65 72 20 6d 6f 6e 69 74 unregister monit
14d20 6f 72 2c 20 68 6f 73 74 3a 70 6f 72 74 3d 22 20 or, host:port="
14d30 68 6f 73 74 20 22 3a 22 20 70 6f 72 74 29 0a 20 host ":" port).
14d40 20 20 20 28 65 78 65 63 20 28 73 71 6c 20 64 62 (exec (sql db
14d50 20 22 44 45 4c 45 54 45 20 46 52 4f 4d 20 64 61 "DELETE FROM da
14d60 73 68 62 6f 61 72 64 73 20 57 48 45 52 45 20 68 shboards WHERE h
14d70 6f 73 74 6e 61 6d 65 3d 3f 20 41 4e 44 20 70 6f ostname=? AND po
14d80 72 74 6e 75 6d 3d 3f 3b 22 29 20 68 6f 73 74 20 rtnum=?;") host
14d90 70 6f 72 74 29 0a 20 20 20 20 28 63 6c 6f 73 65 port). (close
14da0 2d 64 61 74 61 62 61 73 65 20 64 62 29 29 29 0a -database db))).
14db0 0a 3b 3b 20 67 65 74 20 72 65 67 69 73 74 65 72 .;; get register
14dc0 65 64 20 64 61 73 68 62 6f 61 72 64 73 0a 3b 3b ed dashboards.;;
14dd0 0a 28 64 65 66 69 6e 65 20 28 6d 64 64 62 3a 67 .(define (mddb:g
14de0 65 74 2d 64 61 73 68 62 6f 61 72 64 73 29 0a 20 et-dashboards).
14df0 20 28 6c 65 74 20 28 28 64 62 20 28 6d 64 64 62 (let ((db (mddb
14e00 3a 6f 70 65 6e 2d 64 62 29 29 29 0a 20 20 20 20 :open-db))).
14e10 28 71 75 65 72 79 20 66 65 74 63 68 2d 63 6f 6c (query fetch-col
14e20 75 6d 6e 0a 09 20 20 20 28 73 71 6c 20 64 62 20 umn.. (sql db
14e30 22 53 45 4c 45 43 54 20 69 70 61 64 64 72 20 7c "SELECT ipaddr |
14e40 7c 20 27 3a 27 20 7c 7c 20 70 6f 72 74 6e 75 6d | ':' || portnum
14e50 20 46 52 4f 4d 20 64 61 73 68 62 6f 61 72 64 73 FROM dashboards
14e60 3b 22 29 29 29 29 0a 20 20 20 20 0a 3b 3b 3d 3d ;")))). .;;==
14e70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14e90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14ea0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14eb0 3d 3d 3d 3d 0a 3b 3b 20 20 54 20 45 20 53 20 54 ====.;; T E S T
14ec0 20 20 20 4c 20 41 20 55 20 4e 20 43 20 48 20 49 L A U N C H I
14ed0 20 4e 20 47 20 20 20 50 20 45 20 52 20 20 20 49 N G P E R I
14ee0 20 54 20 45 20 4d 20 20 20 57 20 49 20 54 20 48 T E M W I T H
14ef0 20 20 20 48 20 4f 20 53 20 54 20 20 20 54 20 59 H O S T T Y
14f00 20 50 20 45 20 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d P E S.;;=======
14f10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f20 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f30 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
14f40 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
14f50 3b 3b 20 0a 3b 3b 20 5b 68 6f 73 74 73 5d 0a 3b ;; .;; [hosts].;
14f60 3b 20 61 72 6d 20 63 75 62 69 65 30 31 20 63 75 ; arm cubie01 cu
14f70 62 69 65 30 32 0a 3b 3b 20 78 38 36 5f 36 34 20 bie02.;; x86_64
14f80 7a 65 75 73 20 78 65 6e 61 20 6d 79 74 68 30 31 zeus xena myth01
14f90 0a 3b 3b 20 61 6c 6c 68 6f 73 74 73 20 23 7b 67 .;; allhosts #{g
14fa0 20 68 6f 73 74 73 20 61 72 6d 7d 20 23 7b 67 20 hosts arm} #{g
14fb0 68 6f 73 74 73 20 78 38 36 5f 36 34 7d 0a 3b 3b hosts x86_64}.;;
14fc0 20 0a 3b 3b 20 5b 68 6f 73 74 2d 74 79 70 65 73 .;; [host-types
14fd0 5d 0a 3b 3b 20 67 65 6e 65 72 61 6c 20 23 4d 54 ].;; general #MT
14fe0 4c 4f 57 45 53 54 4c 4f 41 44 20 23 7b 67 20 68 LOWESTLOAD #{g h
14ff0 6f 73 74 73 20 61 6c 6c 68 6f 73 74 73 7d 0a 3b osts allhosts}.;
15000 3b 20 61 72 6d 20 20 20 20 20 23 4d 54 4c 4f 57 ; arm #MTLOW
15010 45 53 54 4c 4f 41 44 20 23 7b 67 20 68 6f 73 74 ESTLOAD #{g host
15020 73 20 61 72 6d 7d 0a 3b 3b 20 6e 62 67 65 6e 65 s arm}.;; nbgene
15030 72 61 6c 20 6e 62 6a 6f 62 20 72 75 6e 20 4a 4f ral nbjob run JO
15040 42 43 4f 4d 4d 41 4e 44 20 2d 6c 6f 67 20 24 4d BCOMMAND -log $M
15050 54 5f 4c 49 4e 4b 54 52 45 45 2f 24 4d 54 5f 54 T_LINKTREE/$MT_T
15060 41 52 47 45 54 2f 24 4d 54 5f 52 55 4e 4e 41 4d ARGET/$MT_RUNNAM
15070 45 2e 24 4d 54 5f 54 45 53 54 4e 41 4d 45 2d 24 E.$MT_TESTNAME-$
15080 4d 54 5f 49 54 45 4d 5f 50 41 54 48 2e 6c 67 6f MT_ITEM_PATH.lgo
15090 0a 3b 3b 20 0a 3b 3b 20 5b 6c 61 75 6e 63 68 65 .;; .;; [launche
150a0 72 73 5d 0a 3b 3b 20 65 6e 76 73 65 74 75 70 20 rs].;; envsetup
150b0 67 65 6e 65 72 61 6c 0a 3b 3b 20 78 6f 72 2f 25 general.;; xor/%
150c0 2f 6e 20 34 43 31 36 47 0a 3b 3b 20 25 20 6e 62 /n 4C16G.;; % nb
150d0 67 65 6e 65 72 61 6c 0a 3b 3b 20 0a 3b 3b 20 5b general.;; .;; [
150e0 6a 6f 62 74 6f 6f 6c 73 5d 0a 3b 3b 20 23 20 69 jobtools].;; # i
150f0 66 20 64 65 66 69 6e 65 64 20 61 6e 64 20 6e 6f f defined and no
15100 74 20 22 6e 6f 22 20 66 6c 65 78 69 2d 6c 61 75 t "no" flexi-lau
15110 6e 63 68 65 72 20 77 69 6c 6c 20 62 79 70 61 73 ncher will bypas
15120 73 20 22 6c 61 75 6e 63 68 65 72 22 20 75 6e 6c s "launcher" unl
15130 65 73 73 20 6e 6f 20 6d 61 74 63 68 2e 0a 3b 3b ess no match..;;
15140 20 66 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 flexi-launcher
15150 79 65 73 20 20 0a 3b 3b 20 6c 61 75 6e 63 68 65 yes .;; launche
15160 72 20 6e 62 66 61 6b 65 0a 3b 3b 0a 28 64 65 66 r nbfake.;;.(def
15170 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
15180 6c 61 75 6e 63 68 65 72 20 63 6f 6e 66 69 67 64 launcher configd
15190 61 74 20 74 65 73 74 6e 61 6d 65 20 69 74 65 6d at testname item
151a0 70 61 74 68 29 0a 20 20 28 6c 65 74 20 28 28 66 path). (let ((f
151b0 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 allback-launcher
151c0 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
151d0 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 configdat "jobt
151e0 6f 6f 6c 73 22 20 22 6c 61 75 6e 63 68 65 72 22 ools" "launcher"
151f0 29 29 29 0a 20 20 20 20 28 69 66 20 28 61 6e 64 ))). (if (and
15200 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
15210 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 configdat "jobt
15220 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 75 ools" "flexi-lau
15230 6e 63 68 65 72 22 29 20 3b 3b 20 6f 76 65 72 72 ncher") ;; overr
15240 69 64 65 73 20 6c 61 75 6e 63 68 65 72 0a 09 20 ides launcher..
15250 20 20 20 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f (not (equal?
15260 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f 6b 75 70 (configf:lookup
15270 20 63 6f 6e 66 69 67 64 61 74 20 22 6a 6f 62 74 configdat "jobt
15280 6f 6f 6c 73 22 20 22 66 6c 65 78 69 2d 6c 61 75 ools" "flexi-lau
15290 6e 63 68 65 72 22 29 20 22 6e 6f 22 29 29 29 0a ncher") "no"))).
152a0 09 28 6c 65 74 2a 20 28 28 6c 61 75 6e 63 68 65 .(let* ((launche
152b0 72 73 20 20 20 20 20 20 20 20 20 28 68 61 73 68 rs (hash
152c0 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 -table-ref/defau
152d0 6c 74 20 63 6f 6e 66 69 67 64 61 74 20 22 6c 61 lt configdat "la
152e0 75 6e 63 68 65 72 73 22 20 27 28 29 29 29 29 0a unchers" '()))).
152f0 09 20 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6c 61 . (if (null? la
15300 75 6e 63 68 65 72 73 29 0a 09 20 20 20 20 20 20 unchers)..
15310 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 fallback-launche
15320 72 0a 09 20 20 20 20 20 20 28 6c 65 74 20 6c 6f r.. (let lo
15330 6f 70 20 28 28 68 65 64 20 28 63 61 72 20 6c 61 op ((hed (car la
15340 75 6e 63 68 65 72 73 29 29 0a 09 09 09 20 28 74 unchers)).... (t
15350 61 6c 20 28 63 64 72 20 6c 61 75 6e 63 68 65 72 al (cdr launcher
15360 73 29 29 29 0a 09 09 28 6c 65 74 20 28 28 70 61 s)))...(let ((pa
15370 74 74 20 20 20 20 20 20 28 63 61 72 20 68 65 64 tt (car hed
15380 29 29 0a 09 09 20 20 20 20 20 20 28 68 6f 73 74 ))... (host
15390 2d 74 79 70 65 20 28 63 61 64 72 20 68 65 64 29 -type (cadr hed)
153a0 29 29 0a 09 09 20 20 28 69 66 20 28 74 65 73 74 ))... (if (test
153b0 73 3a 6d 61 74 63 68 20 70 61 74 74 20 74 65 73 s:match patt tes
153c0 74 6e 61 6d 65 20 69 74 65 6d 70 61 74 68 29 0a tname itempath).
153d0 09 09 20 20 20 20 20 20 28 62 65 67 69 6e 0a 09 .. (begin..
153e0 09 09 28 64 65 62 75 67 3a 70 72 69 6e 74 2d 69 ..(debug:print-i
153f0 6e 66 6f 20 32 20 2a 64 65 66 61 75 6c 74 2d 6c nfo 2 *default-l
15400 6f 67 2d 70 6f 72 74 2a 20 22 48 61 76 65 20 66 og-port* "Have f
15410 6c 65 78 69 2d 6c 61 75 6e 63 68 65 72 20 6d 61 lexi-launcher ma
15420 74 63 68 20 66 6f 72 20 22 20 74 65 73 74 6e 61 tch for " testna
15430 6d 65 20 22 2f 22 20 69 74 65 6d 70 61 74 68 20 me "/" itempath
15440 22 20 3d 20 22 20 68 6f 73 74 2d 74 79 70 65 29 " = " host-type)
15450 0a 09 09 09 28 6c 65 74 20 28 28 6c 61 75 6e 63 ....(let ((launc
15460 68 65 72 20 28 63 6f 6e 66 69 67 66 3a 6c 6f 6f her (configf:loo
15470 6b 75 70 20 63 6f 6e 66 69 67 64 61 74 20 22 68 kup configdat "h
15480 6f 73 74 2d 74 79 70 65 73 22 20 68 6f 73 74 2d ost-types" host-
15490 74 79 70 65 29 29 29 0a 09 09 09 20 20 28 69 66 type))).... (if
154a0 20 6c 61 75 6e 63 68 65 72 0a 09 09 09 20 20 20 launcher....
154b0 20 20 20 28 6c 65 74 2a 20 28 28 6c 61 75 6e 63 (let* ((launc
154c0 68 65 72 2d 70 61 72 74 73 20 28 73 74 72 69 6e her-parts (strin
154d0 67 2d 73 70 6c 69 74 20 6c 61 75 6e 63 68 65 72 g-split launcher
154e0 29 29 0a 09 09 09 09 20 20 20 20 20 28 6c 61 75 ))..... (lau
154f0 6e 63 68 65 72 2d 65 78 65 20 20 20 28 63 61 72 ncher-exe (car
15500 20 6c 61 75 6e 63 68 65 72 2d 70 61 72 74 73 29 launcher-parts)
15510 29 29 0a 09 09 09 09 28 69 66 20 28 65 71 75 61 )).....(if (equa
15520 6c 3f 20 6c 61 75 6e 63 68 65 72 2d 65 78 65 20 l? launcher-exe
15530 22 23 4d 54 4c 4f 57 45 53 54 4c 4f 41 44 22 29 "#MTLOWESTLOAD")
15540 20 3b 3b 20 74 68 69 73 20 69 73 20 6f 75 72 20 ;; this is our
15550 73 70 65 63 69 61 6c 20 63 61 73 65 2c 20 77 65 special case, we
15560 20 77 69 6c 6c 20 66 69 6e 64 20 74 68 65 20 6c will find the l
15570 6f 77 65 73 74 20 6c 6f 61 64 20 61 6e 64 20 63 owest load and c
15580 72 61 66 74 20 61 20 6e 62 66 61 6b 65 20 63 6f raft a nbfake co
15590 6d 6d 61 6e 64 6c 69 6e 65 0a 09 09 09 09 20 20 mmandline.....
155a0 20 20 28 6c 65 74 20 28 28 74 61 72 67 2d 68 6f (let ((targ-ho
155b0 73 74 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 6c st (common:get-l
155c0 65 61 73 74 2d 6c 6f 61 64 65 64 2d 68 6f 73 74 east-loaded-host
155d0 20 28 63 64 72 20 6c 61 75 6e 63 68 65 72 2d 70 (cdr launcher-p
155e0 61 72 74 73 29 29 29 29 0a 09 09 09 09 20 20 20 arts)))).....
155f0 20 20 20 28 63 6f 6e 63 20 22 72 65 6d 72 75 6e (conc "remrun
15600 20 22 20 74 61 72 67 2d 68 6f 73 74 29 29 0a 09 " targ-host))..
15610 09 09 09 20 20 20 20 6c 61 75 6e 63 68 65 72 29 ... launcher)
15620 29 0a 09 09 09 20 20 20 20 20 20 28 62 65 67 69 ).... (begi
15630 6e 0a 09 09 09 09 28 64 65 62 75 67 3a 70 72 69 n.....(debug:pri
15640 6e 74 2d 69 6e 66 6f 20 30 20 2a 64 65 66 61 75 nt-info 0 *defau
15650 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 57 41 lt-log-port* "WA
15660 52 4e 49 4e 47 3a 20 6e 6f 20 6c 61 75 6e 63 68 RNING: no launch
15670 65 72 20 66 6f 75 6e 64 20 66 6f 72 20 68 6f 73 er found for hos
15680 74 2d 74 79 70 65 20 22 20 68 6f 73 74 2d 74 79 t-type " host-ty
15690 70 65 29 0a 09 09 09 09 28 69 66 20 28 6e 75 6c pe).....(if (nul
156a0 6c 3f 20 74 61 6c 29 0a 09 09 09 09 20 20 20 20 l? tal).....
156b0 66 61 6c 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 fallback-launche
156c0 72 0a 09 09 09 09 20 20 20 20 28 6c 6f 6f 70 20 r..... (loop
156d0 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 74 61 (car tal)(cdr ta
156e0 6c 29 29 29 29 29 29 29 0a 09 09 20 20 20 20 20 l)))))))...
156f0 20 3b 3b 20 6e 6f 20 6d 61 74 63 68 2c 20 74 72 ;; no match, tr
15700 79 20 61 67 61 69 6e 0a 09 09 20 20 20 20 20 20 y again...
15710 28 69 66 20 28 6e 75 6c 6c 3f 20 74 61 6c 29 0a (if (null? tal).
15720 09 09 09 20 20 66 61 6c 6c 62 61 63 6b 2d 6c 61 ... fallback-la
15730 75 6e 63 68 65 72 0a 09 09 09 20 20 28 6c 6f 6f uncher.... (loo
15740 70 20 28 63 61 72 20 74 61 6c 29 28 63 64 72 20 p (car tal)(cdr
15750 74 61 6c 29 29 29 29 29 29 29 29 0a 09 66 61 6c tal))))))))..fal
15760 6c 62 61 63 6b 2d 6c 61 75 6e 63 68 65 72 29 29 lback-launcher))
15770 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d )..;;===========
15780 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15790 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
157a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
157b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 4e ===========.;; N
157c0 4d 53 47 20 41 4e 44 20 4e 45 57 20 41 50 49 0a MSG AND NEW API.
157d0 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
157e0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
157f0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15800 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15810 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 6e 6d 20 ========..;; nm
15820 62 61 73 65 64 20 73 65 72 76 65 72 0a 3b 3b 0a based server.;;.
15830 28 64 65 66 69 6e 65 20 28 6e 6d 3a 73 74 61 72 (define (nm:star
15840 74 2d 73 65 72 76 65 72 20 64 62 63 6f 6e 6e 20 t-server dbconn
15850 23 21 6b 65 79 20 28 67 69 76 65 6e 2d 68 6f 73 #!key (given-hos
15860 74 2d 6e 61 6d 65 20 23 66 29 29 0a 20 20 28 6c t-name #f)). (l
15870 65 74 2a 20 28 28 73 72 76 64 61 74 20 20 20 20 et* ((srvdat
15880 28 73 74 61 72 74 2d 72 61 77 2d 73 65 72 76 65 (start-raw-serve
15890 72 20 67 69 76 65 6e 2d 68 6f 73 74 2d 6e 61 6d r given-host-nam
158a0 65 3a 20 67 69 76 65 6e 2d 68 6f 73 74 2d 6e 61 e: given-host-na
158b0 6d 65 29 29 0a 09 20 28 68 6f 73 74 2d 6e 61 6d me)).. (host-nam
158c0 65 20 28 73 72 76 64 61 74 2d 68 6f 73 74 20 73 e (srvdat-host s
158d0 72 76 64 61 74 29 29 0a 09 20 28 73 6f 63 20 20 rvdat)).. (soc
158e0 20 20 20 20 20 28 73 72 76 64 61 74 2d 73 6f 63 (srvdat-soc
158f0 20 73 72 76 64 61 74 29 29 29 0a 20 20 20 20 0a srvdat))). .
15900 20 20 20 20 3b 3b 20 73 74 61 72 74 20 74 68 65 ;; start the
15910 20 71 75 65 75 65 20 70 72 6f 63 65 73 73 6f 72 queue processor
15920 20 28 73 61 76 65 20 66 6f 72 20 73 65 63 6f 6e (save for secon
15930 64 20 72 6f 75 6e 64 20 6f 66 20 64 65 76 65 6c d round of devel
15940 6f 70 6d 65 6e 74 29 0a 20 20 20 20 3b 3b 0a 20 opment). ;;.
15950 20 20 20 3b 3b 20 28 74 68 72 65 61 64 2d 73 74 ;; (thread-st
15960 61 72 74 21 20 28 71 75 65 75 65 2d 70 72 6f 63 art! (queue-proc
15970 65 73 73 6f 72 79 20 64 62 63 6f 6e 6e 29 20 22 essory dbconn) "
15980 51 75 65 75 65 20 70 72 6f 63 65 73 73 6f 72 22 Queue processor"
15990 29 0a 20 20 20 20 3b 3b 20 6d 73 67 20 69 73 20 ). ;; msg is
159a0 61 6e 20 61 6c 69 73 74 0a 20 20 20 20 3b 3b 20 an alist. ;;
159b0 20 27 72 20 68 6f 73 74 3a 70 6f 72 74 20 20 3c 'r host:port <
159c0 3d 3d 20 77 68 65 72 65 20 74 6f 20 72 65 74 75 == where to retu
159d0 72 6e 20 74 68 65 20 64 61 74 61 0a 20 20 20 20 rn the data.
159e0 3b 3b 20 20 27 70 20 70 61 72 61 6d 73 20 20 20 ;; 'p params
159f0 20 20 3c 3d 3d 20 64 61 74 61 20 74 6f 20 61 70 <== data to ap
15a00 70 6c 79 20 74 68 65 20 63 6f 6d 6d 61 6e 64 20 ply the command
15a10 74 6f 0a 20 20 20 20 3b 3b 20 20 27 65 20 6a 7c to. ;; 'e j|
15a20 73 7c 6c 20 20 20 20 20 20 3c 3d 3d 20 65 6e 63 s|l <== enc
15a30 6f 64 69 6e 67 20 6f 66 20 74 68 65 20 70 61 72 oding of the par
15a40 61 6d 73 2e 20 64 65 66 61 75 6c 74 20 69 73 20 ams. default is
15a50 73 20 28 73 65 78 70 29 2c 20 69 66 20 6e 6f 74 s (sexp), if not
15a60 20 73 70 65 63 69 66 69 65 64 20 69 73 20 61 73 specified is as
15a70 73 75 6d 65 64 20 74 6f 20 62 65 20 64 65 66 61 sumed to be defa
15a80 75 6c 74 0a 20 20 20 20 3b 3b 20 20 27 63 20 63 ult. ;; 'c c
15a90 6f 6d 6d 61 6e 64 20 20 20 20 3c 3d 3d 20 6c 6f ommand <== lo
15aa0 6f 6b 20 75 70 20 74 68 65 20 66 75 6e 63 74 69 ok up the functi
15ab0 6f 6e 20 74 6f 20 63 61 6c 6c 20 75 73 69 6e 67 on to call using
15ac0 20 74 68 69 73 20 6b 65 79 0a 20 20 20 20 3b 3b this key. ;;
15ad0 0a 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 . (let loop (
15ae0 28 6d 73 67 2d 69 6e 20 28 6e 6e 2d 72 65 63 76 (msg-in (nn-recv
15af0 20 73 6f 63 29 29 29 0a 20 20 20 20 20 20 28 69 soc))). (i
15b00 66 20 28 6e 6f 74 20 28 65 71 75 61 6c 3f 20 6d f (not (equal? m
15b10 73 67 2d 69 6e 20 22 71 75 69 74 22 29 29 0a 09 sg-in "quit"))..
15b20 20 20 28 6c 65 74 2a 20 28 28 64 61 74 20 20 20 (let* ((dat
15b30 20 20 20 20 20 28 64 65 63 6f 64 65 20 6d 73 67 (decode msg
15b40 2d 69 6e 29 29 0a 09 09 20 28 68 6f 73 74 2d 70 -in))... (host-p
15b50 6f 72 74 20 20 28 61 6c 69 73 74 2d 72 65 66 20 ort (alist-ref
15b60 27 72 20 64 61 74 29 29 20 3b 3b 20 74 68 69 73 'r dat)) ;; this
15b70 20 69 73 20 66 6f 72 20 74 68 65 20 72 65 76 65 is for the reve
15b80 72 73 65 20 72 65 71 20 72 65 70 20 77 68 65 72 rse req rep wher
15b90 65 20 74 68 65 20 73 65 72 76 65 72 20 69 73 20 e the server is
15ba0 61 20 63 6c 69 65 6e 74 20 6f 66 20 74 68 65 20 a client of the
15bb0 6f 72 69 67 69 6e 61 6c 20 63 6c 69 65 6e 74 0a original client.
15bc0 09 09 20 28 70 61 72 61 6d 73 20 20 20 20 20 28 .. (params (
15bd0 61 6c 69 73 74 2d 72 65 66 20 27 70 20 64 61 74 alist-ref 'p dat
15be0 29 29 0a 09 09 20 28 63 6f 6d 6d 61 6e 64 20 20 ))... (command
15bf0 20 20 28 6c 65 74 20 28 28 63 20 28 61 6c 69 73 (let ((c (alis
15c00 74 2d 72 65 66 20 27 63 20 64 61 74 29 29 29 28 t-ref 'c dat)))(
15c10 69 66 20 63 20 28 73 74 72 69 6e 67 2d 3e 73 79 if c (string->sy
15c20 6d 62 6f 6c 20 63 29 20 23 66 29 29 29 0a 09 09 mbol c) #f)))...
15c30 20 28 61 6c 6c 2d 67 6f 6f 64 20 20 20 28 61 6e (all-good (an
15c40 64 20 68 6f 73 74 2d 70 6f 72 74 20 70 61 72 61 d host-port para
15c50 6d 73 20 63 6f 6d 6d 61 6e 64 20 28 68 61 73 68 ms command (hash
15c60 2d 74 61 62 6c 65 2d 65 78 69 73 74 73 3f 20 2a -table-exists? *
15c70 63 6f 6d 6d 61 6e 64 73 2a 20 63 6f 6d 6d 61 6e commands* comman
15c80 64 29 29 29 29 0a 09 20 20 20 20 28 69 66 20 61 d)))).. (if a
15c90 6c 6c 2d 67 6f 6f 64 0a 09 09 28 6c 65 74 20 28 ll-good...(let (
15ca0 28 63 6d 64 64 61 74 20 28 6d 61 6b 65 2d 71 69 (cmddat (make-qi
15cb0 74 65 6d 0a 09 09 09 20 20 20 20 20 20 20 63 6f tem.... co
15cc0 6d 6d 61 6e 64 3a 20 20 20 63 6f 6d 6d 61 6e 64 mmand: command
15cd0 0a 09 09 09 20 20 20 20 20 20 20 68 6f 73 74 2d .... host-
15ce0 70 6f 72 74 3a 20 68 6f 73 74 2d 70 6f 72 74 0a port: host-port.
15cf0 09 09 09 20 20 20 20 20 20 20 70 61 72 61 6d 73 ... params
15d00 3a 20 20 20 20 70 61 72 61 6d 73 29 29 29 0a 09 : params)))..
15d10 09 20 20 28 71 75 65 75 65 2d 70 75 73 68 20 63 . (queue-push c
15d20 6d 64 64 61 74 29 20 09 09 3b 3b 20 70 75 74 20 mddat) ..;; put
15d30 72 65 71 75 65 73 74 20 69 6e 74 6f 20 74 68 65 request into the
15d40 20 71 75 65 75 65 0a 09 09 20 20 28 6e 6e 2d 73 queue... (nn-s
15d50 65 6e 64 20 73 6f 63 20 22 71 75 65 75 65 64 22 end soc "queued"
15d60 29 29 20 20 20 20 20 20 20 20 20 3b 3b 20 72 65 )) ;; re
15d70 70 6c 79 20 77 69 74 68 20 22 71 75 65 75 65 64 ply with "queued
15d80 22 0a 09 09 28 70 72 69 6e 74 20 22 45 52 52 4f "...(print "ERRO
15d90 52 3a 20 42 41 44 20 72 65 71 75 65 73 74 20 22 R: BAD request "
15da0 20 64 61 74 29 29 0a 09 20 20 20 20 28 6c 6f 6f dat)).. (loo
15db0 70 20 28 6e 6e 2d 72 65 63 76 20 73 6f 63 29 29 p (nn-recv soc))
15dc0 29 29 29 0a 20 20 20 20 28 6e 6e 2d 63 6c 6f 73 ))). (nn-clos
15dd0 65 20 73 6f 63 29 29 29 0a 20 20 0a 0a 0a 3b 3b e soc))). ...;;
15de0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15df0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e00 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e10 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e20 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 44 20 41 20 53 20 ======.;; D A S
15e30 48 20 42 20 4f 20 41 20 52 20 44 20 20 20 55 20 H B O A R D U
15e40 53 20 45 20 52 20 20 20 56 20 49 20 45 20 57 20 S E R V I E W
15e50 53 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d S.;;============
15e60 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e70 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e80 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
15e90 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 66 ==========..;; f
15ea0 69 72 73 74 20 72 65 61 64 20 7e 2f 76 69 65 77 irst read ~/view
15eb0 73 2e 63 6f 6e 66 69 67 20 69 66 20 69 74 20 65 s.config if it e
15ec0 78 69 73 74 73 2c 20 74 68 65 6e 20 72 65 61 64 xists, then read
15ed0 20 24 4d 54 52 41 48 2f 76 69 65 77 73 2e 63 6f $MTRAH/views.co
15ee0 6e 66 69 67 20 69 66 20 69 74 20 65 78 69 73 74 nfig if it exist
15ef0 73 0a 3b 3b 0a 28 64 65 66 69 6e 65 20 28 63 6f s.;;.(define (co
15f00 6d 6d 6f 6e 3a 6c 6f 61 64 2d 76 69 65 77 73 2d mmon:load-views-
15f10 63 6f 6e 66 69 67 29 0a 20 20 28 6c 65 74 2a 20 config). (let*
15f20 28 28 76 69 65 77 2d 63 66 67 64 61 74 20 20 20 ((view-cfgdat
15f30 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 62 6c (make-hash-tabl
15f40 65 29 29 0a 09 20 28 68 6f 6d 65 2d 63 66 67 66 e)).. (home-cfgf
15f50 69 6c 65 20 20 20 28 63 6f 6e 63 20 28 67 65 74 ile (conc (get
15f60 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
15f70 69 61 62 6c 65 20 22 48 4f 4d 45 22 29 20 22 2f iable "HOME") "/
15f80 2e 6d 74 76 69 65 77 73 2e 63 6f 6e 66 69 67 22 .mtviews.config"
15f90 29 29 0a 09 20 28 6d 74 68 6f 6d 65 2d 63 66 67 )).. (mthome-cfg
15fa0 66 69 6c 65 20 28 63 6f 6e 63 20 2a 74 6f 70 70 file (conc *topp
15fb0 61 74 68 2a 20 22 2f 2e 6d 74 76 69 65 77 73 2e ath* "/.mtviews.
15fc0 63 6f 6e 66 69 67 22 29 29 29 0a 20 20 20 20 28 config"))). (
15fd0 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d if (common:file-
15fe0 65 78 69 73 74 73 3f 20 6d 74 68 6f 6d 65 2d 63 exists? mthome-c
15ff0 66 67 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 fgfile)..(read-c
16000 6f 6e 66 69 67 20 6d 74 68 6f 6d 65 2d 63 66 67 onfig mthome-cfg
16010 66 69 6c 65 20 76 69 65 77 2d 63 66 67 64 61 74 file view-cfgdat
16020 20 23 74 29 29 0a 20 20 20 20 3b 3b 20 77 65 20 #t)). ;; we
16030 6c 6f 61 64 20 74 68 65 20 68 6f 6d 65 20 64 69 load the home di
16040 72 20 66 69 6c 65 20 41 46 54 45 52 20 74 68 65 r file AFTER the
16050 20 4d 54 52 41 48 20 66 69 6c 65 20 73 6f 20 74 MTRAH file so t
16060 68 65 20 75 73 65 72 20 63 61 6e 20 63 6c 6f 62 he user can clob
16070 62 65 72 20 73 65 74 74 69 6e 67 73 20 77 68 65 ber settings whe
16080 6e 20 72 75 6e 6e 69 6e 67 20 74 68 65 20 64 61 n running the da
16090 73 68 62 6f 61 72 64 20 69 6e 20 72 65 61 64 2d shboard in read-
160a0 6f 6e 6c 79 20 61 72 65 61 73 0a 20 20 20 20 28 only areas. (
160b0 69 66 20 28 63 6f 6d 6d 6f 6e 3a 66 69 6c 65 2d if (common:file-
160c0 65 78 69 73 74 73 3f 20 68 6f 6d 65 2d 63 66 67 exists? home-cfg
160d0 66 69 6c 65 29 0a 09 28 72 65 61 64 2d 63 6f 6e file)..(read-con
160e0 66 69 67 20 68 6f 6d 65 2d 63 66 67 66 69 6c 65 fig home-cfgfile
160f0 20 76 69 65 77 2d 63 66 67 64 61 74 20 23 74 29 view-cfgdat #t)
16100 29 0a 20 20 20 20 76 69 65 77 2d 63 66 67 64 61 ). view-cfgda
16110 74 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d t))..;;=========
16120 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16130 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16140 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
16150 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
16160 20 48 20 49 20 45 20 52 20 41 20 52 20 43 20 48 H I E R A R C H
16170 20 49 20 43 20 41 20 4c 20 20 20 48 20 41 20 53 I C A L H A S
16180 20 48 20 20 20 54 20 41 20 42 20 4c 20 45 20 53 H T A B L E S
16190 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
161a0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
161b0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
161c0 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
161d0 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 45 76 =========..;; Ev
161e0 65 72 79 20 65 6c 65 6d 65 6e 74 20 69 6e 63 6c ery element incl
161f0 75 64 69 6e 67 20 74 6f 70 20 65 6c 65 6d 65 6e uding top elemen
16200 74 20 69 73 20 61 20 76 65 63 74 6f 72 3a 0a 3b t is a vector:.;
16210 3b 20 20 20 3c 76 65 63 74 6f 72 20 73 75 62 68 ; <vector subh
16220 61 73 68 20 76 61 6c 75 65 3e 0a 0a 28 64 65 66 ash value>..(def
16230 69 6e 65 20 28 68 68 3a 6d 61 6b 65 2d 68 68 20 ine (hh:make-hh
16240 23 21 6b 65 79 20 28 68 74 20 23 66 29 28 76 61 #!key (ht #f)(va
16250 6c 75 65 20 23 66 29 29 0a 20 20 28 76 65 63 74 lue #f)). (vect
16260 6f 72 20 28 6f 72 20 68 74 20 20 20 20 28 6d 61 or (or ht (ma
16270 6b 65 2d 68 61 73 68 2d 74 61 62 6c 65 29 29 20 ke-hash-table))
16280 76 61 6c 75 65 29 29 0a 0a 3b 3b 20 75 73 65 64 value))..;; used
16290 20 69 6e 74 65 72 6e 61 6c 6c 79 0a 28 64 65 66 internally.(def
162a0 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 68 68 3a 73 ine-inline (hh:s
162b0 65 74 2d 68 74 21 20 68 68 20 68 74 29 20 20 20 et-ht! hh ht)
162c0 20 20 20 20 28 76 65 63 74 6f 72 2d 73 65 74 21 (vector-set!
162d0 20 68 68 20 30 20 68 74 29 29 0a 28 64 65 66 69 hh 0 ht)).(defi
162e0 6e 65 2d 69 6e 6c 69 6e 65 20 28 68 68 3a 67 65 ne-inline (hh:ge
162f0 74 2d 68 74 20 68 68 29 20 20 20 20 20 20 20 20 t-ht hh)
16300 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 (vector-ref
16310 68 68 20 30 29 29 0a 28 64 65 66 69 6e 65 2d 69 hh 0)).(define-i
16320 6e 6c 69 6e 65 20 28 68 68 3a 73 65 74 2d 76 61 nline (hh:set-va
16330 6c 75 65 21 20 68 68 20 76 61 6c 75 65 29 20 28 lue! hh value) (
16340 76 65 63 74 6f 72 2d 73 65 74 21 20 68 68 20 31 vector-set! hh 1
16350 20 76 61 6c 75 65 29 29 0a 28 64 65 66 69 6e 65 value)).(define
16360 2d 69 6e 6c 69 6e 65 20 28 68 68 3a 67 65 74 2d -inline (hh:get-
16370 76 61 6c 75 65 20 20 68 68 20 76 61 6c 75 65 29 value hh value)
16380 20 28 76 65 63 74 6f 72 2d 72 65 66 20 20 68 68 (vector-ref hh
16390 20 31 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 1))..;; given a
163a0 20 68 69 65 72 61 72 63 68 69 61 6c 20 68 61 73 hierarchial has
163b0 68 20 61 6e 64 20 73 6f 6d 65 20 6b 65 79 73 20 h and some keys
163c0 6c 6f 6f 6b 20 75 70 20 74 68 65 20 76 61 6c 75 look up the valu
163d0 65 20 2e 2e 2e 0a 3b 3b 0a 28 64 65 66 69 6e 65 e ....;;.(define
163e0 20 28 68 68 3a 67 65 74 2d 76 61 6c 75 65 20 68 (hh:get-value h
163f0 68 20 2e 20 6b 65 79 73 29 0a 20 20 28 69 66 20 h . keys). (if
16400 28 6e 75 6c 6c 3f 20 6b 65 79 73 29 0a 20 20 20 (null? keys).
16410 20 20 20 28 76 65 63 74 6f 72 2d 72 65 66 20 68 (vector-ref h
16420 68 20 31 29 20 3b 3b 20 77 65 20 68 61 76 65 20 h 1) ;; we have
16430 72 65 61 63 68 65 64 20 74 68 65 20 65 6e 64 20 reached the end
16440 6f 66 20 74 68 65 20 6c 69 6e 65 2c 20 72 65 74 of the line, ret
16450 75 72 6e 20 74 68 65 20 76 61 6c 75 65 20 73 6f urn the value so
16460 75 67 68 74 0a 20 20 20 20 20 20 28 6c 65 74 20 ught. (let
16470 28 28 73 75 62 2d 68 74 20 28 68 68 3a 67 65 74 ((sub-ht (hh:get
16480 2d 68 74 20 68 68 29 29 29 0a 09 28 69 66 20 73 -ht hh)))..(if s
16490 75 62 2d 68 74 20 3b 3b 20 79 65 73 2c 20 74 68 ub-ht ;; yes, th
164a0 65 72 65 20 69 73 20 6d 6f 72 65 20 68 69 65 72 ere is more hier
164b0 61 72 63 68 79 0a 09 20 20 20 20 28 6c 65 74 20 archy.. (let
164c0 28 28 73 75 62 2d 68 68 20 28 68 61 73 68 2d 74 ((sub-hh (hash-t
164d0 61 62 6c 65 2d 72 65 66 2f 64 65 66 61 75 6c 74 able-ref/default
164e0 20 73 75 62 2d 68 74 20 28 63 61 72 20 6b 65 79 sub-ht (car key
164f0 73 29 20 23 66 29 29 29 0a 09 20 20 20 20 20 20 s) #f)))..
16500 28 69 66 20 73 75 62 2d 68 68 0a 09 09 20 20 28 (if sub-hh... (
16510 61 70 70 6c 79 20 68 68 3a 67 65 74 2d 76 61 6c apply hh:get-val
16520 75 65 20 73 75 62 2d 68 68 20 28 63 64 72 20 6b ue sub-hh (cdr k
16530 65 79 73 29 29 0a 09 09 20 20 23 66 29 29 0a 09 eys))... #f))..
16540 20 20 20 20 23 66 29 29 29 29 0a 0a 28 64 65 66 #f))))..(def
16550 69 6e 65 20 28 68 68 3a 67 65 74 2d 73 75 62 68 ine (hh:get-subh
16560 61 73 68 20 68 68 20 2e 20 6b 65 79 73 29 0a 20 ash hh . keys).
16570 20 28 69 66 20 28 6e 75 6c 6c 3f 20 6b 65 79 73 (if (null? keys
16580 29 0a 20 20 20 20 20 20 28 76 65 63 74 6f 72 2d ). (vector-
16590 72 65 66 20 68 68 20 30 29 20 3b 3b 20 77 65 20 ref hh 0) ;; we
165a0 68 61 76 65 20 72 65 61 63 68 65 64 20 74 68 65 have reached the
165b0 20 65 6e 64 20 6f 66 20 74 68 65 20 6c 69 6e 65 end of the line
165c0 2c 20 72 65 74 75 72 6e 20 74 68 65 20 76 61 6c , return the val
165d0 75 65 20 73 6f 75 67 68 74 0a 20 20 20 20 20 20 ue sought.
165e0 28 6c 65 74 20 28 28 73 75 62 2d 68 74 20 28 68 (let ((sub-ht (h
165f0 68 3a 67 65 74 2d 68 74 20 68 68 29 29 29 0a 09 h:get-ht hh)))..
16600 28 69 66 20 73 75 62 2d 68 74 20 3b 3b 20 79 65 (if sub-ht ;; ye
16610 73 2c 20 74 68 65 72 65 20 69 73 20 6d 6f 72 65 s, there is more
16620 20 68 69 65 72 61 72 63 68 79 0a 09 20 20 20 20 hierarchy..
16630 28 6c 65 74 20 28 28 73 75 62 2d 68 68 20 28 68 (let ((sub-hh (h
16640 61 73 68 2d 74 61 62 6c 65 2d 72 65 66 2f 64 65 ash-table-ref/de
16650 66 61 75 6c 74 20 73 75 62 2d 68 74 20 28 63 61 fault sub-ht (ca
16660 72 20 6b 65 79 73 29 20 23 66 29 29 29 0a 09 20 r keys) #f)))..
16670 20 20 20 20 20 28 69 66 20 73 75 62 2d 68 68 0a (if sub-hh.
16680 09 09 20 20 28 61 70 70 6c 79 20 68 68 3a 67 65 .. (apply hh:ge
16690 74 2d 73 75 62 68 61 73 68 20 73 75 62 2d 68 68 t-subhash sub-hh
166a0 20 28 63 64 72 20 6b 65 79 73 29 29 0a 09 09 20 (cdr keys))...
166b0 20 23 66 29 29 0a 09 20 20 20 20 23 66 29 29 29 #f)).. #f)))
166c0 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 61 20 68 69 )..;; given a hi
166d0 65 72 61 72 63 68 69 61 6c 20 68 61 73 68 2c 20 erarchial hash,
166e0 61 20 76 61 6c 75 65 20 61 6e 64 20 73 6f 6d 65 a value and some
166f0 20 6b 65 79 73 2c 20 61 64 64 20 6e 65 65 64 65 keys, add neede
16700 64 20 68 69 65 72 61 72 63 79 20 61 6e 64 20 69 d hierarcy and i
16710 6e 73 65 72 74 20 74 68 65 20 76 61 6c 75 65 0a nsert the value.
16720 3b 3b 0a 28 64 65 66 69 6e 65 20 28 68 68 3a 73 ;;.(define (hh:s
16730 65 74 21 20 68 68 20 76 61 6c 75 65 20 2e 20 6b et! hh value . k
16740 65 79 73 29 0a 20 20 28 69 66 20 28 6e 75 6c 6c eys). (if (null
16750 3f 20 6b 65 79 73 29 0a 20 20 20 20 20 20 28 68 ? keys). (h
16760 68 3a 73 65 74 2d 76 61 6c 75 65 21 20 68 68 20 h:set-value! hh
16770 76 61 6c 75 65 29 20 3b 3b 20 77 65 20 68 61 76 value) ;; we hav
16780 65 20 72 65 61 63 68 65 64 20 74 68 65 20 65 6e e reached the en
16790 64 20 6f 66 20 74 68 65 20 6c 69 6e 65 2c 20 73 d of the line, s
167a0 74 6f 72 65 20 74 68 65 20 76 61 6c 75 65 0a 20 tore the value.
167b0 20 20 20 20 20 28 6c 65 74 20 28 28 73 75 62 2d (let ((sub-
167c0 68 74 20 28 68 68 3a 67 65 74 2d 68 74 20 68 68 ht (hh:get-ht hh
167d0 29 29 29 0a 09 28 69 66 20 73 75 62 2d 68 74 20 )))..(if sub-ht
167e0 3b 3b 20 79 65 73 2c 20 74 68 65 72 65 20 69 73 ;; yes, there is
167f0 20 6d 6f 72 65 20 68 69 65 72 61 72 63 68 79 0a more hierarchy.
16800 09 20 20 20 20 28 6c 65 74 20 28 28 73 75 62 2d . (let ((sub-
16810 68 68 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 72 hh (hash-table-r
16820 65 66 2f 64 65 66 61 75 6c 74 20 73 75 62 2d 68 ef/default sub-h
16830 74 20 28 63 61 72 20 6b 65 79 73 29 20 23 66 29 t (car keys) #f)
16840 29 29 0a 09 20 20 20 20 20 20 28 69 66 20 28 6e )).. (if (n
16850 6f 74 20 73 75 62 2d 68 68 29 20 3b 3b 20 77 65 ot sub-hh) ;; we
16860 27 6c 6c 20 6e 65 65 64 20 74 6f 20 61 64 64 20 'll need to add
16870 74 68 65 20 6e 65 78 74 20 6c 65 76 65 6c 20 6f the next level o
16880 66 20 68 69 65 72 61 72 63 68 79 0a 09 09 20 20 f hierarchy...
16890 28 6c 65 74 20 28 28 6e 65 77 2d 73 75 62 2d 68 (let ((new-sub-h
168a0 68 20 28 68 68 3a 6d 61 6b 65 2d 68 68 29 29 29 h (hh:make-hh)))
168b0 0a 09 09 20 20 20 20 28 68 61 73 68 2d 74 61 62 ... (hash-tab
168c0 6c 65 2d 73 65 74 21 20 73 75 62 2d 68 74 20 28 le-set! sub-ht (
168d0 63 61 72 20 6b 65 79 73 29 20 6e 65 77 2d 73 75 car keys) new-su
168e0 62 2d 68 68 29 0a 09 09 20 20 20 20 28 61 70 70 b-hh)... (app
168f0 6c 79 20 68 68 3a 73 65 74 21 20 6e 65 77 2d 73 ly hh:set! new-s
16900 75 62 2d 68 68 20 76 61 6c 75 65 20 28 63 64 72 ub-hh value (cdr
16910 20 6b 65 79 73 29 29 29 0a 09 09 20 20 28 61 70 keys)))... (ap
16920 70 6c 79 20 68 68 3a 73 65 74 21 20 73 75 62 2d ply hh:set! sub-
16930 68 68 20 76 61 6c 75 65 20 28 63 64 72 20 6b 65 hh value (cdr ke
16940 79 73 29 29 29 29 20 20 20 20 3b 3b 20 63 61 6c ys)))) ;; cal
16950 6c 20 74 68 65 20 73 75 62 2d 68 69 65 72 68 61 l the sub-hierha
16960 73 68 20 77 69 74 68 20 72 65 6d 61 69 6e 69 6e sh with remainin
16970 67 20 6b 65 79 73 0a 09 20 20 20 20 28 62 65 67 g keys.. (beg
16980 69 6e 0a 09 20 20 20 20 20 20 28 68 68 3a 73 65 in.. (hh:se
16990 74 2d 68 74 21 20 68 68 20 28 6d 61 6b 65 2d 68 t-ht! hh (make-h
169a0 61 73 68 2d 74 61 62 6c 65 29 29 0a 09 20 20 20 ash-table))..
169b0 20 20 20 28 61 70 70 6c 79 20 68 68 3a 73 65 74 (apply hh:set
169c0 21 20 68 68 20 76 61 6c 75 65 20 6b 65 79 73 29 ! hh value keys)
169d0 29 29 29 29 29 0a 0a 3b 3b 20 67 69 76 65 6e 20 )))))..;; given
169e0 61 20 68 69 65 72 61 72 63 68 69 61 6c 20 68 61 a hierarchial ha
169f0 73 68 20 61 6e 64 20 73 6f 6d 65 20 6b 65 79 73 sh and some keys
16a00 2c 20 72 65 74 75 72 6e 20 74 68 65 20 6b 65 79 , return the key
16a10 73 20 66 6f 72 20 74 68 61 74 20 68 61 73 68 20 s for that hash
16a20 6c 65 76 65 6c 0a 3b 3b 0a 28 64 65 66 69 6e 65 level.;;.(define
16a30 20 28 68 68 3a 67 65 74 2d 6b 65 79 73 20 68 68 (hh:get-keys hh
16a40 20 2e 20 6b 65 79 73 29 0a 20 20 28 6c 65 74 20 . keys). (let
16a50 28 28 68 74 20 28 61 70 70 6c 79 20 68 68 3a 67 ((ht (apply hh:g
16a60 65 74 2d 73 75 62 68 61 73 68 20 68 68 20 6b 65 et-subhash hh ke
16a70 79 73 29 29 29 0a 20 20 20 20 28 69 66 20 68 74 ys))). (if ht
16a80 0a 09 28 68 61 73 68 2d 74 61 62 6c 65 2d 6b 65 ..(hash-table-ke
16a90 79 73 20 68 74 29 0a 09 27 28 29 29 29 29 0a 20 ys ht)..'()))).
16aa0 20 0a .