libgfortran/intrinsics/stat.c

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