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 v5 3/3] Move popen and posix procedures to spawn*. Date: Mon, 5 Sep 2022 08:48:15 +0200 Message-ID: <1d64d8e0e292fc3a89bcd491dd8f10171cb7c804.1662358976.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="26576"; mail-complaints-to="usenet@ciao.gmane.io" Cc: Timothy Sample , Josselin Poiret To: 52835@debbugs.gnu.org Original-X-From: bug-guile-bounces+guile-bugs=m.gmane-mx.org@gnu.org Mon Sep 05 08:49:16 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 1oV5v0-0006jk-NA for guile-bugs@m.gmane-mx.org; Mon, 05 Sep 2022 08:49:14 +0200 Original-Received: from localhost ([::1]:54002 helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1oV5uz-0001zI-Jl for guile-bugs@m.gmane-mx.org; Mon, 05 Sep 2022 02:49:13 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]:39614) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1oV5uq-0001yN-Bt for bug-guile@gnu.org; Mon, 05 Sep 2022 02:49:04 -0400 Original-Received: from debbugs.gnu.org ([209.51.188.43]:57556) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1oV5uq-0006Sh-3J for bug-guile@gnu.org; Mon, 05 Sep 2022 02:49:04 -0400 Original-Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1oV5up-0000d2-Vc for bug-guile@gnu.org; Mon, 05 Sep 2022 02:49:03 -0400 X-Loop: help-debbugs@gnu.org Resent-From: Josselin Poiret Original-Sender: "Debbugs-submit" Resent-CC: bug-guile@gnu.org Resent-Date: Mon, 05 Sep 2022 06:49:03 +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.16623605142359 (code B ref 52835); Mon, 05 Sep 2022 06:49:03 +0000 Original-Received: (at 52835) by debbugs.gnu.org; 5 Sep 2022 06:48:34 +0000 Original-Received: from localhost ([127.0.0.1]:46252 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oV5uL-0000by-I2 for submit@debbugs.gnu.org; Mon, 05 Sep 2022 02:48:34 -0400 Original-Received: from jpoiret.xyz ([206.189.101.64]:38528) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1oV5uG-0000bH-07 for 52835@debbugs.gnu.org; Mon, 05 Sep 2022 02:48:29 -0400 Original-Received: from authenticated-user (jpoiret.xyz [206.189.101.64]) by jpoiret.xyz (Postfix) with ESMTPA id 5BFEA184F64; Mon, 5 Sep 2022 06:48:27 +0000 (UTC) DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=jpoiret.xyz; s=dkim; t=1662360507; 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=TU0vigAZ8oUicNTOj+bj0Ao7TnNtTjChjyVgmMKiWYI=; b=Reb7HfMT8oDpsz1eFU555m/ZJs9rcBEcMICL6nsg9B5I8/j7WjayUYhOH/G7llv82SelpD lu4i+Dc/VV9gzgjRMcXWYdYqyjM2XMYSYwteGxSbAjhF+PCkdAAfx2ppgQINiyjS+ir4hv VhX7MMLu92OgAyA45JeLCyCCqPQt66gIBEqQebPWvccQGLYAf4j4B1axevPHPVu8BLq64B 9FVil8JTCa5upLYGmh+DKhJSJWzEf8C5hKMoayYH35R1b3H+9SWeG+S1rtdnyRL3rSPss0 uXuYuSAQJBgR+oGQnHCOCrLFQw9WtgpxKaJilvQtZ9PVz//TuEypD+LjQ6e6Gw== 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" Xref: news.gmane.io gmane.lisp.guile.bugs:10361 Archived-At: * libguile/posix.c (renumber_file_descriptor, start_child, scm_piped_process): 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 | 218 +++--------------------------------- module/ice-9/popen.scm | 83 ++++++++++---- test-suite/tests/popen.test | 14 +-- test-suite/tests/posix.test | 36 +++--- 4 files changed, 102 insertions(+), 249 deletions(-) diff --git a/libguile/posix.c b/libguile/posix.c index 5d287ff2a..c35346f9f 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -73,6 +73,7 @@ #include "fports.h" #include "gettext.h" #include "gsubr.h" +#include "ioext.h" #include "list.h" #include "modules.h" #include "numbers.h" @@ -1280,199 +1281,6 @@ SCM_DEFINE (scm_fork, "primitive-fork", 0, 0, 0, #undef FUNC_NAME #endif /* HAVE_FORK */ -#ifdef HAVE_FORK -/* 'renumber_file_descriptor' is a helper function for 'start_child' - below, and is specialized for that particular environment where it - doesn't make sense to report errors via exceptions. It uses dup(2) - to duplicate the file descriptor FD, closes the original FD, and - returns the new descriptor. If dup(2) fails, print an error message - to ERR and abort. */ -static int -renumber_file_descriptor (int fd, int err) -{ - int new_fd; - - do - new_fd = dup (fd); - while (new_fd == -1 && errno == EINTR); - - if (new_fd == -1) - { - /* At this point we are in the child process before exec. We - cannot safely raise an exception in this environment. */ - const char *msg = strerror (errno); - fprintf (fdopen (err, "a"), "start_child: dup failed: %s\n", msg); - _exit (127); /* Use exit status 127, as with other exec errors. */ - } - - close (fd); - return new_fd; -} -#endif /* HAVE_FORK */ - -#ifdef HAVE_FORK -#define HAVE_START_CHILD 1 -/* Since Guile uses threads, we have to be very careful to avoid calling - functions that are not async-signal-safe in the child. That's why - this function is implemented in C. */ -static pid_t -start_child (const char *exec_file, char **exec_argv, - int reading, int c2p[2], int writing, int p2c[2], - int in, int out, int err) -{ - int pid; - int max_fd = 1024; - -#if defined (HAVE_GETRLIMIT) && defined (RLIMIT_NOFILE) - { - struct rlimit lim = { 0, 0 }; - if (getrlimit (RLIMIT_NOFILE, &lim) == 0) - max_fd = lim.rlim_cur; - } -#endif - - pid = fork (); - - if (pid != 0) - /* The parent, with either and error (pid == -1), or the PID of the - child. Return directly in either case. */ - return pid; - - /* The child. */ - if (reading) - close (c2p[0]); - if (writing) - close (p2c[1]); - - /* Close all file descriptors in ports inherited from the parent - except for in, out, and err. Heavy-handed, but robust. */ - while (max_fd--) - if (max_fd != in && max_fd != out && max_fd != err) - close (max_fd); - - /* Ignore errors on these open() calls. */ - if (in == -1) - in = open ("/dev/null", O_RDONLY); - if (out == -1) - out = open ("/dev/null", O_WRONLY); - if (err == -1) - err = open ("/dev/null", O_WRONLY); - - if (in > 0) - { - if (out == 0) - out = renumber_file_descriptor (out, err); - if (err == 0) - err = renumber_file_descriptor (err, err); - do dup2 (in, 0); while (errno == EINTR); - close (in); - } - if (out > 1) - { - if (err == 1) - err = renumber_file_descriptor (err, err); - do dup2 (out, 1); while (errno == EINTR); - if (out > 2) - close (out); - } - if (err > 2) - { - do dup2 (err, 2); while (errno == EINTR); - close (err); - } - - execvp (exec_file, exec_argv); - - /* The exec failed! There is nothing sensible to do. */ - { - const char *msg = strerror (errno); - fprintf (fdopen (2, "a"), "In execvp of %s: %s\n", - exec_file, msg); - } - - /* Use exit status 127, like shells in this case, as per POSIX - . */ - _exit (127); - - /* Not reached. */ - return -1; -} -#endif - -#ifdef HAVE_START_CHILD -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; - - 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 = start_child (exec_file, exec_argv, reading, c2p, writing, p2c, - in, out, err); - - if (pid == -1) - { - int errno_save = errno; - free (exec_file); - if (reading) - { - close (c2p[0]); - close (c2p[1]); - } - if (writing) - { - close (p2c[0]); - close (p2c[1]); - } - errno = errno_save; - SCM_SYSERROR; - } - - if (reading) - close (c2p[1]); - if (writing) - close (p2c[0]); - - return scm_from_int (pid); -} -#undef FUNC_NAME - static SCM scm_spawn_process (SCM prog, SCM args, SCM scm_in, SCM scm_out, SCM scm_err) #define FUNC_NAME "spawn*" @@ -1563,6 +1371,15 @@ scm_dynwind_sigaction (int sig, SCM handler, SCM flags) SCM_F_WIND_EXPLICITLY); } +static SCM +scm_port_to_fd_with_default (SCM port, int mode) +{ + if (!SCM_FPORTP (port)) + return scm_from_int (open_or_open64 ("/dev/null", mode)); + return scm_fileno (port); + +} + SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, (SCM args), "Execute the command indicated by @var{args}. The first element must\n" @@ -1589,7 +1406,6 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, 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). */ @@ -1602,7 +1418,13 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, SCM_UNDEFINED); #endif - pid = scm_piped_process (prog, args, SCM_UNDEFINED, SCM_UNDEFINED); + SCM in, out, err; + + in = scm_port_to_fd_with_default (scm_current_input_port (), O_RDONLY); + out = scm_port_to_fd_with_default (scm_current_output_port (), O_WRONLY); + err = scm_port_to_fd_with_default (scm_current_error_port (), O_WRONLY); + + pid = scm_spawn_process (prog, args, in, out, err); SCM_SYSCALL (wait_result = waitpid (scm_to_int (pid), &status, 0)); if (wait_result == -1) SCM_SYSERROR; @@ -1612,7 +1434,6 @@ SCM_DEFINE (scm_system_star, "system*", 0, 0, 1, return scm_from_int (status); } #undef FUNC_NAME -#endif /* HAVE_START_CHILD */ #ifdef HAVE_UNAME SCM_DEFINE (scm_uname, "uname", 0, 0, 0, @@ -2446,14 +2267,11 @@ SCM_DEFINE (scm_gethostname, "gethostname", 0, 0, 0, #endif /* HAVE_GETHOSTNAME */ -#ifdef HAVE_START_CHILD static void scm_init_popen (void) { - scm_c_define_gsubr ("piped-process", 2, 2, 0, scm_piped_process); scm_c_define_gsubr ("spawn*", 5, 0, 0, scm_spawn_process); } -#endif /* HAVE_START_CHILD */ void scm_init_posix () @@ -2566,11 +2384,9 @@ scm_init_posix () #ifdef HAVE_FORK scm_add_feature ("fork"); #endif /* HAVE_FORK */ -#ifdef HAVE_START_CHILD 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_START_CHILD */ } diff --git a/module/ice-9/popen.scm b/module/ice-9/popen.scm index e638726a4..533282f4d 100644 --- a/module/ice-9/popen.scm +++ b/module/ice-9/popen.scm @@ -25,12 +25,37 @@ #: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* 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))) + (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) pipe-info? @@ -92,13 +117,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 +132,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 +255,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 500dbb94a..157f21e24 100644 --- a/test-suite/tests/posix.test +++ b/test-suite/tests/posix.test @@ -236,24 +236,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.37.2