From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: Josselin Poiret via "Bug reports for GUILE, GNU's Ubiquitous Extension Language" Newsgroups: gmane.lisp.guile.bugs Subject: bug#52835: [PATCH v6 3/3] Move popen and posix procedures to spawn*. Date: Thu, 22 Dec 2022 13:49:10 +0100 Message-ID: <2423f06c9596dc05ab669247551b5b7bd7c134a0.1671710701.git.dev@jpoiret.xyz> References: Reply-To: Josselin Poiret Mime-Version: 1.0 Content-Transfer-Encoding: 8bit Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="30649"; mail-complaints-to="usenet@ciao.gmane.io" Cc: 52835@debbugs.gnu.org, Timothy Sample , Josselin Poiret To: Ludovic =?UTF-8?Q?Court=C3=A8s?= Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Thu Dec 22 13:50:46 2022 Return-path: Envelope-to: guile-bugs@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1p8L25-0007mz-Ua for guile-bugs@m.gmane-mx.org; Thu, 22 Dec 2022 13:50:46 +0100 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1p8L1V-0003tJ-Qx; Thu, 22 Dec 2022 07:50:09 -0500 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1p8L1P-0003qp-Gq for bug-guile@gnu.org; Thu, 22 Dec 2022 07:50:06 -0500 Original-Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1p8L1P-0003bf-84 for bug-guile@gnu.org; Thu, 22 Dec 2022 07:50:03 -0500 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1p8L1P-0001dC-0d for bug-guile@gnu.org; Thu, 22 Dec 2022 07:50:03 -0500 X-Loop: help-debbugs@gnu.org Resent-From: Josselin Poiret Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Thu, 22 Dec 2022 12:50:02 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 52835 X-GNU-PR-Package: guile X-GNU-PR-Keywords: patch Original-Received: via spool by 52835-submit@debbugs.gnu.org id=B52835.16717133906236 (code B ref 52835); Thu, 22 Dec 2022 12:50:02 +0000 Original-Received: (at 52835) by debbugs.gnu.org; 22 Dec 2022 12:49:50 +0000 Original-Received: from localhost ([127.0.0.1]:58196 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1p8L1B-0001cW-OF for submit@debbugs.gnu.org; Thu, 22 Dec 2022 07:49:50 -0500 Original-Received: from jpoiret.xyz ([206.189.101.64]:41712) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1p8L0w-0001bt-5E for 52835@debbugs.gnu.org; Thu, 22 Dec 2022 07:49:35 -0500 Original-Received: from authenticated-user (jpoiret.xyz [206.189.101.64]) by jpoiret.xyz (Postfix) with ESMTPA id 2F0C0185319; Thu, 22 Dec 2022 12:49:31 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=jpoiret.xyz; s=dkim; t=1671713373; h=from:from:reply-to:subject:subject:date:date:message-id:message-id: to:to:cc:cc:mime-version:mime-version: content-transfer-encoding:content-transfer-encoding: in-reply-to:in-reply-to:references:references; bh=ZoJsoLY5htkd87/FUijme8Eo0+rsTcYELO/YqaEebh4=; b=qWKvP/ZOtdJ7+bhqM7HxfBRN8botve6s2dZPnomdgsNEd2GB6dNCLwaeiEQLeUfNMjXO65 I3bqTet79jNDv3QHdtQe0n4YVHPuhDCod4CXhBNCRVM2NcytJ9z/wsDixDHK1/ayoBVYfs 3/85o1vNX/uBWPZkBzD4i2Zdsnz60nnxV4/ZjMTMHikOclRpp5f2vouqllXVSZmPX1qgnx G2WRwumNf4l/ArI+g4+xNN1AUIyA6fz5AFM2Ot4ecA07hHZ5Ipd7pFlVP/zmbEAc4qB60g CM10a42/lhRTXeG7wS7IA9tlUuVfXViJt+A+UOsVARseQMeEJp4GDdjr63i6FQ== In-Reply-To: Authentication-Results: jpoiret.xyz; auth=pass smtp.auth=jpoiret@jpoiret.xyz smtp.mailfrom=dev@jpoiret.xyz X-Spamd-Bar: / X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: bug-guile@gnu.org List-Id: "Bug reports for GUILE, GNU's Ubiquitous Extension Language" List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Original-Sender: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.lisp.guile.bugs:10482 Archived-At: * libguile/posix.c (scm_piped_process, scm_init_popen): Remove functions. (scm_port_to_fd_with_default): New helper function. (scm_system_star): Rewrite using scm_spawn_process. (scm_init_popen): Remove the definition of piped-process. (scm_init_posix): Now make popen available unconditionally. * module/ice-9/popen.scm (port-with-defaults): New helper procedure. (spawn): New procedure. (open-process): Rewrite using spawn. (pipeline): Rewrite using spawn*. * test-suite/tests/popen.test ("piped-process", "piped-process: with-output"): Removed tests. ("spawn", "spawn: with output"): Added tests. * test-suite/tests/posix.test ("http://bugs.gnu.org/13166", "exit code for nonexistent file", "https://bugs.gnu.org/55596"): Remove obsolete tests. ("exception for nonexistent file"): Add test. --- libguile/posix.c | 144 ++++++++---------------------------- module/ice-9/popen.scm | 87 +++++++++++++++------- test-suite/tests/popen.test | 14 ++-- test-suite/tests/posix.test | 36 ++++----- 4 files changed, 118 insertions(+), 163 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index f9c36d7ac..1401a9118 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -64,6 +64,7 @@ #include "fports.h" #include "gettext.h" #include "gsubr.h" +#include "ioext.h" #include "list.h" #include "modules.h" #include "numbers.h" @@ -1388,98 +1389,6 @@ SCM_DEFINE (scm_spawn_process, "spawn*", 5, 0, 0, } #undef FUNC_NAME -#ifdef HAVE_FORK -static SCM -scm_piped_process (SCM prog, SCM args, SCM from, SCM to) -#define FUNC_NAME "piped-process" -{ - int reading, writing; - int c2p[2]; /* Child to parent. */ - int p2c[2]; /* Parent to child. */ - int in = -1, out = -1, err = -1; - int pid; - char *exec_file; - char **exec_argv; - char **exec_env = environ; - - exec_file = scm_to_locale_string (prog); - exec_argv = scm_i_allocate_string_pointers (scm_cons (prog, args)); - - reading = scm_is_pair (from); - writing = scm_is_pair (to); - - if (reading) - { - c2p[0] = scm_to_int (scm_car (from)); - c2p[1] = scm_to_int (scm_cdr (from)); - out = c2p[1]; - } - - if (writing) - { - p2c[0] = scm_to_int (scm_car (to)); - p2c[1] = scm_to_int (scm_cdr (to)); - in = p2c[0]; - } - - { - SCM port; - - if (SCM_OPOUTFPORTP ((port = scm_current_error_port ()))) - err = SCM_FPORT_FDES (port); - if (out == -1 && SCM_OPOUTFPORTP ((port = scm_current_output_port ()))) - out = SCM_FPORT_FDES (port); - if (in == -1 && SCM_OPINFPORTP ((port = scm_current_input_port ()))) - in = SCM_FPORT_FDES (port); - } - - pid = do_spawn (exec_file, exec_argv, exec_env, in, out, err); - int errno_save = errno; - - if (pid == -1) - { - /* TODO This is a compatibility shim until the next major release */ - switch (errno) { - /* If the error seemingly comes from fork */ - case EAGAIN: - case ENOMEM: - case ENOSYS: - free (exec_file); - - if (reading) - { - close (c2p[0]); - } - if (writing) - { - close (p2c[1]); - } - errno = errno_save; - SCM_SYSERROR; - break; - /* Else create a dummy process that exits with value 127 */ - default: - dprintf (err, "In execvp of %s: %s\n", exec_file, - strerror (errno_save)); - pid = fork (); - if (pid == -1) - SCM_SYSERROR; - if (pid == 0) - _exit (127); - } - } - - free (exec_file); - - if (reading) - close (c2p[1]); - if (writing) - close (p2c[0]); - - return scm_from_int (pid); -} -#undef FUNC_NAME - static void restore_sigaction (SCM pair) { @@ -1501,6 +1410,15 @@ scm_dynwind_sigaction (int sig, SCM handler, SCM flags) SCM_F_WIND_EXPLICITLY); } +static int +port_to_fd_with_default (SCM port, int mode) +{ + if (!SCM_FPORTP (port)) + return open_or_open64 ("/dev/null", mode); + return SCM_FPORT_FDES (port); + +} + SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, (SCM args), "Execute the command indicated by @var{args}. The first element must\n" @@ -1521,13 +1439,14 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, "Example: (system* \"echo\" \"foo\" \"bar\")") #define FUNC_NAME s_scm_system_star { - SCM prog, pid; - int status, wait_result; + int pid, status, wait_result; + + int in, out, err; + char *exec_file; + char **exec_argv; if (scm_is_null (args)) SCM_WRONG_NUM_ARGS (); - prog = scm_car (args); - args = scm_cdr (args); scm_dynwind_begin (0); /* Make sure the child can't kill us (as per normal system call). */ @@ -1540,8 +1459,23 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, SCM_UNDEFINED); #endif - pid = scm_piped_process (prog, args, SCM_UNDEFINED, SCM_UNDEFINED); - SCM_SYSCALL (wait_result = waitpid (scm_to_int (pid), &status, 0)); + exec_file = scm_to_locale_string (scm_car (args)); + exec_argv = scm_i_allocate_string_pointers (args); + + in = port_to_fd_with_default (scm_current_input_port (), O_RDONLY); + out = port_to_fd_with_default (scm_current_output_port (), O_WRONLY); + err = port_to_fd_with_default (scm_current_error_port (), O_WRONLY); + + pid = do_spawn (exec_file, exec_argv, environ, in, out, err); + if (pid == -1) + { + int errno_save = errno; + free (exec_file); + errno = errno_save; + SCM_SYSERROR; + } + + SCM_SYSCALL (wait_result = waitpid (pid, &status, 0)); if (wait_result == -1) SCM_SYSERROR; @@ -1550,7 +1484,6 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, return scm_from_int (status); } #undef FUNC_NAME -#endif /* HAVE_FORK */ #ifdef HAVE_UNAME SCM_DEFINE (scm_uname, "uname", 0, 0, 0, @@ -2396,14 +2329,6 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, #endif /* HAVE_GETHOSTNAME */ -#ifdef HAVE_FORK -static void -scm_init_popen (void) -{ - scm_c_define_gsubr ("piped-process", 2, 2, 0, scm_piped_process); -} -#endif /* HAVE_FORK */ - void scm_init_posix () { @@ -2520,10 +2445,5 @@ scm_init_posix () #ifdef HAVE_FORK scm_add_feature ("fork"); - scm_add_feature ("popen"); - scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION, - "scm_init_popen", - (scm_t_extension_init_func) scm_init_popen, - NULL); #endif /* HAVE_FORK */ } diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index e638726a4..547f56d5f 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -25,11 +25,34 @@ #: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)) + open-output-pipe open-input-output-pipe pipeline spawn)) -(eval-when (expand load eval) - (load-extension (string-append "libguile-" (effective-version)) - "scm_init_popen")) +(define (port-with-defaults port default-mode) + (if (file-port? port) + port + (open-file "/dev/null" default-mode))) + +(define* (spawn exec-file argv #:key + (in (current-input-port)) + (out (current-output-port)) + (err (current-error-port))) + "Spawns a new child process executing @var{prog} with arguments +@var{args}, with its standard input, output and error file descriptors +set to @var{in}, @var{out}, @var{err}." + (let* ((in (port-with-defaults in "r")) + (out (port-with-defaults out "w")) + (err (port-with-defaults err "w")) + ;; Increment port revealed counts while to prevent ports GC'ing and + ;; closing the associated fds while we spawn the process. + (result (spawn* exec-file + argv + (port->fdes in) + (port->fdes out) + (port->fdes err)))) + (release-port-handle in) + (release-port-handle out) + (release-port-handle err) + result)) (define-record-type (make-pipe-info pid) @@ -92,13 +115,13 @@ (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}." +libguile/posix.c (scm_open_process) replaced by scm_piped_process, now +replaced by scm_spawn_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) @@ -107,19 +130,25 @@ or @code{OPEN_BOTH}." (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)))) + (let* ((child-to-parent (and (or (string=? mode OPEN_READ) + (string=? mode OPEN_BOTH)) + (pipe))) + (parent-to-child (and (or (string=? mode OPEN_WRITE) + (string=? mode OPEN_BOTH)) + (pipe))) + (in (or (and=> parent-to-child car) (current-input-port))) + (out (or (and=> child-to-parent cdr) (current-output-port))) + (pid (spawn command (cons command args) + #:in in + #:out out))) + (when child-to-parent + (close (cdr child-to-parent))) + (when parent-to-child + (close (car parent-to-child))) ;; The original 'open-process' procedure would return unbuffered ;; ports; do the same here. - (values (and from (unbuffered (car from))) - (and to (unbuffered (cdr to))) + (values (and child-to-parent (unbuffered (car child-to-parent))) + (and parent-to-child (unbuffered (cdr parent-to-child))) pid))) (define (open-pipe* mode command . args) @@ -224,10 +253,16 @@ a list of PIDs of the processes executing the @var{commands}." (pipeline (fold (lambda (from proc prev) (let* ((to (car prev)) (pids (cdr prev)) - (pid (piped-process (car proc) - (cdr proc) - from - to))) + (pid (spawn* (car proc) + proc + (car to) + (cdr from) + (port->fdes + (port-with-defaults + (current-error-port) + "w"))))) + (close-fdes (car to)) + (close-fdes (cdr from)) (cons from (cons pid pids)))) `(,to) pipes diff --git a/test-suite/tests/popen.test b/test-suite/tests/popen.test index 3df863375..fd810e376 100644 --- a/test-suite/tests/popen.test +++ b/test-suite/tests/popen.test @@ -257,18 +257,18 @@ exec 2>~a; read REPLY" (list (read-string from) (status:exit-val (cdr (waitpid pid)))))) -(pass-if-equal "piped-process" +(pass-if-equal "spawn" 42 (status:exit-val - (cdr (waitpid ((@@ (ice-9 popen) piped-process) - "./meta/guile" '("-c" "(exit 42)")))))) + (cdr (waitpid (spawn + "./meta/guile" '("./meta/guile" "-c" "(exit 42)")))))) -(pass-if-equal "piped-process: with output" +(pass-if-equal "spawn: with output" '("foo bar\n" 0) (let* ((p (pipe)) - (pid ((@@ (ice-9 popen) piped-process) "echo" '("foo" "bar") - (cons (port->fdes (car p)) - (port->fdes (cdr p)))))) + (pid (spawn "echo" '("echo" "foo" "bar") + #:out (cdr p)))) + (close (cdr p)) (list (read-string (car p)) (status:exit-val (cdr (waitpid pid)))))) diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test index bfc6f168e..5c971f4f7 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -340,24 +340,24 @@ (with-test-prefix "system*" - (pass-if "http://bugs.gnu.org/13166" - ;; With Guile up to 2.0.7 included, the child process launched by - ;; `system*' would remain alive after an `execvp' failure. - (let ((me (getpid))) - (and (not (zero? (system* "something-that-does-not-exist"))) - (= me (getpid))))) - - (pass-if-equal "exit code for nonexistent file" - 127 ;aka. EX_NOTFOUND - (status:exit-val (system* "something-that-does-not-exist"))) - - (pass-if-equal "https://bugs.gnu.org/55596" - 127 - ;; The parameterization below used to cause 'start_child' to close - ;; fd 2 in the child process, which in turn would cause it to - ;; segfault, leading to a wrong exit code. - (parameterize ((current-output-port (current-error-port))) - (status:exit-val (system* "something-that-does-not-exist"))))) + (pass-if-equal "exception for nonexistent file" + 2 ; ENOENT + (call-with-prompt 'escape + (lambda () + (with-exception-handler + (lambda (exn) + (let* ((kind (exception-kind exn)) + (errno (and (eq? kind 'system-error) + (car (car + (cdr (cdr (cdr (exception-args + exn))))))))) + (abort-to-prompt 'escape errno))) + (lambda () + (status:exit-val (system* + "something-that-does-not-exist"))) + #:unwind? #t)) + (lambda (k arg) + arg)))) ;; ;; crypt -- 2.38.1