Define a Scheme binding to ‘fchmodat’ when it exists.

* 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.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>

4 files changed, 92 insertions, 2 deletions

diff --git a/configure.ac b/configure.ac
index 6a90ef03f..b3aeb6a3c 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, 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)
@@ -517,7 +517,7 @@ AC_CHECK_HEADERS([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 rmdir setegid seteuid                            \
   setuid setgid setpgid setsid sigaction siginterrupt stat64  \
diff --git a/libguile/filesys.c b/libguile/filesys.c
index fc7867fb8..1ec85d940 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1548,6 +1548,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)))