libgfortran/intrinsics/stat.c

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