diff --git a/configure.ac b/configure.ac index 82c0c8bb1..e4e407afa 100644 --- a/configure.ac +++ b/configure.ac @@ -508,7 +508,7 @@ AC_CHECK_HEADERS([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) @@ -526,7 +526,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \ index bcopy rindex truncate isblank _NSGetEnviron \ strcoll_l strtod_l strtol_l newlocale uselocale utimensat \ - sched_getaffinity sched_setaffinity sendfile pipe2]) + futimens sched_getaffinity sched_setaffinity sendfile pipe2]) # The newlib C library uses _NL_ prefixed locale langinfo constants. AC_CHECK_DECLS([_NL_NUMERIC_GROUPING], [], [], [[#include ]]) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index d2344d400..fbb59c720 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -814,14 +814,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 @@ -835,9 +837,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 119c783d6..879aeb7e7 100644 --- a/libguile/posix.c +++ b/libguile/posix.c @@ -1,5 +1,6 @@ /* Copyright 1995-2014, 2016-2019, 2021-2022 Free Software Foundation, Inc. + Copyright 2021 Maxime Devos This file is part of Guile. @@ -1676,13 +1677,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" @@ -1694,7 +1696,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; @@ -1753,8 +1759,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 { @@ -1768,7 +1784,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 e62c84afe..6504eaea8 100644 --- a/libguile/posix.h +++ b/libguile/posix.h @@ -70,7 +70,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 1b1580f5d..bfc6f168e 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-2022 ;;;; Free Software Foundation, Inc. +;;;; Copyright 2021 Maxime Devos ;;;; ;;;; 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