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