1 /* Implementation of the CHMOD intrinsic. 2 Copyright (C) 2006-2019 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 524