From e2ce6ad6d73f32bb630607abf6e90c0e51897db7 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Fri, 12 Mar 2021 13:20:45 +0100 Subject: [PATCH 09/17] Define a Scheme binding to fchmodat when defined. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit fchmodat on both regular files and symbolic links is known to behave oddly when the flag AT_SYMLINK_NOFOLLOW is passed on some Linux versions and file systems, and fchmodat is not required by POSIX to function on symbolic links, so define a few tests to make sure the situation is understood correctly. * configure.ac: Detect existence of ‘fchmodat’. * libguile/filesys.c (scm_chmodat): Define the Scheme binding. * libguile/filesys.h (scm_chmodat): Make the binding part of the API. * test-suite/tests/filesys.test: Test the Scheme binding, in particular whether ‘AT_SYMLINK_NOFOLLOW’ works as expected. --- configure.ac | 2 +- doc/ref/posix.texi | 16 ++++++ libguile/filesys.c | 38 +++++++++++++ libguile/filesys.h | 1 + test-suite/tests/filesys.test | 104 ++++++++++++++++++++++++++++++++++ 5 files changed, 160 insertions(+), 1 deletion(-) diff --git a/configure.ac b/configure.ac index a2ad3364f..20357ce3b 100644 --- a/configure.ac +++ b/configure.ac @@ -482,7 +482,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 \ - symlinkat mkdirat renameat getcwd geteuid getsid \ + symlinkat mkdirat renameat fchmodat 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 a5dabf5e1..2bc067f74 100644 --- a/doc/ref/posix.texi +++ b/doc/ref/posix.texi @@ -829,6 +829,22 @@ the new permissions as a decimal number, e.g., @code{(chmod "foo" #o755)}. The return value is unspecified. @end deffn +@findex fchmodat +@deffn {Scheme Procedure} chmodat dir pathname mode [flags] +@deffnx {C Function} scm_chmodat (dir, pathname, mode, flags) +Like @var{chmod}, but modify the permissions of the file named +@var{pathname} in the directory referred to by the file port +@var{dir} instead. +The optional @var{flags} argument may be 0 or @code{AT_SYMLINK_NOFOLLOW}, +in which case @var{pathname} is not dereferenced if it is a symbolic link, +i.e., the permissions of the symbolic link itself are modified. + +Note that @code{AT_SYMLINK_NOFOLLOW} is not supported on all systems +when @var{pathname} names a symbolic link and may result in @code{ENOTSUP}. +Also, on some systems (e.g. GNU/Linux) using this flag for a regular file +incorrectly results in @code{ENOTSUP}. +@end deffn + @deffn {Scheme Procedure} utime pathname [actime [modtime [actimens [modtimens [flags]]]]] @deffnx {C Function} scm_utime (pathname, actime, modtime, actimens, modtimens, flags) @code{utime} sets the access and modification times for the diff --git a/libguile/filesys.c b/libguile/filesys.c index 61a16f981..52380cd20 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1588,6 +1588,44 @@ SCM_DEFINE (scm_chmod, "chmod", 2, 0, 0, } #undef FUNC_NAME +#ifdef HAVE_FCHMODAT +SCM_DEFINE (scm_chmodat, "chmodat", 3, 1, 0, + (SCM dir, SCM pathname, SCM mode, SCM flags), + "Like @var{chmod}, but modify the permissions of the file named\n" + "@var{pathname} in the directory referred to by the file port\n" + "@var{dir} instead.\n" + "The optional @var{flags} argument may be 0 or @code{AT_SYMLINK_NOFOLLOW},\n" + "in which case @var{pathname} is not dereferenced if it is a symbolic link,\n" + "i.e., the permissions of the symbolic link itself are modified.\n\n" + "Note that @code{AT_SYMLINK_NOFOLLOW} is not supported on all systems\n" + "when @var{pathname} names a symbolic link and may result in @code{ENOTSUP}.\n" + "Also, on some systems (e.g. GNU/Linux) using this flag for a regular file\n" + "incorrectly results in @code{ENOTSUP}.") +#define FUNC_NAME s_scm_chmodat +{ + int rv; + int c_flags; + int dir_fdes; + + 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 (pathname, c_pathname, + rv = fchmodat (dir_fdes, c_pathname, + scm_to_int (mode), c_flags)); + scm_remember_upto_here_1 (dir); + if (rv == -1) + SCM_SYSERROR; + return SCM_UNSPECIFIED; +} +#undef FUNC_NAME +#endif + SCM_DEFINE (scm_umask, "umask", 0, 1, 0, (SCM mode), "If @var{mode} is omitted, returns a decimal number representing the current\n" diff --git a/libguile/filesys.h b/libguile/filesys.h index 7e17cc585..377a3795e 100644 --- a/libguile/filesys.h +++ b/libguile/filesys.h @@ -40,6 +40,7 @@ SCM_API scm_t_bits scm_tc16_dir; SCM_API SCM scm_chown (SCM object, SCM owner, SCM group); 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 (SCM path, SCM flags, SCM mode); diff --git a/test-suite/tests/filesys.test b/test-suite/tests/filesys.test index 6fed981e5..d85f51aac 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -265,3 +265,107 @@ (result (eqv? 'directory (stat:type _stat)))) (false-if-exception (rmdir name)) result))))) + +;;; +;;; chmodat +;;; + +(with-test-prefix "chmodat" + (call-with-output-file (test-file) (const #f)) + (chmod (test-file) #o000) + + (pass-if-equal "regular file" + #o300 + (unless (defined? 'chmodat) + (throw 'unsupported)) + (let ((d (open "/" O_RDONLY))) + (chmodat d (test-file) #o300) + (let ((p (stat:perms (stat (test-file))))) + (close-port d) + p))) + + (chmod (test-file) #o000) + (pass-if-equal "regular file, AT_SYMLINK_NOFOLLOW" + #o300 + (unless (and (defined? 'chmodat) + (defined? 'AT_SYMLINK_NOFOLLOW)) + (throw 'unsupported)) + (let ((dir (open "/" O_RDONLY))) + (catch 'system-error + (lambda () + (chmodat dir (test-file) #o300 AT_SYMLINK_NOFOLLOW)) + (lambda args + (close-port dir) + ;; AT_SYMLINK_NOFOLLOW is not supported on Linux (at least Linux 5.11.2 + ;; with the btrfs file system), even for regular files. + (cond ((not (= ENOTSUP (system-error-errno args))) + (apply throw args)) + ((string-contains %host-type "linux") + (display "warning: on this Linux version and file system, fchmodat incorrectly returns ENOTSUP even for regular files") + (newline) + (throw 'unresolved)) + (#t (apply throw args))))) + (close-port dir) + (let ((p (stat:perms (stat (test-file))))) + (close-port dir) + p))) + + (chmod (test-file) #o000) + (let* ((symlink-created + (not (false-if-exception + (begin (symlink (test-file) (test-symlink)) #t)))) + (has-required-procedures? + (and symlink-created (defined? 'chmodat) (defined? 'lstat)))) + + ;; Without AT_SYMLINK_NOFOLLOW, modify the file permissions + ;; of the file pointed at, and not the permissions of the + ;; symbolic link. + (pass-if "symbolic link" + (unless has-required-procedures? + (throw 'unsupported)) + (let* ((old-perms (stat:perms (lstat (test-symlink)))) + (dir (open "/" O_RDONLY))) + (chmodat dir (test-symlink) #o700) + (let ((ok (equal? (cons #o700 old-perms) + (cons (stat:perms (stat (test-file))) + (stat:perms (lstat (test-symlink))))))) + (close-port dir) + ok))) + + (chmod (test-file) #o000) + ;; With AT_SYMLINK_NOFOLLOW, modify the file permissions + ;; of the symbolic link itself, instead of the file it points + ;; to -- unless this is not supported, of course. + (pass-if "symbolic link, AT_SYMLINK_NOFOLLOW" + (unless (and (defined? 'AT_SYMLINK_NOFOLLOW) + has-required-procedures?) + (throw 'unsupported)) + (let* ((old-perms (stat:perms (stat (test-file)))) + (old-symlink-perms (stat:perms (lstat (test-symlink)))) + (new-symlink-perms (logxor #o700 old-symlink-perms)) + (dir (open "/" O_RDONLY))) + (catch 'system-error + (lambda () + (chmodat dir (test-symlink) new-symlink-perms AT_SYMLINK_NOFOLLOW)) + (lambda args + (close-port dir) + ;; AT_SYMLINK_NOFOLLOW is not supported on Linux (at least Linux 5.11.2 + ;; with the btrfs file system). + (cond ((not (= ENOTSUP (system-error-errno args))) + (apply throw args)) + ((and (= (stat:perms (stat (test-file))) old-perms) + (= (stat:perms (lstat (test-symlink))) old-symlink-perms)) + (throw 'unresolved)) + ((string-contains %host-type "linux") + (display "warning: on this Linux version and file system, fchmodat incorrectly returns ENOTSUP") + (newline) + (throw 'unresolved)) + (#t (apply throw args))))) + (close-port dir) + (equal? (pk 'p (cons old-perms new-symlink-perms)) + (pk 'q (cons (stat:perms (stat (test-file))) + (stat:perms (lstat (test-symlink)))))))))) + +(delete-file (test-file)) +(when (file-exists? (test-symlink)) + (delete-file (test-symlink))) -- 2.30.2