libgfortran/intrinsics/stat.c

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