Artifact 71a058a91cd7728b27ab41b46552f4c7d64ecdad:
- File process.scm — part of check-in [0a116daff3] at 2012-04-01 23:29:41 on branch trunk — Updated copyrights (user: mrwellan size: 2663)
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 64 65 63 6c 61 ========..(decla 0290: 72 65 20 28 75 6e 69 74 20 70 72 6f 63 65 73 73 re (unit process 02a0: 29 29 0a 28 64 65 63 6c 61 72 65 20 28 75 73 65 )).(declare (use 02b0: 73 20 63 6f 6d 6d 6f 6e 29 29 0a 0a 28 64 65 66 s common))..(def 02c0: 69 6e 65 20 28 63 6d 64 2d 72 75 6e 2d 70 72 6f ine (cmd-run-pro 02d0: 63 2d 65 61 63 68 2d 6c 69 6e 65 20 63 6d 64 20 c-each-line cmd 02e0: 70 72 6f 63 20 2e 20 70 61 72 61 6d 73 29 0a 20 proc . params). 02f0: 20 3b 3b 20 28 70 72 69 6e 74 20 22 43 61 6c 6c ;; (print "Call 0300: 65 64 20 77 69 74 68 20 63 6d 64 3d 22 20 63 6d ed with cmd=" cm 0310: 64 20 22 2c 20 70 72 6f 63 3d 22 20 70 72 6f 63 d ", proc=" proc 0320: 20 22 2c 20 70 61 72 61 6d 73 3d 22 20 70 61 72 ", params=" par 0330: 61 6d 73 29 0a 20 20 28 68 61 6e 64 6c 65 2d 65 ams). (handle-e 0340: 78 63 65 70 74 69 6f 6e 73 0a 20 20 20 65 78 6e xceptions. exn 0350: 0a 20 20 20 28 62 65 67 69 6e 0a 20 20 20 20 20 . (begin. 0360: 28 70 72 69 6e 74 20 22 45 52 52 4f 52 3a 20 20 (print "ERROR: 0370: 46 61 69 6c 65 64 20 74 6f 20 72 75 6e 20 63 6f Failed to run co 0380: 6d 6d 61 6e 64 3a 20 22 20 63 6d 64 20 22 20 22 mmand: " cmd " " 0390: 20 28 73 74 72 69 6e 67 2d 69 6e 74 65 72 73 70 (string-intersp 03a0: 65 72 73 65 20 70 61 72 61 6d 73 20 22 20 22 29 erse params " ") 03b0: 29 0a 20 20 20 20 20 23 66 29 0a 20 20 20 28 6c ). #f). (l 03c0: 65 74 2d 76 61 6c 75 65 73 20 28 28 28 66 68 20 et-values (((fh 03d0: 66 68 6f 20 70 69 64 29 20 28 69 66 20 28 6e 75 fho pid) (if (nu 03e0: 6c 6c 3f 20 70 61 72 61 6d 73 29 0a 09 09 09 09 ll? params)..... 03f0: 20 20 28 70 72 6f 63 65 73 73 20 63 6d 64 29 0a (process cmd). 0400: 09 09 09 09 20 20 28 70 72 6f 63 65 73 73 20 63 .... (process c 0410: 6d 64 20 70 61 72 61 6d 73 29 29 29 29 0a 20 20 md params)))). 0420: 20 20 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 (let loop ((c 0430: 75 72 72 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 urr (read-line f 0440: 68 29 29 0a 09 09 28 72 65 73 75 6c 74 20 20 27 h))...(result ' 0450: 28 29 29 29 0a 20 20 20 20 20 20 20 28 69 66 20 ())). (if 0460: 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 (not (eof-object 0470: 3f 20 63 75 72 72 29 29 0a 09 20 20 20 28 6c 6f ? curr)).. (lo 0480: 6f 70 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 op (read-line fh 0490: 29 0a 09 09 20 28 61 70 70 65 6e 64 20 72 65 73 )... (append res 04a0: 75 6c 74 20 28 6c 69 73 74 20 28 70 72 6f 63 20 ult (list (proc 04b0: 63 75 72 72 29 29 29 29 0a 09 20 20 20 28 62 65 curr)))).. (be 04c0: 67 69 6e 0a 09 20 20 20 20 20 28 63 6c 6f 73 65 gin.. (close 04d0: 2d 69 6e 70 75 74 2d 70 6f 72 74 20 66 68 29 0a -input-port fh). 04e0: 09 20 20 20 20 20 28 63 6c 6f 73 65 2d 6f 75 74 . (close-out 04f0: 70 75 74 2d 70 6f 72 74 20 66 68 6f 29 0a 09 20 put-port fho).. 0500: 20 20 20 20 72 65 73 75 6c 74 29 29 29 29 29 29 result)))))) 0510: 0a 0a 28 64 65 66 69 6e 65 20 28 63 6d 64 2d 72 ..(define (cmd-r 0520: 75 6e 2d 70 72 6f 63 2d 65 61 63 68 2d 6c 69 6e un-proc-each-lin 0530: 65 2d 61 6c 74 20 63 6d 64 20 70 72 6f 63 29 0a e-alt cmd proc). 0540: 20 20 28 6c 65 74 2a 20 28 28 66 68 20 28 6f 70 (let* ((fh (op 0550: 65 6e 2d 69 6e 70 75 74 2d 70 69 70 65 20 63 6d en-input-pipe cm 0560: 64 29 29 0a 20 20 20 20 20 20 20 20 20 28 72 65 d)). (re 0570: 73 20 28 70 6f 72 74 2d 70 72 6f 63 2d 3e 6c 69 s (port-proc->li 0580: 73 74 20 66 68 20 70 72 6f 63 29 29 0a 20 20 20 st fh proc)). 0590: 20 20 20 20 20 20 28 73 74 61 74 75 73 20 28 63 (status (c 05a0: 6c 6f 73 65 2d 69 6e 70 75 74 2d 70 69 70 65 20 lose-input-pipe 05b0: 66 68 29 29 29 0a 20 20 20 20 28 69 66 20 28 65 fh))). (if (e 05c0: 71 3f 20 73 74 61 74 75 73 20 30 29 20 72 65 73 q? status 0) res 05d0: 20 23 66 29 29 29 0a 0a 28 64 65 66 69 6e 65 20 #f)))..(define 05e0: 28 63 6d 64 2d 72 75 6e 2d 3e 6c 69 73 74 20 63 (cmd-run->list c 05f0: 6d 64 29 0a 20 20 28 6c 65 74 2a 20 28 28 66 68 md). (let* ((fh 0600: 20 28 6f 70 65 6e 2d 69 6e 70 75 74 2d 70 69 70 (open-input-pip 0610: 65 20 63 6d 64 29 29 0a 20 20 20 20 20 20 20 20 e cmd)). 0620: 20 28 72 65 73 20 28 70 6f 72 74 2d 3e 6c 69 73 (res (port->lis 0630: 74 20 66 68 29 29 0a 20 20 20 20 20 20 20 20 20 t fh)). 0640: 28 73 74 61 74 75 73 20 28 63 6c 6f 73 65 2d 69 (status (close-i 0650: 6e 70 75 74 2d 70 69 70 65 20 66 68 29 29 29 0a nput-pipe fh))). 0660: 20 20 20 20 28 6c 69 73 74 20 72 65 73 20 73 74 (list res st 0670: 61 74 75 73 29 29 29 0a 0a 28 64 65 66 69 6e 65 atus)))..(define 0680: 20 28 70 6f 72 74 2d 3e 6c 69 73 74 20 66 68 29 (port->list fh) 0690: 0a 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 . (if (eof-obje 06a0: 63 74 3f 20 66 68 29 20 23 66 0a 20 20 20 20 20 ct? fh) #f. 06b0: 20 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 75 72 (let loop ((cur 06c0: 72 20 28 72 65 61 64 2d 6c 69 6e 65 20 66 68 29 r (read-line fh) 06d0: 29 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ). 06e0: 20 20 20 28 72 65 73 75 6c 74 20 27 28 29 29 29 (result '())) 06f0: 0a 20 20 20 20 20 20 20 20 28 69 66 20 28 6e 6f . (if (no 0700: 74 20 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 63 t (eof-object? c 0710: 75 72 72 29 29 0a 20 20 20 20 20 20 20 20 20 20 urr)). 0720: 20 20 28 6c 6f 6f 70 20 28 72 65 61 64 2d 6c 69 (loop (read-li 0730: 6e 65 20 66 68 29 0a 20 20 20 20 20 20 20 20 20 ne fh). 0740: 20 20 20 20 20 20 20 20 20 28 61 70 70 65 6e 64 (append 0750: 20 72 65 73 75 6c 74 20 28 6c 69 73 74 20 63 75 result (list cu 0760: 72 72 29 29 29 0a 20 20 20 20 20 20 20 20 20 20 rr))). 0770: 20 20 72 65 73 75 6c 74 29 29 29 29 0a 0a 28 64 result))))..(d 0780: 65 66 69 6e 65 20 28 70 6f 72 74 2d 70 72 6f 63 efine (port-proc 0790: 2d 3e 6c 69 73 74 20 66 68 20 70 72 6f 63 29 0a ->list fh proc). 07a0: 20 20 28 69 66 20 28 65 6f 66 2d 6f 62 6a 65 63 (if (eof-objec 07b0: 74 3f 20 66 68 29 20 23 66 0a 20 20 20 20 20 20 t? fh) #f. 07c0: 28 6c 65 74 20 6c 6f 6f 70 20 28 28 63 75 72 72 (let loop ((curr 07d0: 20 28 70 72 6f 63 20 28 72 65 61 64 2d 6c 69 6e (proc (read-lin 07e0: 65 20 66 68 29 29 29 0a 20 20 20 20 20 20 20 20 e fh))). 07f0: 20 20 20 20 20 20 20 20 20 28 72 65 73 75 6c 74 (result 0800: 20 27 28 29 29 29 0a 20 20 20 20 20 20 20 20 28 '())). ( 0810: 69 66 20 28 6e 6f 74 20 28 65 6f 66 2d 6f 62 6a if (not (eof-obj 0820: 65 63 74 3f 20 63 75 72 72 29 29 0a 20 20 20 20 ect? curr)). 0830: 20 20 20 20 20 20 20 20 28 6c 6f 6f 70 20 28 6c (loop (l 0840: 65 74 20 28 28 6c 20 28 72 65 61 64 2d 6c 69 6e et ((l (read-lin 0850: 65 20 66 68 29 29 29 0a 20 20 20 20 20 20 20 20 e fh))). 0860: 20 20 20 20 20 20 20 20 20 20 20 20 28 69 66 20 (if 0870: 28 65 6f 66 2d 6f 62 6a 65 63 74 3f 20 6c 29 20 (eof-object? l) 0880: 6c 20 28 70 72 6f 63 20 6c 29 29 29 0a 20 20 20 l (proc l))). 0890: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 28 ( 08a0: 61 70 70 65 6e 64 20 72 65 73 75 6c 74 20 28 6c append result (l 08b0: 69 73 74 20 63 75 72 72 29 29 29 0a 20 20 20 20 ist curr))). 08c0: 20 20 20 20 20 20 20 20 72 65 73 75 6c 74 29 29 result)) 08d0: 29 29 0a 0a 3b 3b 20 68 65 72 65 20 69 73 20 61 ))..;; here is a 08e0: 6e 20 65 78 61 6d 70 6c 65 20 6c 69 6e 65 20 77 n example line w 08f0: 68 65 72 65 20 74 68 65 20 73 68 65 6c 6c 20 69 here the shell i 0900: 73 20 73 68 20 6f 72 20 62 61 73 68 0a 3b 3b 20 s sh or bash.;; 0910: 22 66 69 6e 64 20 2f 20 2d 70 72 69 6e 74 20 32 "find / -print 2 0920: 26 3e 31 20 3e 20 66 69 6e 64 61 6c 6c 2e 6c 6f &>1 > findall.lo 0930: 67 22 0a 28 64 65 66 69 6e 65 20 28 72 75 6e 2d g".(define (run- 0940: 6e 2d 77 61 69 74 20 63 6d 64 6c 69 6e 65 29 0a n-wait cmdline). 0950: 20 20 28 6c 65 74 20 28 28 70 69 64 20 28 70 72 (let ((pid (pr 0960: 6f 63 65 73 73 2d 72 75 6e 20 63 6d 64 6c 69 6e ocess-run cmdlin 0970: 65 29 29 29 0a 20 20 20 20 28 6c 65 74 20 6c 6f e))). (let lo 0980: 6f 70 20 28 28 69 20 30 29 29 0a 20 20 20 20 20 op ((i 0)). 0990: 20 28 6c 65 74 2d 76 61 6c 75 65 73 20 28 28 28 (let-values ((( 09a0: 70 69 64 2d 76 61 6c 20 65 78 69 74 2d 73 74 61 pid-val exit-sta 09b0: 74 75 73 20 65 78 69 74 2d 63 6f 64 65 29 20 28 tus exit-code) ( 09c0: 70 72 6f 63 65 73 73 2d 77 61 69 74 20 70 69 64 process-wait pid 09d0: 20 23 74 29 29 29 0a 20 20 20 20 20 20 20 20 20 #t))). 09e0: 28 69 66 20 28 65 71 3f 20 70 69 64 2d 76 61 6c (if (eq? pid-val 09f0: 20 30 29 0a 09 20 20 20 20 20 28 62 65 67 69 6e 0).. (begin 0a00: 0a 09 20 20 20 20 20 20 20 28 74 68 72 65 61 64 .. (thread 0a10: 2d 73 6c 65 65 70 21 20 32 29 0a 09 20 20 20 20 -sleep! 2).. 0a20: 20 20 20 28 6c 6f 6f 70 20 28 2b 20 69 20 31 29 (loop (+ i 1) 0a30: 29 29 0a 09 20 20 20 20 20 28 76 61 6c 75 65 73 )).. (values 0a40: 20 70 69 64 2d 76 61 6c 20 65 78 69 74 2d 73 74 pid-val exit-st 0a50: 61 74 75 73 20 65 78 69 74 2d 63 6f 64 65 29 29 atus exit-code)) 0a60: 29 29 29 29 0a 20 20 )))).