File
common.scm
— part of check-in
[a9efabed17]
at
2011-10-30 19:43:42
on branch trunk
— Added -setvar, changed environment settings to use double quote instead of single quote
(user:
matt
size: 6275)
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 31 2c right 2006-2011,
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 71 6c 69 74 65 33 20 73 72 66 69 2d 31 20 sqlite3 srfi-1
01f0: 70 6f 73 69 78 20 72 65 67 65 78 2d 63 61 73 65 posix regex-case
0200: 20 62 61 73 65 36 34 20 66 6f 72 6d 61 74 20 64 base64 format d
0210: 6f 74 2d 6c 6f 63 6b 69 6e 67 20 63 73 76 2d 78 ot-locking csv-x
0220: 6d 6c 29 0a 28 72 65 71 75 69 72 65 2d 65 78 74 ml).(require-ext
0230: 65 6e 73 69 6f 6e 20 73 71 6c 69 74 65 33 20 72 ension sqlite3 r
0240: 65 67 65 78 20 70 6f 73 69 78 29 0a 0a 28 72 65 egex posix)..(re
0250: 71 75 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 quire-extension
0260: 28 73 72 66 69 20 31 38 29 20 65 78 74 72 61 73 (srfi 18) extras
0270: 20 74 63 70 20 72 70 63 29 0a 0a 28 69 6d 70 6f tcp rpc)..(impo
0280: 72 74 20 28 70 72 65 66 69 78 20 73 71 6c 69 74 rt (prefix sqlit
0290: 65 33 20 73 71 6c 69 74 65 33 3a 29 29 0a 28 69 e3 sqlite3:)).(i
02a0: 6d 70 6f 72 74 20 28 70 72 65 66 69 78 20 62 61 mport (prefix ba
02b0: 73 65 36 34 20 62 61 73 65 36 34 3a 29 29 0a 0a se64 base64:))..
02c0: 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 63 (declare (unit c
02d0: 6f 6d 6d 6f 6e 29 29 0a 0a 28 69 6e 63 6c 75 64 ommon))..(includ
02e0: 65 20 22 63 6f 6d 6d 6f 6e 5f 72 65 63 6f 72 64 e "common_record
02f0: 73 2e 73 63 6d 22 29 0a 0a 3b 3b 20 28 72 65 71 s.scm")..;; (req
0300: 75 69 72 65 2d 6c 69 62 72 61 72 79 20 6d 61 72 uire-library mar
0310: 67 73 29 0a 3b 3b 20 28 69 6e 63 6c 75 64 65 20 gs).;; (include
0320: 22 6d 61 72 67 73 2e 73 63 6d 22 29 0a 0a 28 64 "margs.scm")..(d
0330: 65 66 69 6e 65 20 67 65 74 65 6e 76 20 67 65 74 efine getenv get
0340: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
0350: 69 61 62 6c 65 29 0a 0a 28 64 65 66 69 6e 65 20 iable)..(define
0360: 68 6f 6d 65 20 28 67 65 74 65 6e 76 20 22 48 4f home (getenv "HO
0370: 4d 45 22 29 29 0a 28 64 65 66 69 6e 65 20 75 73 ME")).(define us
0380: 65 72 20 28 67 65 74 65 6e 76 20 22 55 53 45 52 er (getenv "USER
0390: 22 29 29 0a 0a 3b 3b 20 67 6c 6f 62 61 6c 20 67 "))..;; global g
03a0: 6c 65 74 63 68 65 73 0a 28 64 65 66 69 6e 65 20 letches.(define
03b0: 2a 63 6f 6e 66 69 67 69 6e 66 6f 2a 20 23 66 29 *configinfo* #f)
03c0: 0a 28 64 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 .(define *config
03d0: 64 61 74 2a 20 20 23 66 29 0a 28 64 65 66 69 6e dat* #f).(defin
03e0: 65 20 2a 74 6f 70 70 61 74 68 2a 20 20 20 20 23 e *toppath* #
03f0: 66 29 0a 28 64 65 66 69 6e 65 20 2a 61 6c 72 65 f).(define *alre
0400: 61 64 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 ady-seen-runconf
0410: 69 67 2d 69 6e 66 6f 2a 20 23 66 29 0a 28 64 65 ig-info* #f).(de
0420: 66 69 6e 65 20 2a 77 61 69 74 69 6e 67 2d 71 75 fine *waiting-qu
0430: 65 75 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d eue* (make-hash-
0440: 74 61 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 table)).(define
0450: 2a 67 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 *globalexitstatu
0460: 73 2a 20 30 29 20 3b 3b 20 61 74 74 65 6d 70 74 s* 0) ;; attempt
0470: 20 74 6f 20 77 6f 72 6b 20 61 72 6f 75 6e 64 20 to work around
0480: 70 6f 73 73 69 62 6c 65 20 74 68 72 65 61 64 20 possible thread
0490: 69 73 73 75 65 73 0a 28 64 65 66 69 6e 65 20 2a issues.(define *
04a0: 70 61 73 73 6e 75 6d 2a 20 20 20 20 20 30 29 20 passnum* 0)
04b0: 3b 3b 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 ;; when running
04c0: 74 72 61 63 6b 20 63 61 6c 6c 73 20 74 6f 20 72 track calls to r
04d0: 75 6e 2d 74 65 73 74 73 20 6f 72 20 73 69 6d 69 un-tests or simi
04e0: 6c 61 72 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 lar.(define *ver
04f0: 62 6f 73 69 74 79 2a 20 20 20 31 29 0a 28 64 65 bosity* 1).(de
0500: 66 69 6e 65 20 2a 72 70 63 3a 6c 69 73 74 65 6e fine *rpc:listen
0510: 65 72 2a 20 23 66 29 20 3b 3b 20 69 66 20 73 65 er* #f) ;; if se
0520: 74 20 75 70 20 66 6f 72 20 73 65 72 76 65 72 20 t up for server
0530: 63 6f 6d 6d 75 6e 69 63 61 74 69 6f 6e 20 74 68 communication th
0540: 69 73 20 77 69 6c 6c 20 68 6f 6c 64 20 74 68 65 is will hold the
0550: 20 74 63 70 20 70 6f 72 74 0a 0a 28 64 65 66 69 tcp port..(defi
0560: 6e 65 20 28 67 65 74 2d 77 69 74 68 2d 64 65 66 ne (get-with-def
0570: 61 75 6c 74 20 76 61 6c 20 64 65 66 61 75 6c 74 ault val default
0580: 29 0a 20 20 28 6c 65 74 20 28 28 76 61 6c 20 28 ). (let ((val (
0590: 61 72 67 73 3a 67 65 74 2d 61 72 67 20 76 61 6c args:get-arg val
05a0: 29 29 29 0a 20 20 20 20 28 69 66 20 76 61 6c 20 ))). (if val
05b0: 76 61 6c 20 64 65 66 61 75 6c 74 29 29 29 0a 0a val default)))..
05c0: 28 64 65 66 69 6e 65 20 28 61 73 73 6f 63 2f 64 (define (assoc/d
05d0: 65 66 61 75 6c 74 20 6b 65 79 20 6c 73 74 20 2e efault key lst .
05e0: 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 default). (let
05f0: 20 28 28 72 65 73 20 28 61 73 73 6f 63 20 6b 65 ((res (assoc ke
0600: 79 20 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 y lst))). (if
0610: 20 72 65 73 20 28 63 61 64 72 20 72 65 73 29 28 res (cadr res)(
0620: 69 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 75 6c if (null? defaul
0630: 74 29 20 23 66 20 28 63 61 72 20 64 65 66 61 75 t) #f (car defau
0640: 6c 74 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d lt)))))..;;=====
0650: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0660: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0670: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0680: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0690: 3d 0a 3b 3b 20 4d 69 73 63 20 75 74 69 6c 73 0a =.;; Misc utils.
06a0: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
06b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
06e0: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 3b 3b 20 63 6f 6e ========..;; con
06f0: 76 65 72 74 20 73 74 75 66 66 20 74 6f 20 61 20 vert stuff to a
0700: 6e 75 6d 62 65 72 20 69 66 20 70 6f 73 73 69 62 number if possib
0710: 6c 65 0a 28 64 65 66 69 6e 65 20 28 61 6e 79 2d le.(define (any-
0720: 3e 6e 75 6d 62 65 72 20 76 61 6c 29 0a 20 20 28 >number val). (
0730: 63 6f 6e 64 20 0a 20 20 20 28 28 6e 75 6d 62 65 cond . ((numbe
0740: 72 3f 20 76 61 6c 29 20 76 61 6c 29 0a 20 20 20 r? val) val).
0750: 28 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 20 28 ((string? val) (
0760: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 string->number v
0770: 61 6c 29 29 0a 20 20 20 28 28 73 79 6d 62 6f 6c al)). ((symbol
0780: 3f 20 76 61 6c 29 20 28 61 6e 79 2d 3e 6e 75 6d ? val) (any->num
0790: 62 65 72 20 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 ber (symbol->str
07a0: 69 6e 67 20 76 61 6c 29 29 29 0a 20 20 20 28 65 ing val))). (e
07b0: 6c 73 65 20 23 66 29 29 29 0a 0a 28 64 65 66 69 lse #f)))..(defi
07c0: 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 2d ne (any->number-
07d0: 69 66 2d 70 6f 73 73 69 62 6c 65 20 76 61 6c 29 if-possible val)
07e0: 0a 20 20 28 6c 65 74 20 28 28 6e 75 6d 20 28 61 . (let ((num (a
07f0: 6e 79 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 ny->number val))
0800: 29 0a 20 20 20 20 28 69 66 20 6e 75 6d 20 6e 75 ). (if num nu
0810: 6d 20 76 61 6c 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d m val)))..;;====
0820: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0830: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0840: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0850: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0860: 3d 3d 0a 3b 3b 20 53 79 73 74 65 6d 20 73 74 75 ==.;; System stu
0870: 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ff.;;===========
0880: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0890: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
08b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
08c0: 66 69 6e 65 20 28 67 65 74 2d 64 66 20 70 61 74 fine (get-df pat
08d0: 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 66 2d h). (let* ((df-
08e0: 72 65 73 75 6c 74 73 20 28 63 6d 64 2d 72 75 6e results (cmd-run
08f0: 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 64 66 ->list (conc "df
0900: 20 22 20 70 61 74 68 29 29 29 0a 09 20 28 73 70 " path))).. (sp
0910: 61 63 65 2d 72 78 20 20 20 28 72 65 67 65 78 70 ace-rx (regexp
0920: 20 22 28 5b 30 2d 39 5d 2b 29 5c 5c 73 2b 28 5b "([0-9]+)\\s+([
0930: 30 2d 39 5d 2b 29 25 22 29 29 0a 09 20 28 66 72 0-9]+)%")).. (fr
0940: 65 65 73 70 63 20 20 20 20 23 66 29 29 0a 20 20 eespc #f)).
0950: 20 20 3b 3b 20 28 77 72 69 74 65 20 64 66 2d 72 ;; (write df-r
0960: 65 73 75 6c 74 73 29 0a 20 20 20 20 28 66 6f 72 esults). (for
0970: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6c -each (lambda (l
0980: 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 74 63 68 )...(let ((match
0990: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
09a0: 73 70 61 63 65 2d 72 78 20 6c 29 29 29 0a 09 09 space-rx l)))...
09b0: 20 20 28 69 66 20 6d 61 74 63 68 20 0a 09 09 20 (if match ...
09c0: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 (let ((newv
09d0: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 al (string->numb
09e0: 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 er (cadr match))
09f0: 29 29 0a 09 09 09 28 69 66 20 28 6e 75 6d 62 65 ))....(if (numbe
0a00: 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 09 20 20 r? newval)....
0a10: 20 20 28 73 65 74 21 20 66 72 65 65 73 70 63 20 (set! freespc
0a20: 6e 65 77 76 61 6c 29 29 29 29 29 29 0a 09 20 20 newval))))))..
0a30: 20 20 20 20 28 63 61 72 20 64 66 2d 72 65 73 75 (car df-resu
0a40: 6c 74 73 29 29 0a 20 20 20 20 66 72 65 65 73 70 lts)). freesp
0a50: 63 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 c)). .(define (
0a60: 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 0a 20 20 get-cpu-load).
0a70: 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d 72 65 73 (let* ((load-res
0a80: 20 28 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 (cmd-run->list
0a90: 22 75 70 74 69 6d 65 22 29 29 0a 09 20 28 6c 6f "uptime")).. (lo
0aa0: 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 ad-rx (regexp "
0ab0: 6c 6f 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 load average:\\s
0ac0: 2b 28 5c 5c 64 2b 29 22 29 29 0a 09 20 28 63 70 +(\\d+)")).. (cp
0ad0: 75 2d 6c 6f 61 64 20 23 66 29 29 0a 20 20 20 20 u-load #f)).
0ae0: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
0af0: 61 20 28 6c 29 0a 09 09 28 6c 65 74 20 28 28 6d a (l)...(let ((m
0b00: 61 74 63 68 20 28 73 74 72 69 6e 67 2d 73 65 61 atch (string-sea
0b10: 72 63 68 20 6c 6f 61 64 2d 72 78 20 6c 29 29 29 rch load-rx l)))
0b20: 0a 09 09 20 20 28 69 66 20 6d 61 74 63 68 0a 09 ... (if match..
0b30: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 . (let ((ne
0b40: 77 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 wval (string->nu
0b50: 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 mber (cadr match
0b60: 29 29 29 29 0a 09 09 09 28 69 66 20 28 6e 75 6d ))))....(if (num
0b70: 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 09 ber? newval)....
0b80: 20 20 20 20 28 73 65 74 21 20 63 70 75 2d 6c 6f (set! cpu-lo
0b90: 61 64 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a ad newval)))))).
0ba0: 09 20 20 20 20 20 20 28 63 61 72 20 6c 6f 61 64 . (car load
0bb0: 2d 72 65 73 29 29 0a 20 20 20 20 63 70 75 2d 6c -res)). cpu-l
0bc0: 6f 61 64 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 oad))..(define (
0bd0: 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 61 72 61 get-uname . para
0be0: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 6e ms). (let* ((un
0bf0: 61 6d 65 2d 72 65 73 20 28 63 6d 64 2d 72 75 6e ame-res (cmd-run
0c00: 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 6e ->list (conc "un
0c10: 61 6d 65 20 22 20 28 69 66 20 28 6e 75 6c 6c 3f ame " (if (null?
0c20: 20 70 61 72 61 6d 73 29 20 22 2d 61 22 20 28 63 params) "-a" (c
0c30: 61 72 20 70 61 72 61 6d 73 29 29 29 29 29 0a 09 ar params)))))..
0c40: 20 28 75 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 (uname #f)).
0c50: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 61 72 (if (null? (car
0c60: 20 75 6e 61 6d 65 2d 72 65 73 29 29 0a 09 22 75 uname-res)).."u
0c70: 6e 6b 6e 6f 77 6e 22 0a 09 28 63 61 61 72 20 75 nknown"..(caar u
0c80: 6e 61 6d 65 2d 72 65 73 29 29 29 29 0a 09 20 20 name-res))))..
0c90: 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 73 61 .(define (sa
0ca0: 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 ve-environment-a
0cb0: 73 2d 66 69 6c 65 73 20 66 6e 61 6d 65 29 0a 20 s-files fname).
0cc0: 20 28 6c 65 74 20 28 28 65 6e 76 76 61 72 73 20 (let ((envvars
0cd0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
0ce0: 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 20 -variables)).
0cf0: 20 20 20 20 20 28 77 68 69 74 65 73 70 20 28 72 (whitesp (r
0d00: 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 egexp "[^a-zA-Z0
0d10: 2d 39 5f 5c 5c 2d 3a 3b 2c 2e 5c 5c 2f 25 24 5d -9_\\-:;,.\\/%$]
0d20: 22 29 29 29 0a 20 20 20 20 20 28 77 69 74 68 2d "))). (with-
0d30: 6f 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 output-to-file (
0d40: 63 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 73 68 conc fname ".csh
0d50: 22 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 "). (lambd
0d60: 61 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 28 a (). (
0d70: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
0d80: 20 28 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 (key).
0d90: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
0da0: 74 2a 20 28 28 76 61 6c 20 28 63 64 72 20 6b 65 t* ((val (cdr ke
0db0: 79 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 y)).
0dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0dd0: 20 28 73 76 61 6c 20 28 69 66 20 28 73 74 72 69 (sval (if (stri
0de0: 6e 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 73 ng-search whites
0df0: 70 20 76 61 6c 29 28 63 6f 6e 63 20 22 5c 22 22 p val)(conc "\""
0e00: 20 76 61 6c 20 22 5c 22 22 29 20 76 61 6c 29 29 val "\"") val))
0e10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0e20: 20 20 20 20 20 20 20 20 20 20 28 70 72 69 6e 74 (print
0e30: 20 22 73 65 74 65 6e 76 20 22 20 28 63 61 72 20 "setenv " (car
0e40: 6b 65 79 29 20 22 20 22 20 73 76 61 6c 29 29 29 key) " " sval)))
0e50: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0e60: 20 20 20 20 20 20 65 6e 76 76 61 72 73 29 29 29 envvars)))
0e70: 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 . (with-outp
0e80: 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 ut-to-file (conc
0e90: 20 66 6e 61 6d 65 20 22 2e 73 68 22 29 0a 20 20 fname ".sh").
0ea0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
0eb0: 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d 65 (for-e
0ec0: 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 ach (lambda (key
0ed0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0ee0: 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 (let* ((
0ef0: 76 61 6c 20 28 63 64 72 20 6b 65 79 29 29 0a 20 val (cdr key)).
0f00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f10: 20 20 20 20 20 20 20 20 20 20 20 20 28 73 76 61 (sva
0f20: 6c 20 28 69 66 20 28 73 74 72 69 6e 67 2d 73 65 l (if (string-se
0f30: 61 72 63 68 20 77 68 69 74 65 73 70 20 76 61 6c arch whitesp val
0f40: 29 28 63 6f 6e 63 20 22 5c 22 22 20 76 61 6c 20 )(conc "\"" val
0f50: 22 5c 22 22 29 20 76 61 6c 29 29 29 0a 20 20 20 "\"") val))).
0f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f70: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 65 78 (print "ex
0f80: 70 6f 72 74 20 22 20 28 63 61 72 20 6b 65 79 29 port " (car key)
0f90: 20 22 3d 22 20 73 76 61 6c 29 29 29 0a 20 20 20 "=" sval))).
0fa0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0fb0: 20 65 6e 76 76 61 72 73 29 29 29 29 29 0a 0a 3b envvars)))))..;
0fc0: 3b 20 73 65 74 20 73 6f 6d 65 20 65 6e 76 20 76 ; set some env v
0fd0: 61 72 73 20 66 72 6f 6d 20 61 6e 20 61 6c 69 73 ars from an alis
0fe0: 74 2c 20 72 65 74 75 72 6e 20 61 6e 20 61 6c 69 t, return an ali
0ff0: 73 74 20 77 69 74 68 20 6f 72 69 67 69 6e 61 6c st with original
1000: 20 76 61 6c 75 65 73 0a 3b 3b 20 28 28 22 56 41 values.;; (("VA
1010: 52 22 20 22 76 61 6c 75 65 22 29 20 2e 2e 2e 29 R" "value") ...)
1020: 0a 28 64 65 66 69 6e 65 20 28 61 6c 69 73 74 2d .(define (alist-
1030: 3e 65 6e 76 2d 76 61 72 73 20 6c 73 74 29 0a 20 >env-vars lst).
1040: 20 28 69 66 20 28 6c 69 73 74 3f 20 6c 73 74 29 (if (list? lst)
1050: 0a 20 20 20 20 20 20 28 6c 65 74 20 28 28 72 65 . (let ((re
1060: 73 20 27 28 29 29 29 0a 09 28 66 6f 72 2d 65 61 s '()))..(for-ea
1070: 63 68 20 28 6c 61 6d 62 64 61 20 28 70 29 0a 09 ch (lambda (p)..
1080: 09 20 20 20 20 28 6c 65 74 2a 20 28 28 76 61 72 . (let* ((var
1090: 20 28 63 61 72 20 20 70 29 29 0a 09 09 09 20 20 (car p))....
10a0: 20 28 76 61 6c 20 28 63 61 64 72 20 70 29 29 0a (val (cadr p)).
10b0: 09 09 09 20 20 20 28 70 72 76 20 28 67 65 74 2d ... (prv (get-
10c0: 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 environment-vari
10d0: 61 62 6c 65 20 76 61 72 29 29 29 0a 09 09 20 20 able var)))...
10e0: 20 20 20 20 28 73 65 74 21 20 72 65 73 20 28 63 (set! res (c
10f0: 6f 6e 73 20 28 6c 69 73 74 20 76 61 72 20 70 72 ons (list var pr
1100: 76 29 20 72 65 73 29 29 0a 09 09 20 20 20 20 20 v) res))...
1110: 20 28 69 66 20 76 61 6c 20 0a 09 09 09 20 20 28 (if val .... (
1120: 73 65 74 65 6e 76 20 76 61 72 20 28 2d 3e 73 74 setenv var (->st
1130: 72 69 6e 67 20 76 61 6c 29 29 0a 09 09 09 20 20 ring val))....
1140: 28 75 6e 73 65 74 65 6e 76 20 76 61 72 29 29 29 (unsetenv var)))
1150: 29 0a 09 09 20 20 6c 73 74 29 0a 09 72 65 73 29 )... lst)..res)
1160: 0a 20 20 20 20 20 20 27 28 29 29 29 0a 09 09 20 . '()))...
1170: 20 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;============
1180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 74 69 ==========.;; ti
11c0: 6d 65 20 61 6e 64 20 64 61 74 65 20 6e 69 63 65 me and date nice
11d0: 20 74 6f 20 68 61 76 65 20 73 74 75 66 66 0a 3b to have stuff.;
11e0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
11f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1220: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
1230: 20 28 73 65 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 (seconds->hr-mi
1240: 6e 2d 73 65 63 20 73 65 63 73 29 0a 20 20 28 6c n-sec secs). (l
1250: 65 74 2a 20 28 28 68 72 73 20 28 71 75 6f 74 69 et* ((hrs (quoti
1260: 65 6e 74 20 73 65 63 73 20 33 36 30 30 29 29 0a ent secs 3600)).
1270: 09 20 28 6d 69 6e 20 28 71 75 6f 74 69 65 6e 74 . (min (quotient
1280: 20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 (- secs (* hrs
1290: 33 36 30 30 29 29 20 36 30 29 29 0a 09 20 28 73 3600)) 60)).. (s
12a0: 65 63 20 28 2d 20 73 65 63 73 20 28 2a 20 68 72 ec (- secs (* hr
12b0: 73 20 33 36 30 30 29 28 2a 20 6d 69 6e 20 36 30 s 3600)(* min 60
12c0: 29 29 29 29 0a 20 20 20 20 28 63 6f 6e 63 20 28 )))). (conc (
12d0: 69 66 20 28 3e 20 68 72 73 20 30 29 28 63 6f 6e if (> hrs 0)(con
12e0: 63 20 68 72 73 20 22 68 72 20 22 29 20 22 22 29 c hrs "hr ") "")
12f0: 0a 09 20 20 28 69 66 20 28 3e 20 6d 69 6e 20 30 .. (if (> min 0
1300: 29 28 63 6f 6e 63 20 6d 69 6e 20 22 6d 20 22 29 )(conc min "m ")
1310: 20 20 22 22 29 0a 09 20 20 73 65 63 20 22 73 22 "").. sec "s"
1320: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 )))..(define (se
1330: 63 6f 6e 64 73 2d 3e 74 69 6d 65 2d 73 74 72 69 conds->time-stri
1340: 6e 67 20 73 65 63 29 0a 20 20 28 74 69 6d 65 2d ng sec). (time-
1350: 3e 73 74 72 69 6e 67 20 0a 20 20 20 28 73 65 63 >string . (sec
1360: 6f 6e 64 73 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 onds->local-time
1370: 20 73 65 63 29 20 22 25 48 3a 25 4d 3a 25 53 22 sec) "%H:%M:%S"
1380: 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ))..;;==========
1390: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 ============.;;
13d0: 43 6f 6c 6f 72 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d Colors.;;=======
13e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
13f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1400: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1410: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a ===============.
1420: 20 20 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 .(define (
1430: 63 6f 6d 6d 6f 6e 3a 6e 61 6d 65 2d 3e 69 75 70 common:name->iup
1440: 2d 63 6f 6c 6f 72 20 6e 61 6d 65 29 0a 20 20 28 -color name). (
1450: 63 61 73 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 case (string->sy
1460: 6d 62 6f 6c 20 28 73 74 72 69 6e 67 2d 64 6f 77 mbol (string-dow
1470: 6e 63 61 73 65 20 6e 61 6d 65 29 29 0a 20 20 20 ncase name)).
1480: 20 28 28 72 65 64 29 20 20 20 20 22 32 32 33 20 ((red) "223
1490: 33 33 20 34 39 22 29 0a 20 20 20 20 28 28 67 72 33 49"). ((gr
14a0: 65 79 29 20 20 20 22 31 39 32 20 31 39 32 20 31 ey) "192 192 1
14b0: 39 32 22 29 0a 20 20 20 20 28 28 6f 72 61 6e 67 92"). ((orang
14c0: 65 29 20 22 32 35 35 20 31 37 32 20 31 33 22 29 e) "255 172 13")
14d0: 0a 20 20 20 20 28 28 70 75 72 70 6c 65 29 20 22 . ((purple) "
14e0: 54 68 69 73 20 69 73 20 75 6e 66 69 6e 69 73 68 This is unfinish
14f0: 65 64 20 2e 2e 2e 22 29 29 29 0a 0a 28 64 65 66 ed ...")))..(def
1500: 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d ine (common:get-
1510: 63 6f 6c 6f 72 2d 66 6f 72 2d 73 74 61 74 65 2d color-for-state-
1520: 73 74 61 74 75 73 20 73 74 61 74 65 20 73 74 61 status state sta
1530: 74 75 73 20 74 79 70 65 29 0a 20 20 28 63 61 73 tus type). (cas
1540: 65 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f e (string->symbo
1550: 6c 20 73 74 61 74 65 29 0a 20 20 20 20 28 28 43 l state). ((C
1560: 4f 4d 50 4c 45 54 45 44 29 0a 20 20 20 20 20 28 OMPLETED). (
1570: 69 66 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 if (equal? statu
1580: 73 20 22 50 41 53 53 22 29 0a 09 20 22 37 30 20 s "PASS").. "70
1590: 32 34 39 20 37 33 22 0a 09 20 28 69 66 20 28 6f 249 73".. (if (o
15a0: 72 20 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 r (equal? status
15b0: 20 22 57 41 52 4e 22 29 0a 09 09 20 28 65 71 75 "WARN")... (equ
15c0: 61 6c 3f 20 73 74 61 74 75 73 20 22 57 41 49 56 al? status "WAIV
15d0: 45 44 22 29 29 0a 09 20 20 20 20 20 22 32 35 35 ED")).. "255
15e0: 20 31 37 32 20 31 33 22 0a 09 20 20 20 20 20 22 172 13".. "
15f0: 32 32 33 20 33 33 20 34 39 22 29 29 29 20 3b 3b 223 33 49"))) ;;
1600: 20 67 72 65 65 6e 69 73 68 20 6f 72 61 6e 67 65 greenish orange
1610: 69 73 68 20 72 65 64 69 73 68 0a 20 20 20 20 28 ish redish. (
1620: 28 4c 41 55 4e 43 48 45 44 29 20 20 20 20 20 20 (LAUNCHED)
1630: 20 20 20 22 31 30 31 20 31 32 33 20 31 34 32 22 "101 123 142"
1640: 29 0a 20 20 20 20 28 28 43 48 45 43 4b 29 20 20 ). ((CHECK)
1650: 20 20 20 20 20 20 20 20 20 20 22 32 35 35 20 31 "255 1
1660: 30 30 20 35 30 22 29 0a 20 20 20 20 28 28 52 45 00 50"). ((RE
1670: 4d 4f 54 45 48 4f 53 54 53 54 41 52 54 29 20 20 MOTEHOSTSTART)
1680: 22 35 30 20 31 33 30 20 31 39 35 22 29 0a 20 20 "50 130 195").
1690: 20 20 28 28 52 55 4e 4e 49 4e 47 29 20 20 20 20 ((RUNNING)
16a0: 20 20 20 20 20 20 22 39 20 31 33 31 20 32 33 32 "9 131 232
16b0: 22 29 0a 20 20 20 20 28 28 4b 49 4c 4c 52 45 51 "). ((KILLREQ
16c0: 29 20 20 20 20 20 20 20 20 20 20 22 33 39 20 38 ) "39 8
16d0: 32 20 32 30 36 22 29 0a 20 20 20 20 28 28 4b 49 2 206"). ((KI
16e0: 4c 4c 45 44 29 20 20 20 20 20 20 20 20 20 20 20 LLED)
16f0: 22 32 33 34 20 31 30 31 20 31 37 22 29 0a 20 20 "234 101 17").
1700: 20 20 28 28 4e 4f 54 5f 53 54 41 52 54 45 44 29 ((NOT_STARTED)
1710: 20 20 20 20 20 20 22 32 34 30 20 32 34 30 20 32 "240 240 2
1720: 34 30 22 29 0a 20 20 20 20 28 65 6c 73 65 20 20 40"). (else
1730: 20 20 20 20 20 20 20 20 20 20 20 20 20 22 31 39 "19
1740: 32 20 31 39 32 20 31 39 32 22 29 29 29 0a 0a 28 2 192 192")))..(
1750: 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 define (common:g
1760: 65 74 2d 63 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 et-color-from-st
1770: 61 74 75 73 20 73 74 61 74 75 73 29 0a 20 20 28 atus status). (
1780: 63 6f 6e 64 0a 20 20 20 28 28 65 71 75 61 6c 3f cond. ((equal?
1790: 20 73 74 61 74 75 73 20 22 50 41 53 53 22 29 20 status "PASS")
17a0: 20 20 20 22 67 72 65 65 6e 22 29 0a 20 20 20 28 "green"). (
17b0: 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
17c0: 46 41 49 4c 22 29 20 20 20 20 22 72 65 64 22 29 FAIL") "red")
17d0: 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
17e0: 74 75 73 20 22 57 41 52 4e 22 29 20 20 20 20 22 tus "WARN") "
17f0: 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 28 65 71 orange"). ((eq
1800: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 4b 49 4c ual? status "KIL
1810: 4c 45 44 22 29 20 20 22 6f 72 61 6e 67 65 22 29 LED") "orange")
1820: 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
1830: 74 75 73 20 22 4b 49 4c 4c 52 45 51 22 29 20 22 tus "KILLREQ") "
1840: 70 75 72 70 6c 65 22 29 0a 20 20 20 28 28 65 71 purple"). ((eq
1850: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 52 55 4e ual? status "RUN
1860: 4e 49 4e 47 22 29 20 22 62 6c 75 65 22 29 0a 20 NING") "blue").
1870: 20 20 28 65 6c 73 65 20 22 62 6c 61 63 6b 22 29 (else "black")
1880: 29 29 0a )).