1 /* Implementation of the CHMOD intrinsic.
2 Copyright (C) 2006-2020 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
chmod_internal(char * file,char * mode,gfc_charlen_type mode_len)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 mode_t mode_mask, file_mode, new_mode;
75 struct stat stat_buf;
76
77 if (mode_len == 0)
78 return 1;
79
80 if (mode[0] >= '0' && mode[0] <= '9')
81 {
82 unsigned fmode;
83 if (sscanf (mode, "%o", &fmode) != 1)
84 return 1;
85 return chmod (file, (mode_t) fmode);
86 }
87
88 /* Read the current file mode. */
89 if (stat (file, &stat_buf))
90 return 1;
91
92 file_mode = stat_buf.st_mode & ~S_IFMT;
93 #ifndef __MINGW32__
94 is_dir = stat_buf.st_mode & S_IFDIR;
95 #endif
96
97 #ifdef HAVE_UMASK
98 /* Obtain the umask without distroying the setting. */
99 mode_mask = 0;
100 mode_mask = umask (mode_mask);
101 (void) umask (mode_mask);
102 #else
103 honor_umask = false;
104 #endif
105
106 for (gfc_charlen_type i = 0; i < mode_len; i++)
107 {
108 if (!continue_clause)
109 {
110 ugo[0] = false;
111 ugo[1] = false;
112 ugo[2] = false;
113 #ifdef HAVE_UMASK
114 honor_umask = true;
115 #endif
116 }
117 continue_clause = false;
118 rwxXstugo[0] = false;
119 rwxXstugo[1] = false;
120 rwxXstugo[2] = false;
121 rwxXstugo[3] = false;
122 rwxXstugo[4] = false;
123 rwxXstugo[5] = false;
124 rwxXstugo[6] = false;
125 rwxXstugo[7] = false;
126 rwxXstugo[8] = false;
127 part = 0;
128 set_mode = -1;
129 for (; i < mode_len; i++)
130 {
131 switch (mode[i])
132 {
133 /* User setting: a[ll]/u[ser]/g[roup]/o[ther]. */
134 case 'a':
135 if (part > 1)
136 return 1;
137 ugo[0] = true;
138 ugo[1] = true;
139 ugo[2] = true;
140 part = 1;
141 #ifdef HAVE_UMASK
142 honor_umask = false;
143 #endif
144 break;
145 case 'u':
146 if (part == 2)
147 {
148 rwxXstugo[6] = true;
149 part = 4;
150 break;
151 }
152 if (part > 1)
153 return 1;
154 ugo[0] = true;
155 part = 1;
156 #ifdef HAVE_UMASK
157 honor_umask = false;
158 #endif
159 break;
160 case 'g':
161 if (part == 2)
162 {
163 rwxXstugo[7] = true;
164 part = 4;
165 break;
166 }
167 if (part > 1)
168 return 1;
169 ugo[1] = true;
170 part = 1;
171 #ifdef HAVE_UMASK
172 honor_umask = false;
173 #endif
174 break;
175 case 'o':
176 if (part == 2)
177 {
178 rwxXstugo[8] = true;
179 part = 4;
180 break;
181 }
182 if (part > 1)
183 return 1;
184 ugo[2] = true;
185 part = 1;
186 #ifdef HAVE_UMASK
187 honor_umask = false;
188 #endif
189 break;
190
191 /* Mode setting: =+-. */
192 case '=':
193 if (part > 2)
194 {
195 continue_clause = true;
196 i--;
197 part = 2;
198 goto clause_done;
199 }
200 set_mode = 1;
201 part = 2;
202 break;
203
204 case '-':
205 if (part > 2)
206 {
207 continue_clause = true;
208 i--;
209 part = 2;
210 goto clause_done;
211 }
212 set_mode = 2;
213 part = 2;
214 break;
215
216 case '+':
217 if (part > 2)
218 {
219 continue_clause = true;
220 i--;
221 part = 2;
222 goto clause_done;
223 }
224 set_mode = 3;
225 part = 2;
226 break;
227
228 /* Permissions: rwxXst - for ugo see above. */
229 case 'r':
230 if (part != 2 && part != 3)
231 return 1;
232 rwxXstugo[0] = true;
233 part = 3;
234 break;
235
236 case 'w':
237 if (part != 2 && part != 3)
238 return 1;
239 rwxXstugo[1] = true;
240 part = 3;
241 break;
242
243 case 'x':
244 if (part != 2 && part != 3)
245 return 1;
246 rwxXstugo[2] = true;
247 part = 3;
248 break;
249
250 case 'X':
251 if (part != 2 && part != 3)
252 return 1;
253 rwxXstugo[3] = true;
254 part = 3;
255 break;
256
257 case 's':
258 if (part != 2 && part != 3)
259 return 1;
260 rwxXstugo[4] = true;
261 part = 3;
262 break;
263
264 case 't':
265 if (part != 2 && part != 3)
266 return 1;
267 rwxXstugo[5] = true;
268 part = 3;
269 break;
270
271 /* Tailing blanks are valid in Fortran. */
272 case ' ':
273 for (i++; i < mode_len; i++)
274 if (mode[i] != ' ')
275 break;
276 if (i != mode_len)
277 return 1;
278 goto clause_done;
279
280 case ',':
281 goto clause_done;
282
283 default:
284 return 1;
285 }
286 }
287
288 clause_done:
289 if (part < 2)
290 return 1;
291
292 new_mode = 0;
293
294 #ifdef __MINGW32__
295
296 /* Read. */
297 if (rwxXstugo[0] && (ugo[0] || honor_umask))
298 new_mode |= _S_IREAD;
299
300 /* Write. */
301 if (rwxXstugo[1] && (ugo[0] || honor_umask))
302 new_mode |= _S_IWRITE;
303
304 #else
305
306 /* Read. */
307 if (rwxXstugo[0])
308 {
309 if (ugo[0] || honor_umask)
310 new_mode |= S_IRUSR;
311 if (ugo[1] || honor_umask)
312 new_mode |= S_IRGRP;
313 if (ugo[2] || honor_umask)
314 new_mode |= S_IROTH;
315 }
316
317 /* Write. */
318 if (rwxXstugo[1])
319 {
320 if (ugo[0] || honor_umask)
321 new_mode |= S_IWUSR;
322 if (ugo[1] || honor_umask)
323 new_mode |= S_IWGRP;
324 if (ugo[2] || honor_umask)
325 new_mode |= S_IWOTH;
326 }
327
328 /* Execute. */
329 if (rwxXstugo[2])
330 {
331 if (ugo[0] || honor_umask)
332 new_mode |= S_IXUSR;
333 if (ugo[1] || honor_umask)
334 new_mode |= S_IXGRP;
335 if (ugo[2] || honor_umask)
336 new_mode |= S_IXOTH;
337 }
338
339 /* 'X' execute. */
340 if (rwxXstugo[3]
341 && (is_dir || (file_mode & (S_IXUSR | S_IXGRP | S_IXOTH))))
342 new_mode |= (S_IXUSR | S_IXGRP | S_IXOTH);
343
344 /* 's'. */
345 if (rwxXstugo[4])
346 {
347 if (ugo[0] || honor_umask)
348 new_mode |= S_ISUID;
349 if (ugo[1] || honor_umask)
350 new_mode |= S_ISGID;
351 }
352
353 /* As original 'u'. */
354 if (rwxXstugo[6])
355 {
356 if (ugo[1] || honor_umask)
357 {
358 if (file_mode & S_IRUSR)
359 new_mode |= S_IRGRP;
360 if (file_mode & S_IWUSR)
361 new_mode |= S_IWGRP;
362 if (file_mode & S_IXUSR)
363 new_mode |= S_IXGRP;
364 }
365 if (ugo[2] || honor_umask)
366 {
367 if (file_mode & S_IRUSR)
368 new_mode |= S_IROTH;
369 if (file_mode & S_IWUSR)
370 new_mode |= S_IWOTH;
371 if (file_mode & S_IXUSR)
372 new_mode |= S_IXOTH;
373 }
374 }
375
376 /* As original 'g'. */
377 if (rwxXstugo[7])
378 {
379 if (ugo[0] || honor_umask)
380 {
381 if (file_mode & S_IRGRP)
382 new_mode |= S_IRUSR;
383 if (file_mode & S_IWGRP)
384 new_mode |= S_IWUSR;
385 if (file_mode & S_IXGRP)
386 new_mode |= S_IXUSR;
387 }
388 if (ugo[2] || honor_umask)
389 {
390 if (file_mode & S_IRGRP)
391 new_mode |= S_IROTH;
392 if (file_mode & S_IWGRP)
393 new_mode |= S_IWOTH;
394 if (file_mode & S_IXGRP)
395 new_mode |= S_IXOTH;
396 }
397 }
398
399 /* As original 'o'. */
400 if (rwxXstugo[8])
401 {
402 if (ugo[0] || honor_umask)
403 {
404 if (file_mode & S_IROTH)
405 new_mode |= S_IRUSR;
406 if (file_mode & S_IWOTH)
407 new_mode |= S_IWUSR;
408 if (file_mode & S_IXOTH)
409 new_mode |= S_IXUSR;
410 }
411 if (ugo[1] || honor_umask)
412 {
413 if (file_mode & S_IROTH)
414 new_mode |= S_IRGRP;
415 if (file_mode & S_IWOTH)
416 new_mode |= S_IWGRP;
417 if (file_mode & S_IXOTH)
418 new_mode |= S_IXGRP;
419 }
420 }
421 #endif /* __MINGW32__ */
422
423 #ifdef HAVE_UMASK
424 if (honor_umask)
425 new_mode &= ~mode_mask;
426 #endif
427
428 if (set_mode == 1)
429 {
430 #ifdef __MINGW32__
431 if (ugo[0] || honor_umask)
432 file_mode = (file_mode & ~(_S_IWRITE | _S_IREAD))
433 | (new_mode & (_S_IWRITE | _S_IREAD));
434 #else
435 /* Set '='. */
436 if ((ugo[0] || honor_umask) && !rwxXstugo[6])
437 file_mode = (file_mode & ~(S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR))
438 | (new_mode & (S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR));
439 if ((ugo[1] || honor_umask) && !rwxXstugo[7])
440 file_mode = (file_mode & ~(S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP))
441 | (new_mode & (S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP));
442 if ((ugo[2] || honor_umask) && !rwxXstugo[8])
443 file_mode = (file_mode & ~(S_IROTH | S_IWOTH | S_IXOTH))
444 | (new_mode & (S_IROTH | S_IWOTH | S_IXOTH));
445 #ifndef __VXWORKS__
446 if (is_dir && rwxXstugo[5])
447 file_mode |= S_ISVTX;
448 else if (!is_dir)
449 file_mode &= ~S_ISVTX;
450 #endif
451 #endif
452 }
453 else if (set_mode == 2)
454 {
455 /* Clear '-'. */
456 file_mode &= ~new_mode;
457 #if !defined( __MINGW32__) && !defined (__VXWORKS__)
458 if (rwxXstugo[5] || !is_dir)
459 file_mode &= ~S_ISVTX;
460 #endif
461 }
462 else if (set_mode == 3)
463 {
464 file_mode |= new_mode;
465 #if !defined (__MINGW32__) && !defined (__VXWORKS__)
466 if (rwxXstugo[5] && is_dir)
467 file_mode |= S_ISVTX;
468 else if (!is_dir)
469 file_mode &= ~S_ISVTX;
470 #endif
471 }
472 }
473
474 return chmod (file, file_mode);
475 }
476
477
478 extern int chmod_func (char *, char *, gfc_charlen_type, gfc_charlen_type);
479 export_proto(chmod_func);
480
481 int
chmod_func(char * name,char * mode,gfc_charlen_type name_len,gfc_charlen_type mode_len)482 chmod_func (char *name, char *mode, gfc_charlen_type name_len,
483 gfc_charlen_type mode_len)
484 {
485 char *cname = fc_strdup (name, name_len);
486 int ret = chmod_internal (cname, mode, mode_len);
487 free (cname);
488 return ret;
489 }
490
491
492 extern void chmod_i4_sub (char *, char *, GFC_INTEGER_4 *,
493 gfc_charlen_type, gfc_charlen_type);
494 export_proto(chmod_i4_sub);
495
496 void
chmod_i4_sub(char * name,char * mode,GFC_INTEGER_4 * status,gfc_charlen_type name_len,gfc_charlen_type mode_len)497 chmod_i4_sub (char *name, char *mode, GFC_INTEGER_4 * status,
498 gfc_charlen_type name_len, gfc_charlen_type mode_len)
499 {
500 int val;
501
502 val = chmod_func (name, mode, name_len, mode_len);
503 if (status)
504 *status = val;
505 }
506
507
508 extern void chmod_i8_sub (char *, char *, GFC_INTEGER_8 *,
509 gfc_charlen_type, gfc_charlen_type);
510 export_proto(chmod_i8_sub);
511
512 void
chmod_i8_sub(char * name,char * mode,GFC_INTEGER_8 * status,gfc_charlen_type name_len,gfc_charlen_type mode_len)513 chmod_i8_sub (char *name, char *mode, GFC_INTEGER_8 * status,
514 gfc_charlen_type name_len, gfc_charlen_type mode_len)
515 {
516 int val;
517
518 val = chmod_func (name, mode, name_len, mode_len);
519 if (status)
520 *status = val;
521 }
522
523 #endif
524