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