mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
These were found with: make GUILE_WARNINGS='-W1 -Wunused-module' * module/ice-9/copy-tree.scm: * module/ice-9/eval-string.scm: * module/ice-9/getopt-long.scm: * module/ice-9/poll.scm: * module/ice-9/popen.scm: * module/ice-9/sandbox.scm: * module/ice-9/threads.scm: * module/sxml/apply-templates.scm: * module/sxml/simple.scm: * module/system/base/types.scm: * module/system/repl/command.scm: * module/system/repl/common.scm: * module/system/repl/coop-server.scm: * module/system/repl/debug.scm: * module/system/repl/error-handling.scm: * module/system/repl/repl.scm: * module/system/repl/server.scm: * module/system/vm/assembler.scm: * module/system/vm/disassembler.scm: * module/system/vm/dwarf.scm: * module/system/vm/elf.scm: * module/system/vm/frame.scm: * module/system/vm/inspect.scm: * module/system/vm/linker.scm: * module/system/vm/program.scm: * module/system/vm/trace.scm: * module/system/vm/trap-state.scm: * module/system/vm/traps.scm: * module/system/xref.scm: * module/texinfo/indexing.scm: * module/texinfo/plain-text.scm: * module/texinfo/reflection.scm: * module/texinfo/string-utils.scm: * module/web/client.scm: * module/web/http.scm: * module/web/request.scm: * module/web/response.scm: Remove imports of unused modules.
236 lines
9.2 KiB
Scheme
236 lines
9.2 KiB
Scheme
;; popen emulation, for non-stdio based ports.
|
|
|
|
;;;; Copyright (C) 1998-2001, 2003, 2006, 2010-2013, 2019
|
|
;;;; Free Software Foundation, Inc.
|
|
;;;;
|
|
;;;; This library is free software; you can redistribute it and/or
|
|
;;;; modify it under the terms of the GNU Lesser General Public
|
|
;;;; License as published by the Free Software Foundation; either
|
|
;;;; version 3 of the License, or (at your option) any later version.
|
|
;;;;
|
|
;;;; This library is distributed in the hope that it will be useful,
|
|
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
|
;;;; Lesser General Public License for more details.
|
|
;;;;
|
|
;;;; You should have received a copy of the GNU Lesser General Public
|
|
;;;; License along with this library; if not, write to the Free Software
|
|
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
;;;;
|
|
|
|
(define-module (ice-9 popen)
|
|
#:use-module (ice-9 binary-ports)
|
|
#:use-module (ice-9 threads)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (srfi srfi-9)
|
|
#:export (port/pid-table open-pipe* open-pipe close-pipe open-input-pipe
|
|
open-output-pipe open-input-output-pipe pipeline))
|
|
|
|
(eval-when (expand load eval)
|
|
(load-extension (string-append "libguile-" (effective-version))
|
|
"scm_init_popen"))
|
|
|
|
(define-record-type <pipe-info>
|
|
(make-pipe-info pid)
|
|
pipe-info?
|
|
(pid pipe-info-pid set-pipe-info-pid!))
|
|
|
|
(define (make-rw-port read-port write-port)
|
|
(define (read! bv start count)
|
|
(let ((result (get-bytevector-some! read-port bv start count)))
|
|
(if (eof-object? result)
|
|
0
|
|
result)))
|
|
|
|
(define (write! bv start count)
|
|
(put-bytevector write-port bv start count)
|
|
count)
|
|
|
|
(define (close)
|
|
(close-port read-port)
|
|
(close-port write-port))
|
|
|
|
(define rw-port
|
|
(make-custom-binary-input/output-port "ice-9-popen-rw-port"
|
|
read!
|
|
write!
|
|
#f ;get-position
|
|
#f ;set-position!
|
|
close))
|
|
;; Enable buffering on 'read-port' so that 'get-bytevector-some' will
|
|
;; return non-trivial blocks.
|
|
(setvbuf read-port 'block 16384)
|
|
|
|
;; Inherit the port-encoding from the read-port.
|
|
(set-port-encoding! rw-port (port-encoding read-port))
|
|
|
|
;; Reset the port encoding on the underlying ports to inhibit BOM
|
|
;; handling there. Instead, the BOM handling (if any) will be handled
|
|
;; in the rw-port. In the current implementation of Guile ports,
|
|
;; using binary I/O primitives alone is not enough to reliably inhibit
|
|
;; BOM handling, if the port encoding is set to UTF-{8,16,32}.
|
|
(set-port-encoding! read-port "ISO-8859-1")
|
|
(set-port-encoding! write-port "ISO-8859-1")
|
|
|
|
rw-port)
|
|
|
|
;; 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.
|
|
;; XXX use of this table is deprecated. It is no longer used here, and
|
|
;; is populated for backward compatibility only (since it is exported).
|
|
(define port/pid-table (make-weak-key-hash-table))
|
|
(define port/pid-table-mutex (make-mutex))
|
|
|
|
(define (pipe->fdes)
|
|
(let ((p (pipe)))
|
|
(cons (port->fdes (car p))
|
|
(port->fdes (cdr p)))))
|
|
|
|
(define (open-process mode command . args)
|
|
"Backwards compatible implementation of the former procedure in
|
|
libguile/posix.c (scm_open_process) replaced by
|
|
scm_piped_process. Executes the program @var{command} with optional
|
|
arguments @var{args} (all strings) in a subprocess. A port to the
|
|
process (based on pipes) is created and returned. @var{mode} specifies
|
|
whether an input, an output or an input-output port to the process is
|
|
created: it should be the value of @code{OPEN_READ}, @code{OPEN_WRITE}
|
|
or @code{OPEN_BOTH}."
|
|
(define (unbuffered port)
|
|
(setvbuf port 'none)
|
|
port)
|
|
|
|
(define (fdes-pair ports)
|
|
(and ports
|
|
(cons (port->fdes (car ports)) (port->fdes (cdr ports)))))
|
|
|
|
(let* ((from (and (or (string=? mode OPEN_READ)
|
|
(string=? mode OPEN_BOTH))
|
|
(pipe)))
|
|
(to (and (or (string=? mode OPEN_WRITE)
|
|
(string=? mode OPEN_BOTH))
|
|
(pipe)))
|
|
(pid (piped-process command args
|
|
(fdes-pair from)
|
|
(fdes-pair to))))
|
|
;; The original 'open-process' procedure would return unbuffered
|
|
;; ports; do the same here.
|
|
(values (and from (unbuffered (car from)))
|
|
(and to (unbuffered (cdr to)))
|
|
pid)))
|
|
|
|
(define (open-pipe* mode command . args)
|
|
"Executes the program @var{command} with optional arguments
|
|
@var{args} (all strings) in a subprocess.
|
|
A port to the process (based on pipes) is created and returned.
|
|
@var{mode} specifies whether an input, an output or an input-output
|
|
port to the process is created: it should be the value of
|
|
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
|
|
(call-with-values (lambda ()
|
|
(apply open-process mode command args))
|
|
(lambda (read-port write-port pid)
|
|
(let ((port (or (and read-port write-port
|
|
(make-rw-port read-port write-port))
|
|
read-port
|
|
write-port
|
|
(%make-void-port mode)))
|
|
(pipe-info (make-pipe-info pid)))
|
|
|
|
;; Guard the pipe-info instead of the port, so that we can still
|
|
;; call 'waitpid' even if 'close-port' is called (which clears
|
|
;; the port entry).
|
|
(pipe-guardian pipe-info)
|
|
(%set-port-property! port 'popen-pipe-info pipe-info)
|
|
|
|
;; XXX populate port/pid-table for backward compatibility.
|
|
(with-mutex port/pid-table-mutex
|
|
(hashq-set! port/pid-table port pid))
|
|
|
|
port))))
|
|
|
|
(define (open-pipe command mode)
|
|
"Executes the shell command @var{command} (a string) in a subprocess.
|
|
A port to the process (based on pipes) is created and returned.
|
|
@var{mode} specifies whether an input, an output or an input-output
|
|
port to the process is created: it should be the value of
|
|
@code{OPEN_READ}, @code{OPEN_WRITE} or @code{OPEN_BOTH}."
|
|
(open-pipe* mode "/bin/sh" "-c" command))
|
|
|
|
(define (fetch-pipe-info port)
|
|
(%port-property port 'popen-pipe-info))
|
|
|
|
(define (close-process port pid)
|
|
(close-port port)
|
|
(cdr (waitpid pid)))
|
|
|
|
(define (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 ((pipe-info (fetch-pipe-info p)))
|
|
(unless pipe-info
|
|
(error "close-pipe: port not created by (ice-9 popen)"))
|
|
(let ((pid (pipe-info-pid pipe-info)))
|
|
(unless pid
|
|
(error "close-pipe: pid has already been cleared"))
|
|
;; clear the pid to avoid repeated calls to 'waitpid'.
|
|
(set-pipe-info-pid! pipe-info #f)
|
|
(close-process p pid))))
|
|
|
|
(define (reap-pipes)
|
|
(let loop ()
|
|
(let ((pipe-info (pipe-guardian)))
|
|
(when pipe-info
|
|
(let ((pid (pipe-info-pid pipe-info)))
|
|
;; maybe 'close-pipe' was already called.
|
|
(when pid
|
|
;; 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.
|
|
(catch 'system-error
|
|
(lambda ()
|
|
(let ((pid/status (waitpid pid WNOHANG)))
|
|
(if (zero? (car pid/status))
|
|
(pipe-guardian pipe-info) ; not ready for collection
|
|
(set-pipe-info-pid! pipe-info #f))))
|
|
(lambda args #f))))
|
|
(loop)))))
|
|
|
|
(add-hook! after-gc-hook reap-pipes)
|
|
|
|
(define (open-input-pipe command)
|
|
"Equivalent to @code{open-pipe} with mode @code{OPEN_READ}"
|
|
(open-pipe command OPEN_READ))
|
|
|
|
(define (open-output-pipe command)
|
|
"Equivalent to @code{open-pipe} with mode @code{OPEN_WRITE}"
|
|
(open-pipe command OPEN_WRITE))
|
|
|
|
(define (open-input-output-pipe command)
|
|
"Equivalent to @code{open-pipe} with mode @code{OPEN_BOTH}"
|
|
(open-pipe command OPEN_BOTH))
|
|
|
|
(define (pipeline commands)
|
|
"Execute a pipeline of @var{commands}, where each command is a list of a
|
|
program and its arguments as strings, returning an input port to the
|
|
end of the pipeline, an output port to the beginning of the pipeline and
|
|
a list of PIDs of the processes executing the @var{commands}."
|
|
(let* ((to (pipe->fdes))
|
|
(pipes (map (lambda _ (pipe->fdes)) commands))
|
|
(pipeline (fold (lambda (from proc prev)
|
|
(let* ((to (car prev))
|
|
(pids (cdr prev))
|
|
(pid (piped-process (car proc)
|
|
(cdr proc)
|
|
from
|
|
to)))
|
|
(cons from (cons pid pids))))
|
|
`(,to)
|
|
pipes
|
|
commands))
|
|
(from (car pipeline))
|
|
(pids (cdr pipeline)))
|
|
(values (fdes->inport (car from)) (fdes->outport (cdr to)) pids)))
|