[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 12/14: Define a Scheme binding to ‘fstatat’ when availab
From: |
Ludovic Courtès |
Subject: |
[Guile-commits] 12/14: Define a Scheme binding to ‘fstatat’ when available. |
Date: |
Thu, 16 Jun 2022 04:50:52 -0400 (EDT) |
civodul pushed a commit to branch wip-openat
in repository guile.
commit 60940c645415d511236a065f879450fa726e9658
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Tue Nov 16 11:06:35 2021 +0000
Define a Scheme binding to ‘fstatat’ when available.
* configure.ac: Detect if ‘fstatat’ is defined.
* libguile/filesys.c (scm_statat): Define a Scheme binding to ‘fstatat’.
* libguile/filesys.h (scm_statat): Make it part of the C API.
* doc/ref/posix.texi (File System): Document it.
* libguile/syscalls.h (fstatat_or_fstatat64): Choose between ‘fstatat’
and ‘fstatat64’.
Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
configure.ac | 4 +--
doc/ref/posix.texi | 8 +++++
libguile/filesys.c | 39 +++++++++++++++++++++
libguile/filesys.h | 1 +
libguile/syscalls.h | 1 +
test-suite/tests/filesys.test | 80 +++++++++++++++++++++++++++++++++++++++++++
6 files changed, 131 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index 959d2b95f..47442eb53 100644
--- a/configure.ac
+++ b/configure.ac
@@ -522,7 +522,7 @@ AC_CHECK_HEADERS([assert.h crt_externs.h])
# isblank - available as a GNU extension or in C99
# _NSGetEnviron - Darwin specific
# strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat,
-# unlinkat, fchownat - POSIX.1-2008
+# unlinkat, fchownat, fstatat - POSIX.1-2008
# strtol_l - non-POSIX, found in glibc
# fork - unavailable on Windows
# sched_getaffinity, sched_setaffinity - GNU extensions (glibc)
@@ -539,7 +539,7 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10
ctermid \
getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \
index bcopy memcpy rindex truncate isblank _NSGetEnviron \
strcoll strcoll_l strtod_l strtol_l newlocale uselocale utimensat \
- futimens sched_getaffinity sched_setaffinity sendfile])
+ fstatat futimens sched_getaffinity sched_setaffinity sendfile])
# 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 3d06f1c73..cdd03f141 100644
--- a/doc/ref/posix.texi
+++ b/doc/ref/posix.texi
@@ -755,6 +755,14 @@ it will return information about a symbolic link itself,
not the
file it points to. @var{path} must be a string.
@end deffn
+@deffn {Scheme Procedure} statat dir filename [flags]
+@deffnx {C Function} scm_statat dir filename flags
+Like @code{stat}, but resolve @var{filename} relative to the directory
+referred to by the file port @var{dir} instead. The optional argument
+@var{flags} argument can be @code{AT_SYMLINK_NOFOLLOW}, in which case
+@var{filename} will not be dereferenced even if it is a symbolic link.
+@end deffn
+
@deffn {Scheme Procedure} readlink path
@deffnx {C Function} scm_readlink (path)
Return the value of the symbolic link named by @var{path} (a string, or
diff --git a/libguile/filesys.c b/libguile/filesys.c
index c257bb59c..d045a672f 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -601,6 +601,45 @@ SCM_DEFINE (scm_stat, "stat", 1, 1, 0,
}
#undef FUNC_NAME
+#ifdef HAVE_FSTATAT
+SCM_DEFINE (scm_statat, "statat", 2, 1, 0,
+ (SCM dir, SCM filename, SCM flags),
+ "Like @code{stat}, but resolve @var{filename} relative to the\n"
+ "directory referred to by the file port @var{dir} instead.\n\n"
+ "The optional argument @var{flags} argument can be\n"
+ "@code{AT_SYMLINK_NOFOLLOW}, in which case @var{filename} will\n"
+ "not be dereferenced even if it is a symbolic link.")
+#define FUNC_NAME s_scm_statat
+{
+ int rv;
+ int dir_fdes;
+ int c_flags;
+ struct stat_or_stat64 stat_temp;
+
+ 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 (filename, c_filename,
+ rv = fstatat_or_fstatat64 (dir_fdes, c_filename,
+ &stat_temp, c_flags));
+ scm_remember_upto_here_1 (dir);
+ if (rv != 0)
+ {
+ int en = errno;
+ SCM_SYSERROR_MSG ("~A: ~S",
+ scm_list_2 (scm_strerror (scm_from_int (en)),
filename),
+ en);
+ }
+ return scm_stat2scm (&stat_temp);
+}
+#undef FUNC_NAME
+#endif /* HAVE_FSTATAT */
+
SCM_DEFINE (scm_lstat, "lstat", 1, 0, 0,
(SCM str),
"Similar to @code{stat}, but does not follow symbolic links,
i.e.,\n"
diff --git a/libguile/filesys.h b/libguile/filesys.h
index 7673c8051..8af0f989a 100644
--- a/libguile/filesys.h
+++ b/libguile/filesys.h
@@ -48,6 +48,7 @@ SCM_API SCM scm_open (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);
+SCM_API SCM scm_statat (SCM dir, SCM filename, SCM flags);
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);
diff --git a/libguile/syscalls.h b/libguile/syscalls.h
index 30b99c193..37d532e60 100644
--- a/libguile/syscalls.h
+++ b/libguile/syscalls.h
@@ -65,6 +65,7 @@
# define readdir_r_or_readdir64_r readdir_r
#endif
#define stat_or_stat64 CHOOSE_LARGEFILE(stat,stat64)
+#define fstatat_or_fstatat64 CHOOSE_LARGEFILE(fstatat,fstatat64)
#define truncate_or_truncate64 CHOOSE_LARGEFILE(truncate,truncate64)
#define scm_from_off_t_or_off64_t
CHOOSE_LARGEFILE(scm_from_off_t,scm_from_int64)
#define scm_from_ino_t_or_ino64_t
CHOOSE_LARGEFILE(scm_from_ulong,scm_from_uint64)
diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test
index 33b68e16d..b794b07b3 100644
--- a/test-suite/tests/filesys.test
+++ b/test-suite/tests/filesys.test
@@ -134,6 +134,86 @@
(close-port port)
(eqv? 5 (stat:size st))))))
+(with-test-prefix "statat"
+ ;; file-exists? from (ice-9 boot) dereferences symbolic links
+ ;; (a bug?).
+ (define (file-exists? filename)
+ (catch 'system-error
+ (lambda () (lstat filename) #t)
+ (lambda args
+ (if (= (system-error-errno args) ENOENT)
+ ;; For the purposes of the following tests,
+ ;; it is safe to ignore errors like EPERM, but a correct
+ ;; implementation would return #t for that error.
+ #f
+ (apply throw args)))))
+ (define (maybe-delete-directory)
+ (when (file-exists? (test-directory))
+ (for-each
+ (lambda (filename)
+ (define full-name (in-vicinity (test-directory) filename))
+ (when (file-exists? full-name)
+ (delete-file full-name)))
+ '("test-file" "test-symlink"))
+ (rmdir (test-directory))))
+ (define (skip-unless-defined . things)
+ (for-each (lambda (thing)
+ (unless (defined? thing)
+ (throw 'unsupported)))
+ things))
+ (maybe-delete-directory)
+ (mkdir (test-directory))
+ (call-with-output-file (in-vicinity (test-directory) "test-file")
+ (lambda (port)
+ (display "hello" port)))
+
+ ;; Return #true if the symlink was created, #false otherwise.
+ (define (maybe-create-symlink)
+ (if (file-exists? (in-vicinity (test-directory) "test-symlink"))
+ #t
+ (false-if-exception
+ (symlink "test-file"
+ (in-vicinity (test-directory) "test-symlink")))))
+
+ (pass-if-equal "regular file" 5
+ (skip-unless-defined 'statat)
+ (call-with-port
+ (open (test-directory) O_RDONLY)
+ (lambda (port)
+ (stat:size (statat port "test-file")))))
+
+ (pass-if-equal "regular file, AT_SYMLINK_NOFOLLOW" 5
+ (skip-unless-defined 'statat 'AT_SYMLINK_NOFOLLOW)
+ (call-with-port
+ (open (test-directory) O_RDONLY)
+ (lambda (port)
+ (stat:size (statat port "test-file" AT_SYMLINK_NOFOLLOW)))))
+
+ (pass-if-equal "symbolic links are dereferenced" '(regular 5)
+ ;; Not all systems support symlinks.
+ (skip-unless-defined 'statat 'symlink)
+ (unless (maybe-create-symlink)
+ (throw 'unresolved))
+ (call-with-port
+ (open (test-directory) O_RDONLY)
+ (lambda (port)
+ (define result (statat port "test-symlink"))
+ (list (stat:type result) (stat:size result)))))
+
+ (pass-if-equal "symbolic links are not dereferenced"
+ `(symlink ,(string-length "test-file"))
+ ;; Not all systems support symlinks.
+ (skip-unless-defined 'statat 'symlink)
+ (unless (maybe-create-symlink)
+ (throw 'unresolved))
+ (call-with-port
+ (open (test-directory) O_RDONLY)
+ (lambda (port)
+ (define result (statat port "test-symlink" AT_SYMLINK_NOFOLLOW))
+ (list (stat:type result) (stat:size result)))))
+
+ (maybe-delete-directory))
+
(with-test-prefix "sendfile"
(let* ((file (search-path %load-path "ice-9/boot-9.scm"))
- [Guile-commits] branch wip-openat created (now 07f395eb1), Ludovic Courtès, 2022/06/16
- [Guile-commits] 08/14: Define a Scheme binding to ‘renameat’ when it exists., Ludovic Courtès, 2022/06/16
- [Guile-commits] 12/14: Define a Scheme binding to ‘fstatat’ when available.,
Ludovic Courtès <=
- [Guile-commits] 13/14: Define Scheme bindings to ‘openat’ when available., Ludovic Courtès, 2022/06/16
- [Guile-commits] 09/14: Define a Scheme binding to ‘fchmodat’ when it exists., Ludovic Courtès, 2022/06/16
- [Guile-commits] 11/14: Define a Scheme binding to ‘fchownat’ when it exists., Ludovic Courtès, 2022/06/16
- [Guile-commits] 01/14: Allow file ports in ‘chdir’ when supported., Ludovic Courtès, 2022/06/16
- [Guile-commits] 02/14: Allow file ports in ‘readlink’., Ludovic Courtès, 2022/06/16
- [Guile-commits] 06/14: Correct documentation of ‘mkdir’ w.r.t. the umask., Ludovic Courtès, 2022/06/16
- [Guile-commits] 07/14: Define AT_REMOVEDIR and others when available., Ludovic Courtès, 2022/06/16
- [Guile-commits] 14/14: Update NEWS., Ludovic Courtès, 2022/06/16
- [Guile-commits] 03/14: Allow file ports in ‘utime’., Ludovic Courtès, 2022/06/16
- [Guile-commits] 05/14: Define bindings to ‘mkdirat’ when the C function exists., Ludovic Courtès, 2022/06/16