'pipe' now takes an optional 'flags' parameter.

This is the same strategy as used for the 'accept4' bindings introduced
in 6e0965104c579431e5a786b60e1a964a112c73b8.

* libguile/posix.c (scm_pipe): Rename to...
(scm_pipe2): ... this.  Add an optional 'flags' parameter and honor it.
(scm_pipe): Rewrite as a call to 'scm_pipe2'.
* libguile/posix.h (scm_pipe2): New declaration.
* test-suite/tests/posix.test ("pipe"): New tests.
* configure.ac: Look for 'pipe2'.
* NEWS: Update.

6 files changed, 110 insertions, 9 deletions

diff --git a/NEWS b/NEWS
index 05bd1f6e5..19d314f4a 100644
--- a/NEWS
+++ b/NEWS
@@ -18,6 +18,13 @@ pass O_CLOEXEC to the underlying `open' call.  It can now be done by
 appending "e" to the `mode' string passed as a second argument.  See
 "File Ports" in the manual for more info.
 
+** `pipe' now takes flags as an optional argument
+
+This lets you pass flags such as O_CLOEXEC and O_NONBLOCK, as with the
+pipe2(2) system call found on GNU/Linux and GNU/Hurd, instead of having
+to call `fnctl' afterwards.  See "Ports and File Descriptors" in the
+manual for details.
+
 ** Abstract Unix-domain sockets are supported
 
 It is now possible to create an AF_UNIX socket with a leading zero byte
diff --git a/configure.ac b/configure.ac
index b36cf0c15..801110d1b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -534,6 +534,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
 #   fork - unavailable on Windows
 #   sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
 #   sendfile - non-POSIX, found in glibc
+#   pipe2 - non-POSIX, found in glibc (GNU/Linux and GNU/Hurd)
 #
 AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid         \
   fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid        \
@@ -545,7 +546,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid         \
   getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp  \
   index bcopy memcpy rindex truncate isblank _NSGetEnviron              \
   strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat     \
-  sched_getaffinity sched_setaffinity sendfile])
+  sched_getaffinity sched_setaffinity sendfile pipe2])
 
 # The newlib C library uses _NL_ prefixed locale langinfo constants.
 AC_CHECK_DECLS([_NL_NUMERIC_GROUPING], [], [], [[#include <langinfo.h>]])
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 19911a427..6a9f54102 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -318,7 +318,7 @@ the file descriptor will be closed even if a port is using it.  The
 return value is unspecified.
 @end deffn
 
-@deffn {Scheme Procedure} pipe
+@deffn {Scheme Procedure} pipe [flags]
 @deffnx {C Function} scm_pipe ()
 @cindex pipe
 Return a newly created pipe: a pair of ports which are linked together
@@ -329,6 +329,24 @@ for communication with a newly forked child process.  The need to flush
 the output port can be avoided by making it unbuffered using
 @code{setvbuf} (@pxref{Buffering}).
 
+Optionally, on systems that support it such as GNU/Linux and
+GNU/Hurd, @var{flags} can specify a bitwise-or of the following
+constants:
+
+@table @code
+@item O_CLOEXEC
+Mark the returned file descriptors as close-on-exec;
+@item O_DIRECT
+Create a pipe that performs input/output in ``packet"
+mode---see @command{man 2 pipe} for details;
+@item O_NONBLOCK
+Set the @code{O_NONBLOCK} status flag (non-blocking input and
+output) on the file descriptors.
+@end table
+
+On systems that do @emph{not} support it, passing a non-zero
+@var{flags} value triggers a @code{system-error} exception.
+
 @defvar PIPE_BUF
 A write of up to @code{PIPE_BUF} many bytes to a pipe is atomic,
 meaning when done it goes into the pipe instantaneously and as a
diff --git a/libguile/posix.c b/libguile/posix.c
index f4ca72d3e..475312c2a 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -226,8 +226,8 @@ char *getlogin (void);
 SCM_SYMBOL (sym_read_pipe, "read pipe");
 SCM_SYMBOL (sym_write_pipe, "write pipe");
 
-SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0,
-            (),
+SCM_DEFINE (scm_pipe2, "pipe", 0, 1, 0,
+            (SCM flags),
 	    "Return a newly created pipe: a pair of ports which are linked\n"
 	    "together on the local machine.  The @emph{car} is the input\n"
 	    "port and the @emph{cdr} is the output port.  Data written (and\n"
@@ -236,20 +236,54 @@ SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0,
 	    "child process.  The need to flush the output port can be\n"
 	    "avoided by making it unbuffered using @code{setvbuf}.\n"
 	    "\n"
+            "Optionally, on systems that support it such as GNU/Linux and\n"
+            "GNU/Hurd, @var{flags} can specify a bitwise-or of the following\n"
+            "constants:\n"
+            "\n"
+            "@table @code\n"
+            "@item O_CLOEXEC\n"
+            "Mark the returned file descriptors as close-on-exec;\n"
+            "@item O_DIRECT\n"
+            "Create a pipe that performs input/output in \"packet\"\n"
+            "mode---see @command{man 2 pipe} for details;\n"
+            "@item O_NONBLOCK\n"
+            "Set the @code{O_NONBLOCK} status flag (non-blocking input and\n"
+            "output) on the file descriptors.\n"
+            "@end table\n"
+            "\n"
+            "On systems that do @emph{not} support it, passing a non-zero\n"
+            "@var{flags} value triggers a @code{system-error} exception.\n"
+	    "\n"
 	    "Writes occur atomically provided the size of the data in bytes\n"
 	    "is not greater than the value of @code{PIPE_BUF}.  Note that\n"
 	    "the output port is likely to block if too much data (typically\n"
 	    "equal to @code{PIPE_BUF}) has been written but not yet read\n"
 	    "from the input port.")
-#define FUNC_NAME s_scm_pipe
+#define FUNC_NAME s_scm_pipe2
 {
-  int fd[2], rv;
+  int fd[2], rv, c_flags;
   SCM p_rd, p_wt;
 
-  rv = pipe (fd);
+  if (SCM_UNBNDP (flags))
+    c_flags = 0;
+  else
+    SCM_VALIDATE_INT_COPY (1, flags, c_flags);
+
+#ifdef HAVE_PIPE2
+  rv = pipe2 (fd, c_flags);
+#else
+  if (c_flags == 0)
+    rv = pipe (fd);
+  else
+    /* 'pipe2' cannot be emulated on systems that lack it: calling
+       'fnctl' afterwards to set the relevant flags is not equivalent
+       because it's not atomic.  */
+    rv = ENOSYS;
+#endif
+
   if (rv)
     SCM_SYSERROR;
-  
+
   p_rd = scm_i_fdes_to_port (fd[0], scm_mode_bits ("r"), sym_read_pipe,
                              SCM_FPORT_OPTION_NOT_SEEKABLE);
   p_wt = scm_i_fdes_to_port (fd[1], scm_mode_bits ("w"), sym_write_pipe,
@@ -258,6 +292,11 @@ SCM_DEFINE (scm_pipe, "pipe", 0, 0, 0,
 }
 #undef FUNC_NAME
 
+SCM
+scm_pipe (void)
+{
+  return scm_pipe2 (SCM_INUM0);
+}
 
 #ifdef HAVE_GETGROUPS
 SCM_DEFINE (scm_getgroups, "getgroups", 0, 0, 0,
diff --git a/libguile/posix.h b/libguile/posix.h
index ff3bec9ea..e62c84afe 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -1,7 +1,7 @@
 #ifndef SCM_POSIX_H
 #define SCM_POSIX_H
 
-/* Copyright 1995-1998,2000-2001,2003,2006,2008-2011,2018,2021
+/* Copyright 1995-1998,2000-2001,2003,2006,2008-2011,2018,2021,2022
      Free Software Foundation, Inc.
 
    This file is part of Guile.
@@ -34,6 +34,7 @@ SCM_API SCM scm_setsid (void);
 SCM_API SCM scm_getsid (SCM pid);
 SCM_API SCM scm_setpgid (SCM pid, SCM pgid);
 SCM_API SCM scm_pipe (void);
+SCM_INTERNAL SCM scm_pipe2 (SCM flags);
 SCM_API SCM scm_getgroups (void);
 SCM_API SCM scm_setgroups (SCM groups);
 SCM_API SCM scm_getpgrp (void);
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index 500dbb94a..1b1580f5d 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -231,6 +231,41 @@
         (throw 'unresolved))))
 
 ;;
+;; pipe
+;;
+
+(with-test-prefix "pipe"
+
+  (pass-if-equal "in and out"
+      "hi!\n"
+    (let ((in+out (pipe)))
+      (display "hi!\n" (cdr in+out))
+      (close-port (cdr in+out))
+      (let ((str (list->string (list (read-char (car in+out))
+                                     (read-char (car in+out))
+                                     (read-char (car in+out))
+                                     (read-char (car in+out))))))
+        (and (eof-object? (read-char (car in+out)))
+             (begin
+               (close-port (car in+out))
+               str)))))
+
+  (pass-if-equal "O_CLOEXEC"
+      (list FD_CLOEXEC FD_CLOEXEC)
+    (let* ((in+out (catch 'system-error
+                     (lambda ()
+                       (pipe O_CLOEXEC))
+                     (lambda args
+                       (if (= (system-error-errno args) ENOSYS)
+                           (throw 'unresolved)
+                           (apply throw args)))))
+           (flags (list (fcntl (car in+out) F_GETFD)
+                        (fcntl (cdr in+out) F_GETFD))))
+      (close-port (car in+out))
+      (close-port (cdr in+out))
+      flags)))
+
+;;
 ;; system*
 ;;