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