[thirdparty/gcc.git] / libgfortran / intrinsics / chmod.c

/* Implementation of the CHMOD intrinsic.
   Copyright (C) 2006-2024 Free Software Foundation, Inc.
   Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>

This file is part of the GNU Fortran runtime library (libgfortran).

Libgfortran is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public
License as published by the Free Software Foundation; either
version 3 of the License, or (at your option) any later version.

Libgfortran is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

Under Section 7 of GPL version 3, you are granted additional
permissions described in the GCC Runtime Library Exception, version
3.1, as published by the Free Software Foundation.

You should have received a copy of the GNU General Public License and
a copy of the GCC Runtime Library Exception along with this program;
see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
<http://www.gnu.org/licenses/>.  */

#include "libgfortran.h"

#if defined(HAVE_SYS_STAT_H)

#include <sys/stat.h>	/* For stat, chmod and umask.  */


/* INTEGER FUNCTION CHMOD (NAME, MODE)
   CHARACTER(len=*), INTENT(IN) :: NAME, MODE

   Sets the file permission "chmod" using a mode string.

   For MinGW, only _S_IWRITE and _S_IREAD are supported. To set those,
   only the user attributes are used.

   The mode string allows for the same arguments as POSIX's chmod utility.
   a) string containing an octal number.
   b) Comma separated list of clauses of the form:
      [<who-list>]<op>[<perm-list>|<permcopy>][<op>[<perm-list>|<permcopy>],...]
      <who> - 'u', 'g', 'o', 'a'
      <op>  - '+', '-', '='
      <perm> - 'r', 'w', 'x', 'X', 's', t'
   If <op> is not followed by a perm-list or permcopy, '-' and '+' do not
   change the mode while '=' clears all file mode bits. 'u' stands for the
   user permissions, 'g' for the group and 'o' for the permissions for others.
   'a' is equivalent to 'ugo'. '+' sets the given permission in addition to
   the ones of the file, '-' unsets the given permissions of the file, while
   '=' sets the file to that mode. 'r' sets the read, 'w' the write, and
   'x' the execute mode. 'X' sets the execute bit if the file is a directory
   or if the user, group or other executable bit is set. 't' sets the sticky
   bit, 's' (un)sets the and/or S_ISUID/S_ISGID bit.

   Note that if <who> is omitted, the permissions are filtered by the umask.

   A return value of 0 indicates success, -1 an error of chmod() while 1
   indicates a mode parsing error.  */


static int
chmod_internal (char *file, char *mode, gfc_charlen_type mode_len)
{
  bool ugo[3];
  bool rwxXstugo[9];
  int set_mode, part;
  bool honor_umask, continue_clause = false;
#ifndef __MINGW32__
  bool is_dir;
#endif
#ifdef HAVE_UMASK
  mode_t mode_mask;
#endif
  mode_t file_mode, new_mode;
  struct stat stat_buf;

  if (mode_len == 0)
    return 1;

  if (mode[0] >= '0' && mode[0] <= '9')
    {
      unsigned fmode;
      if (sscanf (mode, "%o", &fmode) != 1)
	return 1;
      return chmod (file, (mode_t) fmode);
    }

  /* Read the current file mode. */
  if (stat (file, &stat_buf))
    return 1;

  file_mode = stat_buf.st_mode & ~S_IFMT;
#ifndef __MINGW32__
  is_dir = stat_buf.st_mode & S_IFDIR;
#endif

#ifdef HAVE_UMASK
  /* Obtain the umask without distroying the setting.  */
  mode_mask = 0;
  mode_mask = umask (mode_mask);
  (void) umask (mode_mask);
#else
  honor_umask = false;
#endif

  for (gfc_charlen_type i = 0; i < mode_len; i++)
    {
      if (!continue_clause)
	{
	  ugo[0] = false;
	  ugo[1] = false;
	  ugo[2] = false;
#ifdef HAVE_UMASK
	  honor_umask = true;
#endif
	}
      continue_clause = false; 
      rwxXstugo[0] = false;
      rwxXstugo[1] = false;
      rwxXstugo[2] = false;
      rwxXstugo[3] = false;
      rwxXstugo[4] = false;
      rwxXstugo[5] = false;
      rwxXstugo[6] = false;
      rwxXstugo[7] = false;
      rwxXstugo[8] = false;
      part = 0;
      set_mode = -1;
      for (; i < mode_len; i++)
	{
	  switch (mode[i])
	    {
	    /* User setting: a[ll]/u[ser]/g[roup]/o[ther].  */
	    case 'a':
	      if (part > 1)
		return 1;
	      ugo[0] = true;
	      ugo[1] = true;
	      ugo[2] = true;
	      part = 1;
#ifdef HAVE_UMASK
	      honor_umask = false;
#endif
	      break;
	    case 'u':
	      if (part == 2)
		{
		  rwxXstugo[6] = true; 
		  part = 4;
		  break; 
		}
	      if (part > 1)
		return 1;
	      ugo[0] = true;
	      part = 1;
#ifdef HAVE_UMASK
	      honor_umask = false;
#endif
	      break;
	    case 'g':
	      if (part == 2)
		{
		  rwxXstugo[7] = true; 
		  part = 4;
		  break; 
		}
	      if (part > 1)
		return 1;
       	      ugo[1] = true;
	      part = 1;
#ifdef HAVE_UMASK
	      honor_umask = false;
#endif
	      break;
	    case 'o':
	      if (part == 2)
		{
		  rwxXstugo[8] = true; 
		  part = 4;
		  break; 
		}
	      if (part > 1)
		return 1;
	      ugo[2] = true;
	      part = 1;
#ifdef HAVE_UMASK
	      honor_umask = false;
#endif
	      break;

	    /* Mode setting: =+-.  */
	    case '=':
	      if (part > 2)
		{
		  continue_clause = true;
		  i--;
		  part = 2;
		  goto clause_done;
		}
	      set_mode = 1;
	      part = 2;
	      break;

	    case '-':
	      if (part > 2)
		{
		  continue_clause = true;
		  i--;
		  part = 2;
		  goto clause_done;
		}
	      set_mode = 2;
	      part = 2;
	      break;

	    case '+':
	      if (part > 2)
		{
		  continue_clause = true;
		  i--;
		  part = 2;
		  goto clause_done;
		}
	      set_mode = 3;
	      part = 2;
	      break;

	    /* Permissions: rwxXst - for ugo see above.  */
	    case 'r':
	      if (part != 2 && part != 3)
		return 1;
	      rwxXstugo[0] = true;
	      part = 3;
	      break;

	    case 'w':
	      if (part != 2 && part != 3)
		return 1;
	      rwxXstugo[1] = true;
	      part = 3;
	      break;

	    case 'x':
	      if (part != 2 && part != 3)
		return 1;
	      rwxXstugo[2] = true;
	      part = 3;
	      break;

	    case 'X':
	      if (part != 2 && part != 3)
		return 1;
	      rwxXstugo[3] = true;
	      part = 3;
	      break;

	    case 's':
	      if (part != 2 && part != 3)
		return 1;
	      rwxXstugo[4] = true;
	      part = 3;
	      break;

	    case 't':
	      if (part != 2 && part != 3)
		return 1;
	      rwxXstugo[5] = true;
	      part = 3;
	      break;

	    /* Trailing blanks are valid in Fortran.  */
	    case ' ':
	      for (i++; i < mode_len; i++)
		if (mode[i] != ' ')
		  break;
	      if (i != mode_len)
		return 1;
	      goto clause_done;

	    case ',':
	      goto clause_done;

	    default:
	      return 1;
	    }
	}

clause_done:
      if (part < 2)
	return 1;

      new_mode = 0;

#ifdef __MINGW32__

      /* Read. */
      if (rwxXstugo[0] && (ugo[0] || honor_umask))
	new_mode |= _S_IREAD;

      /* Write. */
      if (rwxXstugo[1] && (ugo[0] || honor_umask))
	new_mode |= _S_IWRITE;

#else

      /* Read. */
      if (rwxXstugo[0])
	{
	  if (ugo[0] || honor_umask)
	    new_mode |= S_IRUSR;
	  if (ugo[1] || honor_umask)
	    new_mode |= S_IRGRP;
	  if (ugo[2] || honor_umask)
	    new_mode |= S_IROTH;
	}

      /* Write.  */
      if (rwxXstugo[1])
	{
	  if (ugo[0] || honor_umask)
	    new_mode |= S_IWUSR;
	  if (ugo[1] || honor_umask)
	    new_mode |= S_IWGRP;
	  if (ugo[2] || honor_umask)
	    new_mode |= S_IWOTH;
	}

      /* Execute. */
      if (rwxXstugo[2])
	{
	  if (ugo[0] || honor_umask)
	    new_mode |= S_IXUSR;
	  if (ugo[1] || honor_umask)
	    new_mode |= S_IXGRP;
	  if (ugo[2] || honor_umask)
	    new_mode |= S_IXOTH;
	}

      /* 'X' execute.  */
      if (rwxXstugo[3]
	  && (is_dir || (file_mode & (S_IXUSR | S_IXGRP | S_IXOTH))))
	new_mode |= (S_IXUSR | S_IXGRP | S_IXOTH);

      /* 's'.  */
      if (rwxXstugo[4])
	{
	  if (ugo[0] || honor_umask)
	    new_mode |= S_ISUID;
	  if (ugo[1] || honor_umask)
	    new_mode |= S_ISGID;
	}

      /* As original 'u'.  */
      if (rwxXstugo[6])
	{
	  if (ugo[1] || honor_umask)
	    {
	      if (file_mode & S_IRUSR)
		new_mode |= S_IRGRP;
	      if (file_mode & S_IWUSR)
		new_mode |= S_IWGRP;
	      if (file_mode & S_IXUSR)
		new_mode |= S_IXGRP;
	    }
	  if (ugo[2] || honor_umask)
	    {
	      if (file_mode & S_IRUSR)
		new_mode |= S_IROTH;
	      if (file_mode & S_IWUSR)
		new_mode |= S_IWOTH;
	      if (file_mode & S_IXUSR)
		new_mode |= S_IXOTH;
	    }
	}

      /* As original 'g'.  */
      if (rwxXstugo[7])
	{
	  if (ugo[0] || honor_umask)
	    {
	      if (file_mode & S_IRGRP)
		new_mode |= S_IRUSR;
	      if (file_mode & S_IWGRP)
		new_mode |= S_IWUSR;
	      if (file_mode & S_IXGRP)
		new_mode |= S_IXUSR;
	    }
	  if (ugo[2] || honor_umask)
	    {
	      if (file_mode & S_IRGRP)
		new_mode |= S_IROTH;
	      if (file_mode & S_IWGRP)
		new_mode |= S_IWOTH;
	      if (file_mode & S_IXGRP)
		new_mode |= S_IXOTH;
	    }
	}

      /* As original 'o'.  */
      if (rwxXstugo[8])
	{
	  if (ugo[0] || honor_umask)
	    {
	      if (file_mode & S_IROTH)
		new_mode |= S_IRUSR;
	      if (file_mode & S_IWOTH)
		new_mode |= S_IWUSR;
	      if (file_mode & S_IXOTH)
		new_mode |= S_IXUSR;
	    }
	  if (ugo[1] || honor_umask)
	    {
	      if (file_mode & S_IROTH)
		new_mode |= S_IRGRP;
	      if (file_mode & S_IWOTH)
		new_mode |= S_IWGRP;
	      if (file_mode & S_IXOTH)
		new_mode |= S_IXGRP;
	    }
	}
#endif  /* __MINGW32__ */

#ifdef HAVE_UMASK
    if (honor_umask)
      new_mode &= ~mode_mask;
#endif

    if (set_mode == 1)
      {
#ifdef __MINGW32__
	if (ugo[0] || honor_umask)
	  file_mode = (file_mode & ~(_S_IWRITE | _S_IREAD))
		      | (new_mode & (_S_IWRITE | _S_IREAD));
#else
	/* Set '='.  */
	if ((ugo[0] || honor_umask) && !rwxXstugo[6])
	  file_mode = (file_mode & ~(S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR))
		      | (new_mode & (S_ISUID | S_IRUSR | S_IWUSR | S_IXUSR));
	if ((ugo[1] || honor_umask) && !rwxXstugo[7])
	  file_mode = (file_mode & ~(S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP))
		      | (new_mode & (S_ISGID | S_IRGRP | S_IWGRP | S_IXGRP));
	if ((ugo[2] || honor_umask) && !rwxXstugo[8])
	  file_mode = (file_mode & ~(S_IROTH | S_IWOTH | S_IXOTH))
		      | (new_mode & (S_IROTH | S_IWOTH | S_IXOTH));
#ifndef __VXWORKS__
	if (is_dir && rwxXstugo[5])
	  file_mode |= S_ISVTX;
	else if (!is_dir)
	  file_mode &= ~S_ISVTX;
#endif
#endif
      }
    else if (set_mode == 2)
      {
	/* Clear '-'.  */
	file_mode &= ~new_mode;
#if !defined( __MINGW32__) && !defined (__VXWORKS__)
	if (rwxXstugo[5] || !is_dir)
	  file_mode &= ~S_ISVTX;
#endif
      }
    else if (set_mode == 3)
      {
	file_mode |= new_mode;
#if !defined (__MINGW32__) && !defined (__VXWORKS__)
	if (rwxXstugo[5] && is_dir)
	  file_mode |= S_ISVTX;
	else if (!is_dir)
	  file_mode &= ~S_ISVTX;
#endif
      }
  }

  return chmod (file, file_mode);
}


extern int chmod_func (char *, char *, gfc_charlen_type, gfc_charlen_type);
export_proto(chmod_func);

int
chmod_func (char *name, char *mode, gfc_charlen_type name_len,
	    gfc_charlen_type mode_len)
{
  char *cname = fc_strdup (name, name_len);
  int ret = chmod_internal (cname, mode, mode_len);
  free (cname);
  return ret;
}


extern void chmod_i4_sub (char *, char *, GFC_INTEGER_4 *,
			  gfc_charlen_type, gfc_charlen_type);
export_proto(chmod_i4_sub);

void
chmod_i4_sub (char *name, char *mode, GFC_INTEGER_4 * status,
	      gfc_charlen_type name_len, gfc_charlen_type mode_len)
{
  int val;

  val = chmod_func (name, mode, name_len, mode_len);
  if (status)
    *status = val;
}


extern void chmod_i8_sub (char *, char *, GFC_INTEGER_8 *,
			  gfc_charlen_type, gfc_charlen_type);
export_proto(chmod_i8_sub);

void
chmod_i8_sub (char *name, char *mode, GFC_INTEGER_8 * status,
	      gfc_charlen_type name_len, gfc_charlen_type mode_len)
{
  int val;

  val = chmod_func (name, mode, name_len, mode_len);
  if (status)
    *status = val;
}

#endif
Commit	Line	Data
a119fc1c	1	/* Implementation of the CHMOD intrinsic.
a945c346	2	Copyright (C) 2006-2024 Free Software Foundation, Inc.
a119fc1c FXC	3	Contributed by François-Xavier Coudert <coudert@clipper.ens.fr>
a119fc1c FXC	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"
a119fc1c FXC	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
581d2326 JB	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)
9c699331 TB	81	return 1;
a119fc1c	82
9c699331	83	if (mode[0] >= '0' && mode[0] <= '9')
a119fc1c	84	{
7ed26a67 TB	85	unsigned fmode;
7ed26a67 TB	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)
9c699331 TB	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)
9c699331 TB	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