1 /* Implementation of the STAT and FSTAT intrinsics. 2 Copyright (C) 2004-2020 Free Software Foundation, Inc. 3 Contributed by Steven G. Kargl <kargls@comcast.net>. 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 #include <errno.h> 29 30 #ifdef HAVE_SYS_STAT_H 31 #include <sys/stat.h> 32 #endif 33 34 35 36 #ifdef HAVE_STAT 37 38 /* SUBROUTINE STAT(FILE, SARRAY, STATUS) 39 CHARACTER(len=*), INTENT(IN) :: FILE 40 INTEGER, INTENT(OUT), :: SARRAY(13) 41 INTEGER, INTENT(OUT), OPTIONAL :: STATUS 42 43 FUNCTION STAT(FILE, SARRAY) 44 INTEGER STAT 45 CHARACTER(len=*), INTENT(IN) :: FILE 46 INTEGER, INTENT(OUT), :: SARRAY(13) */ 47 48 /*extern void stat_i4_sub_0 (char *, gfc_array_i4 *, GFC_INTEGER_4 *, 49 gfc_charlen_type, int); 50 internal_proto(stat_i4_sub_0);*/ 51 52 static void 53 stat_i4_sub_0 (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status, 54 gfc_charlen_type name_len, int is_lstat __attribute__ ((unused))) 55 { 56 int val; 57 char *str; 58 struct stat sb; 59 60 /* If the rank of the array is not 1, abort. */ 61 if (GFC_DESCRIPTOR_RANK (sarray) != 1) 62 runtime_error ("Array rank of SARRAY is not 1."); 63 64 /* If the array is too small, abort. */ 65 if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13) 66 runtime_error ("Array size of SARRAY is too small."); 67 68 /* Make a null terminated copy of the string. */ 69 str = fc_strdup (name, name_len); 70 71 /* On platforms that don't provide lstat(), we use stat() instead. */ 72 #ifdef HAVE_LSTAT 73 if (is_lstat) 74 val = lstat(str, &sb); 75 else 76 #endif 77 val = stat(str, &sb); 78 79 free (str); 80 81 if (val == 0) 82 { 83 index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0); 84 85 /* Device ID */ 86 sarray->base_addr[0 * stride] = sb.st_dev; 87 88 /* Inode number */ 89 sarray->base_addr[1 * stride] = sb.st_ino; 90 91 /* File mode */ 92 sarray->base_addr[2 * stride] = sb.st_mode; 93 94 /* Number of (hard) links */ 95 sarray->base_addr[3 * stride] = sb.st_nlink; 96 97 /* Owner's uid */ 98 sarray->base_addr[4 * stride] = sb.st_uid; 99 100 /* Owner's gid */ 101 sarray->base_addr[5 * stride] = sb.st_gid; 102 103 /* ID of device containing directory entry for file (0 if not available) */ 104 #if HAVE_STRUCT_STAT_ST_RDEV 105 sarray->base_addr[6 * stride] = sb.st_rdev; 106 #else 107 sarray->base_addr[6 * stride] = 0; 108 #endif 109 110 /* File size (bytes) */ 111 sarray->base_addr[7 * stride] = sb.st_size; 112 113 /* Last access time */ 114 sarray->base_addr[8 * stride] = sb.st_atime; 115 116 /* Last modification time */ 117 sarray->base_addr[9 * stride] = sb.st_mtime; 118 119 /* Last file status change time */ 120 sarray->base_addr[10 * stride] = sb.st_ctime; 121 122 /* Preferred I/O block size (-1 if not available) */ 123 #if HAVE_STRUCT_STAT_ST_BLKSIZE 124 sarray->base_addr[11 * stride] = sb.st_blksize; 125 #else 126 sarray->base_addr[11 * stride] = -1; 127 #endif 128 129 /* Number of blocks allocated (-1 if not available) */ 130 #if HAVE_STRUCT_STAT_ST_BLOCKS 131 sarray->base_addr[12 * stride] = sb.st_blocks; 132 #else 133 sarray->base_addr[12 * stride] = -1; 134 #endif 135 } 136 137 if (status != NULL) 138 *status = (val == 0) ? 0 : errno; 139 } 140 141 142 extern void stat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *, 143 gfc_charlen_type); 144 iexport_proto(stat_i4_sub); 145 146 void 147 stat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status, 148 gfc_charlen_type name_len) 149 { 150 stat_i4_sub_0 (name, sarray, status, name_len, 0); 151 } 152 iexport(stat_i4_sub); 153 154 155 extern void lstat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *, 156 gfc_charlen_type); 157 iexport_proto(lstat_i4_sub); 158 159 void 160 lstat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status, 161 gfc_charlen_type name_len) 162 { 163 stat_i4_sub_0 (name, sarray, status, name_len, 1); 164 } 165 iexport(lstat_i4_sub); 166 167 168 169 static void 170 stat_i8_sub_0 (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status, 171 gfc_charlen_type name_len, int is_lstat __attribute__ ((unused))) 172 { 173 int val; 174 char *str; 175 struct stat sb; 176 177 /* If the rank of the array is not 1, abort. */ 178 if (GFC_DESCRIPTOR_RANK (sarray) != 1) 179 runtime_error ("Array rank of SARRAY is not 1."); 180 181 /* If the array is too small, abort. */ 182 if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13) 183 runtime_error ("Array size of SARRAY is too small."); 184 185 /* Make a null terminated copy of the string. */ 186 str = fc_strdup (name, name_len); 187 188 /* On platforms that don't provide lstat(), we use stat() instead. */ 189 #ifdef HAVE_LSTAT 190 if (is_lstat) 191 val = lstat(str, &sb); 192 else 193 #endif 194 val = stat(str, &sb); 195 196 free (str); 197 198 if (val == 0) 199 { 200 index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0); 201 202 /* Device ID */ 203 sarray->base_addr[0] = sb.st_dev; 204 205 /* Inode number */ 206 sarray->base_addr[stride] = sb.st_ino; 207 208 /* File mode */ 209 sarray->base_addr[2 * stride] = sb.st_mode; 210 211 /* Number of (hard) links */ 212 sarray->base_addr[3 * stride] = sb.st_nlink; 213 214 /* Owner's uid */ 215 sarray->base_addr[4 * stride] = sb.st_uid; 216 217 /* Owner's gid */ 218 sarray->base_addr[5 * stride] = sb.st_gid; 219 220 /* ID of device containing directory entry for file (0 if not available) */ 221 #if HAVE_STRUCT_STAT_ST_RDEV 222 sarray->base_addr[6 * stride] = sb.st_rdev; 223 #else 224 sarray->base_addr[6 * stride] = 0; 225 #endif 226 227 /* File size (bytes) */ 228 sarray->base_addr[7 * stride] = sb.st_size; 229 230 /* Last access time */ 231 sarray->base_addr[8 * stride] = sb.st_atime; 232 233 /* Last modification time */ 234 sarray->base_addr[9 * stride] = sb.st_mtime; 235 236 /* Last file status change time */ 237 sarray->base_addr[10 * stride] = sb.st_ctime; 238 239 /* Preferred I/O block size (-1 if not available) */ 240 #if HAVE_STRUCT_STAT_ST_BLKSIZE 241 sarray->base_addr[11 * stride] = sb.st_blksize; 242 #else 243 sarray->base_addr[11 * stride] = -1; 244 #endif 245 246 /* Number of blocks allocated (-1 if not available) */ 247 #if HAVE_STRUCT_STAT_ST_BLOCKS 248 sarray->base_addr[12 * stride] = sb.st_blocks; 249 #else 250 sarray->base_addr[12 * stride] = -1; 251 #endif 252 } 253 254 if (status != NULL) 255 *status = (val == 0) ? 0 : errno; 256 } 257 258 259 extern void stat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *, 260 gfc_charlen_type); 261 iexport_proto(stat_i8_sub); 262 263 void 264 stat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status, 265 gfc_charlen_type name_len) 266 { 267 stat_i8_sub_0 (name, sarray, status, name_len, 0); 268 } 269 270 iexport(stat_i8_sub); 271 272 273 extern void lstat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *, 274 gfc_charlen_type); 275 iexport_proto(lstat_i8_sub); 276 277 void 278 lstat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status, 279 gfc_charlen_type name_len) 280 { 281 stat_i8_sub_0 (name, sarray, status, name_len, 1); 282 } 283 284 iexport(lstat_i8_sub); 285 286 287 extern GFC_INTEGER_4 stat_i4 (char *, gfc_array_i4 *, gfc_charlen_type); 288 export_proto(stat_i4); 289 290 GFC_INTEGER_4 291 stat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len) 292 { 293 GFC_INTEGER_4 val; 294 stat_i4_sub (name, sarray, &val, name_len); 295 return val; 296 } 297 298 extern GFC_INTEGER_8 stat_i8 (char *, gfc_array_i8 *, gfc_charlen_type); 299 export_proto(stat_i8); 300 301 GFC_INTEGER_8 302 stat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len) 303 { 304 GFC_INTEGER_8 val; 305 stat_i8_sub (name, sarray, &val, name_len); 306 return val; 307 } 308 309 310 /* SUBROUTINE LSTAT(FILE, SARRAY, STATUS) 311 CHARACTER(len=*), INTENT(IN) :: FILE 312 INTEGER, INTENT(OUT), :: SARRAY(13) 313 INTEGER, INTENT(OUT), OPTIONAL :: STATUS 314 315 FUNCTION LSTAT(FILE, SARRAY) 316 INTEGER LSTAT 317 CHARACTER(len=*), INTENT(IN) :: FILE 318 INTEGER, INTENT(OUT), :: SARRAY(13) */ 319 320 extern GFC_INTEGER_4 lstat_i4 (char *, gfc_array_i4 *, gfc_charlen_type); 321 export_proto(lstat_i4); 322 323 GFC_INTEGER_4 324 lstat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len) 325 { 326 GFC_INTEGER_4 val; 327 lstat_i4_sub (name, sarray, &val, name_len); 328 return val; 329 } 330 331 extern GFC_INTEGER_8 lstat_i8 (char *, gfc_array_i8 *, gfc_charlen_type); 332 export_proto(lstat_i8); 333 334 GFC_INTEGER_8 335 lstat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len) 336 { 337 GFC_INTEGER_8 val; 338 lstat_i8_sub (name, sarray, &val, name_len); 339 return val; 340 } 341 342 #endif 343 344 345 #ifdef HAVE_FSTAT 346 347 /* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS) 348 INTEGER, INTENT(IN) :: UNIT 349 INTEGER, INTENT(OUT) :: SARRAY(13) 350 INTEGER, INTENT(OUT), OPTIONAL :: STATUS 351 352 FUNCTION FSTAT(UNIT, SARRAY) 353 INTEGER FSTAT 354 INTEGER, INTENT(IN) :: UNIT 355 INTEGER, INTENT(OUT) :: SARRAY(13) */ 356 357 extern void fstat_i4_sub (GFC_INTEGER_4 *, gfc_array_i4 *, GFC_INTEGER_4 *); 358 iexport_proto(fstat_i4_sub); 359 360 void 361 fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray, GFC_INTEGER_4 *status) 362 { 363 int val; 364 struct stat sb; 365 366 /* If the rank of the array is not 1, abort. */ 367 if (GFC_DESCRIPTOR_RANK (sarray) != 1) 368 runtime_error ("Array rank of SARRAY is not 1."); 369 370 /* If the array is too small, abort. */ 371 if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13) 372 runtime_error ("Array size of SARRAY is too small."); 373 374 /* Convert Fortran unit number to C file descriptor. */ 375 val = unit_to_fd (*unit); 376 if (val >= 0) 377 val = fstat(val, &sb); 378 379 if (val == 0) 380 { 381 index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0); 382 383 /* Device ID */ 384 sarray->base_addr[0 * stride] = sb.st_dev; 385 386 /* Inode number */ 387 sarray->base_addr[1 * stride] = sb.st_ino; 388 389 /* File mode */ 390 sarray->base_addr[2 * stride] = sb.st_mode; 391 392 /* Number of (hard) links */ 393 sarray->base_addr[3 * stride] = sb.st_nlink; 394 395 /* Owner's uid */ 396 sarray->base_addr[4 * stride] = sb.st_uid; 397 398 /* Owner's gid */ 399 sarray->base_addr[5 * stride] = sb.st_gid; 400 401 /* ID of device containing directory entry for file (0 if not available) */ 402 #if HAVE_STRUCT_STAT_ST_RDEV 403 sarray->base_addr[6 * stride] = sb.st_rdev; 404 #else 405 sarray->base_addr[6 * stride] = 0; 406 #endif 407 408 /* File size (bytes) */ 409 sarray->base_addr[7 * stride] = sb.st_size; 410 411 /* Last access time */ 412 sarray->base_addr[8 * stride] = sb.st_atime; 413 414 /* Last modification time */ 415 sarray->base_addr[9 * stride] = sb.st_mtime; 416 417 /* Last file status change time */ 418 sarray->base_addr[10 * stride] = sb.st_ctime; 419 420 /* Preferred I/O block size (-1 if not available) */ 421 #if HAVE_STRUCT_STAT_ST_BLKSIZE 422 sarray->base_addr[11 * stride] = sb.st_blksize; 423 #else 424 sarray->base_addr[11 * stride] = -1; 425 #endif 426 427 /* Number of blocks allocated (-1 if not available) */ 428 #if HAVE_STRUCT_STAT_ST_BLOCKS 429 sarray->base_addr[12 * stride] = sb.st_blocks; 430 #else 431 sarray->base_addr[12 * stride] = -1; 432 #endif 433 } 434 435 if (status != NULL) 436 *status = (val == 0) ? 0 : errno; 437 } 438 iexport(fstat_i4_sub); 439 440 extern void fstat_i8_sub (GFC_INTEGER_8 *, gfc_array_i8 *, GFC_INTEGER_8 *); 441 iexport_proto(fstat_i8_sub); 442 443 void 444 fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *status) 445 { 446 int val; 447 struct stat sb; 448 449 /* If the rank of the array is not 1, abort. */ 450 if (GFC_DESCRIPTOR_RANK (sarray) != 1) 451 runtime_error ("Array rank of SARRAY is not 1."); 452 453 /* If the array is too small, abort. */ 454 if (GFC_DESCRIPTOR_EXTENT(sarray,0) < 13) 455 runtime_error ("Array size of SARRAY is too small."); 456 457 /* Convert Fortran unit number to C file descriptor. */ 458 val = unit_to_fd ((int) *unit); 459 if (val >= 0) 460 val = fstat(val, &sb); 461 462 if (val == 0) 463 { 464 index_type stride = GFC_DESCRIPTOR_STRIDE(sarray,0); 465 466 /* Device ID */ 467 sarray->base_addr[0] = sb.st_dev; 468 469 /* Inode number */ 470 sarray->base_addr[stride] = sb.st_ino; 471 472 /* File mode */ 473 sarray->base_addr[2 * stride] = sb.st_mode; 474 475 /* Number of (hard) links */ 476 sarray->base_addr[3 * stride] = sb.st_nlink; 477 478 /* Owner's uid */ 479 sarray->base_addr[4 * stride] = sb.st_uid; 480 481 /* Owner's gid */ 482 sarray->base_addr[5 * stride] = sb.st_gid; 483 484 /* ID of device containing directory entry for file (0 if not available) */ 485 #if HAVE_STRUCT_STAT_ST_RDEV 486 sarray->base_addr[6 * stride] = sb.st_rdev; 487 #else 488 sarray->base_addr[6 * stride] = 0; 489 #endif 490 491 /* File size (bytes) */ 492 sarray->base_addr[7 * stride] = sb.st_size; 493 494 /* Last access time */ 495 sarray->base_addr[8 * stride] = sb.st_atime; 496 497 /* Last modification time */ 498 sarray->base_addr[9 * stride] = sb.st_mtime; 499 500 /* Last file status change time */ 501 sarray->base_addr[10 * stride] = sb.st_ctime; 502 503 /* Preferred I/O block size (-1 if not available) */ 504 #if HAVE_STRUCT_STAT_ST_BLKSIZE 505 sarray->base_addr[11 * stride] = sb.st_blksize; 506 #else 507 sarray->base_addr[11 * stride] = -1; 508 #endif 509 510 /* Number of blocks allocated (-1 if not available) */ 511 #if HAVE_STRUCT_STAT_ST_BLOCKS 512 sarray->base_addr[12 * stride] = sb.st_blocks; 513 #else 514 sarray->base_addr[12 * stride] = -1; 515 #endif 516 } 517 518 if (status != NULL) 519 *status = (val == 0) ? 0 : errno; 520 } 521 iexport(fstat_i8_sub); 522 523 extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); 524 export_proto(fstat_i4); 525 526 GFC_INTEGER_4 527 fstat_i4 (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray) 528 { 529 GFC_INTEGER_4 val; 530 fstat_i4_sub (unit, sarray, &val); 531 return val; 532 } 533 534 extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); 535 export_proto(fstat_i8); 536 537 GFC_INTEGER_8 538 fstat_i8 (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray) 539 { 540 GFC_INTEGER_8 val; 541 fstat_i8_sub (unit, sarray, &val); 542 return val; 543 } 544 545 #endif 546