From: Maxime Devos <maximedevos@telenet.be>
To: guile-devel@gnu.org
Cc: Maxime Devos <maximedevos@telenet.be>
Subject: [PATCH v2 10/14] Define a Scheme binding to ‘unlinkat’ when it exists.
Date: Tue, 16 Nov 2021 11:06:33 +0000 [thread overview]
Message-ID: <20211116110637.125579-11-maximedevos@telenet.be> (raw)
In-Reply-To: <20211116110637.125579-1-maximedevos@telenet.be>
‘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
next prev parent reply other threads:[~2021-11-16 11:06 UTC|newest]
Thread overview: 26+ messages / expand[flat|nested] mbox.gz Atom feed top
2021-03-12 21:59 [PATCH] Bindings to *at functions & allowing more functions to operate on ports Maxime Devos
2021-03-27 21:19 ` Maxime Devos
2021-03-28 11:17 ` tomas
2021-05-04 22:58 ` rob piko
2021-05-05 10:11 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 00/14] Bindings to *at functions Maxime Devos
2021-11-16 11:06 ` [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported Maxime Devos
2021-11-16 12:18 ` Maxime Devos
2021-11-16 17:10 ` Maxime Devos
2021-11-16 11:06 ` [PATCH v2 02/14] Allow file ports in ‘readlink’ Maxime Devos
2021-11-16 11:06 ` [PATCH v2 03/14] Allow file ports in ‘utime’ Maxime Devos
2021-11-16 11:06 ` [PATCH v2 04/14] Define ‘symlinkat’ wrapper when supported Maxime Devos
2021-11-16 11:06 ` [PATCH v2 05/14] Define bindings to ‘mkdirat’ when the C function exists Maxime Devos
2021-11-16 11:06 ` [PATCH v2 06/14] Correct documentation of ‘mkdir’ w.r.t. the umask Maxime Devos
2021-11-16 11:06 ` [PATCH v2 07/14] Define AT_REMOVEDIR and others when available Maxime Devos
2021-11-16 11:06 ` [PATCH v2 08/14] Define a Scheme binding to ‘renameat’ when it exists Maxime Devos
2021-11-16 11:06 ` [PATCH v2 09/14] Define a Scheme binding to ‘fchmodat’ " Maxime Devos
2021-11-16 11:06 ` Maxime Devos [this message]
2021-11-16 11:06 ` [PATCH v2 11/14] Define a Scheme binding to ‘fchownat’ " Maxime Devos
2021-11-16 11:06 ` [PATCH v2 12/14] Define a Scheme binding to ‘fstatat’ when available Maxime Devos
2021-11-16 11:06 ` [PATCH v2 13/14] Define Scheme bindings to ‘openat’ " Maxime Devos
2021-11-16 11:06 ` [PATCH v2 14/14] Update NEWS Maxime Devos
2021-11-16 12:16 ` Maxime Devos
2022-06-16 8:42 ` [PATCH v2 00/14] Bindings to *at functions Ludovic Courtès
2022-10-21 15:59 ` Ludovic Courtès
2022-10-21 16:03 ` Ludovic Courtès
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/guile/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=20211116110637.125579-11-maximedevos@telenet.be \
--to=maximedevos@telenet.be \
--cc=guile-devel@gnu.org \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).