From c8b81ffb3492d1f1e7fc6886809108f31ac55794 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Tue, 16 Nov 2021 11:06:36 +0000 Subject: =?UTF-8?q?Define=20Scheme=20bindings=20to=20=E2=80=98openat?= =?UTF-8?q?=E2=80=99=20when=20available.?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * configure.ac: Detect if ‘openat’ is defined. * libguile/filesys.c (flags_to_mode): Extract from ... (scm_mode): ... here. (scm_open_fdes_at, scm_openat): Define the Scheme bindings. * libguile/filesys.h (scm_open_fdes_at, scm_openat): Make them part of the API. * doc/ref/posix.texi (File System): Document them. * test-suite/tests/filesys.test ("openat"): Test ‘openat’. * libguile/syscalls.h (openat_or_openat64): Decide between ‘openat’ and ‘openat64’. Signed-off-by: Ludovic Courtès --- configure.ac | 5 ++- doc/ref/posix.texi | 13 ++++++ libguile/filesys.c | 96 ++++++++++++++++++++++++++++++++++--------- libguile/filesys.h | 2 + libguile/syscalls.h | 1 + test-suite/tests/filesys.test | 73 ++++++++++++++++++++++++++++++++ 6 files changed, 168 insertions(+), 22 deletions(-) diff --git a/configure.ac b/configure.ac index 7aa5a46d7..b3879df1f 100644 --- a/configure.ac +++ b/configure.ac @@ -509,7 +509,7 @@ AC_CHECK_HEADERS([crt_externs.h]) # isblank - available as a GNU extension or in C99 # _NSGetEnviron - Darwin specific # strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat, -# unlinkat, fchownat, fstatat - POSIX.1-2008 +# unlinkat, fchownat, fstatat, openat - POSIX.1-2008 # strtol_l - non-POSIX, found in glibc # fork - unavailable on Windows # sched_getaffinity, sched_setaffinity - GNU extensions (glibc) @@ -527,7 +527,8 @@ AC_CHECK_FUNCS([DINFINITY DQNAN cexp chsize clog clog10 ctermid \ getgrent kill getppid getpgrp fork setitimer getitimer strchr strcmp \ index bcopy rindex truncate isblank _NSGetEnviron \ strcoll_l strtod_l strtol_l newlocale uselocale utimensat \ - fstatat futimens sched_getaffinity sched_setaffinity sendfile pipe2]) + fstatat futimens openat \ + sched_getaffinity sched_setaffinity sendfile pipe2]) # The newlib C library uses _NL_ prefixed locale langinfo constants. AC_CHECK_DECLS([_NL_NUMERIC_GROUPING], [], [], [[#include ]]) diff --git a/doc/ref/posix.texi b/doc/ref/posix.texi index 601c33747..bde0f150c 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -296,12 +296,25 @@ Create the file if it does not already exist. for additional flags. @end deffn +@deffn {Scheme Procedure} openat dir path flags [mode] +@deffnx {C Function} scm_openat (dir, path, flags, mode) +Similar to @code{open}, but resolve the file name @var{path} +relative to the directory referred to by the file port @var{dir} +instead. +@end deffn + @deffn {Scheme Procedure} open-fdes path flags [mode] @deffnx {C Function} scm_open_fdes (path, flags, mode) Similar to @code{open} but return a file descriptor instead of a port. @end deffn +@deffn {Scheme Procedure} open-fdes-at dir path flags [mode] +@deffnx {C Function} scm_open_fdes_at (dir, path, flags, mode) +Similar to @code{openat}, but return a file descriptor instead +of a port. +@end deffn + @deffn {Scheme Procedure} close fd_or_port @deffnx {C Function} scm_close (fd_or_port) Similar to @code{close-port} (@pxref{Ports, close-port}), diff --git a/libguile/filesys.c b/libguile/filesys.c index 6fa641d16..1f0bba556 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -236,6 +236,60 @@ SCM_DEFINE (scm_open_fdes, "open-fdes", 2, 1, 0, } #undef FUNC_NAME +#ifdef HAVE_OPENAT +SCM_DEFINE (scm_open_fdes_at, "open-fdes-at", 3, 1, 0, + (SCM dir, SCM path, SCM flags, SCM mode), + "Similar to @code{openat}, but return a file descriptor instead\n" + "of a port.") +#define FUNC_NAME s_scm_open_fdes_at +{ + int dir_fdes; + int fd; + int iflags; + int imode; + + iflags = SCM_NUM2INT (SCM_ARG2, flags); + imode = SCM_NUM2INT_DEF (3, mode, 0666); + SCM_VALIDATE_OPFPORT (SCM_ARG1, dir); + dir_fdes = SCM_FPORT_FDES (dir); + + STRING_SYSCALL (path, c_path, + fd = openat_or_openat64 (dir_fdes, c_path, iflags, imode)); + scm_remember_upto_here_1 (dir); + if (fd == -1) + SCM_SYSERROR; + return scm_from_int (fd); +} +#undef FUNC_NAME +#endif /* HAVE_OPENAT */ + +/* A helper function for converting some open flags to + what scm_fdes_to_port expects. */ +static char * +flags_to_mode (int iflags) +{ + if ((iflags & O_RDWR) == O_RDWR) + { + /* Opened read-write. */ + if (iflags & O_APPEND) + return "a+"; + else if (iflags & O_CREAT) + return "w+"; + else + return "r+"; + } + else + { + /* Opened read-only or write-only. */ + if (iflags & O_APPEND) + return "a"; + else if (iflags & O_WRONLY) + return "w"; + else + return "r"; + } +} + SCM_DEFINE (scm_open, "open", 2, 1, 0, (SCM path, SCM flags, SCM mode), "Open the file named by @var{path} for reading and/or writing.\n" @@ -272,31 +326,33 @@ SCM_DEFINE (scm_open, "open", 2, 1, 0, fd = scm_to_int (scm_open_fdes (path, flags, mode)); iflags = SCM_NUM2INT (2, flags); - if ((iflags & O_RDWR) == O_RDWR) - { - /* Opened read-write. */ - if (iflags & O_APPEND) - port_mode = "a+"; - else if (iflags & O_CREAT) - port_mode = "w+"; - else - port_mode = "r+"; - } - else - { - /* Opened read-only or write-only. */ - if (iflags & O_APPEND) - port_mode = "a"; - else if (iflags & O_WRONLY) - port_mode = "w"; - else - port_mode = "r"; - } + port_mode = (char *) flags_to_mode (iflags); + newpt = scm_fdes_to_port (fd, port_mode, path); + return newpt; +} +#undef FUNC_NAME +#ifdef HAVE_OPENAT +SCM_DEFINE (scm_openat, "openat", 3, 1, 0, + (SCM dir, SCM path, SCM flags, SCM mode), + "Similar to @code{open}, but resolve the file name @var{path}\n" + "relative to the directory referred to by the file port @var{dir}\n" + "instead.") +#define FUNC_NAME s_scm_openat +{ + SCM newpt; + char *port_mode; + int fd; + int iflags; + + iflags = SCM_NUM2INT (2, flags); + port_mode = (char *) flags_to_mode (iflags); + fd = scm_to_int (scm_open_fdes_at (dir, path, flags, mode)); newpt = scm_fdes_to_port (fd, port_mode, path); return newpt; } #undef FUNC_NAME +#endif /* HAVE_OPENAT */ SCM_DEFINE (scm_close, "close", 1, 0, 0, (SCM fd_or_port), diff --git a/libguile/filesys.h b/libguile/filesys.h index 8af0f989a..1ce50d30e 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -44,7 +44,9 @@ SCM_API SCM scm_chmod (SCM object, SCM mode); SCM_API SCM scm_chmodat (SCM dir, SCM pathname, SCM mode, SCM flags); SCM_API SCM scm_umask (SCM mode); SCM_API SCM scm_open_fdes (SCM path, SCM flags, SCM mode); +SCM_API SCM scm_open_fdes_at (SCM dir, SCM path, SCM flags, SCM mode); SCM_API SCM scm_open (SCM path, SCM flags, SCM mode); +SCM_API SCM scm_openat (SCM dir, 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); diff --git a/libguile/syscalls.h b/libguile/syscalls.h index 37d532e60..6f4061138 100644 --- a/libguile/syscalls.h +++ b/libguile/syscalls.h @@ -58,6 +58,7 @@ #define lstat_or_lstat64 CHOOSE_LARGEFILE(lstat,lstat64) #define off_t_or_off64_t CHOOSE_LARGEFILE(off_t,off64_t) #define open_or_open64 CHOOSE_LARGEFILE(open,open64) +#define openat_or_openat64 CHOOSE_LARGEFILE(openat,openat64) #define readdir_or_readdir64 CHOOSE_LARGEFILE(readdir,readdir64) #if SCM_HAVE_READDIR64_R == 1 # define readdir_r_or_readdir64_r CHOOSE_LARGEFILE(readdir_r,readdir64_r) diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index b794b07b3..45e77c823 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -728,3 +728,76 @@ (skip-if-unsupported) (delete-file-at (call-with-port (open "." O_RDONLY) identity) "irrelevant"))) + +(with-test-prefix "openat" + (define (skip-if-unsupported) + (unless (defined? 'openat) + (throw 'unsupported))) + + (define file (search-path %load-path "ice-9/boot-9.scm")) + + (define (call-with-relatively-opened-file directory-arguments file-arguments + proc) + (call-with-port + (apply open directory-arguments) + (lambda (directory) + (call-with-port + (apply openat directory file-arguments) + (lambda (port) + (proc port)))))) + + (pass-if-equal "mode read-only" "r" + (skip-if-unsupported) + (call-with-relatively-opened-file + (list (dirname file) O_RDONLY) + (list (basename file) O_RDONLY) + (lambda (port) (port-mode port)))) + + (pass-if-equal "port-revealed count" 0 + (skip-if-unsupported) + (call-with-relatively-opened-file + (list (dirname file) O_RDONLY) + (list (basename file) O_RDONLY) + (lambda (port) (port-revealed port)))) + + (when (file-exists? (test-file)) + (delete-file (test-file))) + + (pass-if-equal "O_CREAT/O_WRONLY" (list #t (logand (lognot (umask)) #o666) "w") + (skip-if-unsupported) + (call-with-relatively-opened-file + (list (dirname (test-file)) O_RDONLY) + (list (basename (test-file)) (logior O_WRONLY O_CREAT)) + (lambda (port) + (list (file-exists? (test-file)) + (stat:perms (stat (test-file))) + (port-mode port))))) + + (when (file-exists? (test-file)) + (delete-file (test-file))) + + (pass-if-equal "O_CREAT/O_WRONLY, non-default mode" + (list #t (logand (lognot (umask)) #o700) "w") + (skip-if-unsupported) + (call-with-relatively-opened-file + (list (dirname (test-file)) O_RDONLY) + (list (basename (test-file)) (logior O_WRONLY O_CREAT) #o700) + (lambda (port) + (list (file-exists? (test-file)) + (stat:perms (stat (test-file))) + (port-mode port))))) + + (pass-if-exception "closed port" exception:wrong-type-arg + (skip-if-unsupported) + (openat (call-with-port (open "." O_RDONLY) identity) "." O_RDONLY)) + + (pass-if-exception "non-file port" exception:wrong-type-arg + (skip-if-unsupported) + (openat (open-input-string "") "." O_RDONLY)) + + (pass-if-exception "not a port" exception:wrong-type-arg + (skip-if-unsupported) + (openat "not a port" "." O_RDONLY)) + + (when (file-exists? (test-file)) + (delete-file (test-file)))) -- cgit v1.2.1