libgfortran/intrinsics/stat.c

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