1/* Implementation of the STAT and FSTAT intrinsics. 2 Copyright (C) 2004-2022 Free Software Foundation, Inc. 3 Contributed by Steven G. Kargl <kargls@comcast.net>. 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#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); 50internal_proto(stat_i4_sub_0);*/ 51 52static void 53stat_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 142extern void stat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *, 143 gfc_charlen_type); 144iexport_proto(stat_i4_sub); 145 146void 147stat_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} 152iexport(stat_i4_sub); 153 154 155extern void lstat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *, 156 gfc_charlen_type); 157iexport_proto(lstat_i4_sub); 158 159void 160lstat_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} 165iexport(lstat_i4_sub); 166 167 168 169static void 170stat_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 259extern void stat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *, 260 gfc_charlen_type); 261iexport_proto(stat_i8_sub); 262 263void 264stat_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 270iexport(stat_i8_sub); 271 272 273extern void lstat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *, 274 gfc_charlen_type); 275iexport_proto(lstat_i8_sub); 276 277void 278lstat_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 284iexport(lstat_i8_sub); 285 286 287extern GFC_INTEGER_4 stat_i4 (char *, gfc_array_i4 *, gfc_charlen_type); 288export_proto(stat_i4); 289 290GFC_INTEGER_4 291stat_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 298extern GFC_INTEGER_8 stat_i8 (char *, gfc_array_i8 *, gfc_charlen_type); 299export_proto(stat_i8); 300 301GFC_INTEGER_8 302stat_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 320extern GFC_INTEGER_4 lstat_i4 (char *, gfc_array_i4 *, gfc_charlen_type); 321export_proto(lstat_i4); 322 323GFC_INTEGER_4 324lstat_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 331extern GFC_INTEGER_8 lstat_i8 (char *, gfc_array_i8 *, gfc_charlen_type); 332export_proto(lstat_i8); 333 334GFC_INTEGER_8 335lstat_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 357extern void fstat_i4_sub (GFC_INTEGER_4 *, gfc_array_i4 *, GFC_INTEGER_4 *); 358iexport_proto(fstat_i4_sub); 359 360void 361fstat_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} 438iexport(fstat_i4_sub); 439 440extern void fstat_i8_sub (GFC_INTEGER_8 *, gfc_array_i8 *, GFC_INTEGER_8 *); 441iexport_proto(fstat_i8_sub); 442 443void 444fstat_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} 521iexport(fstat_i8_sub); 522 523extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 *, gfc_array_i4 *); 524export_proto(fstat_i4); 525 526GFC_INTEGER_4 527fstat_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 534extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 *, gfc_array_i8 *); 535export_proto(fstat_i8); 536 537GFC_INTEGER_8 538fstat_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