1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
| | Guix-Upstream: https://lists.gnu.org/archive/html/guile-devel/2021-11/msg00005.html
From: Maxime Devos <maximedevos@telenet.be>
Subject: [PATCH v2 09/14] =?UTF-8?q?Define=20a=20Scheme=20binding=20to=20?=
=?UTF-8?q?=E2=80=98fchmodat=E2=80=99=20when=20it=20exists.?=
Date: Tue, 16 Nov 2021 11:06:32 +0000
Message-Id: <20211116110637.125579-10-maximedevos@telenet.be>
In-Reply-To: <20211116110637.125579-1-maximedevos@telenet.be>
References: <175c3a6572e832d84927937b309a3095cadf5702.camel@telenet.be>
<20211116110637.125579-1-maximedevos@telenet.be>
MIME-Version: 1.0
Content-Type: text/plain; charset=UTF-8
Content-Transfer-Encoding: 8bit
* configure.ac: Detect existence of fchmodat.
* libguile/filesys.c (scm_chmodat): New procedure.
* libguile/filesys.h (scm_chmodat): Make it part of the API.
* test-suite/tests/filesys.test ("chmodat"): Test it.
---
configure.ac | 4 +--
libguile/filesys.c | 36 ++++++++++++++++++++++++
libguile/filesys.h | 1 +
test-suite/tests/filesys.test | 53 +++++++++++++++++++++++++++++++++++
4 files changed, 92 insertions(+), 2 deletions(-)
diff --git a/configure.ac b/configure.ac
index e67892feb..2a5485990 100644
--- a/configure.ac
+++ b/configure.ac
@@ -477,7 +477,7 @@ AC_CHECK_HEADERS([assert.h 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)
@@ -485,7 +485,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 \
+ fchmodat symlinkat mkdirat renameat 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/libguile/filesys.c b/libguile/filesys.c
index 9c63beaa8..4dd9c7b48 100644
--- a/libguile/filesys.c
+++ b/libguile/filesys.c
@@ -1561,6 +1561,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)))
--
2.30.2
|