libgfortran/intrinsics/chmod.c

   1 /* Implementation of the CHMOD intrinsic.
   2    Copyright (C) 2006-2024 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
  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 #ifdef HAVE_UMASK
  75   mode_t mode_mask;
  76 #endif
  77   mode_t 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       unsigned fmode;
  86       if (sscanf (mode, "%o", &fmode) != 1)
  87         return 1;
  88       return chmod (file, (mode_t) fmode);
  89     }
  90
  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;
  96 #ifndef __MINGW32__
  97   is_dir = stat_buf.st_mode & S_IFDIR;
  98 #endif
  99
 100 #ifdef HAVE_UMASK
 101   /* Obtain the umask without distroying the setting.  */
 102   mode_mask = 0;
 103   mode_mask = umask (mode_mask);
 104   (void) umask (mode_mask);
 105 #else
 106   honor_umask = false;
 107 #endif
 108
 109   for (gfc_charlen_type i = 0; i < mode_len; i++)
 110     {
 111       if (!continue_clause)
 112         {
 113           ugo[0] = false;
 114           ugo[1] = false;
 115           ugo[2] = false;
 116 #ifdef HAVE_UMASK
 117           honor_umask = true;
 118 #endif
 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;
 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;
 144 #ifdef HAVE_UMASK
 145               honor_umask = false;
 146 #endif
 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;
 159 #ifdef HAVE_UMASK
 160               honor_umask = false;
 161 #endif
 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;
 174 #ifdef HAVE_UMASK
 175               honor_umask = false;
 176 #endif
 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;
 189 #ifdef HAVE_UMASK
 190               honor_umask = false;
 191 #endif
 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
 274             /* Trailing blanks are valid in Fortran.  */
 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
 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
 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         }
 424 #endif  /* __MINGW32__ */
 425
 426 #ifdef HAVE_UMASK
 427     if (honor_umask)
 428       new_mode &= ~mode_mask;
 429 #endif
 430
 431     if (set_mode == 1)
 432       {
 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
 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));
 448 #ifndef __VXWORKS__
 449         if (is_dir && rwxXstugo[5])
 450           file_mode |= S_ISVTX;
 451         else if (!is_dir)
 452           file_mode &= ~S_ISVTX;
 453 #endif
 454 #endif
 455       }
 456     else if (set_mode == 2)
 457       {
 458         /* Clear '-'.  */
 459         file_mode &= ~new_mode;
 460 #if !defined( __MINGW32__) && !defined (__VXWORKS__)
 461         if (rwxXstugo[5] || !is_dir)
 462           file_mode &= ~S_ISVTX;
 463 #endif
 464       }
 465     else if (set_mode == 3)
 466       {
 467         file_mode |= new_mode;
 468 #if !defined (__MINGW32__) && !defined (__VXWORKS__)
 469         if (rwxXstugo[5] && is_dir)
 470           file_mode |= S_ISVTX;
 471         else if (!is_dir)
 472           file_mode &= ~S_ISVTX;
 473 #endif
 474       }
 475   }
 476
 477   return chmod (file, file_mode);
 478 }
 479
 480
 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
 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