libgfortran/intrinsics/chmod.c

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