diff --git a/configure.ac b/configure.ac index 6a90ef03f..b3aeb6a3c 100644 --- a/configure.ac +++ b/configure.ac @@ -508,7 +508,7 @@ AC_CHECK_HEADERS([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 - POSIX.1-2008 +# strcoll_l, newlocale, uselocale, utimensat, futimens, fchmodat - POSIX.1-2008 # strtol_l - non-POSIX, found in glibc # fork - unavailable on Windows # sched_getaffinity, sched_setaffinity - GNU extensions (glibc) @@ -517,7 +517,7 @@ AC_CHECK_HEADERS([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 \ + fchmodat symlinkat mkdirat renameat getcwd geteuid getsid \ gettimeofday getuid getgid gmtime_r ioctl lstat mkdir mkdtemp mknod \ nice readlink rmdir setegid seteuid \ setuid setgid setpgid setsid sigaction siginterrupt stat64 \ diff --git a/libguile/filesys.c b/libguile/filesys.c index fc7867fb8..1ec85d940 100644 --- a/libguile/filesys.c +++ b/libguile/filesys.c @@ -1548,6 +1548,42 @@ 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" + "and may result 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 bbce2c858..204f3414c 100644 --- a/test-suite/tests/filesys.test +++ b/test-suite/tests/filesys.test @@ -271,6 +271,59 @@ (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)) + (call-with-port + (open (dirname (test-file)) O_RDONLY) + (lambda (port) + (chmodat port (test-file) #o300))) + (stat:perms (stat (test-file)))) + + (chmod (test-file) #o000) + + (pass-if-equal "regular file, AT_SYMLINK_NOFOLLOW" + #o300 + (unless (and (defined? 'chmodat) + (defined? 'AT_SYMLINK_NOFOLLOW)) + (throw 'unsupported)) + (call-with-port + (open (dirname (test-file)) O_RDONLY) + (lambda (port) + (catch 'system-error + (lambda () + (chmodat port (basename (test-file)) #o300 AT_SYMLINK_NOFOLLOW)) + (lambda args + (close-port port) + ;; AT_SYMLINK_NOFOLLOW is not supported on Linux (at least Linux + ;; 5.11.2 with the btrfs file system), even for regular files. + (if (= ENOTSUP (system-error-errno args)) + (begin + (display "fchmodat doesn't support AT_SYMLINK_NOFOLLOW\n") + (throw 'unresolved)) + (apply throw args)))))) + (stat:perms (stat (test-file)))) + + (pass-if-exception "not a port" exception:wrong-type-arg + (chmodat "bogus" (test-file) #o300)) + + (pass-if-exception "not a file port" exception:wrong-type-arg + (chmodat (open-input-string "") (test-file) #o300)) + + (pass-if-exception "closed port" exception:wrong-type-arg + (chmodat (call-with-port (open "." O_RDONLY) identity) (test-file) #o300)) + + (delete-file (test-file))) + (with-test-prefix "chdir" (pass-if-equal "current directory" (getcwd) (begin (chdir ".") (getcwd)))