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