libgfortran/intrinsics/stat.c

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