Artifact
36b394cc1eaebe95d1c14c6843ec623ab7ceea30:
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 32 2c right 2006-2012,
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 3b 3b 3d 3d ==========..;;==
01e0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
01f0: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0200: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0210: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0220: 3d 3d 3d 3d 0a 3b 3b 20 50 72 6f 63 65 73 73 20 ====.;; Process
0230: 63 6f 6e 76 69 65 6e 63 65 20 75 74 69 6c 73 0a convience utils.
0240: 3b 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;;==============
0250: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0260: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0270: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
0280: 3d 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 75 73 65 20 72 ========..(use r
0290: 65 67 65 78 29 0a 28 64 65 63 6c 61 72 65 20 28 egex).(declare (
02a0: 75 6e 69 74 20 70 72 6f 63 65 73 73 29 29 0a 3b unit process)).;
02b0: 3b 28 64 65 63 6c 61 72 65 20 28 75 73 65 73 20 ;(declare (uses
02c0: 63 6f 6d 6d 6f 6e 29 29 0a 0a 28 64 65 66 69 6e common))..(defin
02d0: 65 20 28 70 72 6f 63 65 73 73 3a 63 6f 6e 73 65 e (process:conse
02e0: 72 76 61 74 69 76 65 2d 72 65 61 64 20 70 6f 72 rvative-read por
02f0: 74 29 0a 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 t). (let loop (
0300: 28 72 65 73 20 22 22 29 29 0a 20 20 20 20 28 69 (res "")). (i
0310: 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 f (not (eof-obje
0320: 63 74 3f 20 28 70 65 65 6b 2d 63 68 61 72 20 70 ct? (peek-char p
0330: 6f 72 74 29 29 29 0a 09 28 6c 6f 6f 70 20 28 63 ort)))..(loop (c
0340: 6f 6e 63 20 72 65 73 20 28 72 65 61 64 2d 63 68 onc res (read-ch
0350: 61 72 20 70 6f 72 74 29 29 29 0a 09 72 65 73 29 ar port)))..res)
0360: 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f ))..(define (pro
0370: 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 77 69 74 cess:cmd-run-wit
0380: 68 2d 73 74 64 65 72 72 2d 3e 6c 69 73 74 20 63 h-stderr->list c
0390: 6d 64 20 2e 20 70 61 72 61 6d 73 29 0a 20 20 3b md . params). ;
03a0: 3b 20 28 70 72 69 6e 74 20 22 43 61 6c 6c 65 64 ; (print "Called
03b0: 20 77 69 74 68 20 63 6d 64 3d 22 20 63 6d 64 20 with cmd=" cmd
03c0: 22 2c 20 70 72 6f 63 3d 22 20 70 72 6f 63 20 22 ", proc=" proc "
03d0: 2c 20 70 61 72 61 6d 73 3d 22 20 70 61 72 61 6d , params=" param
03e0: 73 29 0a 3b 3b 20 20 28 68 61 6e 64 6c 65 2d 65 s).;; (handle-e
03f0: 78 63 65 70 74 69 6f 6e 73 0a 3b 3b 20 20 20 65 xceptions.;; e
0400: 78 6e 0a 3b 3b 20 20 20 28 62 65 67 69 6e 0a 3b xn.;; (begin.;
0410: 3b 20 20 20 20 20 28 70 72 69 6e 74 20 22 45 52 ; (print "ER
0420: 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 6f 20 ROR: Failed to
0430: 72 75 6e 20 63 6f 6d 6d 61 6e 64 3a 20 22 20 63 run command: " c
0440: 6d 64 20 22 20 22 20 28 73 74 72 69 6e 67 2d 69 md " " (string-i
0450: 6e 74 65 72 73 70 65 72 73 65 20 70 61 72 61 6d ntersperse param
0460: 73 20 22 20 22 29 29 0a 3b 3b 20 20 20 20 20 28 s " ")).;; (
0470: 70 72 69 6e 74 20 22 20 20 20 20 20 20 20 22 20 print " "
0480: 28 28 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 ((condition-prop
0490: 65 72 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 erty-accessor 'e
04a0: 78 6e 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e xn 'message) exn
04b0: 29 29 0a 3b 3b 20 20 20 20 20 23 66 29 0a 20 20 )).;; #f).
04c0: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 (let-values (((
04d0: 66 68 20 66 68 6f 20 70 69 64 20 66 68 65 29 20 fh fho pid fhe)
04e0: 28 69 66 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d (if (null? param
04f0: 73 29 0a 09 09 09 09 20 20 20 20 20 20 28 70 72 s)..... (pr
0500: 6f 63 65 73 73 2a 20 63 6d 64 29 0a 09 09 09 09 ocess* cmd).....
0510: 20 20 20 20 20 20 28 70 72 6f 63 65 73 73 2a 20 (process*
0520: 63 6d 64 20 70 61 72 61 6d 73 29 29 29 29 0a 20 cmd params)))).
0530: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
0540: 28 28 63 75 72 72 20 28 72 65 61 64 2d 6c 69 6e ((curr (read-lin
0550: 65 20 66 68 29 29 0a 09 09 20 20 28 72 65 73 75 e fh))... (resu
0560: 6c 74 20 20 27 28 29 29 29 0a 09 20 28 6c 65 74 lt '())).. (let
0570: 20 28 28 65 72 72 73 74 72 20 28 70 72 6f 63 65 ((errstr (proce
0580: 73 73 3a 63 6f 6e 73 65 72 76 61 74 69 76 65 2d ss:conservative-
0590: 72 65 61 64 20 66 68 65 29 29 29 0a 09 20 20 20 read fhe)))..
05a0: 28 69 66 20 28 6e 6f 74 20 28 73 74 72 69 6e 67 (if (not (string
05b0: 3d 3f 20 65 72 72 73 74 72 20 22 22 29 29 0a 09 =? errstr ""))..
05c0: 20 20 20 20 20 20 20 28 73 65 74 21 20 72 65 73 (set! res
05d0: 75 6c 74 20 28 61 70 70 65 6e 64 20 72 65 73 75 ult (append resu
05e0: 6c 74 20 28 6c 69 73 74 20 65 72 72 73 74 72 29 lt (list errstr)
05f0: 29 29 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 )))). (if
0600: 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (not (eof-object
0610: 3f 20 63 75 72 72 29 29 0a 09 20 20 20 28 6c 6f ? curr)).. (lo
0620: 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 op (read-line fh
0630: 29 0a 09 09 20 28 61 70 70 65 6e 64 20 72 65 73 )... (append res
0640: 75 6c 74 20 28 6c 69 73 74 20 63 75 72 72 29 29 ult (list curr))
0650: 29 0a 09 20 20 20 28 62 65 67 69 6e 0a 09 20 20 ).. (begin..
0660: 20 20 20 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d (close-input-
0670: 70 6f 72 74 20 66 68 29 0a 09 20 20 20 20 20 28 port fh).. (
0680: 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 close-input-port
0690: 20 66 68 65 29 0a 09 20 20 20 20 20 28 63 6c 6f fhe).. (clo
06a0: 73 65 2d 6f 75 74 70 75 74 2d 70 6f 72 74 20 66 se-output-port f
06b0: 68 6f 29 0a 09 20 20 20 20 20 72 65 73 75 6c 74 ho).. result
06c0: 29 29 29 29 29 20 3b 3b 20 29 0a 0a 28 64 65 66 ))))) ;; )..(def
06d0: 69 6e 65 20 28 70 72 6f 63 65 73 73 3a 63 6d 64 ine (process:cmd
06e0: 2d 72 75 6e 2d 70 72 6f 63 2d 65 61 63 68 2d 6c -run-proc-each-l
06f0: 69 6e 65 20 63 6d 64 20 70 72 6f 63 20 2e 20 70 ine cmd proc . p
0700: 61 72 61 6d 73 29 0a 20 20 3b 3b 20 28 70 72 69 arams). ;; (pri
0710: 6e 74 20 22 43 61 6c 6c 65 64 20 77 69 74 68 20 nt "Called with
0720: 63 6d 64 3d 22 20 63 6d 64 20 22 2c 20 70 72 6f cmd=" cmd ", pro
0730: 63 3d 22 20 70 72 6f 63 20 22 2c 20 70 61 72 61 c=" proc ", para
0740: 6d 73 3d 22 20 70 61 72 61 6d 73 29 0a 20 20 28 ms=" params). (
0750: 68 61 6e 64 6c 65 2d 65 78 63 65 70 74 69 6f 6e handle-exception
0760: 73 0a 20 20 20 65 78 6e 0a 20 20 20 28 62 65 67 s. exn. (beg
0770: 69 6e 0a 20 20 20 20 20 28 70 72 69 6e 74 20 22 in. (print "
0780: 45 52 52 4f 52 3a 20 20 46 61 69 6c 65 64 20 74 ERROR: Failed t
0790: 6f 20 72 75 6e 20 63 6f 6d 6d 61 6e 64 3a 20 22 o run command: "
07a0: 20 63 6d 64 20 22 20 22 20 28 73 74 72 69 6e 67 cmd " " (string
07b0: 2d 69 6e 74 65 72 73 70 65 72 73 65 20 70 61 72 -intersperse par
07c0: 61 6d 73 20 22 20 22 29 29 0a 20 20 20 20 20 28 ams " ")). (
07d0: 64 65 62 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 debug:print 0 *d
07e0: 65 66 61 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a efault-log-port*
07f0: 20 22 20 6d 65 73 73 61 67 65 3a 20 22 20 28 28 " message: " ((
0800: 63 6f 6e 64 69 74 69 6f 6e 2d 70 72 6f 70 65 72 condition-proper
0810: 74 79 2d 61 63 63 65 73 73 6f 72 20 27 65 78 6e ty-accessor 'exn
0820: 20 27 6d 65 73 73 61 67 65 29 20 65 78 6e 29 29 'message) exn))
0830: 0a 20 20 20 20 20 28 64 65 62 75 67 3a 70 72 69 . (debug:pri
0840: 6e 74 20 35 20 2a 64 65 66 61 75 6c 74 2d 6c 6f nt 5 *default-lo
0850: 67 2d 70 6f 72 74 2a 20 22 65 78 6e 3d 22 20 28 g-port* "exn=" (
0860: 63 6f 6e 64 69 74 69 6f 6e 2d 3e 6c 69 73 74 20 condition->list
0870: 65 78 6e 29 29 0a 20 20 20 20 20 23 66 29 0a 20 exn)). #f).
0880: 20 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 (let-values ((
0890: 28 66 68 20 66 68 6f 20 70 69 64 29 20 28 69 66 (fh fho pid) (if
08a0: 20 28 6e 75 6c 6c 3f 20 70 61 72 61 6d 73 29 0a (null? params).
08b0: 09 09 09 09 20 20 28 70 72 6f 63 65 73 73 20 63 .... (process c
08c0: 6d 64 29 0a 09 09 09 09 20 20 28 70 72 6f 63 65 md)..... (proce
08d0: 73 73 20 63 6d 64 20 70 61 72 61 6d 73 29 29 29 ss cmd params)))
08e0: 29 0a 20 20 20 20 20 20 20 28 6c 65 74 20 6c 6f ). (let lo
08f0: 6f 70 20 28 28 63 75 72 72 20 28 72 65 61 64 2d op ((curr (read-
0900: 6c 69 6e 65 20 66 68 29 29 0a 09 09 28 72 65 73 line fh))...(res
0910: 75 6c 74 20 20 27 28 29 29 29 0a 20 20 20 20 20 ult '())).
0920: 20 20 28 69 66 20 28 6e 6f 74 20 28 65 6f 66 2d (if (not (eof-
0930: 6f 62 6a 65 63 74 3f 20 63 75 72 72 29 29 0a 09 object? curr))..
0940: 20 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c (loop (read-l
0950: 69 6e 65 20 66 68 29 0a 09 09 20 28 61 70 70 65 ine fh)... (appe
0960: 6e 64 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 nd result (list
0970: 28 70 72 6f 63 20 63 75 72 72 29 29 29 29 0a 09 (proc curr))))..
0980: 20 20 20 28 62 65 67 69 6e 0a 09 20 20 20 20 20 (begin..
0990: 28 63 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 6f 72 (close-input-por
09a0: 74 20 66 68 29 0a 09 20 20 20 20 20 28 63 6c 6f t fh).. (clo
09b0: 73 65 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 68 se-input-port fh
09c0: 65 29 0a 09 20 20 20 20 20 28 63 6c 6f 73 65 2d e).. (close-
09d0: 6f 75 74 70 75 74 2d 70 6f 72 74 20 66 68 6f 29 output-port fho)
09e0: 0a 09 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 .. result)))
09f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 )))..(define (pr
0a00: 6f 63 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 70 72 ocess:cmd-run-pr
0a10: 6f 63 2d 65 61 63 68 2d 6c 69 6e 65 2d 61 6c 74 oc-each-line-alt
0a20: 20 63 6d 64 20 70 72 6f 63 29 0a 20 20 28 6c 65 cmd proc). (le
0a30: 74 2a 20 28 28 66 68 20 28 6f 70 65 6e 2d 69 6e t* ((fh (open-in
0a40: 70 75 74 2d 70 69 70 65 20 63 6d 64 29 29 0a 20 put-pipe cmd)).
0a50: 20 20 20 20 20 20 20 20 28 72 65 73 20 28 70 6f (res (po
0a60: 72 74 2d 70 72 6f 63 2d 3e 6c 69 73 74 20 66 68 rt-proc->list fh
0a70: 20 70 72 6f 63 29 29 0a 20 20 20 20 20 20 20 20 proc)).
0a80: 20 28 73 74 61 74 75 73 20 28 63 6c 6f 73 65 2d (status (close-
0a90: 69 6e 70 75 74 2d 70 69 70 65 20 66 68 29 29 29 input-pipe fh)))
0aa0: 0a 20 20 20 20 28 69 66 20 28 65 71 3f 20 73 74 . (if (eq? st
0ab0: 61 74 75 73 20 30 29 20 72 65 73 20 23 66 29 29 atus 0) res #f))
0ac0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 6f 63 )..(define (proc
0ad0: 65 73 73 3a 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 ess:cmd-run->lis
0ae0: 74 20 63 6d 64 20 23 21 6b 65 79 20 28 64 65 6c t cmd #!key (del
0af0: 74 61 2d 65 6e 76 2d 61 6c 69 73 74 2d 6f 72 2d ta-env-alist-or-
0b00: 68 61 73 68 2d 74 61 62 6c 65 20 27 28 29 29 29 hash-table '()))
0b10: 0a 20 20 28 63 6f 6d 6d 6f 6e 3a 77 69 74 68 2d . (common:with-
0b20: 65 6e 76 2d 76 61 72 73 0a 20 20 20 64 65 6c 74 env-vars. delt
0b30: 61 2d 65 6e 76 2d 61 6c 69 73 74 2d 6f 72 2d 68 a-env-alist-or-h
0b40: 61 73 68 2d 74 61 62 6c 65 0a 20 20 20 28 6c 61 ash-table. (la
0b50: 6d 62 64 61 20 28 29 0a 20 20 20 20 20 28 6c 65 mbda (). (le
0b60: 74 2a 20 28 28 66 68 20 28 6f 70 65 6e 2d 69 6e t* ((fh (open-in
0b70: 70 75 74 2d 70 69 70 65 20 63 6d 64 29 29 0a 20 put-pipe cmd)).
0b80: 20 20 20 20 20 20 20 20 20 20 20 28 72 65 73 20 (res
0b90: 28 70 6f 72 74 2d 3e 6c 69 73 74 20 66 68 29 29 (port->list fh))
0ba0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 73 74 . (st
0bb0: 61 74 75 73 20 28 63 6c 6f 73 65 2d 69 6e 70 75 atus (close-inpu
0bc0: 74 2d 70 69 70 65 20 66 68 29 29 29 0a 20 20 20 t-pipe fh))).
0bd0: 20 20 20 20 28 6c 69 73 74 20 72 65 73 20 73 74 (list res st
0be0: 61 74 75 73 29 29 29 29 29 0a 20 20 20 0a 28 64 atus))))). .(d
0bf0: 65 66 69 6e 65 20 28 70 6f 72 74 2d 3e 6c 69 73 efine (port->lis
0c00: 74 20 66 68 29 0a 20 20 28 69 66 20 28 65 6f 66 t fh). (if (eof
0c10: 2d 6f 62 6a 65 63 74 3f 20 66 68 29 20 23 66 0a -object? fh) #f.
0c20: 20 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 (let loop
0c30: 28 28 63 75 72 72 20 28 72 65 61 64 2d 6c 69 6e ((curr (read-lin
0c40: 65 20 66 68 29 29 0a 20 20 20 20 20 20 20 20 20 e fh)).
0c50: 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 20 (result
0c60: 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 28 69 '())). (i
0c70: 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 f (not (eof-obje
0c80: 63 74 3f 20 63 75 72 72 29 29 0a 20 20 20 20 20 ct? curr)).
0c90: 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 72 65 (loop (re
0ca0: 61 64 2d 6c 69 6e 65 20 66 68 29 0a 20 20 20 20 ad-line fh).
0cb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 61 (a
0cc0: 70 70 65 6e 64 20 72 65 73 75 6c 74 20 28 6c 69 ppend result (li
0cd0: 73 74 20 63 75 72 72 29 29 29 0a 20 20 20 20 20 st curr))).
0ce0: 20 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 29 result)))
0cf0: 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 6f 72 74 )..(define (port
0d00: 2d 70 72 6f 63 2d 3e 6c 69 73 74 20 66 68 20 70 -proc->list fh p
0d10: 72 6f 63 29 0a 20 20 28 69 66 20 28 65 6f 66 2d roc). (if (eof-
0d20: 6f 62 6a 65 63 74 3f 20 66 68 29 20 23 66 0a 20 object? fh) #f.
0d30: 20 20 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 (let loop (
0d40: 28 63 75 72 72 20 28 70 72 6f 63 20 28 72 65 61 (curr (proc (rea
0d50: 64 2d 6c 69 6e 65 20 66 68 29 29 29 0a 20 20 20 d-line fh))).
0d60: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 72 (r
0d70: 65 73 75 6c 74 20 27 28 29 29 29 0a 20 20 20 20 esult '())).
0d80: 20 20 20 20 28 69 66 20 28 6e 6f 74 20 28 65 6f (if (not (eo
0d90: 66 2d 6f 62 6a 65 63 74 3f 20 63 75 72 72 29 29 f-object? curr))
0da0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 28 6c 6f . (lo
0db0: 6f 70 20 28 6c 65 74 20 28 28 6c 20 28 72 65 61 op (let ((l (rea
0dc0: 64 2d 6c 69 6e 65 20 66 68 29 29 29 0a 20 20 20 d-line fh))).
0dd0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0de0: 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (if (eof-object
0df0: 3f 20 6c 29 20 6c 20 28 70 72 6f 63 20 6c 29 29 ? l) l (proc l))
0e00: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ).
0e10: 20 20 20 20 28 61 70 70 65 6e 64 20 72 65 73 75 (append resu
0e20: 6c 74 20 28 6c 69 73 74 20 63 75 72 72 29 29 29 lt (list curr)))
0e30: 0a 20 20 20 20 20 20 20 20 20 20 20 20 72 65 73 . res
0e40: 75 6c 74 29 29 29 29 0a 0a 3b 3b 20 68 65 72 65 ult))))..;; here
0e50: 20 69 73 20 61 6e 20 65 78 61 6d 70 6c 65 20 6c is an example l
0e60: 69 6e 65 20 77 68 65 72 65 20 74 68 65 20 73 68 ine where the sh
0e70: 65 6c 6c 20 69 73 20 73 68 20 6f 72 20 62 61 73 ell is sh or bas
0e80: 68 0a 3b 3b 20 22 66 69 6e 64 20 2f 20 2d 70 72 h.;; "find / -pr
0e90: 69 6e 74 20 32 26 3e 31 20 3e 20 66 69 6e 64 61 int 2&>1 > finda
0ea0: 6c 6c 2e 6c 6f 67 22 0a 28 64 65 66 69 6e 65 20 ll.log".(define
0eb0: 28 72 75 6e 2d 6e 2d 77 61 69 74 20 63 6d 64 6c (run-n-wait cmdl
0ec0: 69 6e 65 20 23 21 6b 65 79 20 28 70 61 72 61 6d ine #!key (param
0ed0: 73 20 23 66 29 28 70 72 69 6e 74 2d 63 6d 64 20 s #f)(print-cmd
0ee0: 23 66 29 29 0a 20 20 28 69 66 20 70 72 69 6e 74 #f)). (if print
0ef0: 2d 63 6d 64 20 0a 20 20 20 20 20 20 28 64 65 62 -cmd . (deb
0f00: 75 67 3a 70 72 69 6e 74 20 30 20 2a 64 65 66 61 ug:print 0 *defa
0f10: 75 6c 74 2d 6c 6f 67 2d 70 6f 72 74 2a 20 0a 09 ult-log-port* ..
0f20: 09 20 20 20 28 69 66 20 28 73 74 72 69 6e 67 3f . (if (string?
0f30: 20 70 72 69 6e 74 2d 63 6d 64 29 0a 09 09 20 20 print-cmd)...
0f40: 20 20 20 20 20 70 72 69 6e 74 2d 63 6d 64 0a 09 print-cmd..
0f50: 09 20 20 20 20 20 20 20 22 22 29 0a 09 09 20 20 . "")...
0f60: 20 63 6d 64 6c 69 6e 65 0a 09 09 20 20 20 28 69 cmdline... (i
0f70: 66 20 70 61 72 61 6d 73 0a 09 09 20 20 20 20 20 f params...
0f80: 20 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 (string-inters
0f90: 70 65 72 73 65 20 70 61 72 61 6d 73 20 22 20 22 perse params " "
0fa0: 29 0a 09 09 20 20 20 20 20 20 20 22 22 29 29 29 )... "")))
0fb0: 0a 20 20 28 6c 65 74 20 28 28 70 69 64 20 28 69 . (let ((pid (i
0fc0: 66 20 70 61 72 61 6d 73 0a 09 09 20 28 70 72 6f f params... (pro
0fd0: 63 65 73 73 2d 72 75 6e 20 63 6d 64 6c 69 6e 65 cess-run cmdline
0fe0: 20 70 61 72 61 6d 73 29 0a 09 09 20 28 70 72 6f params)... (pro
0ff0: 63 65 73 73 2d 72 75 6e 20 63 6d 64 6c 69 6e 65 cess-run cmdline
1000: 29 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f )))). (let lo
1010: 6f 70 20 28 28 69 20 30 29 29 0a 20 20 20 20 20 op ((i 0)).
1020: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 (let-values (((
1030: 70 69 64 2d 76 61 6c 20 65 78 69 74 2d 73 74 61 pid-val exit-sta
1040: 74 75 73 20 65 78 69 74 2d 63 6f 64 65 29 20 28 tus exit-code) (
1050: 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 69 64 process-wait pid
1060: 20 23 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 #t))).
1070: 28 69 66 20 28 65 71 3f 20 70 69 64 2d 76 61 6c (if (eq? pid-val
1080: 20 30 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0).. (begin
1090: 0a 09 20 20 20 20 20 20 20 28 74 68 72 65 61 64 .. (thread
10a0: 2d 73 6c 65 65 70 21 20 32 29 0a 09 20 20 20 20 -sleep! 2)..
10b0: 20 20 20 28 6c 6f 6f 70 20 28 2b 20 69 20 31 29 (loop (+ i 1)
10c0: 29 29 0a 09 20 20 20 20 20 28 76 61 6c 75 65 73 )).. (values
10d0: 20 70 69 64 2d 76 61 6c 20 65 78 69 74 2d 73 74 pid-val exit-st
10e0: 61 74 75 73 20 65 78 69 74 2d 63 6f 64 65 29 29 atus exit-code))
10f0: 29 29 29 29 0a 20 20 0a 3b 3b 3d 3d 3d 3d 3d 3d )))). .;;======
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: 0a 3b 3b 20 4d 49 53 43 20 50 52 4f 43 45 53 53 .;; MISC PROCESS
1150: 20 52 45 4c 41 54 45 44 20 53 54 55 46 46 0a 3b RELATED STUFF.;
1160: 3b 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ;===============
1170: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1180: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
1190: 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d 3d ================
11a0: 3d 3d 3d 3d 3d 3d 3d 0a 0a 28 64 65 66 69 6e 65 =======..(define
11b0: 20 28 70 72 6f 63 65 73 73 3a 63 68 69 6c 64 72 (process:childr
11c0: 65 6e 20 70 72 6f 63 29 0a 20 20 28 77 69 74 68 en proc). (with
11d0: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
11e0: 0a 20 20 20 28 63 6f 6e 63 20 22 70 73 20 68 20 . (conc "ps h
11f0: 2d 2d 70 70 69 64 20 22 20 28 63 75 72 72 65 6e --ppid " (curren
1200: 74 2d 70 72 6f 63 65 73 73 2d 69 64 29 20 22 20 t-process-id) "
1210: 2d 6f 20 70 69 64 22 29 0a 20 20 20 28 6c 61 6d -o pid"). (lam
1220: 62 64 61 20 28 29 0a 20 20 20 20 20 28 6c 65 74 bda (). (let
1230: 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 65 61 loop ((inl (rea
1240: 64 2d 6c 69 6e 65 29 29 0a 09 09 28 72 65 73 20 d-line))...(res
1250: 27 28 29 29 29 0a 20 20 20 20 20 20 20 28 69 66 '())). (if
1260: 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 69 6e (eof-object? in
1270: 6c 29 0a 09 20 20 20 28 72 65 76 65 72 73 65 20 l).. (reverse
1280: 72 65 73 29 0a 09 20 20 20 28 6c 65 74 20 28 28 res).. (let ((
1290: 70 69 64 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d pid (string->num
12a0: 62 65 72 20 69 6e 6c 29 29 29 0a 09 20 20 20 20 ber inl)))..
12b0: 20 28 69 66 20 70 72 6f 63 20 28 70 72 6f 63 20 (if proc (proc
12c0: 70 69 64 29 29 0a 09 20 20 20 20 20 28 6c 6f 6f pid)).. (loo
12d0: 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 20 28 63 p (read-line) (c
12e0: 6f 6e 73 20 70 69 64 20 72 65 73 29 29 29 29 29 ons pid res)))))
12f0: 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 28 70 72 )))..(define (pr
1300: 6f 63 65 73 73 3a 61 6c 69 76 65 3f 20 70 69 64 ocess:alive? pid
1310: 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 78 63 65 ). (handle-exce
1320: 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e 0a 20 20 ptions. exn.
1330: 20 3b 3b 20 70 6f 73 73 69 62 6c 79 20 70 69 64 ;; possibly pid
1340: 20 69 73 20 61 20 70 72 6f 63 65 73 73 20 6e 6f is a process no
1350: 74 20 61 20 63 68 69 6c 64 2c 20 6c 6f 6f 6b 20 t a child, look
1360: 69 6e 20 2f 70 72 6f 63 20 74 6f 20 73 65 65 20 in /proc to see
1370: 69 66 20 69 74 20 69 73 20 72 75 6e 6e 69 6e 67 if it is running
1380: 20 73 74 69 6c 6c 0a 20 20 20 28 63 6f 6d 6d 6f still. (commo
1390: 6e 3a 66 69 6c 65 2d 65 78 69 73 74 73 3f 20 28 n:file-exists? (
13a0: 63 6f 6e 63 20 22 2f 70 72 6f 63 2f 22 20 70 69 conc "/proc/" pi
13b0: 64 29 29 0a 20 20 20 28 6c 65 74 2d 76 61 6c 75 d)). (let-valu
13c0: 65 73 20 28 28 28 72 70 69 64 20 65 78 69 74 2d es (((rpid exit-
13d0: 74 79 70 65 20 65 78 69 74 2d 73 69 67 6e 61 6c type exit-signal
13e0: 29 28 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 )(process-wait p
13f0: 69 64 20 23 74 29 29 29 0a 20 20 20 20 20 20 20 id #t))).
1400: 28 61 6e 64 20 28 6e 75 6d 62 65 72 3f 20 72 70 (and (number? rp
1410: 69 64 29 0a 09 20 20 20 20 28 65 71 75 61 6c 3f id).. (equal?
1420: 20 72 70 69 64 20 70 69 64 29 29 29 29 29 0a 0a rpid pid)))))..
1430: 28 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 73 (define (process
1440: 3a 61 6c 69 76 65 2d 6f 6e 2d 68 6f 73 74 3f 20 :alive-on-host?
1450: 68 6f 73 74 20 70 69 64 29 0a 20 20 28 6c 65 74 host pid). (let
1460: 20 28 28 63 6d 64 20 28 63 6f 6e 63 20 22 73 73 ((cmd (conc "ss
1470: 68 20 22 20 68 6f 73 74 20 22 20 70 73 20 2d 6f h " host " ps -o
1480: 20 70 69 64 3d 20 2d 70 20 22 20 70 69 64 29 29 pid= -p " pid))
1490: 29 0a 20 20 20 20 28 68 61 6e 64 6c 65 2d 65 78 ). (handle-ex
14a0: 63 65 70 74 69 6f 6e 73 0a 20 20 20 20 20 65 78 ceptions. ex
14b0: 6e 0a 20 20 20 20 20 23 66 20 3b 3b 20 61 6e 79 n. #f ;; any
14c0: 74 68 69 6e 67 20 67 6f 65 73 20 77 72 6f 6e 67 thing goes wrong
14d0: 20 2d 20 61 73 73 75 6d 65 20 74 68 65 20 70 72 - assume the pr
14e0: 6f 63 65 73 73 20 69 6e 20 4e 4f 54 20 72 75 6e ocess in NOT run
14f0: 6e 69 6e 67 2e 0a 20 20 20 20 20 28 77 69 74 68 ning.. (with
1500: 2d 69 6e 70 75 74 2d 66 72 6f 6d 2d 70 69 70 65 -input-from-pipe
1510: 20 0a 20 20 20 20 20 20 63 6d 64 0a 20 20 20 20 . cmd.
1520: 20 20 28 6c 61 6d 62 64 61 20 28 29 0a 09 28 6c (lambda ()..(l
1530: 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 et loop ((inl (r
1540: 65 61 64 2d 6c 69 6e 65 29 29 29 0a 09 20 20 28 ead-line))).. (
1550: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
1560: 69 6e 6c 29 0a 09 20 20 20 20 20 20 23 66 0a 09 inl).. #f..
1570: 20 20 20 20 20 20 28 6c 65 74 2a 20 28 28 63 6c (let* ((cl
1580: 65 61 6e 2d 73 74 72 20 28 73 74 72 69 6e 67 2d ean-str (string-
1590: 73 75 62 73 74 69 74 75 74 65 20 22 5e 5b 5e 5c substitute "^[^\
15a0: 5c 64 5d 2a 28 5b 30 2d 39 5d 2b 29 5b 5e 5c 5c \d]*([0-9]+)[^\\
15b0: 64 5d 2a 24 22 20 22 5c 5c 31 22 20 69 6e 6c 29 d]*$" "\\1" inl)
15c0: 29 0a 09 09 20 20 20 20 20 28 69 6e 6e 75 6d 20 )... (innum
15d0: 20 20 20 20 28 73 74 72 69 6e 67 2d 3e 6e 75 6d (string->num
15e0: 62 65 72 20 63 6c 65 61 6e 2d 73 74 72 29 29 29 ber clean-str)))
15f0: 0a 09 09 28 61 6e 64 20 69 6e 6e 75 6d 0a 09 09 ...(and innum...
1600: 20 20 20 20 20 28 65 71 3f 20 70 69 64 20 69 6e (eq? pid in
1610: 6e 75 6d 29 29 29 29 29 29 29 29 29 29 0a 0a 28 num))))))))))..(
1620: 64 65 66 69 6e 65 20 28 70 72 6f 63 65 73 73 3a define (process:
1630: 67 65 74 2d 73 75 62 2d 70 69 64 73 20 70 69 64 get-sub-pids pid
1640: 29 0a 20 20 28 77 69 74 68 2d 69 6e 70 75 74 2d ). (with-input-
1650: 66 72 6f 6d 2d 70 69 70 65 0a 20 20 20 28 63 6f from-pipe. (co
1660: 6e 63 20 22 70 73 74 72 65 65 20 2d 41 20 2d 70 nc "pstree -A -p
1670: 20 22 20 70 69 64 29 20 3b 3b 20 7c 20 74 72 20 " pid) ;; | tr
1680: 27 61 2d 7a 5c 5c 2d 2b 60 28 29 5c 5c 2e 27 20 'a-z\\-+`()\\.'
1690: 27 20 27 20 22 20 70 69 64 29 0a 20 20 20 28 6c ' ' " pid). (l
16a0: 61 6d 62 64 61 20 28 29 0a 20 20 20 20 20 28 6c ambda (). (l
16b0: 65 74 20 6c 6f 6f 70 20 28 28 69 6e 6c 20 28 72 et loop ((inl (r
16c0: 65 61 64 2d 6c 69 6e 65 29 29 0a 09 09 28 72 65 ead-line))...(re
16d0: 73 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 28 s '())). (
16e0: 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 if (eof-object?
16f0: 69 6e 6c 29 0a 09 20 20 20 28 72 65 76 65 72 73 inl).. (revers
1700: 65 20 72 65 73 29 0a 09 20 20 20 28 6c 65 74 20 e res).. (let
1710: 28 28 6e 75 6d 73 20 28 6d 61 70 20 73 74 72 69 ((nums (map stri
1720: 6e 67 2d 3e 6e 75 6d 62 65 72 0a 09 09 09 20 20 ng->number....
1730: 20 20 28 73 74 72 69 6e 67 2d 73 70 6c 69 74 2d (string-split-
1740: 66 69 65 6c 64 73 20 22 5c 5c 64 2b 22 20 69 6e fields "\\d+" in
1750: 6c 29 29 29 29 0a 09 20 20 20 20 20 28 6c 6f 6f l)))).. (loo
1760: 70 20 28 72 65 61 64 2d 6c 69 6e 65 29 0a 09 09 p (read-line)...
1770: 20 20 20 28 61 70 70 65 6e 64 20 72 65 73 20 6e (append res n
1780: 75 6d 73 29 29 29 29 29 29 29 29 0a ums)))))))).