1/* Implementation of the CHMOD intrinsic. 2 Copyright (C) 2006-2020 Free Software Foundation, Inc. 3 Contributed by Fran��ois-Xavier Coudert <coudert@clipper.ens.fr> 4 5This file is part of the GNU Fortran runtime library (libgfortran). 6 7Libgfortran is free software; you can redistribute it and/or 8modify it under the terms of the GNU General Public 9License as published by the Free Software Foundation; either 10version 3 of the License, or (at your option) any later version. 11 12Libgfortran is distributed in the hope that it will be useful, 13but WITHOUT ANY WARRANTY; without even the implied warranty of 14MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 15GNU General Public License for more details. 16 17Under Section 7 of GPL version 3, you are granted additional 18permissions described in the GCC Runtime Library Exception, version 193.1, as published by the Free Software Foundation. 20 21You should have received a copy of the GNU General Public License and 22a copy of the GCC Runtime Library Exception along with this program; 23see 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 64static int 65chmod_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 288clause_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 478extern int chmod_func (char *, char *, gfc_charlen_type, gfc_charlen_type); 479export_proto(chmod_func); 480 481int 482chmod_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 492extern void chmod_i4_sub (char *, char *, GFC_INTEGER_4 *, 493 gfc_charlen_type, gfc_charlen_type); 494export_proto(chmod_i4_sub); 495 496void 497chmod_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 508extern void chmod_i8_sub (char *, char *, GFC_INTEGER_8 *, 509 gfc_charlen_type, gfc_charlen_type); 510export_proto(chmod_i8_sub); 511 512void 513chmod_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