libgfortran/intrinsics/chmod.c

   1 /* Implementation of the CHMOD intrinsic.
   2    Copyright (C) 2006-2018 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   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
 288 clause_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
 478 extern int chmod_func (char *, char *, gfc_charlen_type, gfc_charlen_type);
 479 export_proto(chmod_func);
 480
 481 int
 482 chmod_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
 492 extern void chmod_i4_sub (char *, char *, GFC_INTEGER_4 *,
 493                           gfc_charlen_type, gfc_charlen_type);
 494 export_proto(chmod_i4_sub);
 495
 496 void
 497 chmod_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
 508 extern void chmod_i8_sub (char *, char *, GFC_INTEGER_8 *,
 509                           gfc_charlen_type, gfc_charlen_type);
 510 export_proto(chmod_i8_sub);
 511
 512 void
 513 chmod_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