libgfortran/intrinsics/stat.c

   1 /* Implementation of the STAT and FSTAT intrinsics.
   2    Copyright (C) 2004, 2005 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 "config.h"
  32 #include "libgfortran.h"
  33
  34 #ifdef HAVE_SYS_TYPES_H
  35 #include <sys/types.h>
  36 #endif
  37
  38 #ifdef HAVE_SYS_STAT_H
  39 #include <sys/stat.h>
  40 #endif
  41
  42 #ifdef HAVE_STDLIB_H
  43 #include <stdlib.h>
  44 #endif
  45
  46 #ifdef HAVE_STRING_H
  47 #include <string.h>
  48 #endif
  49
  50 #include <errno.h>
  51
  52 #include "../io/io.h"
  53
  54 /* SUBROUTINE STAT(FILE, SARRAY, STATUS)
  55    CHARACTER(len=*), INTENT(IN) :: FILE
  56    INTEGER, INTENT(OUT), :: SARRAY(13)
  57    INTEGER, INTENT(OUT), OPTIONAL :: STATUS
  58
  59    FUNCTION STAT(FILE, SARRAY)
  60    INTEGER STAT
  61    CHARACTER(len=*), INTENT(IN) :: FILE
  62    INTEGER, INTENT(OUT), :: SARRAY(13)  */
  63
  64 extern void stat_i4_sub (char *, gfc_array_i4 *, GFC_INTEGER_4 *,
  65                          gfc_charlen_type);
  66 iexport_proto(stat_i4_sub);
  67
  68 void
  69 stat_i4_sub (char *name, gfc_array_i4 *sarray, GFC_INTEGER_4 *status,
  70              gfc_charlen_type name_len)
  71 {
  72   int val;
  73   char *str;
  74   struct stat sb;
  75
  76   /* If the rank of the array is not 1, abort.  */
  77   if (GFC_DESCRIPTOR_RANK (sarray) != 1)
  78     runtime_error ("Array rank of SARRAY is not 1.");
  79
  80   /* If the array is too small, abort.  */
  81   if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
  82     runtime_error ("Array size of SARRAY is too small.");
  83
  84   if (sarray->dim[0].stride == 0)
  85     sarray->dim[0].stride = 1;
  86
  87   /* Trim trailing spaces from name.  */
  88   while (name_len > 0 && name[name_len - 1] == ' ')
  89     name_len--;
  90
  91   /* Make a null terminated copy of the string.  */
  92   str = gfc_alloca (name_len + 1);
  93   memcpy (str, name, name_len);
  94   str[name_len] = '\0';
  95
  96   val = stat(str, &sb);
  97
  98   if (val == 0)
  99     {
 100       /* Device ID  */
 101       sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;
 102
 103       /* Inode number  */
 104       sarray->data[1 * sarray->dim[0].stride] = sb.st_ino;
 105
 106       /* File mode  */
 107       sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
 108
 109       /* Number of (hard) links  */
 110       sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
 111
 112       /* Owner's uid  */
 113       sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
 114
 115       /* Owner's gid  */
 116       sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
 117
 118       /* ID of device containing directory entry for file (0 if not available) */
 119 #if HAVE_STRUCT_STAT_ST_RDEV
 120       sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
 121 #else
 122       sarray->data[6 * sarray->dim[0].stride] = 0;
 123 #endif
 124
 125       /* File size (bytes)  */
 126       sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
 127
 128       /* Last access time  */
 129       sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
 130
 131       /* Last modification time  */
 132       sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
 133
 134       /* Last file status change time  */
 135       sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
 136
 137       /* Preferred I/O block size (-1 if not available)  */
 138 #if HAVE_STRUCT_STAT_ST_BLKSIZE
 139       sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
 140 #else
 141       sarray->data[11 * sarray->dim[0].stride] = -1;
 142 #endif
 143
 144       /* Number of blocks allocated (-1 if not available)  */
 145 #if HAVE_STRUCT_STAT_ST_BLOCKS
 146       sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
 147 #else
 148       sarray->data[12 * sarray->dim[0].stride] = -1;
 149 #endif
 150     }
 151
 152   if (status != NULL)
 153     *status = (val == 0) ? 0 : errno;
 154 }
 155 iexport(stat_i4_sub);
 156
 157 extern void stat_i8_sub (char *, gfc_array_i8 *, GFC_INTEGER_8 *,
 158                          gfc_charlen_type);
 159 iexport_proto(stat_i8_sub);
 160
 161 void
 162 stat_i8_sub (char *name, gfc_array_i8 *sarray, GFC_INTEGER_8 *status,
 163              gfc_charlen_type name_len)
 164 {
 165   int val;
 166   char *str;
 167   struct stat sb;
 168
 169   /* If the rank of the array is not 1, abort.  */
 170   if (GFC_DESCRIPTOR_RANK (sarray) != 1)
 171     runtime_error ("Array rank of SARRAY is not 1.");
 172
 173   /* If the array is too small, abort.  */
 174   if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
 175     runtime_error ("Array size of SARRAY is too small.");
 176
 177   if (sarray->dim[0].stride == 0)
 178     sarray->dim[0].stride = 1;
 179
 180   /* Trim trailing spaces from name.  */
 181   while (name_len > 0 && name[name_len - 1] == ' ')
 182     name_len--;
 183
 184   /* Make a null terminated copy of the string.  */
 185   str = gfc_alloca (name_len + 1);
 186   memcpy (str, name, name_len);
 187   str[name_len] = '\0';
 188
 189   val = stat(str, &sb);
 190
 191   if (val == 0)
 192     {
 193       /* Device ID  */
 194       sarray->data[0] = sb.st_dev;
 195
 196       /* Inode number  */
 197       sarray->data[sarray->dim[0].stride] = sb.st_ino;
 198
 199       /* File mode  */
 200       sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
 201
 202       /* Number of (hard) links  */
 203       sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
 204
 205       /* Owner's uid  */
 206       sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
 207
 208       /* Owner's gid  */
 209       sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
 210
 211       /* ID of device containing directory entry for file (0 if not available) */
 212 #if HAVE_STRUCT_STAT_ST_RDEV
 213       sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
 214 #else
 215       sarray->data[6 * sarray->dim[0].stride] = 0;
 216 #endif
 217
 218       /* File size (bytes)  */
 219       sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
 220
 221       /* Last access time  */
 222       sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
 223
 224       /* Last modification time  */
 225       sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
 226
 227       /* Last file status change time  */
 228       sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
 229
 230       /* Preferred I/O block size (-1 if not available)  */
 231 #if HAVE_STRUCT_STAT_ST_BLKSIZE
 232       sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
 233 #else
 234       sarray->data[11 * sarray->dim[0].stride] = -1;
 235 #endif
 236
 237       /* Number of blocks allocated (-1 if not available)  */
 238 #if HAVE_STRUCT_STAT_ST_BLOCKS
 239       sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
 240 #else
 241       sarray->data[12 * sarray->dim[0].stride] = -1;
 242 #endif
 243     }
 244
 245   if (status != NULL)
 246     *status = (val == 0) ? 0 : errno;
 247 }
 248 iexport(stat_i8_sub);
 249
 250 extern GFC_INTEGER_4 stat_i4 (char *, gfc_array_i4 *, gfc_charlen_type);
 251 export_proto(stat_i4);
 252
 253 GFC_INTEGER_4
 254 stat_i4 (char *name, gfc_array_i4 *sarray, gfc_charlen_type name_len)
 255 {
 256   GFC_INTEGER_4 val;
 257   stat_i4_sub (name, sarray, &val, name_len);
 258   return val;
 259 }
 260
 261 extern GFC_INTEGER_8 stat_i8 (char *, gfc_array_i8 *, gfc_charlen_type);
 262 export_proto(stat_i8);
 263
 264 GFC_INTEGER_8
 265 stat_i8 (char *name, gfc_array_i8 *sarray, gfc_charlen_type name_len)
 266 {
 267   GFC_INTEGER_8 val;
 268   stat_i8_sub (name, sarray, &val, name_len);
 269   return val;
 270 }
 271
 272
 273 /* SUBROUTINE FSTAT(UNIT, SARRAY, STATUS)
 274    INTEGER, INTENT(IN) :: UNIT
 275    INTEGER, INTENT(OUT) :: SARRAY(13)
 276    INTEGER, INTENT(OUT), OPTIONAL :: STATUS
 277
 278    FUNCTION FSTAT(UNIT, SARRAY)
 279    INTEGER FSTAT
 280    INTEGER, INTENT(IN) :: UNIT
 281    INTEGER, INTENT(OUT) :: SARRAY(13)  */
 282
 283 extern void fstat_i4_sub (GFC_INTEGER_4 *, gfc_array_i4 *, GFC_INTEGER_4 *);
 284 iexport_proto(fstat_i4_sub);
 285
 286 void
 287 fstat_i4_sub (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray, GFC_INTEGER_4 *status)
 288 {
 289   int val;
 290   struct stat sb;
 291
 292   /* If the rank of the array is not 1, abort.  */
 293   if (GFC_DESCRIPTOR_RANK (sarray) != 1)
 294     runtime_error ("Array rank of SARRAY is not 1.");
 295
 296   /* If the array is too small, abort.  */
 297   if (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
 298     runtime_error ("Array size of SARRAY is too small.");
 299
 300   if (sarray->dim[0].stride == 0)
 301     sarray->dim[0].stride = 1;
 302
 303   /* Convert Fortran unit number to C file descriptor.  */
 304   val = unit_to_fd (*unit);
 305   if (val >= 0)
 306     val = fstat(val, &sb);
 307
 308   if (val == 0)
 309     {
 310       /* Device ID  */
 311       sarray->data[0 * sarray->dim[0].stride] = sb.st_dev;
 312
 313       /* Inode number  */
 314       sarray->data[1 * sarray->dim[0].stride] = sb.st_ino;
 315
 316       /* File mode  */
 317       sarray->data[2 * sarray->dim[0].stride] = sb.st_mode;
 318
 319       /* Number of (hard) links  */
 320       sarray->data[3 * sarray->dim[0].stride] = sb.st_nlink;
 321
 322       /* Owner's uid  */
 323       sarray->data[4 * sarray->dim[0].stride] = sb.st_uid;
 324
 325       /* Owner's gid  */
 326       sarray->data[5 * sarray->dim[0].stride] = sb.st_gid;
 327
 328       /* ID of device containing directory entry for file (0 if not available) */
 329 #if HAVE_STRUCT_STAT_ST_RDEV
 330       sarray->data[6 * sarray->dim[0].stride] = sb.st_rdev;
 331 #else
 332       sarray->data[6 * sarray->dim[0].stride] = 0;
 333 #endif
 334
 335       /* File size (bytes)  */
 336       sarray->data[7 * sarray->dim[0].stride] = sb.st_size;
 337
 338       /* Last access time  */
 339       sarray->data[8 * sarray->dim[0].stride] = sb.st_atime;
 340
 341       /* Last modification time  */
 342       sarray->data[9 * sarray->dim[0].stride] = sb.st_mtime;
 343
 344       /* Last file status change time  */
 345       sarray->data[10 * sarray->dim[0].stride] = sb.st_ctime;
 346
 347       /* Preferred I/O block size (-1 if not available)  */
 348 #if HAVE_STRUCT_STAT_ST_BLKSIZE
 349       sarray->data[11 * sarray->dim[0].stride] = sb.st_blksize;
 350 #else
 351       sarray->data[11 * sarray->dim[0].stride] = -1;
 352 #endif
 353
 354       /* Number of blocks allocated (-1 if not available)  */
 355 #if HAVE_STRUCT_STAT_ST_BLOCKS
 356       sarray->data[12 * sarray->dim[0].stride] = sb.st_blocks;
 357 #else
 358       sarray->data[12 * sarray->dim[0].stride] = -1;
 359 #endif
 360     }
 361
 362   if (status != NULL)
 363     *status = (val == 0) ? 0 : errno;
 364 }
 365 iexport(fstat_i4_sub);
 366
 367 extern void fstat_i8_sub (GFC_INTEGER_8 *, gfc_array_i8 *, GFC_INTEGER_8 *);
 368 iexport_proto(fstat_i8_sub);
 369
 370 void
 371 fstat_i8_sub (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray, GFC_INTEGER_8 *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 (sarray->dim[0].ubound + 1 - sarray->dim[0].lbound < 13)
 382     runtime_error ("Array size of SARRAY is too small.");
 383
 384   if (sarray->dim[0].stride == 0)
 385     sarray->dim[0].stride = 1;
 386
 387   /* Convert Fortran unit number to C file descriptor.  */
 388   val = unit_to_fd ((int) *unit);
 389   if (val >= 0)
 390     val = fstat(val, &sb);
 391
 392   if (val == 0)
 393     {
 394       /* Device ID  */
 395       sarray->data[0] = sb.st_dev;
 396
 397       /* Inode number  */
 398       sarray->data[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_i8_sub);
 450
 451 extern GFC_INTEGER_4 fstat_i4 (GFC_INTEGER_4 *, gfc_array_i4 *);
 452 export_proto(fstat_i4);
 453
 454 GFC_INTEGER_4
 455 fstat_i4 (GFC_INTEGER_4 *unit, gfc_array_i4 *sarray)
 456 {
 457   GFC_INTEGER_4 val;
 458   fstat_i4_sub (unit, sarray, &val);
 459   return val;
 460 }
 461
 462 extern GFC_INTEGER_8 fstat_i8 (GFC_INTEGER_8 *, gfc_array_i8 *);
 463 export_proto(fstat_i8);
 464
 465 GFC_INTEGER_8
 466 fstat_i8 (GFC_INTEGER_8 *unit, gfc_array_i8 *sarray)
 467 {
 468   GFC_INTEGER_8 val;
 469   fstat_i8_sub (unit, sarray, &val);
 470   return val;
 471 }