[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[PATCH v2 12/14] Define a Scheme binding to ‘fstatat’ when available.
From: |
Maxime Devos |
Subject: |
[PATCH v2 12/14] Define a Scheme binding to ‘fstatat’ when available. |
Date: |
Tue, 16 Nov 2021 11:06:35 +0000 |
* 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’.
---
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 dcb6bceb5..e073e04f4 100644
--- a/configure.ac
+++ b/configure.ac
@@ -478,7 +478,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)
@@ -495,7 +495,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"))
--
2.30.2
- [PATCH v2 04/14] Define ‘symlinkat’ wrapper when supported., (continued)
- [PATCH v2 04/14] Define ‘symlinkat’ wrapper when supported., Maxime Devos, 2021/11/16
- [PATCH v2 10/14] Define a Scheme binding to ‘unlinkat’ when it exists., Maxime Devos, 2021/11/16
- [PATCH v2 06/14] Correct documentation of ‘mkdir’ w.r.t. the umask., Maxime Devos, 2021/11/16
- [PATCH v2 07/14] Define AT_REMOVEDIR and others when available., Maxime Devos, 2021/11/16
- [PATCH v2 05/14] Define bindings to ‘mkdirat’ when the C function exists., Maxime Devos, 2021/11/16
- [PATCH v2 03/14] Allow file ports in ‘utime’., Maxime Devos, 2021/11/16
- [PATCH v2 08/14] Define a Scheme binding to ‘renameat’ when it exists., Maxime Devos, 2021/11/16
- [PATCH v2 14/14] Update NEWS., Maxime Devos, 2021/11/16
- [PATCH v2 13/14] Define Scheme bindings to ‘openat’ when available., Maxime Devos, 2021/11/16
- [PATCH v2 12/14] Define a Scheme binding to ‘fstatat’ when available.,
Maxime Devos <=
- [PATCH v2 01/14] Allow file ports in ‘chdir’ when supported., Maxime Devos, 2021/11/16