libgfortran/intrinsics/stat.c

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