blob: 5689e5ffc5709855fa373988927fac0a7c36141e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
|
;; popen emulation, for non-stdio based ports.
(define-module (ice-9 popen))
;; (define-module (guile popen)
;; :use-module (guile posix))
;; a guardian to ensure the cleanup is done correctly when
;; an open pipe is gc'd or a close-port is used.
(define pipe-guardian (make-guardian))
;; a weak hash-table to store the process ids.
(define-public port/pid-table (make-weak-key-hash-table 31))
;; run a process connected to an input or output port.
;; mode: OPEN_READ or OPEN_WRITE.
;; returns port/pid pair.
(define (open-process mode prog . args)
(let ((p (pipe))
(reading (string=? mode OPEN_READ)))
(setvbuf (cdr p) _IONBF)
(let ((pid (primitive-fork)))
(cond ((= pid 0)
;; child
(set-batch-mode?! #t)
(close-all-ports-except (if reading (cdr p) (car p)))
(move->fdes (if reading (cdr p) (car p))
(if reading 1 0))
(apply execlp prog prog args))
(else
;; parent
(if reading
(close-port (cdr p))
(close-port (car p)))
(cons (if reading
(car p)
(cdr p))
pid))))))
(define-public (open-pipe command mode)
"Executes the shell command @var{command} (a string) in a subprocess.
A pipe to the process is created and returned. @var{modes} specifies
whether an input or output pipe to the process is created: it should
be the value of @code{OPEN_READ} or @code{OPEN_WRITE}."
(let* ((port/pid (open-process mode "/bin/sh" "-c" command))
(port (car port/pid)))
(pipe-guardian port)
(hashq-set! port/pid-table port (cdr port/pid))
port))
(define (fetch-pid port)
(let ((pid (hashq-ref port/pid-table port)))
(hashq-remove! port/pid-table port)
pid))
(define (close-process port/pid)
(close-port (car port/pid))
(cdr (waitpid (cdr port/pid))))
;; for the background cleanup handler: just clean up without reporting
;; errors. also avoids blocking the process: if the child isn't ready
;; to be collected, puts it back into the guardian's live list so it
;; can be tried again the next time the cleanup runs.
(define (close-process-quietly port/pid)
(catch 'system-error
(lambda ()
(close-port (car port/pid)))
(lambda args #f))
(catch 'system-error
(lambda ()
(let ((pid/status (waitpid (cdr port/pid) WNOHANG)))
(cond ((= (car pid/status) 0)
;; not ready for collection
(pipe-guardian (car port/pid))
(hashq-set! port/pid-table
(car port/pid) (cdr port/pid))))))
(lambda args #f)))
(define-public (close-pipe p)
"Closes the pipe created by @code{open-pipe}, then waits for the process
to terminate and returns its status value, @xref{Processes, waitpid}, for
information on how to interpret this value."
(let ((pid (fetch-pid p)))
(if (not pid)
(error "close-pipe: pipe not in table"))
(close-process (cons p pid))))
(define reap-pipes
(lambda ()
(let loop ((p (pipe-guardian)))
(cond (p
;; maybe removed already by close-pipe.
(let ((pid (fetch-pid p)))
(if pid
(close-process-quietly (cons p pid))))
(loop (pipe-guardian)))))))
(set! gc-thunk
(let ((old-thunk gc-thunk))
(lambda ()
(if old-thunk (old-thunk))
(reap-pipes))))
;; (add-hook! after-gc-hook reap-pipes)
(define-public (open-input-pipe command) (open-pipe command OPEN_READ))
(define-public (open-output-pipe command) (open-pipe command OPEN_WRITE))
|