libgfortran/intrinsics/stat.c

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