Guix-Upstream: https://lists.gnu.org/archive/html/guile-devel/2021-11/msg00005.html
From: Maxime Devos <maximedevos@telenet.be>
Subject: [PATCH v2 12/14] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
 =?UTF-8?q?=E2=80=98fstatat=E2=80=99=20when=20available.?=
Date: Tue, 16 Nov 2021 11:06:35 +0000
Message-Id: <20211116110637.125579-13-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

* 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