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>
5 This file is part of the GNU Fortran runtime library (libgfortran).
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.
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.
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.
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/>. */
26 #include "libgfortran.h"
28 #if defined(HAVE_SYS_STAT_H)
30 #include <sys/stat.h> /* For stat, chmod and umask. */
33 /* INTEGER FUNCTION CHMOD (NAME, MODE)
34 CHARACTER(len=*), INTENT(IN) :: NAME, MODE
36 Sets the file permission "chmod" using a mode string.
38 For MinGW, only _S_IWRITE and _S_IREAD are supported. To set those,
39 only the user attributes are used.
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'
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.
58 Note that if <who> is omitted, the permissions are filtered by the umask.
60 A return value of 0 indicates success, -1 an error of chmod() while 1
61 indicates a mode parsing error. */
65 chmod_internal (char *file
, char *mode
, gfc_charlen_type mode_len
)
70 bool honor_umask
, continue_clause
= false;
77 mode_t file_mode
, new_mode
;
83 if (mode
[0] >= '0' && mode
[0] <= '9')
86 if (sscanf (mode
, "%o", &fmode
) != 1)
88 return chmod (file
, (mode_t
) fmode
);
91 /* Read the current file mode. */
92 if (stat (file
, &stat_buf
))
95 file_mode
= stat_buf
.st_mode
& ~S_IFMT
;
97 is_dir
= stat_buf
.st_mode
& S_IFDIR
;
101 /* Obtain the umask without distroying the setting. */
103 mode_mask
= umask (mode_mask
);
104 (void) umask (mode_mask
);
109 for (gfc_charlen_type i
= 0; i
< mode_len
; i
++)
111 if (!continue_clause
)
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;
132 for (; i
< mode_len
; i
++)
136 /* User setting: a[ll]/u[ser]/g[roup]/o[ther]. */
194 /* Mode setting: =+-. */
198 continue_clause
= true;
210 continue_clause
= true;
222 continue_clause
= true;
231 /* Permissions: rwxXst - for ugo see above. */
233 if (part
!= 2 && part
!= 3)
240 if (part
!= 2 && part
!= 3)
247 if (part
!= 2 && part
!= 3)
254 if (part
!= 2 && part
!= 3)
261 if (part
!= 2 && part
!= 3)
268 if (part
!= 2 && part
!= 3)
274 /* Trailing blanks are valid in Fortran. */
276 for (i
++; i
< mode_len
; i
++)
300 if (rwxXstugo
[0] && (ugo
[0] || honor_umask
))
301 new_mode
|= _S_IREAD
;
304 if (rwxXstugo
[1] && (ugo
[0] || honor_umask
))
305 new_mode
|= _S_IWRITE
;
312 if (ugo
[0] || honor_umask
)
314 if (ugo
[1] || honor_umask
)
316 if (ugo
[2] || honor_umask
)
323 if (ugo
[0] || honor_umask
)
325 if (ugo
[1] || honor_umask
)
327 if (ugo
[2] || honor_umask
)
334 if (ugo
[0] || honor_umask
)
336 if (ugo
[1] || honor_umask
)
338 if (ugo
[2] || honor_umask
)
344 && (is_dir
|| (file_mode
& (S_IXUSR
| S_IXGRP
| S_IXOTH
))))
345 new_mode
|= (S_IXUSR
| S_IXGRP
| S_IXOTH
);
350 if (ugo
[0] || honor_umask
)
352 if (ugo
[1] || honor_umask
)
356 /* As original 'u'. */
359 if (ugo
[1] || honor_umask
)
361 if (file_mode
& S_IRUSR
)
363 if (file_mode
& S_IWUSR
)
365 if (file_mode
& S_IXUSR
)
368 if (ugo
[2] || honor_umask
)
370 if (file_mode
& S_IRUSR
)
372 if (file_mode
& S_IWUSR
)
374 if (file_mode
& S_IXUSR
)
379 /* As original 'g'. */
382 if (ugo
[0] || honor_umask
)
384 if (file_mode
& S_IRGRP
)
386 if (file_mode
& S_IWGRP
)
388 if (file_mode
& S_IXGRP
)
391 if (ugo
[2] || honor_umask
)
393 if (file_mode
& S_IRGRP
)
395 if (file_mode
& S_IWGRP
)
397 if (file_mode
& S_IXGRP
)
402 /* As original 'o'. */
405 if (ugo
[0] || honor_umask
)
407 if (file_mode
& S_IROTH
)
409 if (file_mode
& S_IWOTH
)
411 if (file_mode
& S_IXOTH
)
414 if (ugo
[1] || honor_umask
)
416 if (file_mode
& S_IROTH
)
418 if (file_mode
& S_IWOTH
)
420 if (file_mode
& S_IXOTH
)
424 #endif /* __MINGW32__ */
428 new_mode
&= ~mode_mask
;
434 if (ugo
[0] || honor_umask
)
435 file_mode
= (file_mode
& ~(_S_IWRITE
| _S_IREAD
))
436 | (new_mode
& (_S_IWRITE
| _S_IREAD
));
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
));
449 if (is_dir
&& rwxXstugo
[5])
450 file_mode
|= S_ISVTX
;
452 file_mode
&= ~S_ISVTX
;
456 else if (set_mode
== 2)
459 file_mode
&= ~new_mode
;
460 #if !defined( __MINGW32__) && !defined (__VXWORKS__)
461 if (rwxXstugo
[5] || !is_dir
)
462 file_mode
&= ~S_ISVTX
;
465 else if (set_mode
== 3)
467 file_mode
|= new_mode
;
468 #if !defined (__MINGW32__) && !defined (__VXWORKS__)
469 if (rwxXstugo
[5] && is_dir
)
470 file_mode
|= S_ISVTX
;
472 file_mode
&= ~S_ISVTX
;
477 return chmod (file
, file_mode
);
481 extern int chmod_func (char *, char *, gfc_charlen_type
, gfc_charlen_type
);
482 export_proto(chmod_func
);
485 chmod_func (char *name
, char *mode
, gfc_charlen_type name_len
,
486 gfc_charlen_type mode_len
)
488 char *cname
= fc_strdup (name
, name_len
);
489 int ret
= chmod_internal (cname
, mode
, mode_len
);
495 extern void chmod_i4_sub (char *, char *, GFC_INTEGER_4
*,
496 gfc_charlen_type
, gfc_charlen_type
);
497 export_proto(chmod_i4_sub
);
500 chmod_i4_sub (char *name
, char *mode
, GFC_INTEGER_4
* status
,
501 gfc_charlen_type name_len
, gfc_charlen_type mode_len
)
505 val
= chmod_func (name
, mode
, name_len
, mode_len
);
511 extern void chmod_i8_sub (char *, char *, GFC_INTEGER_8
*,
512 gfc_charlen_type
, gfc_charlen_type
);
513 export_proto(chmod_i8_sub
);
516 chmod_i8_sub (char *name
, char *mode
, GFC_INTEGER_8
* status
,
517 gfc_charlen_type name_len
, gfc_charlen_type mode_len
)
521 val
= chmod_func (name
, mode
, name_len
, mode_len
);