diff --git a/NEWS b/NEWS index ca194f319..dfe1895ee 100644 --- a/NEWS +++ b/NEWS @@ -11,6 +11,13 @@ Changes in 3.0.9 (since 3.0.8) * New interfaces and functionality +** `open-file' now supports an "e" flag for O_CLOEXEC + +Until now, the high-level `open-file' facility did not provide a way to +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. + ** Abstract Unix-domain sockets are supported It is now possible to create an AF_UNIX socket with a leading zero byte diff --git a/doc/ref/api-io.texi b/doc/ref/api-io.texi index 93bbca5ba..a0be2dd57 100644 --- a/doc/ref/api-io.texi +++ b/doc/ref/api-io.texi @@ -996,6 +996,9 @@ Also, open the file using the binary-compatible character encoding @item + Open the port for both input and output. E.g., @code{r+}: open an existing file for both input and output. +@item e +Mark the underlying file descriptor as close-on-exec, as per the +@code{O_CLOEXEC} flag. @item 0 Create an "unbuffered" port. In this case input and output operations are passed directly to the underlying port diff --git a/libguile/fports.c b/libguile/fports.c index 4a3c30b88..121d50bf0 100644 --- a/libguile/fports.c +++ b/libguile/fports.c @@ -1,4 +1,4 @@ -/* Copyright 1995-2004,2006-2015,2017-2020 +/* Copyright 1995-2004,2006-2015,2017-2020,2022 Free Software Foundation, Inc. This file is part of Guile. @@ -208,6 +208,9 @@ scm_i_mode_to_open_flags (SCM mode, int *is_binary, const char *FUNC_NAME) flags |= O_BINARY; #endif break; + case 'e': + flags |= O_CLOEXEC; + break; case '0': /* unbuffered: handled later. */ case 'l': /* line buffered: handled during output. */ break; @@ -368,6 +371,9 @@ SCM_DEFINE (scm_i_open_file, "open-file", 2, 0, 1, "@item +\n" "Open the port for both input and output. E.g., @code{r+}: open\n" "an existing file for both input and output.\n" + "@item e\n" + "Mark the underlying file descriptor as close-on-exec, as per the\n" + "@code{O_CLOEXEC} flag.\n" "@item 0\n" "Create an \"unbuffered\" port. In this case input and output\n" "operations are passed directly to the underlying port\n" diff --git a/test-suite/standalone/Makefile.am b/test-suite/standalone/Makefile.am index e87100c96..547241afa 100644 --- a/test-suite/standalone/Makefile.am +++ b/test-suite/standalone/Makefile.am @@ -1,7 +1,7 @@ ## Process this file with automake to produce Makefile.in. ## ## Copyright 2003, 2004, 2005, 2006, 2007, 2008, 2009, 2010, -## 2011, 2012, 2013, 2014, 2020, 2021 Free Software Foundation, Inc. +## 2011, 2012, 2013, 2014, 2020, 2021, 2022 Free Software Foundation, Inc. ## ## This file is part of GUILE. ## @@ -301,4 +301,7 @@ TESTS += test-stack-overflow check_SCRIPTS += test-out-of-memory TESTS += test-out-of-memory +check_SCRIPTS += test-close-on-exec +TESTS += test-close-on-exec + EXTRA_DIST += ${check_SCRIPTS} diff --git a/test-suite/standalone/test-close-on-exec b/test-suite/standalone/test-close-on-exec new file mode 100755 index 000000000..1eb46c20a --- /dev/null +++ b/test-suite/standalone/test-close-on-exec @@ -0,0 +1,38 @@ +#!/bin/sh +exec guile -q -s "$0" "$@" +!# + +;;; Exercise the 'e' flag to 'open-file' (O_CLOEXEC). + +(define file + (string-append (or (getenv "TMPDIR") "/tmp") + "/guile-test-close-on-exec-" + (number->string (getpid)) ".txt")) + +;;; Since fcntl(2) F_GETFD does not return flags such as O_CLOEXEC, +;;; create a child process, call 'exec', and make sure it doesn't +;;; inherit the file descriptor. +(let ((port (open-file file "we"))) + (display "Hello!\n" port) + (let ((pid (primitive-fork))) + (if (zero? pid) + (dynamic-wind + (const #t) + (lambda () + (execlp "guile" "guile" "-c" + (object->string + `(catch #t + (lambda () + (fdopen ,(fileno port) "w") + (primitive-exit 0)) + (lambda (key . args) + (pk 'child-exception args) + (if (and (eq? key 'system-error) + (= EBADF (system-error-errno (cons key args)))) + (primitive-exit 1) + (primitive-exit 2))))))) + (lambda () + (primitive-exit 3))) + (let ((status (pk 'child-status (cdr (waitpid pid))))) + (false-if-exception (delete-file file)) + (exit (equal? (status:exit-val status) 1))))))