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
5This file is part of the GNU Fortran runtime library (libgfortran).
6
7Libgfortran is free software; you can redistribute it and/or
8modify it under the terms of the GNU General Public
9License as published by the Free Software Foundation; either
10version 3 of the License, or (at your option) any later version.
11
12Libgfortran is distributed in the hope that it will be useful,
13but WITHOUT ANY WARRANTY; without even the implied warranty of
14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
15GNU General Public License for more details.
16
17Under Section 7 of GPL version 3, you are granted additional
18permissions described in the GCC Runtime Library Exception, version
193.1, as published by the Free Software Foundation.
20
21You should have received a copy of the GNU General Public License and
22a copy of the GCC Runtime Library Exception along with this program;
23see 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
64static int
65chmod_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
288clause_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
478extern int chmod_func (char *, char *, gfc_charlen_type, gfc_charlen_type);
479export_proto(chmod_func);
480
481int
482chmod_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
492extern void chmod_i4_sub (char *, char *, GFC_INTEGER_4 *,
493			  gfc_charlen_type, gfc_charlen_type);
494export_proto(chmod_i4_sub);
495
496void
497chmod_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
508extern void chmod_i8_sub (char *, char *, GFC_INTEGER_8 *,
509			  gfc_charlen_type, gfc_charlen_type);
510export_proto(chmod_i8_sub);
511
512void
513chmod_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