]>
Commit | Line | Data |
---|---|---|
a119fc1c | 1 | /* Implementation of the CHMOD intrinsic. |
83ffe9cd | 2 | Copyright (C) 2006-2023 Free Software Foundation, Inc. |
a119fc1c FXC |
3 | Contributed by François-Xavier Coudert <coudert@clipper.ens.fr> |
4 | ||
9c699331 | 5 | This file is part of the GNU Fortran runtime library (libgfortran). |
a119fc1c FXC |
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 | |
748086b7 | 10 | version 3 of the License, or (at your option) any later version. |
a119fc1c FXC |
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 | ||
748086b7 JJ |
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/>. */ | |
a119fc1c | 25 | |
a119fc1c FXC |
26 | #include "libgfortran.h" |
27 | ||
9c699331 | 28 | #if defined(HAVE_SYS_STAT_H) |
36ae8a61 | 29 | |
9c699331 TB |
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. | |
a119fc1c | 37 | |
8ecd1c0d TB |
38 | For MinGW, only _S_IWRITE and _S_IREAD are supported. To set those, |
39 | only the user attributes are used. | |
40 | ||
9c699331 TB |
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. | |
a119fc1c | 57 | |
9c699331 TB |
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. */ | |
a119fc1c | 62 | |
a119fc1c | 63 | |
581d2326 JB |
64 | static int |
65 | chmod_internal (char *file, char *mode, gfc_charlen_type mode_len) | |
a119fc1c | 66 | { |
9c699331 TB |
67 | bool ugo[3]; |
68 | bool rwxXstugo[9]; | |
69 | int set_mode, part; | |
7ed26a67 TB |
70 | bool honor_umask, continue_clause = false; |
71 | #ifndef __MINGW32__ | |
72 | bool is_dir; | |
73 | #endif | |
dee371fd TB |
74 | #ifdef HAVE_UMASK |
75 | mode_t mode_mask; | |
76 | #endif | |
77 | mode_t file_mode, new_mode; | |
9c699331 | 78 | struct stat stat_buf; |
a119fc1c | 79 | |
9c699331 TB |
80 | if (mode_len == 0) |
81 | return 1; | |
a119fc1c | 82 | |
9c699331 | 83 | if (mode[0] >= '0' && mode[0] <= '9') |
a119fc1c | 84 | { |
7ed26a67 TB |
85 | unsigned fmode; |
86 | if (sscanf (mode, "%o", &fmode) != 1) | |
8ecd1c0d | 87 | return 1; |
dc31c238 | 88 | return chmod (file, (mode_t) fmode); |
a119fc1c | 89 | } |
a119fc1c | 90 | |
9c699331 TB |
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; | |
7ed26a67 | 96 | #ifndef __MINGW32__ |
9c699331 | 97 | is_dir = stat_buf.st_mode & S_IFDIR; |
7ed26a67 | 98 | #endif |
9c699331 | 99 | |
8ecd1c0d | 100 | #ifdef HAVE_UMASK |
9c699331 TB |
101 | /* Obtain the umask without distroying the setting. */ |
102 | mode_mask = 0; | |
103 | mode_mask = umask (mode_mask); | |
104 | (void) umask (mode_mask); | |
8ecd1c0d TB |
105 | #else |
106 | honor_umask = false; | |
107 | #endif | |
9c699331 | 108 | |
f622221a | 109 | for (gfc_charlen_type i = 0; i < mode_len; i++) |
9c699331 TB |
110 | { |
111 | if (!continue_clause) | |
112 | { | |
113 | ugo[0] = false; | |
114 | ugo[1] = false; | |
115 | ugo[2] = false; | |
8ecd1c0d | 116 | #ifdef HAVE_UMASK |
9c699331 | 117 | honor_umask = true; |
8ecd1c0d | 118 | #endif |
9c699331 TB |
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; | |
9c699331 TB |
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; | |
8ecd1c0d | 144 | #ifdef HAVE_UMASK |
9c699331 | 145 | honor_umask = false; |
8ecd1c0d | 146 | #endif |
9c699331 TB |
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; | |
8ecd1c0d | 159 | #ifdef HAVE_UMASK |
9c699331 | 160 | honor_umask = false; |
8ecd1c0d | 161 | #endif |
9c699331 TB |
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; | |
8ecd1c0d | 174 | #ifdef HAVE_UMASK |
9c699331 | 175 | honor_umask = false; |
8ecd1c0d | 176 | #endif |
9c699331 TB |
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; | |
8ecd1c0d | 189 | #ifdef HAVE_UMASK |
9c699331 | 190 | honor_umask = false; |
8ecd1c0d | 191 | #endif |
9c699331 TB |
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 | ||
48aa5c60 | 274 | /* Trailing blanks are valid in Fortran. */ |
9c699331 TB |
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 | ||
8ecd1c0d TB |
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 | ||
9c699331 TB |
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 | } | |
8ecd1c0d | 424 | #endif /* __MINGW32__ */ |
9c699331 | 425 | |
8ecd1c0d | 426 | #ifdef HAVE_UMASK |
9c699331 TB |
427 | if (honor_umask) |
428 | new_mode &= ~mode_mask; | |
8ecd1c0d | 429 | #endif |
9c699331 TB |
430 | |
431 | if (set_mode == 1) | |
432 | { | |
8ecd1c0d TB |
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 | |
9c699331 TB |
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)); | |
b8ce6b9c | 448 | #ifndef __VXWORKS__ |
9c699331 TB |
449 | if (is_dir && rwxXstugo[5]) |
450 | file_mode |= S_ISVTX; | |
451 | else if (!is_dir) | |
452 | file_mode &= ~S_ISVTX; | |
b8ce6b9c | 453 | #endif |
8ecd1c0d | 454 | #endif |
9c699331 TB |
455 | } |
456 | else if (set_mode == 2) | |
457 | { | |
458 | /* Clear '-'. */ | |
459 | file_mode &= ~new_mode; | |
b8ce6b9c | 460 | #if !defined( __MINGW32__) && !defined (__VXWORKS__) |
9c699331 TB |
461 | if (rwxXstugo[5] || !is_dir) |
462 | file_mode &= ~S_ISVTX; | |
8ecd1c0d | 463 | #endif |
9c699331 TB |
464 | } |
465 | else if (set_mode == 3) | |
466 | { | |
467 | file_mode |= new_mode; | |
b8ce6b9c | 468 | #if !defined (__MINGW32__) && !defined (__VXWORKS__) |
9c699331 TB |
469 | if (rwxXstugo[5] && is_dir) |
470 | file_mode |= S_ISVTX; | |
471 | else if (!is_dir) | |
472 | file_mode &= ~S_ISVTX; | |
8ecd1c0d | 473 | #endif |
9c699331 TB |
474 | } |
475 | } | |
476 | ||
477 | return chmod (file, file_mode); | |
a119fc1c FXC |
478 | } |
479 | ||
480 | ||
581d2326 JB |
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 | ||
a119fc1c FXC |
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 |