1 /* Implementation of the CHMOD intrinsic.
2 Copyright (C) 2006-2023 Free Software Foundation, Inc.
3 Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
4
5 This file is part of the GNU Fortran runtime library (libgfortran).
6
7 Libgfortran is free software; you can redistribute it and/or
8 modify it under the terms of the GNU General Public
9 License as published by the Free Software Foundation; either
10 version 3 of the License, or (at your option) any later version.
11
12 Libgfortran is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 Under Section 7 of GPL version 3, you are granted additional
18 permissions described in the GCC Runtime Library Exception, version
19 3.1, as published by the Free Software Foundation.
20
21 You should have received a copy of the GNU General Public License and
22 a copy of the GCC Runtime Library Exception along with this program;
23 see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24 <http://www.gnu.org/licenses/>. */
25
26 #include "libgfortran.h"
27
28 #if defined(HAVE_SYS_STAT_H)
29
30 #include <sys/stat.h> /* For stat, chmod and umask. */
31
32
33 /* INTEGER FUNCTION CHMOD (NAME, MODE)
34 CHARACTER(len=*), INTENT(IN) :: NAME, MODE
35
36 Sets the file permission "chmod" using a mode string.
37
38 For MinGW, only _S_IWRITE and _S_IREAD are supported. To set those,
39 only the user attributes are used.
40
41 The mode string allows for the same arguments as POSIX's chmod utility.
42 a) string containing an octal number.
43 b) Comma separated list of clauses of the form:
44 [<who-list>]<op>[<perm-list>|<permcopy>][<op>[<perm-list>|<permcopy>],...]
45 <who> - 'u', 'g', 'o', 'a'
46 <op> - '+', '-', '='
47 <perm> - 'r', 'w', 'x', 'X', 's', t'
48 If <op> is not followed by a perm-list or permcopy, '-' and '+' do not
49 change the mode while '=' clears all file mode bits. 'u' stands for the
50 user permissions, 'g' for the group and 'o' for the permissions for others.
51 'a' is equivalent to 'ugo'. '+' sets the given permission in addition to
52 the ones of the file, '-' unsets the given permissions of the file, while
53 '=' sets the file to that mode. 'r' sets the read, 'w' the write, and
54 'x' the execute mode. 'X' sets the execute bit if the file is a directory
55 or if the user, group or other executable bit is set. 't' sets the sticky
56 bit, 's' (un)sets the and/or S_ISUID/S_ISGID bit.
57
58 Note that if <who> is omitted, the permissions are filtered by the umask.
59
60 A return value of 0 indicates success, -1 an error of chmod() while 1
61 indicates a mode parsing error. */
62
63
64 static int
65 chmod_internal (char *file, char *mode, gfc_charlen_type mode_len)
66 {
67 bool ugo[3];
68 bool rwxXstugo[9];
69 int set_mode, part;
70 bool honor_umask, continue_clause = false;
71 #ifndef __MINGW32__
72 bool is_dir;
73 #endif
74 #ifdef HAVE_UMASK
75 mode_t mode_mask;
76 #endif
77 mode_t file_mode, new_mode;
78 struct stat stat_buf;
79
80 if (mode_len == 0)
81 return 1;
82
83 if (mode[0] >= '0' && mode[0] <= '9')
84 {
85 unsigned fmode;
86 if (sscanf (mode, "%o", &fmode) != 1)
87 return 1;
88 return chmod (file, (mode_t) fmode);
89 }
90
91 /* Read the current file mode. */
92 if (stat (file, &stat_buf))
93 return 1;
94
95 file_mode = stat_buf.st_mode & ~S_IFMT;
96 #ifndef __MINGW32__
97 is_dir = stat_buf.st_mode & S_IFDIR;
98 #endif
99
100 #ifdef HAVE_UMASK
101 /* Obtain the umask without distroying the setting. */
102 mode_mask = 0;
103 mode_mask = umask (mode_mask);
104 (void) umask (mode_mask);
105 #else
106 honor_umask = false;
107 #endif
108
109 for (gfc_charlen_type i = 0; i < mode_len; i++)
110 {
111 if (!continue_clause)
112 {
113 ugo[0] = false;
114 ugo[1] = false;
115 ugo[2] = false;
116 #ifdef HAVE_UMASK
117 honor_umask = true;
118 #endif
119 }
120 continue_clause = false;
121 rwxXstugo[0] = false;
122 rwxXstugo[1] = false;
123 rwxXstugo[2] = false;
124 rwxXstugo[3] = false;
125 rwxXstugo[4] = false;
126 rwxXstugo[5] = false;
127 rwxXstugo[6] = false;
128 rwxXstugo[7] = false;
129 rwxXstugo[8] = false;
130 part = 0;
131 set_mode = -1;
132 for (; i < mode_len; i++)
133 {
134 switch (mode[i])
135 {
136 /* User setting: a[ll]/u[ser]/g[roup]/o[ther]. */
137 case 'a':
138 if (part > 1)
139 return 1;
140 ugo[0] = true;
141 ugo[1] = true;
142 ugo[2] = true;
143 part = 1;
144 #ifdef HAVE_UMASK
145 honor_umask = false;
146 #endif
147 break;
148 case 'u':
149 if (part == 2)
150 {
151 rwxXstugo[6] = true;
152 part = 4;
153 break;
154 }
155 if (part > 1)
156 return 1;
157 ugo[0] = true;
158 part = 1;
159 #ifdef HAVE_UMASK
160 honor_umask = false;
161 #endif
162 break;
163 case 'g':
164 if (part == 2)
165 {
166 rwxXstugo[7] = true;
167 part = 4;
168 break;
169 }
170 if (part > 1)
171 return 1;
172 ugo[1] = true;
173 part = 1;
174 #ifdef HAVE_UMASK
175 honor_umask = false;
176 #endif
177 break;
178 case 'o':
179 if (part == 2)
180 {
181 rwxXstugo[8] = true;
182 part = 4;
183 break;
184 }
185 if (part > 1)
186 return 1;
187 ugo[2] = true;
188 part = 1;
189 #ifdef HAVE_UMASK
190 honor_umask = false;
191 #endif
192 break;
193
194 /* Mode setting: =+-. */
195 case '=':
196 if (part > 2)
197 {
198 continue_clause = true;
199 i--;
200 part = 2;
201 goto clause_done;
202 }
203 set_mode = 1;
204 part = 2;
205 break;
206
207 case '-':
208 if (part > 2)
209 {
210 continue_clause = true;
211 i--;
212 part = 2;
213 goto clause_done;
214 }
215 set_mode = 2;
216 part = 2;
217 break;
218
219 case '+':
220 if (part > 2)
221 {
222 continue_clause = true;
223 i--;
224 part = 2;
225 goto clause_done;
226 }
227 set_mode = 3;
228 part = 2;
229 break;
230
231 /* Permissions: rwxXst - for ugo see above. */
232 case 'r':
233 if (part != 2 && part != 3)
234 return 1;
235 rwxXstugo[0] = true;
236 part = 3;
237 break;
238
239 case 'w':
240 if (part != 2 && part != 3)
241 return 1;
242 rwxXstugo[1] = true;
243 part = 3;
244 break;
245
246 case 'x':
247 if (part != 2 && part != 3)
248 return 1;
249 rwxXstugo[2] = true;
250 part = 3;
251 break;
252
253 case 'X':
254 if (part != 2 && part != 3)
255 return 1;
256 rwxXstugo[3] = true;
257 part = 3;
258 break;
259
260 case 's':
261 if (part != 2 && part != 3)
262 return 1;
263 rwxXstugo[4] = true;
264 part = 3;
265 break;
266
267 case 't':
268 if (part != 2 && part != 3)
269 return 1;
270 rwxXstugo[5] = true;
271 part = 3;
272 break;
273
274 /* Trailing blanks are valid in Fortran. */
275 case ' ':
276 for (i++; i < mode_len; i++)
277 if (mode[i] != ' ')
278 break;
279 if (i != mode_len)
280 return 1;
281 goto clause_done;
282
283 case ',':
284 goto clause_done;
285
286 default:
287 return 1;
288 }
289 }
290
291 clause_done:
292 if (part < 2)
293 return 1;
294
295 new_mode = 0;
296
297 #ifdef __MINGW32__
298
299 /* Read. */
300 if (rwxXstugo[0] && (ugo[0] || honor_umask))
301 new_mode |= _S_IREAD;
302
303 /* Write. */
304 if (rwxXstugo[1] && (ugo[0] || honor_umask))
305 new_mode |= _S_IWRITE;
306
307 #else
308
309 /* Read. */
310 if (rwxXstugo[0])
311 {
312 if (ugo[0] || honor_umask)
313 new_mode |= S_IRUSR;
314 if (ugo[1] || honor_umask)
315 new_mode |= S_IRGRP;
316 if (ugo[2] || honor_umask)
317 new_mode |= S_IROTH;
318 }
319
320 /* Write. */
321 if (rwxXstugo[1])
322 {
323 if (ugo[0] || honor_umask)
324 new_mode |= S_IWUSR;
325 if (ugo[1] || honor_umask)
326 new_mode |= S_IWGRP;
327 if (ugo[2] || honor_umask)
328 new_mode |= S_IWOTH;
329 }
330
331 /* Execute. */
332 if (rwxXstugo[2])
333 {
334 if (ugo[0] || honor_umask)
335 new_mode |= S_IXUSR;
336 if (ugo[1] || honor_umask)
337 new_mode |= S_IXGRP;
338 if (ugo[2] || honor_umask)
339 new_mode |= S_IXOTH;
340 }
341
342 /* 'X' execute. */
343 if (rwxXstugo[3]
344 && (is_dir || (file_mode & (S_IXUSR | S_IXGRP | S_IXOTH))))
345 new_mode |= (S_IXUSR | S_IXGRP | S_IXOTH);
346
347 /* 's'. */
348 if (rwxXstugo[4])
349 {
350 if (ugo[0] || honor_umask)
351 new_mode |= S_ISUID;
352 if (ugo[1] || honor_umask)
353 new_mode |= S_ISGID;
354 }
355
356 /* As original 'u'. */
357 if (rwxXstugo[6])
358 {
359 if (ugo[1] || honor_umask)
360 {
361 if (file_mode & S_IRUSR)
362 new_mode |= S_IRGRP;
363 if (file_mode & S_IWUSR)
364 new_mode |= S_IWGRP;
365 if (file_mode & S_IXUSR)
366 new_mode |= S_IXGRP;
367 }
368 if (ugo[2] || honor_umask)
369 {
370 if (file_mode & S_IRUSR)
371 new_mode |= S_IROTH;
372 if (file_mode & S_IWUSR)
373 new_mode |= S_IWOTH;
374 if (file_mode & S_IXUSR)
375 new_mode |= S_IXOTH;
376 }
377 }
378
379 /* As original 'g'. */
380 if (rwxXstugo[7])
381 {
382 if (ugo[0] || honor_umask)
383 {
384 if (file_mode & S_IRGRP)
385 new_mode |= S_IRUSR;
386 if (file_mode & S_IWGRP)
387 new_mode |= S_IWUSR;
388 if (file_mode & S_IXGRP)
389 new_mode |= S_IXUSR;
390 }
391 if (ugo[2] || honor_umask)
392 {
393 if (file_mode & S_IRGRP)
394 new_mode |= S_IROTH;
395 if (file_mode & S_IWGRP)
396 new_mode |= S_IWOTH;
397 if (file_mode & S_IXGRP)
398 new_mode |= S_IXOTH;
399 }
400 }
401
402 /* As original 'o'. */
403 if (rwxXstugo[8])
404 {
405 if (ugo[0] || honor_umask)
406 {
407 if (file_mode & S_IROTH)
408 new_mode |= S_IRUSR;
409 if (file_mode & S_IWOTH)
410 new_mode |= S_IWUSR;
411 if (file_mode & S_IXOTH)
412 new_mode |= S_IXUSR;
413 }
414 if (ugo[1] || honor_umask)
415 {
416 if (file_mode & S_IROTH)
417 new_mode |= S_IRGRP;
418 if (file_mode & S_IWOTH)
419 new_mode |= S_IWGRP;
420 if (file_mode & S_IXOTH)
421 new_mode |= S_IXGRP;
422 }
423 }
424 #endif /* __MINGW32__ */
425
426 #ifdef HAVE_UMASK
427 if (honor_umask)
428 new_mode &= ~mode_mask;
429 #endif
430
431 if (set_mode == 1)
432 {
433 #ifdef __MINGW32__
434 if (ugo[0] || honor_umask)
435 file_mode = (file_mode & ~(_S_IWRITE | _S_IREAD))
436 | (new_mode & (_S_IWRITE | _S_IREAD));
437 #else
438 /* Set '='. */
439 if ((ugo[0] || honor_umask) && !rwxXstugo[6])
440 file_mode = (file_mode & ~(S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR))
441 | (new_mode & (S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR));
442 if ((ugo[1] || honor_umask) && !rwxXstugo[7])
443 file_mode = (file_mode & ~(S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP))
444 | (new_mode & (S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP));
445 if ((ugo[2] || honor_umask) && !rwxXstugo[8])
446 file_mode = (file_mode & ~(S_IROTH | S_IWOTH | S_IXOTH))
447 | (new_mode & (S_IROTH | S_IWOTH | S_IXOTH));
448 #ifndef __VXWORKS__
449 if (is_dir && rwxXstugo[5])
450 file_mode |= S_ISVTX;
451 else if (!is_dir)
452 file_mode &= ~S_ISVTX;
453 #endif
454 #endif
455 }
456 else if (set_mode == 2)
457 {
458 /* Clear '-'. */
459 file_mode &= ~new_mode;
460 #if !defined( __MINGW32__) && !defined (__VXWORKS__)
461 if (rwxXstugo[5] || !is_dir)
462 file_mode &= ~S_ISVTX;
463 #endif
464 }
465 else if (set_mode == 3)
466 {
467 file_mode |= new_mode;
468 #if !defined (__MINGW32__) && !defined (__VXWORKS__)
469 if (rwxXstugo[5] && is_dir)
470 file_mode |= S_ISVTX;
471 else if (!is_dir)
472 file_mode &= ~S_ISVTX;
473 #endif
474 }
475 }
476
477 return chmod (file, file_mode);
478 }
479
480
481 extern int chmod_func (char *, char *, gfc_charlen_type, gfc_charlen_type);
482 export_proto(chmod_func);
483
484 int
485 chmod_func (char *name, char *mode, gfc_charlen_type name_len,
486 gfc_charlen_type mode_len)
487 {
488 char *cname = fc_strdup (name, name_len);
489 int ret = chmod_internal (cname, mode, mode_len);
490 free (cname);
491 return ret;
492 }
493
494
495 extern void chmod_i4_sub (char *, char *, GFC_INTEGER_4 *,
496 gfc_charlen_type, gfc_charlen_type);
497 export_proto(chmod_i4_sub);
498
499 void
500 chmod_i4_sub (char *name, char *mode, GFC_INTEGER_4 * status,
501 gfc_charlen_type name_len, gfc_charlen_type mode_len)
502 {
503 int val;
504
505 val = chmod_func (name, mode, name_len, mode_len);
506 if (status)
507 *status = val;
508 }
509
510
511 extern void chmod_i8_sub (char *, char *, GFC_INTEGER_8 *,
512 gfc_charlen_type, gfc_charlen_type);
513 export_proto(chmod_i8_sub);
514
515 void
516 chmod_i8_sub (char *name, char *mode, GFC_INTEGER_8 * status,
517 gfc_charlen_type name_len, gfc_charlen_type mode_len)
518 {
519 int val;
520
521 val = chmod_func (name, mode, name_len, mode_len);
522 if (status)
523 *status = val;
524 }
525
526 #endif