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