Define Scheme bindings to ‘openat’ when available.

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

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

6 files changed, 168 insertions, 22 deletions

diff --git a/configure.ac b/configure.ac
index 7aa5a46d7..b3879df1f 100644
--- a/configure.ac
+++ b/configure.ac
@@ -509,7 +509,7 @@ AC_CHECK_HEADERS([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)
@@ -527,7 +527,8 @@ 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     \
-  fstatat futimens sched_getaffinity sched_setaffinity sendfile pipe2])
+  fstatat futimens openat						\
+  sched_getaffinity sched_setaffinity sendfile pipe2])
 
 # 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 601c33747..bde0f150c 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 6fa641d16..1f0bba556 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -236,6 +236,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"
@@ -272,31 +326,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))))