Artifact
65263dfd68b3cb586e0349a21ef4388b095642cd:
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 31 39 2c 20 4d 61 74 74 right 2019, Matt
0060: 68 65 77 20 57 65 6c 6c 61 6e 64 2e 0a 3b 3b 20 hew Welland..;;
0070: 0a 3b 3b 20 54 68 69 73 20 66 69 6c 65 20 69 73 .;; This file is
0080: 20 70 61 72 74 20 6f 66 20 4d 65 67 61 74 65 73 part of Megates
0090: 74 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 t..;; .;; Me
00a0: 67 61 74 65 73 74 20 69 73 20 66 72 65 65 20 73 gatest is free s
00b0: 6f 66 74 77 61 72 65 3a 20 79 6f 75 20 63 61 6e oftware: you can
00c0: 20 72 65 64 69 73 74 72 69 62 75 74 65 20 69 74 redistribute it
00d0: 20 61 6e 64 2f 6f 72 20 6d 6f 64 69 66 79 0a 3b and/or modify.;
00e0: 3b 20 20 20 20 20 69 74 20 75 6e 64 65 72 20 74 ; it under t
00f0: 68 65 20 74 65 72 6d 73 20 6f 66 20 74 68 65 20 he terms of the
0100: 47 4e 55 20 47 65 6e 65 72 61 6c 20 50 75 62 6c GNU General Publ
0110: 69 63 20 4c 69 63 65 6e 73 65 20 61 73 20 70 75 ic License as pu
0120: 62 6c 69 73 68 65 64 20 62 79 0a 3b 3b 20 20 20 blished by.;;
0130: 20 20 74 68 65 20 46 72 65 65 20 53 6f 66 74 77 the Free Softw
0140: 61 72 65 20 46 6f 75 6e 64 61 74 69 6f 6e 2c 20 are Foundation,
0150: 65 69 74 68 65 72 20 76 65 72 73 69 6f 6e 20 33 either version 3
0160: 20 6f 66 20 74 68 65 20 4c 69 63 65 6e 73 65 2c of the License,
0170: 20 6f 72 0a 3b 3b 20 20 20 20 20 28 61 74 20 79 or.;; (at y
0180: 6f 75 72 20 6f 70 74 69 6f 6e 29 20 61 6e 79 20 our option) any
0190: 6c 61 74 65 72 20 76 65 72 73 69 6f 6e 2e 0a 3b later version..;
01a0: 3b 20 0a 3b 3b 20 20 20 20 20 4d 65 67 61 74 65 ; .;; Megate
01b0: 73 74 20 69 73 20 64 69 73 74 72 69 62 75 74 65 st is distribute
01c0: 64 20 69 6e 20 74 68 65 20 68 6f 70 65 20 74 68 d in the hope th
01d0: 61 74 20 69 74 20 77 69 6c 6c 20 62 65 20 75 73 at it will be us
01e0: 65 66 75 6c 2c 0a 3b 3b 20 20 20 20 20 62 75 74 eful,.;; but
01f0: 20 57 49 54 48 4f 55 54 20 41 4e 59 20 57 41 52 WITHOUT ANY WAR
0200: 52 41 4e 54 59 3b 20 77 69 74 68 6f 75 74 20 65 RANTY; without e
0210: 76 65 6e 20 74 68 65 20 69 6d 70 6c 69 65 64 20 ven the implied
0220: 77 61 72 72 61 6e 74 79 20 6f 66 0a 3b 3b 20 20 warranty of.;;
0230: 20 20 20 4d 45 52 43 48 41 4e 54 41 42 49 4c 49 MERCHANTABILI
0240: 54 59 20 6f 72 20 46 49 54 4e 45 53 53 20 46 4f TY or FITNESS FO
0250: 52 20 41 20 50 41 52 54 49 43 55 4c 41 52 20 50 R A PARTICULAR P
0260: 55 52 50 4f 53 45 2e 20 20 53 65 65 20 74 68 65 URPOSE. See the
0270: 0a 3b 3b 20 20 20 20 20 47 4e 55 20 47 65 6e 65 .;; GNU Gene
0280: 72 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e ral Public Licen
0290: 73 65 20 66 6f 72 20 6d 6f 72 65 20 64 65 74 61 se for more deta
02a0: 69 6c 73 2e 0a 3b 3b 20 0a 3b 3b 20 20 20 20 20 ils..;; .;;
02b0: 59 6f 75 20 73 68 6f 75 6c 64 20 68 61 76 65 20 You should have
02c0: 72 65 63 65 69 76 65 64 20 61 20 63 6f 70 79 20 received a copy
02d0: 6f 66 20 74 68 65 20 47 4e 55 20 47 65 6e 65 72 of the GNU Gener
02e0: 61 6c 20 50 75 62 6c 69 63 20 4c 69 63 65 6e 73 al Public Licens
02f0: 65 0a 3b 3b 20 20 20 20 20 61 6c 6f 6e 67 20 77 e.;; along w
0300: 69 74 68 20 4d 65 67 61 74 65 73 74 2e 20 20 49 ith Megatest. I
0310: 66 20 6e 6f 74 2c 20 73 65 65 20 3c 68 74 74 70 f not, see <http
0320: 3a 2f 2f 77 77 77 2e 67 6e 75 2e 6f 72 67 2f 6c ://www.gnu.org/l
0330: 69 63 65 6e 73 65 73 2f 3e 2e 0a 0a 3b 3b 3d 3d icenses/>...;;==
0340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0370: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0380: 3d 3d 3d 3d 0a 0a 28 64 65 63 6c 61 72 65 20 28 ====..(declare (
0390: 75 6e 69 74 20 70 72 6f 63 65 73 73 6d 6f 64 29 unit processmod)
03a0: 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 ).(declare (uses
03b0: 20 63 6f 6d 6d 6f 6e 6d 6f 64 29 29 0a 0a 28 6d commonmod))..(m
03c0: 6f 64 75 6c 65 20 70 72 6f 63 65 73 73 6d 6f 64 odule processmod
03d0: 0a 09 2a 0a 09 0a 28 69 6d 70 6f 72 74 20 73 63 ..*...(import sc
03e0: 68 65 6d 65 20 63 68 69 63 6b 65 6e 20 64 61 74 heme chicken dat
03f0: 61 2d 73 74 72 75 63 74 75 72 65 73 20 65 78 74 a-structures ext
0400: 72 61 73 29 0a 28 69 6d 70 6f 72 74 20 28 70 72 ras).(import (pr
0410: 65 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c efix sqlite3 sql
0420: 69 74 65 33 3a 29 20 70 6f 73 69 78 20 74 79 70 ite3:) posix typ
0430: 65 64 2d 72 65 63 6f 72 64 73 20 73 72 66 69 2d ed-records srfi-
0440: 31 38 20 73 72 66 69 2d 36 39 0a 09 66 6f 72 6d 18 srfi-69..form
0450: 61 74 20 70 6f 72 74 73 20 73 72 66 69 2d 31 20 at ports srfi-1
0460: 6d 61 74 63 68 61 62 6c 65 20 72 65 67 65 78 20 matchable regex
0470: 64 69 72 65 63 74 6f 72 79 2d 75 74 69 6c 73 29 directory-utils)
0480: 0a 28 69 6d 70 6f 72 74 20 63 6f 6d 6d 6f 6e 6d .(import commonm
0490: 6f 64 29 0a 3b 3b 20 28 75 73 65 20 28 70 72 65 od).;; (use (pre
04a0: 66 69 78 20 75 6c 65 78 20 75 6c 65 78 3a 29 29 fix ulex ulex:))
04b0: 0a 0a 28 69 6e 63 6c 75 64 65 20 22 63 6f 6d 6d ..(include "comm
04c0: 6f 6e 5f 72 65 63 6f 72 64 73 2e 73 63 6d 22 29 on_records.scm")
04d0: 0a 0a 0a 0a 3b 3b 20 61 63 63 65 70 74 20 61 6e ....;; accept an
04e0: 20 61 6c 69 73 74 20 6f 72 20 68 61 73 68 20 74 alist or hash t
04f0: 61 62 6c 65 20 63 6f 6e 74 61 69 6e 69 6e 67 20 able containing
0500: 65 6e 76 76 61 72 2f 65 6e 76 20 76 61 6c 75 65 envvar/env value
0510: 20 70 61 69 72 73 20 28 76 61 6c 75 65 20 6f 66 pairs (value of
0520: 20 23 66 20 63 61 75 73 65 73 20 75 6e 73 65 74 #f causes unset
0530: 29 20 0a 3b 3b 20 20 20 65 78 65 63 75 74 65 20 ) .;; execute
0540: 74 68 75 6e 6b 20 69 6e 20 63 6f 6e 74 65 78 74 thunk in context
0550: 20 6f 66 20 65 6e 76 69 72 6f 6e 6d 65 6e 74 20 of environment
0560: 6d 6f 64 69 66 69 65 64 20 61 73 20 70 65 72 20 modified as per
0570: 74 68 69 73 20 6c 69 73 74 0a 3b 3b 20 20 20 72 this list.;; r
0580: 65 73 74 6f 72 65 20 65 6e 76 20 74 6f 20 70 72 estore env to pr
0590: 69 6f 72 20 73 74 61 74 65 20 74 68 65 6e 20 72 ior state then r
05a0: 65 74 75 72 6e 20 76 61 6c 75 65 20 6f 66 20 65 eturn value of e
05b0: 76 61 6c 27 64 20 74 68 75 6e 6b 2e 0a 3b 3b 20 val'd thunk..;;
05c0: 20 20 2a 2a 20 74 68 69 73 20 69 73 20 6e 6f 74 ** this is not
05d0: 20 74 68 72 65 61 64 20 73 61 66 65 20 2a 2a 0a thread safe **.
05e0: 28 64 65 66 69 6e 65 20 28 63 6f 6d 6d 6f 6e 3a (define (common:
05f0: 77 69 74 68 2d 65 6e 76 2d 76 61 72 73 20 64 65 with-env-vars de
0600: 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 74 2d 6f 72 lta-env-alist-or
0610: 2d 68 61 73 68 2d 74 61 62 6c 65 20 74 68 75 6e -hash-table thun
0620: 6b 29 0a 20 20 28 6c 65 74 2a 20 28 28 64 65 6c k). (let* ((del
0630: 74 61 2d 65 6e 76 2d 61 6c 69 73 74 20 28 69 66 ta-env-alist (if
0640: 20 28 68 61 73 68 2d 74 61 62 6c 65 3f 20 64 65 (hash-table? de
0650: 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 74 2d 6f 72 lta-env-alist-or
0660: 2d 68 61 73 68 2d 74 61 62 6c 65 29 0a 20 20 20 -hash-table).
0670: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0680: 20 20 20 20 20 20 20 20 20 20 20 28 68 61 73 68 (hash
0690: 2d 74 61 62 6c 65 2d 3e 61 6c 69 73 74 20 64 65 -table->alist de
06a0: 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 74 2d 6f 72 lta-env-alist-or
06b0: 2d 68 61 73 68 2d 74 61 62 6c 65 29 0a 20 20 20 -hash-table).
06c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
06d0: 20 20 20 20 20 20 20 20 20 20 20 64 65 6c 74 61 delta
06e0: 2d 65 6e 76 2d 61 6c 69 73 74 2d 6f 72 2d 68 61 -env-alist-or-ha
06f0: 73 68 2d 74 61 62 6c 65 29 29 0a 20 20 20 20 20 sh-table)).
0700: 20 20 20 20 28 72 65 73 74 6f 72 65 2d 74 68 75 (restore-thu
0710: 6e 6b 73 0a 20 20 20 20 20 20 20 20 20 20 28 66 nks. (f
0720: 69 6c 74 65 72 0a 20 20 20 20 20 20 20 20 20 20 ilter.
0730: 20 69 64 65 6e 74 69 74 79 0a 20 20 20 20 20 20 identity.
0740: 20 20 20 20 20 28 6d 61 70 20 28 6c 61 6d 62 64 (map (lambd
0750: 61 20 28 65 6e 76 2d 70 61 69 72 29 0a 20 20 20 a (env-pair).
0760: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0770: 6c 65 74 2a 20 28 28 65 6e 76 2d 76 61 72 20 20 let* ((env-var
0780: 20 20 20 28 63 61 72 20 65 6e 76 2d 70 61 69 72 (car env-pair
0790: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
07a0: 20 20 20 20 20 20 20 20 20 20 20 20 28 6e 65 77 (new
07b0: 2d 76 61 6c 20 20 20 20 20 28 6c 65 74 20 28 28 -val (let ((
07c0: 74 6d 70 20 28 63 64 72 20 65 6e 76 2d 70 61 69 tmp (cdr env-pai
07d0: 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 r))).
07e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
07f0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 (if
0800: 20 28 6c 69 73 74 3f 20 74 6d 70 29 20 28 63 61 (list? tmp) (ca
0810: 72 20 74 6d 70 29 20 74 6d 70 29 29 29 0a 20 20 r tmp) tmp))).
0820: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0830: 20 20 20 20 20 20 20 28 63 75 72 72 65 6e 74 2d (current-
0840: 76 61 6c 20 28 67 65 74 2d 65 6e 76 69 72 6f 6e val (get-environ
0850: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 20 65 6e ment-variable en
0860: 76 2d 76 61 72 29 29 0a 20 20 20 20 20 20 20 20 v-var)).
0870: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0880: 20 28 72 65 73 74 6f 72 65 2d 74 68 75 6e 6b 0a (restore-thunk.
0890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
08a0: 20 20 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a (cond.
08b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
08c0: 20 20 20 20 20 20 20 20 20 20 20 28 28 6e 6f 74 ((not
08d0: 20 63 75 72 72 65 6e 74 2d 76 61 6c 29 20 28 6c current-val) (l
08e0: 61 6d 62 64 61 20 28 29 20 28 75 6e 73 65 74 65 ambda () (unsete
08f0: 6e 76 20 65 6e 76 2d 76 61 72 29 29 29 0a 20 20 nv env-var))).
0900: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0910: 20 20 20 20 20 20 20 20 20 28 28 6e 6f 74 20 28 ((not (
0920: 73 74 72 69 6e 67 3f 20 6e 65 77 2d 76 61 6c 29 string? new-val)
0930: 29 20 23 66 29 0a 20 20 20 20 20 20 20 20 20 20 ) #f).
0940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0950: 20 28 28 65 71 3f 20 63 75 72 72 65 6e 74 2d 76 ((eq? current-v
0960: 61 6c 20 6e 65 77 2d 76 61 6c 29 20 23 66 29 0a al new-val) #f).
0970: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0980: 20 20 20 20 20 20 20 20 20 20 20 28 65 6c 73 65 (else
0990: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
09a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c (l
09b0: 61 6d 62 64 61 20 28 29 20 28 73 65 74 65 6e 76 ambda () (setenv
09c0: 20 65 6e 76 2d 76 61 72 20 63 75 72 72 65 6e 74 env-var current
09d0: 2d 76 61 6c 29 29 29 29 29 29 0a 20 20 20 20 20 -val)))))).
09e0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 3b ;
09f0: 3b 28 77 68 65 6e 20 28 6e 6f 74 20 28 73 74 72 ;(when (not (str
0a00: 69 6e 67 3f 20 6e 65 77 2d 76 61 6c 29 29 0a 20 ing? new-val)).
0a10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0a20: 20 20 20 3b 3b 20 20 20 20 28 64 65 62 75 67 3a ;; (debug:
0a30: 70 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 print 0 *default
0a40: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 20 50 52 4f -log-port* " PRO
0a50: 42 4c 45 4d 3a 20 6e 6f 74 20 61 20 73 74 72 69 BLEM: not a stri
0a60: 6e 67 3a 20 22 6e 65 77 2d 76 61 6c 22 5c 6e 20 ng: "new-val"\n
0a70: 66 72 6f 6d 20 65 6e 76 2d 61 6c 69 73 74 3a 5c from env-alist:\
0a80: 6e 22 64 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 n"delta-env-alis
0a90: 74 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 t).
0aa0: 20 20 20 20 20 20 20 3b 3b 20 20 20 20 28 70 70 ;; (pp
0ab0: 20 64 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 74 delta-env-alist
0ac0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0ad0: 20 20 20 20 20 20 3b 3b 20 20 20 20 28 65 78 69 ;; (exi
0ae0: 74 20 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 t 1)).
0af0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 .
0b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b10: 20 20 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 .
0b20: 20 20 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 (cond.
0b30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b40: 20 20 20 28 28 6e 6f 74 20 6e 65 77 2d 76 61 6c ((not new-val
0b50: 29 20 20 3b 3b 20 6d 6f 64 69 66 79 20 65 6e 76 ) ;; modify env
0b60: 20 68 65 72 65 0a 20 20 20 20 20 20 20 20 20 20 here.
0b70: 20 20 20 20 20 20 20 20 20 20 20 20 28 75 6e 73 (uns
0b80: 65 74 65 6e 76 20 65 6e 76 2d 76 61 72 29 29 0a etenv env-var)).
0b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ba0: 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 6e ((string? n
0bb0: 65 77 2d 76 61 6c 29 0a 20 20 20 20 20 20 20 20 ew-val).
0bc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 73 (s
0bd0: 65 74 65 6e 76 20 65 6e 76 2d 76 61 72 20 6e 65 etenv env-var ne
0be0: 77 2d 76 61 6c 29 29 29 0a 20 20 20 20 20 20 20 w-val))).
0bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 res
0c00: 74 6f 72 65 2d 74 68 75 6e 6b 29 29 0a 20 20 20 tore-thunk)).
0c10: 20 20 20 20 20 20 20 20 20 20 20 20 20 64 65 6c del
0c20: 74 61 2d 65 6e 76 2d 61 6c 69 73 74 29 29 29 29 ta-env-alist))))
0c30: 0a 20 20 20 20 28 6c 65 74 20 28 28 72 76 20 28 . (let ((rv (
0c40: 74 68 75 6e 6b 29 29 29 0a 20 20 20 20 20 20 28 thunk))). (
0c50: 66 6f 72 2d 65 61 63 68 20 28 6c 61 6d 62 64 61 for-each (lambda
0c60: 20 28 78 29 20 28 78 29 29 20 72 65 73 74 6f 72 (x) (x)) restor
0c70: 65 2d 74 68 75 6e 6b 73 29 20 3b 3b 20 72 65 73 e-thunks) ;; res
0c80: 74 6f 72 65 20 65 6e 76 20 74 6f 20 6f 72 69 67 tore env to orig
0c90: 69 6e 61 6c 20 73 74 61 74 65 0a 20 20 20 20 20 inal state.
0ca0: 20 72 76 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 rv)))..(define
0cb0: 28 70 72 6f 63 65 73 73 3a 63 6f 6e 73 65 72 76 (process:conserv
0cc0: 61 74 69 76 65 2d 72 65 61 64 20 70 6f 72 74 29 ative-read port)
0cd0: 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 72 . (let loop ((r
0ce0: 65 73 20 22 22 29 29 0a 20 20 20 20 28 69 66 20 es "")). (if
0cf0: 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (not (eof-object
0d00: 3f 20 28 70 65 65 6b 2d 63 68 61 72 20 70 6f 72 ? (peek-char por
0d10: 74 29 29 29 0a 09 28 6c 6f 6f 70 20 28 63 6f 6e t)))..(loop (con
0d20: 63 20 72 65 73 20 28 72 65 61 64 2d 63 68 61 72 c res (read-char
0d30: 20 70 6f 72 74 29 29 29 0a 09 72 65 73 29 29 29 port)))..res)))
0d40: 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 ..(define (proce
0d50: 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 68 2d ss:cmd-run-with-
0d60: 73 74 64 65 72 72 2d 3e 6c 69 73 74 20 63 6d 64 stderr->list cmd
0d70: 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 . params). ;;
0d80: 28 70 72 69 6e 74 20 22 43 61 6c 6c 65 64 20 77 (print "Called w
0d90: 69 74 68 20 63 6d 64 3d 22 20 63 6d 64 20 22 2c ith cmd=" cmd ",
0da0: 20 70 72 6f 63 3d 22 20 70 72 6f 63 20 22 2c 20 proc=" proc ",
0db0: 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 params=" params)
0dc0: 0a 3b 3b 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 .;; (handle-exc
0dd0: 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 65 78 6e eptions.;; exn
0de0: 0a 3b 3b 20 20 20 28 62 65 67 69 6e 0a 3b 3b 20 .;; (begin.;;
0df0: 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 52 4f (print "ERRO
0e00: 52 3a 20 20 46 61 69 6c 65 64 20 74 6f 20 72 75 R: Failed to ru
0e10: 6e 20 63 6f 6d 6d 61 6e 64 3a 20 22 20 63 6d 64 n command: " cmd
0e20: 20 22 20 22 20 28 73 74 72 69 6e 67 2d 69 6e 74 " " (string-int
0e30: 65 72 73 70 65 72 73 65 20 70 61 72 61 6d 73 20 ersperse params
0e40: 22 20 22 29 29 0a 3b 3b 20 20 20 20 20 28 70 72 " ")).;; (pr
0e50: 69 6e 74 20 22 20 20 20 20 20 20 20 22 20 28 28 int " " ((
0e60: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
0e70: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
0e80: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
0e90: 0a 3b 3b 20 20 20 20 20 23 66 29 0a 20 20 20 28 .;; #f). (
0ea0: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 66 68 let-values (((fh
0eb0: 20 66 68 6f 20 70 69 64 20 66 68 65 29 20 28 69 fho pid fhe) (i
0ec0: 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 f (null? params)
0ed0: 0a 09 09 09 09 20 20 20 20 20 20 28 70 72 6f 63 ..... (proc
0ee0: 65 73 73 2a 20 63 6d 64 29 0a 09 09 09 09 20 20 ess* cmd).....
0ef0: 20 20 20 20 28 70 72 6f 63 65 73 73 2a 20 63 6d (process* cm
0f00: 64 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 20 d params)))).
0f10: 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 (let loop ((
0f20: 63 75 72 72 20 28 72 65 61 64 2d 6c 69 6e 65 20 curr (read-line
0f30: 66 68 29 29 0a 09 09 20 20 28 72 65 73 75 6c 74 fh))... (result
0f40: 20 20 27 28 29 29 29 0a 09 20 28 6c 65 74 20 28 '())).. (let (
0f50: 28 65 72 72 73 74 72 20 28 70 72 6f 63 65 73 73 (errstr (process
0f60: 3a 63 6f 6e 73 65 72 76 61 74 69 76 65 2d 72 65 :conservative-re
0f70: 61 64 20 66 68 65 29 29 29 0a 09 20 20 20 28 69 ad fhe))).. (i
0f80: 66 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 3d 3f f (not (string=?
0f90: 20 65 72 72 73 74 72 20 22 22 29 29 0a 09 20 20 errstr ""))..
0fa0: 20 20 20 20 20 28 73 65 74 21 20 72 65 73 75 6c (set! resul
0fb0: 74 20 28 61 70 70 65 6e 64 20 72 65 73 75 6c 74 t (append result
0fc0: 20 28 6c 69 73 74 20 65 72 72 73 74 72 29 29 29 (list errstr)))
0fd0: 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 6e )). (if (n
0fe0: 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 ot (eof-object?
0ff0: 63 75 72 72 29 29 0a 09 20 20 20 28 6c 6f 6f 70 curr)).. (loop
1000: 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 29 0a (read-line fh).
1010: 09 09 20 28 61 70 70 65 6e 64 20 72 65 73 75 6c .. (append resul
1020: 74 20 28 6c 69 73 74 20 63 75 72 72 29 29 29 0a t (list curr))).
1030: 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 . (begin..
1040: 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f (close-input-po
1050: 72 74 20 66 68 29 0a 09 20 20 20 20 20 28 63 6c rt fh).. (cl
1060: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 ose-input-port f
1070: 68 65 29 0a 09 20 20 20 20 20 28 63 6c 6f 73 65 he).. (close
1080: 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 66 68 6f -output-port fho
1090: 29 0a 09 20 20 20 20 20 72 65 73 75 6c 74 29 29 ).. result))
10a0: 29 29 29 20 3b 3b 20 29 0a 0a 28 64 65 66 69 6e ))) ;; )..(defin
10b0: 65 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 e (process:cmd-r
10c0: 75 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 2d 61 un-with-stderr-a
10d0: 6e 64 2d 65 78 69 74 63 6f 64 65 2d 3e 6c 69 73 nd-exitcode->lis
10e0: 74 20 63 6d 64 20 2e 20 70 61 72 61 6d 73 29 0a t cmd . params).
10f0: 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 43 61 6c ;; (print "Cal
1100: 6c 65 64 20 77 69 74 68 20 63 6d 64 3d 22 20 63 led with cmd=" c
1110: 6d 64 20 22 2c 20 70 72 6f 63 3d 22 20 70 72 6f md ", proc=" pro
1120: 63 20 22 2c 20 70 61 72 61 6d 73 3d 22 20 70 61 c ", params=" pa
1130: 72 61 6d 73 29 0a 3b 3b 20 20 28 68 61 6e 64 6c rams).;; (handl
1140: 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 e-exceptions.;;
1150: 20 20 65 78 6e 0a 3b 3b 20 20 20 28 62 65 67 69 exn.;; (begi
1160: 6e 0a 3b 3b 20 20 20 20 20 28 70 72 69 6e 74 20 n.;; (print
1170: 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 "ERROR: Failed
1180: 74 6f 20 72 75 6e 20 63 6f 6d 6d 61 6e 64 3a 20 to run command:
1190: 22 20 63 6d 64 20 22 20 22 20 28 73 74 72 69 6e " cmd " " (strin
11a0: 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 61 g-intersperse pa
11b0: 72 61 6d 73 20 22 20 22 29 29 0a 3b 3b 20 20 20 rams " ")).;;
11c0: 20 20 28 70 72 69 6e 74 20 22 20 20 20 20 20 20 (print "
11d0: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
11e0: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
11f0: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
1200: 65 78 6e 29 29 0a 3b 3b 20 20 20 20 20 23 66 29 exn)).;; #f)
1210: 0a 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 . (let-values
1220: 28 28 28 66 68 20 66 68 6f 20 70 69 64 20 66 68 (((fh fho pid fh
1230: 65 29 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 e) (if (null? pa
1240: 72 61 6d 73 29 0a 09 09 09 09 20 20 20 20 20 20 rams).....
1250: 28 70 72 6f 63 65 73 73 2a 20 63 6d 64 29 0a 09 (process* cmd)..
1260: 09 09 09 20 20 20 20 20 20 28 70 72 6f 63 65 73 ... (proces
1270: 73 2a 20 63 6d 64 20 70 61 72 61 6d 73 29 29 29 s* cmd params)))
1280: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ). (let lo
1290: 6f 70 20 28 28 63 75 72 72 20 28 72 65 61 64 2d op ((curr (read-
12a0: 6c 69 6e 65 20 66 68 29 29 0a 09 09 20 20 28 72 line fh))... (r
12b0: 65 73 75 6c 74 20 20 27 28 29 29 29 0a 09 20 28 esult '())).. (
12c0: 6c 65 74 20 28 28 65 72 72 73 74 72 20 28 70 72 let ((errstr (pr
12d0: 6f 63 65 73 73 3a 63 6f 6e 73 65 72 76 61 74 69 ocess:conservati
12e0: 76 65 2d 72 65 61 64 20 66 68 65 29 29 29 0a 09 ve-read fhe)))..
12f0: 20 20 20 28 69 66 20 28 6e 6f 74 20 28 73 74 72 (if (not (str
1300: 69 6e 67 3d 3f 20 65 72 72 73 74 72 20 22 22 29 ing=? errstr "")
1310: 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 21 20 ).. (set!
1320: 72 65 73 75 6c 74 20 28 61 70 70 65 6e 64 20 72 result (append r
1330: 65 73 75 6c 74 20 28 6c 69 73 74 20 65 72 72 73 esult (list errs
1340: 74 72 29 29 29 29 29 0a 20 20 20 20 20 20 20 28 tr))))). (
1350: 69 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a if (not (eof-obj
1360: 65 63 74 3f 20 63 75 72 72 29 29 0a 09 20 20 20 ect? curr))..
1370: 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 (loop (read-line
1380: 20 66 68 29 0a 09 09 20 28 61 70 70 65 6e 64 20 fh)... (append
1390: 72 65 73 75 6c 74 20 28 6c 69 73 74 20 63 75 72 result (list cur
13a0: 72 29 29 29 0a 09 20 20 20 28 62 65 67 69 6e 0a r))).. (begin.
13b0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 65 (le
13c0: 74 2d 76 61 6c 75 65 73 20 28 28 28 61 6e 6f 74 t-values (((anot
13d0: 68 65 72 70 69 64 20 6e 6f 72 6d 61 6c 65 78 69 herpid normalexi
13e0: 74 3f 20 65 78 69 74 73 74 61 74 75 73 29 20 20 t? exitstatus)
13f0: 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 69 (process-wait pi
1400: 64 29 29 29 0a 09 20 20 20 20 20 28 63 6c 6f 73 d))).. (clos
1410: 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 68 29 e-input-port fh)
1420: 0a 09 20 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e .. (close-in
1430: 70 75 74 2d 70 6f 72 74 20 66 68 65 29 0a 09 20 put-port fhe)..
1440: 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 70 75 (close-outpu
1450: 74 2d 70 6f 72 74 20 66 68 6f 29 0a 20 20 20 20 t-port fho).
1460: 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 73 74 (list
1470: 20 72 65 73 75 6c 74 20 28 69 66 20 6e 6f 72 6d result (if norm
1480: 61 6c 65 78 69 74 3f 20 65 78 69 74 73 74 61 74 alexit? exitstat
1490: 75 73 20 2d 31 29 29 29 29 29 29 29 29 0a 0a 28 us -1))))))))..(
14a0: 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 73 3a define (process:
14b0: 63 6d 64 2d 72 75 6e 2d 70 72 6f 63 2d 65 61 63 cmd-run-proc-eac
14c0: 68 2d 6c 69 6e 65 20 63 6d 64 20 70 72 6f 63 20 h-line cmd proc
14d0: 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 . params). ;; (
14e0: 70 72 69 6e 74 20 22 43 61 6c 6c 65 64 20 77 69 print "Called wi
14f0: 74 68 20 63 6d 64 3d 22 20 63 6d 64 20 22 2c 20 th cmd=" cmd ",
1500: 70 72 6f 63 3d 22 20 70 72 6f 63 20 22 2c 20 70 proc=" proc ", p
1510: 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a arams=" params).
1520: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
1530: 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 ions. exn. (
1540: 62 65 67 69 6e 0a 20 20 20 20 20 28 70 72 69 6e begin. (prin
1550: 74 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 t "ERROR: Faile
1560: 64 20 74 6f 20 72 75 6e 20 63 6f 6d 6d 61 6e 64 d to run command
1570: 3a 20 22 20 63 6d 64 20 22 20 22 20 28 73 74 72 : " cmd " " (str
1580: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
1590: 70 61 72 61 6d 73 20 22 20 22 29 29 0a 20 20 20 params " ")).
15a0: 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 20 30 (debug:print 0
15b0: 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f *default-log-po
15c0: 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a 20 22 rt* " message: "
15d0: 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f ((condition-pro
15e0: 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 perty-accessor '
15f0: 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 exn 'message) ex
1600: 6e 29 29 0a 20 20 20 20 20 28 64 65 62 75 67 3a n)). (debug:
1610: 70 72 69 6e 74 20 35 20 2a 64 65 66 61 75 6c 74 print 5 *default
1620: 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 78 6e 3d -log-port* "exn=
1630: 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 " (condition->li
1640: 73 74 20 65 78 6e 29 29 0a 20 20 20 20 20 23 66 st exn)). #f
1650: 29 0a 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 ). (let-values
1660: 20 28 28 28 66 68 20 66 68 6f 20 70 69 64 29 20 (((fh fho pid)
1670: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
1680: 73 29 0a 09 09 09 09 20 20 28 70 72 6f 63 65 73 s)..... (proces
1690: 73 20 63 6d 64 29 0a 09 09 09 09 20 20 28 70 72 s cmd)..... (pr
16a0: 6f 63 65 73 73 20 63 6d 64 20 70 61 72 61 6d 73 ocess cmd params
16b0: 29 29 29 29 0a 20 20 20 20 20 20 20 28 6c 65 74 )))). (let
16c0: 20 6c 6f 6f 70 20 28 28 63 75 72 72 20 28 72 65 loop ((curr (re
16d0: 61 64 2d 6c 69 6e 65 20 66 68 29 29 0a 09 09 28 ad-line fh))...(
16e0: 72 65 73 75 6c 74 20 20 27 28 29 29 29 0a 20 20 result '())).
16f0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
1700: 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 75 72 72 29 of-object? curr)
1710: 29 0a 09 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 ).. (loop (rea
1720: 64 2d 6c 69 6e 65 20 66 68 29 0a 09 09 20 28 61 d-line fh)... (a
1730: 70 70 65 6e 64 20 72 65 73 75 6c 74 20 28 6c 69 ppend result (li
1740: 73 74 20 28 70 72 6f 63 20 63 75 72 72 29 29 29 st (proc curr)))
1750: 29 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 ).. (begin..
1760: 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d (close-input-
1770: 70 6f 72 74 20 66 68 29 0a 09 20 20 20 20 20 3b port fh).. ;
1780: 3b 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 ; (close-input-p
1790: 6f 72 74 20 66 68 65 29 0a 09 20 20 20 20 20 28 ort fhe).. (
17a0: 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 close-output-por
17b0: 74 20 66 68 6f 29 0a 09 20 20 20 20 20 72 65 73 t fho).. res
17c0: 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 66 69 ult))))))..(defi
17d0: 6e 65 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d ne (process:cmd-
17e0: 72 75 6e 2d 70 72 6f 63 2d 65 61 63 68 2d 6c 69 run-proc-each-li
17f0: 6e 65 2d 61 6c 74 20 63 6d 64 20 70 72 6f 63 29 ne-alt cmd proc)
1800: 0a 20 20 28 6c 65 74 2a 20 28 28 66 68 20 28 6f . (let* ((fh (o
1810: 70 65 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 63 pen-input-pipe c
1820: 6d 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 md)). (r
1830: 65 73 20 28 70 6f 72 74 2d 70 72 6f 63 2d 3e 6c es (port-proc->l
1840: 69 73 74 20 66 68 20 70 72 6f 63 29 29 0a 20 20 ist fh proc)).
1850: 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 28 (status (
1860: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 69 70 65 close-input-pipe
1870: 20 66 68 29 29 29 0a 20 20 20 20 28 69 66 20 28 fh))). (if (
1880: 65 71 3f 20 73 74 61 74 75 73 20 30 29 20 72 65 eq? status 0) re
1890: 73 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 s #f)))..(define
18a0: 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 75 (process:cmd-ru
18b0: 6e 2d 3e 6c 69 73 74 20 63 6d 64 20 23 21 6b 65 n->list cmd #!ke
18c0: 79 20 28 64 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 y (delta-env-ali
18d0: 73 74 2d 6f 72 2d 68 61 73 68 2d 74 61 62 6c 65 st-or-hash-table
18e0: 20 27 28 29 29 29 0a 20 20 28 63 6f 6d 6d 6f 6e '())). (common
18f0: 3a 77 69 74 68 2d 65 6e 76 2d 76 61 72 73 0a 20 :with-env-vars.
1900: 20 20 64 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 delta-env-alis
1910: 74 2d 6f 72 2d 68 61 73 68 2d 74 61 62 6c 65 0a t-or-hash-table.
1920: 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 (lambda ().
1930: 20 20 20 28 6c 65 74 2a 20 28 28 66 68 20 28 6f (let* ((fh (o
1940: 70 65 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 63 pen-input-pipe c
1950: 6d 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 md)).
1960: 20 28 72 65 73 20 28 70 6f 72 74 2d 3e 6c 69 73 (res (port->lis
1970: 74 20 66 68 29 29 0a 20 20 20 20 20 20 20 20 20 t fh)).
1980: 20 20 20 28 73 74 61 74 75 73 20 28 63 6c 6f 73 (status (clos
1990: 65 2d 69 6e 70 75 74 2d 70 69 70 65 20 66 68 29 e-input-pipe fh)
19a0: 29 29 0a 20 20 20 20 20 20 20 28 6c 69 73 74 20 )). (list
19b0: 72 65 73 20 73 74 61 74 75 73 29 29 29 29 29 0a res status))))).
19c0: 20 20 20 0a 28 64 65 66 69 6e 65 20 28 70 6f 72 .(define (por
19d0: 74 2d 3e 6c 69 73 74 20 66 68 29 0a 20 20 28 69 t->list fh). (i
19e0: 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 66 f (eof-object? f
19f0: 68 29 20 23 66 0a 20 20 20 20 20 20 28 6c 65 74 h) #f. (let
1a00: 20 6c 6f 6f 70 20 28 28 63 75 72 72 20 28 72 65 loop ((curr (re
1a10: 61 64 2d 6c 69 6e 65 20 66 68 29 29 0a 20 20 20 ad-line fh)).
1a20: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
1a30: 65 73 75 6c 74 20 27 28 29 29 29 0a 20 20 20 20 esult '())).
1a40: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 6f (if (not (eo
1a50: 66 2d 6f 62 6a 65 63 74 3f 20 63 75 72 72 29 29 f-object? curr))
1a60: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f . (lo
1a70: 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 op (read-line fh
1a80: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
1a90: 20 20 20 20 28 61 70 70 65 6e 64 20 72 65 73 75 (append resu
1aa0: 6c 74 20 28 6c 69 73 74 20 63 75 72 72 29 29 29 lt (list curr)))
1ab0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 . res
1ac0: 75 6c 74 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 ult))))..(define
1ad0: 20 28 70 6f 72 74 2d 70 72 6f 63 2d 3e 6c 69 73 (port-proc->lis
1ae0: 74 20 66 68 20 70 72 6f 63 29 0a 20 20 28 69 66 t fh proc). (if
1af0: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 66 68 (eof-object? fh
1b00: 29 20 23 66 0a 20 20 20 20 20 20 28 6c 65 74 20 ) #f. (let
1b10: 6c 6f 6f 70 20 28 28 63 75 72 72 20 28 70 72 6f loop ((curr (pro
1b20: 63 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 29 c (read-line fh)
1b30: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
1b40: 20 20 20 20 28 72 65 73 75 6c 74 20 27 28 29 29 (result '())
1b50: 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 6e ). (if (n
1b60: 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 ot (eof-object?
1b70: 63 75 72 72 29 29 0a 20 20 20 20 20 20 20 20 20 curr)).
1b80: 20 20 20 28 6c 6f 6f 70 20 28 6c 65 74 20 28 28 (loop (let ((
1b90: 6c 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 29 l (read-line fh)
1ba0: 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 )).
1bb0: 20 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 2d (if (eof-
1bc0: 6f 62 6a 65 63 74 3f 20 6c 29 20 6c 20 28 70 72 object? l) l (pr
1bd0: 6f 63 20 6c 29 29 29 0a 20 20 20 20 20 20 20 20 oc l))).
1be0: 20 20 20 20 20 20 20 20 20 20 28 61 70 70 65 6e (appen
1bf0: 64 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 63 d result (list c
1c00: 75 72 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 urr))).
1c10: 20 20 20 72 65 73 75 6c 74 29 29 29 29 0a 0a 3b result))))..;
1c20: 3b 20 68 65 72 65 20 69 73 20 61 6e 20 65 78 61 ; here is an exa
1c30: 6d 70 6c 65 20 6c 69 6e 65 20 77 68 65 72 65 20 mple line where
1c40: 74 68 65 20 73 68 65 6c 6c 20 69 73 20 73 68 20 the shell is sh
1c50: 6f 72 20 62 61 73 68 0a 3b 3b 20 22 66 69 6e 64 or bash.;; "find
1c60: 20 2f 20 2d 70 72 69 6e 74 20 32 26 3e 31 20 3e / -print 2&>1 >
1c70: 20 66 69 6e 64 61 6c 6c 2e 6c 6f 67 22 0a 28 64 findall.log".(d
1c80: 65 66 69 6e 65 20 28 72 75 6e 2d 6e 2d 77 61 69 efine (run-n-wai
1c90: 74 20 63 6d 64 6c 69 6e 65 20 23 21 6b 65 79 20 t cmdline #!key
1ca0: 28 70 61 72 61 6d 73 20 23 66 29 28 70 72 69 6e (params #f)(prin
1cb0: 74 2d 63 6d 64 20 23 66 29 28 72 75 6e 2d 64 69 t-cmd #f)(run-di
1cc0: 72 20 23 66 29 29 0a 20 20 28 69 66 20 70 72 69 r #f)). (if pri
1cd0: 6e 74 2d 63 6d 64 20 0a 20 20 20 20 20 20 28 64 nt-cmd . (d
1ce0: 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 ebug:print 0 *de
1cf0: 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 fault-log-port*
1d00: 0a 09 09 20 20 20 28 69 66 20 28 73 74 72 69 6e ... (if (strin
1d10: 67 3f 20 70 72 69 6e 74 2d 63 6d 64 29 0a 09 09 g? print-cmd)...
1d20: 20 20 20 20 20 20 20 70 72 69 6e 74 2d 63 6d 64 print-cmd
1d30: 0a 09 09 20 20 20 20 20 20 20 22 22 29 0a 09 09 ... "")...
1d40: 20 20 20 28 69 66 20 72 75 6e 2d 64 69 72 20 28 (if run-dir (
1d50: 63 6f 6e 63 20 22 52 75 6e 20 69 6e 20 22 20 72 conc "Run in " r
1d60: 75 6e 2d 64 69 72 20 22 3b 22 29 20 22 22 29 0a un-dir ";") "").
1d70: 09 09 20 20 20 63 6d 64 6c 69 6e 65 0a 09 09 20 .. cmdline...
1d80: 20 20 28 69 66 20 70 61 72 61 6d 73 0a 09 09 20 (if params...
1d90: 20 20 20 20 20 20 28 63 6f 6e 63 20 22 20 22 20 (conc " "
1da0: 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 (string-interspe
1db0: 72 73 65 20 70 61 72 61 6d 73 20 22 20 22 29 29 rse params " "))
1dc0: 0a 09 09 20 20 20 20 20 20 20 22 22 29 29 29 0a ... ""))).
1dd0: 20 20 28 69 66 20 28 61 6e 64 20 72 75 6e 2d 64 (if (and run-d
1de0: 69 72 0a 09 20 20 20 28 64 69 72 65 63 74 6f 72 ir.. (director
1df0: 79 2d 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 69 y-exists? run-di
1e00: 72 29 29 0a 20 20 20 20 20 20 28 70 75 73 68 2d r)). (push-
1e10: 64 69 72 65 63 74 6f 72 79 20 72 75 6e 2d 64 69 directory run-di
1e20: 72 29 29 0a 20 20 28 6c 65 74 20 28 28 70 69 64 r)). (let ((pid
1e30: 20 28 69 66 20 70 61 72 61 6d 73 0a 09 09 20 28 (if params... (
1e40: 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 6d 64 6c process-run cmdl
1e50: 69 6e 65 20 70 61 72 61 6d 73 29 0a 09 09 20 28 ine params)... (
1e60: 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 6d 64 6c process-run cmdl
1e70: 69 6e 65 29 29 29 29 0a 20 20 20 20 28 6c 65 74 ine)))). (let
1e80: 20 6c 6f 6f 70 20 28 28 69 20 30 29 29 0a 20 20 loop ((i 0)).
1e90: 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 (let-values
1ea0: 28 28 28 70 69 64 2d 76 61 6c 20 65 78 69 74 2d (((pid-val exit-
1eb0: 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f 64 65 status exit-code
1ec0: 29 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 ) (process-wait
1ed0: 70 69 64 20 23 74 29 29 29 0a 20 20 20 20 20 20 pid #t))).
1ee0: 20 20 20 28 69 66 20 28 65 71 3f 20 70 69 64 2d (if (eq? pid-
1ef0: 76 61 6c 20 30 29 0a 09 20 20 20 20 20 28 62 65 val 0).. (be
1f00: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 74 68 72 gin.. (thr
1f10: 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 20 ead-sleep! 2)..
1f20: 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 69 (loop (+ i
1f30: 20 31 29 29 29 0a 09 20 20 20 20 20 28 62 65 67 1))).. (beg
1f40: 69 6e 0a 09 20 20 20 20 20 20 20 28 69 66 20 28 in.. (if (
1f50: 61 6e 64 20 72 75 6e 2d 64 69 72 0a 09 09 09 28 and run-dir....(
1f60: 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 73 directory-exists
1f70: 3f 20 72 75 6e 2d 64 69 72 29 29 0a 09 09 20 20 ? run-dir))...
1f80: 20 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 29 (pop-directory)
1f90: 29 0a 09 20 20 20 20 20 20 20 28 76 61 6c 75 65 ).. (value
1fa0: 73 20 70 69 64 2d 76 61 6c 20 65 78 69 74 2d 73 s pid-val exit-s
1fb0: 74 61 74 75 73 20 65 78 69 74 2d 63 6f 64 65 29 tatus exit-code)
1fc0: 29 29 29 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d )))))). .;;====
1fd0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1fe0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1ff0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2000: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2010: 3d 3d 0a 3b 3b 20 4d 49 53 43 20 50 52 4f 43 45 ==.;; MISC PROCE
2020: 53 53 20 52 45 4c 41 54 45 44 20 53 54 55 46 46 SS RELATED STUFF
2030: 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d .;;=============
2040: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2050: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2060: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2070: 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 =========..(defi
2080: 6e 65 20 28 70 72 6f 63 65 73 73 3a 63 68 69 6c ne (process:chil
2090: 64 72 65 6e 20 70 72 6f 63 29 0a 20 20 28 77 69 dren proc). (wi
20a0: 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 th-input-from-pi
20b0: 70 65 0a 20 20 20 28 63 6f 6e 63 20 22 70 73 20 pe. (conc "ps
20c0: 68 20 2d 2d 70 70 69 64 20 22 20 28 63 75 72 72 h --ppid " (curr
20d0: 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 ent-process-id)
20e0: 22 20 2d 6f 20 70 69 64 22 29 0a 20 20 20 28 6c " -o pid"). (l
20f0: 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 28 6c ambda (). (l
2100: 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 et loop ((inl (r
2110: 65 61 64 2d 6c 69 6e 65 29 29 0a 09 09 28 72 65 ead-line))...(re
2120: 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 28 s '())). (
2130: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
2140: 69 6e 6c 29 0a 09 20 20 20 28 72 65 76 65 72 73 inl).. (revers
2150: 65 20 72 65 73 29 0a 09 20 20 20 28 6c 65 74 20 e res).. (let
2160: 28 28 70 69 64 20 28 73 74 72 69 6e 67 2d 3e 6e ((pid (string->n
2170: 75 6d 62 65 72 20 69 6e 6c 29 29 29 0a 09 20 20 umber inl)))..
2180: 20 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 6f (if proc (pro
2190: 63 20 70 69 64 29 29 0a 09 20 20 20 20 20 28 6c c pid)).. (l
21a0: 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 20 oop (read-line)
21b0: 28 63 6f 6e 73 20 70 69 64 20 72 65 73 29 29 29 (cons pid res)))
21c0: 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 )))))..(define (
21d0: 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 3f 20 70 process:alive? p
21e0: 69 64 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 id). (handle-ex
21f0: 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a ceptions. exn.
2200: 20 20 20 3b 3b 20 70 6f 73 73 69 62 6c 79 20 70 ;; possibly p
2210: 69 64 20 69 73 20 61 20 70 72 6f 63 65 73 73 20 id is a process
2220: 6e 6f 74 20 61 20 63 68 69 6c 64 2c 20 6c 6f 6f not a child, loo
2230: 6b 20 69 6e 20 2f 70 72 6f 63 20 74 6f 20 73 65 k in /proc to se
2240: 65 20 69 66 20 69 74 20 69 73 20 72 75 6e 6e 69 e if it is runni
2250: 6e 67 20 73 74 69 6c 6c 0a 20 20 20 28 66 69 6c ng still. (fil
2260: 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 20 e-exists? (conc
2270: 22 2f 70 72 6f 63 2f 22 20 70 69 64 29 29 0a 20 "/proc/" pid)).
2280: 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 (let-values ((
2290: 28 72 70 69 64 20 65 78 69 74 2d 74 79 70 65 20 (rpid exit-type
22a0: 65 78 69 74 2d 73 69 67 6e 61 6c 29 28 70 72 6f exit-signal)(pro
22b0: 63 65 73 73 2d 77 61 69 74 20 70 69 64 20 23 74 cess-wait pid #t
22c0: 29 29 29 0a 20 20 20 20 20 20 20 28 61 6e 64 20 ))). (and
22d0: 28 6e 75 6d 62 65 72 3f 20 72 70 69 64 29 0a 09 (number? rpid)..
22e0: 20 20 20 20 28 65 71 75 61 6c 3f 20 72 70 69 64 (equal? rpid
22f0: 20 70 69 64 29 29 29 29 29 0a 0a 28 64 65 66 69 pid)))))..(defi
2300: 6e 65 20 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 ne (process:aliv
2310: 65 2d 6f 6e 2d 68 6f 73 74 3f 20 68 6f 73 74 20 e-on-host? host
2320: 70 69 64 29 0a 20 20 28 6c 65 74 20 28 28 63 6d pid). (let ((cm
2330: 64 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 68 d (conc "ssh " h
2340: 6f 73 74 20 22 20 70 73 20 2d 6f 20 70 69 64 3d ost " ps -o pid=
2350: 20 2d 70 20 22 20 70 69 64 29 29 29 0a 20 20 20 -p " pid))).
2360: 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 (handle-excepti
2370: 6f 6e 73 0a 20 20 20 20 20 65 78 6e 0a 20 20 20 ons. exn.
2380: 20 20 23 66 20 3b 3b 20 61 6e 79 74 68 69 6e 67 #f ;; anything
2390: 20 67 6f 65 73 20 77 72 6f 6e 67 20 2d 20 61 73 goes wrong - as
23a0: 73 75 6d 65 20 74 68 65 20 70 72 6f 63 65 73 73 sume the process
23b0: 20 69 6e 20 4e 4f 54 20 72 75 6e 6e 69 6e 67 2e in NOT running.
23c0: 0a 20 20 20 20 20 28 77 69 74 68 2d 69 6e 70 75 . (with-inpu
23d0: 74 2d 66 72 6f 6d 2d 70 69 70 65 20 0a 20 20 20 t-from-pipe .
23e0: 20 20 20 63 6d 64 0a 20 20 20 20 20 20 28 6c 61 cmd. (la
23f0: 6d 62 64 61 20 28 29 0a 09 28 6c 65 74 20 6c 6f mbda ()..(let lo
2400: 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c op ((inl (read-l
2410: 69 6e 65 29 29 29 0a 09 20 20 28 69 66 20 28 65 ine))).. (if (e
2420: 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a of-object? inl).
2430: 09 20 20 20 20 20 20 23 66 0a 09 20 20 20 20 20 . #f..
2440: 20 28 6c 65 74 2a 20 28 28 63 6c 65 61 6e 2d 73 (let* ((clean-s
2450: 74 72 20 28 73 74 72 69 6e 67 2d 73 75 62 73 74 tr (string-subst
2460: 69 74 75 74 65 20 22 5e 5b 5e 5c 5c 64 5d 2a 28 itute "^[^\\d]*(
2470: 5b 30 2d 39 5d 2b 29 5b 5e 5c 5c 64 5d 2a 24 22 [0-9]+)[^\\d]*$"
2480: 20 22 5c 5c 31 22 20 69 6e 6c 29 29 0a 09 09 20 "\\1" inl))...
2490: 20 20 20 20 28 69 6e 6e 75 6d 20 20 20 20 20 28 (innum (
24a0: 73 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 20 63 string->number c
24b0: 6c 65 61 6e 2d 73 74 72 29 29 29 0a 09 09 28 61 lean-str)))...(a
24c0: 6e 64 20 69 6e 6e 75 6d 0a 09 09 20 20 20 20 20 nd innum...
24d0: 28 65 71 3f 20 70 69 64 20 69 6e 6e 75 6d 29 29 (eq? pid innum))
24e0: 29 29 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e ))))))))..(defin
24f0: 65 20 28 70 72 6f 63 65 73 73 3a 67 65 74 2d 73 e (process:get-s
2500: 75 62 2d 70 69 64 73 20 70 69 64 29 0a 20 20 28 ub-pids pid). (
2510: 77 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d with-input-from-
2520: 70 69 70 65 0a 20 20 20 28 63 6f 6e 63 20 22 70 pipe. (conc "p
2530: 73 74 72 65 65 20 2d 41 20 2d 70 20 22 20 70 69 stree -A -p " pi
2540: 64 29 20 3b 3b 20 7c 20 74 72 20 27 61 2d 7a 5c d) ;; | tr 'a-z\
2550: 5c 2d 2b 60 28 29 5c 5c 2e 27 20 27 20 27 20 22 \-+`()\\.' ' ' "
2560: 20 70 69 64 29 0a 20 20 20 28 6c 61 6d 62 64 61 pid). (lambda
2570: 20 28 29 0a 20 20 20 20 20 28 6c 65 74 20 6c 6f (). (let lo
2580: 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 64 2d 6c op ((inl (read-l
2590: 69 6e 65 29 29 0a 09 09 28 72 65 73 20 27 28 29 ine))...(res '()
25a0: 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 28 65 )). (if (e
25b0: 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e 6c 29 0a of-object? inl).
25c0: 09 20 20 20 28 72 65 76 65 72 73 65 20 72 65 73 . (reverse res
25d0: 29 0a 09 20 20 20 28 6c 65 74 20 28 28 6e 75 6d ).. (let ((num
25e0: 73 20 28 6d 61 70 20 73 74 72 69 6e 67 2d 3e 6e s (map string->n
25f0: 75 6d 62 65 72 0a 09 09 09 20 20 20 20 28 73 74 umber.... (st
2600: 72 69 6e 67 2d 73 70 6c 69 74 2d 66 69 65 6c 64 ring-split-field
2610: 73 20 22 5c 5c 64 2b 22 20 69 6e 6c 29 29 29 29 s "\\d+" inl))))
2620: 0a 09 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 .. (loop (re
2630: 61 64 2d 6c 69 6e 65 29 0a 09 09 20 20 20 28 61 ad-line)... (a
2640: 70 70 65 6e 64 20 72 65 73 20 6e 75 6d 73 29 29 ppend res nums))
2650: 29 29 29 29 29 29 0a 0a 29 0a ))))))..).