Guix-Upstream: https://lists.gnu.org/archive/html/guile-devel/2021-11/msg00005.html
From: Maxime Devos <maximedevos@telenet.be>
Subject: [PATCH v2 03/14]
 =?UTF-8?q?Allow=20file=20ports=20in=20=E2=80=98u?=
 =?UTF-8?q?time=E2=80=99.?=
Date: Tue, 16 Nov 2021 11:06:26 +0000
Message-Id: <20211116110637.125579-4-maximedevos@telenet.be>
In-Reply-To: <20211116110637.125579-1-maximedevos@telenet.be>
References: <175c3a6572e832d84927937b309a3095cadf5702.camel@telenet.be>
 <20211116110637.125579-1-maximedevos@telenet.be>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit

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