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