libgfortran/intrinsics/stat.c

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