Commit | Line | Data |
---|---|---|
51786bda JB |
1 | ;; popen emulation, for non-stdio based ports. |
2 | ||
3 | (define-module (ice-9 popen)) | |
4 | ||
5 | ;; (define-module (guile popen) | |
6 | ;; :use-module (guile posix)) | |
7 | ||
8 | ;; a guardian to ensure the cleanup is done correctly when | |
9 | ;; an open pipe is gc'd or a close-port is used. | |
10 | (define pipe-guardian (make-guardian)) | |
11 | ||
12 | ;; a weak hash-table to store the process ids. | |
13 | (define port/pid-table (make-weak-key-hash-table 31)) | |
14 | ||
15 | ;; run a process connected to an input or output port. | |
16 | ;; mode: OPEN_READ or OPEN_WRITE. | |
17 | ;; returns port/pid pair. | |
18 | (define (open-process mode prog . args) | |
19 | (let ((p (pipe)) | |
20 | (reading (string=? mode OPEN_READ))) | |
21 | (setvbuf (cdr p) _IONBF) | |
22 | (let ((pid (primitive-fork))) | |
23 | (cond ((= pid 0) | |
24 | ;; child | |
25 | (set-batch-mode?! #t) | |
26 | (if reading | |
27 | (close-port (car p)) | |
28 | (close-port (cdr p))) | |
29 | (move->fdes (if reading (cdr p) (car p)) | |
30 | (if reading 1 0)) | |
31 | (apply execlp prog prog args)) | |
32 | (else | |
33 | ;; parent | |
34 | (if reading | |
35 | (close-port (cdr p)) | |
36 | (close-port (car p))) | |
37 | (cons (if reading | |
38 | (car p) | |
39 | (cdr p)) | |
40 | pid)))))) | |
41 | ||
42 | (define-public (open-pipe command mode) | |
43 | (let* ((port/pid (open-process mode "/bin/sh" "-c" command)) | |
44 | (port (car port/pid))) | |
45 | (pipe-guardian port) | |
46 | (hashq-set! port/pid-table port (cdr port/pid)) | |
47 | port)) | |
48 | ||
49 | (define (fetch-pid port) | |
50 | (let ((pid (hashq-ref port/pid-table port))) | |
51 | (hashq-remove! port/pid-table port) | |
52 | pid)) | |
53 | ||
54 | (define (close-process port/pid) | |
55 | (close-port (car port/pid)) | |
56 | (cdr (waitpid (cdr port/pid)))) | |
57 | ||
58 | (define-public (close-pipe p) | |
59 | (let ((pid (fetch-pid p))) | |
60 | (if (not pid) | |
61 | (error "close-pipe: pipe not in table")) | |
62 | (close-process (cons p pid)))) | |
63 | ||
64 | (define reap-pipes | |
65 | (lambda () | |
66 | (let loop ((p (pipe-guardian))) | |
67 | (cond (p | |
68 | ;; maybe removed already by close-pipe. | |
69 | (let ((pid (fetch-pid p))) | |
70 | (if pid | |
71 | (close-process (cons p pid)))) | |
72 | (loop (pipe-guardian))))))) | |
73 | ||
74 | (set! gc-thunk | |
75 | (let ((old-thunk gc-thunk)) | |
76 | (lambda () | |
77 | (if old-thunk (old-thunk)) | |
78 | (reap-pipes)))) | |
79 | ||
80 | ;; (add-hook! after-gc-hook reap-pipes) | |
81 | ||
82 | (define-public (open-input-pipe command) (open-pipe command OPEN_READ)) | |
83 | (define-public (open-output-pipe command) (open-pipe command OPEN_WRITE)) |