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