File
common.scm
— part of check-in
[331e7c90b2]
at
2012-02-23 21:42:21
on branch archiving
— Merged in rpc stuff, fixed few bugs
(user:
matt
size: 6367)
[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 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 28 64 65 66 69 6e tcp port.(defin
0560: 65 20 2a 72 75 6e 72 65 6d 6f 74 65 2a 20 20 20 e *runremote*
0570: 20 23 66 29 20 3b 3b 20 69 66 20 73 65 74 20 75 #f) ;; if set u
0580: 70 20 66 6f 72 20 73 65 72 76 65 72 20 63 6f 6d p for server com
0590: 6d 75 6e 69 63 61 74 69 6f 6e 20 74 68 69 73 20 munication this
05a0: 77 69 6c 6c 20 68 6f 6c 64 20 3c 68 6f 73 74 20 will hold <host
05b0: 70 6f 72 74 3e 0a 0a 28 64 65 66 69 6e 65 20 28 port>..(define (
05c0: 67 65 74 2d 77 69 74 68 2d 64 65 66 61 75 6c 74 get-with-default
05d0: 20 76 61 6c 20 64 65 66 61 75 6c 74 29 0a 20 20 val default).
05e0: 28 6c 65 74 20 28 28 76 61 6c 20 28 61 72 67 73 (let ((val (args
05f0: 3a 67 65 74 2d 61 72 67 20 76 61 6c 29 29 29 0a :get-arg val))).
0600: 20 20 20 20 28 69 66 20 76 61 6c 20 76 61 6c 20 (if val val
0610: 64 65 66 61 75 6c 74 29 29 29 0a 0a 28 64 65 66 default)))..(def
0620: 69 6e 65 20 28 61 73 73 6f 63 2f 64 65 66 61 75 ine (assoc/defau
0630: 6c 74 20 6b 65 79 20 6c 73 74 20 2e 20 64 65 66 lt key lst . def
0640: 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 28 28 72 ault). (let ((r
0650: 65 73 20 28 61 73 73 6f 63 20 6b 65 79 20 6c 73 es (assoc key ls
0660: 74 29 29 29 0a 20 20 20 20 28 69 66 20 72 65 73 t))). (if res
0670: 20 28 63 61 64 72 20 72 65 73 29 28 69 66 20 28 (cadr res)(if (
0680: 6e 75 6c 6c 3f 20 64 65 66 61 75 6c 74 29 20 23 null? default) #
0690: 66 20 28 63 61 72 20 64 65 66 61 75 6c 74 29 29 f (car default))
06a0: 29 29 29 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
06f0: 20 4d 69 73 63 20 75 74 69 6c 73 0a 3b 3b 3d 3d Misc utils.;;==
0700: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0710: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 3b 3b 20 63 6f 6e 76 65 72 74 ====..;; convert
0750: 20 73 74 75 66 66 20 74 6f 20 61 20 6e 75 6d 62 stuff to a numb
0760: 65 72 20 69 66 20 70 6f 73 73 69 62 6c 65 0a 28 er if possible.(
0770: 64 65 66 69 6e 65 20 28 61 6e 79 2d 3e 6e 75 6d define (any->num
0780: 62 65 72 20 76 61 6c 29 0a 20 20 28 63 6f 6e 64 ber val). (cond
0790: 20 0a 20 20 20 28 28 6e 75 6d 62 65 72 3f 20 76 . ((number? v
07a0: 61 6c 29 20 76 61 6c 29 0a 20 20 20 28 28 73 74 al) val). ((st
07b0: 72 69 6e 67 3f 20 76 61 6c 29 20 28 73 74 72 69 ring? val) (stri
07c0: 6e 67 2d 3e 6e 75 6d 62 65 72 20 76 61 6c 29 29 ng->number val))
07d0: 0a 20 20 20 28 28 73 79 6d 62 6f 6c 3f 20 76 61 . ((symbol? va
07e0: 6c 29 20 28 61 6e 79 2d 3e 6e 75 6d 62 65 72 20 l) (any->number
07f0: 28 73 79 6d 62 6f 6c 2d 3e 73 74 72 69 6e 67 20 (symbol->string
0800: 76 61 6c 29 29 29 0a 20 20 20 28 65 6c 73 65 20 val))). (else
0810: 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 #f)))..(define (
0820: 61 6e 79 2d 3e 6e 75 6d 62 65 72 2d 69 66 2d 70 any->number-if-p
0830: 6f 73 73 69 62 6c 65 20 76 61 6c 29 0a 20 20 28 ossible val). (
0840: 6c 65 74 20 28 28 6e 75 6d 20 28 61 6e 79 2d 3e let ((num (any->
0850: 6e 75 6d 62 65 72 20 76 61 6c 29 29 29 0a 20 20 number val))).
0860: 20 20 28 69 66 20 6e 75 6d 20 6e 75 6d 20 76 61 (if num num va
0870: 6c 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d l)))..;;========
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 3d 3d 3d 0a 3b ==============.;
08c0: 3b 20 53 79 73 74 65 6d 20 73 74 75 66 66 0a 3b ; System stuff.;
08d0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
08e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
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 0a 0a 28 64 65 66 69 6e 65 =======..(define
0920: 20 28 67 65 74 2d 64 66 20 70 61 74 68 29 0a 20 (get-df path).
0930: 20 28 6c 65 74 2a 20 28 28 64 66 2d 72 65 73 75 (let* ((df-resu
0940: 6c 74 73 20 28 63 6d 64 2d 72 75 6e 2d 3e 6c 69 lts (cmd-run->li
0950: 73 74 20 28 63 6f 6e 63 20 22 64 66 20 22 20 70 st (conc "df " p
0960: 61 74 68 29 29 29 0a 09 20 28 73 70 61 63 65 2d ath))).. (space-
0970: 72 78 20 20 20 28 72 65 67 65 78 70 20 22 28 5b rx (regexp "([
0980: 30 2d 39 5d 2b 29 5c 5c 73 2b 28 5b 30 2d 39 5d 0-9]+)\\s+([0-9]
0990: 2b 29 25 22 29 29 0a 09 20 28 66 72 65 65 73 70 +)%")).. (freesp
09a0: 63 20 20 20 20 23 66 29 29 0a 20 20 20 20 3b 3b c #f)). ;;
09b0: 20 28 77 72 69 74 65 20 64 66 2d 72 65 73 75 6c (write df-resul
09c0: 74 73 29 0a 20 20 20 20 28 66 6f 72 2d 65 61 63 ts). (for-eac
09d0: 68 20 28 6c 61 6d 62 64 61 20 28 6c 29 0a 09 09 h (lambda (l)...
09e0: 28 6c 65 74 20 28 28 6d 61 74 63 68 20 28 73 74 (let ((match (st
09f0: 72 69 6e 67 2d 73 65 61 72 63 68 20 73 70 61 63 ring-search spac
0a00: 65 2d 72 78 20 6c 29 29 29 0a 09 09 20 20 28 69 e-rx l)))... (i
0a10: 66 20 6d 61 74 63 68 20 0a 09 09 20 20 20 20 20 f match ...
0a20: 20 28 6c 65 74 20 28 28 6e 65 77 76 61 6c 20 28 (let ((newval (
0a30: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 28 string->number (
0a40: 63 61 64 72 20 6d 61 74 63 68 29 29 29 29 0a 09 cadr match))))..
0a50: 09 09 28 69 66 20 28 6e 75 6d 62 65 72 3f 20 6e ..(if (number? n
0a60: 65 77 76 61 6c 29 0a 09 09 09 20 20 20 20 28 73 ewval).... (s
0a70: 65 74 21 20 66 72 65 65 73 70 63 20 6e 65 77 76 et! freespc newv
0a80: 61 6c 29 29 29 29 29 29 0a 09 20 20 20 20 20 20 al))))))..
0a90: 28 63 61 72 20 64 66 2d 72 65 73 75 6c 74 73 29 (car df-results)
0aa0: 29 0a 20 20 20 20 66 72 65 65 73 70 63 29 29 0a ). freespc)).
0ab0: 20 20 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d .(define (get-
0ac0: 63 70 75 2d 6c 6f 61 64 29 0a 20 20 28 6c 65 74 cpu-load). (let
0ad0: 2a 20 28 28 6c 6f 61 64 2d 72 65 73 20 28 63 6d * ((load-res (cm
0ae0: 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 22 75 70 74 d-run->list "upt
0af0: 69 6d 65 22 29 29 0a 09 20 28 6c 6f 61 64 2d 72 ime")).. (load-r
0b00: 78 20 20 28 72 65 67 65 78 70 20 22 6c 6f 61 64 x (regexp "load
0b10: 20 61 76 65 72 61 67 65 3a 5c 5c 73 2b 28 5c 5c average:\\s+(\\
0b20: 64 2b 29 22 29 29 0a 09 20 28 63 70 75 2d 6c 6f d+)")).. (cpu-lo
0b30: 61 64 20 23 66 29 29 0a 20 20 20 20 28 66 6f 72 ad #f)). (for
0b40: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6c -each (lambda (l
0b50: 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 74 63 68 )...(let ((match
0b60: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
0b70: 6c 6f 61 64 2d 72 78 20 6c 29 29 29 0a 09 09 20 load-rx l)))...
0b80: 20 28 69 66 20 6d 61 74 63 68 0a 09 09 20 20 20 (if match...
0b90: 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 61 6c (let ((newval
0ba0: 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 (string->number
0bb0: 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 29 29 (cadr match))))
0bc0: 0a 09 09 09 28 69 66 20 28 6e 75 6d 62 65 72 3f ....(if (number?
0bd0: 20 6e 65 77 76 61 6c 29 0a 09 09 09 20 20 20 20 newval)....
0be0: 28 73 65 74 21 20 63 70 75 2d 6c 6f 61 64 20 6e (set! cpu-load n
0bf0: 65 77 76 61 6c 29 29 29 29 29 29 0a 09 20 20 20 ewval))))))..
0c00: 20 20 20 28 63 61 72 20 6c 6f 61 64 2d 72 65 73 (car load-res
0c10: 29 29 0a 20 20 20 20 63 70 75 2d 6c 6f 61 64 29 )). cpu-load)
0c20: 29 0a 0a 28 64 65 66 69 6e 65 20 28 67 65 74 2d )..(define (get-
0c30: 75 6e 61 6d 65 20 2e 20 70 61 72 61 6d 73 29 0a uname . params).
0c40: 20 20 28 6c 65 74 2a 20 28 28 75 6e 61 6d 65 2d (let* ((uname-
0c50: 72 65 73 20 28 63 6d 64 2d 72 75 6e 2d 3e 6c 69 res (cmd-run->li
0c60: 73 74 20 28 63 6f 6e 63 20 22 75 6e 61 6d 65 20 st (conc "uname
0c70: 22 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 " (if (null? par
0c80: 61 6d 73 29 20 22 2d 61 22 20 28 63 61 72 20 70 ams) "-a" (car p
0c90: 61 72 61 6d 73 29 29 29 29 29 0a 09 20 28 75 6e arams))))).. (un
0ca0: 61 6d 65 20 23 66 29 29 0a 20 20 20 20 28 69 66 ame #f)). (if
0cb0: 20 28 6e 75 6c 6c 3f 20 28 63 61 72 20 75 6e 61 (null? (car una
0cc0: 6d 65 2d 72 65 73 29 29 0a 09 22 75 6e 6b 6e 6f me-res)).."unkno
0cd0: 77 6e 22 0a 09 28 63 61 61 72 20 75 6e 61 6d 65 wn"..(caar uname
0ce0: 2d 72 65 73 29 29 29 29 0a 09 20 20 20 20 20 20 -res))))..
0cf0: 0a 28 64 65 66 69 6e 65 20 28 73 61 76 65 2d 65 .(define (save-e
0d00: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 73 2d 66 69 nvironment-as-fi
0d10: 6c 65 73 20 66 6e 61 6d 65 29 0a 20 20 28 6c 65 les fname). (le
0d20: 74 20 28 28 65 6e 76 76 61 72 73 20 28 67 65 74 t ((envvars (get
0d30: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
0d40: 69 61 62 6c 65 73 29 29 0a 20 20 20 20 20 20 20 iables)).
0d50: 20 28 77 68 69 74 65 73 70 20 28 72 65 67 65 78 (whitesp (regex
0d60: 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 2d 39 5f 5c p "[^a-zA-Z0-9_\
0d70: 5c 2d 3a 3b 2c 2e 5c 5c 2f 25 24 5d 22 29 29 29 \-:;,.\\/%$]")))
0d80: 0a 20 20 20 20 20 28 77 69 74 68 2d 6f 75 74 70 . (with-outp
0d90: 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 ut-to-file (conc
0da0: 20 66 6e 61 6d 65 20 22 2e 63 73 68 22 29 0a 20 fname ".csh").
0db0: 20 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 (lambda ()
0dc0: 0a 20 20 20 20 20 20 20 20 20 20 28 66 6f 72 2d . (for-
0dd0: 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6b 65 each (lambda (ke
0de0: 79 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 y).
0df0: 20 20 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 (let* (
0e00: 28 76 61 6c 20 28 63 64 72 20 6b 65 79 29 29 0a (val (cdr key)).
0e10: 20 20 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 20 20 20 28 73 76 (sv
0e30: 61 6c 20 28 69 66 20 28 73 74 72 69 6e 67 2d 73 al (if (string-s
0e40: 65 61 72 63 68 20 77 68 69 74 65 73 70 20 76 61 earch whitesp va
0e50: 6c 29 28 63 6f 6e 63 20 22 5c 22 22 20 76 61 6c l)(conc "\"" val
0e60: 20 22 5c 22 22 29 20 76 61 6c 29 29 29 0a 20 20 "\"") val))).
0e70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e80: 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 73 65 (print "se
0e90: 74 65 6e 76 20 22 20 28 63 61 72 20 6b 65 79 29 tenv " (car key)
0ea0: 20 22 20 22 20 73 76 61 6c 29 29 29 0a 20 20 20 " " sval))).
0eb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ec0: 20 20 65 6e 76 76 61 72 73 29 29 29 0a 20 20 20 envvars))).
0ed0: 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d 74 (with-output-t
0ee0: 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e 61 o-file (conc fna
0ef0: 6d 65 20 22 2e 73 68 22 29 0a 20 20 20 20 20 20 me ".sh").
0f00: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
0f10: 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 20 (for-each
0f20: 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 20 (lambda (key).
0f30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f40: 20 20 20 20 28 6c 65 74 2a 20 28 28 76 61 6c 20 (let* ((val
0f50: 28 63 64 72 20 6b 65 79 29 29 0a 20 20 20 20 20 (cdr key)).
0f60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f70: 20 20 20 20 20 20 20 20 28 73 76 61 6c 20 28 69 (sval (i
0f80: 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 f (string-search
0f90: 20 77 68 69 74 65 73 70 20 76 61 6c 29 28 63 6f whitesp val)(co
0fa0: 6e 63 20 22 5c 22 22 20 76 61 6c 20 22 5c 22 22 nc "\"" val "\""
0fb0: 29 20 76 61 6c 29 29 29 0a 20 20 20 20 20 20 20 ) val))).
0fc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0fd0: 20 20 28 70 72 69 6e 74 20 22 65 78 70 6f 72 74 (print "export
0fe0: 20 22 20 28 63 61 72 20 6b 65 79 29 20 22 3d 22 " (car key) "="
0ff0: 20 73 76 61 6c 29 29 29 0a 20 20 20 20 20 20 20 sval))).
1000: 20 20 20 20 20 20 20 20 20 20 20 20 20 65 6e 76 env
1010: 76 61 72 73 29 29 29 29 29 0a 0a 3b 3b 20 73 65 vars)))))..;; se
1020: 74 20 73 6f 6d 65 20 65 6e 76 20 76 61 72 73 20 t some env vars
1030: 66 72 6f 6d 20 61 6e 20 61 6c 69 73 74 2c 20 72 from an alist, r
1040: 65 74 75 72 6e 20 61 6e 20 61 6c 69 73 74 20 77 eturn an alist w
1050: 69 74 68 20 6f 72 69 67 69 6e 61 6c 20 76 61 6c ith original val
1060: 75 65 73 0a 3b 3b 20 28 28 22 56 41 52 22 20 22 ues.;; (("VAR" "
1070: 76 61 6c 75 65 22 29 20 2e 2e 2e 29 0a 28 64 65 value") ...).(de
1080: 66 69 6e 65 20 28 61 6c 69 73 74 2d 3e 65 6e 76 fine (alist->env
1090: 2d 76 61 72 73 20 6c 73 74 29 0a 20 20 28 69 66 -vars lst). (if
10a0: 20 28 6c 69 73 74 3f 20 6c 73 74 29 0a 20 20 20 (list? lst).
10b0: 20 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 (let ((res '(
10c0: 29 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 )))..(for-each (
10d0: 6c 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 lambda (p)...
10e0: 20 28 6c 65 74 2a 20 28 28 76 61 72 20 28 63 61 (let* ((var (ca
10f0: 72 20 20 70 29 29 0a 09 09 09 20 20 20 28 76 61 r p)).... (va
1100: 6c 20 28 63 61 64 72 20 70 29 29 0a 09 09 09 20 l (cadr p))....
1110: 20 20 28 70 72 76 20 28 67 65 74 2d 65 6e 76 69 (prv (get-envi
1120: 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 ronment-variable
1130: 20 76 61 72 29 29 29 0a 09 09 20 20 20 20 20 20 var)))...
1140: 28 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 (set! res (cons
1150: 28 6c 69 73 74 20 76 61 72 20 70 72 76 29 20 72 (list var prv) r
1160: 65 73 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 es))... (if
1170: 20 76 61 6c 20 0a 09 09 09 20 20 28 73 65 74 65 val .... (sete
1180: 6e 76 20 76 61 72 20 28 2d 3e 73 74 72 69 6e 67 nv var (->string
1190: 20 76 61 6c 29 29 0a 09 09 09 20 20 28 75 6e 73 val)).... (uns
11a0: 65 74 65 6e 76 20 76 61 72 29 29 29 29 0a 09 09 etenv var))))...
11b0: 20 20 6c 73 74 29 0a 09 72 65 73 29 0a 20 20 20 lst)..res).
11c0: 20 20 20 27 28 29 29 29 0a 09 09 20 20 0a 3b 3b '()))... .;;
11d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11e0: 3d 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 0a 3b 3b 20 74 69 6d 65 20 61 ======.;; time a
1220: 6e 64 20 64 61 74 65 20 6e 69 63 65 20 74 6f 20 nd date nice to
1230: 68 61 76 65 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d have stuff.;;===
1240: 3d 3d 3d 3d 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 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 ===..(define (se
1290: 63 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 conds->hr-min-se
12a0: 63 20 73 65 63 73 29 0a 20 20 28 6c 65 74 2a 20 c secs). (let*
12b0: 28 28 68 72 73 20 28 71 75 6f 74 69 65 6e 74 20 ((hrs (quotient
12c0: 73 65 63 73 20 33 36 30 30 29 29 0a 09 20 28 6d secs 3600)).. (m
12d0: 69 6e 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 in (quotient (-
12e0: 73 65 63 73 20 28 2a 20 68 72 73 20 33 36 30 30 secs (* hrs 3600
12f0: 29 29 20 36 30 29 29 0a 09 20 28 73 65 63 20 28 )) 60)).. (sec (
1300: 2d 20 73 65 63 73 20 28 2a 20 68 72 73 20 33 36 - secs (* hrs 36
1310: 30 30 29 28 2a 20 6d 69 6e 20 36 30 29 29 29 29 00)(* min 60))))
1320: 0a 20 20 20 20 28 63 6f 6e 63 20 28 69 66 20 28 . (conc (if (
1330: 3e 20 68 72 73 20 30 29 28 63 6f 6e 63 20 68 72 > hrs 0)(conc hr
1340: 73 20 22 68 72 20 22 29 20 22 22 29 0a 09 20 20 s "hr ") "")..
1350: 28 69 66 20 28 3e 20 6d 69 6e 20 30 29 28 63 6f (if (> min 0)(co
1360: 6e 63 20 6d 69 6e 20 22 6d 20 22 29 20 20 22 22 nc min "m ") ""
1370: 29 0a 09 20 20 73 65 63 20 22 73 22 29 29 29 0a ).. sec "s"))).
1380: 0a 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 .(define (second
1390: 73 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 s->time-string s
13a0: 65 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 ec). (time->str
13b0: 69 6e 67 20 0a 20 20 20 28 73 65 63 6f 6e 64 73 ing . (seconds
13c0: 2d 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 ->local-time sec
13d0: 29 20 22 25 48 3a 25 4d 3a 25 53 22 29 29 0a 0a ) "%H:%M:%S"))..
13e0: 3b 3b 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 3d ================
1420: 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 43 6f 6c 6f ========.;; Colo
1430: 72 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d rs.;;===========
1440: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1450: 3d 3d 3d 3d 3d 3d 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 0a 20 20 20 20 ===========.
1480: 20 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d .(define (comm
1490: 6f 6e 3a 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c on:name->iup-col
14a0: 6f 72 20 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 or name). (case
14b0: 20 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c (string->symbol
14c0: 20 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 (string-downcas
14d0: 65 20 6e 61 6d 65 29 29 0a 20 20 20 20 28 28 72 e name)). ((r
14e0: 65 64 29 20 20 20 20 22 32 32 33 20 33 33 20 34 ed) "223 33 4
14f0: 39 22 29 0a 20 20 20 20 28 28 67 72 65 79 29 20 9"). ((grey)
1500: 20 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 "192 192 192")
1510: 0a 20 20 20 20 28 28 6f 72 61 6e 67 65 29 20 22 . ((orange) "
1520: 32 35 35 20 31 37 32 20 31 33 22 29 0a 20 20 20 255 172 13").
1530: 20 28 28 70 75 72 70 6c 65 29 20 22 54 68 69 73 ((purple) "This
1540: 20 69 73 20 75 6e 66 69 6e 69 73 68 65 64 20 2e is unfinished .
1550: 2e 2e 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ..")))..(define
1560: 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f (common:get-colo
1570: 72 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 61 74 r-for-state-stat
1580: 75 73 20 73 74 61 74 65 20 73 74 61 74 75 73 20 us state status
1590: 74 79 70 65 29 0a 20 20 28 63 61 73 65 20 28 73 type). (case (s
15a0: 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 tring->symbol st
15b0: 61 74 65 29 0a 20 20 20 20 28 28 43 4f 4d 50 4c ate). ((COMPL
15c0: 45 54 45 44 29 0a 20 20 20 20 20 28 69 66 20 28 ETED). (if (
15d0: 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 equal? status "P
15e0: 41 53 53 22 29 0a 09 20 22 37 30 20 32 34 39 20 ASS").. "70 249
15f0: 37 33 22 0a 09 20 28 69 66 20 28 6f 72 20 28 65 73".. (if (or (e
1600: 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 57 41 qual? status "WA
1610: 52 4e 22 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 RN")... (equal?
1620: 73 74 61 74 75 73 20 22 57 41 49 56 45 44 22 29 status "WAIVED")
1630: 29 0a 09 20 20 20 20 20 22 32 35 35 20 31 37 32 ).. "255 172
1640: 20 31 33 22 0a 09 20 20 20 20 20 22 32 32 33 20 13".. "223
1650: 33 33 20 34 39 22 29 29 29 20 3b 3b 20 67 72 65 33 49"))) ;; gre
1660: 65 6e 69 73 68 20 6f 72 61 6e 67 65 69 73 68 20 enish orangeish
1670: 72 65 64 69 73 68 0a 20 20 20 20 28 28 4c 41 55 redish. ((LAU
1680: 4e 43 48 45 44 29 20 20 20 20 20 20 20 20 20 22 NCHED) "
1690: 31 30 31 20 31 32 33 20 31 34 32 22 29 0a 20 20 101 123 142").
16a0: 20 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 20 ((CHECK)
16b0: 20 20 20 20 20 20 22 32 35 35 20 31 30 30 20 35 "255 100 5
16c0: 30 22 29 0a 20 20 20 20 28 28 52 45 4d 4f 54 45 0"). ((REMOTE
16d0: 48 4f 53 54 53 54 41 52 54 29 20 20 22 35 30 20 HOSTSTART) "50
16e0: 31 33 30 20 31 39 35 22 29 0a 20 20 20 20 28 28 130 195"). ((
16f0: 52 55 4e 4e 49 4e 47 29 20 20 20 20 20 20 20 20 RUNNING)
1700: 20 20 22 39 20 31 33 31 20 32 33 32 22 29 0a 20 "9 131 232").
1710: 20 20 20 28 28 4b 49 4c 4c 52 45 51 29 20 20 20 ((KILLREQ)
1720: 20 20 20 20 20 20 20 22 33 39 20 38 32 20 32 30 "39 82 20
1730: 36 22 29 0a 20 20 20 20 28 28 4b 49 4c 4c 45 44 6"). ((KILLED
1740: 29 20 20 20 20 20 20 20 20 20 20 20 22 32 33 34 ) "234
1750: 20 31 30 31 20 31 37 22 29 0a 20 20 20 20 28 28 101 17"). ((
1760: 4e 4f 54 5f 53 54 41 52 54 45 44 29 20 20 20 20 NOT_STARTED)
1770: 20 20 22 32 34 30 20 32 34 30 20 32 34 30 22 29 "240 240 240")
1780: 0a 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 . (else
1790: 20 20 20 20 20 20 20 20 20 22 31 39 32 20 31 39 "192 19
17a0: 32 20 31 39 32 22 29 29 29 0a 0a 28 64 65 66 69 2 192")))..(defi
17b0: 6e 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 ne (common:get-c
17c0: 6f 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 olor-from-status
17d0: 20 73 74 61 74 75 73 29 0a 20 20 28 63 6f 6e 64 status). (cond
17e0: 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 . ((equal? sta
17f0: 74 75 73 20 22 50 41 53 53 22 29 20 20 20 20 22 tus "PASS") "
1800: 67 72 65 65 6e 22 29 0a 20 20 20 28 28 65 71 75 green"). ((equ
1810: 61 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c al? status "FAIL
1820: 22 29 20 20 20 20 22 72 65 64 22 29 0a 20 20 20 ") "red").
1830: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
1840: 22 57 41 52 4e 22 29 20 20 20 20 22 6f 72 61 6e "WARN") "oran
1850: 67 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f ge"). ((equal?
1860: 20 73 74 61 74 75 73 20 22 4b 49 4c 4c 45 44 22 status "KILLED"
1870: 29 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 ) "orange").
1880: 28 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 ((equal? status
1890: 22 4b 49 4c 4c 52 45 51 22 29 20 22 70 75 72 70 "KILLREQ") "purp
18a0: 6c 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f le"). ((equal?
18b0: 20 73 74 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 status "RUNNING
18c0: 22 29 20 22 62 6c 75 65 22 29 0a 20 20 20 28 65 ") "blue"). (e
18d0: 6c 73 65 20 22 62 6c 61 63 6b 22 29 29 29 0a lse "black"))).