* [PATCH] Bindings to *at functions & allowing more functions to operate on ports
@ 2021-03-12 21:59 Maxime Devos
2021-03-27 21:19 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
0 siblings, 2 replies; 24+ messages in thread
From: Maxime Devos @ 2021-03-12 21:59 UTC (permalink / raw)
Cc: guile-devel
[-- Attachment #1.1: Type: text/plain, Size: 438 bytes --]
Hi guilers!
This patch series defines:
* More AT_* and O_* flags.
* Bindings to *at functions (e.g. mkdirat, fchmodat).
* Bindings to f* functions (e.g. fchdir).
(No new functions, the old functions just accept more types.)
It also sprinkles some scm_remember_upto_here's in
some procedures operating on ports where I think it's needed.
I haven't assigned copyright to the FSF, how would this work?
Greetings,
Maxime
[-- Attachment #1.2: 0001-Add-scm_remember_upto_here-to-functions-using-a-port.patch --]
[-- Type: text/x-patch, Size: 14965 bytes --]
From e4deaca45606a9ade686e7cf447c9cec93e8c9e2 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Sat, 6 Mar 2021 21:39:52 +0100
Subject: [PATCH 01/17] Add scm_remember_upto_here to functions using a port's
fd.
This prevents a garbage collection cycle at an inopportune
time from closing a port while its file descriptor is still
required.
* libguile/filesys.c
(scm_chown, scm_stat, scm_fcntl, scm_fsync, scm_sendfile)
(scm_chmod): Add a scm_remember_upto_here after the system call
is done with fhe file descriptor.
* libguile/fports.c
(fport_input_waiting, fport_read, fport_write, fport_seek)
(fport_truncate, fport_close, port_random_access_p)
(fport_get_natural_buffer_sizes): Likewise.
* libguile/ioext.c
(scm_dup_to_fdes, scm_dup2, scm_isatty_p)
(scm_primitive_move_to_fdes): Likewise.
* libguile/posix.c
(scm_ttyname, scm_tcgetpgrp, scm_tcsetpgrp, scm_flock): Likewise.
(scm_piped_process): Likewise, and introduce the 'error_port',
'output_port' and 'input_port' variables in order to be able
to remember these later.
* libguile/rw.c
(scm_read_string_x_partial, scm_write_string_partial): Likewise,
and introduce a 'port' variable in order to be able to remember
it later.
* THANKS: Add patch author.
---
THANKS | 1 +
libguile/filesys.c | 6 ++++++
libguile/fports.c | 11 +++++++++++
libguile/ioext.c | 7 ++++++-
libguile/posix.c | 28 +++++++++++++++++-----------
libguile/rw.c | 26 ++++++++++++++++++++------
libguile/socket.c | 17 ++++++++++++++---
7 files changed, 75 insertions(+), 21 deletions(-)
diff --git a/THANKS b/THANKS
index aa4877e95..cdfa9e10d 100644
--- a/THANKS
+++ b/THANKS
@@ -78,6 +78,7 @@ For fixes or providing information which led to a fix:
Brian Crowder
Christopher Cramer
Josh Datko
+ Maxime Devos
David Diffenbaugh
Hyper Division
Erik Dominikus
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 666bcb8c3..b97614498 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -177,6 +177,7 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
SCM_FPORT_FDES (object) : scm_to_int (object));
SCM_SYSCALL (rv = fchown (fdes, scm_to_int (owner), scm_to_int (group)));
+ scm_remember_upto_here_1 (object);
}
else
#endif
@@ -581,6 +582,7 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
SCM_VALIDATE_OPFPORT (1, object);
fdes = SCM_FPORT_FDES (object);
SCM_SYSCALL (rv = fstat_or_fstat64 (fdes, &stat_temp));
+ scm_remember_upto_here_1 (object);
}
if (rv == -1)
@@ -1012,6 +1014,7 @@ SCM_DEFINE (scm_fcntl, "fcntl", 2, 1, 0,
SCM_SYSCALL (rv = fcntl (fdes, scm_to_int (cmd), ivalue));
if (rv == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (object);
return scm_from_int (rv);
}
#undef FUNC_NAME
@@ -1039,6 +1042,7 @@ SCM_DEFINE (scm_fsync, "fsync", 1, 0, 0,
if (fsync (fdes) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (object);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1260,6 +1264,7 @@ SCM_DEFINE (scm_sendfile, "sendfile", 3, 1, 0,
}
+ scm_remember_upto_here_2 (in, out);
return scm_from_size_t (total);
#undef VALIDATE_FD_OR_PORT
@@ -1453,6 +1458,7 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
else
fdes = SCM_FPORT_FDES (object);
SCM_SYSCALL (rv = fchmod (fdes, scm_to_int (mode)));
+ scm_remember_upto_here_1 (object);
}
else
#endif
diff --git a/libguile/fports.c b/libguile/fports.c
index 4a3c30b88..5c59f0958 100644
--- a/libguile/fports.c
+++ b/libguile/fports.c
@@ -480,6 +480,7 @@ fport_input_waiting (SCM port)
if (poll (&pollfd, 1, 0) < 0)
scm_syserror ("fport_input_waiting");
+ scm_remember_upto_here_1 (port);
return pollfd.revents & POLLIN ? 1 : 0;
}
@@ -606,6 +607,7 @@ fport_read (SCM port, SCM dst, size_t start, size_t count)
return -1;
scm_syserror ("fport_read");
}
+ scm_remember_upto_here_1 (port);
return ret;
}
@@ -630,6 +632,7 @@ fport_write (SCM port, SCM src, size_t start, size_t count)
scm_syserror ("fport_write");
}
+ scm_remember_upto_here_1 (port);
return ret;
}
@@ -640,6 +643,7 @@ fport_seek (SCM port, scm_t_off offset, int whence)
scm_t_off result;
result = lseek (fp->fdes, offset, whence);
+ scm_remember_upto_here_1 (port);
if (result == -1)
scm_syserror ("fport_seek");
@@ -654,6 +658,8 @@ fport_truncate (SCM port, scm_t_off length)
if (ftruncate (fp->fdes, length) == -1)
scm_syserror ("ftruncate");
+
+ scm_remember_upto_here_1 (port);
}
static void
@@ -673,6 +679,8 @@ fport_close (SCM port)
Instead just throw an error if close fails, trusting that the fd
was cleaned up. */
scm_syserror ("fport_close");
+
+ scm_remember_upto_here_1 (port);
}
static int
@@ -686,6 +694,7 @@ fport_random_access_p (SCM port)
if (lseek (fp->fdes, 0, SEEK_CUR) == -1)
return 0;
+ scm_remember_upto_here_1 (port);
return 1;
}
@@ -705,6 +714,8 @@ fport_get_natural_buffer_sizes (SCM port, size_t *read_size, size_t *write_size)
if (fstat (fp->fdes, &st) == 0)
*read_size = *write_size = st.st_blksize;
+
+ scm_remember_upto_here_1 (port);
#endif
}
diff --git a/libguile/ioext.c b/libguile/ioext.c
index d08b68df3..9dc1980dd 100644
--- a/libguile/ioext.c
+++ b/libguile/ioext.c
@@ -140,6 +140,7 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
if (SCM_UNBNDP (fd))
{
newfd = dup (oldfd);
+ scm_remember_upto_here_1 (fd_or_port);
if (newfd == -1)
SCM_SYSERROR;
fd = scm_from_int (newfd);
@@ -151,6 +152,7 @@ SCM_DEFINE (scm_dup_to_fdes, "dup->fdes", 1, 1, 0,
{
scm_evict_ports (newfd); /* see scsh manual. */
rv = dup2 (oldfd, newfd);
+ scm_remember_upto_here_1 (fd_or_port);
if (rv == -1)
SCM_SYSERROR;
}
@@ -179,6 +181,7 @@ SCM_DEFINE (scm_dup2, "dup2", 2, 0, 0,
c_oldfd = scm_to_int (oldfd);
c_newfd = scm_to_int (newfd);
rv = dup2 (c_oldfd, c_newfd);
+ scm_remember_upto_here_2 (oldfd, newfd);
if (rv == -1)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
@@ -219,7 +222,8 @@ SCM_DEFINE (scm_isatty_p, "isatty?", 1, 0, 0,
return SCM_BOOL_F;
rv = isatty (SCM_FPORT_FDES (port));
- return scm_from_bool(rv);
+ scm_remember_upto_here_1 (port);
+ return scm_from_bool(rv);
}
#undef FUNC_NAME
@@ -278,6 +282,7 @@ SCM_DEFINE (scm_primitive_move_to_fdes, "primitive-move->fdes", 2, 0, 0,
stream->fdes = new_fd;
scm_run_fdes_finalizers (old_fd);
SCM_SYSCALL (close (old_fd));
+ scm_remember_upto_here_1 (port);
return SCM_BOOL_T;
}
#undef FUNC_NAME
diff --git a/libguile/posix.c b/libguile/posix.c
index 47769003a..f76722a43 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1029,6 +1029,7 @@ SCM_DEFINE (scm_ttyname, "ttyname", 1, 0, 0,
SCM_SYSCALL (result = ttyname (fd));
err = errno;
+ scm_remember_upto_here_1 (port);
if (result != NULL)
result = strdup (result);
@@ -1093,6 +1094,7 @@ SCM_DEFINE (scm_tcgetpgrp, "tcgetpgrp", 1, 0, 0,
fd = SCM_FPORT_FDES (port);
if ((pgid = tcgetpgrp (fd)) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (port);
return scm_from_int (pgid);
}
#undef FUNC_NAME
@@ -1116,6 +1118,7 @@ SCM_DEFINE (scm_tcsetpgrp, "tcsetpgrp", 2, 0, 0,
fd = SCM_FPORT_FDES (port);
if (tcsetpgrp (fd, scm_to_int (pgid)) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (port);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1404,19 +1407,21 @@ scm_piped_process (SCM prog, SCM args, SCM from, SCM to)
}
{
- 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);
+ SCM error_port, output_port = SCM_UNDEFINED, input_port = SCM_UNDEFINED;
+
+ if (SCM_OPOUTFPORTP ((error_port = scm_current_error_port ())))
+ err = SCM_FPORT_FDES (error_port);
+ if (out == -1 && SCM_OPOUTFPORTP ((output_port = scm_current_output_port ())))
+ out = SCM_FPORT_FDES (output_port);
+ if (in == -1 && SCM_OPINFPORTP ((input_port = scm_current_input_port ())))
+ in = SCM_FPORT_FDES (input_port);
+
+ pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c,
+ in, out, err);
+ scm_remember_upto_here_2 (input_port, output_port);
+ scm_remember_upto_here (error_port);
}
- pid = start_child (exec_file, exec_argv, reading, c2p, writing, p2c,
- in, out, err);
-
if (pid == -1)
{
int errno_save = errno;
@@ -2241,6 +2246,7 @@ SCM_DEFINE (scm_flock, "flock", 2, 0, 0,
}
if (flock (fdes, scm_to_int (operation)) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (file);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
diff --git a/libguile/rw.c b/libguile/rw.c
index 7afae1c63..ff1b2f7d1 100644
--- a/libguile/rw.c
+++ b/libguile/rw.c
@@ -109,6 +109,7 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
size_t offset;
long read_len;
long chars_read = 0;
+ SCM port = SCM_UNDEFINED;
int fdes;
{
@@ -124,8 +125,8 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
fdes = scm_to_int (port_or_fdes);
else
{
- SCM port = (SCM_UNBNDP (port_or_fdes)?
- scm_current_input_port () : port_or_fdes);
+ port = (SCM_UNBNDP (port_or_fdes)?
+ scm_current_input_port () : port_or_fdes);
SCM_VALIDATE_OPFPORT (2, port);
SCM_VALIDATE_INPUT_PORT (2, port);
@@ -162,7 +163,13 @@ SCM_DEFINE (scm_read_string_x_partial, "read-string!/partial", 1, 3, 0,
}
}
- scm_remember_upto_here_1 (str);
+ /* We need to remember 'port' here; 'port_or_fdes' won't suffice
+ as '(current-input-port)' can be assigned to 'port'
+ and the '(current-input-port)' can be changed by an asynchronuous
+ interrupt, potentially allowing the old input port to be garbage
+ collected and closed, even though the system call still requires
+ its file descriptor. */
+ scm_remember_upto_here_2 (port, str);
return scm_from_long (chars_read);
}
#undef FUNC_NAME
@@ -214,6 +221,7 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
const char *src;
scm_t_off write_len;
int fdes;
+ SCM port = SCM_UNDEFINED;
{
size_t offset;
@@ -234,8 +242,8 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
fdes = scm_to_int (port_or_fdes);
else
{
- SCM port = (SCM_UNBNDP (port_or_fdes)?
- scm_current_output_port () : port_or_fdes);
+ port = (SCM_UNBNDP (port_or_fdes)?
+ scm_current_output_port () : port_or_fdes);
SCM write_buf;
size_t end;
@@ -266,7 +274,13 @@ SCM_DEFINE (scm_write_string_partial, "write-string/partial", 1, 3, 0,
SCM_SYSERROR;
}
- scm_remember_upto_here_1 (str);
+ /* We need to rememember 'port'; remembering 'port_or_fdes' won't
+ suffice as '(current-output-port)' can be assigned to 'port'
+ and the '(current-output-port)' can be changed by an asynchronuous
+ interrupt, potentially allowing the old output port to be garbage
+ collected and closed even though the 'write' system call still
+ requires the file descriptor. */
+ scm_remember_upto_here_2 (str, port);
return scm_from_long (rv);
}
}
diff --git a/libguile/socket.c b/libguile/socket.c
index 8af6f57bf..8b9e64a8b 100644
--- a/libguile/socket.c
+++ b/libguile/socket.c
@@ -503,6 +503,7 @@ SCM_DEFINE (scm_getsockopt, "getsockopt", 3, 0, 0,
if (getsockopt (fd, ilevel, ioptname, (void *) &optval, &optlen) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (sock);
if (ilevel == SOL_SOCKET)
{
#ifdef SO_LINGER
@@ -673,6 +674,8 @@ SCM_DEFINE (scm_setsockopt, "setsockopt", 4, 0, 0,
if (setsockopt (fd, ilevel, ioptname, optval, optlen) == -1)
SCM_SYSERROR;
+
+ scm_remember_upto_here_1 (sock);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -707,6 +710,7 @@ SCM_DEFINE (scm_shutdown, "shutdown", 2, 0, 0,
fd = SCM_FPORT_FDES (sock);
if (shutdown (fd, scm_to_signed_integer (how, 0, 2)) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (sock);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -876,6 +880,7 @@ SCM_DEFINE (scm_connect, "connect", 2, 1, 1,
SCM_SYSERROR;
}
free (soka);
+ scm_remember_upto_here_1 (sock);
return SCM_BOOL_T;
}
#undef FUNC_NAME
@@ -946,6 +951,7 @@ SCM_DEFINE (scm_bind, "bind", 2, 1, 1,
SCM_SYSERROR;
}
free (soka);
+ scm_remember_upto_here_1 (sock);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -967,6 +973,7 @@ SCM_DEFINE (scm_listen, "listen", 2, 0, 0,
fd = SCM_FPORT_FDES (sock);
if (listen (fd, scm_to_int (backlog)) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (sock);
return SCM_UNSPECIFIED;
}
#undef FUNC_NAME
@@ -1284,6 +1291,7 @@ SCM_DEFINE (scm_accept4, "accept", 1, 1, 0,
return SCM_BOOL_F;
SCM_SYSERROR;
}
+ scm_remember_upto_here_1 (sock);
newsock = scm_socket_fd_to_port (newfd);
address = _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
@@ -1314,6 +1322,7 @@ SCM_DEFINE (scm_getsockname, "getsockname", 1, 0, 0,
if (getsockname (fd, (struct sockaddr *) &addr, &addr_size) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (sock);
return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
}
#undef FUNC_NAME
@@ -1336,6 +1345,7 @@ SCM_DEFINE (scm_getpeername, "getpeername", 1, 0, 0,
if (getpeername (fd, (struct sockaddr *) &addr, &addr_size) == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (sock);
return _scm_from_sockaddr (&addr, addr_size, FUNC_NAME);
}
#undef FUNC_NAME
@@ -1381,7 +1391,7 @@ SCM_DEFINE (scm_recv, "recv!", 2, 1, 0,
if (SCM_UNLIKELY (rv == -1))
SCM_SYSERROR;
- scm_remember_upto_here (buf);
+ scm_remember_upto_here_2 (sock, buf);
return scm_from_int (rv);
}
#undef FUNC_NAME
@@ -1426,7 +1436,7 @@ SCM_DEFINE (scm_send, "send", 2, 1, 0,
if (rv == -1)
SCM_SYSERROR;
- scm_remember_upto_here_1 (message);
+ scm_remember_upto_here_2 (sock, message);
return scm_from_int (rv);
}
#undef FUNC_NAME
@@ -1504,6 +1514,7 @@ SCM_DEFINE (scm_recvfrom, "recvfrom!", 2, 3, 0,
if (rv == -1)
SCM_SYSERROR;
+ scm_remember_upto_here_1 (sock);
/* `recvfrom' does not necessarily return an address. Usually nothing
is returned for stream sockets. */
if (((struct sockaddr *) &addr)->sa_family != AF_UNSPEC)
@@ -1586,7 +1597,7 @@ SCM_DEFINE (scm_sendto, "sendto", 3, 1, 1,
}
free (soka);
- scm_remember_upto_here_1 (message);
+ scm_remember_upto_here_2 (sock, message);
return scm_from_int (rv);
}
#undef FUNC_NAME
--
2.30.2
[-- Attachment #1.3: 0002-Allow-file-ports-in-chdir-when-supported.patch --]
[-- Type: text/x-patch, Size: 2786 bytes --]
From af8c3fdfad9343dec8b44dedfb05da9c99cc8269 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Tue, 9 Mar 2021 15:59:36 +0100
Subject: [PATCH 02/17] =?UTF-8?q?Allow=20file=20ports=20in=20=E2=80=98chdi?=
=?UTF-8?q?r=E2=80=99=20when=20supported..?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Check for ‘fchdir’.
* libguile/filesys.c (scm_chdir): Suppport file ports.
* doc/ref/posix.texi (Processes): Update accordingly.
---
configure.ac | 3 ++-
doc/ref/posix.texi | 2 ++
libguile/filesys.c | 16 +++++++++++++++-
3 files changed, 19 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index 271ac3c2d..a23249d95 100644
--- a/configure.ac
+++ b/configure.ac
@@ -481,7 +481,8 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# sendfile - non-POSIX, found in glibc
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
- fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid \
+ fesetround ftime ftruncate fchown fchmod fchdir \
+ getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 2b2d6eb4f..54c564cb0 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -1641,6 +1641,8 @@ The return value is unspecified.
@deffnx {C Function} scm_chdir (str)
@cindex current directory
Change the current working directory to @var{str}.
+@var{str} can be a string containing a file name,
+or a port if the @code{fchdir} system call is supported.
The return value is unspecified.
@end deffn
diff --git a/libguile/filesys.c b/libguile/filesys.c
index b97614498..a8879f0e1 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -658,12 +658,26 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0,
SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
(SCM str),
"Change the current working directory to @var{str}.\n"
+ "@var{str} can be a string containing a file name,\n"
+ "or a port if the @code{fchdir} system call is supported.\n"
"The return value is unspecified.")
#define FUNC_NAME s_scm_chdir
{
int ans;
- STRING_SYSCALL (str, c_str, ans = chdir (c_str));
+#ifdef HAVE_FCHDIR
+ if (SCM_OPFPORTP (str))
+ {
+ int fdes;
+ fdes = SCM_FPORT_FDES (str);
+ SCM_SYSCALL (ans = fchdir (fdes));
+ scm_remember_upto_here_1 (str);
+ }
+ else
+#endif
+ {
+ STRING_SYSCALL (str, c_str, ans = chdir (c_str));
+ }
if (ans != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
--
2.30.2
[-- Attachment #1.4: 0003-Allow-file-ports-in-readlink.patch --]
[-- Type: text/x-patch, Size: 3861 bytes --]
From 2fb0446d5b4f410608adcfe3297338bdeef23abe Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Wed, 10 Mar 2021 12:07:01 +0100
Subject: [PATCH 03/17] =?UTF-8?q?Allow=20file=20ports=20in=20=E2=80=98read?=
=?UTF-8?q?link=E2=80=99.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect whether ‘readlinkat’ is defined.
* libguile/filesys.c (scm_readlink): Support file ports
when ‘readlinkat’ exists.
* doc/ref/posix.texi (File System): Document it.
---
configure.ac | 2 +-
doc/ref/posix.texi | 3 ++-
libguile/filesys.c | 45 ++++++++++++++++++++++++++++++++++++---------
3 files changed, 39 insertions(+), 11 deletions(-)
diff --git a/configure.ac b/configure.ac
index a23249d95..0f032272a 100644
--- a/configure.ac
+++ b/configure.ac
@@ -481,7 +481,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# sendfile - non-POSIX, found in glibc
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
- fesetround ftime ftruncate fchown fchmod fchdir \
+ fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 54c564cb0..68de5a2ed 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -795,7 +795,8 @@ file it points to. @var{path} must be a string.
@deffn {Scheme Procedure} readlink path
@deffnx {C Function} scm_readlink (path)
Return the value of the symbolic link named by @var{path} (a
-string), i.e., the file that the link points to.
+string, or a port if the @code{readlinkat} system call is supported),
+i.e., the file that the link points to.
@end deffn
@findex fchown
diff --git a/libguile/filesys.c b/libguile/filesys.c
index a8879f0e1..06a550fc8 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1081,10 +1081,25 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_SYMLINK */
-SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
+/* Static helper function for choosing between readlink
+ and readlinkat. */
+static int
+do_readlink (int fd, const char *c_path, char *buf, size_t size)
+{
+#ifdef HAVE_READLINKAT
+ if (fd != -1)
+ return readlinkat (fd, c_path, buf, size);
+#else
+ (void) fd;
+#endif
+ return readlink (c_path, buf, size);
+}
+
+SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
(SCM path),
- "Return the value of the symbolic link named by @var{path} (a\n"
- "string), i.e., the file that the link points to.")
+ "Return the value of the symbolic link named by @var{path} (a\n"
+ "string, or a port if the @code{readlinkat} system call is supported),\n"
+ "i.e., the file that the link points to.")
#define FUNC_NAME s_scm_readlink
{
int rv;
@@ -1092,20 +1107,32 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
char *buf;
SCM result;
char *c_path;
-
- scm_dynwind_begin (0);
-
- c_path = scm_to_locale_string (path);
- scm_dynwind_free (c_path);
+ int fdes;
+ scm_dynwind_begin (0);
+#ifdef HAVE_READLINKAT
+ if (SCM_FPORTP (path))
+ {
+ SCM_VALIDATE_OPINPORT (SCM_ARG1, path);
+ c_path = "";
+ fdes = SCM_FPORT_FDES (path);
+ }
+ else
+#endif
+ {
+ fdes = -1;
+ c_path = scm_to_locale_string (path);
+ scm_dynwind_free (c_path);
+ }
buf = scm_malloc (size);
- while ((rv = readlink (c_path, buf, size)) == size)
+ while ((rv = do_readlink (fdes, c_path, buf, size)) == size)
{
free (buf);
size *= 2;
buf = scm_malloc (size);
}
+ scm_remember_upto_here_1 (path);
if (rv == -1)
{
int save_errno = errno;
--
2.30.2
[-- Attachment #1.5: 0004-Accept-open-file-ports-in-utime-when-supported.patch --]
[-- Type: text/x-patch, Size: 6676 bytes --]
From 021567541a2685b6b7467d08188c51cd22368374 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Wed, 10 Mar 2021 15:02:03 +0100
Subject: [PATCH 04/17] =?UTF-8?q?Accept=20open=20file=20ports=20in=20?=
=?UTF-8?q?=E2=80=98utime=E2=80=99=20when=20supported.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect if the ‘futimens’ system call
is defined.
* libguile/posix.c (scm_utime): Allow file ports if the
‘futimens’ and ‘utimensat’ system calls are defined.
* doc/ref/posix.texi (File System): Document it.
* test-suite/tests/posix.test: Test it.
---
configure.ac | 4 ++--
doc/ref/posix.texi | 10 ++++++----
libguile/posix.c | 22 +++++++++++++++++++---
test-suite/tests/posix.test | 33 +++++++++++++++++++++++++++++++--
4 files changed, 58 insertions(+), 11 deletions(-)
diff --git a/configure.ac b/configure.ac
index 0f032272a..551856fc4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -474,7 +474,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# truncate - not in mingw
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
-# strcoll_l, newlocale, uselocale, utimensat - POSIX.1-2008
+# strcoll_l, newlocale, uselocale, utimensat, futimens - POSIX.1-2008
# strtol_l - non-POSIX, found in glibc
# fork - unavailable on Windows
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
@@ -491,7 +491,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 futimens])
# 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 68de5a2ed..80ee02b93 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -832,7 +832,8 @@ The return value is unspecified.
@deffn {Scheme Procedure} utime pathname [actime [modtime [actimens [modtimens [flags]]]]]
@deffnx {C Function} scm_utime (pathname, actime, modtime, actimens, modtimens, flags)
@code{utime} sets the access and modification times for the
-file named by @var{pathname}. If @var{actime} or @var{modtime} is
+file named by @var{pathname} (a string, or a file port if supported
+by the host system). If @var{actime} or @var{modtime} is
not supplied, then the current time is used. @var{actime} and
@var{modtime} must be integer time values as returned by the
@code{current-time} procedure.
@@ -848,9 +849,10 @@ will set the access time to one hour in the past and the
modification time to the current time.
@vindex AT_SYMLINK_NOFOLLOW
-Last, @var{flags} may be either @code{0} or the
-@code{AT_SYMLINK_NOFOLLOW} constant, to set the time of
-@var{pathname} even if it is a symbolic link.
+Last, @var{flags} may be either @code{0} or;
+if @var{pathname} is not a port, the @code{AT_SYMLINK_NOFOLLOW}
+constant, to set the time of @var{pathname} even if it is a
+symbolic link.
@end deffn
@findex unlink
diff --git a/libguile/posix.c b/libguile/posix.c
index f76722a43..351ce8c0c 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1629,7 +1629,8 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
(SCM pathname, SCM actime, SCM modtime, SCM actimens, SCM modtimens,
SCM flags),
"@code{utime} sets the access and modification times for the\n"
- "file named by @var{pathname}. If @var{actime} or @var{modtime} is\n"
+ "file named by @var{pathname} (a string, or a file port if\n"
+ "supported by the host system). If @var{actime} or @var{modtime} is\n"
"not supplied, then the current time is used. @var{actime} and\n"
"@var{modtime} must be integer time values as returned by the\n"
"@code{current-time} procedure.\n\n"
@@ -1703,8 +1704,23 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
times[1].tv_sec = mtim_sec;
times[1].tv_nsec = mtim_nsec;
- STRING_SYSCALL (pathname, c_pathname,
- rv = utimensat (AT_FDCWD, c_pathname, times, f));
+#ifdef HAVE_FUTIMENS
+ if (SCM_OPFPORTP (pathname))
+ {
+ int fd;
+ fd = SCM_FPORT_FDES (pathname);
+ if (f != 0)
+ scm_out_of_range (FUNC_NAME, flags);
+
+ SCM_SYSCALL (rv = futimens (fd, times));
+ scm_remember_upto_here_1 (pathname);
+ }
+ else
+#endif
+ {
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = utimensat (AT_FDCWD, c_pathname, times, f));
+ }
}
#else
{
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index 135f09c11..88f9d8a58 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -1,6 +1,6 @@
;;;; posix.test --- Test suite for Guile POSIX functions. -*- scheme -*-
;;;;
-;;;; Copyright 2003-2004,2006-2007,2010,2012,2015,2017-2019
+;;;; Copyright 2003-2004,2006-2007,2010,2012,2015,2017-2019,2021
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -211,7 +211,36 @@
(list (stat:atime info) (stat:mtime info))))
(lambda ()
(delete-file file))))
- (throw 'unsupported))))
+ (throw 'unsupported)))
+
+ (pass-if-equal "file port"
+ '(1 1)
+ (let ((file "posix.test-utime"))
+ (dynamic-wind
+ (lambda ()
+ (close-port (open-output-file file)))
+ (lambda ()
+ (with-input-from-file file
+ (lambda ()
+ (catch 'system-error
+ (lambda ()
+ (catch 'wrong-type-arg
+ (lambda ()
+ (utime file 1 1 0 0))
+ ;; 'futimens' is not supported on all
+ ;; platforms.
+ (lambda _
+ (throw 'unsupported))))
+ (lambda args
+ ;; On some platforms, 'futimens' returns
+ ;; ENOSYS according to Gnulib.
+ (if (= (system-error-errno args) ENOSYS)
+ (throw 'unsupported)
+ (apply throw args))))))
+ (let ((info (stat file)))
+ (list (stat:atime info) (stat:mtime info))))
+ (lambda ()
+ (delete-file file))))))
;;
;; affinity
--
2.30.2
[-- Attachment #1.6: 0005-Define-symlinkat-wrapper-when-supported.patch --]
[-- Type: text/x-patch, Size: 3742 bytes --]
From 83e4862a1d9a023f1c2a19a1938d761cb020d6d8 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Wed, 10 Mar 2021 20:50:07 +0100
Subject: [PATCH 05/17] =?UTF-8?q?Define=20=E2=80=98symlinkat=E2=80=99=20wr?=
=?UTF-8?q?apper=20when=20supported.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect whether ‘symlinkat’ exists.
* libguile/filesys.c (scm_symlinkat): Define a Scheme binding
when it exists.
* libguile/filesys.h: Make the binding part of the public C API.
* doc/ref/posix.texi (File System): Document the binding.
---
configure.ac | 2 +-
doc/ref/posix.texi | 6 ++++++
libguile/filesys.c | 23 +++++++++++++++++++++++
libguile/filesys.h | 1 +
4 files changed, 31 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index 551856fc4..1af02bb7b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -482,7 +482,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- getcwd geteuid getsid \
+ symlinkat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 80ee02b93..eff49b5a5 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -919,6 +919,12 @@ Create a symbolic link named @var{newpath} with the value (i.e., pointing to)
@var{oldpath}. The return value is unspecified.
@end deffn
+@deffn {Scheme Procedure} symlinkat dir oldpath newpath
+@deffnx {C Function} scm_symlinkat (dir, oldpath, newpath)
+Like @code{symlink}, but resolve @var{newpath} relative to
+the directory referred to by the file port @var{dir}.
+@end deffn
+
@deffn {Scheme Procedure} mkdir path [mode]
@deffnx {C Function} scm_mkdir (path, mode)
Create a new directory named by @var{path}. If @var{mode} is omitted
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 06a550fc8..f86b5bb70 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1081,6 +1081,29 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_SYMLINK */
+#ifdef HAVE_SYMLINKAT
+SCM_DEFINE (scm_symlinkat, "symlinkat", 3, 0, 0,
+ (SCM dir, SCM oldpath, SCM newpath),
+ "Like @code{symlink}, but resolve @var{newpath} relative\n"
+ "to the directory referred to by the file port @var{dir}.")
+#define FUNC_NAME s_scm_symlinkat
+{
+ int val;
+ int fdes;
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ fdes = SCM_FPORT_FDES (dir);
+ STRING2_SYSCALL (oldpath, c_oldpath,
+ newpath, c_newpath,
+ val = symlinkat (c_oldpath, fdes, c_newpath));
+ scm_remember_upto_here_1 (dir);
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SYMLINKAT */
+
/* Static helper function for choosing between readlink
and readlinkat. */
static int
diff --git a/libguile/filesys.h b/libguile/filesys.h
index a3b257c12..d181aca52 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -62,6 +62,7 @@ SCM_API SCM scm_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs)
SCM_API SCM scm_fcntl (SCM object, SCM cmd, SCM value);
SCM_API SCM scm_fsync (SCM object);
SCM_API SCM scm_symlink (SCM oldpath, SCM newpath);
+SCM_API SCM scm_symlinkat (SCM dir, SCM oldpath, SCM newpath);
SCM_API SCM scm_readlink (SCM path);
SCM_API SCM scm_lstat (SCM str);
SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
--
2.30.2
[-- Attachment #1.7: 0006-Define-bindings-to-mkdirat-when-the-C-function-exist.patch --]
[-- Type: text/x-patch, Size: 3614 bytes --]
From 68f62489c75c8449bd6bdf8fa3c8aacbf19cc33f Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Thu, 11 Mar 2021 20:40:18 +0100
Subject: [PATCH 06/17] =?UTF-8?q?Define=20bindings=20to=20=E2=80=98mkdirat?=
=?UTF-8?q?=E2=80=99=20when=20the=20C=20function=20exists.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect if ‘mkdirat’ exists.
* libguile/filesys.c (scm_mkdirat): Define the Scheme binding.
* doc/ref/posix.texi (File System): Document it.
---
configure.ac | 2 +-
doc/ref/posix.texi | 6 ++++++
libguile/filesys.c | 25 +++++++++++++++++++++++++
libguile/filesys.h | 1 +
4 files changed, 33 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index 1af02bb7b..15b0ff4a9 100644
--- a/configure.ac
+++ b/configure.ac
@@ -482,7 +482,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat getcwd geteuid getsid \
+ symlinkat mkdirat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index eff49b5a5..72e0c3032 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -934,6 +934,12 @@ Otherwise they are set to the value specified with @var{mode}.
The return value is unspecified.
@end deffn
+@deffn {Scheme Proecdure} mkdirat dir path [mode]
+@deffnx {C Function} scm_mkdirat (dir, path, mode)
+Like @code{mkdir}, but resolve @var{path} relative to the directory
+referred to by the file port @var{dir} instead.
+@end deffn
+
@deffn {Scheme Procedure} rmdir path
@deffnx {C Function} scm_rmdir (path)
Remove the existing directory named by @var{path}. The directory must
diff --git a/libguile/filesys.c b/libguile/filesys.c
index f86b5bb70..2d0c619af 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1397,6 +1397,31 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_MKDIRAT
+SCM_DEFINE (scm_mkdirat, "mkdirat", 2, 1, 0,
+ (SCM dir, SCM path, SCM mode),
+ "Like @code{mkdir}, but resolve @var{path} relative to the directory\n"
+ "referred to by the file port @var{dir} instead.")
+#define FUNC_NAME s_scm_mkdirat
+{
+ int rv;
+ int dir_fdes;
+ mode_t c_mode;
+
+ c_mode = SCM_UNBNDP (mode) ? 0777 : scm_to_uint (mode);
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (path, c_path, rv = mkdirat (dir_fdes, c_path, c_mode));
+ if (rv != 0)
+ SCM_SYSERROR;
+
+ scm_remember_upto_here_1 (dir);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
(SCM path),
"Remove the existing directory named by @var{path}. The directory must\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index d181aca52..f0dd35ede 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -50,6 +50,7 @@ SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
SCM_API SCM scm_mkdir (SCM path, SCM mode);
+SCM_API SCM scm_mkdirat (SCM dir, SCM path, SCM mode);
SCM_API SCM scm_rmdir (SCM path);
SCM_API SCM scm_directory_stream_p (SCM obj);
SCM_API SCM scm_opendir (SCM dirname);
--
2.30.2
[-- Attachment #1.8: 0007-Define-AT_REMOVEDIR-and-others-when-available.patch --]
[-- Type: text/x-patch, Size: 1169 bytes --]
From f2e681ec9562cd23f0cfaba7edd3702aafb673b6 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Thu, 11 Mar 2021 21:01:45 +0100
Subject: [PATCH 07/17] Define AT_REMOVEDIR and others when available.
* libguile/posix.c (scm_init_posix): Define (in Scheme)
AT_REMOVEDIR, AT_FDCWD and AT_EACCESS when defined (in C).
---
libguile/posix.c | 11 ++++++++++-
1 file changed, 10 insertions(+), 1 deletion(-)
diff --git a/libguile/posix.c b/libguile/posix.c
index 351ce8c0c..2ee459d2d 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,4 +1,4 @@
-/* Copyright 1995-2014,2016-2019
+/* Copyright 1995-2014,2016-2019,2021
Free Software Foundation, Inc.
This file is part of Guile.
@@ -2482,6 +2482,15 @@ scm_init_posix ()
#ifdef AT_EMPTY_PATH
scm_c_define ("AT_EMPTY_PATH", scm_from_int (AT_EMPTY_PATH));
#endif
+#ifdef AT_REMOVEDIR
+ scm_c_define ("AT_REMOVEDIR", scm_from_int (AT_REMOVEDIR));
+#endif
+#ifdef AT_FDCWD
+ scm_c_define ("AT_FDCWD", scm_from_int (AT_FDCWD));
+#endif
+#ifdef AT_EACCESS
+ scm_c_define ("AT_EACCESS", scm_from_int (AT_EACCESS));
+#endif
#include "cpp-SIG.c"
#include "posix.x"
--
2.30.2
[-- Attachment #1.9: 0008-Define-a-Scheme-binding-to-renameat-when-it-exists.patch --]
[-- Type: text/x-patch, Size: 4037 bytes --]
From cf9308cb74fee4f4401cf06a8701318f885a6bd3 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Thu, 11 Mar 2021 22:47:16 +0100
Subject: [PATCH 08/17] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98renameat=E2=80=99=20when=20it=20exists.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect if ‘renameat’ is defined.
* libguile/filesys.c (scm_renameat): Define a Scheme binding
to the ‘renameat’ system call.
* doc/ref/posix.texi (File System): Document it.
* libguile/filesys.h (scm_renameat): Make it part of the C API.
---
configure.ac | 2 +-
doc/ref/posix.texi | 8 ++++++++
libguile/filesys.c | 27 +++++++++++++++++++++++++++
libguile/filesys.h | 1 +
4 files changed, 37 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index 15b0ff4a9..a2ad3364f 100644
--- a/configure.ac
+++ b/configure.ac
@@ -482,7 +482,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat mkdirat getcwd geteuid getsid \
+ symlinkat mkdirat renameat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 72e0c3032..a5dabf5e1 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -905,6 +905,14 @@ Renames the file specified by @var{oldname} to @var{newname}.
The return value is unspecified.
@end deffn
+@findex renameat
+@deffn {Scheme Procedure} rename-file-at olddir oldname newdir newname
+@deffnx {C Function} scm_renameat (olddir, oldname, newdir, newname)
+Like @code{rename-file}, but resolve @var{oldname} and @var{newname}
+relative to the directories referred to by the file ports @var{olddir}
+and @var{newdir} respectively.
+@end deffn
+
@deffn {Scheme Procedure} link oldpath newpath
@deffnx {C Function} scm_link (oldpath, newpath)
Creates a new name @var{newpath} in the file system for the
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 2d0c619af..61a16f981 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1454,6 +1454,33 @@ SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_RENAMEAT
+SCM_DEFINE (scm_renameat, "rename-file-at", 4, 0, 0,
+ (SCM olddir, SCM oldname, SCM newdir, SCM newname),
+ "Like @code{rename-file}, but resolve @var{oldname} and @var{newname}\n"
+ "relative to the directories referred to by the file ports @var{olddir}\n"
+ "and @var{newdir} respectively.")
+#define FUNC_NAME s_scm_renameat
+{
+ int rv;
+ int old_fdes, new_fdes;
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, olddir);
+ SCM_VALIDATE_OPFPORT (SCM_ARG3, newdir);
+
+ old_fdes = SCM_FPORT_FDES (olddir);
+ new_fdes = SCM_FPORT_FDES (newdir);
+
+ STRING2_SYSCALL (oldname, c_oldname,
+ newname, c_newname,
+ rv = renameat (old_fdes, c_oldname, new_fdes, c_newname));
+ scm_remember_upto_here_2 (olddir, newdir);
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
(SCM str),
diff --git a/libguile/filesys.h b/libguile/filesys.h
index f0dd35ede..7e17cc585 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -48,6 +48,7 @@ SCM_API SCM scm_close_fdes (SCM fd);
SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
+SCM_API SCM scm_renameat (SCM olddir, SCM oldname, SCM newdir, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
SCM_API SCM scm_mkdir (SCM path, SCM mode);
SCM_API SCM scm_mkdirat (SCM dir, SCM path, SCM mode);
--
2.30.2
[-- Attachment #1.10: 0009-Define-a-Scheme-binding-to-fchmodat-when-defined.patch --]
[-- Type: text/x-patch, Size: 10147 bytes --]
From e2ce6ad6d73f32bb630607abf6e90c0e51897db7 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 13:20:45 +0100
Subject: [PATCH 09/17] Define a Scheme binding to fchmodat when defined.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
fchmodat on both regular files and symbolic links is known
to behave oddly when the flag AT_SYMLINK_NOFOLLOW is passed
on some Linux versions and file systems, and fchmodat is not
required by POSIX to function on symbolic links, so define a
few tests to make sure the situation is understood correctly.
* configure.ac: Detect existence of ‘fchmodat’.
* libguile/filesys.c (scm_chmodat): Define the Scheme binding.
* libguile/filesys.h (scm_chmodat): Make the binding part of the API.
* test-suite/tests/filesys.test: Test the Scheme binding, in particular
whether ‘AT_SYMLINK_NOFOLLOW’ works as expected.
---
configure.ac | 2 +-
doc/ref/posix.texi | 16 ++++++
libguile/filesys.c | 38 +++++++++++++
libguile/filesys.h | 1 +
test-suite/tests/filesys.test | 104 ++++++++++++++++++++++++++++++++++
5 files changed, 160 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index a2ad3364f..20357ce3b 100644
--- a/configure.ac
+++ b/configure.ac
@@ -482,7 +482,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat mkdirat renameat getcwd geteuid getsid \
+ symlinkat mkdirat renameat fchmodat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index a5dabf5e1..2bc067f74 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -829,6 +829,22 @@ the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}.
The return value is unspecified.
@end deffn
+@findex fchmodat
+@deffn {Scheme Procedure} chmodat dir pathname mode [flags]
+@deffnx {C Function} scm_chmodat (dir, pathname, mode, flags)
+Like @var{chmod}, but modify the permissions of the file named
+@var{pathname} in the directory referred to by the file port
+@var{dir} instead.
+The optional @var{flags} argument may be 0 or @code{AT_SYMLINK_NOFOLLOW},
+in which case @var{pathname} is not dereferenced if it is a symbolic link,
+i.e., the permissions of the symbolic link itself are modified.
+
+Note that @code{AT_SYMLINK_NOFOLLOW} is not supported on all systems
+when @var{pathname} names a symbolic link and may result in @code{ENOTSUP}.
+Also, on some systems (e.g. GNU/Linux) using this flag for a regular file
+incorrectly results in @code{ENOTSUP}.
+@end deffn
+
@deffn {Scheme Procedure} utime pathname [actime [modtime [actimens [modtimens [flags]]]]]
@deffnx {C Function} scm_utime (pathname, actime, modtime, actimens, modtimens, flags)
@code{utime} sets the access and modification times for the
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 61a16f981..52380cd20 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1588,6 +1588,44 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_FCHMODAT
+SCM_DEFINE (scm_chmodat, "chmodat", 3, 1, 0,
+ (SCM dir, SCM pathname, SCM mode, SCM flags),
+ "Like @var{chmod}, but modify the permissions of the file named\n"
+ "@var{pathname} in the directory referred to by the file port\n"
+ "@var{dir} instead.\n"
+ "The optional @var{flags} argument may be 0 or @code{AT_SYMLINK_NOFOLLOW},\n"
+ "in which case @var{pathname} is not dereferenced if it is a symbolic link,\n"
+ "i.e., the permissions of the symbolic link itself are modified.\n\n"
+ "Note that @code{AT_SYMLINK_NOFOLLOW} is not supported on all systems\n"
+ "when @var{pathname} names a symbolic link and may result in @code{ENOTSUP}.\n"
+ "Also, on some systems (e.g. GNU/Linux) using this flag for a regular file\n"
+ "incorrectly results in @code{ENOTSUP}.")
+#define FUNC_NAME s_scm_chmodat
+{
+ int rv;
+ int c_flags;
+ int dir_fdes;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = fchmodat (dir_fdes, c_pathname,
+ scm_to_int (mode), c_flags));
+ scm_remember_upto_here_1 (dir);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
(SCM mode),
"If @var{mode} is omitted, returns a decimal number representing the current\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 7e17cc585..377a3795e 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -40,6 +40,7 @@ SCM_API scm_t_bits scm_tc16_dir;
SCM_API SCM scm_chown (SCM object, SCM owner, SCM group);
SCM_API SCM scm_chmod (SCM object, SCM mode);
+SCM_API SCM scm_chmodat (SCM dir, SCM pathname, SCM mode, SCM flags);
SCM_API SCM scm_umask (SCM mode);
SCM_API SCM scm_open_fdes (SCM path, SCM flags, SCM mode);
SCM_API SCM scm_open (SCM path, SCM flags, SCM mode);
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 6fed981e5..d85f51aac 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -265,3 +265,107 @@
(result (eqv? 'directory (stat:type _stat))))
(false-if-exception (rmdir name))
result)))))
+
+;;;
+;;; chmodat
+;;;
+
+(with-test-prefix "chmodat"
+ (call-with-output-file (test-file) (const #f))
+ (chmod (test-file) #o000)
+
+ (pass-if-equal "regular file"
+ #o300
+ (unless (defined? 'chmodat)
+ (throw 'unsupported))
+ (let ((d (open "/" O_RDONLY)))
+ (chmodat d (test-file) #o300)
+ (let ((p (stat:perms (stat (test-file)))))
+ (close-port d)
+ p)))
+
+ (chmod (test-file) #o000)
+ (pass-if-equal "regular file, AT_SYMLINK_NOFOLLOW"
+ #o300
+ (unless (and (defined? 'chmodat)
+ (defined? 'AT_SYMLINK_NOFOLLOW))
+ (throw 'unsupported))
+ (let ((dir (open "/" O_RDONLY)))
+ (catch 'system-error
+ (lambda ()
+ (chmodat dir (test-file) #o300 AT_SYMLINK_NOFOLLOW))
+ (lambda args
+ (close-port dir)
+ ;; AT_SYMLINK_NOFOLLOW is not supported on Linux (at least Linux 5.11.2
+ ;; with the btrfs file system), even for regular files.
+ (cond ((not (= ENOTSUP (system-error-errno args)))
+ (apply throw args))
+ ((string-contains %host-type "linux")
+ (display "warning: on this Linux version and file system, fchmodat incorrectly returns ENOTSUP even for regular files")
+ (newline)
+ (throw 'unresolved))
+ (#t (apply throw args)))))
+ (close-port dir)
+ (let ((p (stat:perms (stat (test-file)))))
+ (close-port dir)
+ p)))
+
+ (chmod (test-file) #o000)
+ (let* ((symlink-created
+ (not (false-if-exception
+ (begin (symlink (test-file) (test-symlink)) #t))))
+ (has-required-procedures?
+ (and symlink-created (defined? 'chmodat) (defined? 'lstat))))
+
+ ;; Without AT_SYMLINK_NOFOLLOW, modify the file permissions
+ ;; of the file pointed at, and not the permissions of the
+ ;; symbolic link.
+ (pass-if "symbolic link"
+ (unless has-required-procedures?
+ (throw 'unsupported))
+ (let* ((old-perms (stat:perms (lstat (test-symlink))))
+ (dir (open "/" O_RDONLY)))
+ (chmodat dir (test-symlink) #o700)
+ (let ((ok (equal? (cons #o700 old-perms)
+ (cons (stat:perms (stat (test-file)))
+ (stat:perms (lstat (test-symlink)))))))
+ (close-port dir)
+ ok)))
+
+ (chmod (test-file) #o000)
+ ;; With AT_SYMLINK_NOFOLLOW, modify the file permissions
+ ;; of the symbolic link itself, instead of the file it points
+ ;; to -- unless this is not supported, of course.
+ (pass-if "symbolic link, AT_SYMLINK_NOFOLLOW"
+ (unless (and (defined? 'AT_SYMLINK_NOFOLLOW)
+ has-required-procedures?)
+ (throw 'unsupported))
+ (let* ((old-perms (stat:perms (stat (test-file))))
+ (old-symlink-perms (stat:perms (lstat (test-symlink))))
+ (new-symlink-perms (logxor #o700 old-symlink-perms))
+ (dir (open "/" O_RDONLY)))
+ (catch 'system-error
+ (lambda ()
+ (chmodat dir (test-symlink) new-symlink-perms AT_SYMLINK_NOFOLLOW))
+ (lambda args
+ (close-port dir)
+ ;; AT_SYMLINK_NOFOLLOW is not supported on Linux (at least Linux 5.11.2
+ ;; with the btrfs file system).
+ (cond ((not (= ENOTSUP (system-error-errno args)))
+ (apply throw args))
+ ((and (= (stat:perms (stat (test-file))) old-perms)
+ (= (stat:perms (lstat (test-symlink))) old-symlink-perms))
+ (throw 'unresolved))
+ ((string-contains %host-type "linux")
+ (display "warning: on this Linux version and file system, fchmodat incorrectly returns ENOTSUP")
+ (newline)
+ (throw 'unresolved))
+ (#t (apply throw args)))))
+ (close-port dir)
+ (equal? (pk 'p (cons old-perms new-symlink-perms))
+ (pk 'q (cons (stat:perms (stat (test-file)))
+ (stat:perms (lstat (test-symlink))))))))))
+
+(delete-file (test-file))
+(when (file-exists? (test-symlink))
+ (delete-file (test-symlink)))
--
2.30.2
[-- Attachment #1.11: 0010-Define-delete-file-at-when-unlinkat-exists.patch --]
[-- Type: text/x-patch, Size: 5467 bytes --]
From 5c303d44bf094b777fb7d8eae5b4ce9cc00c597b Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 15:10:23 +0100
Subject: [PATCH 10/17] Define delete-file-at when unlinkat exists.
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
unlinkat is used for both unlinking regular files
and removing empty directories.
* configure.ac: Detect if unlinkat exists.
* doc/ref/posix.texi (File System): Document why there is no
‘rmdirat’ procedure, and document the ‘delete-file-at’ procedure.
* libguile/filesys.c
(scm_rmdir): Adjust the docstring here as well.
(scm_delete_file_at): Define a Scheme binding to ‘unlinkat’.
* libguile/filesys.h (scm_delete_file_at): Make ‘scm_delete_file_at’
part of the C API.
---
configure.ac | 2 +-
doc/ref/posix.texi | 13 +++++++++++++
libguile/filesys.c | 33 ++++++++++++++++++++++++++++++++-
libguile/filesys.h | 1 +
4 files changed, 47 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index 20357ce3b..dea94a364 100644
--- a/configure.ac
+++ b/configure.ac
@@ -482,7 +482,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat mkdirat renameat fchmodat getcwd geteuid getsid \
+ symlinkat mkdirat renameat fchmodat unlinkat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 2bc067f74..dcea0352a 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -878,6 +878,18 @@ Deletes (or ``unlinks'') the file whose path is specified by
@var{str}.
@end deffn
+@findex unlinkat
+@deffn {Scheme Procedure} delete-file-at dir str [flags]
+@deffnx {C Function} scm_delete_file_at (dir, str, flags)
+Like @code{unlink}, but resolve @var{str} relative to the
+directory referred to by the file port @var{dir} instead.
+
+The optional @var{flags} argument can be @code{AT_REMOVEDIR},
+in which case @code{delete-file-at} will act like @code{rmdir} instead
+of @code{delete-file}. Why doesn't POSIX have a @code{rmdirat} function
+for this instead? No idea!
+@end deffn
+
@deffn {Scheme Procedure} copy-file oldfile newfile
@deffnx {C Function} scm_copy_file (oldfile, newfile)
Copy the file specified by @var{oldfile} to @var{newfile}.
@@ -968,6 +980,7 @@ referred to by the file port @var{dir} instead.
@deffnx {C Function} scm_rmdir (path)
Remove the existing directory named by @var{path}. The directory must
be empty for this to succeed. The return value is unspecified.
+There is no @code{rmdirat} procedure; use @code{delete-file-at} instead.
@end deffn
@deffn {Scheme Procedure} opendir dirname
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 52380cd20..baa149a33 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1425,7 +1425,8 @@ SCM_DEFINE (scm_mkdirat, "mkdirat", 2, 1, 0,
SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
(SCM path),
"Remove the existing directory named by @var{path}. The directory must\n"
- "be empty for this to succeed. The return value is unspecified.")
+ "be empty for this to succeed. The return value is unspecified.\n"
+ "There is no @code{rmdirat} procedure, use @code{delete-file-at} instead.")
#define FUNC_NAME s_scm_rmdir
{
int val;
@@ -1495,6 +1496,36 @@ SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
}
#undef FUNC_NAME
+SCM_DEFINE (scm_delete_file_at, "delete-file-at", 2, 1, 0,
+ (SCM dir, SCM str, SCM flags),
+ "Like @code{unlink}, but resolve @var{str} relative to the\n"
+ "directory referred to by the file port @var{dir} instead.\n\n"
+ "The optional @var{flags} argument can be @code{AT_REMOVEDIR},\n"
+ "in which case @code{delete-file-at} will act like @code{rmdir} instead\n"
+ "of @code{delete-file}. Why doesn't POSIX have a @code{rmdirat} function\n"
+ "for this instead? No idea!")
+#define FUNC_NAME s_scm_delete_file_at
+{
+ int ans;
+ int dir_fdes;
+ int c_flags;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (str, c_str, ans = unlinkat (dir_fdes, c_str, c_flags));
+ scm_remember_upto_here_1 (dir);
+ if (ans != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+
SCM_DEFINE (scm_access, "access?", 2, 0, 0,
(SCM path, SCM how),
"Test accessibility of a file under the real UID and GID of the\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 377a3795e..37d084cd5 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -51,6 +51,7 @@ SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_renameat (SCM olddir, SCM oldname, SCM newdir, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
+SCM_API SCM scm_delete_file_at (SCM dir, SCM str, SCM flags);
SCM_API SCM scm_mkdir (SCM path, SCM mode);
SCM_API SCM scm_mkdirat (SCM dir, SCM path, SCM mode);
SCM_API SCM scm_rmdir (SCM path);
--
2.30.2
[-- Attachment #1.12: 0011-Define-a-Scheme-binding-to-fchownat-when-available.patch --]
[-- Type: text/x-patch, Size: 4393 bytes --]
From 1e322e6298ebed31e982bb4ad3a4132f8e7b2036 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 17:30:58 +0100
Subject: [PATCH 11/17] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98fchownat=E2=80=99=20when=20available.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect whether ‘fchownat’ is available.
* libguile/filesys.c (scm_chownat): Define a Scheme binding to
‘fchownat’ when available.
* libguile/filesys.h (scm_chownat): Make it part of the API.
* doc/ref/posix.texi (File System): Document it.
---
configure.ac | 3 ++-
doc/ref/posix.texi | 11 +++++++++++
libguile/filesys.c | 35 +++++++++++++++++++++++++++++++++++
libguile/filesys.h | 1 +
4 files changed, 49 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index dea94a364..5f8389b82 100644
--- a/configure.ac
+++ b/configure.ac
@@ -482,7 +482,8 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat mkdirat renameat fchmodat unlinkat getcwd geteuid getsid \
+ symlinkat mkdirat renameat fchmodat unlinkat fchownat \
+ getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index dcea0352a..077ba8c79 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -817,6 +817,17 @@ unsupported at present). If @var{owner} or @var{group} is specified
as @code{-1}, then that ID is not changed.
@end deffn
+@findex fchownat
+@deffn {Scheme Procedure} chownat dir name owner group [flags]
+@deffnx {C Function} scm_chownat (dir, name, owner, group, flags)
+Like @code{chown}, but modify the owner and/or group of
+the file named @var{name} in the directory referred to
+by the file port @var{dir} instead. The optional argument
+@var{flags} is a bitmask. If @code{AT_SYMLINK_NOFOLLOW} is
+present, then @var{name} will not be dereferenced if it is a
+symbolic link.
+@end deffn
+
@findex fchmod
@deffn {Scheme Procedure} chmod object mode
@deffnx {C Function} scm_chmod (object, mode)
diff --git a/libguile/filesys.c b/libguile/filesys.c
index baa149a33..a319d9794 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -193,6 +193,41 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_CHOWN */
+#ifdef HAVE_FCHOWNAT
+SCM_DEFINE (scm_chownat, "chownat", 4, 1, 0,
+ (SCM dir, SCM name, SCM owner, SCM group, SCM flags),
+ "Like @code{chown}, but modify the owner and/or group of\n"
+ "the file named @var{name} in the directory referred to\n"
+ "by the file port @var{dir} instead. The optional argument\n"
+ "@var{flags} is a bitmask. If @code{AT_SYMLINK_NOFOLLOW} is\n"
+ "present, then @var{name} will not be dereferenced if it is a\n"
+ "symbolic link.")
+#define FUNC_NAME s_scm_chownat
+{
+ int rv;
+ int dir_fdes;
+ int c_flags;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (name, c_name,
+ rv = fchownat (dir_fdes, c_name,
+ scm_to_int (owner), scm_to_int (group),
+ c_flags));
+ scm_remember_upto_here_1 (dir);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_FCHOWNAT */
+
\f
SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 37d084cd5..7673c8051 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -39,6 +39,7 @@ SCM_API scm_t_bits scm_tc16_dir;
\f
SCM_API SCM scm_chown (SCM object, SCM owner, SCM group);
+SCM_API SCM scm_chownat (SCM dir, SCM object, SCM owner, SCM group, SCM flags);
SCM_API SCM scm_chmod (SCM object, SCM mode);
SCM_API SCM scm_chmodat (SCM dir, SCM pathname, SCM mode, SCM flags);
SCM_API SCM scm_umask (SCM mode);
--
2.30.2
[-- Attachment #1.13: 0012-Define-a-Scheme-binding-to-fstatat-when-available.patch --]
[-- Type: text/x-patch, Size: 5614 bytes --]
From b761434c6b7be1c6bcbe6eb0a179b7fb897272cc Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 19:10:34 +0100
Subject: [PATCH 12/17] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98fstatat=E2=80=99=20when=20available.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect if ‘fstatat’ is defined.
* libguile/filesys.c (scm_statat): Define a Scheme binding to ‘fstatat’.
* libguile/filesys.h (scm_statat): Make it part of the C API.
* doc/ref/posix.texi (File System): Document it.
* libguile/syscalls.h (fstatat_or_fstatat64): Choose between ‘fstatat’
and ‘fstatat64’.
---
configure.ac | 4 ++--
doc/ref/posix.texi | 12 ++++++++++++
libguile/filesys.c | 42 ++++++++++++++++++++++++++++++++++++++++++
libguile/filesys.h | 1 +
libguile/syscalls.h | 1 +
5 files changed, 58 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index 5f8389b82..22cdffdf8 100644
--- a/configure.ac
+++ b/configure.ac
@@ -482,8 +482,8 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat mkdirat renameat fchmodat unlinkat fchownat \
- getcwd geteuid getsid \
+ symlinkat mkdirat renameat fchmodat unlinkat fchownat fstatat \
+ getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 077ba8c79..b595fa44d 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -792,6 +792,18 @@ it will return information about a symbolic link itself, not the
file it points to. @var{path} must be a string.
@end deffn
+@deffn {Scheme Procedure} statat dir filename [flags]
+@deffnx {C Function} scm_statat (dir, filename, flags)
+Similar to @code{stat}, but consider the file
+named @var{filename} in the directory referred to by the file
+port @var{dir} instead.
+
+The optional argument @var{flags} is a bitmask. If it
+contains @code{AT_SYMLINK_NOFOLLOW}, @var{filename} will not be
+dereferenced even if it is a symbolic link, i.e., act as
+@code{lstat} instead of @code{stat}.
+@end deffn
+
@deffn {Scheme Procedure} readlink path
@deffnx {C Function} scm_readlink (path)
Return the value of the symbolic link named by @var{path} (a
diff --git a/libguile/filesys.c b/libguile/filesys.c
index a319d9794..454ce228e 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -637,6 +637,48 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_FSTATAT
+SCM_DEFINE (scm_statat, "statat", 2, 1, 0,
+ (SCM dir, SCM filename, SCM flags),
+ "Similar to @code{stat}, but consider the file named\n"
+ "@var{filename} in the directory referred to by the file\n"
+ "port @var{dir} instead.\n\n"
+ "The optional argument @var{flags} is a bitmask. If it\n"
+ "contains @code{AT_SYMLINK_NOFOLLOW}, @var{filename} will not be\n"
+ "dereferenced even if it is a symbolic link, i.e., act as\n"
+ "@code{lstat} instead of @code{stat}.")
+#define FUNC_NAME s_scm_statat
+{
+ int rv;
+ int dir_fdes;
+ int c_flags;
+ struct stat_or_stat64 stat_temp;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (filename, c_filename,
+ rv = fstatat_or_fstatat64 (dir_fdes, c_filename,
+ &stat_temp, c_flags));
+ scm_remember_upto_here_1 (dir);
+
+ if (rv != 0)
+ {
+ int en = errno;
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_list_2 (scm_strerror (scm_from_int (en)), filename),
+ en);
+ }
+ return scm_stat2scm (&stat_temp);
+}
+#undef FUNC_NAME
+#endif /* HAVE_FSTATAT */
+
SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
(SCM str),
"Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 7673c8051..8af0f989a 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -48,6 +48,7 @@ SCM_API SCM scm_open (SCM path, SCM flags, SCM mode);
SCM_API SCM scm_close (SCM fd_or_port);
SCM_API SCM scm_close_fdes (SCM fd);
SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
+SCM_API SCM scm_statat (SCM dir, SCM filename, SCM flags);
SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_renameat (SCM olddir, SCM oldname, SCM newdir, SCM newname);
diff --git a/libguile/syscalls.h b/libguile/syscalls.h
index 30b99c193..37d532e60 100644
--- a/libguile/syscalls.h
+++ b/libguile/syscalls.h
@@ -65,6 +65,7 @@
# define readdir_r_or_readdir64_r readdir_r
#endif
#define stat_or_stat64 CHOOSE_LARGEFILE(stat,stat64)
+#define fstatat_or_fstatat64 CHOOSE_LARGEFILE(fstatat,fstatat64)
#define truncate_or_truncate64 CHOOSE_LARGEFILE(truncate,truncate64)
#define scm_from_off_t_or_off64_t CHOOSE_LARGEFILE(scm_from_off_t,scm_from_int64)
#define scm_from_ino_t_or_ino64_t CHOOSE_LARGEFILE(scm_from_ulong,scm_from_uint64)
--
2.30.2
[-- Attachment #1.14: 0013-Define-a-Scheme-binding-to-openat-when-available.patch --]
[-- Type: text/x-patch, Size: 7355 bytes --]
From bb3ff1b5fff3c759c7ec4c0d5c9b10060396b055 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 20:26:29 +0100
Subject: [PATCH 13/17] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98openat=E2=80=99=20when=20available.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect if ‘openat’ is defined.
* libguile/filesys.c
(scm_open_fdes_at, scm_openat): Define the Scheme bindings.
* libguile/filesys.h (scm_open_fdes_at, scm_openat): Make them part
of the API.
* doc/ref/posix.texi (File System): Document them.
* libguile/syscalls.h (openat_or_openat64): Decide between ‘openat’
and ‘openat64’.
---
configure.ac | 2 +-
doc/ref/posix.texi | 13 ++++++
libguile/filesys.c | 97 +++++++++++++++++++++++++++++++++++----------
libguile/filesys.h | 2 +
libguile/syscalls.h | 1 +
5 files changed, 93 insertions(+), 22 deletions(-)
diff --git a/configure.ac b/configure.ac
index 22cdffdf8..85a3a0dac 100644
--- a/configure.ac
+++ b/configure.ac
@@ -482,7 +482,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat mkdirat renameat fchmodat unlinkat fchownat fstatat \
+ symlinkat mkdirat renameat fchmodat unlinkat fchownat fstatat openat \
getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index b595fa44d..29d9b8d28 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -333,12 +333,25 @@ See @xref{File Status Flags,,,libc,The GNU C Library Reference Manual}
or @samp{man 3 strftime}, for additional flags and explanation.
@end deffn
+@deffn {Scheme Procedure} openat dir path flags [mode]
+@deffnx {C Function} scm_openat (dir, path, flags, mode)
+Similar to @code{open}, but resolve the file name @var{path}
+relative to the directory referred to by the file port @var{dir}
+instead.
+@end deffn
+
@deffn {Scheme Procedure} open-fdes path flags [mode]
@deffnx {C Function} scm_open_fdes (path, flags, mode)
Similar to @code{open} but return a file descriptor instead of
a port.
@end deffn
+@deffn {Scheme Procedure} open-fdes-at dir path flags [mode]
+@deffnx {C Function} scm_open_fdes_at (dir, path, flags, mode)
+Similar to @code{openat}, but return a file descriptor instead
+of a port.
+@end deffn
+
@deffn {Scheme Procedure} close fd_or_port
@deffnx {C Function} scm_close (fd_or_port)
Similar to @code{close-port} (@pxref{Ports, close-port}),
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 454ce228e..d0566336a 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -249,6 +249,60 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_OPENAT
+SCM_DEFINE (scm_open_fdes_at, "open-fdes-at", 3, 1, 0,
+ (SCM dir, SCM path, SCM flags, SCM mode),
+ "Similar to @code{openat}, but return a file descriptor instead\n"
+ "of a port.\n")
+#define FUNC_NAME s_scm_open_fdes_at
+{
+ int dir_fdes;
+ int fd;
+ int iflags;
+ int imode;
+
+ iflags = SCM_NUM2INT (SCM_ARG2, flags);
+ imode = SCM_NUM2INT_DEF (3, mode, 0666);
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (path, c_path,
+ fd = openat_or_openat64 (dir_fdes, c_path, iflags, imode));
+ scm_remember_upto_here_1 (dir);
+ if (fd == -1)
+ SCM_SYSERROR;
+ return scm_from_int (fd);
+}
+#undef FUNC_NAME
+#endif /* HAVE_OPENAT */
+
+/* A helper function for converting some open flags to
+ what scm_fdes_to_port expects. */
+static const char *
+flags_to_mode (int iflags)
+{
+ if ((iflags & O_RDWR) == O_RDWR)
+ {
+ /* Opened read-write. */
+ if (iflags & O_APPEND)
+ return "a+";
+ else if (iflags & O_CREAT)
+ return "w+";
+ else
+ return "r+";
+ }
+ else
+ {
+ /* Opened read-only or write-only. */
+ if (iflags & O_APPEND)
+ return "a";
+ else if (iflags & O_WRONLY)
+ return "w";
+ else
+ return "r";
+ }
+}
+
SCM_DEFINE (scm_open, "open", 2, 1, 0,
(SCM path, SCM flags, SCM mode),
"Open the file named by @var{path} for reading and/or writing.\n"
@@ -319,32 +373,33 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
fd = scm_to_int (scm_open_fdes (path, flags, mode));
iflags = SCM_NUM2INT (2, flags);
+ port_mode = (char *) flags_to_mode (iflags);
+ newpt = scm_fdes_to_port (fd, port_mode, path);
+ return newpt;
+}
+#undef FUNC_NAME
- if ((iflags & O_RDWR) == O_RDWR)
- {
- /* Opened read-write. */
- if (iflags & O_APPEND)
- port_mode = "a+";
- else if (iflags & O_CREAT)
- port_mode = "w+";
- else
- port_mode = "r+";
- }
- else
- {
- /* Opened read-only or write-only. */
- if (iflags & O_APPEND)
- port_mode = "a";
- else if (iflags & O_WRONLY)
- port_mode = "w";
- else
- port_mode = "r";
- }
+#ifdef HAVE_OPENAT
+SCM_DEFINE (scm_openat, "openat", 3, 1, 0,
+ (SCM dir, SCM path, SCM flags, SCM mode),
+ "Similar to @code{open}, but resolve the file name @var{path}\n"
+ "relative to the directory referred to by the file port @var{dir}\n"
+ "instead.")
+#define FUNC_NAME s_scm_openat
+{
+ SCM newpt;
+ char *port_mode;
+ int fd;
+ int iflags;
- newpt = scm_fdes_to_port (fd, port_mode, path);
+ fd = scm_to_int (scm_open_fdes_at (dir, path, flags, mode));
+ iflags = SCM_NUM2INT (2, flags);
+ port_mode = (char *) flags_to_mode (iflags);
+ newpt = scm_fdes_to_port (fd, (char *) port_mode, path);
return newpt;
}
#undef FUNC_NAME
+#endif /* HAVE_OPENAT */
SCM_DEFINE (scm_close, "close", 1, 0, 0,
(SCM fd_or_port),
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 8af0f989a..1ce50d30e 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -44,7 +44,9 @@ SCM_API SCM scm_chmod (SCM object, SCM mode);
SCM_API SCM scm_chmodat (SCM dir, SCM pathname, SCM mode, SCM flags);
SCM_API SCM scm_umask (SCM mode);
SCM_API SCM scm_open_fdes (SCM path, SCM flags, SCM mode);
+SCM_API SCM scm_open_fdes_at (SCM dir, SCM path, SCM flags, SCM mode);
SCM_API SCM scm_open (SCM path, SCM flags, SCM mode);
+SCM_API SCM scm_openat (SCM dir, SCM path, SCM flags, SCM mode);
SCM_API SCM scm_close (SCM fd_or_port);
SCM_API SCM scm_close_fdes (SCM fd);
SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
diff --git a/libguile/syscalls.h b/libguile/syscalls.h
index 37d532e60..6f4061138 100644
--- a/libguile/syscalls.h
+++ b/libguile/syscalls.h
@@ -58,6 +58,7 @@
#define lstat_or_lstat64 CHOOSE_LARGEFILE(lstat,lstat64)
#define off_t_or_off64_t CHOOSE_LARGEFILE(off_t,off64_t)
#define open_or_open64 CHOOSE_LARGEFILE(open,open64)
+#define openat_or_openat64 CHOOSE_LARGEFILE(openat,openat64)
#define readdir_or_readdir64 CHOOSE_LARGEFILE(readdir,readdir64)
#if SCM_HAVE_READDIR64_R == 1
# define readdir_r_or_readdir64_r CHOOSE_LARGEFILE(readdir_r,readdir64_r)
--
2.30.2
[-- Attachment #1.15: 0014-Define-a-Scheme-binding-to-readlinkat-when-it-exists.patch --]
[-- Type: text/x-patch, Size: 4839 bytes --]
From 1d152d7fcc4fbf3c6b4492bed8aaf9502ffae778 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 21:32:12 +0100
Subject: [PATCH 14/17] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98readlinkat=E2=80=99=20when=20it=20exists.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* libguile/filesys.c
(scm_readlink): Extract common code with scm_readlinkat ...
(do_readlink_loop): ... to here.
(scm_readlinkat): Define the binding, using ‘do_readlink_loop’.
* libguile/filesys.h (scm_readlinkat): Make the binding part of
the C API.
---
doc/ref/posix.texi | 7 +++++
libguile/filesys.c | 73 ++++++++++++++++++++++++++++++++++------------
libguile/filesys.h | 1 +
3 files changed, 62 insertions(+), 19 deletions(-)
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 29d9b8d28..58dcaec01 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -824,6 +824,13 @@ string, or a port if the @code{readlinkat} system call is supported),
i.e., the file that the link points to.
@end deffn
+@deffn {Scheme Procedure} readlinkat dir path
+@deffnx {C Function} scm_readlinkat (dir, path)
+Like @code{readlink}, but resolve the symbolic link named by
+@var{path} relative to the directory referred to by the file
+port @var{dir} instead.
+@end deffn
+
@findex fchown
@findex lchown
@deffn {Scheme Procedure} chown object owner group
diff --git a/libguile/filesys.c b/libguile/filesys.c
index d0566336a..ecea49822 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1250,6 +1250,35 @@ do_readlink (int fd, const char *c_path, char *buf, size_t size)
return readlink (c_path, buf, size);
}
+/* Except for the possibility of specifying a directory
+ to resolve relative to, scm_readlink and scm_readlinkat
+ function pretty much the same. */
+static SCM
+do_readlink_loop (const char *FUNC_NAME, int fdes, char *c_path)
+{
+ int rv;
+ int size = 100;
+ char *buf;
+ SCM result;
+
+ buf = scm_malloc (size);
+ while ((rv = do_readlink (fdes, c_path, buf, size)) == size)
+ {
+ free (buf);
+ size *= 2;
+ buf = scm_malloc (size);
+ }
+ if (rv == -1)
+ {
+ int save_errno = errno;
+ free (buf);
+ errno = save_errno;
+ SCM_SYSERROR;
+ }
+ result = scm_take_locale_stringn (buf, rv);
+ return result;
+}
+
SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
(SCM path),
"Return the value of the symbolic link named by @var{path} (a\n"
@@ -1257,9 +1286,6 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
"i.e., the file that the link points to.")
#define FUNC_NAME s_scm_readlink
{
- int rv;
- int size = 100;
- char *buf;
SCM result;
char *c_path;
int fdes;
@@ -1279,28 +1305,37 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
c_path = scm_to_locale_string (path);
scm_dynwind_free (c_path);
}
- buf = scm_malloc (size);
-
- while ((rv = do_readlink (fdes, c_path, buf, size)) == size)
- {
- free (buf);
- size *= 2;
- buf = scm_malloc (size);
- }
+ result = do_readlink_loop (FUNC_NAME, fdes, c_path);
scm_remember_upto_here_1 (path);
- if (rv == -1)
- {
- int save_errno = errno;
- free (buf);
- errno = save_errno;
- SCM_SYSERROR;
- }
- result = scm_take_locale_stringn (buf, rv);
+ scm_dynwind_end ();
+ return result;
+}
+#undef FUNC_NAME
+
+#ifdef HAVE_READLINKAT
+SCM_DEFINE (scm_readlinkat, "readlinkat", 2, 0, 0,
+ (SCM dir, SCM path),
+ "Like @code{readlink}, but resolve the symbolic link named by\n"
+ "@var{path} relative to the directory referred to by the file\n"
+ "port @var{dir} instead.")
+#define FUNC_NAME s_scm_readlinkat
+{
+ SCM result;
+ char *c_path;
+ int fdes;
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ fdes = SCM_FPORT_FDES (dir);
+ scm_dynwind_begin (0);
+ c_path = scm_to_locale_string (path);
+ scm_dynwind_free (c_path);
+ result = do_readlink_loop (FUNC_NAME, fdes, c_path);
+ scm_remember_upto_here_1 (dir);
scm_dynwind_end ();
return result;
}
#undef FUNC_NAME
+#endif /* HAVE_READLINKAT */
SCM_DEFINE (scm_copy_file, "copy-file", 2, 0, 0,
(SCM oldfile, SCM newfile),
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 1ce50d30e..65a3c5b75 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -72,6 +72,7 @@ SCM_API SCM scm_fsync (SCM object);
SCM_API SCM scm_symlink (SCM oldpath, SCM newpath);
SCM_API SCM scm_symlinkat (SCM dir, SCM oldpath, SCM newpath);
SCM_API SCM scm_readlink (SCM path);
+SCM_API SCM scm_readlinkat (SCM dir, SCM path);
SCM_API SCM scm_lstat (SCM str);
SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
SCM_API SCM scm_mkstemp (SCM tmpl);
--
2.30.2
[-- Attachment #1.16: 0015-Define-a-Scheme-binding-to-linkat-when-available.patch --]
[-- Type: text/x-patch, Size: 4557 bytes --]
From 8b68e99cddf68e77a64f8179dbd3e8b4e3f1ef2b Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 22:01:53 +0100
Subject: [PATCH 15/17] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98linkat=E2=80=99=20when=20available.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect if ‘linkat’ is available.
* libguile/filesys.c (scm_linkat): Define the Scheme binding.
* libguile/filesys.h (scm_linkat): Make it part of the C API.
* doc/ref/posix.texi (File System): Document it.
---
configure.ac | 2 +-
doc/ref/posix.texi | 11 +++++++++++
libguile/filesys.c | 38 ++++++++++++++++++++++++++++++++++++++
libguile/filesys.h | 1 +
4 files changed, 51 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index 85a3a0dac..10320ce98 100644
--- a/configure.ac
+++ b/configure.ac
@@ -481,7 +481,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# sendfile - non-POSIX, found in glibc
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
- fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
+ fesetround ftime ftruncate fchown fchmod fchdir readlinkat linkat \
symlinkat mkdirat renameat fchmodat unlinkat fchownat fstatat openat \
getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 58dcaec01..dbbf8cc7a 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -992,6 +992,17 @@ link, the link may or may not be followed depending on the
system.
@end deffn
+@deffn {Scheme Procedure} linkat olddir oldpath newdir newpath [flags]
+@deffnx {C Function} scm_linkat (olddir, oldpath, newdir, newpath, flags)
+Like @code{link}, but resolve @var{oldpath} relative to
+the directory referred to by the file port @var{olddir}
+and @var{newpath} relative to @var{newdir} instead.
+
+The optional argument @var{flags} is a bitmask. If it contains
+@code{AT_SYMLINK_FOLLOW}, then @var{oldpath} will be dereferenced
+if it is a symbolic link.
+@end deffn
+
@deffn {Scheme Procedure} symlink oldpath newpath
@deffnx {C Function} scm_symlink (oldpath, newpath)
Create a symbolic link named @var{newpath} with the value (i.e., pointing to)
diff --git a/libguile/filesys.c b/libguile/filesys.c
index ecea49822..f010397bd 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -782,6 +782,44 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_LINKAT
+SCM_DEFINE (scm_linkat, "linkat", 4, 1, 0,
+ (SCM olddir, SCM oldpath, SCM newdir, SCM newpath, SCM flags),
+ "Like @code{link}, but resolve @var{oldpath} relative to\n"
+ "the directory referred to by the file port @var{olddir}\n"
+ "and @var{newpath} relative to @var{newdir} instead.\n\n"
+ "The optional argument @var{flags} is a bitmask. If it contains\n"
+ "@code{AT_SYMLINK_FOLLOW}, then @var{oldpath} will be dereferenced\n"
+ "if it is a symbolic link.")
+#define FUNC_NAME s_scm_linkat
+{
+ int val;
+ int c_flags;
+ int olddir_fdes, newdir_fdes;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, olddir);
+ SCM_VALIDATE_OPFPORT (SCM_ARG2, newdir);
+ olddir_fdes = SCM_FPORT_FDES (olddir);
+ newdir_fdes = SCM_FPORT_FDES (newdir);
+
+ STRING2_SYSCALL (oldpath, c_oldpath,
+ newpath, c_newpath,
+ val = linkat (olddir_fdes, c_oldpath,
+ newdir_fdes, c_newpath,
+ c_flags));
+ scm_remember_upto_here_2 (olddir, newdir);
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
\f
/* {Navigating Directories}
*/
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 65a3c5b75..16eab6d4e 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -52,6 +52,7 @@ SCM_API SCM scm_close_fdes (SCM fd);
SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
SCM_API SCM scm_statat (SCM dir, SCM filename, SCM flags);
SCM_API SCM scm_link (SCM oldpath, SCM newpath);
+SCM_API SCM scm_linkat (SCM olddir, SCM oldpath, SCM newdir, SCM newpath, SCM flags);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_renameat (SCM olddir, SCM oldname, SCM newdir, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
--
2.30.2
[-- Attachment #1.17: 0016-Define-a-Scheme-binding-to-mknodat-when-supported.patch --]
[-- Type: text/x-patch, Size: 5998 bytes --]
From 239396557cd0f428ef803bb034ed1ec4db0cf887 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 22:36:22 +0100
Subject: [PATCH 16/17] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98mknodat=E2=80=99=20when=20supported.?=
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect if ‘mknodat’ exists.
* libguile/posix.texi
(mknod, symbol_to_numeric_type): Split off common code with
‘mknodat’.
(mknodat): Define the new Scheme binding.
* libguile/posix.h (scm_mknodat): Make it part of the C API.
* doc/ref/posix.texi (File System): Document it.
---
configure.ac | 2 +-
doc/ref/posix.texi | 6 ++++
libguile/posix.c | 88 +++++++++++++++++++++++++++++++++-------------
libguile/posix.h | 1 +
4 files changed, 72 insertions(+), 25 deletions(-)
diff --git a/configure.ac b/configure.ac
index 10320ce98..d5a8208f8 100644
--- a/configure.ac
+++ b/configure.ac
@@ -483,7 +483,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat linkat \
symlinkat mkdirat renameat fchmodat unlinkat fchownat fstatat openat \
- getcwd geteuid getsid \
+ mknodat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index dbbf8cc7a..5844e271c 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -1110,6 +1110,12 @@ E.g.,
The return value is unspecified.
@end deffn
+@deffn {Scheme Procedure} mknodat dir path type perms dev
+@deffnx {C Fuction} scm_mknodat (dir, path, type, perms, dev)
+Similar to @code{mknod}, but resolve @var{path} relative to
+@var{dir} instead.
+@end deffn
+
@deffn {Scheme Procedure} tmpnam
@deffnx {C Function} scm_tmpnam ()
@cindex temporary file
diff --git a/libguile/posix.c b/libguile/posix.c
index 2ee459d2d..a74f87215 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1854,6 +1854,38 @@ SCM_DEFINE (scm_setlocale, "setlocale", 1, 1, 0,
#undef FUNC_NAME
#endif /* HAVE_SETLOCALE */
+#if defined(HAVE_MKNOD) || defined(HAVE_MKNODAT)
+/* Static helper function for converting symbols to their
+ corresponding S_* constants */
+static int
+symbol_to_numeric_type (const char *FUNC_NAME, int position, SCM type)
+{
+ const char *p;
+ p = scm_i_symbol_chars (type);
+ if (strcmp (p, "regular") == 0)
+ return S_IFREG;
+ else if (strcmp (p, "directory") == 0)
+ return S_IFDIR;
+#ifdef S_IFLNK
+ /* systems without symlinks probably don't have S_IFLNK defined */
+ else if (strcmp (p, "symlink") == 0)
+ return S_IFLNK;
+#endif
+ else if (strcmp (p, "block-special") == 0)
+ return S_IFBLK;
+ else if (strcmp (p, "char-special") == 0)
+ return S_IFCHR;
+ else if (strcmp (p, "fifo") == 0)
+ return S_IFIFO;
+#ifdef S_IFSOCK
+ else if (strcmp (p, "socket") == 0)
+ return S_IFSOCK;
+#endif
+ else
+ SCM_OUT_OF_RANGE (position, type);
+}
+#endif
+
#ifdef HAVE_MKNOD
SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0,
(SCM path, SCM type, SCM perms, SCM dev),
@@ -1873,34 +1905,12 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0,
#define FUNC_NAME s_scm_mknod
{
int val;
- const char *p;
- int ctype = 0;
+ int ctype;
SCM_VALIDATE_STRING (1, path);
SCM_VALIDATE_SYMBOL (2, type);
- p = scm_i_symbol_chars (type);
- if (strcmp (p, "regular") == 0)
- ctype = S_IFREG;
- else if (strcmp (p, "directory") == 0)
- ctype = S_IFDIR;
-#ifdef S_IFLNK
- /* systems without symlinks probably don't have S_IFLNK defined */
- else if (strcmp (p, "symlink") == 0)
- ctype = S_IFLNK;
-#endif
- else if (strcmp (p, "block-special") == 0)
- ctype = S_IFBLK;
- else if (strcmp (p, "char-special") == 0)
- ctype = S_IFCHR;
- else if (strcmp (p, "fifo") == 0)
- ctype = S_IFIFO;
-#ifdef S_IFSOCK
- else if (strcmp (p, "socket") == 0)
- ctype = S_IFSOCK;
-#endif
- else
- SCM_OUT_OF_RANGE (2, type);
+ ctype = symbol_to_numeric_type (FUNC_NAME, SCM_ARG2, type);
STRING_SYSCALL (path, c_path,
val = mknod (c_path,
@@ -1913,6 +1923,36 @@ SCM_DEFINE (scm_mknod, "mknod", 4, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_MKNOD */
+#ifdef HAVE_MKNODAT
+SCM_DEFINE (scm_mknodat, "mknodat", 5, 0, 0,
+ (SCM dir, SCM path, SCM type, SCM perms, SCM dev),
+ "Similar to @code{mknod}, but resolve @var{path} relative to\n"
+ "@var{dir} instead.")
+#define FUNC_NAME s_scm_mknodat
+{
+ int val;
+ int ctype;
+ int dir_fdes;
+
+ SCM_VALIDATE_STRING (2, path);
+ SCM_VALIDATE_SYMBOL (3, type);
+ SCM_VALIDATE_OPFPORT (1, dir);
+
+ dir_fdes = SCM_FPORT_FDES (dir);
+ ctype = symbol_to_numeric_type (FUNC_NAME, SCM_ARG3, type);
+
+ STRING_SYSCALL (path, c_path,
+ val = mknodat (dir_fdes, c_path,
+ ctype | scm_to_int (perms),
+ scm_to_int (dev)));
+ scm_remember_upto_here_1 (dir);
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_MKNODAT */
+
#ifdef HAVE_NICE
SCM_DEFINE (scm_nice, "nice", 1, 0, 0,
(SCM incr),
diff --git a/libguile/posix.h b/libguile/posix.h
index ff3bec9ea..da82ae8eb 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -76,6 +76,7 @@ SCM_API SCM scm_getpid (void);
SCM_API SCM scm_putenv (SCM str);
SCM_API SCM scm_setlocale (SCM category, SCM locale);
SCM_API SCM scm_mknod (SCM path, SCM type, SCM perms, SCM dev);
+SCM_API SCM scm_mknodat (SCM dir, SCM path, SCM type, SCM perms, SCM dev);
SCM_API SCM scm_nice (SCM incr);
SCM_API SCM scm_sync (void);
SCM_API SCM scm_crypt (SCM key, SCM salt);
--
2.30.2
[-- Attachment #1.18: 0017-Document-recent-new-bindings-for-file-system-functio.patch --]
[-- Type: text/x-patch, Size: 1159 bytes --]
From e8d8b0ce279f0c1ba7243c4bd9ce3c88706a8656 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Fri, 12 Mar 2021 22:43:43 +0100
Subject: [PATCH 17/17] Document recent new bindings for file system functions.
* NEWS (New interfaces and functionality): Add some information
on the new functionality of this patch series.
---
NEWS | 11 +++++++++++
1 file changed, 11 insertions(+)
diff --git a/NEWS b/NEWS
index 3a5956bc3..95fca3b78 100644
--- a/NEWS
+++ b/NEWS
@@ -64,6 +64,17 @@ See "Bytevector Ports" in the manual.
These include various open flags found on GNU/Linux, GNU/Hurd
and BSD, on systems where they are supported.
+** Bindings to openat and other *at functions.
+
+See ‘File System’ in the manual. The procedures are:
+mknodat, linkat, readlinkat, openat, statat, chownat,
+delete-file-at, renameat, chmodat, symlinkat and mkdirat.
+
+** More procedures accept file ports instead of only file names.
+
+See ‘File System’ in the manual. The procedures are:
+chdir, readlink, utime.
+
** `(system foreign-library)' module
See the newly reorganized "Foreign Function Interface", for details.
--
2.30.2
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] Bindings to *at functions & allowing more functions to operate on ports
2021-03-12 21:59 [PATCH] Bindings to *at functions & allowing more functions to operate on ports Maxime Devos
@ 2021-03-27 21:19 ` Maxime Devos
2021-03-28 11:17 ` tomas
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
1 sibling, 1 reply; 24+ messages in thread
From: Maxime Devos @ 2021-03-27 21:19 UTC (permalink / raw)
Cc: Andy Wingo, Ludovic Courtès, guile-devel, Leo Famulari
[-- Attachment #1: Type: text/plain, Size: 2513 bytes --]
Hi,
[CC'ing some Guile and Guix maintainers because this is
important for the security of Guix System.]
I want to explain why these patches (and the O_FLAGS (*)
patch) should be included in Guile. Functions like "openat"
are important to avoid TOCTTOU (time-of-check to time-of-use)
vulnerabilities involving symbolic links.
For example, suppose we have a web server implemented in
Guile. Suppose the address is https://web.gnu. It allows
a local user U (and some others) to define their own web
pages to host at http://web.gnu/~U, by writing files to
/home/U/www. As there are multiple users, the server has
to run as root.
Now suppose U is the malicious kind of user. Then $U
could create a symlink at /home/U/www/maliciousity pointing
to /home/other-user/.gnupg/private-keys-v1.d/FINGERPRINT.key.
Now U could download other-user's gpg key, for example
with "wget http://web.gnu/~U/maliciousity". Oops!
How can this vulnerability be avoided?
* Use O_NOFOLLOW to *not* follow the symbolic link.
Patch for adding O_NOFOLLOW to guile:
<https://debbugs.gnu.org/cgi/bugreport.cgi?bug=46220>.
And why do we need openat? Well, suppose the web server
is not read-only, and supports (say) WebDAV or FTP for
modifying files remotely (I mean U can remotely modify
http://web.gnu/~U). Then U could create a symlink
at /home/U/www/maliciousity pointing to /home/other-user.
Now U can peek into other-user's home directory and overwrite
files. Oops!
How can the web server avoid this?
* First open "/home/U" as usual, resulting in a port $1.
Then use (openat $1 "maliciousity" O_NOFOLLOW), resulting
in a port $2. Use (stat $2) to see if $2 is a directory
or a regular file **and** to see if $2 is owned by $2!
If necessary, recurse, etc. Display a directory listing
or display the file, etc.
How does this matter for Guix?
Guix has a TOCTTOU race:
<https://lists.gnu.org/archive/html/guix-devel/2021-01/msg00388.html>.
It has been partially fixed:
<https://git.savannah.gnu.org/cgit/guix.git/commit/?id=520bac7ed00a949a0391ad680de65a1498105c2b>.
However, a complete fix requires bindings to "openat".
I found another similar issue in Guix lately (not yet disclosed publicly).
While I think the conditions for this other potential security issue
to be exploitable don't ever happen in practice, I would still like
to fix this issue, and to be able to prevent similar issues from appearing
in the future.
Greetings,
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] Bindings to *at functions & allowing more functions to operate on ports
2021-03-27 21:19 ` Maxime Devos
@ 2021-03-28 11:17 ` tomas
2021-05-04 22:58 ` rob piko
0 siblings, 1 reply; 24+ messages in thread
From: tomas @ 2021-03-28 11:17 UTC (permalink / raw)
To: Maxime Devos; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 455 bytes --]
On Sat, Mar 27, 2021 at 10:19:20PM +0100, Maxime Devos wrote:
> Hi,
>
> [CC'ing some Guile and Guix maintainers because this is
> important for the security of Guix System.]
[snipped CC, since my answer is just a thankyou]
> I want to explain why these patches (and the O_FLAGS (*)
> patch) should be included in Guile [...]
*THANK YOU*
This from someone striving to make Guile the "default tool for
around the house".
Cheers
- t
[-- Attachment #2: Digital signature --]
[-- Type: application/pgp-signature, Size: 198 bytes --]
^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] Bindings to *at functions & allowing more functions to operate on ports
2021-03-28 11:17 ` tomas
@ 2021-05-04 22:58 ` rob piko
2021-05-05 10:11 ` Maxime Devos
0 siblings, 1 reply; 24+ messages in thread
From: rob piko @ 2021-05-04 22:58 UTC (permalink / raw)
To: tomas; +Cc: Maxime Devos, guile-devel
[-- Attachment #1: Type: text/plain, Size: 1099 bytes --]
Hello Maxime,
> * Use O_NOFOLLOW to *not* follow the symbolic link.
> Patch for adding O_NOFOLLOW to guile:
According to the man pages for the O_NOFOLLOW:
If the trailing component (i.e., basename) of *pathname* is
> a symbolic link, then the open fails, with the error
> *ELOOP*. Symbolic links in earlier components of the
> pathname will still be followed.
>
>
Sounds like O_NOFOLLOW would not fix the issue if the symlink is found in
other parts of the pathname outside of the basename?
Regards,
Kostyantyn Kovalskyy
On Sun, Mar 28, 2021 at 7:18 AM <tomas@tuxteam.de> wrote:
> On Sat, Mar 27, 2021 at 10:19:20PM +0100, Maxime Devos wrote:
> > Hi,
> >
> > [CC'ing some Guile and Guix maintainers because this is
> > important for the security of Guix System.]
>
> [snipped CC, since my answer is just a thankyou]
>
> > I want to explain why these patches (and the O_FLAGS (*)
> > patch) should be included in Guile [...]
>
> *THANK YOU*
>
> This from someone striving to make Guile the "default tool for
> around the house".
>
> Cheers
> - t
>
[-- Attachment #2: Type: text/html, Size: 1772 bytes --]
^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH] Bindings to *at functions & allowing more functions to operate on ports
2021-05-04 22:58 ` rob piko
@ 2021-05-05 10:11 ` Maxime Devos
0 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-05-05 10:11 UTC (permalink / raw)
To: rob piko, tomas; +Cc: guile-devel
[-- Attachment #1: Type: text/plain, Size: 1197 bytes --]
rob piko schreef op di 04-05-2021 om 18:58 [-0400]:
> Hello Maxime,
>
> > * Use O_NOFOLLOW to *not* follow the symbolic link.
> > Patch for adding O_NOFOLLOW to guile:
>
> According to the man pages for the O_NOFOLLOW:
>
> > If the trailing component (i.e., basename) of pathname is
> > a symbolic link, then the open fails, with the error
> > ELOOP. Symbolic links in earlier components of the
> > pathname will still be followed.
>
> Sounds like O_NOFOLLOW would not fix the issue if the symlink is found in other parts of the pathname outside of the basename?
Indeed! To avoid *all* symlinks, and not only a symlink in the trailing component,
you would need to call 'open' with O_NOFOLLOW in a loop.
Something like:
(let* ((dir (open "/symlinks/acceptable-here" O_RDONLY))
;; Symlinks are not followed here.
(dir* (openat dir "dir" (logior O_RDONLY O_NOFOLLOW)))
(file (openat dir* "file" (logior O_RDONLY O_NOFOLLOW))))
(close dir)
(close dir*)
file)
It has been a while since I wrote the patch though, maybe the argument
order is a little different.
Greetings,
Maxime.
[-- Attachment #2: This is a digitally signed message part --]
[-- Type: application/pgp-signature, Size: 260 bytes --]
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 00/14] Bindings to *at functions
2021-03-12 21:59 [PATCH] Bindings to *at functions & allowing more functions to operate on ports Maxime Devos
2021-03-27 21:19 ` Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported Maxime Devos
` (14 more replies)
1 sibling, 15 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
This is a v2 of
https://lists.gnu.org/archive/html/guile-devel/2021-03/msg0026.html,
with a lot more tests, a few less functions and more consistent documentation.
‘rename-file-at’ has been modified to support #f as one of the two directory
arguments, denoting the current working directory.
Maxime Devos (14):
Allow file ports in ‘chdir’ when supported.
Allow file ports in ‘readlink’.
Allow file ports in ‘utime’.
Define ‘symlinkat’ wrapper when supported.
Define bindings to ‘mkdirat’ when the C function exists.
Correct documentation of ‘mkdir’ w.r.t. the umask.
Define AT_REMOVEDIR and others when available.
Define a Scheme binding to ‘renameat’ when it exists.
Define a Scheme binding to ‘fchmodat’ when it exists.
Define a Scheme binding to ‘unlinkat’ when it exists.
Define a Scheme binding to ‘fchownat’ when it exists.
Define a Scheme binding to ‘fstatat’ when available.
Define Scheme bindings to ‘openat’ when available.
Update NEWS.
NEWS | 12 +
configure.ac | 9 +-
doc/ref/guile.texi | 3 +-
doc/ref/posix.texi | 97 +++++-
libguile/filesys.c | 395 +++++++++++++++++++++++--
libguile/filesys.h | 9 +
libguile/posix.c | 34 ++-
libguile/posix.h | 2 +-
libguile/syscalls.h | 2 +
test-suite/tests/filesys.test | 536 ++++++++++++++++++++++++++++++++++
test-suite/tests/posix.test | 71 ++++-
11 files changed, 1120 insertions(+), 50 deletions(-)
base-commit: 6f1b620b829bc0a1852a43e9cb843fd719954a0f
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 12:18 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 02/14] Allow file ports in ‘readlink’ Maxime Devos
` (13 subsequent siblings)
14 siblings, 1 reply; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Check for ‘fchdir’.
* libguile/filesys.c
(scm_chdir): Support file ports.
(scm_init_filesys): Report support of file ports.
* doc/ref/posix.texi (Processes): Update accordingly.
* doc/ref/guile.texi: Add copyright line for new documentation in this
patch and later patches.
* test-suite/tests/filesys.test ("chdir"): Test it.
---
configure.ac | 3 ++-
doc/ref/guile.texi | 3 ++-
doc/ref/posix.texi | 5 ++++-
libguile/filesys.c | 23 +++++++++++++++++++-
test-suite/tests/filesys.test | 41 +++++++++++++++++++++++++++++++++++
5 files changed, 71 insertions(+), 4 deletions(-)
diff --git a/configure.ac b/configure.ac
index bd49bf162..b7e4663f7 100644
--- a/configure.ac
+++ b/configure.ac
@@ -484,7 +484,8 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# sendfile - non-POSIX, found in glibc
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
- fesetround ftime ftruncate fchown fchmod getcwd geteuid getsid \
+ fesetround ftime ftruncate fchown fchmod fchdir \
+ getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/guile.texi b/doc/ref/guile.texi
index 660b1ae90..48af1f820 100644
--- a/doc/ref/guile.texi
+++ b/doc/ref/guile.texi
@@ -14,7 +14,8 @@
This manual documents Guile version @value{VERSION}.
Copyright (C) 1996-1997, 2000-2005, 2009-2021 Free Software Foundation,
-Inc.
+Inc. \\
+Copyright (C) 2021 Maxime Devos
Permission is granted to copy, distribute and/or modify this document
under the terms of the GNU Free Documentation License, Version 1.3 or
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 7633bd5a3..7555f9319 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -2,6 +2,7 @@
@c This is part of the GNU Guile Reference Manual.
@c Copyright (C) 1996, 1997, 2000, 2001, 2002, 2003, 2004, 2006, 2007,
@c 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2017, 2021 Free Software Foundation, Inc.
+@c Copyright (C) 2021 Maxime Devos <maximedevos@telenet.be>
@c See the file guile.texi for copying conditions.
@node POSIX
@@ -1605,7 +1606,9 @@ The return value is unspecified.
@deffn {Scheme Procedure} chdir str
@deffnx {C Function} scm_chdir (str)
@cindex current directory
-Change the current working directory to @var{str}.
+Change the current working directory to @var{str}. @var{str} can be a
+string containing a file name, or a port if supported by the system.
+@code{(provided? 'chdir-port)} reports whether ports are supported.
The return value is unspecified.
@end deffn
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 6247734e8..2a9c36a12 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1,5 +1,6 @@
/* Copyright 1996-2002,2004,2006,2009-2019,2021
Free Software Foundation, Inc.
+ Copyright 2021 Maxime Devos <maximedevos@telenet.be>
This file is part of Guile.
@@ -621,12 +622,28 @@ SCM_DEFINE (scm_link, "link", 2, 0, 0,
SCM_DEFINE (scm_chdir, "chdir", 1, 0, 0,
(SCM str),
"Change the current working directory to @var{str}.\n"
+ "@var{str} can be a string containing a file name,\n"
+ "or a port if supported by the system.\n"
+ "@code{(provided? 'chdir-port)} reports whether ports "
+ "are supported."
"The return value is unspecified.")
#define FUNC_NAME s_scm_chdir
{
int ans;
- STRING_SYSCALL (str, c_str, ans = chdir (c_str));
+#ifdef HAVE_FCHDIR
+ if (SCM_OPFPORTP (str))
+ {
+ int fdes;
+ fdes = SCM_FPORT_FDES (str);
+ SCM_SYSCALL (ans = fchdir (fdes));
+ scm_remember_upto_here_1 (str);
+ }
+ else
+#endif
+ {
+ STRING_SYSCALL (str, c_str, ans = chdir (c_str));
+ }
if (ans != 0)
SCM_SYSERROR;
return SCM_UNSPECIFIED;
@@ -2066,5 +2083,9 @@ scm_init_filesys ()
scm_dot_string = scm_from_utf8_string (".");
+#ifdef HAVE_FCHDIR
+ scm_add_feature("chdir-port");
+#endif
+
#include "filesys.x"
}
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 6fed981e5..6b09a2ba0 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -1,6 +1,7 @@
;;;; filesys.test --- test file system functions -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2006, 2013, 2019, 2021 Free Software Foundation, Inc.
+;;;; Copyright (C) 2021 Maxime Devos <maximedevos@telenet.be>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -265,3 +266,43 @@
(result (eqv? 'directory (stat:type _stat))))
(false-if-exception (rmdir name))
result)))))
+
+(with-test-prefix "chdir"
+ (pass-if-equal "current directory" (getcwd)
+ (begin (chdir ".") (getcwd)))
+ (define file (search-path %load-path "ice-9/boot-9.scm"))
+
+
+ (pass-if-equal "test directory" (dirname file)
+ (let ((olddir (getcwd))
+ (dir #f))
+ (chdir (dirname file))
+ (set! dir (getcwd))
+ (chdir olddir)
+ dir))
+
+ (pass-if-equal "test directory, via port" (dirname file)
+ (unless (provided? 'chdir-port)
+ (throw 'unresolved))
+ (let ((olddir (getcwd))
+ (port (open (dirname file) O_RDONLY))
+ (dir #f))
+ (chdir port)
+ (set! dir (getcwd))
+ (chdir olddir)
+ dir))
+
+ (pass-if-exception "closed port" exception:wrong-type-arg
+ (unless (provided? 'chdir-port)
+ (throw 'unresolved))
+ (let ((port (open (dirname file) O_RDONLY))
+ (olddir (getcwd)))
+ (close-port port)
+ (chdir port)
+ (chdir olddir))) ; should not be reached
+
+ (pass-if-exception "not a port or file name" exception:wrong-type-arg
+ (chdir '(stuff)))
+
+ (pass-if-exception "non-file port" exception:wrong-type-arg
+ (chdir (open-input-string ""))))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 02/14] Allow file ports in ‘readlink’.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
2021-11-16 11:06 ` [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 03/14] Allow file ports in ‘utime’ Maxime Devos
` (12 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Detect whether ‘readlinkat’ is defined.
* libguile/filesys.c (scm_readlink): Support file ports
when ‘readlinkat’ exists.
(scm_init_filesys): Provide ‘chdir-ports’ when it exists.
* doc/ref/posix.texi (File System): Document it.
* test-suite/tests/filesys.test ("readlink"): Test it.
---
configure.ac | 2 +-
doc/ref/posix.texi | 9 ++++--
libguile/filesys.c | 52 +++++++++++++++++++++++------
test-suite/tests/filesys.test | 61 +++++++++++++++++++++++++++++++++++
4 files changed, 112 insertions(+), 12 deletions(-)
diff --git a/configure.ac b/configure.ac
index b7e4663f7..4888f880d 100644
--- a/configure.ac
+++ b/configure.ac
@@ -484,7 +484,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# sendfile - non-POSIX, found in glibc
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
- fesetround ftime ftruncate fchown fchmod fchdir \
+ fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 7555f9319..cd23240c4 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -757,8 +757,13 @@ file it points to. @var{path} must be a string.
@deffn {Scheme Procedure} readlink path
@deffnx {C Function} scm_readlink (path)
-Return the value of the symbolic link named by @var{path} (a
-string), i.e., the file that the link points to.
+Return the value of the symbolic link named by @var{path} (a string, or
+a port if supported by the system), i.e., the file that the link points
+to.
+
+To read a symbolic link represented by a port, the symbolic link must
+have been opened with the @code{O_NOFOLLOW} and @code{O_PATH} flags.
+@code{(provided? 'readlink-port)} reports whether ports are supported.
@end deffn
@findex fchown
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 2a9c36a12..c5bedec07 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1045,10 +1045,30 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_SYMLINK */
-SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
+/* Static helper function for choosing between readlink
+ and readlinkat. */
+static int
+do_readlink (int fd, const char *c_path, char *buf, size_t size)
+{
+#ifdef HAVE_READLINKAT
+ if (fd != -1)
+ return readlinkat (fd, c_path, buf, size);
+#else
+ (void) fd;
+#endif
+ return readlink (c_path, buf, size);
+}
+
+SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
(SCM path),
- "Return the value of the symbolic link named by @var{path} (a\n"
- "string), i.e., the file that the link points to.")
+ "Return the value of the symbolic link named by @var{path} (a\n"
+ "string, or a port if supported by the system),\n"
+ "i.e., the file that the link points to.\n"
+ "To read a symbolic link represented by a port, the symbolic\n"
+ "link must have been opened with the @code{O_NOFOLLOW} and\n"
+ "@code{O_PATH} flags."
+ "@code{(provided? 'readlink-port)} reports whether ports are\n"
+ "supported.")
#define FUNC_NAME s_scm_readlink
{
int rv;
@@ -1056,20 +1076,31 @@ SCM_DEFINE (scm_readlink, "readlink", 1, 0, 0,
char *buf;
SCM result;
char *c_path;
-
- scm_dynwind_begin (0);
-
- c_path = scm_to_locale_string (path);
- scm_dynwind_free (c_path);
+ int fdes;
+ scm_dynwind_begin (0);
+#ifdef HAVE_READLINKAT
+ if (SCM_OPFPORTP (path))
+ {
+ c_path = "";
+ fdes = SCM_FPORT_FDES (path);
+ }
+ else
+#endif
+ {
+ fdes = -1;
+ c_path = scm_to_locale_string (path);
+ scm_dynwind_free (c_path);
+ }
buf = scm_malloc (size);
- while ((rv = readlink (c_path, buf, size)) == size)
+ while ((rv = do_readlink (fdes, c_path, buf, size)) == size)
{
free (buf);
size *= 2;
buf = scm_malloc (size);
}
+ scm_remember_upto_here_1 (path);
if (rv == -1)
{
int save_errno = errno;
@@ -2086,6 +2117,9 @@ scm_init_filesys ()
#ifdef HAVE_FCHDIR
scm_add_feature("chdir-port");
#endif
+#ifdef HAVE_READLINKAT
+ scm_add_feature("readlink-port");
+#endif
#include "filesys.x"
}
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 6b09a2ba0..7feb3492f 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -306,3 +306,64 @@
(pass-if-exception "non-file port" exception:wrong-type-arg
(chdir (open-input-string ""))))
+
+(with-test-prefix "readlink"
+ (false-if-exception (delete-file (test-symlink)))
+ (false-if-exception (delete-file (test-file)))
+ (call-with-output-file (test-file)
+ (lambda (port)
+ (display "hello" port)))
+ (if (not (false-if-exception
+ (begin (symlink (test-file) (test-symlink)) #t)))
+ (display "cannot create symlink, some readlink tests skipped\n")
+ (let ()
+ (pass-if-equal "file name of symlink" (test-file)
+ (readlink (test-symlink)))
+
+ (pass-if-equal "port representing a symlink" (test-file)
+ (let ()
+ (unless (and (provided? 'readlink-port)
+ (defined? 'O_NOFOLLOW)
+ (defined? 'O_PATH)
+ (not (= 0 O_NOFOLLOW))
+ (not (= 0 O_PATH)))
+ (throw 'unsupported))
+ (define port (open (test-symlink) (logior O_NOFOLLOW O_PATH)))
+ (define points-to (false-if-exception (readlink port)))
+ (close-port port)
+ points-to))
+
+ (pass-if-exception "not a port or file name" exception:wrong-type-arg
+ (readlink '(stuff)))))
+
+ (pass-if-equal "port representing a regular file" EINVAL
+ (call-with-input-file (test-file)
+ (lambda (port)
+ (unless (provided? 'readlink-port)
+ (throw 'unsupported))
+ (catch 'system-error
+ (lambda ()
+ (readlink port)
+ (close-port port) ; should be unreachable
+ #f)
+ (lambda args
+ (close-port port)
+ ;; At least Linux 5.10.46 returns ENOENT instead of EINVAL.
+ ;; Possibly surprising, but it is documented in some man
+ ;; pages and it doesn't appear to be an accident:
+ ;; <https://elixir.bootlin.com/linux/v5.10.46/source/fs/stat.c#L419>.
+ (define error (system-error-errno args))
+ (if (= error ENOENT)
+ EINVAL
+ error))))))
+
+ (pass-if-exception "non-file port" exception:wrong-type-arg
+ (readlink (open-input-string "")))
+
+ (pass-if-exception "closed port" exception:wrong-type-arg
+ (let ((port (open-file (test-file) "r")))
+ (close-port port)
+ (readlink port)))
+
+ (false-if-exception (delete-file (test-symlink)))
+ (false-if-exception (delete-file (test-file))))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 03/14] Allow file ports in ‘utime’.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
2021-11-16 11:06 ` [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported Maxime Devos
2021-11-16 11:06 ` [PATCH v2 02/14] Allow file ports in ‘readlink’ Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 04/14] Define ‘symlinkat’ wrapper when supported Maxime Devos
` (11 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
Ports representing symbolic links are currently unsupported.
* configure.ac: Detect 'futimens'.
* doc/ref/posix.texi (utime): Update documentation.
* libguile/posix.c (scm_utime): Support ports.
* libguile/posix.h (scm_utime): Rename argument.
* test-suite/tests/posix.test ("utime"): Add more tests.
---
configure.ac | 4 +--
doc/ref/posix.texi | 15 +++++---
libguile/posix.c | 28 +++++++++++----
libguile/posix.h | 2 +-
test-suite/tests/posix.test | 71 ++++++++++++++++++++++++++++++++++++-
5 files changed, 106 insertions(+), 14 deletions(-)
diff --git a/configure.ac b/configure.ac
index 4888f880d..ddf330d96 100644
--- a/configure.ac
+++ b/configure.ac
@@ -477,7 +477,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# truncate - not in mingw
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
-# strcoll_l, newlocale, uselocale, utimensat - POSIX.1-2008
+# strcoll_l, newlocale, uselocale, utimensat, futimens - POSIX.1-2008
# strtol_l - non-POSIX, found in glibc
# fork - unavailable on Windows
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
@@ -494,7 +494,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])
+ futimens sched_getaffinity sched_setaffinity sendfile])
# 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 cd23240c4..b6deffd43 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -796,14 +796,16 @@ the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}.
The return value is unspecified.
@end deffn
-@deffn {Scheme Procedure} utime pathname [actime [modtime [actimens [modtimens [flags]]]]]
-@deffnx {C Function} scm_utime (pathname, actime, modtime, actimens, modtimens, flags)
+@deffn {Scheme Procedure} utime object [actime [modtime [actimens [modtimens [flags]]]]]
+@deffnx {C Function} scm_utime (object, actime, modtime, actimens, modtimens, flags)
@code{utime} sets the access and modification times for the
-file named by @var{pathname}. If @var{actime} or @var{modtime} is
+file named by @var{object}. If @var{actime} or @var{modtime} is
not supplied, then the current time is used. @var{actime} and
@var{modtime} must be integer time values as returned by the
@code{current-time} procedure.
+@var{object} must be a file name or a port (if supported by the system).
+
The optional @var{actimens} and @var{modtimens} are nanoseconds
to add @var{actime} and @var{modtime}. Nanosecond precision is
only supported on some combinations of file systems and operating
@@ -817,9 +819,14 @@ modification time to the current time.
@vindex AT_SYMLINK_NOFOLLOW
Last, @var{flags} may be either @code{0} or the
@code{AT_SYMLINK_NOFOLLOW} constant, to set the time of
-@var{pathname} even if it is a symbolic link.
+@var{object} even if it is a symbolic link.
@end deffn
+On GNU/Linux systems, at least when using the Linux kernel 5.10.46,
+if @var{object} is a port, it may not be a symbolic link,
+even if @code{AT_SYMLINK_NOFOLLOW} is set. This is either a bug
+in Linux or Guile's wrappers. The exact cause is unclear.
+
@findex unlink
@deffn {Scheme Procedure} delete-file str
@deffnx {C Function} scm_delete_file (str)
diff --git a/libguile/posix.c b/libguile/posix.c
index 3ab12b99e..bd7f40ca8 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -1,5 +1,6 @@
/* Copyright 1995-2014,2016-2019,2021
Free Software Foundation, Inc.
+ Copyright 2021 Maxime Devos <maximedevos@telenet.be>
This file is part of Guile.
@@ -1648,13 +1649,14 @@ SCM_DEFINE (scm_tmpfile, "tmpfile", 0, 0, 0,
#undef FUNC_NAME
SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
- (SCM pathname, SCM actime, SCM modtime, SCM actimens, SCM modtimens,
+ (SCM object, SCM actime, SCM modtime, SCM actimens, SCM modtimens,
SCM flags),
"@code{utime} sets the access and modification times for the\n"
- "file named by @var{pathname}. If @var{actime} or @var{modtime} is\n"
+ "file named by @var{object}. If @var{actime} or @var{modtime} is\n"
"not supplied, then the current time is used. @var{actime} and\n"
"@var{modtime} must be integer time values as returned by the\n"
"@code{current-time} procedure.\n\n"
+ "@var{object} must be a file name or a port (if supported by the system).\n\n"
"The optional @var{actimens} and @var{modtimens} are nanoseconds\n"
"to add @var{actime} and @var{modtime}. Nanosecond precision is\n"
"only supported on some combinations of file systems and operating\n"
@@ -1666,7 +1668,11 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
"modification time to the current time.\n\n"
"Last, @var{flags} may be either @code{0} or the\n"
"@code{AT_SYMLINK_NOFOLLOW} constant, to set the time of\n"
- "@var{pathname} even if it is a symbolic link.\n")
+ "@var{pathname} even if it is a symbolic link.\n\n"
+ "On GNU/Linux systems, at least when using the Linux kernel\n"
+ "5.10.46, if @var{object} is a port, it may not be a symbolic\n"
+ "link, even if @code{AT_SYMLINK_NOFOLLOW} is set. This is either\n"
+ "a bug in Linux or Guile's wrappers. The exact cause is unclear.")
#define FUNC_NAME s_scm_utime
{
int rv;
@@ -1725,8 +1731,18 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
times[1].tv_sec = mtim_sec;
times[1].tv_nsec = mtim_nsec;
- STRING_SYSCALL (pathname, c_pathname,
- rv = utimensat (AT_FDCWD, c_pathname, times, f));
+ if (SCM_OPFPORTP (object))
+ {
+ int fd;
+ fd = SCM_FPORT_FDES (object);
+ SCM_SYSCALL (rv = futimens (fd, times));
+ scm_remember_upto_here_1 (object);
+ }
+ else
+ {
+ STRING_SYSCALL (object, c_pathname,
+ rv = utimensat (AT_FDCWD, c_pathname, times, f));
+ }
}
#else
{
@@ -1740,7 +1756,7 @@ SCM_DEFINE (scm_utime, "utime", 1, 5, 0,
if (f != 0)
scm_out_of_range(FUNC_NAME, flags);
- STRING_SYSCALL (pathname, c_pathname,
+ STRING_SYSCALL (object, c_pathname,
rv = utime (c_pathname, &utm));
}
#endif
diff --git a/libguile/posix.h b/libguile/posix.h
index ff3bec9ea..dda8013a5 100644
--- a/libguile/posix.h
+++ b/libguile/posix.h
@@ -69,7 +69,7 @@ SCM_API SCM scm_tmpfile (void);
SCM_API SCM scm_open_pipe (SCM pipestr, SCM modes);
SCM_API SCM scm_close_pipe (SCM port);
SCM_API SCM scm_system_star (SCM cmds);
-SCM_API SCM scm_utime (SCM pathname, SCM actime, SCM modtime,
+SCM_API SCM scm_utime (SCM object, SCM actime, SCM modtime,
SCM actimens, SCM modtimens, SCM flags);
SCM_API SCM scm_access (SCM path, SCM how);
SCM_API SCM scm_getpid (void);
diff --git a/test-suite/tests/posix.test b/test-suite/tests/posix.test
index 1e552d16f..8e32251b5 100644
--- a/test-suite/tests/posix.test
+++ b/test-suite/tests/posix.test
@@ -2,6 +2,7 @@
;;;;
;;;; Copyright 2003-2004,2006-2007,2010,2012,2015,2017-2019,2021
;;;; Free Software Foundation, Inc.
+;;;; Copyright 2021 Maxime Devos <maximedevos@telenet.be>
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -201,7 +202,75 @@
(list (stat:atime info) (stat:mtime info))))
(lambda ()
(delete-file file))))
- (throw 'unsupported))))
+ (throw 'unsupported)))
+
+ (define (utime-unless-unsupported oops . arguments)
+ (catch 'system-error
+ (lambda ()
+ (catch 'wrong-type-arg
+ (lambda ()
+ (apply utime arguments))
+ (lambda _
+ ;; 'futimens' is not supported on all platforms.
+ (oops))))
+ (lambda args
+ ;; On some platforms, 'futimens' returns ENOSYS according to Gnulib.
+ (if (= (system-error-errno args) ENOSYS)
+ (oops)
+ (apply throw args)))))
+
+ (pass-if-equal "file port"
+ '(1 1)
+ (let ((file "posix.test-utime"))
+ (false-if-exception (delete-file file))
+ (close-port (open-output-file file))
+ (define (delete)
+ (delete-file file))
+ (define (oops)
+ (delete)
+ (throw 'unsupported))
+ (call-with-input-file file
+ (lambda (port)
+ (utime-unless-unsupported oops port 1 1 0 0)
+ (define info (stat file))
+ (delete)
+ (list (stat:atime info) (stat:mtime info))))))
+
+ ;; This causes an EBADF system error on GNU/Linux with the 5.10.46 kernel.
+ #;
+ (pass-if-equal "file port (port representing symbolic link)"
+ '(1 1)
+ (let ((file "posix.test-utime"))
+ (unless (false-if-exception
+ (begin (symlink "/should-be-irrelevant" file)
+ #t))
+ (display "cannot create symlink, a utime test skipped\n")
+ (throw 'unresolved))
+ (unless (and (defined? 'O_NOFOLLOW)
+ (defined? 'O_PATH)
+ (not (= 0 O_NOFOLLOW))
+ (not (= 0 O_PATH)))
+ (display "cannot open symlinks, a utime test skipped\n")
+ (throw 'unresolved))
+ (define (delete)
+ (when port (close-port port))
+ (false-if-exception (delete-file file)))
+ (define (oops)
+ (delete)
+ (throw 'unsupported))
+ (define port #f)
+ (catch #t
+ (lambda ()
+ (set! port
+ (open file (logior O_NOFOLLOW O_PATH)))
+ (utime-unless-unsupported oops port 1 1 0 0))
+ (lambda args
+ (pk 'deleting file)
+ (delete)
+ (apply throw args)))
+ (define info (lstat file))
+ (delete)
+ (list (stat:mtime info) (stat:atime info)))))
;;
;; affinity
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 04/14] Define ‘symlinkat’ wrapper when supported.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (2 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 03/14] Allow file ports in ‘utime’ Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 05/14] Define bindings to ‘mkdirat’ when the C function exists Maxime Devos
` (10 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Detect whether ‘symlinkat’ exists.
* libguile/filesys.c (scm_symlinkat): Define a Scheme binding
when it exists.
* libguile/filesys.h: Make the binding part of the public C API.
* doc/ref/posix.texi (File System): Document the binding.
* test-suite/tests/filesys.test ("symlinkat"): Test it.
---
configure.ac | 2 +-
doc/ref/posix.texi | 6 ++++++
libguile/filesys.c | 23 +++++++++++++++++++++++
libguile/filesys.h | 1 +
test-suite/tests/filesys.test | 27 +++++++++++++++++++++++++++
5 files changed, 58 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index ddf330d96..b2e9ef3e9 100644
--- a/configure.ac
+++ b/configure.ac
@@ -485,7 +485,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- getcwd geteuid getsid \
+ symlinkat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index b6deffd43..a329eec39 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -891,6 +891,12 @@ Create a symbolic link named @var{newpath} with the value (i.e., pointing to)
@var{oldpath}. The return value is unspecified.
@end deffn
+@deffn {Scheme Procedure} symlinkat dir oldpath newpath
+@deffnx {C Function} scm_symlinkat (dir, oldpath, newpath)
+Like @code{symlink}, but resolve @var{newpath} relative to
+the directory referred to by the file port @var{dir}.
+@end deffn
+
@deffn {Scheme Procedure} mkdir path [mode]
@deffnx {C Function} scm_mkdir (path, mode)
Create a new directory named by @var{path}. If @var{mode} is omitted
diff --git a/libguile/filesys.c b/libguile/filesys.c
index c5bedec07..bfd223434 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1045,6 +1045,29 @@ SCM_DEFINE (scm_symlink, "symlink", 2, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_SYMLINK */
+#ifdef HAVE_SYMLINKAT
+SCM_DEFINE (scm_symlinkat, "symlinkat", 3, 0, 0,
+ (SCM dir, SCM oldpath, SCM newpath),
+ "Like @code{symlink}, but resolve @var{newpath} relative\n"
+ "to the directory referred to by the file port @var{dir}.")
+#define FUNC_NAME s_scm_symlinkat
+{
+ int val;
+ int fdes;
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ fdes = SCM_FPORT_FDES (dir);
+ STRING2_SYSCALL (oldpath, c_oldpath,
+ newpath, c_newpath,
+ val = symlinkat (c_oldpath, fdes, c_newpath));
+ scm_remember_upto_here_1 (dir);
+ if (val != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_SYMLINKAT */
+
/* Static helper function for choosing between readlink
and readlinkat. */
static int
diff --git a/libguile/filesys.h b/libguile/filesys.h
index a3b257c12..d181aca52 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -62,6 +62,7 @@ SCM_API SCM scm_select (SCM reads, SCM writes, SCM excepts, SCM secs, SCM msecs)
SCM_API SCM scm_fcntl (SCM object, SCM cmd, SCM value);
SCM_API SCM scm_fsync (SCM object);
SCM_API SCM scm_symlink (SCM oldpath, SCM newpath);
+SCM_API SCM scm_symlinkat (SCM dir, SCM oldpath, SCM newpath);
SCM_API SCM scm_readlink (SCM path);
SCM_API SCM scm_lstat (SCM str);
SCM_API SCM scm_copy_file (SCM oldfile, SCM newfile);
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 7feb3492f..64bf92333 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -367,3 +367,30 @@
(false-if-exception (delete-file (test-symlink)))
(false-if-exception (delete-file (test-file))))
+
+(with-test-prefix "symlinkat"
+ (pass-if-equal "create" (test-file)
+ (unless (defined? 'symlinkat)
+ (throw 'unsupported))
+ (call-with-port
+ (open "." O_RDONLY)
+ (lambda (port)
+ (symlinkat port (test-file) (test-symlink))
+ (readlink (test-symlink)))))
+ (false-if-exception (delete-file (test-symlink)))
+
+ (pass-if-exception "not a port" exception:wrong-type-arg
+ (unless (defined? 'symlinkat)
+ (throw 'unsupported))
+ (symlinkat "bogus" (test-file) (test-symlink)))
+
+ (pass-if-exception "not a file port" exception:wrong-type-arg
+ (unless (defined? 'symlinkat)
+ (throw 'unsupported))
+ (symlinkat (open-input-string "") (test-file) (test-symlink)))
+
+ (pass-if-exception "closed port" exception:wrong-type-arg
+ (unless (defined? 'symlinkat)
+ (throw 'unsupported))
+ (symlinkat (call-with-port (open "." O_RDONLY) identity)
+ (test-file) (test-symlink))))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 05/14] Define bindings to ‘mkdirat’ when the C function exists.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (3 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 04/14] Define ‘symlinkat’ wrapper when supported Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 06/14] Correct documentation of ‘mkdir’ w.r.t. the umask Maxime Devos
` (9 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Detect if ‘mkdirat’ exists.
* libguile/filesys.c (scm_mkdirat): Define the Scheme binding.
* doc/ref/posix.texi (File System): Document it.
---
configure.ac | 2 +-
doc/ref/posix.texi | 6 ++++++
libguile/filesys.c | 25 +++++++++++++++++++++++
libguile/filesys.h | 1 +
test-suite/tests/filesys.test | 38 +++++++++++++++++++++++++++++++++++
5 files changed, 71 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index b2e9ef3e9..da8dfadd0 100644
--- a/configure.ac
+++ b/configure.ac
@@ -485,7 +485,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat getcwd geteuid getsid \
+ symlinkat mkdirat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index a329eec39..d261ac8da 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -906,6 +906,12 @@ Otherwise they are set to the value specified with @var{mode}.
The return value is unspecified.
@end deffn
+@deffn {Scheme Procedure} mkdirat dir path [mode]
+@deffnx {C Function} scm_mkdirat (dir, path, mode)
+Like @code{mkdir}, but resolve @var{path} relative to the directory
+referred to by the file port @var{dir} instead.
+@end deffn
+
@deffn {Scheme Procedure} rmdir path
@deffnx {C Function} scm_rmdir (path)
Remove the existing directory named by @var{path}. The directory must
diff --git a/libguile/filesys.c b/libguile/filesys.c
index bfd223434..ee01b2e2c 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1364,6 +1364,31 @@ SCM_DEFINE (scm_mkdir, "mkdir", 1, 1, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_MKDIRAT
+SCM_DEFINE (scm_mkdirat, "mkdirat", 2, 1, 0,
+ (SCM dir, SCM path, SCM mode),
+ "Like @code{mkdir}, but resolve @var{path} relative to the directory\n"
+ "referred to by the file port @var{dir} instead.")
+#define FUNC_NAME s_scm_mkdirat
+{
+ int rv;
+ int dir_fdes;
+ mode_t c_mode;
+
+ c_mode = SCM_UNBNDP (mode) ? 0777 : scm_to_uint (mode);
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (path, c_path, rv = mkdirat (dir_fdes, c_path, c_mode));
+ if (rv != 0)
+ SCM_SYSERROR;
+
+ scm_remember_upto_here_1 (dir);
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
SCM_DEFINE (scm_rmdir, "rmdir", 1, 0, 0,
(SCM path),
"Remove the existing directory named by @var{path}. The directory must\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index d181aca52..f0dd35ede 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -50,6 +50,7 @@ SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
SCM_API SCM scm_mkdir (SCM path, SCM mode);
+SCM_API SCM scm_mkdirat (SCM dir, SCM path, SCM mode);
SCM_API SCM scm_rmdir (SCM path);
SCM_API SCM scm_directory_stream_p (SCM obj);
SCM_API SCM scm_opendir (SCM dirname);
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 64bf92333..4ea62d513 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -29,6 +29,8 @@
(data-file-name "filesys-test.tmp"))
(define (test-symlink)
(data-file-name "filesys-test-link.tmp"))
+(define (test-directory)
+ (data-file-name "filesys-test-dir.tmp"))
;;;
@@ -394,3 +396,39 @@
(throw 'unsupported))
(symlinkat (call-with-port (open "." O_RDONLY) identity)
(test-file) (test-symlink))))
+
+(with-test-prefix "mkdirat"
+ (define (skip-if-unsupported)
+ (unless (defined? 'mkdirat)
+ (throw 'unsupported)))
+ (define (maybe-delete-directory)
+ (when (file-exists? (test-directory))
+ (rmdir (test-directory))))
+ (maybe-delete-directory)
+
+ (pass-if-equal "create" 'directory
+ (skip-if-unsupported)
+ (call-with-port
+ (open "." O_RDONLY)
+ (lambda (port)
+ (mkdirat port (test-directory))
+ (stat:type (stat (test-directory))))))
+ (maybe-delete-directory)
+
+ (pass-if-equal "explicit perms" (logand #o111 (lognot (umask)))
+ (skip-if-unsupported)
+ (call-with-port
+ (open "." O_RDONLY)
+ (lambda (port)
+ (mkdirat port (test-directory) #o111)
+ (stat:perms (stat (test-directory))))))
+ (maybe-delete-directory)
+
+ (pass-if-equal "create, implicit perms" (logand #o777 (lognot (umask)))
+ (skip-if-unsupported)
+ (call-with-port
+ (open "." O_RDONLY)
+ (lambda (port)
+ (mkdirat port (test-directory))
+ (stat:perms (stat (test-directory))))))
+ (maybe-delete-directory))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 06/14] Correct documentation of ‘mkdir’ w.r.t. the umask.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (4 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 05/14] Define bindings to ‘mkdirat’ when the C function exists Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 07/14] Define AT_REMOVEDIR and others when available Maxime Devos
` (8 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* doc/ref/posix.texi (mkdir): Note that the umask is applied even if the
mode argument is set.
---
doc/ref/posix.texi | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index d261ac8da..7f136376b 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -902,7 +902,8 @@ the directory referred to by the file port @var{dir}.
Create a new directory named by @var{path}. If @var{mode} is omitted
then the permissions of the directory are set to @code{#o777}
masked with the current umask (@pxref{Processes, @code{umask}}).
-Otherwise they are set to the value specified with @var{mode}.
+Otherwise they are set to the value specified with @var{mode}
+masked with the current umask.
The return value is unspecified.
@end deffn
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 07/14] Define AT_REMOVEDIR and others when available.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (5 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 06/14] Correct documentation of ‘mkdir’ w.r.t. the umask Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 08/14] Define a Scheme binding to ‘renameat’ when it exists Maxime Devos
` (7 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* libguile/posix.c (scm_init_posix): Define (in Scheme)
AT_REMOVEDIR and AT_EACCESS when defined (in C).
---
libguile/posix.c | 6 ++++++
1 file changed, 6 insertions(+)
diff --git a/libguile/posix.c b/libguile/posix.c
index bd7f40ca8..a6f7c9a0d 100644
--- a/libguile/posix.c
+++ b/libguile/posix.c
@@ -2503,6 +2503,12 @@ scm_init_posix ()
#ifdef AT_EMPTY_PATH
scm_c_define ("AT_EMPTY_PATH", scm_from_int (AT_EMPTY_PATH));
#endif
+#ifdef AT_REMOVEDIR
+ scm_c_define ("AT_REMOVEDIR", scm_from_int (AT_REMOVEDIR));
+#endif
+#ifdef AT_EACCESS
+ scm_c_define ("AT_EACCESS", scm_from_int (AT_EACCESS));
+#endif
#include "cpp-SIG.c"
#include "posix.x"
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 08/14] Define a Scheme binding to ‘renameat’ when it exists.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (6 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 07/14] Define AT_REMOVEDIR and others when available Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 09/14] Define a Scheme binding to ‘fchmodat’ " Maxime Devos
` (6 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Detect if ‘renameat’ is defined.
* libguile/filesys.c (scm_renameat): Define a Scheme binding
to the ‘renameat’ system call.
* doc/ref/posix.texi (File System): Document it.
* libguile/filesys.h (scm_renameat): Make it part of the C API.
* test-suite/tests/filesys.test ("rename-file-at"): New tests.
---
configure.ac | 2 +-
doc/ref/posix.texi | 9 +++
libguile/filesys.c | 34 +++++++++++
libguile/filesys.h | 1 +
test-suite/tests/filesys.test | 104 ++++++++++++++++++++++++++++++++++
5 files changed, 149 insertions(+), 1 deletion(-)
diff --git a/configure.ac b/configure.ac
index da8dfadd0..e67892feb 100644
--- a/configure.ac
+++ b/configure.ac
@@ -485,7 +485,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat mkdirat getcwd geteuid getsid \
+ symlinkat mkdirat renameat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index 7f136376b..ebb001581 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -877,6 +877,15 @@ Renames the file specified by @var{oldname} to @var{newname}.
The return value is unspecified.
@end deffn
+@findex renameat
+@deffn {Scheme Procedure} rename-file-at olddir oldname newdir newname
+@deffnx {C Function} scm_renameat (olddir, oldname, newdir, newname)
+Like @code{rename-file}, but when @var{olddir} or @var{newdir} is true,
+resolve @var{oldname} or @var{newname} relative to the directory
+specified by the file port @var{olddir} or @var{newdir} instead of the
+current working directory.
+@end deffn
+
@deffn {Scheme Procedure} link oldpath newpath
@deffnx {C Function} scm_link (oldpath, newpath)
Creates a new name @var{newpath} in the file system for the
diff --git a/libguile/filesys.c b/libguile/filesys.c
index ee01b2e2c..9c63beaa8 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1421,6 +1421,40 @@ SCM_DEFINE (scm_rename, "rename-file", 2, 0, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_RENAMEAT
+SCM_DEFINE (scm_renameat, "rename-file-at", 4, 0, 0,
+ (SCM olddir, SCM oldname, SCM newdir, SCM newname),
+ "Like @code{rename-file}, but when @var{olddir} or @var{newdir}\n"
+ "is true, resolve @var{oldname} or @var{newname} relative to\n"
+ "the directory specified by file port @var{olddir} or\n"
+ "@var{newdir} instead of the current working directory.")
+#define FUNC_NAME s_scm_renameat
+{
+ int rv;
+ int old_fdes, new_fdes;
+
+ old_fdes = AT_FDCWD;
+ new_fdes = AT_FDCWD;
+
+ if (scm_is_true (olddir)) {
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, olddir);
+ old_fdes = SCM_FPORT_FDES (olddir);
+ }
+ if (scm_is_true (newdir)) {
+ SCM_VALIDATE_OPFPORT (SCM_ARG3, newdir);
+ new_fdes = SCM_FPORT_FDES (newdir);
+ }
+
+ STRING2_SYSCALL (oldname, c_oldname,
+ newname, c_newname,
+ rv = renameat (old_fdes, c_oldname, new_fdes, c_newname));
+ scm_remember_upto_here_2 (olddir, newdir);
+ if (rv != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
(SCM str),
diff --git a/libguile/filesys.h b/libguile/filesys.h
index f0dd35ede..7e17cc585 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -48,6 +48,7 @@ SCM_API SCM scm_close_fdes (SCM fd);
SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
+SCM_API SCM scm_renameat (SCM olddir, SCM oldname, SCM newdir, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
SCM_API SCM scm_mkdir (SCM path, SCM mode);
SCM_API SCM scm_mkdirat (SCM dir, SCM path, SCM mode);
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 4ea62d513..bbce2c858 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -31,6 +31,8 @@
(data-file-name "filesys-test-link.tmp"))
(define (test-directory)
(data-file-name "filesys-test-dir.tmp"))
+(define (test-directory2)
+ (data-file-name "filesys-test-dir2.tmp"))
;;;
@@ -432,3 +434,105 @@
(mkdirat port (test-directory))
(stat:perms (stat (test-directory))))))
(maybe-delete-directory))
+
+(with-test-prefix "rename-file-at"
+ (define (skip-if-unsupported)
+ (unless (defined? 'rename-file-at)
+ (throw 'unsupported)))
+ (pass-if-equal "current working directory" '(#f "hello")
+ (skip-if-unsupported)
+ ;; Create a file in the test directory
+ (call-with-output-file "filesys-test-a.tmp"
+ (lambda (port) (display "hello" port)))
+ ;; Try to rename it
+ (rename-file-at #f "filesys-test-a.tmp" #f "filesys-test-b.tmp")
+ ;; Verify it exists under the new name, and not under the old name
+ (list (file-exists? "filesys-test-a.tmp")
+ (call-with-input-file "filesys-test-b.tmp" get-string-all)))
+
+ (false-if-exception (delete-file "filesys-test-a.tmp"))
+ (false-if-exception (delete-file "filesys-test-b.tmp"))
+
+ (pass-if-equal "two ports" '(#f "hello")
+ (skip-if-unsupported)
+ (mkdir (test-directory))
+ (mkdir (test-directory2))
+ ;; Create a file in the first directory
+ (call-with-output-file (in-vicinity (test-directory) "a")
+ (lambda (port) (display "hello" port)))
+ (let ((port1 (open (test-directory) O_RDONLY))
+ (port2 (open (test-directory2) O_RDONLY)))
+ ;; Try to rename it
+ (rename-file-at port1 "a" port2 "b")
+ (close-port port1)
+ (close-port port2)
+ ;; Verify it exists under the new name, and not under the old name
+ (list (file-exists? (in-vicinity (test-directory) "a"))
+ (call-with-input-file (in-vicinity (test-directory2) "b")
+ get-string-all))))
+ (false-if-exception (delete-file (in-vicinity (test-directory) "a")))
+ (false-if-exception (delete-file (in-vicinity (test-directory2) "b")))
+ (false-if-exception (rmdir (test-directory)))
+ (false-if-exception (rmdir (test-directory2)))
+
+ (pass-if-equal "port and current working directory" '(#f "hello")
+ (skip-if-unsupported)
+ (mkdir (test-directory))
+ ;; Create a file in (test-directory)
+ (call-with-output-file (in-vicinity (test-directory) "a")
+ (lambda (port) (display "hello" port)))
+ (let ((port (open (test-directory) O_RDONLY)))
+ ;; Try to rename it
+ (rename-file-at port "a" #f (basename (test-file)))
+ (close-port port)
+ ;; Verify it exists under the new name, and not under the old name.
+ (list (file-exists? (in-vicinity (test-directory) "a"))
+ (call-with-input-file (test-file) get-string-all))))
+ (false-if-exception (delete-file (in-vicinity (test-directory) "a")))
+ (false-if-exception (rmdir (test-directory)))
+ (false-if-exception (delete-file (test-file)))
+
+ (pass-if-equal "current working directory and port" '(#f "hello")
+ (skip-if-unsupported)
+ (mkdir (test-directory))
+ ;; Create a file in the working directory
+ (call-with-output-file (test-file)
+ (lambda (port) (display "hello" port)))
+ (let ((port (open (test-directory) O_RDONLY)))
+ ;; Try to rename it
+ (rename-file-at #f (basename (test-file)) port "b")
+ (close-port port)
+ ;; Verify it exists under the new name, and not under the old name.
+ (list (file-exists? (test-file))
+ (call-with-input-file (in-vicinity (test-directory) "b")
+ get-string-all))))
+
+ (false-if-exception (delete-file (in-vicinity (test-directory) "b")))
+ (false-if-exception (delete-file (test-file)))
+ (false-if-exception (rmdir (test-directory)))
+
+ (pass-if-exception "not a file port (1)" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (rename-file-at (open-input-string "") "some" #f "thing"))
+
+ (pass-if-exception "not a file port (2)" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (rename-file-at #f "some" (open-input-string "") "thing"))
+
+ (pass-if-exception "closed port (1)" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (rename-file-at (call-with-port (open "." O_RDONLY) identity)
+ "some" #f "thing"))
+
+ (pass-if-exception "closed port (2)" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (rename-file-at #f "some" (call-with-port (open "." O_RDONLY) identity)
+ "thing"))
+
+ (pass-if-exception "not a string (1)" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (rename-file-at #f 'what #f "thing"))
+
+ (pass-if-exception "not a string (2)" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (rename-file-at #f "some" #f 'what)))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 09/14] Define a Scheme binding to ‘fchmodat’ when it exists.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (7 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 08/14] Define a Scheme binding to ‘renameat’ when it exists Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 10/14] Define a Scheme binding to ‘unlinkat’ " Maxime Devos
` (5 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Detect existence of fchmodat.
* libguile/filesys.c (scm_chmodat): New procedure.
* libguile/filesys.h (scm_chmodat): Make it part of the API.
* test-suite/tests/filesys.test ("chmodat"): Test it.
---
configure.ac | 4 +--
libguile/filesys.c | 36 ++++++++++++++++++++++++
libguile/filesys.h | 1 +
test-suite/tests/filesys.test | 53 +++++++++++++++++++++++++++++++++++
4 files changed, 92 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index e67892feb..2a5485990 100644
--- a/configure.ac
+++ b/configure.ac
@@ -477,7 +477,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# truncate - not in mingw
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
-# strcoll_l, newlocale, uselocale, utimensat, futimens - POSIX.1-2008
+# strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat - POSIX.1-2008
# strtol_l - non-POSIX, found in glibc
# fork - unavailable on Windows
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
@@ -485,7 +485,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- symlinkat mkdirat renameat getcwd geteuid getsid \
+ fchmodat symlinkat mkdirat renameat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 9c63beaa8..4dd9c7b48 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1561,6 +1561,42 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_FCHMODAT
+SCM_DEFINE (scm_chmodat, "chmodat", 3, 1, 0,
+ (SCM dir, SCM pathname, SCM mode, SCM flags),
+ "Like @var{chmod}, but modify the permissions of the file named\n"
+ "@var{pathname} in the directory referred to by the file port\n"
+ "@var{dir} instead.\n"
+ "The optional @var{flags} argument may be 0 or @code{AT_SYMLINK_NOFOLLOW},\n"
+ "in which case @var{pathname} is not dereferenced if it is a symbolic link,\n"
+ "i.e., the permissions of the symbolic link itself are modified.\n\n"
+ "Note that @code{AT_SYMLINK_NOFOLLOW} is not supported on all systems\n"
+ "and may result in @code{ENOTSUP}.")
+#define FUNC_NAME s_scm_chmodat
+{
+ int rv;
+ int c_flags;
+ int dir_fdes;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (pathname, c_pathname,
+ rv = fchmodat (dir_fdes, c_pathname,
+ scm_to_int (mode), c_flags));
+ scm_remember_upto_here_1 (dir);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
SCM_DEFINE (scm_umask, "umask", 0, 1, 0,
(SCM mode),
"If @var{mode} is omitted, returns a decimal number representing the current\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 7e17cc585..377a3795e 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -40,6 +40,7 @@ SCM_API scm_t_bits scm_tc16_dir;
SCM_API SCM scm_chown (SCM object, SCM owner, SCM group);
SCM_API SCM scm_chmod (SCM object, SCM mode);
+SCM_API SCM scm_chmodat (SCM dir, SCM pathname, SCM mode, SCM flags);
SCM_API SCM scm_umask (SCM mode);
SCM_API SCM scm_open_fdes (SCM path, SCM flags, SCM mode);
SCM_API SCM scm_open (SCM path, SCM flags, SCM mode);
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index bbce2c858..204f3414c 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -271,6 +271,59 @@
(false-if-exception (rmdir name))
result)))))
+;;;
+;;; chmodat
+;;;
+
+(with-test-prefix "chmodat"
+ (call-with-output-file (test-file) (const #f))
+ (chmod (test-file) #o000)
+
+ (pass-if-equal "regular file"
+ #o300
+ (unless (defined? 'chmodat)
+ (throw 'unsupported))
+ (call-with-port
+ (open (dirname (test-file)) O_RDONLY)
+ (lambda (port)
+ (chmodat port (test-file) #o300)))
+ (stat:perms (stat (test-file))))
+
+ (chmod (test-file) #o000)
+
+ (pass-if-equal "regular file, AT_SYMLINK_NOFOLLOW"
+ #o300
+ (unless (and (defined? 'chmodat)
+ (defined? 'AT_SYMLINK_NOFOLLOW))
+ (throw 'unsupported))
+ (call-with-port
+ (open (dirname (test-file)) O_RDONLY)
+ (lambda (port)
+ (catch 'system-error
+ (lambda ()
+ (chmodat port (basename (test-file)) #o300 AT_SYMLINK_NOFOLLOW))
+ (lambda args
+ (close-port port)
+ ;; AT_SYMLINK_NOFOLLOW is not supported on Linux (at least Linux
+ ;; 5.11.2 with the btrfs file system), even for regular files.
+ (if (= ENOTSUP (system-error-errno args))
+ (begin
+ (display "fchmodat doesn't support AT_SYMLINK_NOFOLLOW\n")
+ (throw 'unresolved))
+ (apply throw args))))))
+ (stat:perms (stat (test-file))))
+
+ (pass-if-exception "not a port" exception:wrong-type-arg
+ (chmodat "bogus" (test-file) #o300))
+
+ (pass-if-exception "not a file port" exception:wrong-type-arg
+ (chmodat (open-input-string "") (test-file) #o300))
+
+ (pass-if-exception "closed port" exception:wrong-type-arg
+ (chmodat (call-with-port (open "." O_RDONLY) identity) (test-file) #o300))
+
+ (delete-file (test-file)))
+
(with-test-prefix "chdir"
(pass-if-equal "current directory" (getcwd)
(begin (chdir ".") (getcwd)))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 10/14] Define a Scheme binding to ‘unlinkat’ when it exists.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (8 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 09/14] Define a Scheme binding to ‘fchmodat’ " Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 11/14] Define a Scheme binding to ‘fchownat’ " Maxime Devos
` (4 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
‘unlinkat’ is used for both unlinking regular files
and removing empty directories.
* configure.ac: Detect if ‘unlinkat’ exists.
* doc/ref/posix.texi (File System): Document why there is no
‘rmdirat’ procedure, and document the ‘delete-file-at’ procedure.
* libguile/filesys.c
(scm_rmdir): Adjust the docstring here as well.
(scm_delete_file_at): Define a Scheme binding to ‘unlinkat’.
* libguile/filesys.h (scm_delete_file_at): Make ‘scm_delete_file_at’
part of the C API.
---
configure.ac | 5 +--
doc/ref/posix.texi | 12 +++++++
libguile/filesys.c | 32 +++++++++++++++++++
libguile/filesys.h | 1 +
test-suite/tests/filesys.test | 59 +++++++++++++++++++++++++++++++++++
5 files changed, 107 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index 2a5485990..e1c090321 100644
--- a/configure.ac
+++ b/configure.ac
@@ -477,7 +477,8 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# truncate - not in mingw
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
-# strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat - POSIX.1-2008
+# strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat,
+# unlinkat - POSIX.1-2008
# strtol_l - non-POSIX, found in glibc
# fork - unavailable on Windows
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
@@ -485,7 +486,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
- fchmodat symlinkat mkdirat renameat getcwd geteuid getsid \
+ fchmodat symlinkat mkdirat renameat unlinkat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64 \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index ebb001581..ad10585d9 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -834,6 +834,18 @@ Deletes (or ``unlinks'') the file whose path is specified by
@var{str}.
@end deffn
+@findex unlinkat
+@deffn {Scheme Procedure} delete-file-at dir str [flags]
+@deffnx {C Function} scm_delete_file_at (dir, str, flags)
+Like @code{unlink}, but resolve @var{str} relative to the
+directory referred to by the file port @var{dir} instead.
+
+The optional @var{flags} argument can be @code{AT_REMOVEDIR},
+in which case @code{delete-file-at} will act like @code{rmdir} instead
+of @code{delete-file}. Why doesn't POSIX have a @code{rmdirat} function
+for this instead? No idea!
+@end deffn
+
@deffn {Scheme Procedure} copy-file oldfile newfile
@deffnx {C Function} scm_copy_file (oldfile, newfile)
Copy the file specified by @var{oldfile} to @var{newfile}.
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 4dd9c7b48..7e6d89626 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1469,6 +1469,38 @@ SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_UNLINKAT
+SCM_DEFINE (scm_delete_file_at, "delete-file-at", 2, 1, 0,
+ (SCM dir, SCM str, SCM flags),
+ "Like @code{unlink}, but resolve @var{str} relative to the\n"
+ "directory referred to by the file port @var{dir} instead.\n\n"
+ "The optional @var{flags} argument can be @code{AT_REMOVEDIR},\n"
+ "in which case @code{delete-file-at} will act like @code{rmdir} instead\n"
+ "of @code{delete-file}. Why doesn't POSIX have a @code{rmdirat} function\n"
+ "for this instead? No idea!")
+#define FUNC_NAME s_scm_delete_file_at
+{
+ int ans;
+ int dir_fdes;
+ int c_flags;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (str, c_str, ans = unlinkat (dir_fdes, c_str, c_flags));
+ scm_remember_upto_here_1 (dir);
+ if (ans != 0)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
SCM_DEFINE (scm_access, "access?", 2, 0, 0,
(SCM path, SCM how),
"Test accessibility of a file under the real UID and GID of the\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 377a3795e..37d084cd5 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -51,6 +51,7 @@ SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_renameat (SCM olddir, SCM oldname, SCM newdir, SCM newname);
SCM_API SCM scm_delete_file (SCM str);
+SCM_API SCM scm_delete_file_at (SCM dir, SCM str, SCM flags);
SCM_API SCM scm_mkdir (SCM path, SCM mode);
SCM_API SCM scm_mkdirat (SCM dir, SCM path, SCM mode);
SCM_API SCM scm_rmdir (SCM path);
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 204f3414c..33b68e16d 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -589,3 +589,62 @@
(pass-if-exception "not a string (2)" exception:wrong-type-arg
(skip-if-unsupported)
(rename-file-at #f "some" #f 'what)))
+
+(with-test-prefix "delete-file-at"
+ (define (skip-if-unsupported)
+ (when (not (and (defined? 'delete-file-at)
+ (defined? 'AT_REMOVEDIR)))
+ (throw 'unsupported)))
+ (define (create-test-file)
+ (call-with-output-file (test-file) identity))
+ (define (create-test-directory)
+ (mkdir (test-directory)))
+ (define (delete-test-file)
+ (when (file-exists? (test-file))
+ (delete-file (test-file))))
+ (define (delete-test-directory)
+ (when (file-exists? (test-directory))
+ (rmdir (test-directory))))
+
+ (pass-if-equal "regular file" #f
+ (skip-if-unsupported)
+ (create-test-file)
+ (call-with-port
+ (open (dirname (test-file)) O_RDONLY)
+ (lambda (port)
+ (delete-file-at port (basename (test-file)))))
+ (file-exists? (test-file)))
+ (delete-test-file)
+
+ (pass-if-equal "regular file, explicit flags" #f
+ (skip-if-unsupported)
+ (create-test-file)
+ (call-with-port
+ (open (dirname (test-file)) O_RDONLY)
+ (lambda (port)
+ (delete-file-at port (basename (test-file)) 0)))
+ (file-exists? (test-file)))
+ (delete-test-file)
+
+ (pass-if-equal "directory, explicit flags" #f
+ (skip-if-unsupported)
+ (create-test-directory)
+ (call-with-port
+ (open (dirname (test-directory)) O_RDONLY)
+ (lambda (port)
+ (delete-file-at port (basename (test-directory)) AT_REMOVEDIR)))
+ (file-exists? (test-directory)))
+ (delete-test-directory)
+
+ (pass-if-exception "not a port" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (delete-file-at 'bogus "irrelevant"))
+
+ (pass-if-exception "not a file port" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (delete-file-at (open-input-string "") "irrelevant"))
+
+ (pass-if-exception "closed port" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (delete-file-at (call-with-port (open "." O_RDONLY) identity)
+ "irrelevant")))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 11/14] Define a Scheme binding to ‘fchownat’ when it exists.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (9 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 10/14] Define a Scheme binding to ‘unlinkat’ " Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 12/14] Define a Scheme binding to ‘fstatat’ when available Maxime Devos
` (3 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Detect whether ‘fchownat’ is available.
* libguile/filesys.c (scm_chownat): Define a Scheme binding to
‘fchownat’ when available.
* libguile/filesys.h (scm_chownat): Make it part of the API.
* doc/ref/posix.texi (File System): Document it.
---
configure.ac | 4 ++--
doc/ref/posix.texi | 11 +++++++++++
libguile/filesys.c | 35 +++++++++++++++++++++++++++++++++++
libguile/filesys.h | 1 +
4 files changed, 49 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index e1c090321..dcb6bceb5 100644
--- a/configure.ac
+++ b/configure.ac
@@ -478,14 +478,14 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
# strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat,
-# unlinkat - POSIX.1-2008
+# unlinkat, fchownat - POSIX.1-2008
# strtol_l - non-POSIX, found in glibc
# fork - unavailable on Windows
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
# sendfile - non-POSIX, found in glibc
#
AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \
- fesetround ftime ftruncate fchown fchmod fchdir readlinkat \
+ fesetround ftime ftruncate fchown fchownat fchmod fchdir readlinkat \
fchmodat symlinkat mkdirat renameat unlinkat getcwd geteuid getsid \
gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \
nice readlink rename rmdir setegid seteuid \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index ad10585d9..3d06f1c73 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -784,6 +784,17 @@ unsupported at present). If @var{owner} or @var{group} is specified
as @code{-1}, then that ID is not changed.
@end deffn
+@findex fchownat
+@deffn {Scheme Procedure} chownat dir name owner group [flags]
+@deffnx {C Function} scm_chownat (dir, name, owner, group, flags)
+Like @code{chown}, but modify the owner and/or group of
+the file named @var{name} in the directory referred to
+by the file port @var{dir} instead. The optional argument
+@var{flags} is a bitmask. If @code{AT_SYMLINK_NOFOLLOW} is
+present, then @var{name} will not be dereferenced if it is a
+symbolic link.
+@end deffn
+
@findex fchmod
@deffn {Scheme Procedure} chmod object mode
@deffnx {C Function} scm_chmod (object, mode)
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 7e6d89626..c257bb59c 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -193,6 +193,41 @@ SCM_DEFINE (scm_chown, "chown", 3, 0, 0,
#undef FUNC_NAME
#endif /* HAVE_CHOWN */
+#ifdef HAVE_FCHOWNAT
+SCM_DEFINE (scm_chownat, "chown-at", 4, 1, 0,
+ (SCM dir, SCM name, SCM owner, SCM group, SCM flags),
+ "Like @code{chown}, but modify the owner and/or group of\n"
+ "the file named @var{name} in the directory referred to\n"
+ "by the file port @var{dir} instead. The optional argument\n"
+ "@var{flags} is a bitmask. If @code{AT_SYMLINK_NOFOLLOW} is\n"
+ "present, then @var{name} will not be dereferenced if it is a\n"
+ "symbolic link.")
+#define FUNC_NAME s_scm_chownat
+{
+ int rv;
+ int dir_fdes;
+ int c_flags;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (name, c_name,
+ rv = fchownat (dir_fdes, c_name,
+ scm_to_int (owner), scm_to_int (group),
+ c_flags));
+ scm_remember_upto_here_1 (dir);
+ if (rv == -1)
+ SCM_SYSERROR;
+ return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif /* HAVE_FCHOWNAT */
+
\f
SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 37d084cd5..7673c8051 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -39,6 +39,7 @@ SCM_API scm_t_bits scm_tc16_dir;
\f
SCM_API SCM scm_chown (SCM object, SCM owner, SCM group);
+SCM_API SCM scm_chownat (SCM dir, SCM object, SCM owner, SCM group, SCM flags);
SCM_API SCM scm_chmod (SCM object, SCM mode);
SCM_API SCM scm_chmodat (SCM dir, SCM pathname, SCM mode, SCM flags);
SCM_API SCM scm_umask (SCM mode);
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 12/14] Define a Scheme binding to ‘fstatat’ when available.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (10 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 11/14] Define a Scheme binding to ‘fchownat’ " Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 13/14] Define Scheme bindings to ‘openat’ " Maxime Devos
` (2 subsequent siblings)
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Detect if ‘fstatat’ is defined.
* libguile/filesys.c (scm_statat): Define a Scheme binding to ‘fstatat’.
* libguile/filesys.h (scm_statat): Make it part of the C API.
* doc/ref/posix.texi (File System): Document it.
* libguile/syscalls.h (fstatat_or_fstatat64): Choose between ‘fstatat’
and ‘fstatat64’.
---
configure.ac | 4 +-
doc/ref/posix.texi | 8 ++++
libguile/filesys.c | 39 +++++++++++++++++
libguile/filesys.h | 1 +
libguile/syscalls.h | 1 +
test-suite/tests/filesys.test | 80 +++++++++++++++++++++++++++++++++++
6 files changed, 131 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index dcb6bceb5..e073e04f4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -478,7 +478,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
# strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat,
-# unlinkat, fchownat - POSIX.1-2008
+# unlinkat, fchownat, fstatat - POSIX.1-2008
# strtol_l - non-POSIX, found in glibc
# fork - unavailable on Windows
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
@@ -495,7 +495,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 \
- futimens sched_getaffinity sched_setaffinity sendfile])
+ fstatat futimens sched_getaffinity sched_setaffinity sendfile])
# 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 3d06f1c73..cdd03f141 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -755,6 +755,14 @@ it will return information about a symbolic link itself, not the
file it points to. @var{path} must be a string.
@end deffn
+@deffn {Scheme Procedure} statat dir filename [flags]
+@deffnx {C Function} scm_statat dir filename flags
+Like @code{stat}, but resolve @var{filename} relative to the directory
+referred to by the file port @var{dir} instead. The optional argument
+@var{flags} argument can be @code{AT_SYMLINK_NOFOLLOW}, in which case
+@var{filename} will not be dereferenced even if it is a symbolic link.
+@end deffn
+
@deffn {Scheme Procedure} readlink path
@deffnx {C Function} scm_readlink (path)
Return the value of the symbolic link named by @var{path} (a string, or
diff --git a/libguile/filesys.c b/libguile/filesys.c
index c257bb59c..d045a672f 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -601,6 +601,45 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_FSTATAT
+SCM_DEFINE (scm_statat, "statat", 2, 1, 0,
+ (SCM dir, SCM filename, SCM flags),
+ "Like @code{stat}, but resolve @var{filename} relative to the\n"
+ "directory referred to by the file port @var{dir} instead.\n\n"
+ "The optional argument @var{flags} argument can be\n"
+ "@code{AT_SYMLINK_NOFOLLOW}, in which case @var{filename} will\n"
+ "not be dereferenced even if it is a symbolic link.")
+#define FUNC_NAME s_scm_statat
+{
+ int rv;
+ int dir_fdes;
+ int c_flags;
+ struct stat_or_stat64 stat_temp;
+
+ if (SCM_UNBNDP (flags))
+ c_flags = 0;
+ else
+ c_flags = scm_to_int (flags);
+
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (filename, c_filename,
+ rv = fstatat_or_fstatat64 (dir_fdes, c_filename,
+ &stat_temp, c_flags));
+ scm_remember_upto_here_1 (dir);
+ if (rv != 0)
+ {
+ int en = errno;
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_list_2 (scm_strerror (scm_from_int (en)), filename),
+ en);
+ }
+ return scm_stat2scm (&stat_temp);
+}
+#undef FUNC_NAME
+#endif /* HAVE_FSTATAT */
+
SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
(SCM str),
"Similar to @code{stat}, but does not follow symbolic links, i.e.,\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 7673c8051..8af0f989a 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -48,6 +48,7 @@ SCM_API SCM scm_open (SCM path, SCM flags, SCM mode);
SCM_API SCM scm_close (SCM fd_or_port);
SCM_API SCM scm_close_fdes (SCM fd);
SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
+SCM_API SCM scm_statat (SCM dir, SCM filename, SCM flags);
SCM_API SCM scm_link (SCM oldpath, SCM newpath);
SCM_API SCM scm_rename (SCM oldname, SCM newname);
SCM_API SCM scm_renameat (SCM olddir, SCM oldname, SCM newdir, SCM newname);
diff --git a/libguile/syscalls.h b/libguile/syscalls.h
index 30b99c193..37d532e60 100644
--- a/libguile/syscalls.h
+++ b/libguile/syscalls.h
@@ -65,6 +65,7 @@
# define readdir_r_or_readdir64_r readdir_r
#endif
#define stat_or_stat64 CHOOSE_LARGEFILE(stat,stat64)
+#define fstatat_or_fstatat64 CHOOSE_LARGEFILE(fstatat,fstatat64)
#define truncate_or_truncate64 CHOOSE_LARGEFILE(truncate,truncate64)
#define scm_from_off_t_or_off64_t CHOOSE_LARGEFILE(scm_from_off_t,scm_from_int64)
#define scm_from_ino_t_or_ino64_t CHOOSE_LARGEFILE(scm_from_ulong,scm_from_uint64)
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 33b68e16d..b794b07b3 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -134,6 +134,86 @@
(close-port port)
(eqv? 5 (stat:size st))))))
+(with-test-prefix "statat"
+ ;; file-exists? from (ice-9 boot) dereferences symbolic links
+ ;; (a bug?).
+ (define (file-exists? filename)
+ (catch 'system-error
+ (lambda () (lstat filename) #t)
+ (lambda args
+ (if (= (system-error-errno args) ENOENT)
+ ;; For the purposes of the following tests,
+ ;; it is safe to ignore errors like EPERM, but a correct
+ ;; implementation would return #t for that error.
+ #f
+ (apply throw args)))))
+ (define (maybe-delete-directory)
+ (when (file-exists? (test-directory))
+ (for-each
+ (lambda (filename)
+ (define full-name (in-vicinity (test-directory) filename))
+ (when (file-exists? full-name)
+ (delete-file full-name)))
+ '("test-file" "test-symlink"))
+ (rmdir (test-directory))))
+ (define (skip-unless-defined . things)
+ (for-each (lambda (thing)
+ (unless (defined? thing)
+ (throw 'unsupported)))
+ things))
+ (maybe-delete-directory)
+ (mkdir (test-directory))
+ (call-with-output-file (in-vicinity (test-directory) "test-file")
+ (lambda (port)
+ (display "hello" port)))
+
+ ;; Return #true if the symlink was created, #false otherwise.
+ (define (maybe-create-symlink)
+ (if (file-exists? (in-vicinity (test-directory) "test-symlink"))
+ #t
+ (false-if-exception
+ (symlink "test-file"
+ (in-vicinity (test-directory) "test-symlink")))))
+
+ (pass-if-equal "regular file" 5
+ (skip-unless-defined 'statat)
+ (call-with-port
+ (open (test-directory) O_RDONLY)
+ (lambda (port)
+ (stat:size (statat port "test-file")))))
+
+ (pass-if-equal "regular file, AT_SYMLINK_NOFOLLOW" 5
+ (skip-unless-defined 'statat 'AT_SYMLINK_NOFOLLOW)
+ (call-with-port
+ (open (test-directory) O_RDONLY)
+ (lambda (port)
+ (stat:size (statat port "test-file" AT_SYMLINK_NOFOLLOW)))))
+
+ (pass-if-equal "symbolic links are dereferenced" '(regular 5)
+ ;; Not all systems support symlinks.
+ (skip-unless-defined 'statat 'symlink)
+ (unless (maybe-create-symlink)
+ (throw 'unresolved))
+ (call-with-port
+ (open (test-directory) O_RDONLY)
+ (lambda (port)
+ (define result (statat port "test-symlink"))
+ (list (stat:type result) (stat:size result)))))
+
+ (pass-if-equal "symbolic links are not dereferenced"
+ `(symlink ,(string-length "test-file"))
+ ;; Not all systems support symlinks.
+ (skip-unless-defined 'statat 'symlink)
+ (unless (maybe-create-symlink)
+ (throw 'unresolved))
+ (call-with-port
+ (open (test-directory) O_RDONLY)
+ (lambda (port)
+ (define result (statat port "test-symlink" AT_SYMLINK_NOFOLLOW))
+ (list (stat:type result) (stat:size result)))))
+
+ (maybe-delete-directory))
+
(with-test-prefix "sendfile"
(let* ((file (search-path %load-path "ice-9/boot-9.scm"))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 13/14] Define Scheme bindings to ‘openat’ when available.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (11 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 12/14] Define a Scheme binding to ‘fstatat’ when available Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 14/14] Update NEWS Maxime Devos
2022-06-16 8:42 ` [PATCH v2 00/14] Bindings to *at functions Ludovic Courtès
14 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
* configure.ac: Detect if ‘openat’ is defined.
* libguile/filesys.c
(flags_to_mode): Extract from ...
(scm_mode): ... here.
(scm_open_fdes_at, scm_openat): Define the Scheme bindings.
* libguile/filesys.h (scm_open_fdes_at, scm_openat): Make them part
of the API.
* doc/ref/posix.texi (File System): Document them.
* test-suite/tests/filesys.test ("openat"): Test ‘openat’.
* libguile/syscalls.h (openat_or_openat64): Decide between ‘openat’
and ‘openat64’.
---
configure.ac | 3 +-
doc/ref/posix.texi | 13 +++++
libguile/filesys.c | 96 +++++++++++++++++++++++++++--------
libguile/filesys.h | 2 +
libguile/syscalls.h | 1 +
test-suite/tests/filesys.test | 73 ++++++++++++++++++++++++++
6 files changed, 167 insertions(+), 21 deletions(-)
diff --git a/configure.ac b/configure.ac
index e073e04f4..905e4d465 100644
--- a/configure.ac
+++ b/configure.ac
@@ -478,7 +478,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
# strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat,
-# unlinkat, fchownat, fstatat - POSIX.1-2008
+# unlinkat, fchownat, fstatat, openat - POSIX.1-2008
# strtol_l - non-POSIX, found in glibc
# fork - unavailable on Windows
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
@@ -495,6 +495,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 \
+ openat \
fstatat futimens sched_getaffinity sched_setaffinity sendfile])
# The newlib C library uses _NL_ prefixed locale langinfo constants.
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index cdd03f141..3619ee2c3 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -296,12 +296,25 @@ Create the file if it does not already exist.
for additional flags.
@end deffn
+@deffn {Scheme Procedure} openat dir path flags [mode]
+@deffnx {C Function} scm_openat (dir, path, flags, mode)
+Similar to @code{open}, but resolve the file name @var{path}
+relative to the directory referred to by the file port @var{dir}
+instead.
+@end deffn
+
@deffn {Scheme Procedure} open-fdes path flags [mode]
@deffnx {C Function} scm_open_fdes (path, flags, mode)
Similar to @code{open} but return a file descriptor instead of
a port.
@end deffn
+@deffn {Scheme Procedure} open-fdes-at dir path flags [mode]
+@deffnx {C Function} scm_open_fdes_at (dir, path, flags, mode)
+Similar to @code{openat}, but return a file descriptor instead
+of a port.
+@end deffn
+
@deffn {Scheme Procedure} close fd_or_port
@deffnx {C Function} scm_close (fd_or_port)
Similar to @code{close-port} (@pxref{Ports, close-port}),
diff --git a/libguile/filesys.c b/libguile/filesys.c
index d045a672f..dadbe3393 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -249,6 +249,60 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_OPENAT
+SCM_DEFINE (scm_open_fdes_at, "open-fdes-at", 3, 1, 0,
+ (SCM dir, SCM path, SCM flags, SCM mode),
+ "Similar to @code{openat}, but return a file descriptor instead\n"
+ "of a port.")
+#define FUNC_NAME s_scm_open_fdes_at
+{
+ int dir_fdes;
+ int fd;
+ int iflags;
+ int imode;
+
+ iflags = SCM_NUM2INT (SCM_ARG2, flags);
+ imode = SCM_NUM2INT_DEF (3, mode, 0666);
+ SCM_VALIDATE_OPFPORT (SCM_ARG1, dir);
+ dir_fdes = SCM_FPORT_FDES (dir);
+
+ STRING_SYSCALL (path, c_path,
+ fd = openat_or_openat64 (dir_fdes, c_path, iflags, imode));
+ scm_remember_upto_here_1 (dir);
+ if (fd == -1)
+ SCM_SYSERROR;
+ return scm_from_int (fd);
+}
+#undef FUNC_NAME
+#endif /* HAVE_OPENAT */
+
+/* A helper function for converting some open flags to
+ what scm_fdes_to_port expects. */
+static char *
+flags_to_mode (int iflags)
+{
+ if ((iflags & O_RDWR) == O_RDWR)
+ {
+ /* Opened read-write. */
+ if (iflags & O_APPEND)
+ return "a+";
+ else if (iflags & O_CREAT)
+ return "w+";
+ else
+ return "r+";
+ }
+ else
+ {
+ /* Opened read-only or write-only. */
+ if (iflags & O_APPEND)
+ return "a";
+ else if (iflags & O_WRONLY)
+ return "w";
+ else
+ return "r";
+ }
+}
+
SCM_DEFINE (scm_open, "open", 2, 1, 0,
(SCM path, SCM flags, SCM mode),
"Open the file named by @var{path} for reading and/or writing.\n"
@@ -285,31 +339,33 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0,
fd = scm_to_int (scm_open_fdes (path, flags, mode));
iflags = SCM_NUM2INT (2, flags);
- if ((iflags & O_RDWR) == O_RDWR)
- {
- /* Opened read-write. */
- if (iflags & O_APPEND)
- port_mode = "a+";
- else if (iflags & O_CREAT)
- port_mode = "w+";
- else
- port_mode = "r+";
- }
- else
- {
- /* Opened read-only or write-only. */
- if (iflags & O_APPEND)
- port_mode = "a";
- else if (iflags & O_WRONLY)
- port_mode = "w";
- else
- port_mode = "r";
- }
+ port_mode = (char *) flags_to_mode (iflags);
+ newpt = scm_fdes_to_port (fd, port_mode, path);
+ return newpt;
+}
+#undef FUNC_NAME
+#ifdef HAVE_OPENAT
+SCM_DEFINE (scm_openat, "openat", 3, 1, 0,
+ (SCM dir, SCM path, SCM flags, SCM mode),
+ "Similar to @code{open}, but resolve the file name @var{path}\n"
+ "relative to the directory referred to by the file port @var{dir}\n"
+ "instead.")
+#define FUNC_NAME s_scm_openat
+{
+ SCM newpt;
+ char *port_mode;
+ int fd;
+ int iflags;
+
+ iflags = SCM_NUM2INT (2, flags);
+ port_mode = (char *) flags_to_mode (iflags);
+ fd = scm_to_int (scm_open_fdes_at (dir, path, flags, mode));
newpt = scm_fdes_to_port (fd, port_mode, path);
return newpt;
}
#undef FUNC_NAME
+#endif /* HAVE_OPENAT */
SCM_DEFINE (scm_close, "close", 1, 0, 0,
(SCM fd_or_port),
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 8af0f989a..1ce50d30e 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -44,7 +44,9 @@ SCM_API SCM scm_chmod (SCM object, SCM mode);
SCM_API SCM scm_chmodat (SCM dir, SCM pathname, SCM mode, SCM flags);
SCM_API SCM scm_umask (SCM mode);
SCM_API SCM scm_open_fdes (SCM path, SCM flags, SCM mode);
+SCM_API SCM scm_open_fdes_at (SCM dir, SCM path, SCM flags, SCM mode);
SCM_API SCM scm_open (SCM path, SCM flags, SCM mode);
+SCM_API SCM scm_openat (SCM dir, SCM path, SCM flags, SCM mode);
SCM_API SCM scm_close (SCM fd_or_port);
SCM_API SCM scm_close_fdes (SCM fd);
SCM_API SCM scm_stat (SCM object, SCM exception_on_error);
diff --git a/libguile/syscalls.h b/libguile/syscalls.h
index 37d532e60..6f4061138 100644
--- a/libguile/syscalls.h
+++ b/libguile/syscalls.h
@@ -58,6 +58,7 @@
#define lstat_or_lstat64 CHOOSE_LARGEFILE(lstat,lstat64)
#define off_t_or_off64_t CHOOSE_LARGEFILE(off_t,off64_t)
#define open_or_open64 CHOOSE_LARGEFILE(open,open64)
+#define openat_or_openat64 CHOOSE_LARGEFILE(openat,openat64)
#define readdir_or_readdir64 CHOOSE_LARGEFILE(readdir,readdir64)
#if SCM_HAVE_READDIR64_R == 1
# define readdir_r_or_readdir64_r CHOOSE_LARGEFILE(readdir_r,readdir64_r)
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index b794b07b3..45e77c823 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -728,3 +728,76 @@
(skip-if-unsupported)
(delete-file-at (call-with-port (open "." O_RDONLY) identity)
"irrelevant")))
+
+(with-test-prefix "openat"
+ (define (skip-if-unsupported)
+ (unless (defined? 'openat)
+ (throw 'unsupported)))
+
+ (define file (search-path %load-path "ice-9/boot-9.scm"))
+
+ (define (call-with-relatively-opened-file directory-arguments file-arguments
+ proc)
+ (call-with-port
+ (apply open directory-arguments)
+ (lambda (directory)
+ (call-with-port
+ (apply openat directory file-arguments)
+ (lambda (port)
+ (proc port))))))
+
+ (pass-if-equal "mode read-only" "r"
+ (skip-if-unsupported)
+ (call-with-relatively-opened-file
+ (list (dirname file) O_RDONLY)
+ (list (basename file) O_RDONLY)
+ (lambda (port) (port-mode port))))
+
+ (pass-if-equal "port-revealed count" 0
+ (skip-if-unsupported)
+ (call-with-relatively-opened-file
+ (list (dirname file) O_RDONLY)
+ (list (basename file) O_RDONLY)
+ (lambda (port) (port-revealed port))))
+
+ (when (file-exists? (test-file))
+ (delete-file (test-file)))
+
+ (pass-if-equal "O_CREAT/O_WRONLY" (list #t (logand (lognot (umask)) #o666) "w")
+ (skip-if-unsupported)
+ (call-with-relatively-opened-file
+ (list (dirname (test-file)) O_RDONLY)
+ (list (basename (test-file)) (logior O_WRONLY O_CREAT))
+ (lambda (port)
+ (list (file-exists? (test-file))
+ (stat:perms (stat (test-file)))
+ (port-mode port)))))
+
+ (when (file-exists? (test-file))
+ (delete-file (test-file)))
+
+ (pass-if-equal "O_CREAT/O_WRONLY, non-default mode"
+ (list #t (logand (lognot (umask)) #o700) "w")
+ (skip-if-unsupported)
+ (call-with-relatively-opened-file
+ (list (dirname (test-file)) O_RDONLY)
+ (list (basename (test-file)) (logior O_WRONLY O_CREAT) #o700)
+ (lambda (port)
+ (list (file-exists? (test-file))
+ (stat:perms (stat (test-file)))
+ (port-mode port)))))
+
+ (pass-if-exception "closed port" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (openat (call-with-port (open "." O_RDONLY) identity) "." O_RDONLY))
+
+ (pass-if-exception "non-file port" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (openat (open-input-string "") "." O_RDONLY))
+
+ (pass-if-exception "not a port" exception:wrong-type-arg
+ (skip-if-unsupported)
+ (openat "not a port" "." O_RDONLY))
+
+ (when (file-exists? (test-file))
+ (delete-file (test-file))))
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* [PATCH v2 14/14] Update NEWS.
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (12 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 13/14] Define Scheme bindings to ‘openat’ " Maxime Devos
@ 2021-11-16 11:06 ` Maxime Devos
2021-11-16 12:16 ` Maxime Devos
2022-06-16 8:42 ` [PATCH v2 00/14] Bindings to *at functions Ludovic Courtès
14 siblings, 1 reply; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 11:06 UTC (permalink / raw)
To: guile-devel; +Cc: Maxime Devos
---
NEWS | 12 ++++++++++++
1 file changed, 12 insertions(+)
diff --git a/NEWS b/NEWS
index 710b8ddda..922543a31 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,9 @@ Changes in 3.0.8 (since 3.0.7)
** Fix compilation of (ash x N), where N is a literal, at -O1 and below
** Texinfo and XML parsers are now thread-safe
(<https://bugs.gnu.org/51264>)
+** Fix documentation of ‘mkdir’
+ Previously, the documentation implied the umask was ignored if the
+ mode was set explicitely. However, this is not the case.
* New deprecations
@@ -28,6 +31,15 @@ This function was undocumented.
* New interfaces and functionality
+** Bindings to openat and friends
+
+The procedures `openat', `open-fdes-at', `statat', `chownat',
+`unlinkat', `chmodat', `renameat', `mkdirat' and `symlinkat' have been
+added. They resolve file names relative to a directory passed as a file
+port. The procedures `chdir' `readlink' and `utime' have been extended
+to support file ports. The related flags `AT_REMOVEDIR' and
+`AT_EACCESS' have been added. See `File System' in the manual
+
** Typed vector copy functions
The functions `u8vector-copy' `s8vector-copy' `u16vector-copy'
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH v2 14/14] Update NEWS.
2021-11-16 11:06 ` [PATCH v2 14/14] Update NEWS Maxime Devos
@ 2021-11-16 12:16 ` Maxime Devos
0 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 12:16 UTC (permalink / raw)
To: guile-devel
[-- Attachment #1: Type: text/plain, Size: 362 bytes --]
Maxime Devos schreef op di 16-11-2021 om 11:06 [+0000]:
> [...]
> +** Fix documentation of ‘mkdir’
> + Previously, the documentation implied the umask was ignored if
> the
> + mode was set explicitely. However, this is not the case.
As noted by Thien-Thi Nguyen, the spelling is ‘explicitly’, not
‘explicitely’. Revised patch is attached.
[-- Attachment #2: 0001-Update-NEWS.patch --]
[-- Type: text/x-patch, Size: 1373 bytes --]
From 6aa21f7287f98c9a79fa7014688f3cfdf1803422 Mon Sep 17 00:00:00 2001
From: Maxime Devos <maximedevos@telenet.be>
Date: Mon, 15 Nov 2021 21:17:10 +0000
Subject: [PATCH] Update NEWS.
---
NEWS | 12 ++++++++++++
1 file changed, 12 insertions(+)
diff --git a/NEWS b/NEWS
index 710b8ddda..298dbaabb 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,9 @@ Changes in 3.0.8 (since 3.0.7)
** Fix compilation of (ash x N), where N is a literal, at -O1 and below
** Texinfo and XML parsers are now thread-safe
(<https://bugs.gnu.org/51264>)
+** Fix documentation of ‘mkdir’
+ Previously, the documentation implied the umask was ignored if the
+ mode was set explicitly. However, this is not the case.
* New deprecations
@@ -28,6 +31,15 @@ This function was undocumented.
* New interfaces and functionality
+** Bindings to openat and friends
+
+The procedures `openat', `open-fdes-at', `statat', `chownat',
+`unlinkat', `chmodat', `renameat', `mkdirat' and `symlinkat' have been
+added. They resolve file names relative to a directory passed as a file
+port. The procedures `chdir' `readlink' and `utime' have been extended
+to support file ports. The related flags `AT_REMOVEDIR' and
+`AT_EACCESS' have been added. See `File System' in the manual
+
** Typed vector copy functions
The functions `u8vector-copy' `s8vector-copy' `u16vector-copy'
--
2.30.2
^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported.
2021-11-16 11:06 ` [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported Maxime Devos
@ 2021-11-16 12:18 ` Maxime Devos
2021-11-16 17:10 ` Maxime Devos
0 siblings, 1 reply; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 12:18 UTC (permalink / raw)
To: guile-devel
Maxime Devos schreef op di 16-11-2021 om 11:06 [+0000]:
> Copyright (C) 1996-1997, 2000-2005, 2009-2021 Free Software
> Foundation,
> -Inc.
> +Inc. \\
> +Copyright (C) 2021 Maxime Devos
\\ doesn't work. I'll try something else
^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported.
2021-11-16 12:18 ` Maxime Devos
@ 2021-11-16 17:10 ` Maxime Devos
0 siblings, 0 replies; 24+ messages in thread
From: Maxime Devos @ 2021-11-16 17:10 UTC (permalink / raw)
To: guile-devel
Maxime Devos schreef op di 16-11-2021 om 12:18 [+0000]:
> Maxime Devos schreef op di 16-11-2021 om 11:06 [+0000]:
> > Copyright (C) 1996-1997, 2000-2005, 2009-2021 Free Software
> > Foundation,
> > -Inc.
> > +Inc. \\
> > +Copyright (C) 2021 Maxime Devos
>
>
> \\ doesn't work. I'll try something else
@* instead of \\ appears to work. (to put it in a separate line, but
not a separate paragraph).
^ permalink raw reply [flat|nested] 24+ messages in thread
* Re: [PATCH v2 00/14] Bindings to *at functions
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
` (13 preceding siblings ...)
2021-11-16 11:06 ` [PATCH v2 14/14] Update NEWS Maxime Devos
@ 2022-06-16 8:42 ` Ludovic Courtès
14 siblings, 0 replies; 24+ messages in thread
From: Ludovic Courtès @ 2022-06-16 8:42 UTC (permalink / raw)
To: Maxime Devos; +Cc: guile-devel
Hi Maxime,
First, apologies for the embarrassingly-long silence…
Maxime Devos <maximedevos@telenet.be> skribis:
> This is a v2 of
> https://lists.gnu.org/archive/html/guile-devel/2021-03/msg0026.html,
> with a lot more tests, a few less functions and more consistent documentation.
> ‘rename-file-at’ has been modified to support #f as one of the two directory
> arguments, denoting the current working directory.
>
> Maxime Devos (14):
> Allow file ports in ‘chdir’ when supported.
> Allow file ports in ‘readlink’.
> Allow file ports in ‘utime’.
> Define ‘symlinkat’ wrapper when supported.
> Define bindings to ‘mkdirat’ when the C function exists.
> Correct documentation of ‘mkdir’ w.r.t. the umask.
> Define AT_REMOVEDIR and others when available.
> Define a Scheme binding to ‘renameat’ when it exists.
> Define a Scheme binding to ‘fchmodat’ when it exists.
> Define a Scheme binding to ‘unlinkat’ when it exists.
> Define a Scheme binding to ‘fchownat’ when it exists.
> Define a Scheme binding to ‘fstatat’ when available.
> Define Scheme bindings to ‘openat’ when available.
> Update NEWS.
I applied the whole series locally, skimmed over the patches, ran the
tests, and it all LGTM.
I think the strategy to accept a string or a port where applicable
(utime, readlink) makes sense and is consistent with existing
interfaces; the new *at procedures look fine as well (there’s a naming
scheme discrepancy with ‘rename-file-at’ and ‘delete-file-at’, but I
think it’s fine: it’s just an evolution of the discrepancy that was
already there with ‘delete-file’ and ‘rename-file’.)
Copyright for Guile code is assigned to the FSF. I’d like to offer you
to do the same if that’s an option for you (I’ll send you the details
off-list.) This would add another delay, but hopefully a short one.
Thank you!
Ludo’.
^ permalink raw reply [flat|nested] 24+ messages in thread
end of thread, other threads:[~2022-06-16 8:42 UTC | newest]
Thread overview: 24+ messages (download: mbox.gz / follow: Atom feed)
-- links below jump to the message on this page --
2021-03-12 21:59 [PATCH] Bindings to *at functions & allowing more functions to operate on ports Maxime Devos
2021-03-27 21:19 ` Maxime Devos
2021-03-28 11:17 ` tomas
2021-05-04 22:58 ` rob piko
2021-05-05 10:11 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
2021-11-16 11:06 ` [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported Maxime Devos
2021-11-16 12:18 ` Maxime Devos
2021-11-16 17:10 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 02/14] Allow file ports in ‘readlink’ Maxime Devos
2021-11-16 11:06 ` [PATCH v2 03/14] Allow file ports in ‘utime’ Maxime Devos
2021-11-16 11:06 ` [PATCH v2 04/14] Define ‘symlinkat’ wrapper when supported Maxime Devos
2021-11-16 11:06 ` [PATCH v2 05/14] Define bindings to ‘mkdirat’ when the C function exists Maxime Devos
2021-11-16 11:06 ` [PATCH v2 06/14] Correct documentation of ‘mkdir’ w.r.t. the umask Maxime Devos
2021-11-16 11:06 ` [PATCH v2 07/14] Define AT_REMOVEDIR and others when available Maxime Devos
2021-11-16 11:06 ` [PATCH v2 08/14] Define a Scheme binding to ‘renameat’ when it exists Maxime Devos
2021-11-16 11:06 ` [PATCH v2 09/14] Define a Scheme binding to ‘fchmodat’ " Maxime Devos
2021-11-16 11:06 ` [PATCH v2 10/14] Define a Scheme binding to ‘unlinkat’ " Maxime Devos
2021-11-16 11:06 ` [PATCH v2 11/14] Define a Scheme binding to ‘fchownat’ " Maxime Devos
2021-11-16 11:06 ` [PATCH v2 12/14] Define a Scheme binding to ‘fstatat’ when available Maxime Devos
2021-11-16 11:06 ` [PATCH v2 13/14] Define Scheme bindings to ‘openat’ " Maxime Devos
2021-11-16 11:06 ` [PATCH v2 14/14] Update NEWS Maxime Devos
2021-11-16 12:16 ` Maxime Devos
2022-06-16 8:42 ` [PATCH v2 00/14] Bindings to *at functions Ludovic Courtès
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).