1 ;; popen emulation, for non-stdio based ports.
3 (define-module (ice-9 popen))
5 ;; (define-module (guile popen)
6 ;; :use-module (guile posix))
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))
12 ;; a weak hash-table to store the process ids.
13 (define port/pid-table (make-weak-key-hash-table 31))
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)
20 (reading (string=? mode OPEN_READ)))
21 (setvbuf (cdr p) _IONBF)
22 (let ((pid (primitive-fork)))
29 (move->fdes (if reading (cdr p) (car p))
31 (apply execlp prog prog args))
42 (define-public (open-pipe command mode)
43 (let* ((port/pid (open-process mode "/bin/sh" "-c" command))
44 (port (car port/pid)))
46 (hashq-set! port/pid-table port (cdr port/pid))
49 (define (fetch-pid port)
50 (let ((pid (hashq-ref port/pid-table port)))
51 (hashq-remove! port/pid-table port)
54 (define (close-process port/pid)
55 (close-port (car port/pid))
56 (cdr (waitpid (cdr port/pid))))
58 (define-public (close-pipe p)
59 (let ((pid (fetch-pid p)))
61 (error "close-pipe: pipe not in table"))
62 (close-process (cons p pid))))
66 (let loop ((p (pipe-guardian)))
68 ;; maybe removed already by close-pipe.
69 (let ((pid (fetch-pid p)))
71 (close-process (cons p pid))))
72 (loop (pipe-guardian)))))))
75 (let ((old-thunk gc-thunk))
77 (if old-thunk (old-thunk))
80 ;; (add-hook! after-gc-hook reap-pipes)
82 (define-public (open-input-pipe command) (open-pipe command OPEN_READ))
83 (define-public (open-output-pipe command) (open-pipe command OPEN_WRITE))