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

‘unlinkat’ is used for both unlinking regular files
and removing empty directories.

* configure.ac: Detect if ‘unlinkat’ exists.
* doc/ref/posix.texi (File System): Document why there is no
  ‘rmdirat’ procedure, and document the ‘delete-file-at’ procedure.
* libguile/filesys.c
  (scm_rmdir): Adjust the docstring here as well.
  (scm_delete_file_at): Define a Scheme binding to ‘unlinkat’.
* libguile/filesys.h (scm_delete_file_at): Make ‘scm_delete_file_at’
  part of the C API.

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

5 files changed, 107 insertions, 2 deletions

diff --git a/configure.ac b/configure.ac
index b3aeb6a3c..16786eab7 100644
--- a/configure.ac
+++ b/configure.ac
@@ -508,7 +508,8 @@ 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, fchmodat - POSIX.1-2008
+#   strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat,
+#   unlinkat - POSIX.1-2008
 #   strtol_l - non-POSIX, found in glibc
 #   fork - unavailable on Windows
 #   sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
@@ -517,7 +518,7 @@ AC_CHECK_HEADERS([crt_externs.h])
 #
 AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid         \
   fesetround ftime ftruncate fchown fchmod fchdir readlinkat		\
-  fchmodat symlinkat mkdirat renameat getcwd geteuid getsid		\
+  fchmodat symlinkat mkdirat renameat unlinkat 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/doc/ref/posix.texi b/doc/ref/posix.texi
index 85da56ca8..7524ba5df 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -852,6 +852,18 @@ Deletes (or ``unlinks'') the file whose path is specified by
 @var{str}.
 @end deffn
 
+@findex unlinkat
+@deffn {Scheme Procedure} delete-file-at dir str [flags]
+@deffnx {C Function} scm_delete_file_at (dir, str, flags)
+Like @code{unlink}, but resolve @var{str} relative to the
+directory referred to by the file port @var{dir} instead.
+
+The optional @var{flags} argument can be @code{AT_REMOVEDIR},
+in which case @code{delete-file-at} will act like @code{rmdir} instead
+of @code{delete-file}.  Why doesn't POSIX have a @code{rmdirat} function
+for this instead?  No idea!
+@end deffn
+
 @deffn {Scheme Procedure} copy-file oldfile newfile
 @deffnx {C Function} scm_copy_file (oldfile, newfile)
 Copy the file specified by @var{oldfile} to @var{newfile}.
diff --git a/libguile/filesys.c b/libguile/filesys.c
index 1ec85d940..ee7fc5bfa 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1456,6 +1456,38 @@ SCM_DEFINE (scm_delete_file, "delete-file", 1, 0, 0,
 }
 #undef FUNC_NAME
 
+#ifdef HAVE_UNLINKAT
+SCM_DEFINE (scm_delete_file_at, "delete-file-at", 2, 1, 0,
+            (SCM dir, SCM str, SCM flags),
+            "Like @code{unlink}, but resolve @var{str} relative to the\n"
+            "directory referred to by the file port @var{dir} instead.\n\n"
+            "The optional @var{flags} argument can be @code{AT_REMOVEDIR},\n"
+            "in which case @code{delete-file-at} will act like @code{rmdir} instead\n"
+            "of @code{delete-file}.  Why doesn't POSIX have a @code{rmdirat} function\n"
+            "for this instead?  No idea!")
+#define FUNC_NAME s_scm_delete_file_at
+{
+  int ans;
+  int dir_fdes;
+  int c_flags;
+
+  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 (str, c_str, ans = unlinkat (dir_fdes, c_str, c_flags));
+  scm_remember_upto_here_1 (dir);
+  if (ans != 0)
+    SCM_SYSERROR;
+  return SCM_UNSPECIFIED;
+}
+#undef FUNC_NAME
+#endif
+
 SCM_DEFINE (scm_access, "access?", 2, 0, 0,
             (SCM path, SCM how),
 	    "Test accessibility of a file under the real UID and GID of the\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 377a3795e..37d084cd5 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -51,6 +51,7 @@ 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);
 SCM_API SCM scm_delete_file (SCM str);
+SCM_API SCM scm_delete_file_at (SCM dir, SCM str, SCM flags);
 SCM_API SCM scm_mkdir (SCM path, SCM mode);
 SCM_API SCM scm_mkdirat (SCM dir, SCM path, SCM mode);
 SCM_API SCM scm_rmdir (SCM path);
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 204f3414c..33b68e16d 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -589,3 +589,62 @@
   (pass-if-exception "not a string (2)" exception:wrong-type-arg
     (skip-if-unsupported)
     (rename-file-at #f "some" #f 'what)))
+
+(with-test-prefix "delete-file-at"
+  (define (skip-if-unsupported)
+    (when (not (and (defined? 'delete-file-at)
+                    (defined? 'AT_REMOVEDIR)))
+      (throw 'unsupported)))
+  (define (create-test-file)
+    (call-with-output-file (test-file) identity))
+  (define (create-test-directory)
+    (mkdir (test-directory)))
+  (define (delete-test-file)
+    (when (file-exists? (test-file))
+      (delete-file (test-file))))
+  (define (delete-test-directory)
+    (when (file-exists? (test-directory))
+      (rmdir (test-directory))))
+
+  (pass-if-equal "regular file" #f
+    (skip-if-unsupported)
+    (create-test-file)
+    (call-with-port
+     (open (dirname (test-file)) O_RDONLY)
+     (lambda (port)
+       (delete-file-at port (basename (test-file)))))
+    (file-exists? (test-file)))
+  (delete-test-file)
+
+  (pass-if-equal "regular file, explicit flags" #f
+    (skip-if-unsupported)
+    (create-test-file)
+    (call-with-port
+     (open (dirname (test-file)) O_RDONLY)
+     (lambda (port)
+       (delete-file-at port (basename (test-file)) 0)))
+    (file-exists? (test-file)))
+  (delete-test-file)
+
+  (pass-if-equal "directory, explicit flags" #f
+    (skip-if-unsupported)
+    (create-test-directory)
+    (call-with-port
+     (open (dirname (test-directory)) O_RDONLY)
+     (lambda (port)
+       (delete-file-at port (basename (test-directory)) AT_REMOVEDIR)))
+    (file-exists? (test-directory)))
+  (delete-test-directory)
+
+  (pass-if-exception "not a port" exception:wrong-type-arg
+    (skip-if-unsupported)
+    (delete-file-at 'bogus "irrelevant"))
+
+  (pass-if-exception "not a file port" exception:wrong-type-arg
+    (skip-if-unsupported)
+    (delete-file-at (open-input-string "") "irrelevant"))
+
+  (pass-if-exception "closed port" exception:wrong-type-arg
+    (skip-if-unsupported)
+    (delete-file-at (call-with-port (open "." O_RDONLY) identity)
+                    "irrelevant")))