1 /* Copyright (C) 2002-2014 Free Software Foundation, Inc.
2 Contributed by Andy Vaught
3 F2003 I/O support contributed by Jerry DeLisle
5 This file is part of the GNU Fortran runtime library (libgfortran).
7 Libgfortran is free software; you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation; either version 3, or (at your option)
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.
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.
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/>. */
26 /* Unix stream I/O module */
45 /* For mingw, we don't identify files by their inode number, but by a
46 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
49 #define WIN32_LEAN_AND_MEAN
52 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
54 #define lseek _lseeki64
56 #define fstat _fstati64
61 #ifndef HAVE_WORKING_STAT
63 id_from_handle (HANDLE hFile
)
65 BY_HANDLE_FILE_INFORMATION FileInformation
;
67 if (hFile
== INVALID_HANDLE_VALUE
)
70 memset (&FileInformation
, 0, sizeof(FileInformation
));
71 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
74 return ((uint64_t) FileInformation
.nFileIndexLow
)
75 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
80 id_from_path (const char *path
)
85 if (!path
|| !*path
|| access (path
, F_OK
))
88 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
89 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
91 res
= id_from_handle (hFile
);
98 id_from_fd (const int fd
)
100 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
103 #endif /* HAVE_WORKING_STAT */
104 #endif /* __MINGW32__ */
107 /* min macro that evaluates its arguments only once. */
113 ({ typeof (a) _a = (a); \
114 typeof (b) _b = (b); \
115 _a < _b ? _a : _b; })
118 /* These flags aren't defined on all targets (mingw32), so provide them
151 /* Fallback implementation of access() on systems that don't have it.
152 Only modes R_OK, W_OK and F_OK are used in this file. */
155 fallback_access (const char *path
, int mode
)
159 if ((mode
& R_OK
) && (fd
= open (path
, O_RDONLY
)) < 0)
163 if ((mode
& W_OK
) && (fd
= open (path
, O_WRONLY
)) < 0)
170 return stat (path
, &st
);
177 #define access fallback_access
181 /* Fallback directory for creating temporary files. P_tmpdir is
182 defined on many POSIX platforms. */
185 #define P_tmpdir _P_tmpdir /* MinGW */
187 #define P_tmpdir "/tmp"
192 /* Unix and internal stream I/O module */
194 static const int BUFFER_SIZE
= 8192;
200 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
201 gfc_offset physical_offset
; /* Current physical file offset */
202 gfc_offset logical_offset
; /* Current logical file offset */
203 gfc_offset file_length
; /* Length of the file. */
205 char *buffer
; /* Pointer to the buffer. */
206 int fd
; /* The POSIX file descriptor. */
208 int active
; /* Length of valid bytes in the buffer */
210 int ndirty
; /* Dirty bytes starting at buffer_offset */
212 /* Cached stat(2) values. */
216 bool unbuffered
; /* Buffer should be flushed after each I/O statement. */
221 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
222 * standard descriptors, returning a non-standard descriptor. If the
223 * user specifies that system errors should go to standard output,
224 * then closes standard output, we don't want the system errors to a
225 * file that has been given file descriptor 1 or 0. We want to send
226 * the error to the invalid descriptor. */
232 int input
, output
, error
;
234 input
= output
= error
= 0;
236 /* Unix allocates the lowest descriptors first, so a loop is not
237 required, but this order is. */
238 if (fd
== STDIN_FILENO
)
243 if (fd
== STDOUT_FILENO
)
248 if (fd
== STDERR_FILENO
)
255 close (STDIN_FILENO
);
257 close (STDOUT_FILENO
);
259 close (STDERR_FILENO
);
266 /* If the stream corresponds to a preconnected unit, we flush the
267 corresponding C stream. This is bugware for mixed C-Fortran codes
268 where the C code doesn't flush I/O before returning. */
270 flush_if_preconnected (stream
* s
)
274 fd
= ((unix_stream
*) s
)->fd
;
275 if (fd
== STDIN_FILENO
)
277 else if (fd
== STDOUT_FILENO
)
279 else if (fd
== STDERR_FILENO
)
284 /********************************************************************
285 Raw I/O functions (read, write, seek, tell, truncate, close).
287 These functions wrap the basic POSIX I/O syscalls. Any deviation in
288 semantics is a bug, except the following: write restarts in case
289 of being interrupted by a signal, and as the first argument the
290 functions take the unix_stream struct rather than an integer file
291 descriptor. Also, for POSIX read() and write() a nbyte argument larger
292 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
293 than size_t as for POSIX read/write.
294 *********************************************************************/
297 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
303 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
305 /* For read we can't do I/O in a loop like raw_write does, because
306 that will break applications that wait for interactive I/O. */
307 return read (s
->fd
, buf
, nbyte
);
311 raw_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
313 ssize_t trans
, bytes_left
;
317 buf_st
= (char *) buf
;
319 /* We must write in a loop since some systems don't restart system
320 calls in case of a signal. */
321 while (bytes_left
> 0)
323 trans
= write (s
->fd
, buf_st
, bytes_left
);
335 return nbyte
- bytes_left
;
339 raw_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
341 return lseek (s
->fd
, offset
, whence
);
345 raw_tell (unix_stream
* s
)
347 return lseek (s
->fd
, 0, SEEK_CUR
);
351 raw_size (unix_stream
* s
)
354 int ret
= fstat (s
->fd
, &statbuf
);
357 if (S_ISREG (statbuf
.st_mode
))
358 return statbuf
.st_size
;
364 raw_truncate (unix_stream
* s
, gfc_offset length
)
375 h
= (HANDLE
) _get_osfhandle (s
->fd
);
376 if (h
== INVALID_HANDLE_VALUE
)
381 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
384 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
386 if (!SetEndOfFile (h
))
391 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
395 lseek (s
->fd
, cur
, SEEK_SET
);
397 #elif defined HAVE_FTRUNCATE
398 return ftruncate (s
->fd
, length
);
399 #elif defined HAVE_CHSIZE
400 return chsize (s
->fd
, length
);
402 runtime_error ("required ftruncate or chsize support not present");
408 raw_close (unix_stream
* s
)
414 else if (s
->fd
!= STDOUT_FILENO
415 && s
->fd
!= STDERR_FILENO
416 && s
->fd
!= STDIN_FILENO
)
417 retval
= close (s
->fd
);
425 raw_markeor (unix_stream
* s
__attribute__ ((unused
)))
430 static const struct stream_vtable raw_vtable
= {
431 .read
= (void *) raw_read
,
432 .write
= (void *) raw_write
,
433 .seek
= (void *) raw_seek
,
434 .tell
= (void *) raw_tell
,
435 .size
= (void *) raw_size
,
436 .trunc
= (void *) raw_truncate
,
437 .close
= (void *) raw_close
,
438 .flush
= (void *) raw_flush
,
439 .markeor
= (void *) raw_markeor
443 raw_init (unix_stream
* s
)
445 s
->st
.vptr
= &raw_vtable
;
452 /*********************************************************************
453 Buffered I/O functions. These functions have the same semantics as the
454 raw I/O functions above, except that they are buffered in order to
455 improve performance. The buffer must be flushed when switching from
456 reading to writing and vice versa.
457 *********************************************************************/
460 buf_flush (unix_stream
* s
)
464 /* Flushing in read mode means discarding read bytes. */
470 if (s
->physical_offset
!= s
->buffer_offset
471 && lseek (s
->fd
, s
->buffer_offset
, SEEK_SET
) < 0)
474 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
476 s
->physical_offset
= s
->buffer_offset
+ writelen
;
478 if (s
->physical_offset
> s
->file_length
)
479 s
->file_length
= s
->physical_offset
;
481 s
->ndirty
-= writelen
;
489 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
492 s
->buffer_offset
= s
->logical_offset
;
494 /* Is the data we want in the buffer? */
495 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
496 && s
->buffer_offset
<= s
->logical_offset
)
497 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), nbyte
);
500 /* First copy the active bytes if applicable, then read the rest
501 either directly or filling the buffer. */
504 ssize_t to_read
, did_read
;
505 gfc_offset new_logical
;
508 if (s
->logical_offset
>= s
->buffer_offset
509 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
511 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
512 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
516 /* At this point we consider all bytes in the buffer discarded. */
517 to_read
= nbyte
- nread
;
518 new_logical
= s
->logical_offset
+ nread
;
519 if (s
->physical_offset
!= new_logical
520 && lseek (s
->fd
, new_logical
, SEEK_SET
) < 0)
522 s
->buffer_offset
= s
->physical_offset
= new_logical
;
523 if (to_read
<= BUFFER_SIZE
/2)
525 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
526 s
->physical_offset
+= did_read
;
527 s
->active
= did_read
;
528 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
529 memcpy (p
, s
->buffer
, did_read
);
533 did_read
= raw_read (s
, p
, to_read
);
534 s
->physical_offset
+= did_read
;
537 nbyte
= did_read
+ nread
;
539 s
->logical_offset
+= nbyte
;
544 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
547 s
->buffer_offset
= s
->logical_offset
;
549 /* Does the data fit into the buffer? As a special case, if the
550 buffer is empty and the request is bigger than BUFFER_SIZE/2,
551 write directly. This avoids the case where the buffer would have
552 to be flushed at every write. */
553 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
554 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
555 && s
->buffer_offset
<= s
->logical_offset
556 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
558 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
559 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
565 /* Flush, and either fill the buffer with the new data, or if
566 the request is bigger than the buffer size, write directly
567 bypassing the buffer. */
569 if (nbyte
<= BUFFER_SIZE
/2)
571 memcpy (s
->buffer
, buf
, nbyte
);
572 s
->buffer_offset
= s
->logical_offset
;
577 if (s
->physical_offset
!= s
->logical_offset
)
579 if (lseek (s
->fd
, s
->logical_offset
, SEEK_SET
) < 0)
581 s
->physical_offset
= s
->logical_offset
;
584 nbyte
= raw_write (s
, buf
, nbyte
);
585 s
->physical_offset
+= nbyte
;
588 s
->logical_offset
+= nbyte
;
589 if (s
->logical_offset
> s
->file_length
)
590 s
->file_length
= s
->logical_offset
;
595 /* "Unbuffered" really means I/O statement buffering. For formatted
596 I/O, the fbuf manages this, and then uses raw I/O. For unformatted
597 I/O, buffered I/O is used, and the buffer is flushed at the end of
598 each I/O statement, where this function is called. Alternatively,
599 the buffer is flushed at the end of the record if the buffer is
600 more than half full; this prevents needless seeking back and forth
601 when writing sequential unformatted. */
604 buf_markeor (unix_stream
* s
)
606 if (s
->unbuffered
|| s
->ndirty
>= BUFFER_SIZE
/ 2)
607 return buf_flush (s
);
612 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
619 offset
+= s
->logical_offset
;
622 offset
+= s
->file_length
;
632 s
->logical_offset
= offset
;
637 buf_tell (unix_stream
* s
)
639 return buf_seek (s
, 0, SEEK_CUR
);
643 buf_size (unix_stream
* s
)
645 return s
->file_length
;
649 buf_truncate (unix_stream
* s
, gfc_offset length
)
653 if (buf_flush (s
) != 0)
655 r
= raw_truncate (s
, length
);
657 s
->file_length
= length
;
662 buf_close (unix_stream
* s
)
664 if (buf_flush (s
) != 0)
667 return raw_close (s
);
670 static const struct stream_vtable buf_vtable
= {
671 .read
= (void *) buf_read
,
672 .write
= (void *) buf_write
,
673 .seek
= (void *) buf_seek
,
674 .tell
= (void *) buf_tell
,
675 .size
= (void *) buf_size
,
676 .trunc
= (void *) buf_truncate
,
677 .close
= (void *) buf_close
,
678 .flush
= (void *) buf_flush
,
679 .markeor
= (void *) buf_markeor
683 buf_init (unix_stream
* s
)
685 s
->st
.vptr
= &buf_vtable
;
687 s
->buffer
= xmalloc (BUFFER_SIZE
);
692 /*********************************************************************
693 memory stream functions - These are used for internal files
695 The idea here is that a single stream structure is created and all
696 requests must be satisfied from it. The location and size of the
697 buffer is the character variable supplied to the READ or WRITE
700 *********************************************************************/
703 mem_alloc_r (stream
* strm
, int * len
)
705 unix_stream
* s
= (unix_stream
*) strm
;
707 gfc_offset where
= s
->logical_offset
;
709 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
712 n
= s
->buffer_offset
+ s
->active
- where
;
716 s
->logical_offset
= where
+ *len
;
718 return s
->buffer
+ (where
- s
->buffer_offset
);
723 mem_alloc_r4 (stream
* strm
, int * len
)
725 unix_stream
* s
= (unix_stream
*) strm
;
727 gfc_offset where
= s
->logical_offset
;
729 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
732 n
= s
->buffer_offset
+ s
->active
- where
;
736 s
->logical_offset
= where
+ *len
;
738 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
743 mem_alloc_w (stream
* strm
, int * len
)
745 unix_stream
* s
= (unix_stream
*) strm
;
747 gfc_offset where
= s
->logical_offset
;
751 if (where
< s
->buffer_offset
)
754 if (m
> s
->file_length
)
757 s
->logical_offset
= m
;
759 return s
->buffer
+ (where
- s
->buffer_offset
);
764 mem_alloc_w4 (stream
* strm
, int * len
)
766 unix_stream
* s
= (unix_stream
*) strm
;
768 gfc_offset where
= s
->logical_offset
;
769 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
773 if (where
< s
->buffer_offset
)
776 if (m
> s
->file_length
)
779 s
->logical_offset
= m
;
780 return &result
[where
- s
->buffer_offset
];
784 /* Stream read function for character(kind=1) internal units. */
787 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
792 p
= mem_alloc_r (s
, &nb
);
803 /* Stream read function for chracter(kind=4) internal units. */
806 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
811 p
= mem_alloc_r (s
, &nb
);
822 /* Stream write function for character(kind=1) internal units. */
825 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
830 p
= mem_alloc_w (s
, &nb
);
841 /* Stream write function for character(kind=4) internal units. */
844 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
849 p
= mem_alloc_w4 (s
, &nw
);
853 *p
++ = (gfc_char4_t
) *((char *) buf
);
862 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
864 unix_stream
* s
= (unix_stream
*) strm
;
870 offset
+= s
->logical_offset
;
873 offset
+= s
->file_length
;
879 /* Note that for internal array I/O it's actually possible to have a
880 negative offset, so don't check for that. */
881 if (offset
> s
->file_length
)
887 s
->logical_offset
= offset
;
889 /* Returning < 0 is the error indicator for sseek(), so return 0 if
890 offset is negative. Thus if the return value is 0, the caller
891 has to use stell() to get the real value of logical_offset. */
899 mem_tell (stream
* s
)
901 return ((unix_stream
*)s
)->logical_offset
;
906 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
907 gfc_offset length
__attribute__ ((unused
)))
914 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
921 mem_close (unix_stream
* s
)
928 static const struct stream_vtable mem_vtable
= {
929 .read
= (void *) mem_read
,
930 .write
= (void *) mem_write
,
931 .seek
= (void *) mem_seek
,
932 .tell
= (void *) mem_tell
,
933 /* buf_size is not a typo, we just reuse an identical
935 .size
= (void *) buf_size
,
936 .trunc
= (void *) mem_truncate
,
937 .close
= (void *) mem_close
,
938 .flush
= (void *) mem_flush
,
939 .markeor
= (void *) raw_markeor
942 static const struct stream_vtable mem4_vtable
= {
943 .read
= (void *) mem_read4
,
944 .write
= (void *) mem_write4
,
945 .seek
= (void *) mem_seek
,
946 .tell
= (void *) mem_tell
,
947 /* buf_size is not a typo, we just reuse an identical
949 .size
= (void *) buf_size
,
950 .trunc
= (void *) mem_truncate
,
951 .close
= (void *) mem_close
,
952 .flush
= (void *) mem_flush
,
953 .markeor
= (void *) raw_markeor
956 /*********************************************************************
957 Public functions -- A reimplementation of this module needs to
958 define functional equivalents of the following.
959 *********************************************************************/
961 /* open_internal()-- Returns a stream structure from a character(kind=1)
965 open_internal (char *base
, int length
, gfc_offset offset
)
969 s
= xcalloc (1, sizeof (unix_stream
));
972 s
->buffer_offset
= offset
;
974 s
->active
= s
->file_length
= length
;
976 s
->st
.vptr
= &mem_vtable
;
981 /* open_internal4()-- Returns a stream structure from a character(kind=4)
985 open_internal4 (char *base
, int length
, gfc_offset offset
)
989 s
= xcalloc (1, sizeof (unix_stream
));
992 s
->buffer_offset
= offset
;
994 s
->active
= s
->file_length
= length
* sizeof (gfc_char4_t
);
996 s
->st
.vptr
= &mem4_vtable
;
1002 /* fd_to_stream()-- Given an open file descriptor, build a stream
1006 fd_to_stream (int fd
, bool unformatted
)
1008 struct stat statbuf
;
1011 s
= xcalloc (1, sizeof (unix_stream
));
1015 /* Get the current length of the file. */
1017 if (fstat (fd
, &statbuf
) == -1)
1019 s
->st_dev
= s
->st_ino
= -1;
1024 return (stream
*) s
;
1027 s
->st_dev
= statbuf
.st_dev
;
1028 s
->st_ino
= statbuf
.st_ino
;
1029 s
->file_length
= statbuf
.st_size
;
1031 /* Only use buffered IO for regular files. */
1032 if (S_ISREG (statbuf
.st_mode
)
1033 && !options
.all_unbuffered
1034 && !(options
.unbuffered_preconnected
&&
1035 (s
->fd
== STDIN_FILENO
1036 || s
->fd
== STDOUT_FILENO
1037 || s
->fd
== STDERR_FILENO
)))
1043 s
->unbuffered
= true;
1050 return (stream
*) s
;
1054 /* Given the Fortran unit number, convert it to a C file descriptor. */
1057 unit_to_fd (int unit
)
1062 us
= find_unit (unit
);
1066 fd
= ((unix_stream
*) us
->s
)->fd
;
1072 /* Set the close-on-exec flag for an existing fd, if the system
1075 static void __attribute__ ((unused
))
1076 set_close_on_exec (int fd
__attribute__ ((unused
)))
1078 /* Mingw does not define F_SETFD. */
1079 #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1081 fcntl(fd
, F_SETFD
, FD_CLOEXEC
);
1086 /* Helper function for tempfile(). Tries to open a temporary file in
1087 the directory specified by tempdir. If successful, the file name is
1088 stored in fname and the descriptor returned. Returns -1 on
1092 tempfile_open (const char *tempdir
, char **fname
)
1095 const char *slash
= "/";
1096 #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1103 /* Check for the special case that tempdir ends with a slash or
1105 size_t tempdirlen
= strlen (tempdir
);
1106 if (*tempdir
== 0 || tempdir
[tempdirlen
- 1] == '/'
1108 || tempdir
[tempdirlen
- 1] == '\\'
1113 // Take care that the template is longer in the mktemp() branch.
1114 char * template = xmalloc (tempdirlen
+ 23);
1117 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpXXXXXX",
1121 /* Temporarily set the umask such that the file has 0600 permissions. */
1122 mode_mask
= umask (S_IXUSR
| S_IRWXG
| S_IRWXO
);
1125 #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1126 fd
= mkostemp (template, O_CLOEXEC
);
1128 fd
= mkstemp (template);
1129 set_close_on_exec (fd
);
1133 (void) umask (mode_mask
);
1136 #else /* HAVE_MKSTEMP */
1139 size_t slashlen
= strlen (slash
);
1140 int flags
= O_RDWR
| O_CREAT
| O_EXCL
;
1141 #if defined(HAVE_CRLF) && defined(O_BINARY)
1149 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpaaaXXXXXX",
1154 template[tempdirlen
+ slashlen
+ 13] = 'a' + (c
% 26);
1156 template[tempdirlen
+ slashlen
+ 12] = 'a' + (c
% 26);
1158 template[tempdirlen
+ slashlen
+ 11] = 'a' + (c
% 26);
1163 if (!mktemp (template))
1170 fd
= open (template, flags
, S_IRUSR
| S_IWUSR
);
1172 while (fd
== -1 && errno
== EEXIST
);
1174 set_close_on_exec (fd
);
1176 #endif /* HAVE_MKSTEMP */
1183 /* tempfile()-- Generate a temporary filename for a scratch file and
1184 * open it. mkstemp() opens the file for reading and writing, but the
1185 * library mode prevents anything that is not allowed. The descriptor
1186 * is returned, which is -1 on error. The template is pointed to by
1187 * opp->file, which is copied into the unit structure
1188 * and freed later. */
1191 tempfile (st_parameter_open
*opp
)
1193 const char *tempdir
;
1197 tempdir
= secure_getenv ("TMPDIR");
1198 fd
= tempfile_open (tempdir
, &fname
);
1202 char buffer
[MAX_PATH
+ 1];
1204 ret
= GetTempPath (MAX_PATH
, buffer
);
1205 /* If we are not able to get a temp-directory, we use
1206 current directory. */
1207 if (ret
> MAX_PATH
|| !ret
)
1211 tempdir
= strdup (buffer
);
1212 fd
= tempfile_open (tempdir
, &fname
);
1214 #elif defined(__CYGWIN__)
1217 tempdir
= secure_getenv ("TMP");
1218 fd
= tempfile_open (tempdir
, &fname
);
1222 tempdir
= secure_getenv ("TEMP");
1223 fd
= tempfile_open (tempdir
, &fname
);
1227 fd
= tempfile_open (P_tmpdir
, &fname
);
1230 opp
->file_len
= strlen (fname
); /* Don't include trailing nul */
1236 /* regular_file2()-- Open a regular file.
1237 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1238 * unless an error occurs.
1239 * Returns the descriptor, which is less than zero on error. */
1242 regular_file2 (const char *path
, st_parameter_open
*opp
, unit_flags
*flags
)
1246 int crflag
, crflag2
;
1250 if (opp
->file_len
== 7)
1252 if (strncmp (path
, "CONOUT$", 7) == 0
1253 || strncmp (path
, "CONERR$", 7) == 0)
1255 fd
= open ("/dev/conout", O_WRONLY
);
1256 flags
->action
= ACTION_WRITE
;
1261 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1263 fd
= open ("/dev/conin", O_RDONLY
);
1264 flags
->action
= ACTION_READ
;
1271 if (opp
->file_len
== 7)
1273 if (strncmp (path
, "CONOUT$", 7) == 0
1274 || strncmp (path
, "CONERR$", 7) == 0)
1276 fd
= open ("CONOUT$", O_WRONLY
);
1277 flags
->action
= ACTION_WRITE
;
1282 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1284 fd
= open ("CONIN$", O_RDONLY
);
1285 flags
->action
= ACTION_READ
;
1290 switch (flags
->action
)
1300 case ACTION_READWRITE
:
1301 case ACTION_UNSPECIFIED
:
1306 internal_error (&opp
->common
, "regular_file(): Bad action");
1309 switch (flags
->status
)
1312 crflag
= O_CREAT
| O_EXCL
;
1315 case STATUS_OLD
: /* open will fail if the file does not exist*/
1319 case STATUS_UNKNOWN
:
1320 if (rwflag
== O_RDONLY
)
1326 case STATUS_REPLACE
:
1327 crflag
= O_CREAT
| O_TRUNC
;
1331 /* Note: STATUS_SCRATCH is handled by tempfile () and should
1332 never be seen here. */
1333 internal_error (&opp
->common
, "regular_file(): Bad status");
1336 /* rwflag |= O_LARGEFILE; */
1338 #if defined(HAVE_CRLF) && defined(O_BINARY)
1343 crflag
|= O_CLOEXEC
;
1346 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1347 fd
= open (path
, rwflag
| crflag
, mode
);
1348 if (flags
->action
!= ACTION_UNSPECIFIED
)
1353 flags
->action
= ACTION_READWRITE
;
1356 if (errno
!= EACCES
&& errno
!= EROFS
)
1359 /* retry for read-only access */
1361 if (flags
->status
== STATUS_UNKNOWN
)
1362 crflag2
= crflag
& ~(O_CREAT
);
1365 fd
= open (path
, rwflag
| crflag2
, mode
);
1368 flags
->action
= ACTION_READ
;
1369 return fd
; /* success */
1372 if (errno
!= EACCES
&& errno
!= ENOENT
)
1373 return fd
; /* failure */
1375 /* retry for write-only access */
1377 fd
= open (path
, rwflag
| crflag
, mode
);
1380 flags
->action
= ACTION_WRITE
;
1381 return fd
; /* success */
1383 return fd
; /* failure */
1387 /* Wrapper around regular_file2, to make sure we free the path after
1391 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1393 char *path
= fc_strdup (opp
->file
, opp
->file_len
);
1394 int fd
= regular_file2 (path
, opp
, flags
);
1399 /* open_external()-- Open an external file, unix specific version.
1400 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1401 * Returns NULL on operating system error. */
1404 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1408 if (flags
->status
== STATUS_SCRATCH
)
1410 fd
= tempfile (opp
);
1411 if (flags
->action
== ACTION_UNSPECIFIED
)
1412 flags
->action
= ACTION_READWRITE
;
1414 #if HAVE_UNLINK_OPEN_FILE
1415 /* We can unlink scratch files now and it will go away when closed. */
1422 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1424 fd
= regular_file (opp
, flags
);
1426 set_close_on_exec (fd
);
1434 return fd_to_stream (fd
, flags
->form
== FORM_UNFORMATTED
);
1438 /* input_stream()-- Return a stream pointer to the default input stream.
1439 * Called on initialization. */
1444 return fd_to_stream (STDIN_FILENO
, false);
1448 /* output_stream()-- Return a stream pointer to the default output stream.
1449 * Called on initialization. */
1452 output_stream (void)
1456 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1457 setmode (STDOUT_FILENO
, O_BINARY
);
1460 s
= fd_to_stream (STDOUT_FILENO
, false);
1465 /* error_stream()-- Return a stream pointer to the default error stream.
1466 * Called on initialization. */
1473 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1474 setmode (STDERR_FILENO
, O_BINARY
);
1477 s
= fd_to_stream (STDERR_FILENO
, false);
1482 /* compare_file_filename()-- Given an open stream and a fortran string
1483 * that is a filename, figure out if the file is the same as the
1487 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1491 #ifdef HAVE_WORKING_STAT
1499 char *path
= fc_strdup (name
, len
);
1501 /* If the filename doesn't exist, then there is no match with the
1504 if (stat (path
, &st
) < 0)
1510 #ifdef HAVE_WORKING_STAT
1511 s
= (unix_stream
*) (u
->s
);
1512 ret
= (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1517 /* We try to match files by a unique ID. On some filesystems (network
1518 fs and FAT), we can't generate this unique ID, and will simply compare
1520 id1
= id_from_path (path
);
1521 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1529 if (len
!= u
->file_len
)
1532 ret
= (memcmp(path
, u
->file
, len
) == 0);
1540 #ifdef HAVE_WORKING_STAT
1541 # define FIND_FILE0_DECL struct stat *st
1542 # define FIND_FILE0_ARGS st
1544 # define FIND_FILE0_DECL uint64_t id, const char *file, gfc_charlen_type file_len
1545 # define FIND_FILE0_ARGS id, file, file_len
1548 /* find_file0()-- Recursive work function for find_file() */
1551 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1554 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1561 #ifdef HAVE_WORKING_STAT
1564 unix_stream
*s
= (unix_stream
*) (u
->s
);
1565 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1570 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1577 if (compare_string (u
->file_len
, u
->file
, file_len
, file
) == 0)
1581 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1585 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1593 /* find_file()-- Take the current filename and see if there is a unit
1594 * that has the file already open. Returns a pointer to the unit if so. */
1597 find_file (const char *file
, gfc_charlen_type file_len
)
1601 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1605 char *path
= fc_strdup (file
, file_len
);
1607 if (stat (path
, &st
[0]) < 0)
1613 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1614 id
= id_from_path (path
);
1617 __gthread_mutex_lock (&unit_lock
);
1619 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1623 if (! __gthread_mutex_trylock (&u
->lock
))
1625 /* assert (u->closed == 0); */
1626 __gthread_mutex_unlock (&unit_lock
);
1630 inc_waiting_locked (u
);
1632 __gthread_mutex_unlock (&unit_lock
);
1635 __gthread_mutex_lock (&u
->lock
);
1638 __gthread_mutex_lock (&unit_lock
);
1639 __gthread_mutex_unlock (&u
->lock
);
1640 if (predec_waiting_locked (u
) == 0)
1645 dec_waiting_unlocked (u
);
1653 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1657 if (u
->unit_number
> min_unit
)
1659 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1663 if (u
->unit_number
>= min_unit
)
1665 if (__gthread_mutex_trylock (&u
->lock
))
1669 __gthread_mutex_unlock (&u
->lock
);
1677 flush_all_units (void)
1682 __gthread_mutex_lock (&unit_lock
);
1685 u
= flush_all_units_1 (unit_root
, min_unit
);
1687 inc_waiting_locked (u
);
1688 __gthread_mutex_unlock (&unit_lock
);
1692 __gthread_mutex_lock (&u
->lock
);
1694 min_unit
= u
->unit_number
+ 1;
1699 __gthread_mutex_lock (&unit_lock
);
1700 __gthread_mutex_unlock (&u
->lock
);
1701 (void) predec_waiting_locked (u
);
1705 __gthread_mutex_lock (&unit_lock
);
1706 __gthread_mutex_unlock (&u
->lock
);
1707 if (predec_waiting_locked (u
) == 0)
1715 /* delete_file()-- Given a unit structure, delete the file associated
1716 * with the unit. Returns nonzero if something went wrong. */
1719 delete_file (gfc_unit
* u
)
1721 char *path
= fc_strdup (u
->file
, u
->file_len
);
1722 int err
= unlink (path
);
1728 /* file_exists()-- Returns nonzero if the current filename exists on
1732 file_exists (const char *file
, gfc_charlen_type file_len
)
1734 char *path
= fc_strdup (file
, file_len
);
1735 int res
= !(access (path
, F_OK
));
1741 /* file_size()-- Returns the size of the file. */
1744 file_size (const char *file
, gfc_charlen_type file_len
)
1746 char *path
= fc_strdup (file
, file_len
);
1747 struct stat statbuf
;
1748 int err
= stat (path
, &statbuf
);
1752 return (GFC_IO_INT
) statbuf
.st_size
;
1755 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1757 /* inquire_sequential()-- Given a fortran string, determine if the
1758 * file is suitable for sequential access. Returns a C-style
1762 inquire_sequential (const char *string
, int len
)
1764 struct stat statbuf
;
1769 char *path
= fc_strdup (string
, len
);
1770 int err
= stat (path
, &statbuf
);
1775 if (S_ISREG (statbuf
.st_mode
) ||
1776 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1779 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1786 /* inquire_direct()-- Given a fortran string, determine if the file is
1787 * suitable for direct access. Returns a C-style string. */
1790 inquire_direct (const char *string
, int len
)
1792 struct stat statbuf
;
1797 char *path
= fc_strdup (string
, len
);
1798 int err
= stat (path
, &statbuf
);
1803 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1806 if (S_ISDIR (statbuf
.st_mode
) ||
1807 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1814 /* inquire_formatted()-- Given a fortran string, determine if the file
1815 * is suitable for formatted form. Returns a C-style string. */
1818 inquire_formatted (const char *string
, int len
)
1820 struct stat statbuf
;
1825 char *path
= fc_strdup (string
, len
);
1826 int err
= stat (path
, &statbuf
);
1831 if (S_ISREG (statbuf
.st_mode
) ||
1832 S_ISBLK (statbuf
.st_mode
) ||
1833 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1836 if (S_ISDIR (statbuf
.st_mode
))
1843 /* inquire_unformatted()-- Given a fortran string, determine if the file
1844 * is suitable for unformatted form. Returns a C-style string. */
1847 inquire_unformatted (const char *string
, int len
)
1849 return inquire_formatted (string
, len
);
1853 /* inquire_access()-- Given a fortran string, determine if the file is
1854 * suitable for access. */
1857 inquire_access (const char *string
, int len
, int mode
)
1861 char *path
= fc_strdup (string
, len
);
1862 int res
= access (path
, mode
);
1871 /* inquire_read()-- Given a fortran string, determine if the file is
1872 * suitable for READ access. */
1875 inquire_read (const char *string
, int len
)
1877 return inquire_access (string
, len
, R_OK
);
1881 /* inquire_write()-- Given a fortran string, determine if the file is
1882 * suitable for READ access. */
1885 inquire_write (const char *string
, int len
)
1887 return inquire_access (string
, len
, W_OK
);
1891 /* inquire_readwrite()-- Given a fortran string, determine if the file is
1892 * suitable for read and write access. */
1895 inquire_readwrite (const char *string
, int len
)
1897 return inquire_access (string
, len
, R_OK
| W_OK
);
1902 stream_isatty (stream
*s
)
1904 return isatty (((unix_stream
*) s
)->fd
);
1908 stream_ttyname (stream
*s
__attribute__ ((unused
)),
1909 char * buf
__attribute__ ((unused
)),
1910 size_t buflen
__attribute__ ((unused
)))
1912 #ifdef HAVE_TTYNAME_R
1913 return ttyname_r (((unix_stream
*) s
)->fd
, buf
, buflen
);
1914 #elif defined HAVE_TTYNAME
1917 p
= ttyname (((unix_stream
*) s
)->fd
);
1923 memcpy (buf
, p
, plen
);
1933 /* How files are stored: This is an operating-system specific issue,
1934 and therefore belongs here. There are three cases to consider.
1937 Records are written as block of bytes corresponding to the record
1938 length of the file. This goes for both formatted and unformatted
1939 records. Positioning is done explicitly for each data transfer,
1940 so positioning is not much of an issue.
1942 Sequential Formatted:
1943 Records are separated by newline characters. The newline character
1944 is prohibited from appearing in a string. If it does, this will be
1945 messed up on the next read. End of file is also the end of a record.
1947 Sequential Unformatted:
1948 In this case, we are merely copying bytes to and from main storage,
1949 yet we need to keep track of varying record lengths. We adopt
1950 the solution used by f2c. Each record contains a pair of length
1953 Length of record n in bytes
1955 Length of record n in bytes
1957 Length of record n+1 in bytes
1959 Length of record n+1 in bytes
1961 The length is stored at the end of a record to allow backspacing to the
1962 previous record. Between data transfer statements, the file pointer
1963 is left pointing to the first length of the current record.
1965 ENDFILE records are never explicitly stored.