Artifact
ae869b679b8cd6ebc307fbd93eafb7b81079f051:
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 29 0a 28 72 65 71 ot-locking).(req
0220: 75 69 72 65 2d 65 78 74 65 6e 73 69 6f 6e 20 73 uire-extension s
0230: 71 6c 69 74 65 33 20 72 65 67 65 78 20 70 6f 73 qlite3 regex pos
0240: 69 78 29 0a 0a 28 69 6d 70 6f 72 74 20 28 70 72 ix)..(import (pr
0250: 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c efix sqlite3 sql
0260: 69 74 65 33 3a 29 29 0a 28 69 6d 70 6f 72 74 20 ite3:)).(import
0270: 28 70 72 65 66 69 78 20 62 61 73 65 36 34 20 62 (prefix base64 b
0280: 61 73 65 36 34 3a 29 29 0a 0a 3b 3b 20 28 72 65 ase64:))..;; (re
0290: 71 75 69 72 65 2d 6c 69 62 72 61 72 79 20 6d 61 quire-library ma
02a0: 72 67 73 29 0a 28 69 6e 63 6c 75 64 65 20 22 6d rgs).(include "m
02b0: 61 72 67 73 2e 73 63 6d 22 29 0a 0a 28 64 65 66 args.scm")..(def
02c0: 69 6e 65 20 67 65 74 65 6e 76 20 67 65 74 2d 65 ine getenv get-e
02d0: 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 nvironment-varia
02e0: 62 6c 65 29 0a 0a 28 64 65 66 69 6e 65 20 68 6f ble)..(define ho
02f0: 6d 65 20 28 67 65 74 65 6e 76 20 22 48 4f 4d 45 me (getenv "HOME
0300: 22 29 29 0a 28 64 65 66 69 6e 65 20 75 73 65 72 ")).(define user
0310: 20 28 67 65 74 65 6e 76 20 22 55 53 45 52 22 29 (getenv "USER")
0320: 29 0a 0a 3b 3b 20 67 6c 6f 62 61 6c 20 67 6c 65 )..;; global gle
0330: 74 63 68 65 73 0a 28 64 65 66 69 6e 65 20 2a 63 tches.(define *c
0340: 6f 6e 66 69 67 69 6e 66 6f 2a 20 23 66 29 0a 28 onfiginfo* #f).(
0350: 64 65 66 69 6e 65 20 2a 63 6f 6e 66 69 67 64 61 define *configda
0360: 74 2a 20 20 23 66 29 0a 28 64 65 66 69 6e 65 20 t* #f).(define
0370: 2a 74 6f 70 70 61 74 68 2a 20 20 20 20 23 66 29 *toppath* #f)
0380: 0a 28 64 65 66 69 6e 65 20 2a 61 6c 72 65 61 64 .(define *alread
0390: 79 2d 73 65 65 6e 2d 72 75 6e 63 6f 6e 66 69 67 y-seen-runconfig
03a0: 2d 69 6e 66 6f 2a 20 23 66 29 0a 28 64 65 66 69 -info* #f).(defi
03b0: 6e 65 20 2a 77 61 69 74 69 6e 67 2d 71 75 65 75 ne *waiting-queu
03c0: 65 2a 20 28 6d 61 6b 65 2d 68 61 73 68 2d 74 61 e* (make-hash-ta
03d0: 62 6c 65 29 29 0a 28 64 65 66 69 6e 65 20 2a 67 ble)).(define *g
03e0: 6c 6f 62 61 6c 65 78 69 74 73 74 61 74 75 73 2a lobalexitstatus*
03f0: 20 30 29 20 3b 3b 20 61 74 74 65 6d 70 74 20 74 0) ;; attempt t
0400: 6f 20 77 6f 72 6b 20 61 72 6f 75 6e 64 20 70 6f o work around po
0410: 73 73 69 62 6c 65 20 74 68 72 65 61 64 20 69 73 ssible thread is
0420: 73 75 65 73 0a 28 64 65 66 69 6e 65 20 2a 70 61 sues.(define *pa
0430: 73 73 6e 75 6d 2a 20 20 20 20 20 30 29 20 3b 3b ssnum* 0) ;;
0440: 20 77 68 65 6e 20 72 75 6e 6e 69 6e 67 20 74 72 when running tr
0450: 61 63 6b 20 63 61 6c 6c 73 20 74 6f 20 72 75 6e ack calls to run
0460: 2d 74 65 73 74 73 20 6f 72 20 73 69 6d 69 6c 61 -tests or simila
0470: 72 0a 28 64 65 66 69 6e 65 20 2a 76 65 72 62 6f r.(define *verbo
0480: 73 69 74 79 2a 20 20 20 31 29 0a 0a 28 64 65 66 sity* 1)..(def
0490: 69 6e 65 2d 69 6e 6c 69 6e 65 20 28 67 65 74 2d ine-inline (get-
04a0: 77 69 74 68 2d 64 65 66 61 75 6c 74 20 76 61 6c with-default val
04b0: 20 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 default). (let
04c0: 20 28 28 76 61 6c 20 28 61 72 67 73 3a 67 65 74 ((val (args:get
04d0: 2d 61 72 67 20 76 61 6c 29 29 29 0a 20 20 20 20 -arg val))).
04e0: 28 69 66 20 76 61 6c 20 76 61 6c 20 64 65 66 61 (if val val defa
04f0: 75 6c 74 29 29 29 0a 0a 28 64 65 66 69 6e 65 2d ult)))..(define-
0500: 69 6e 6c 69 6e 65 20 28 61 73 73 6f 63 2f 64 65 inline (assoc/de
0510: 66 61 75 6c 74 20 6b 65 79 20 6c 73 74 20 2e 20 fault key lst .
0520: 64 65 66 61 75 6c 74 29 0a 20 20 28 6c 65 74 20 default). (let
0530: 28 28 72 65 73 20 28 61 73 73 6f 63 20 6b 65 79 ((res (assoc key
0540: 20 6c 73 74 29 29 29 0a 20 20 20 20 28 69 66 20 lst))). (if
0550: 72 65 73 20 28 63 61 64 72 20 72 65 73 29 28 69 res (cadr res)(i
0560: 66 20 28 6e 75 6c 6c 3f 20 64 65 66 61 75 6c 74 f (null? default
0570: 29 20 23 66 20 28 63 61 72 20 64 65 66 61 75 6c ) #f (car defaul
0580: 74 29 29 29 29 29 0a 0a 3b 3b 3d 3d 3d 3d 3d 3d t)))))..;;======
0590: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
05d0: 0a 3b 3b 20 4d 69 73 63 20 75 74 69 6c 73 0a 3b .;; Misc utils.;
05e0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
05f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0600: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0610: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0620: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
0630: 2d 69 6e 6c 69 6e 65 20 28 64 65 62 75 67 3a 70 -inline (debug:p
0640: 72 69 6e 74 20 6e 20 2e 20 70 61 72 61 6d 73 29 rint n . params)
0650: 0a 20 20 28 69 66 20 28 3c 3d 20 6e 20 2a 76 65 . (if (<= n *ve
0660: 72 62 6f 73 69 74 79 2a 29 0a 20 20 20 20 20 20 rbosity*).
0670: 28 61 70 70 6c 79 20 70 72 69 6e 74 20 70 61 72 (apply print par
0680: 61 6d 73 29 29 29 0a 0a 3b 3b 20 69 66 20 61 20 ams)))..;; if a
0690: 76 61 6c 75 65 20 69 73 20 70 72 69 6e 74 61 62 value is printab
06a0: 6c 65 20 28 69 2e 65 2e 20 73 74 72 69 6e 67 20 le (i.e. string
06b0: 6f 72 20 6e 75 6d 62 65 72 29 20 72 65 74 75 72 or number) retur
06c0: 6e 20 74 68 65 20 76 61 6c 75 65 0a 3b 3b 20 65 n the value.;; e
06d0: 6c 73 65 20 72 65 74 75 72 6e 20 61 6e 20 65 6d lse return an em
06e0: 70 74 79 20 73 74 72 69 6e 67 0a 28 64 65 66 69 pty string.(defi
06f0: 6e 65 2d 69 6e 6c 69 6e 65 20 28 70 72 69 6e 74 ne-inline (print
0700: 61 62 6c 65 20 76 61 6c 29 0a 20 20 28 69 66 20 able val). (if
0710: 28 6f 72 20 28 6e 75 6d 62 65 72 3f 20 76 61 6c (or (number? val
0720: 29 28 73 74 72 69 6e 67 3f 20 76 61 6c 29 29 20 )(string? val))
0730: 76 61 6c 20 22 22 29 29 0a 0a 3b 3b 3d 3d 3d 3d val ""))..;;====
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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0770: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0780: 3d 3d 0a 3b 3b 20 53 79 73 74 65 6d 20 73 74 75 ==.;; System stu
0790: 66 66 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ff.;;===========
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 3d 3d 3d 3d 3d 3d 3d 3d ================
07c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 ===========..(de
07e0: 66 69 6e 65 20 28 67 65 74 2d 64 66 20 70 61 74 fine (get-df pat
07f0: 68 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 66 2d h). (let* ((df-
0800: 72 65 73 75 6c 74 73 20 28 63 6d 64 2d 72 75 6e results (cmd-run
0810: 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 64 66 ->list (conc "df
0820: 20 22 20 70 61 74 68 29 29 29 0a 09 20 28 73 70 " path))).. (sp
0830: 61 63 65 2d 72 78 20 20 20 28 72 65 67 65 78 70 ace-rx (regexp
0840: 20 22 28 5b 30 2d 39 5d 2b 29 5c 5c 73 2b 28 5b "([0-9]+)\\s+([
0850: 30 2d 39 5d 2b 29 25 22 29 29 0a 09 20 28 66 72 0-9]+)%")).. (fr
0860: 65 65 73 70 63 20 20 20 20 23 66 29 29 0a 20 20 eespc #f)).
0870: 20 20 3b 3b 20 28 77 72 69 74 65 20 64 66 2d 72 ;; (write df-r
0880: 65 73 75 6c 74 73 29 0a 20 20 20 20 28 66 6f 72 esults). (for
0890: 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 28 6c -each (lambda (l
08a0: 29 0a 09 09 28 6c 65 74 20 28 28 6d 61 74 63 68 )...(let ((match
08b0: 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 68 20 (string-search
08c0: 73 70 61 63 65 2d 72 78 20 6c 29 29 29 0a 09 09 space-rx l)))...
08d0: 20 20 28 69 66 20 6d 61 74 63 68 20 0a 09 09 20 (if match ...
08e0: 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 77 76 (let ((newv
08f0: 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 al (string->numb
0900: 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 29 29 er (cadr match))
0910: 29 29 0a 09 09 09 28 69 66 20 28 6e 75 6d 62 65 ))....(if (numbe
0920: 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 09 20 20 r? newval)....
0930: 20 20 28 73 65 74 21 20 66 72 65 65 73 70 63 20 (set! freespc
0940: 6e 65 77 76 61 6c 29 29 29 29 29 29 0a 09 20 20 newval))))))..
0950: 20 20 20 20 28 63 61 72 20 64 66 2d 72 65 73 75 (car df-resu
0960: 6c 74 73 29 29 0a 20 20 20 20 66 72 65 65 73 70 lts)). freesp
0970: 63 29 29 0a 20 20 0a 28 64 65 66 69 6e 65 20 28 c)). .(define (
0980: 67 65 74 2d 63 70 75 2d 6c 6f 61 64 29 0a 20 20 get-cpu-load).
0990: 28 6c 65 74 2a 20 28 28 6c 6f 61 64 2d 72 65 73 (let* ((load-res
09a0: 20 28 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 (cmd-run->list
09b0: 22 75 70 74 69 6d 65 22 29 29 0a 09 20 28 6c 6f "uptime")).. (lo
09c0: 61 64 2d 72 78 20 20 28 72 65 67 65 78 70 20 22 ad-rx (regexp "
09d0: 6c 6f 61 64 20 61 76 65 72 61 67 65 3a 5c 5c 73 load average:\\s
09e0: 2b 28 5c 5c 64 2b 29 22 29 29 0a 09 20 28 63 70 +(\\d+)")).. (cp
09f0: 75 2d 6c 6f 61 64 20 23 66 29 29 0a 20 20 20 20 u-load #f)).
0a00: 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 (for-each (lambd
0a10: 61 20 28 6c 29 0a 09 09 28 6c 65 74 20 28 28 6d a (l)...(let ((m
0a20: 61 74 63 68 20 28 73 74 72 69 6e 67 2d 73 65 61 atch (string-sea
0a30: 72 63 68 20 6c 6f 61 64 2d 72 78 20 6c 29 29 29 rch load-rx l)))
0a40: 0a 09 09 20 20 28 69 66 20 6d 61 74 63 68 0a 09 ... (if match..
0a50: 09 20 20 20 20 20 20 28 6c 65 74 20 28 28 6e 65 . (let ((ne
0a60: 77 76 61 6c 20 28 73 74 72 69 6e 67 2d 3e 6e 75 wval (string->nu
0a70: 6d 62 65 72 20 28 63 61 64 72 20 6d 61 74 63 68 mber (cadr match
0a80: 29 29 29 29 0a 09 09 09 28 69 66 20 28 6e 75 6d ))))....(if (num
0a90: 62 65 72 3f 20 6e 65 77 76 61 6c 29 0a 09 09 09 ber? newval)....
0aa0: 20 20 20 20 28 73 65 74 21 20 63 70 75 2d 6c 6f (set! cpu-lo
0ab0: 61 64 20 6e 65 77 76 61 6c 29 29 29 29 29 29 0a ad newval)))))).
0ac0: 09 20 20 20 20 20 20 28 63 61 72 20 6c 6f 61 64 . (car load
0ad0: 2d 72 65 73 29 29 0a 20 20 20 20 63 70 75 2d 6c -res)). cpu-l
0ae0: 6f 61 64 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 oad))..(define (
0af0: 67 65 74 2d 75 6e 61 6d 65 20 2e 20 70 61 72 61 get-uname . para
0b00: 6d 73 29 0a 20 20 28 6c 65 74 2a 20 28 28 75 6e ms). (let* ((un
0b10: 61 6d 65 2d 72 65 73 20 28 63 6d 64 2d 72 75 6e ame-res (cmd-run
0b20: 2d 3e 6c 69 73 74 20 28 63 6f 6e 63 20 22 75 6e ->list (conc "un
0b30: 61 6d 65 20 22 20 28 69 66 20 28 6e 75 6c 6c 3f ame " (if (null?
0b40: 20 70 61 72 61 6d 73 29 20 22 2d 61 22 20 28 63 params) "-a" (c
0b50: 61 72 20 70 61 72 61 6d 73 29 29 29 29 29 0a 09 ar params)))))..
0b60: 20 28 75 6e 61 6d 65 20 23 66 29 29 0a 20 20 20 (uname #f)).
0b70: 20 28 69 66 20 28 6e 75 6c 6c 3f 20 28 63 61 72 (if (null? (car
0b80: 20 75 6e 61 6d 65 2d 72 65 73 29 29 0a 09 22 75 uname-res)).."u
0b90: 6e 6b 6e 6f 77 6e 22 0a 09 28 63 61 61 72 20 75 nknown"..(caar u
0ba0: 6e 61 6d 65 2d 72 65 73 29 29 29 29 0a 09 20 20 name-res))))..
0bb0: 20 20 20 20 0a 28 64 65 66 69 6e 65 20 28 73 61 .(define (sa
0bc0: 76 65 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 61 ve-environment-a
0bd0: 73 2d 66 69 6c 65 73 20 66 6e 61 6d 65 29 0a 20 s-files fname).
0be0: 20 28 6c 65 74 20 28 28 65 6e 76 76 61 72 73 20 (let ((envvars
0bf0: 28 67 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 (get-environment
0c00: 2d 76 61 72 69 61 62 6c 65 73 29 29 0a 20 20 20 -variables)).
0c10: 20 20 20 20 20 28 77 68 69 74 65 73 70 20 28 72 (whitesp (r
0c20: 65 67 65 78 70 20 22 5b 5e 61 2d 7a 41 2d 5a 30 egexp "[^a-zA-Z0
0c30: 2d 39 5f 5c 5c 2d 3a 3b 2c 2e 5c 5c 2f 25 5d 22 -9_\\-:;,.\\/%]"
0c40: 29 29 29 0a 20 20 20 20 20 28 77 69 74 68 2d 6f ))). (with-o
0c50: 75 74 70 75 74 2d 74 6f 2d 66 69 6c 65 20 28 63 utput-to-file (c
0c60: 6f 6e 63 20 66 6e 61 6d 65 20 22 2e 63 73 68 22 onc fname ".csh"
0c70: 29 0a 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 ). (lambda
0c80: 20 28 29 0a 20 20 20 20 20 20 20 20 20 20 28 66 (). (f
0c90: 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 20 or-each (lambda
0ca0: 28 6b 65 79 29 0a 20 20 20 20 20 20 20 20 20 20 (key).
0cb0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 74 (let
0cc0: 2a 20 28 28 76 61 6c 20 28 63 64 72 20 6b 65 79 * ((val (cdr key
0cd0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
0ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0cf0: 28 73 76 61 6c 20 28 69 66 20 28 73 74 72 69 6e (sval (if (strin
0d00: 67 2d 73 65 61 72 63 68 20 77 68 69 74 65 73 70 g-search whitesp
0d10: 20 76 61 6c 29 28 63 6f 6e 63 20 22 27 22 20 76 val)(conc "'" v
0d20: 61 6c 20 22 27 22 29 20 76 61 6c 29 29 29 0a 20 al "'") val))).
0d30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d40: 20 20 20 20 20 20 20 28 70 72 69 6e 74 20 22 73 (print "s
0d50: 65 74 65 6e 76 20 22 20 28 63 61 72 20 6b 65 79 etenv " (car key
0d60: 29 20 22 20 22 20 73 76 61 6c 29 29 29 0a 20 20 ) " " sval))).
0d70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d80: 20 20 20 65 6e 76 76 61 72 73 29 29 29 0a 20 20 envvars))).
0d90: 20 20 20 28 77 69 74 68 2d 6f 75 74 70 75 74 2d (with-output-
0da0: 74 6f 2d 66 69 6c 65 20 28 63 6f 6e 63 20 66 6e to-file (conc fn
0db0: 61 6d 65 20 22 2e 73 68 22 29 0a 20 20 20 20 20 ame ".sh").
0dc0: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 (lambda ().
0dd0: 20 20 20 20 20 20 20 28 66 6f 72 2d 65 61 63 68 (for-each
0de0: 20 28 6c 61 6d 62 64 61 20 28 6b 65 79 29 0a 20 (lambda (key).
0df0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e00: 20 20 20 20 20 28 6c 65 74 2a 20 28 28 76 61 6c (let* ((val
0e10: 20 28 63 64 72 20 6b 65 79 29 29 0a 20 20 20 20 (cdr key)).
0e20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e30: 20 20 20 20 20 20 20 20 20 28 73 76 61 6c 20 28 (sval (
0e40: 69 66 20 28 73 74 72 69 6e 67 2d 73 65 61 72 63 if (string-searc
0e50: 68 20 77 68 69 74 65 73 70 20 76 61 6c 29 28 63 h whitesp val)(c
0e60: 6f 6e 63 20 22 27 22 20 76 61 6c 20 22 27 22 29 onc "'" val "'")
0e70: 20 76 61 6c 29 29 29 0a 20 20 20 20 20 20 20 20 val))).
0e80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e90: 20 28 70 72 69 6e 74 20 22 65 78 70 6f 72 74 20 (print "export
0ea0: 22 20 28 63 61 72 20 6b 65 79 29 20 22 3d 22 20 " (car key) "="
0eb0: 73 76 61 6c 29 29 29 0a 20 20 20 20 20 20 20 20 sval))).
0ec0: 20 20 20 20 20 20 20 20 20 20 20 20 65 6e 76 76 envv
0ed0: 61 72 73 29 29 29 29 29 0a 0a 3b 3b 20 73 65 74 ars)))))..;; set
0ee0: 20 73 6f 6d 65 20 65 6e 76 20 76 61 72 73 20 66 some env vars f
0ef0: 72 6f 6d 20 61 6e 20 61 6c 69 73 74 2c 20 72 65 rom an alist, re
0f00: 74 75 72 6e 20 61 6e 20 61 6c 69 73 74 20 77 69 turn an alist wi
0f10: 74 68 20 6f 72 69 67 69 6e 61 6c 20 76 61 6c 75 th original valu
0f20: 65 73 0a 3b 3b 20 28 28 22 56 41 52 22 20 22 76 es.;; (("VAR" "v
0f30: 61 6c 75 65 22 29 20 2e 2e 2e 29 0a 28 64 65 66 alue") ...).(def
0f40: 69 6e 65 20 28 61 6c 69 73 74 2d 3e 65 6e 76 2d ine (alist->env-
0f50: 76 61 72 73 20 6c 73 74 29 0a 20 20 28 69 66 20 vars lst). (if
0f60: 28 6c 69 73 74 3f 20 6c 73 74 29 0a 20 20 20 20 (list? lst).
0f70: 20 20 28 6c 65 74 20 28 28 72 65 73 20 27 28 29 (let ((res '()
0f80: 29 29 0a 09 28 66 6f 72 2d 65 61 63 68 20 28 6c ))..(for-each (l
0f90: 61 6d 62 64 61 20 28 70 29 0a 09 09 20 20 20 20 ambda (p)...
0fa0: 28 6c 65 74 2a 20 28 28 76 61 72 20 28 63 61 72 (let* ((var (car
0fb0: 20 20 70 29 29 0a 09 09 09 20 20 20 28 76 61 6c p)).... (val
0fc0: 20 28 63 61 64 72 20 70 29 29 0a 09 09 09 20 20 (cadr p))....
0fd0: 20 28 70 72 76 20 28 67 65 74 2d 65 6e 76 69 72 (prv (get-envir
0fe0: 6f 6e 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 onment-variable
0ff0: 76 61 72 29 29 29 0a 09 09 20 20 20 20 20 20 28 var)))... (
1000: 73 65 74 21 20 72 65 73 20 28 63 6f 6e 73 20 28 set! res (cons (
1010: 6c 69 73 74 20 76 61 72 20 70 72 76 29 20 72 65 list var prv) re
1020: 73 29 29 0a 09 09 20 20 20 20 20 20 28 69 66 20 s))... (if
1030: 76 61 6c 20 0a 09 09 09 20 20 28 73 65 74 65 6e val .... (seten
1040: 76 20 76 61 72 20 28 2d 3e 73 74 72 69 6e 67 20 v var (->string
1050: 76 61 6c 29 29 0a 09 09 09 20 20 28 75 6e 73 65 val)).... (unse
1060: 74 65 6e 76 20 76 61 72 29 29 29 29 0a 09 09 20 tenv var))))...
1070: 20 6c 73 74 29 0a 09 72 65 73 29 0a 20 20 20 20 lst)..res).
1080: 20 20 27 28 29 29 29 0a 09 09 20 20 0a 3b 3b 3d '()))... .;;=
1090: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
10d0: 3d 3d 3d 3d 3d 0a 3b 3b 20 74 69 6d 65 20 61 6e =====.;; time an
10e0: 64 20 64 61 74 65 20 6e 69 63 65 20 74 6f 20 68 d date nice to h
10f0: 61 76 65 20 73 74 75 66 66 0a 3b 3b 3d 3d 3d 3d ave stuff.;;====
1100: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1110: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1120: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1130: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1140: 3d 3d 0a 0a 28 64 65 66 69 6e 65 20 28 73 65 63 ==..(define (sec
1150: 6f 6e 64 73 2d 3e 68 72 2d 6d 69 6e 2d 73 65 63 onds->hr-min-sec
1160: 20 73 65 63 73 29 0a 20 20 28 6c 65 74 2a 20 28 secs). (let* (
1170: 28 68 72 73 20 28 71 75 6f 74 69 65 6e 74 20 73 (hrs (quotient s
1180: 65 63 73 20 33 36 30 30 29 29 0a 09 20 28 6d 69 ecs 3600)).. (mi
1190: 6e 20 28 71 75 6f 74 69 65 6e 74 20 28 2d 20 73 n (quotient (- s
11a0: 65 63 73 20 28 2a 20 68 72 73 20 33 36 30 30 29 ecs (* hrs 3600)
11b0: 29 20 36 30 29 29 0a 09 20 28 73 65 63 20 28 2d ) 60)).. (sec (-
11c0: 20 73 65 63 73 20 28 2a 20 68 72 73 20 33 36 30 secs (* hrs 360
11d0: 30 29 28 2a 20 6d 69 6e 20 36 30 29 29 29 29 0a 0)(* min 60)))).
11e0: 20 20 20 20 28 63 6f 6e 63 20 28 69 66 20 28 3e (conc (if (>
11f0: 20 68 72 73 20 30 29 28 63 6f 6e 63 20 68 72 73 hrs 0)(conc hrs
1200: 20 22 68 72 20 22 29 20 22 22 29 0a 09 20 20 28 "hr ") "").. (
1210: 69 66 20 28 3e 20 6d 69 6e 20 30 29 28 63 6f 6e if (> min 0)(con
1220: 63 20 6d 69 6e 20 22 6d 20 22 29 20 20 22 22 29 c min "m ") "")
1230: 0a 09 20 20 73 65 63 20 22 73 22 29 29 29 0a 0a .. sec "s")))..
1240: 28 64 65 66 69 6e 65 20 28 73 65 63 6f 6e 64 73 (define (seconds
1250: 2d 3e 74 69 6d 65 2d 73 74 72 69 6e 67 20 73 65 ->time-string se
1260: 63 29 0a 20 20 28 74 69 6d 65 2d 3e 73 74 72 69 c). (time->stri
1270: 6e 67 20 0a 20 20 20 28 73 65 63 6f 6e 64 73 2d ng . (seconds-
1280: 3e 6c 6f 63 61 6c 2d 74 69 6d 65 20 73 65 63 29 >local-time sec)
1290: 20 22 25 48 3a 25 4d 3a 25 53 22 29 29 0a 0a 3b "%H:%M:%S"))..;
12a0: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
12b0: 3d 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 0a 3b 3b 20 43 6f 6c 6f 72 =======.;; Color
12f0: 73 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d s.;;============
1300: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1310: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1320: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 20 20 20 20 20 ==========.
1340: 20 0a 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f .(define (commo
1350: 6e 3a 6e 61 6d 65 2d 3e 69 75 70 2d 63 6f 6c 6f n:name->iup-colo
1360: 72 20 6e 61 6d 65 29 0a 20 20 28 63 61 73 65 20 r name). (case
1370: 28 73 74 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 (string->symbol
1380: 28 73 74 72 69 6e 67 2d 64 6f 77 6e 63 61 73 65 (string-downcase
1390: 20 6e 61 6d 65 29 29 0a 20 20 20 20 28 28 72 65 name)). ((re
13a0: 64 29 20 20 20 20 22 32 32 33 20 33 33 20 34 39 d) "223 33 49
13b0: 22 29 0a 20 20 20 20 28 28 67 72 65 79 29 20 20 "). ((grey)
13c0: 20 22 31 39 32 20 31 39 32 20 31 39 32 22 29 0a "192 192 192").
13d0: 20 20 20 20 28 28 6f 72 61 6e 67 65 29 20 22 32 ((orange) "2
13e0: 35 35 20 31 37 32 20 31 33 22 29 0a 20 20 20 20 55 172 13").
13f0: 28 28 70 75 72 70 6c 65 29 20 22 54 68 69 73 20 ((purple) "This
1400: 69 73 20 75 6e 66 69 6e 69 73 68 65 64 20 2e 2e is unfinished ..
1410: 2e 22 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 .")))..(define (
1420: 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f 6c 6f 72 common:get-color
1430: 2d 66 6f 72 2d 73 74 61 74 65 2d 73 74 61 74 75 -for-state-statu
1440: 73 20 73 74 61 74 65 20 73 74 61 74 75 73 20 74 s state status t
1450: 79 70 65 29 0a 20 20 28 63 61 73 65 20 28 73 74 ype). (case (st
1460: 72 69 6e 67 2d 3e 73 79 6d 62 6f 6c 20 73 74 61 ring->symbol sta
1470: 74 65 29 0a 20 20 20 20 28 28 43 4f 4d 50 4c 45 te). ((COMPLE
1480: 54 45 44 29 0a 20 20 20 20 20 28 69 66 20 28 65 TED). (if (e
1490: 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 50 41 qual? status "PA
14a0: 53 53 22 29 0a 09 20 22 37 30 20 32 34 39 20 37 SS").. "70 249 7
14b0: 33 22 0a 09 20 28 69 66 20 28 6f 72 20 28 65 71 3".. (if (or (eq
14c0: 75 61 6c 3f 20 73 74 61 74 75 73 20 22 57 41 52 ual? status "WAR
14d0: 4e 22 29 0a 09 09 20 28 65 71 75 61 6c 3f 20 73 N")... (equal? s
14e0: 74 61 74 75 73 20 22 57 41 49 56 45 44 22 29 29 tatus "WAIVED"))
14f0: 0a 09 20 20 20 20 20 22 32 35 35 20 31 37 32 20 .. "255 172
1500: 31 33 22 0a 09 20 20 20 20 20 22 32 32 33 20 33 13".. "223 3
1510: 33 20 34 39 22 29 29 29 20 3b 3b 20 67 72 65 65 3 49"))) ;; gree
1520: 6e 69 73 68 20 6f 72 61 6e 67 65 69 73 68 20 72 nish orangeish r
1530: 65 64 69 73 68 0a 20 20 20 20 28 28 4c 41 55 4e edish. ((LAUN
1540: 43 48 45 44 29 20 20 20 20 20 20 20 20 20 22 31 CHED) "1
1550: 30 31 20 31 32 33 20 31 34 32 22 29 0a 20 20 20 01 123 142").
1560: 20 28 28 43 48 45 43 4b 29 20 20 20 20 20 20 20 ((CHECK)
1570: 20 20 20 20 20 22 32 35 35 20 31 30 30 20 35 30 "255 100 50
1580: 22 29 0a 20 20 20 20 28 28 52 45 4d 4f 54 45 48 "). ((REMOTEH
1590: 4f 53 54 53 54 41 52 54 29 20 20 22 35 30 20 31 OSTSTART) "50 1
15a0: 33 30 20 31 39 35 22 29 0a 20 20 20 20 28 28 52 30 195"). ((R
15b0: 55 4e 4e 49 4e 47 29 20 20 20 20 20 20 20 20 20 UNNING)
15c0: 20 22 39 20 31 33 31 20 32 33 32 22 29 0a 20 20 "9 131 232").
15d0: 20 20 28 28 4b 49 4c 4c 52 45 51 29 20 20 20 20 ((KILLREQ)
15e0: 20 20 20 20 20 20 22 33 39 20 38 32 20 32 30 36 "39 82 206
15f0: 22 29 0a 20 20 20 20 28 28 4b 49 4c 4c 45 44 29 "). ((KILLED)
1600: 20 20 20 20 20 20 20 20 20 20 20 22 32 33 34 20 "234
1610: 31 30 31 20 31 37 22 29 0a 20 20 20 20 28 28 4e 101 17"). ((N
1620: 4f 54 5f 53 54 41 52 54 45 44 29 20 20 20 20 20 OT_STARTED)
1630: 20 22 32 34 30 20 32 34 30 20 32 34 30 22 29 0a "240 240 240").
1640: 20 20 20 20 28 65 6c 73 65 20 20 20 20 20 20 20 (else
1650: 20 20 20 20 20 20 20 20 22 31 39 32 20 31 39 32 "192 192
1660: 20 31 39 32 22 29 29 29 0a 0a 28 64 65 66 69 6e 192")))..(defin
1670: 65 20 28 63 6f 6d 6d 6f 6e 3a 67 65 74 2d 63 6f e (common:get-co
1680: 6c 6f 72 2d 66 72 6f 6d 2d 73 74 61 74 75 73 20 lor-from-status
1690: 73 74 61 74 75 73 29 0a 20 20 28 63 6f 6e 64 0a status). (cond.
16a0: 20 20 20 28 28 65 71 75 61 6c 3f 20 73 74 61 74 ((equal? stat
16b0: 75 73 20 22 50 41 53 53 22 29 20 20 20 20 22 67 us "PASS") "g
16c0: 72 65 65 6e 22 29 0a 20 20 20 28 28 65 71 75 61 reen"). ((equa
16d0: 6c 3f 20 73 74 61 74 75 73 20 22 46 41 49 4c 22 l? status "FAIL"
16e0: 29 20 20 20 20 22 72 65 64 22 29 0a 20 20 20 28 ) "red"). (
16f0: 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
1700: 57 41 52 4e 22 29 20 20 20 20 22 6f 72 61 6e 67 WARN") "orang
1710: 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
1720: 73 74 61 74 75 73 20 22 4b 49 4c 4c 45 44 22 29 status "KILLED")
1730: 20 20 22 6f 72 61 6e 67 65 22 29 0a 20 20 20 28 "orange"). (
1740: 28 65 71 75 61 6c 3f 20 73 74 61 74 75 73 20 22 (equal? status "
1750: 4b 49 4c 4c 52 45 51 22 29 20 22 70 75 72 70 6c KILLREQ") "purpl
1760: 65 22 29 0a 20 20 20 28 28 65 71 75 61 6c 3f 20 e"). ((equal?
1770: 73 74 61 74 75 73 20 22 52 55 4e 4e 49 4e 47 22 status "RUNNING"
1780: 29 20 22 62 6c 75 65 22 29 0a 20 20 20 28 65 6c ) "blue"). (el
1790: 73 65 20 22 62 6c 61 63 6b 22 29 29 29 0a se "black"))).