guile-commits
[Top][All Lists]
Advanced

[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

[Guile-commits] 10/14: Define a Scheme binding to ‘unlinkat’ when it exi


From: Ludovic Courtès
Subject: [Guile-commits] 10/14: Define a Scheme binding to ‘unlinkat’ when it exists.
Date: Thu, 16 Jun 2022 04:50:51 -0400 (EDT)

civodul pushed a commit to branch wip-openat
in repository guile.

commit 681d918b810f4fa3c2389d4f7afc5945a5fa371a
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Tue Nov 16 11:06:33 2021 +0000

    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>
---
 configure.ac                  |  5 ++--
 doc/ref/posix.texi            | 12 +++++++++
 libguile/filesys.c            | 32 +++++++++++++++++++++++
 libguile/filesys.h            |  1 +
 test-suite/tests/filesys.test | 59 +++++++++++++++++++++++++++++++++++++++++++
 5 files changed, 107 insertions(+), 2 deletions(-)

diff --git a/configure.ac b/configure.ac
index 34c499945..2233ce937 100644
--- a/configure.ac
+++ b/configure.ac
@@ -521,7 +521,8 @@ 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, 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)
@@ -529,7 +530,7 @@ AC_CHECK_HEADERS([assert.h 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 rename rmdir setegid seteuid                            \
   setlocale setuid setgid setpgid setsid sigaction siginterrupt stat64  \
diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi
index ebb001581..ad10585d9 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -834,6 +834,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 4dd9c7b48..7e6d89626 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1469,6 +1469,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")))



reply via email to

[Prev in Thread] Current Thread [Next in Thread]