libgfortran/intrinsics/stat.c

   1 /* Implementation of the STAT and FSTAT intrinsics.
   2    Copyright (C) 2004-2024 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