Artifact
f591b3597ddc1f8e2eb9ab948ff2d63dea553931:
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 37 2c 20 4d 61 74 74 right 2017, 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 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
03b0: 73 65 73 20 6d 74 76 65 72 29 29 0a 28 64 65 63 ses mtver)).(dec
03c0: 6c 61 72 65 20 28 75 73 65 73 20 64 65 62 75 67 lare (uses debug
03d0: 70 72 69 6e 74 29 29 0a 3b 3b 20 28 64 65 63 6c print)).;; (decl
03e0: 61 72 65 20 28 75 73 65 73 20 73 74 6d 6c 32 29 are (uses stml2)
03f0: 29 0a 3b 3b 20 28 64 65 63 6c 61 72 65 20 28 75 ).;; (declare (u
0400: 73 65 73 20 70 6b 74 73 29 29 0a 0a 28 6d 6f 64 ses pkts))..(mod
0410: 75 6c 65 20 70 72 6f 63 65 73 73 6d 6f 64 0a 09 ule processmod..
0420: 2a 0a 09 0a 28 69 6d 70 6f 72 74 20 73 63 68 65 *...(import sche
0430: 6d 65 0a 09 63 68 69 63 6b 65 6e 2e 62 61 73 65 me..chicken.base
0440: 0a 20 09 63 68 69 63 6b 65 6e 2e 63 6f 6e 64 69 . .chicken.condi
0450: 74 69 6f 6e 0a 20 09 63 68 69 63 6b 65 6e 2e 66 tion. .chicken.f
0460: 69 6c 65 0a 3b 3b 20 09 63 68 69 63 6b 65 6e 2e ile.;; .chicken.
0470: 74 69 6d 65 0a 3b 3b 20 09 63 68 69 63 6b 65 6e time.;; .chicken
0480: 2e 66 69 6c 65 2e 70 6f 73 69 78 0a 20 09 63 68 .file.posix. .ch
0490: 69 63 6b 65 6e 2e 70 61 74 68 6e 61 6d 65 0a 3b icken.pathname.;
04a0: 3b 20 09 63 68 69 63 6b 65 6e 2e 70 6f 72 74 0a ; .chicken.port.
04b0: 20 09 63 68 69 63 6b 65 6e 2e 70 72 6f 63 65 73 .chicken.proces
04c0: 73 0a 20 09 63 68 69 63 6b 65 6e 2e 70 72 6f 63 s. .chicken.proc
04d0: 65 73 73 2d 63 6f 6e 74 65 78 74 0a 20 09 63 68 ess-context. .ch
04e0: 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 2d 63 6f icken.process-co
04f0: 6e 74 65 78 74 2e 70 6f 73 69 78 0a 20 09 63 68 ntext.posix. .ch
0500: 69 63 6b 65 6e 2e 70 72 6f 63 65 73 73 2e 73 69 icken.process.si
0510: 67 6e 61 6c 0a 3b 3b 20 09 63 68 69 63 6b 65 6e gnal.;; .chicken
0520: 2e 70 72 65 74 74 79 2d 70 72 69 6e 74 0a 3b 3b .pretty-print.;;
0530: 20 09 63 68 69 63 6b 65 6e 2e 72 61 6e 64 6f 6d .chicken.random
0540: 0a 20 09 63 68 69 63 6b 65 6e 2e 69 6f 0a 20 09 . .chicken.io. .
0550: 63 68 69 63 6b 65 6e 2e 73 74 72 69 6e 67 0a 3b chicken.string.;
0560: 3b 20 09 63 68 69 63 6b 65 6e 2e 73 6f 72 74 0a ; .chicken.sort.
0570: 3b 3b 20 09 63 68 69 63 6b 65 6e 2e 74 69 6d 65 ;; .chicken.time
0580: 2e 70 6f 73 69 78 0a 3b 3b 20 09 0a 3b 3b 20 09 .posix.;; ..;; .
0590: 28 70 72 65 66 69 78 20 62 61 73 65 36 34 20 62 (prefix base64 b
05a0: 61 73 65 36 34 3a 29 0a 3b 3b 20 09 28 70 72 65 ase64:).;; .(pre
05b0: 66 69 78 20 73 71 6c 69 74 65 33 20 73 71 6c 69 fix sqlite3 sqli
05c0: 74 65 33 3a 29 0a 09 64 69 72 65 63 74 6f 72 79 te3:)..directory
05d0: 2d 75 74 69 6c 73 0a 3b 3b 20 09 6d 61 74 63 68 -utils.;; .match
05e0: 61 62 6c 65 0a 3b 3b 20 09 6d 64 35 0a 3b 3b 20 able.;; .md5.;;
05f0: 09 6d 65 73 73 61 67 65 2d 64 69 67 65 73 74 0a .message-digest.
0600: 20 09 72 65 67 65 78 0a 3b 3b 20 09 72 65 67 65 .regex.;; .rege
0610: 78 2d 63 61 73 65 0a 3b 3b 20 09 73 70 61 72 73 x-case.;; .spars
0620: 65 2d 76 65 63 74 6f 72 73 0a 20 09 73 72 66 69 e-vectors. .srfi
0630: 2d 31 0a 3b 3b 20 09 73 72 66 69 2d 31 33 0a 20 -1.;; .srfi-13.
0640: 09 73 72 66 69 2d 31 38 0a 20 09 73 72 66 69 2d .srfi-18. .srfi-
0650: 36 39 0a 3b 3b 20 09 73 79 73 74 65 6d 2d 69 6e 69.;; .system-in
0660: 66 6f 72 6d 61 74 69 6f 6e 0a 3b 3b 20 09 74 79 formation.;; .ty
0670: 70 65 64 2d 72 65 63 6f 72 64 73 0a 3b 3b 20 09 ped-records.;; .
0680: 7a 33 0a 3b 3b 20 0a 3b 3b 20 09 6d 74 76 65 72 z3.;; .;; .mtver
0690: 0a 20 09 64 65 62 75 67 70 72 69 6e 74 0a 3b 3b . .debugprint.;;
06a0: 20 09 73 74 6d 6c 32 0a 3b 3b 20 09 70 6b 74 73 .stml2.;; .pkts
06b0: 0a 09 29 0a 0a 3b 3b 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 3d 3d 3d ================
06f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b =============.;;
0700: 20 50 72 6f 63 65 73 73 20 63 6f 6e 76 69 65 6e Process convien
0710: 63 65 20 75 74 69 6c 73 0a 3b 3b 3d 3d 3d 3d 3d ce utils.;;=====
0720: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0730: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0740: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0750: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0760: 3d 0a 0a 3b 3b 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 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0790: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
07a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 3b 3b 20 61 ===========.;; a
07b0: 63 63 65 70 74 20 61 6e 20 61 6c 69 73 74 20 6f ccept an alist o
07c0: 72 20 68 61 73 68 20 74 61 62 6c 65 20 63 6f 6e r hash table con
07d0: 74 61 69 6e 69 6e 67 20 65 6e 76 76 61 72 2f 65 taining envvar/e
07e0: 6e 76 20 76 61 6c 75 65 20 70 61 69 72 73 20 28 nv value pairs (
07f0: 76 61 6c 75 65 20 6f 66 20 23 66 20 63 61 75 73 value of #f caus
0800: 65 73 20 75 6e 73 65 74 29 20 0a 3b 3b 20 20 20 es unset) .;;
0810: 65 78 65 63 75 74 65 20 74 68 75 6e 6b 20 69 6e execute thunk in
0820: 20 63 6f 6e 74 65 78 74 20 6f 66 20 65 6e 76 69 context of envi
0830: 72 6f 6e 6d 65 6e 74 20 6d 6f 64 69 66 69 65 64 ronment modified
0840: 20 61 73 20 70 65 72 20 74 68 69 73 20 6c 69 73 as per this lis
0850: 74 0a 3b 3b 20 20 20 72 65 73 74 6f 72 65 20 65 t.;; restore e
0860: 6e 76 20 74 6f 20 70 72 69 6f 72 20 73 74 61 74 nv to prior stat
0870: 65 20 74 68 65 6e 20 72 65 74 75 72 6e 20 76 61 e then return va
0880: 6c 75 65 20 6f 66 20 65 76 61 6c 27 64 20 74 68 lue of eval'd th
0890: 75 6e 6b 2e 0a 3b 3b 20 20 20 2a 2a 20 74 68 69 unk..;; ** thi
08a0: 73 20 69 73 20 6e 6f 74 20 74 68 72 65 61 64 20 s is not thread
08b0: 73 61 66 65 20 2a 2a 0a 28 64 65 66 69 6e 65 20 safe **.(define
08c0: 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d 65 6e 76 (common:with-env
08d0: 2d 76 61 72 73 20 64 65 6c 74 61 2d 65 6e 76 2d -vars delta-env-
08e0: 61 6c 69 73 74 2d 6f 72 2d 68 61 73 68 2d 74 61 alist-or-hash-ta
08f0: 62 6c 65 20 74 68 75 6e 6b 29 0a 20 20 28 6c 65 ble thunk). (le
0900: 74 2a 20 28 28 64 65 6c 74 61 2d 65 6e 76 2d 61 t* ((delta-env-a
0910: 6c 69 73 74 20 28 69 66 20 28 68 61 73 68 2d 74 list (if (hash-t
0920: 61 62 6c 65 3f 20 64 65 6c 74 61 2d 65 6e 76 2d able? delta-env-
0930: 61 6c 69 73 74 2d 6f 72 2d 68 61 73 68 2d 74 61 alist-or-hash-ta
0940: 62 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ble).
0950: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0960: 20 20 20 28 68 61 73 68 2d 74 61 62 6c 65 2d 3e (hash-table->
0970: 61 6c 69 73 74 20 64 65 6c 74 61 2d 65 6e 76 2d alist delta-env-
0980: 61 6c 69 73 74 2d 6f 72 2d 68 61 73 68 2d 74 61 alist-or-hash-ta
0990: 62 6c 65 29 0a 20 20 20 20 20 20 20 20 20 20 20 ble).
09a0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
09b0: 20 20 20 64 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 delta-env-ali
09c0: 73 74 2d 6f 72 2d 68 61 73 68 2d 74 61 62 6c 65 st-or-hash-table
09d0: 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 65 73 )). (res
09e0: 74 6f 72 65 2d 74 68 75 6e 6b 73 0a 20 20 20 20 tore-thunks.
09f0: 20 20 20 20 20 20 28 66 69 6c 74 65 72 0a 20 20 (filter.
0a00: 20 20 20 20 20 20 20 20 20 69 64 65 6e 74 69 74 identit
0a10: 79 0a 20 20 20 20 20 20 20 20 20 20 20 28 6d 61 y. (ma
0a20: 70 20 28 6c 61 6d 62 64 61 20 28 65 6e 76 2d 70 p (lambda (env-p
0a30: 61 69 72 29 0a 20 20 20 20 20 20 20 20 20 20 20 air).
0a40: 20 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 65 (let* ((e
0a50: 6e 76 2d 76 61 72 20 20 20 20 20 28 63 61 72 20 nv-var (car
0a60: 65 6e 76 2d 70 61 69 72 29 29 0a 20 20 20 20 20 env-pair)).
0a70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0a80: 20 20 20 20 28 6e 65 77 2d 76 61 6c 20 20 20 20 (new-val
0a90: 20 28 6c 65 74 20 28 28 74 6d 70 20 28 63 64 72 (let ((tmp (cdr
0aa0: 20 65 6e 76 2d 70 61 69 72 29 29 29 0a 20 20 20 env-pair))).
0ab0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ac0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ad0: 20 20 20 20 20 28 69 66 20 28 6c 69 73 74 3f 20 (if (list?
0ae0: 74 6d 70 29 20 28 63 61 72 20 74 6d 70 29 20 74 tmp) (car tmp) t
0af0: 6d 70 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 mp))).
0b00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0b10: 63 75 72 72 65 6e 74 2d 76 61 6c 20 28 67 65 74 current-val (get
0b20: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
0b30: 69 61 62 6c 65 20 65 6e 76 2d 76 61 72 29 29 0a iable env-var)).
0b40: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b50: 20 20 20 20 20 20 20 20 20 28 72 65 73 74 6f 72 (restor
0b60: 65 2d 74 68 75 6e 6b 0a 20 20 20 20 20 20 20 20 e-thunk.
0b70: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0b80: 20 20 28 63 6f 6e 64 0a 20 20 20 20 20 20 20 20 (cond.
0b90: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0ba0: 20 20 20 28 28 6e 6f 74 20 63 75 72 72 65 6e 74 ((not current
0bb0: 2d 76 61 6c 29 20 28 6c 61 6d 62 64 61 20 28 29 -val) (lambda ()
0bc0: 20 28 75 6e 73 65 74 2d 65 6e 76 69 72 6f 6e 6d (unset-environm
0bd0: 65 6e 74 2d 76 61 72 69 61 62 6c 65 21 20 65 6e ent-variable! en
0be0: 76 2d 76 61 72 29 29 29 0a 20 20 20 20 20 20 20 v-var))).
0bf0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c00: 20 20 20 20 28 28 6e 6f 74 20 28 73 74 72 69 6e ((not (strin
0c10: 67 3f 20 6e 65 77 2d 76 61 6c 29 29 20 23 66 29 g? new-val)) #f)
0c20: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0c30: 20 20 20 20 20 20 20 20 20 20 20 20 28 28 65 71 ((eq
0c40: 3f 20 63 75 72 72 65 6e 74 2d 76 61 6c 20 6e 65 ? current-val ne
0c50: 77 2d 76 61 6c 29 20 23 66 29 0a 20 20 20 20 20 w-val) #f).
0c60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c70: 20 20 20 20 20 20 28 65 6c 73 65 20 0a 20 20 20 (else .
0c80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0c90: 20 20 20 20 20 20 20 20 20 28 6c 61 6d 62 64 61 (lambda
0ca0: 20 28 29 20 28 73 65 74 2d 65 6e 76 69 72 6f 6e () (set-environ
0cb0: 6d 65 6e 74 2d 76 61 72 69 61 62 6c 65 21 20 65 ment-variable! e
0cc0: 6e 76 2d 76 61 72 20 63 75 72 72 65 6e 74 2d 76 nv-var current-v
0cd0: 61 6c 29 29 29 29 29 29 0a 20 20 20 20 20 20 20 al)))))).
0ce0: 20 20 20 20 20 20 20 20 20 20 20 20 20 3b 3b 28 ;;(
0cf0: 77 68 65 6e 20 28 6e 6f 74 20 28 73 74 72 69 6e when (not (strin
0d00: 67 3f 20 6e 65 77 2d 76 61 6c 29 29 0a 20 20 20 g? new-val)).
0d10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0d20: 20 3b 3b 20 20 20 20 28 64 65 62 75 67 3a 70 72 ;; (debug:pr
0d30: 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c int 0 *default-l
0d40: 6f 67 2d 70 6f 72 74 2a 20 22 20 50 52 4f 42 4c og-port* " PROBL
0d50: 45 4d 3a 20 6e 6f 74 20 61 20 73 74 72 69 6e 67 EM: not a string
0d60: 3a 20 22 6e 65 77 2d 76 61 6c 22 5c 6e 20 66 72 : "new-val"\n fr
0d70: 6f 6d 20 65 6e 76 2d 61 6c 69 73 74 3a 5c 6e 22 om env-alist:\n"
0d80: 64 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 74 29 delta-env-alist)
0d90: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0da0: 20 20 20 20 20 3b 3b 20 20 20 20 28 70 70 20 64 ;; (pp d
0db0: 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 74 29 0a elta-env-alist).
0dc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0dd0: 20 20 20 20 3b 3b 20 20 20 20 28 65 78 69 74 20 ;; (exit
0de0: 31 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 1)).
0df0: 20 20 20 20 20 20 20 20 20 20 20 20 0a 20 20 20 .
0e00: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e10: 20 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0e20: 20 20 20 20 20 20 28 63 6f 6e 64 0a 20 20 20 20 (cond.
0e30: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0e40: 20 28 28 6e 6f 74 20 6e 65 77 2d 76 61 6c 29 20 ((not new-val)
0e50: 20 3b 3b 20 6d 6f 64 69 66 79 20 65 6e 76 20 68 ;; modify env h
0e60: 65 72 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 ere.
0e70: 20 20 20 20 20 20 20 20 20 20 28 75 6e 73 65 74 (unset
0e80: 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d 76 61 72 -environment-var
0e90: 69 61 62 6c 65 21 20 65 6e 76 2d 76 61 72 29 29 iable! env-var))
0ea0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0eb0: 20 20 20 20 20 20 28 28 73 74 72 69 6e 67 3f 20 ((string?
0ec0: 6e 65 77 2d 76 61 6c 29 0a 20 20 20 20 20 20 20 new-val).
0ed0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
0ee0: 73 65 74 2d 65 6e 76 69 72 6f 6e 6d 65 6e 74 2d set-environment-
0ef0: 76 61 72 69 61 62 6c 65 21 20 65 6e 76 2d 76 61 variable! env-va
0f00: 72 20 6e 65 77 2d 76 61 6c 29 29 29 0a 20 20 20 r new-val))).
0f10: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0f20: 20 72 65 73 74 6f 72 65 2d 74 68 75 6e 6b 29 29 restore-thunk))
0f30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0f40: 20 64 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 73 74 delta-env-alist
0f50: 29 29 29 29 0a 20 20 20 20 28 6c 65 74 20 28 28 )))). (let ((
0f60: 72 76 20 28 74 68 75 6e 6b 29 29 29 0a 20 20 20 rv (thunk))).
0f70: 20 20 20 28 66 6f 72 2d 65 61 63 68 20 28 6c 61 (for-each (la
0f80: 6d 62 64 61 20 28 78 29 20 28 78 29 29 20 72 65 mbda (x) (x)) re
0f90: 73 74 6f 72 65 2d 74 68 75 6e 6b 73 29 20 3b 3b store-thunks) ;;
0fa0: 20 72 65 73 74 6f 72 65 20 65 6e 76 20 74 6f 20 restore env to
0fb0: 6f 72 69 67 69 6e 61 6c 20 73 74 61 74 65 0a 20 original state.
0fc0: 20 20 20 20 20 72 76 29 29 29 0a 0a 3b 3b 20 20 rv)))..;;
0fd0: 28 75 73 65 20 72 65 67 65 78 20 64 69 72 65 63 (use regex direc
0fe0: 74 6f 72 79 2d 75 74 69 6c 73 29 0a 3b 3b 20 20 tory-utils).;;
0ff0: 28 64 65 63 6c 61 72 65 20 28 75 6e 69 74 20 70 (declare (unit p
1000: 72 6f 63 65 73 73 29 29 0a 0a 28 64 65 66 69 6e rocess))..(defin
1010: 65 20 28 70 72 6f 63 65 73 73 3a 63 6f 6e 73 65 e (process:conse
1020: 72 76 61 74 69 76 65 2d 72 65 61 64 20 70 6f 72 rvative-read por
1030: 74 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 t). (let loop (
1040: 28 72 65 73 20 22 22 29 29 0a 20 20 20 20 28 69 (res "")). (i
1050: 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 f (not (eof-obje
1060: 63 74 3f 20 28 70 65 65 6b 2d 63 68 61 72 20 70 ct? (peek-char p
1070: 6f 72 74 29 29 29 0a 09 28 6c 6f 6f 70 20 28 63 ort)))..(loop (c
1080: 6f 6e 63 20 72 65 73 20 28 72 65 61 64 2d 63 68 onc res (read-ch
1090: 61 72 20 70 6f 72 74 29 29 29 0a 09 72 65 73 29 ar port)))..res)
10a0: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f ))..(define (pro
10b0: 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 cess:cmd-run-wit
10c0: 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 74 20 63 h-stderr->list c
10d0: 6d 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b md . params). ;
10e0: 3b 20 28 70 72 69 6e 74 20 22 43 61 6c 6c 65 64 ; (print "Called
10f0: 20 77 69 74 68 20 63 6d 64 3d 22 20 63 6d 64 20 with cmd=" cmd
1100: 22 2c 20 70 72 6f 63 3d 22 20 70 72 6f 63 20 22 ", proc=" proc "
1110: 2c 20 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d , params=" param
1120: 73 29 0a 3b 3b 20 20 28 68 61 6e 64 6c 65 2d 65 s).;; (handle-e
1130: 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 65 xceptions.;; e
1140: 78 6e 0a 3b 3b 20 20 20 28 62 65 67 69 6e 0a 3b xn.;; (begin.;
1150: 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 ; (print "ER
1160: 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 6f 20 ROR: Failed to
1170: 72 75 6e 20 63 6f 6d 6d 61 6e 64 3a 20 22 20 63 run command: " c
1180: 6d 64 20 22 20 22 20 28 73 74 72 69 6e 67 2d 69 md " " (string-i
1190: 6e 74 65 72 73 70 65 72 73 65 20 70 61 72 61 6d ntersperse param
11a0: 73 20 22 20 22 29 29 0a 3b 3b 20 20 20 20 20 28 s " ")).;; (
11b0: 70 72 69 6e 74 20 22 20 20 20 20 20 20 20 22 20 print " "
11c0: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
11d0: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
11e0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
11f0: 29 29 0a 3b 3b 20 20 20 20 20 23 66 29 0a 20 20 )).;; #f).
1200: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 (let-values (((
1210: 66 68 20 66 68 6f 20 70 69 64 20 66 68 65 29 20 fh fho pid fhe)
1220: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
1230: 73 29 0a 09 09 09 09 20 20 20 20 20 20 28 70 72 s)..... (pr
1240: 6f 63 65 73 73 2a 20 63 6d 64 29 0a 09 09 09 09 ocess* cmd).....
1250: 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 2a 20 (process*
1260: 63 6d 64 20 70 61 72 61 6d 73 29 29 29 29 0a 20 cmd params)))).
1270: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
1280: 28 28 63 75 72 72 20 28 72 65 61 64 2d 6c 69 6e ((curr (read-lin
1290: 65 20 66 68 29 29 0a 09 09 20 20 28 72 65 73 75 e fh))... (resu
12a0: 6c 74 20 20 27 28 29 29 29 0a 09 20 28 6c 65 74 lt '())).. (let
12b0: 20 28 28 65 72 72 73 74 72 20 28 70 72 6f 63 65 ((errstr (proce
12c0: 73 73 3a 63 6f 6e 73 65 72 76 61 74 69 76 65 2d ss:conservative-
12d0: 72 65 61 64 20 66 68 65 29 29 29 0a 09 20 20 20 read fhe)))..
12e0: 28 69 66 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 (if (not (string
12f0: 3d 3f 20 65 72 72 73 74 72 20 22 22 29 29 0a 09 =? errstr ""))..
1300: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 (set! res
1310: 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 73 75 ult (append resu
1320: 6c 74 20 28 6c 69 73 74 20 65 72 72 73 74 72 29 lt (list errstr)
1330: 29 29 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 )))). (if
1340: 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (not (eof-object
1350: 3f 20 63 75 72 72 29 29 0a 09 20 20 20 28 6c 6f ? curr)).. (lo
1360: 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 op (read-line fh
1370: 29 0a 09 09 20 28 61 70 70 65 6e 64 20 72 65 73 )... (append res
1380: 75 6c 74 20 28 6c 69 73 74 20 63 75 72 72 29 29 ult (list curr))
1390: 29 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 ).. (begin..
13a0: 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d (close-input-
13b0: 70 6f 72 74 20 66 68 29 0a 09 20 20 20 20 20 28 port fh).. (
13c0: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
13d0: 20 66 68 65 29 0a 09 20 20 20 20 20 28 63 6c 6f fhe).. (clo
13e0: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 66 se-output-port f
13f0: 68 6f 29 0a 09 20 20 20 20 20 72 65 73 75 6c 74 ho).. result
1400: 29 29 29 29 29 20 3b 3b 20 29 0a 0a 28 64 65 66 ))))) ;; )..(def
1410: 69 6e 65 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 ine (process:cmd
1420: 2d 72 75 6e 2d 77 69 74 68 2d 73 74 64 65 72 72 -run-with-stderr
1430: 2d 61 6e 64 2d 65 78 69 74 63 6f 64 65 2d 3e 6c -and-exitcode->l
1440: 69 73 74 20 63 6d 64 20 2e 20 70 61 72 61 6d 73 ist cmd . params
1450: 29 0a 20 20 3b 3b 20 28 70 72 69 6e 74 20 22 43 ). ;; (print "C
1460: 61 6c 6c 65 64 20 77 69 74 68 20 63 6d 64 3d 22 alled with cmd="
1470: 20 63 6d 64 20 22 2c 20 70 72 6f 63 3d 22 20 70 cmd ", proc=" p
1480: 72 6f 63 20 22 2c 20 70 61 72 61 6d 73 3d 22 20 roc ", params="
1490: 70 61 72 61 6d 73 29 0a 3b 3b 20 20 28 68 61 6e params).;; (han
14a0: 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e 73 0a 3b dle-exceptions.;
14b0: 3b 20 20 20 65 78 6e 0a 3b 3b 20 20 20 28 62 65 ; exn.;; (be
14c0: 67 69 6e 0a 3b 3b 20 20 20 20 20 28 70 72 69 6e gin.;; (prin
14d0: 74 20 22 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 t "ERROR: Faile
14e0: 64 20 74 6f 20 72 75 6e 20 63 6f 6d 6d 61 6e 64 d to run command
14f0: 3a 20 22 20 63 6d 64 20 22 20 22 20 28 73 74 72 : " cmd " " (str
1500: 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 65 20 ing-intersperse
1510: 70 61 72 61 6d 73 20 22 20 22 29 29 0a 3b 3b 20 params " ")).;;
1520: 20 20 20 20 28 70 72 69 6e 74 20 22 20 20 20 20 (print "
1530: 20 20 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e " ((condition
1540: 2d 70 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 -property-access
1550: 6f 72 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 or 'exn 'message
1560: 29 20 65 78 6e 29 29 0a 3b 3b 20 20 20 20 20 23 ) exn)).;; #
1570: 66 29 0a 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 f). (let-value
1580: 73 20 28 28 28 66 68 20 66 68 6f 20 70 69 64 20 s (((fh fho pid
1590: 66 68 65 29 20 28 69 66 20 28 6e 75 6c 6c 3f 20 fhe) (if (null?
15a0: 70 61 72 61 6d 73 29 0a 09 09 09 09 20 20 20 20 params).....
15b0: 20 20 28 70 72 6f 63 65 73 73 2a 20 63 6d 64 29 (process* cmd)
15c0: 0a 09 09 09 09 20 20 20 20 20 20 28 70 72 6f 63 ..... (proc
15d0: 65 73 73 2a 20 63 6d 64 20 70 61 72 61 6d 73 29 ess* cmd params)
15e0: 29 29 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 ))). (let
15f0: 6c 6f 6f 70 20 28 28 63 75 72 72 20 28 72 65 61 loop ((curr (rea
1600: 64 2d 6c 69 6e 65 20 66 68 29 29 0a 09 09 20 20 d-line fh))...
1610: 28 72 65 73 75 6c 74 20 20 27 28 29 29 29 0a 09 (result '()))..
1620: 20 28 6c 65 74 20 28 28 65 72 72 73 74 72 20 28 (let ((errstr (
1630: 70 72 6f 63 65 73 73 3a 63 6f 6e 73 65 72 76 61 process:conserva
1640: 74 69 76 65 2d 72 65 61 64 20 66 68 65 29 29 29 tive-read fhe)))
1650: 0a 09 20 20 20 28 69 66 20 28 6e 6f 74 20 28 73 .. (if (not (s
1660: 74 72 69 6e 67 3d 3f 20 65 72 72 73 74 72 20 22 tring=? errstr "
1670: 22 29 29 0a 09 20 20 20 20 20 20 20 28 73 65 74 ")).. (set
1680: 21 20 72 65 73 75 6c 74 20 28 61 70 70 65 6e 64 ! result (append
1690: 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 65 72 result (list er
16a0: 72 73 74 72 29 29 29 29 29 0a 20 20 20 20 20 20 rstr))))).
16b0: 20 28 69 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f (if (not (eof-o
16c0: 62 6a 65 63 74 3f 20 63 75 72 72 29 29 0a 09 20 bject? curr))..
16d0: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li
16e0: 6e 65 20 66 68 29 0a 09 09 20 28 61 70 70 65 6e ne fh)... (appen
16f0: 64 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 63 d result (list c
1700: 75 72 72 29 29 29 0a 09 20 20 20 28 62 65 67 69 urr))).. (begi
1710: 6e 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 28 n. (
1720: 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 61 6e let-values (((an
1730: 6f 74 68 65 72 70 69 64 20 6e 6f 72 6d 61 6c 65 otherpid normale
1740: 78 69 74 3f 20 65 78 69 74 73 74 61 74 75 73 29 xit? exitstatus)
1750: 20 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 (process-wait
1760: 70 69 64 29 29 29 0a 09 20 20 20 20 20 28 63 6c pid))).. (cl
1770: 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 ose-input-port f
1780: 68 29 0a 09 20 20 20 20 20 28 63 6c 6f 73 65 2d h).. (close-
1790: 69 6e 70 75 74 2d 70 6f 72 74 20 66 68 65 29 0a input-port fhe).
17a0: 09 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 . (close-out
17b0: 70 75 74 2d 70 6f 72 74 20 66 68 6f 29 0a 20 20 put-port fho).
17c0: 20 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 69 (li
17d0: 73 74 20 72 65 73 75 6c 74 20 28 69 66 20 6e 6f st result (if no
17e0: 72 6d 61 6c 65 78 69 74 3f 20 65 78 69 74 73 74 rmalexit? exitst
17f0: 61 74 75 73 20 2d 31 29 29 29 29 29 29 29 29 0a atus -1)))))))).
1800: 0a 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 .(define (proces
1810: 73 3a 63 6d 64 2d 72 75 6e 2d 70 72 6f 63 2d 65 s:cmd-run-proc-e
1820: 61 63 68 2d 6c 69 6e 65 20 63 6d 64 20 70 72 6f ach-line cmd pro
1830: 63 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b 3b c . params). ;;
1840: 20 28 70 72 69 6e 74 20 22 43 61 6c 6c 65 64 20 (print "Called
1850: 77 69 74 68 20 63 6d 64 3d 22 20 63 6d 64 20 22 with cmd=" cmd "
1860: 2c 20 70 72 6f 63 3d 22 20 70 72 6f 63 20 22 2c , proc=" proc ",
1870: 20 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d 73 params=" params
1880: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
1890: 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 ptions. exn.
18a0: 20 28 62 65 67 69 6e 0a 20 20 20 20 20 28 70 72 (begin. (pr
18b0: 69 6e 74 20 22 45 52 52 4f 52 3a 20 20 46 61 69 int "ERROR: Fai
18c0: 6c 65 64 20 74 6f 20 72 75 6e 20 63 6f 6d 6d 61 led to run comma
18d0: 6e 64 3a 20 22 20 63 6d 64 20 22 20 22 20 28 73 nd: " cmd " " (s
18e0: 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 65 72 73 tring-interspers
18f0: 65 20 70 61 72 61 6d 73 20 22 20 22 29 29 0a 20 e params " ")).
1900: 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 6e 74 (debug:print
1910: 20 30 20 2a 64 65 66 61 75 6c 74 2d 6c 6f 67 2d 0 *default-log-
1920: 70 6f 72 74 2a 20 22 20 6d 65 73 73 61 67 65 3a port* " message:
1930: 20 22 20 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 " ((condition-p
1940: 72 6f 70 65 72 74 79 2d 61 63 63 65 73 73 6f 72 roperty-accessor
1950: 20 27 65 78 6e 20 27 6d 65 73 73 61 67 65 29 20 'exn 'message)
1960: 65 78 6e 29 29 0a 20 20 20 20 20 28 64 65 62 75 exn)). (debu
1970: 67 3a 70 72 69 6e 74 20 35 20 2a 64 65 66 61 75 g:print 5 *defau
1980: 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 22 65 78 lt-log-port* "ex
1990: 6e 3d 22 20 28 63 6f 6e 64 69 74 69 6f 6e 2d 3e n=" (condition->
19a0: 6c 69 73 74 20 65 78 6e 29 29 0a 20 20 20 20 20 list exn)).
19b0: 23 66 29 0a 20 20 20 28 6c 65 74 2d 76 61 6c 75 #f). (let-valu
19c0: 65 73 20 28 28 28 66 68 20 66 68 6f 20 70 69 64 es (((fh fho pid
19d0: 29 20 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 ) (if (null? par
19e0: 61 6d 73 29 0a 09 09 09 09 20 20 28 70 72 6f 63 ams)..... (proc
19f0: 65 73 73 20 63 6d 64 29 0a 09 09 09 09 20 20 28 ess cmd)..... (
1a00: 70 72 6f 63 65 73 73 20 63 6d 64 20 70 61 72 61 process cmd para
1a10: 6d 73 29 29 29 29 0a 20 20 20 20 20 20 20 28 6c ms)))). (l
1a20: 65 74 20 6c 6f 6f 70 20 28 28 63 75 72 72 20 28 et loop ((curr (
1a30: 72 65 61 64 2d 6c 69 6e 65 20 66 68 29 29 0a 09 read-line fh))..
1a40: 09 28 72 65 73 75 6c 74 20 20 27 28 29 29 29 0a .(result '())).
1a50: 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 (if (not
1a60: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 75 72 (eof-object? cur
1a70: 72 29 29 0a 09 20 20 20 28 6c 6f 6f 70 20 28 72 r)).. (loop (r
1a80: 65 61 64 2d 6c 69 6e 65 20 66 68 29 0a 09 09 20 ead-line fh)...
1a90: 28 61 70 70 65 6e 64 20 72 65 73 75 6c 74 20 28 (append result (
1aa0: 6c 69 73 74 20 28 70 72 6f 63 20 63 75 72 72 29 list (proc curr)
1ab0: 29 29 29 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 ))).. (begin..
1ac0: 20 20 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 (close-inpu
1ad0: 74 2d 70 6f 72 74 20 66 68 29 0a 09 20 20 20 20 t-port fh)..
1ae0: 20 3b 3b 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d ;;(close-input-
1af0: 70 6f 72 74 20 66 68 65 29 0a 09 20 20 20 20 20 port fhe)..
1b00: 28 63 6c 6f 73 65 2d 6f 75 74 70 75 74 2d 70 6f (close-output-po
1b10: 72 74 20 66 68 6f 29 0a 09 20 20 20 20 20 72 65 rt fho).. re
1b20: 73 75 6c 74 29 29 29 29 29 29 0a 0a 28 64 65 66 sult))))))..(def
1b30: 69 6e 65 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 ine (process:cmd
1b40: 2d 72 75 6e 2d 70 72 6f 63 2d 65 61 63 68 2d 6c -run-proc-each-l
1b50: 69 6e 65 2d 61 6c 74 20 63 6d 64 20 70 72 6f 63 ine-alt cmd proc
1b60: 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 68 20 28 ). (let* ((fh (
1b70: 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 open-input-pipe
1b80: 63 6d 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 cmd)). (
1b90: 72 65 73 20 28 70 6f 72 74 2d 70 72 6f 63 2d 3e res (port-proc->
1ba0: 6c 69 73 74 20 66 68 20 70 72 6f 63 29 29 0a 20 list fh proc)).
1bb0: 20 20 20 20 20 20 20 20 28 73 74 61 74 75 73 20 (status
1bc0: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 69 70 (close-input-pip
1bd0: 65 20 66 68 29 29 29 0a 20 20 20 20 28 69 66 20 e fh))). (if
1be0: 28 65 71 3f 20 73 74 61 74 75 73 20 30 29 20 72 (eq? status 0) r
1bf0: 65 73 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e es #f)))..(defin
1c00: 65 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 2d 72 e (process:cmd-r
1c10: 75 6e 2d 3e 6c 69 73 74 20 63 6d 64 20 23 21 6b un->list cmd #!k
1c20: 65 79 20 28 64 65 6c 74 61 2d 65 6e 76 2d 61 6c ey (delta-env-al
1c30: 69 73 74 2d 6f 72 2d 68 61 73 68 2d 74 61 62 6c ist-or-hash-tabl
1c40: 65 20 27 28 29 29 29 0a 20 20 28 63 6f 6d 6d 6f e '())). (commo
1c50: 6e 3a 77 69 74 68 2d 65 6e 76 2d 76 61 72 73 0a n:with-env-vars.
1c60: 20 20 20 64 65 6c 74 61 2d 65 6e 76 2d 61 6c 69 delta-env-ali
1c70: 73 74 2d 6f 72 2d 68 61 73 68 2d 74 61 62 6c 65 st-or-hash-table
1c80: 0a 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 . (lambda ().
1c90: 20 20 20 20 28 6c 65 74 2a 20 28 28 66 68 20 28 (let* ((fh (
1ca0: 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 open-input-pipe
1cb0: 63 6d 64 29 29 0a 20 20 20 20 20 20 20 20 20 20 cmd)).
1cc0: 20 20 28 72 65 73 20 28 70 6f 72 74 2d 3e 6c 69 (res (port->li
1cd0: 73 74 20 66 68 29 29 0a 20 20 20 20 20 20 20 20 st fh)).
1ce0: 20 20 20 20 28 73 74 61 74 75 73 20 28 63 6c 6f (status (clo
1cf0: 73 65 2d 69 6e 70 75 74 2d 70 69 70 65 20 66 68 se-input-pipe fh
1d00: 29 29 29 0a 20 20 20 20 20 20 20 28 6c 69 73 74 ))). (list
1d10: 20 72 65 73 20 73 74 61 74 75 73 29 29 29 29 29 res status)))))
1d20: 0a 20 20 20 0a 28 64 65 66 69 6e 65 20 28 70 6f . .(define (po
1d30: 72 74 2d 3e 6c 69 73 74 20 66 68 29 0a 20 20 28 rt->list fh). (
1d40: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
1d50: 66 68 29 20 23 66 0a 20 20 20 20 20 20 28 6c 65 fh) #f. (le
1d60: 74 20 6c 6f 6f 70 20 28 28 63 75 72 72 20 28 72 t loop ((curr (r
1d70: 65 61 64 2d 6c 69 6e 65 20 66 68 29 29 0a 20 20 ead-line fh)).
1d80: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 (
1d90: 72 65 73 75 6c 74 20 27 28 29 29 29 0a 20 20 20 result '())).
1da0: 20 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 (if (not (e
1db0: 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 75 72 72 29 of-object? curr)
1dc0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c ). (l
1dd0: 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 oop (read-line f
1de0: 68 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 h).
1df0: 20 20 20 20 20 28 61 70 70 65 6e 64 20 72 65 73 (append res
1e00: 75 6c 74 20 28 6c 69 73 74 20 63 75 72 72 29 29 ult (list curr))
1e10: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 72 65 ). re
1e20: 73 75 6c 74 29 29 29 29 0a 0a 28 64 65 66 69 6e sult))))..(defin
1e30: 65 20 28 70 6f 72 74 2d 70 72 6f 63 2d 3e 6c 69 e (port-proc->li
1e40: 73 74 20 66 68 20 70 72 6f 63 29 0a 20 20 28 69 st fh proc). (i
1e50: 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 66 f (eof-object? f
1e60: 68 29 20 23 66 0a 20 20 20 20 20 20 28 6c 65 74 h) #f. (let
1e70: 20 6c 6f 6f 70 20 28 28 63 75 72 72 20 28 70 72 loop ((curr (pr
1e80: 6f 63 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 oc (read-line fh
1e90: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
1ea0: 20 20 20 20 20 28 72 65 73 75 6c 74 20 27 28 29 (result '()
1eb0: 29 29 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 )). (if (
1ec0: 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f not (eof-object?
1ed0: 20 63 75 72 72 29 29 0a 20 20 20 20 20 20 20 20 curr)).
1ee0: 20 20 20 20 28 6c 6f 6f 70 20 28 6c 65 74 20 28 (loop (let (
1ef0: 28 6c 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 (l (read-line fh
1f00: 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 ))).
1f10: 20 20 20 20 20 20 20 20 28 69 66 20 28 65 6f 66 (if (eof
1f20: 2d 6f 62 6a 65 63 74 3f 20 6c 29 20 6c 20 28 70 -object? l) l (p
1f30: 72 6f 63 20 6c 29 29 29 0a 20 20 20 20 20 20 20 roc l))).
1f40: 20 20 20 20 20 20 20 20 20 20 20 28 61 70 70 65 (appe
1f50: 6e 64 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 nd result (list
1f60: 63 75 72 72 29 29 29 0a 20 20 20 20 20 20 20 20 curr))).
1f70: 20 20 20 20 72 65 73 75 6c 74 29 29 29 29 0a 0a result))))..
1f80: 3b 3b 20 68 65 72 65 20 69 73 20 61 6e 20 65 78 ;; here is an ex
1f90: 61 6d 70 6c 65 20 6c 69 6e 65 20 77 68 65 72 65 ample line where
1fa0: 20 74 68 65 20 73 68 65 6c 6c 20 69 73 20 73 68 the shell is sh
1fb0: 20 6f 72 20 62 61 73 68 0a 3b 3b 20 22 66 69 6e or bash.;; "fin
1fc0: 64 20 2f 20 2d 70 72 69 6e 74 20 32 26 3e 31 20 d / -print 2&>1
1fd0: 3e 20 66 69 6e 64 61 6c 6c 2e 6c 6f 67 22 0a 28 > findall.log".(
1fe0: 64 65 66 69 6e 65 20 28 72 75 6e 2d 6e 2d 77 61 define (run-n-wa
1ff0: 69 74 20 63 6d 64 6c 69 6e 65 20 23 21 6b 65 79 it cmdline #!key
2000: 20 28 70 61 72 61 6d 73 20 23 66 29 28 70 72 69 (params #f)(pri
2010: 6e 74 2d 63 6d 64 20 23 66 29 28 72 75 6e 2d 64 nt-cmd #f)(run-d
2020: 69 72 20 23 66 29 29 0a 20 20 28 69 66 20 70 72 ir #f)). (if pr
2030: 69 6e 74 2d 63 6d 64 20 0a 20 20 20 20 20 20 28 int-cmd . (
2040: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
2050: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
2060: 20 0a 09 09 20 20 20 28 69 66 20 28 73 74 72 69 ... (if (stri
2070: 6e 67 3f 20 70 72 69 6e 74 2d 63 6d 64 29 0a 09 ng? print-cmd)..
2080: 09 20 20 20 20 20 20 20 70 72 69 6e 74 2d 63 6d . print-cm
2090: 64 0a 09 09 20 20 20 20 20 20 20 22 22 29 0a 09 d... "")..
20a0: 09 20 20 20 28 69 66 20 72 75 6e 2d 64 69 72 20 . (if run-dir
20b0: 28 63 6f 6e 63 20 22 52 75 6e 20 69 6e 20 22 20 (conc "Run in "
20c0: 72 75 6e 2d 64 69 72 20 22 3b 22 29 20 22 22 29 run-dir ";") "")
20d0: 0a 09 09 20 20 20 63 6d 64 6c 69 6e 65 0a 09 09 ... cmdline...
20e0: 20 20 20 28 69 66 20 70 61 72 61 6d 73 0a 09 09 (if params...
20f0: 20 20 20 20 20 20 20 28 63 6f 6e 63 20 22 20 22 (conc " "
2100: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp
2110: 65 72 73 65 20 70 61 72 61 6d 73 20 22 20 22 29 erse params " ")
2120: 29 0a 09 09 20 20 20 20 20 20 20 22 22 29 29 29 )... "")))
2130: 0a 20 20 28 69 66 20 28 61 6e 64 20 72 75 6e 2d . (if (and run-
2140: 64 69 72 0a 09 20 20 20 28 64 69 72 65 63 74 6f dir.. (directo
2150: 72 79 2d 65 78 69 73 74 73 3f 20 72 75 6e 2d 64 ry-exists? run-d
2160: 69 72 29 29 0a 20 20 20 20 20 20 28 70 75 73 68 ir)). (push
2170: 2d 64 69 72 65 63 74 6f 72 79 20 72 75 6e 2d 64 -directory run-d
2180: 69 72 29 29 0a 20 20 28 6c 65 74 20 28 28 70 69 ir)). (let ((pi
2190: 64 20 28 69 66 20 70 61 72 61 6d 73 0a 09 09 20 d (if params...
21a0: 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 6d 64 (process-run cmd
21b0: 6c 69 6e 65 20 70 61 72 61 6d 73 29 0a 09 09 20 line params)...
21c0: 28 70 72 6f 63 65 73 73 2d 72 75 6e 20 63 6d 64 (process-run cmd
21d0: 6c 69 6e 65 29 29 29 29 0a 20 20 20 20 28 6c 65 line)))). (le
21e0: 74 20 6c 6f 6f 70 20 28 28 69 20 30 29 29 0a 20 t loop ((i 0)).
21f0: 20 20 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 (let-values
2200: 20 28 28 28 70 69 64 2d 76 61 6c 20 65 78 69 74 (((pid-val exit
2210: 2d 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f 64 -status exit-cod
2220: 65 29 20 28 70 72 6f 63 65 73 73 2d 77 61 69 74 e) (process-wait
2230: 20 70 69 64 20 23 74 29 29 29 0a 20 20 20 20 20 pid #t))).
2240: 20 20 20 20 28 69 66 20 28 65 71 3f 20 70 69 64 (if (eq? pid
2250: 2d 76 61 6c 20 30 29 0a 09 20 20 20 20 20 28 62 -val 0).. (b
2260: 65 67 69 6e 0a 09 20 20 20 20 20 20 20 28 74 68 egin.. (th
2270: 72 65 61 64 2d 73 6c 65 65 70 21 20 32 29 0a 09 read-sleep! 2)..
2280: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 2b 20 (loop (+
2290: 69 20 31 29 29 29 0a 09 20 20 20 20 20 28 62 65 i 1))).. (be
22a0: 67 69 6e 0a 09 20 20 20 20 20 20 20 28 69 66 20 gin.. (if
22b0: 28 61 6e 64 20 72 75 6e 2d 64 69 72 0a 09 09 09 (and run-dir....
22c0: 28 64 69 72 65 63 74 6f 72 79 2d 65 78 69 73 74 (directory-exist
22d0: 73 3f 20 72 75 6e 2d 64 69 72 29 29 0a 09 09 20 s? run-dir))...
22e0: 20 20 28 70 6f 70 2d 64 69 72 65 63 74 6f 72 79 (pop-directory
22f0: 29 29 0a 09 20 20 20 20 20 20 20 28 76 61 6c 75 )).. (valu
2300: 65 73 20 70 69 64 2d 76 61 6c 20 65 78 69 74 2d es pid-val exit-
2310: 73 74 61 74 75 73 20 65 78 69 74 2d 63 6f 64 65 status exit-code
2320: 29 29 29 29 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d ))))))). .;;===
2330: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2340: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2350: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2360: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
2370: 3d 3d 3d 0a 3b 3b 20 4d 49 53 43 20 50 52 4f 43 ===.;; MISC PROC
2380: 45 53 53 20 52 45 4c 41 54 45 44 20 53 54 55 46 ESS RELATED STUF
2390: 46 0a 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d F.;;============
23a0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
23b0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
23c0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
23d0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 ==========..(def
23e0: 69 6e 65 20 28 70 72 6f 63 65 73 73 3a 63 68 69 ine (process:chi
23f0: 6c 64 72 65 6e 20 70 72 6f 63 29 0a 20 20 28 77 ldren proc). (w
2400: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
2410: 69 70 65 0a 20 20 20 28 63 6f 6e 63 20 22 70 73 ipe. (conc "ps
2420: 20 68 20 2d 2d 70 70 69 64 20 22 20 28 63 75 72 h --ppid " (cur
2430: 72 65 6e 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 rent-process-id)
2440: 20 22 20 2d 6f 20 70 69 64 22 29 0a 20 20 20 28 " -o pid"). (
2450: 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 28 lambda (). (
2460: 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 let loop ((inl (
2470: 72 65 61 64 2d 6c 69 6e 65 29 29 0a 09 09 28 72 read-line))...(r
2480: 65 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 es '())).
2490: 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f (if (eof-object?
24a0: 20 69 6e 6c 29 0a 09 20 20 20 28 72 65 76 65 72 inl).. (rever
24b0: 73 65 20 72 65 73 29 0a 09 20 20 20 28 6c 65 74 se res).. (let
24c0: 20 28 28 70 69 64 20 28 73 74 72 69 6e 67 2d 3e ((pid (string->
24d0: 6e 75 6d 62 65 72 20 69 6e 6c 29 29 29 0a 09 20 number inl)))..
24e0: 20 20 20 20 28 69 66 20 70 72 6f 63 20 28 70 72 (if proc (pr
24f0: 6f 63 20 70 69 64 29 29 0a 09 20 20 20 20 20 28 oc pid)).. (
2500: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
2510: 20 28 63 6f 6e 73 20 70 69 64 20 72 65 73 29 29 (cons pid res))
2520: 29 29 29 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 ))))))..(define
2530: 28 70 72 6f 63 65 73 73 3a 61 6c 69 76 65 3f 20 (process:alive?
2540: 70 69 64 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 pid). (handle-e
2550: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e xceptions. exn
2560: 0a 20 20 20 3b 3b 20 70 6f 73 73 69 62 6c 79 20 . ;; possibly
2570: 70 69 64 20 69 73 20 61 20 70 72 6f 63 65 73 73 pid is a process
2580: 20 6e 6f 74 20 61 20 63 68 69 6c 64 2c 20 6c 6f not a child, lo
2590: 6f 6b 20 69 6e 20 2f 70 72 6f 63 20 74 6f 20 73 ok in /proc to s
25a0: 65 65 20 69 66 20 69 74 20 69 73 20 72 75 6e 6e ee if it is runn
25b0: 69 6e 67 20 73 74 69 6c 6c 0a 20 20 20 28 66 69 ing still. (fi
25c0: 6c 65 2d 65 78 69 73 74 73 3f 20 28 63 6f 6e 63 le-exists? (conc
25d0: 20 22 2f 70 72 6f 63 2f 22 20 70 69 64 29 29 0a "/proc/" pid)).
25e0: 20 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 (let-values (
25f0: 28 28 72 70 69 64 20 65 78 69 74 2d 74 79 70 65 ((rpid exit-type
2600: 20 65 78 69 74 2d 73 69 67 6e 61 6c 29 28 70 72 exit-signal)(pr
2610: 6f 63 65 73 73 2d 77 61 69 74 20 70 69 64 20 23 ocess-wait pid #
2620: 74 29 29 29 0a 20 20 20 20 20 20 20 28 61 6e 64 t))). (and
2630: 20 28 6e 75 6d 62 65 72 3f 20 72 70 69 64 29 0a (number? rpid).
2640: 09 20 20 20 20 28 65 71 75 61 6c 3f 20 72 70 69 . (equal? rpi
2650: 64 20 70 69 64 29 29 29 29 29 0a 0a 28 64 65 66 d pid)))))..(def
2660: 69 6e 65 20 28 70 72 6f 63 65 73 73 3a 61 6c 69 ine (process:ali
2670: 76 65 2d 6f 6e 2d 68 6f 73 74 3f 20 68 6f 73 74 ve-on-host? host
2680: 20 70 69 64 29 0a 20 20 28 6c 65 74 20 28 28 63 pid). (let ((c
2690: 6d 64 20 28 63 6f 6e 63 20 22 73 73 68 20 22 20 md (conc "ssh "
26a0: 68 6f 73 74 20 22 20 70 73 20 2d 6f 20 70 69 64 host " ps -o pid
26b0: 3d 20 2d 70 20 22 20 70 69 64 29 29 29 0a 20 20 = -p " pid))).
26c0: 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 (handle-except
26d0: 69 6f 6e 73 0a 09 65 78 6e 0a 20 20 20 20 20 20 ions..exn.
26e0: 28 62 65 67 69 6e 0a 09 28 64 65 62 75 67 3a 70 (begin..(debug:p
26f0: 72 69 6e 74 20 30 20 2a 64 65 66 61 75 6c 74 2d rint 0 *default-
2700: 6c 6f 67 2d 70 6f 72 74 2a 20 22 66 61 69 6c 65 log-port* "faile
2710: 64 20 74 6f 20 69 64 65 6e 74 69 66 79 20 69 66 d to identify if
2720: 20 70 72 6f 63 65 73 73 20 22 20 70 69 64 20 22 process " pid "
2730: 2c 20 6f 6e 20 68 6f 73 74 20 22 20 68 6f 73 74 , on host " host
2740: 20 22 20 69 73 20 61 6c 69 76 65 2e 20 65 78 6e " is alive. exn
2750: 3d 22 20 65 78 6e 29 0a 09 23 66 29 20 3b 3b 20 =" exn)..#f) ;;
2760: 61 6e 79 74 68 69 6e 67 20 67 6f 65 73 20 77 72 anything goes wr
2770: 6f 6e 67 20 2d 20 61 73 73 75 6d 65 20 74 68 65 ong - assume the
2780: 20 70 72 6f 63 65 73 73 20 69 6e 20 4e 4f 54 20 process in NOT
2790: 72 75 6e 6e 69 6e 67 2e 0a 20 20 20 20 20 28 77 running.. (w
27a0: 69 74 68 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 ith-input-from-p
27b0: 69 70 65 20 0a 20 20 20 20 20 20 63 6d 64 0a 20 ipe . cmd.
27c0: 20 20 20 20 20 28 6c 61 6d 62 64 61 20 28 29 0a (lambda ().
27d0: 09 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c .(let loop ((inl
27e0: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 (read-line)))..
27f0: 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 (if (eof-objec
2800: 74 3f 20 69 6e 6c 29 0a 09 20 20 20 20 20 20 23 t? inl).. #
2810: 66 0a 09 20 20 20 20 20 20 28 6c 65 74 2a 20 28 f.. (let* (
2820: 28 63 6c 65 61 6e 2d 73 74 72 20 28 73 74 72 69 (clean-str (stri
2830: 6e 67 2d 73 75 62 73 74 69 74 75 74 65 20 22 5e ng-substitute "^
2840: 5b 5e 5c 5c 64 5d 2a 28 5b 30 2d 39 5d 2b 29 5b [^\\d]*([0-9]+)[
2850: 5e 5c 5c 64 5d 2a 24 22 20 22 5c 5c 31 22 20 69 ^\\d]*$" "\\1" i
2860: 6e 6c 29 29 0a 09 09 20 20 20 20 20 28 69 6e 6e nl))... (inn
2870: 75 6d 20 20 20 20 20 28 73 74 72 69 6e 67 2d 3e um (string->
2880: 6e 75 6d 62 65 72 20 63 6c 65 61 6e 2d 73 74 72 number clean-str
2890: 29 29 29 0a 09 09 28 61 6e 64 20 69 6e 6e 75 6d )))...(and innum
28a0: 0a 09 09 20 20 20 20 20 28 65 71 3f 20 70 69 64 ... (eq? pid
28b0: 20 69 6e 6e 75 6d 29 29 29 29 29 29 29 29 29 29 innum))))))))))
28c0: 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 ..(define (proce
28d0: 73 73 3a 67 65 74 2d 73 75 62 2d 70 69 64 73 20 ss:get-sub-pids
28e0: 70 69 64 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 pid). (with-inp
28f0: 75 74 2d 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 ut-from-pipe.
2900: 28 63 6f 6e 63 20 22 70 73 74 72 65 65 20 2d 41 (conc "pstree -A
2910: 20 2d 70 20 22 20 70 69 64 29 20 3b 3b 20 7c 20 -p " pid) ;; |
2920: 74 72 20 27 61 2d 7a 5c 5c 2d 2b 60 28 29 5c 5c tr 'a-z\\-+`()\\
2930: 2e 27 20 27 20 27 20 22 20 70 69 64 29 0a 20 20 .' ' ' " pid).
2940: 20 28 6c 61 6d 62 64 61 20 28 29 0a 20 20 20 20 (lambda ().
2950: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c (let loop ((inl
2960: 20 28 72 65 61 64 2d 6c 69 6e 65 29 29 0a 09 09 (read-line))...
2970: 28 72 65 73 20 27 28 29 29 29 0a 20 20 20 20 20 (res '())).
2980: 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 (if (eof-objec
2990: 74 3f 20 69 6e 6c 29 0a 09 20 20 20 28 72 65 76 t? inl).. (rev
29a0: 65 72 73 65 20 72 65 73 29 0a 09 20 20 20 28 6c erse res).. (l
29b0: 65 74 20 28 28 6e 75 6d 73 20 28 6d 61 70 20 73 et ((nums (map s
29c0: 74 72 69 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 09 tring->number...
29d0: 09 20 20 20 20 28 73 74 72 69 6e 67 2d 73 70 6c . (string-spl
29e0: 69 74 2d 66 69 65 6c 64 73 20 22 5c 5c 64 2b 22 it-fields "\\d+"
29f0: 20 69 6e 6c 29 29 29 29 0a 09 20 20 20 20 20 28 inl)))).. (
2a00: 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 loop (read-line)
2a10: 0a 09 09 20 20 20 28 61 70 70 65 6e 64 20 72 65 ... (append re
2a20: 73 20 6e 75 6d 73 29 29 29 29 29 29 29 29 0a 0a s nums))))))))..
2a30: 29 0a ).