Guix-Upstream: https://lists.gnu.org/archive/html/guile-devel/2021-11/msg00005.html
From: Maxime Devos
Subject: [PATCH v2 10/14] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98unlinkat=E2=80=99=20when=20it=20exists.?=
Date: Tue, 16 Nov 2021 11:06:33 +0000
Message-Id: <20211116110637.125579-11-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
‘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.
---
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 2a5485990..e1c090321 100644
--- a/configure.ac
+++ b/configure.ac
@@ -477,7 +477,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)
@@ -485,7 +486,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")))
--
2.30.2