1 /* Copyright (C) 2002-2016 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 */
43 /* For mingw, we don't identify files by their inode number, but by a
44 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
47 #define WIN32_LEAN_AND_MEAN
50 #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
52 #define lseek _lseeki64
54 #define fstat _fstati64
59 #ifndef HAVE_WORKING_STAT
61 id_from_handle (HANDLE hFile
)
63 BY_HANDLE_FILE_INFORMATION FileInformation
;
65 if (hFile
== INVALID_HANDLE_VALUE
)
68 memset (&FileInformation
, 0, sizeof(FileInformation
));
69 if (!GetFileInformationByHandle (hFile
, &FileInformation
))
72 return ((uint64_t) FileInformation
.nFileIndexLow
)
73 | (((uint64_t) FileInformation
.nFileIndexHigh
) << 32);
78 id_from_path (const char *path
)
83 if (!path
|| !*path
|| access (path
, F_OK
))
86 hFile
= CreateFile (path
, 0, 0, NULL
, OPEN_EXISTING
,
87 FILE_FLAG_BACKUP_SEMANTICS
| FILE_ATTRIBUTE_READONLY
,
89 res
= id_from_handle (hFile
);
96 id_from_fd (const int fd
)
98 return id_from_handle ((HANDLE
) _get_osfhandle (fd
));
101 #endif /* HAVE_WORKING_STAT */
104 /* On mingw, we don't use umask in tempfile_open(), because it
105 doesn't support the user/group/other-based permissions. */
108 #endif /* __MINGW32__ */
111 /* These flags aren't defined on all targets (mingw32), so provide them
144 /* Fallback implementation of access() on systems that don't have it.
145 Only modes R_OK, W_OK and F_OK are used in this file. */
148 fallback_access (const char *path
, int mode
)
152 if ((mode
& R_OK
) && (fd
= open (path
, O_RDONLY
)) < 0)
156 if ((mode
& W_OK
) && (fd
= open (path
, O_WRONLY
)) < 0)
163 return stat (path
, &st
);
170 #define access fallback_access
174 /* Fallback directory for creating temporary files. P_tmpdir is
175 defined on many POSIX platforms. */
178 #define P_tmpdir _P_tmpdir /* MinGW */
180 #define P_tmpdir "/tmp"
185 /* Unix and internal stream I/O module */
187 static const int BUFFER_SIZE
= 8192;
193 gfc_offset buffer_offset
; /* File offset of the start of the buffer */
194 gfc_offset physical_offset
; /* Current physical file offset */
195 gfc_offset logical_offset
; /* Current logical file offset */
196 gfc_offset file_length
; /* Length of the file. */
198 char *buffer
; /* Pointer to the buffer. */
199 int fd
; /* The POSIX file descriptor. */
201 int active
; /* Length of valid bytes in the buffer */
203 int ndirty
; /* Dirty bytes starting at buffer_offset */
205 /* Cached stat(2) values. */
209 bool unbuffered
; /* Buffer should be flushed after each I/O statement. */
214 /* fix_fd()-- Given a file descriptor, make sure it is not one of the
215 * standard descriptors, returning a non-standard descriptor. If the
216 * user specifies that system errors should go to standard output,
217 * then closes standard output, we don't want the system errors to a
218 * file that has been given file descriptor 1 or 0. We want to send
219 * the error to the invalid descriptor. */
225 int input
, output
, error
;
227 input
= output
= error
= 0;
229 /* Unix allocates the lowest descriptors first, so a loop is not
230 required, but this order is. */
231 if (fd
== STDIN_FILENO
)
236 if (fd
== STDOUT_FILENO
)
241 if (fd
== STDERR_FILENO
)
248 close (STDIN_FILENO
);
250 close (STDOUT_FILENO
);
252 close (STDERR_FILENO
);
259 /* If the stream corresponds to a preconnected unit, we flush the
260 corresponding C stream. This is bugware for mixed C-Fortran codes
261 where the C code doesn't flush I/O before returning. */
263 flush_if_preconnected (stream
* s
)
267 fd
= ((unix_stream
*) s
)->fd
;
268 if (fd
== STDIN_FILENO
)
270 else if (fd
== STDOUT_FILENO
)
272 else if (fd
== STDERR_FILENO
)
277 /********************************************************************
278 Raw I/O functions (read, write, seek, tell, truncate, close).
280 These functions wrap the basic POSIX I/O syscalls. Any deviation in
281 semantics is a bug, except the following: write restarts in case
282 of being interrupted by a signal, and as the first argument the
283 functions take the unix_stream struct rather than an integer file
284 descriptor. Also, for POSIX read() and write() a nbyte argument larger
285 than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
286 than size_t as for POSIX read/write.
287 *********************************************************************/
290 raw_flush (unix_stream
* s
__attribute__ ((unused
)))
296 raw_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
298 /* For read we can't do I/O in a loop like raw_write does, because
299 that will break applications that wait for interactive I/O. We
300 still can loop around EINTR, though. */
303 ssize_t trans
= read (s
->fd
, buf
, nbyte
);
304 if (trans
== -1 && errno
== EINTR
)
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
)
343 gfc_offset off
= lseek (s
->fd
, offset
, whence
);
344 if (off
== (gfc_offset
) -1 && errno
== EINTR
)
351 raw_tell (unix_stream
* s
)
355 gfc_offset off
= lseek (s
->fd
, 0, SEEK_CUR
);
356 if (off
== (gfc_offset
) -1 && errno
== EINTR
)
363 raw_size (unix_stream
* s
)
366 if (TEMP_FAILURE_RETRY (fstat (s
->fd
, &statbuf
)) == -1)
368 if (S_ISREG (statbuf
.st_mode
))
369 return statbuf
.st_size
;
375 raw_truncate (unix_stream
* s
, gfc_offset length
)
386 h
= (HANDLE
) _get_osfhandle (s
->fd
);
387 if (h
== INVALID_HANDLE_VALUE
)
392 cur
= lseek (s
->fd
, 0, SEEK_CUR
);
395 if (lseek (s
->fd
, length
, SEEK_SET
) == -1)
397 if (!SetEndOfFile (h
))
402 if (lseek (s
->fd
, cur
, SEEK_SET
) == -1)
406 lseek (s
->fd
, cur
, SEEK_SET
);
408 #elif defined HAVE_FTRUNCATE
409 if (TEMP_FAILURE_RETRY (ftruncate (s
->fd
, length
)) == -1)
412 #elif defined HAVE_CHSIZE
413 return chsize (s
->fd
, length
);
415 runtime_error ("required ftruncate or chsize support not present");
421 raw_close (unix_stream
* s
)
427 else if (s
->fd
!= STDOUT_FILENO
428 && s
->fd
!= STDERR_FILENO
429 && s
->fd
!= STDIN_FILENO
)
431 retval
= close (s
->fd
);
432 /* close() and EINTR is special, as the file descriptor is
433 deallocated before doing anything that might cause the
434 operation to be interrupted. Thus if we get EINTR the best we
435 can do is ignore it and continue (otherwise if we try again
436 the file descriptor may have been allocated again to some
438 if (retval
== -1 && errno
== EINTR
)
448 raw_markeor (unix_stream
* s
__attribute__ ((unused
)))
453 static const struct stream_vtable raw_vtable
= {
454 .read
= (void *) raw_read
,
455 .write
= (void *) raw_write
,
456 .seek
= (void *) raw_seek
,
457 .tell
= (void *) raw_tell
,
458 .size
= (void *) raw_size
,
459 .trunc
= (void *) raw_truncate
,
460 .close
= (void *) raw_close
,
461 .flush
= (void *) raw_flush
,
462 .markeor
= (void *) raw_markeor
466 raw_init (unix_stream
* s
)
468 s
->st
.vptr
= &raw_vtable
;
475 /*********************************************************************
476 Buffered I/O functions. These functions have the same semantics as the
477 raw I/O functions above, except that they are buffered in order to
478 improve performance. The buffer must be flushed when switching from
479 reading to writing and vice versa.
480 *********************************************************************/
483 buf_flush (unix_stream
* s
)
487 /* Flushing in read mode means discarding read bytes. */
493 if (s
->physical_offset
!= s
->buffer_offset
494 && raw_seek (s
, s
->buffer_offset
, SEEK_SET
) < 0)
497 writelen
= raw_write (s
, s
->buffer
, s
->ndirty
);
499 s
->physical_offset
= s
->buffer_offset
+ writelen
;
501 if (s
->physical_offset
> s
->file_length
)
502 s
->file_length
= s
->physical_offset
;
504 s
->ndirty
-= writelen
;
512 buf_read (unix_stream
* s
, void * buf
, ssize_t nbyte
)
515 s
->buffer_offset
= s
->logical_offset
;
517 /* Is the data we want in the buffer? */
518 if (s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ s
->active
519 && s
->buffer_offset
<= s
->logical_offset
)
521 /* When nbyte == 0, buf can be NULL which would lead to undefined
522 behavior if we called memcpy(). */
524 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
529 /* First copy the active bytes if applicable, then read the rest
530 either directly or filling the buffer. */
533 ssize_t to_read
, did_read
;
534 gfc_offset new_logical
;
537 if (s
->logical_offset
>= s
->buffer_offset
538 && s
->buffer_offset
+ s
->active
>= s
->logical_offset
)
540 nread
= s
->active
- (s
->logical_offset
- s
->buffer_offset
);
541 memcpy (buf
, s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
),
545 /* At this point we consider all bytes in the buffer discarded. */
546 to_read
= nbyte
- nread
;
547 new_logical
= s
->logical_offset
+ nread
;
548 if (s
->physical_offset
!= new_logical
549 && raw_seek (s
, new_logical
, SEEK_SET
) < 0)
551 s
->buffer_offset
= s
->physical_offset
= new_logical
;
552 if (to_read
<= BUFFER_SIZE
/2)
554 did_read
= raw_read (s
, s
->buffer
, BUFFER_SIZE
);
555 if (likely (did_read
>= 0))
557 s
->physical_offset
+= did_read
;
558 s
->active
= did_read
;
559 did_read
= (did_read
> to_read
) ? to_read
: did_read
;
560 memcpy (p
, s
->buffer
, did_read
);
567 did_read
= raw_read (s
, p
, to_read
);
568 if (likely (did_read
>= 0))
570 s
->physical_offset
+= did_read
;
576 nbyte
= did_read
+ nread
;
578 s
->logical_offset
+= nbyte
;
583 buf_write (unix_stream
* s
, const void * buf
, ssize_t nbyte
)
586 s
->buffer_offset
= s
->logical_offset
;
588 /* Does the data fit into the buffer? As a special case, if the
589 buffer is empty and the request is bigger than BUFFER_SIZE/2,
590 write directly. This avoids the case where the buffer would have
591 to be flushed at every write. */
592 if (!(s
->ndirty
== 0 && nbyte
> BUFFER_SIZE
/2)
593 && s
->logical_offset
+ nbyte
<= s
->buffer_offset
+ BUFFER_SIZE
594 && s
->buffer_offset
<= s
->logical_offset
595 && s
->buffer_offset
+ s
->ndirty
>= s
->logical_offset
)
597 memcpy (s
->buffer
+ (s
->logical_offset
- s
->buffer_offset
), buf
, nbyte
);
598 int nd
= (s
->logical_offset
- s
->buffer_offset
) + nbyte
;
604 /* Flush, and either fill the buffer with the new data, or if
605 the request is bigger than the buffer size, write directly
606 bypassing the buffer. */
608 if (nbyte
<= BUFFER_SIZE
/2)
610 memcpy (s
->buffer
, buf
, nbyte
);
611 s
->buffer_offset
= s
->logical_offset
;
616 if (s
->physical_offset
!= s
->logical_offset
)
618 if (raw_seek (s
, s
->logical_offset
, SEEK_SET
) < 0)
620 s
->physical_offset
= s
->logical_offset
;
623 nbyte
= raw_write (s
, buf
, nbyte
);
624 s
->physical_offset
+= nbyte
;
627 s
->logical_offset
+= nbyte
;
628 if (s
->logical_offset
> s
->file_length
)
629 s
->file_length
= s
->logical_offset
;
634 /* "Unbuffered" really means I/O statement buffering. For formatted
635 I/O, the fbuf manages this, and then uses raw I/O. For unformatted
636 I/O, buffered I/O is used, and the buffer is flushed at the end of
637 each I/O statement, where this function is called. Alternatively,
638 the buffer is flushed at the end of the record if the buffer is
639 more than half full; this prevents needless seeking back and forth
640 when writing sequential unformatted. */
643 buf_markeor (unix_stream
* s
)
645 if (s
->unbuffered
|| s
->ndirty
>= BUFFER_SIZE
/ 2)
646 return buf_flush (s
);
651 buf_seek (unix_stream
* s
, gfc_offset offset
, int whence
)
658 offset
+= s
->logical_offset
;
661 offset
+= s
->file_length
;
671 s
->logical_offset
= offset
;
676 buf_tell (unix_stream
* s
)
678 return buf_seek (s
, 0, SEEK_CUR
);
682 buf_size (unix_stream
* s
)
684 return s
->file_length
;
688 buf_truncate (unix_stream
* s
, gfc_offset length
)
692 if (buf_flush (s
) != 0)
694 r
= raw_truncate (s
, length
);
696 s
->file_length
= length
;
701 buf_close (unix_stream
* s
)
703 if (buf_flush (s
) != 0)
706 return raw_close (s
);
709 static const struct stream_vtable buf_vtable
= {
710 .read
= (void *) buf_read
,
711 .write
= (void *) buf_write
,
712 .seek
= (void *) buf_seek
,
713 .tell
= (void *) buf_tell
,
714 .size
= (void *) buf_size
,
715 .trunc
= (void *) buf_truncate
,
716 .close
= (void *) buf_close
,
717 .flush
= (void *) buf_flush
,
718 .markeor
= (void *) buf_markeor
722 buf_init (unix_stream
* s
)
724 s
->st
.vptr
= &buf_vtable
;
726 s
->buffer
= xmalloc (BUFFER_SIZE
);
731 /*********************************************************************
732 memory stream functions - These are used for internal files
734 The idea here is that a single stream structure is created and all
735 requests must be satisfied from it. The location and size of the
736 buffer is the character variable supplied to the READ or WRITE
739 *********************************************************************/
742 mem_alloc_r (stream
* strm
, int * len
)
744 unix_stream
* s
= (unix_stream
*) strm
;
746 gfc_offset where
= s
->logical_offset
;
748 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
751 n
= s
->buffer_offset
+ s
->active
- where
;
755 s
->logical_offset
= where
+ *len
;
757 return s
->buffer
+ (where
- s
->buffer_offset
);
762 mem_alloc_r4 (stream
* strm
, int * len
)
764 unix_stream
* s
= (unix_stream
*) strm
;
766 gfc_offset where
= s
->logical_offset
;
768 if (where
< s
->buffer_offset
|| where
> s
->buffer_offset
+ s
->active
)
771 n
= s
->buffer_offset
+ s
->active
- where
;
775 s
->logical_offset
= where
+ *len
;
777 return s
->buffer
+ (where
- s
->buffer_offset
) * 4;
782 mem_alloc_w (stream
* strm
, int * len
)
784 unix_stream
* s
= (unix_stream
*) strm
;
786 gfc_offset where
= s
->logical_offset
;
790 if (where
< s
->buffer_offset
)
793 if (m
> s
->file_length
)
796 s
->logical_offset
= m
;
798 return s
->buffer
+ (where
- s
->buffer_offset
);
803 mem_alloc_w4 (stream
* strm
, int * len
)
805 unix_stream
* s
= (unix_stream
*) strm
;
807 gfc_offset where
= s
->logical_offset
;
808 gfc_char4_t
*result
= (gfc_char4_t
*) s
->buffer
;
812 if (where
< s
->buffer_offset
)
815 if (m
> s
->file_length
)
818 s
->logical_offset
= m
;
819 return &result
[where
- s
->buffer_offset
];
823 /* Stream read function for character(kind=1) internal units. */
826 mem_read (stream
* s
, void * buf
, ssize_t nbytes
)
831 p
= mem_alloc_r (s
, &nb
);
842 /* Stream read function for chracter(kind=4) internal units. */
845 mem_read4 (stream
* s
, void * buf
, ssize_t nbytes
)
850 p
= mem_alloc_r4 (s
, &nb
);
853 memcpy (buf
, p
, nb
* 4);
861 /* Stream write function for character(kind=1) internal units. */
864 mem_write (stream
* s
, const void * buf
, ssize_t nbytes
)
869 p
= mem_alloc_w (s
, &nb
);
880 /* Stream write function for character(kind=4) internal units. */
883 mem_write4 (stream
* s
, const void * buf
, ssize_t nwords
)
888 p
= mem_alloc_w4 (s
, &nw
);
892 *p
++ = (gfc_char4_t
) *((char *) buf
);
901 mem_seek (stream
* strm
, gfc_offset offset
, int whence
)
903 unix_stream
* s
= (unix_stream
*) strm
;
909 offset
+= s
->logical_offset
;
912 offset
+= s
->file_length
;
918 /* Note that for internal array I/O it's actually possible to have a
919 negative offset, so don't check for that. */
920 if (offset
> s
->file_length
)
926 s
->logical_offset
= offset
;
928 /* Returning < 0 is the error indicator for sseek(), so return 0 if
929 offset is negative. Thus if the return value is 0, the caller
930 has to use stell() to get the real value of logical_offset. */
938 mem_tell (stream
* s
)
940 return ((unix_stream
*)s
)->logical_offset
;
945 mem_truncate (unix_stream
* s
__attribute__ ((unused
)),
946 gfc_offset length
__attribute__ ((unused
)))
953 mem_flush (unix_stream
* s
__attribute__ ((unused
)))
960 mem_close (unix_stream
* s
)
967 static const struct stream_vtable mem_vtable
= {
968 .read
= (void *) mem_read
,
969 .write
= (void *) mem_write
,
970 .seek
= (void *) mem_seek
,
971 .tell
= (void *) mem_tell
,
972 /* buf_size is not a typo, we just reuse an identical
974 .size
= (void *) buf_size
,
975 .trunc
= (void *) mem_truncate
,
976 .close
= (void *) mem_close
,
977 .flush
= (void *) mem_flush
,
978 .markeor
= (void *) raw_markeor
981 static const struct stream_vtable mem4_vtable
= {
982 .read
= (void *) mem_read4
,
983 .write
= (void *) mem_write4
,
984 .seek
= (void *) mem_seek
,
985 .tell
= (void *) mem_tell
,
986 /* buf_size is not a typo, we just reuse an identical
988 .size
= (void *) buf_size
,
989 .trunc
= (void *) mem_truncate
,
990 .close
= (void *) mem_close
,
991 .flush
= (void *) mem_flush
,
992 .markeor
= (void *) raw_markeor
995 /*********************************************************************
996 Public functions -- A reimplementation of this module needs to
997 define functional equivalents of the following.
998 *********************************************************************/
1000 /* open_internal()-- Returns a stream structure from a character(kind=1)
1004 open_internal (char *base
, int length
, gfc_offset offset
)
1008 s
= xcalloc (1, sizeof (unix_stream
));
1011 s
->buffer_offset
= offset
;
1013 s
->active
= s
->file_length
= length
;
1015 s
->st
.vptr
= &mem_vtable
;
1017 return (stream
*) s
;
1020 /* open_internal4()-- Returns a stream structure from a character(kind=4)
1024 open_internal4 (char *base
, int length
, gfc_offset offset
)
1028 s
= xcalloc (1, sizeof (unix_stream
));
1031 s
->buffer_offset
= offset
;
1033 s
->active
= s
->file_length
= length
* sizeof (gfc_char4_t
);
1035 s
->st
.vptr
= &mem4_vtable
;
1037 return (stream
*) s
;
1041 /* fd_to_stream()-- Given an open file descriptor, build a stream
1045 fd_to_stream (int fd
, bool unformatted
)
1047 struct stat statbuf
;
1050 s
= xcalloc (1, sizeof (unix_stream
));
1054 /* Get the current length of the file. */
1056 if (TEMP_FAILURE_RETRY (fstat (fd
, &statbuf
)) == -1)
1058 s
->st_dev
= s
->st_ino
= -1;
1063 return (stream
*) s
;
1066 s
->st_dev
= statbuf
.st_dev
;
1067 s
->st_ino
= statbuf
.st_ino
;
1068 s
->file_length
= statbuf
.st_size
;
1070 /* Only use buffered IO for regular files. */
1071 if (S_ISREG (statbuf
.st_mode
)
1072 && !options
.all_unbuffered
1073 && !(options
.unbuffered_preconnected
&&
1074 (s
->fd
== STDIN_FILENO
1075 || s
->fd
== STDOUT_FILENO
1076 || s
->fd
== STDERR_FILENO
)))
1082 s
->unbuffered
= true;
1089 return (stream
*) s
;
1093 /* Given the Fortran unit number, convert it to a C file descriptor. */
1096 unit_to_fd (int unit
)
1101 us
= find_unit (unit
);
1105 fd
= ((unix_stream
*) us
->s
)->fd
;
1111 /* Set the close-on-exec flag for an existing fd, if the system
1114 static void __attribute__ ((unused
))
1115 set_close_on_exec (int fd
__attribute__ ((unused
)))
1117 /* Mingw does not define F_SETFD. */
1118 #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1120 fcntl(fd
, F_SETFD
, FD_CLOEXEC
);
1125 /* Helper function for tempfile(). Tries to open a temporary file in
1126 the directory specified by tempdir. If successful, the file name is
1127 stored in fname and the descriptor returned. Returns -1 on
1131 tempfile_open (const char *tempdir
, char **fname
)
1134 const char *slash
= "/";
1135 #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1142 /* Check for the special case that tempdir ends with a slash or
1144 size_t tempdirlen
= strlen (tempdir
);
1145 if (*tempdir
== 0 || tempdir
[tempdirlen
- 1] == '/'
1147 || tempdir
[tempdirlen
- 1] == '\\'
1152 /* Take care that the template is longer in the mktemp() branch. */
1153 char * template = xmalloc (tempdirlen
+ 23);
1156 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpXXXXXX",
1160 /* Temporarily set the umask such that the file has 0600 permissions. */
1161 mode_mask
= umask (S_IXUSR
| S_IRWXG
| S_IRWXO
);
1164 #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1165 TEMP_FAILURE_RETRY (fd
= mkostemp (template, O_CLOEXEC
));
1167 TEMP_FAILURE_RETRY (fd
= mkstemp (template));
1168 set_close_on_exec (fd
);
1172 (void) umask (mode_mask
);
1175 #else /* HAVE_MKSTEMP */
1178 size_t slashlen
= strlen (slash
);
1179 int flags
= O_RDWR
| O_CREAT
| O_EXCL
;
1180 #if defined(HAVE_CRLF) && defined(O_BINARY)
1188 snprintf (template, tempdirlen
+ 23, "%s%sgfortrantmpaaaXXXXXX",
1193 template[tempdirlen
+ slashlen
+ 13] = 'a' + (c
% 26);
1195 template[tempdirlen
+ slashlen
+ 12] = 'a' + (c
% 26);
1197 template[tempdirlen
+ slashlen
+ 11] = 'a' + (c
% 26);
1202 if (!mktemp (template))
1209 TEMP_FAILURE_RETRY (fd
= open (template, flags
, S_IRUSR
| S_IWUSR
));
1211 while (fd
== -1 && errno
== EEXIST
);
1213 set_close_on_exec (fd
);
1215 #endif /* HAVE_MKSTEMP */
1222 /* tempfile()-- Generate a temporary filename for a scratch file and
1223 * open it. mkstemp() opens the file for reading and writing, but the
1224 * library mode prevents anything that is not allowed. The descriptor
1225 * is returned, which is -1 on error. The template is pointed to by
1226 * opp->file, which is copied into the unit structure
1227 * and freed later. */
1230 tempfile (st_parameter_open
*opp
)
1232 const char *tempdir
;
1236 tempdir
= secure_getenv ("TMPDIR");
1237 fd
= tempfile_open (tempdir
, &fname
);
1241 char buffer
[MAX_PATH
+ 1];
1243 ret
= GetTempPath (MAX_PATH
, buffer
);
1244 /* If we are not able to get a temp-directory, we use
1245 current directory. */
1246 if (ret
> MAX_PATH
|| !ret
)
1250 tempdir
= strdup (buffer
);
1251 fd
= tempfile_open (tempdir
, &fname
);
1253 #elif defined(__CYGWIN__)
1256 tempdir
= secure_getenv ("TMP");
1257 fd
= tempfile_open (tempdir
, &fname
);
1261 tempdir
= secure_getenv ("TEMP");
1262 fd
= tempfile_open (tempdir
, &fname
);
1266 fd
= tempfile_open (P_tmpdir
, &fname
);
1269 opp
->file_len
= strlen (fname
); /* Don't include trailing nul */
1275 /* regular_file2()-- Open a regular file.
1276 * Change flags->action if it is ACTION_UNSPECIFIED on entry,
1277 * unless an error occurs.
1278 * Returns the descriptor, which is less than zero on error. */
1281 regular_file2 (const char *path
, st_parameter_open
*opp
, unit_flags
*flags
)
1285 int crflag
, crflag2
;
1289 if (opp
->file_len
== 7)
1291 if (strncmp (path
, "CONOUT$", 7) == 0
1292 || strncmp (path
, "CONERR$", 7) == 0)
1294 fd
= open ("/dev/conout", O_WRONLY
);
1295 flags
->action
= ACTION_WRITE
;
1300 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1302 fd
= open ("/dev/conin", O_RDONLY
);
1303 flags
->action
= ACTION_READ
;
1310 if (opp
->file_len
== 7)
1312 if (strncmp (path
, "CONOUT$", 7) == 0
1313 || strncmp (path
, "CONERR$", 7) == 0)
1315 fd
= open ("CONOUT$", O_WRONLY
);
1316 flags
->action
= ACTION_WRITE
;
1321 if (opp
->file_len
== 6 && strncmp (path
, "CONIN$", 6) == 0)
1323 fd
= open ("CONIN$", O_RDONLY
);
1324 flags
->action
= ACTION_READ
;
1329 switch (flags
->action
)
1339 case ACTION_READWRITE
:
1340 case ACTION_UNSPECIFIED
:
1345 internal_error (&opp
->common
, "regular_file(): Bad action");
1348 switch (flags
->status
)
1351 crflag
= O_CREAT
| O_EXCL
;
1354 case STATUS_OLD
: /* open will fail if the file does not exist*/
1358 case STATUS_UNKNOWN
:
1359 if (rwflag
== O_RDONLY
)
1365 case STATUS_REPLACE
:
1366 crflag
= O_CREAT
| O_TRUNC
;
1370 /* Note: STATUS_SCRATCH is handled by tempfile () and should
1371 never be seen here. */
1372 internal_error (&opp
->common
, "regular_file(): Bad status");
1375 /* rwflag |= O_LARGEFILE; */
1377 #if defined(HAVE_CRLF) && defined(O_BINARY)
1382 crflag
|= O_CLOEXEC
;
1385 mode
= S_IRUSR
| S_IWUSR
| S_IRGRP
| S_IWGRP
| S_IROTH
| S_IWOTH
;
1386 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag
, mode
));
1387 if (flags
->action
!= ACTION_UNSPECIFIED
)
1392 flags
->action
= ACTION_READWRITE
;
1395 if (errno
!= EACCES
&& errno
!= EPERM
&& errno
!= EROFS
)
1398 /* retry for read-only access */
1400 if (flags
->status
== STATUS_UNKNOWN
)
1401 crflag2
= crflag
& ~(O_CREAT
);
1404 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag2
, mode
));
1407 flags
->action
= ACTION_READ
;
1408 return fd
; /* success */
1411 if (errno
!= EACCES
&& errno
!= EPERM
&& errno
!= ENOENT
)
1412 return fd
; /* failure */
1414 /* retry for write-only access */
1416 TEMP_FAILURE_RETRY (fd
= open (path
, rwflag
| crflag
, mode
));
1419 flags
->action
= ACTION_WRITE
;
1420 return fd
; /* success */
1422 return fd
; /* failure */
1426 /* Lock the file, if necessary, based on SHARE flags. */
1428 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1430 open_share (st_parameter_open
*opp
, int fd
, unit_flags
*flags
)
1434 if (fd
== STDOUT_FILENO
|| fd
== STDERR_FILENO
|| fd
== STDIN_FILENO
)
1439 f
.l_whence
= SEEK_SET
;
1441 switch (flags
->share
)
1443 case SHARE_DENYNONE
:
1445 r
= fcntl (fd
, F_SETLK
, &f
);
1448 /* Must be writable to hold write lock. */
1449 if (flags
->action
== ACTION_READ
)
1451 generate_error (&opp
->common
, LIBERROR_BAD_ACTION
,
1452 "Cannot set write lock on file opened for READ");
1456 r
= fcntl (fd
, F_SETLK
, &f
);
1458 case SHARE_UNSPECIFIED
:
1467 open_share (st_parameter_open
*opp
__attribute__ ((unused
)),
1468 int fd
__attribute__ ((unused
)),
1469 unit_flags
*flags
__attribute__ ((unused
)))
1473 #endif /* defined(HAVE_FCNTL) ... */
1476 /* Wrapper around regular_file2, to make sure we free the path after
1480 regular_file (st_parameter_open
*opp
, unit_flags
*flags
)
1482 char *path
= fc_strdup (opp
->file
, opp
->file_len
);
1483 int fd
= regular_file2 (path
, opp
, flags
);
1488 /* open_external()-- Open an external file, unix specific version.
1489 * Change flags->action if it is ACTION_UNSPECIFIED on entry.
1490 * Returns NULL on operating system error. */
1493 open_external (st_parameter_open
*opp
, unit_flags
*flags
)
1497 if (flags
->status
== STATUS_SCRATCH
)
1499 fd
= tempfile (opp
);
1500 if (flags
->action
== ACTION_UNSPECIFIED
)
1501 flags
->action
= flags
->readonly
? ACTION_READ
: ACTION_READWRITE
;
1503 #if HAVE_UNLINK_OPEN_FILE
1504 /* We can unlink scratch files now and it will go away when closed. */
1511 /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1513 fd
= regular_file (opp
, flags
);
1515 set_close_on_exec (fd
);
1523 if (open_share (opp
, fd
, flags
) < 0)
1526 return fd_to_stream (fd
, flags
->form
== FORM_UNFORMATTED
);
1530 /* input_stream()-- Return a stream pointer to the default input stream.
1531 * Called on initialization. */
1536 return fd_to_stream (STDIN_FILENO
, false);
1540 /* output_stream()-- Return a stream pointer to the default output stream.
1541 * Called on initialization. */
1544 output_stream (void)
1548 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1549 setmode (STDOUT_FILENO
, O_BINARY
);
1552 s
= fd_to_stream (STDOUT_FILENO
, false);
1557 /* error_stream()-- Return a stream pointer to the default error stream.
1558 * Called on initialization. */
1565 #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1566 setmode (STDERR_FILENO
, O_BINARY
);
1569 s
= fd_to_stream (STDERR_FILENO
, false);
1574 /* compare_file_filename()-- Given an open stream and a fortran string
1575 * that is a filename, figure out if the file is the same as the
1579 compare_file_filename (gfc_unit
*u
, const char *name
, int len
)
1583 #ifdef HAVE_WORKING_STAT
1591 char *path
= fc_strdup (name
, len
);
1593 /* If the filename doesn't exist, then there is no match with the
1596 if (TEMP_FAILURE_RETRY (stat (path
, &st
)) < 0)
1602 #ifdef HAVE_WORKING_STAT
1603 s
= (unix_stream
*) (u
->s
);
1604 ret
= (st
.st_dev
== s
->st_dev
) && (st
.st_ino
== s
->st_ino
);
1609 /* We try to match files by a unique ID. On some filesystems (network
1610 fs and FAT), we can't generate this unique ID, and will simply compare
1612 id1
= id_from_path (path
);
1613 id2
= id_from_fd (((unix_stream
*) (u
->s
))->fd
);
1621 ret
= (strcmp(path
, u
->filename
) == 0);
1631 #ifdef HAVE_WORKING_STAT
1632 # define FIND_FILE0_DECL struct stat *st
1633 # define FIND_FILE0_ARGS st
1635 # define FIND_FILE0_DECL uint64_t id, const char *path
1636 # define FIND_FILE0_ARGS id, path
1639 /* find_file0()-- Recursive work function for find_file() */
1642 find_file0 (gfc_unit
*u
, FIND_FILE0_DECL
)
1645 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1652 #ifdef HAVE_WORKING_STAT
1655 unix_stream
*s
= (unix_stream
*) (u
->s
);
1656 if (st
[0].st_dev
== s
->st_dev
&& st
[0].st_ino
== s
->st_ino
)
1661 if (u
->s
&& ((id1
= id_from_fd (((unix_stream
*) u
->s
)->fd
)) || id1
))
1668 if (u
->filename
&& strcmp (u
->filename
, path
) == 0)
1672 v
= find_file0 (u
->left
, FIND_FILE0_ARGS
);
1676 v
= find_file0 (u
->right
, FIND_FILE0_ARGS
);
1684 /* find_file()-- Take the current filename and see if there is a unit
1685 * that has the file already open. Returns a pointer to the unit if so. */
1688 find_file (const char *file
, gfc_charlen_type file_len
)
1692 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1696 char *path
= fc_strdup (file
, file_len
);
1698 if (TEMP_FAILURE_RETRY (stat (path
, &st
[0])) < 0)
1704 #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1705 id
= id_from_path (path
);
1708 __gthread_mutex_lock (&unit_lock
);
1710 u
= find_file0 (unit_root
, FIND_FILE0_ARGS
);
1714 if (! __gthread_mutex_trylock (&u
->lock
))
1716 /* assert (u->closed == 0); */
1717 __gthread_mutex_unlock (&unit_lock
);
1721 inc_waiting_locked (u
);
1723 __gthread_mutex_unlock (&unit_lock
);
1726 __gthread_mutex_lock (&u
->lock
);
1729 __gthread_mutex_lock (&unit_lock
);
1730 __gthread_mutex_unlock (&u
->lock
);
1731 if (predec_waiting_locked (u
) == 0)
1736 dec_waiting_unlocked (u
);
1744 flush_all_units_1 (gfc_unit
*u
, int min_unit
)
1748 if (u
->unit_number
> min_unit
)
1750 gfc_unit
*r
= flush_all_units_1 (u
->left
, min_unit
);
1754 if (u
->unit_number
>= min_unit
)
1756 if (__gthread_mutex_trylock (&u
->lock
))
1760 __gthread_mutex_unlock (&u
->lock
);
1768 flush_all_units (void)
1773 __gthread_mutex_lock (&unit_lock
);
1776 u
= flush_all_units_1 (unit_root
, min_unit
);
1778 inc_waiting_locked (u
);
1779 __gthread_mutex_unlock (&unit_lock
);
1783 __gthread_mutex_lock (&u
->lock
);
1785 min_unit
= u
->unit_number
+ 1;
1790 __gthread_mutex_lock (&unit_lock
);
1791 __gthread_mutex_unlock (&u
->lock
);
1792 (void) predec_waiting_locked (u
);
1796 __gthread_mutex_lock (&unit_lock
);
1797 __gthread_mutex_unlock (&u
->lock
);
1798 if (predec_waiting_locked (u
) == 0)
1806 /* Unlock the unit if necessary, based on SHARE flags. */
1809 close_share (gfc_unit
*u
__attribute__ ((unused
)))
1812 #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1813 unix_stream
*s
= (unix_stream
*) u
->s
;
1817 switch (u
->flags
.share
)
1820 case SHARE_DENYNONE
:
1821 if (fd
!= STDOUT_FILENO
&& fd
!= STDERR_FILENO
&& fd
!= STDIN_FILENO
)
1825 f
.l_whence
= SEEK_SET
;
1827 r
= fcntl (fd
, F_SETLK
, &f
);
1830 case SHARE_UNSPECIFIED
:
1840 /* file_exists()-- Returns nonzero if the current filename exists on
1844 file_exists (const char *file
, gfc_charlen_type file_len
)
1846 char *path
= fc_strdup (file
, file_len
);
1847 int res
= !(access (path
, F_OK
));
1853 /* file_size()-- Returns the size of the file. */
1856 file_size (const char *file
, gfc_charlen_type file_len
)
1858 char *path
= fc_strdup (file
, file_len
);
1859 struct stat statbuf
;
1861 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1865 return (GFC_IO_INT
) statbuf
.st_size
;
1868 static const char yes
[] = "YES", no
[] = "NO", unknown
[] = "UNKNOWN";
1870 /* inquire_sequential()-- Given a fortran string, determine if the
1871 * file is suitable for sequential access. Returns a C-style
1875 inquire_sequential (const char *string
, int len
)
1877 struct stat statbuf
;
1882 char *path
= fc_strdup (string
, len
);
1884 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1889 if (S_ISREG (statbuf
.st_mode
) ||
1890 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1893 if (S_ISDIR (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1900 /* inquire_direct()-- Given a fortran string, determine if the file is
1901 * suitable for direct access. Returns a C-style string. */
1904 inquire_direct (const char *string
, int len
)
1906 struct stat statbuf
;
1911 char *path
= fc_strdup (string
, len
);
1913 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1918 if (S_ISREG (statbuf
.st_mode
) || S_ISBLK (statbuf
.st_mode
))
1921 if (S_ISDIR (statbuf
.st_mode
) ||
1922 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1929 /* inquire_formatted()-- Given a fortran string, determine if the file
1930 * is suitable for formatted form. Returns a C-style string. */
1933 inquire_formatted (const char *string
, int len
)
1935 struct stat statbuf
;
1940 char *path
= fc_strdup (string
, len
);
1942 TEMP_FAILURE_RETRY (err
= stat (path
, &statbuf
));
1947 if (S_ISREG (statbuf
.st_mode
) ||
1948 S_ISBLK (statbuf
.st_mode
) ||
1949 S_ISCHR (statbuf
.st_mode
) || S_ISFIFO (statbuf
.st_mode
))
1952 if (S_ISDIR (statbuf
.st_mode
))
1959 /* inquire_unformatted()-- Given a fortran string, determine if the file
1960 * is suitable for unformatted form. Returns a C-style string. */
1963 inquire_unformatted (const char *string
, int len
)
1965 return inquire_formatted (string
, len
);
1969 /* inquire_access()-- Given a fortran string, determine if the file is
1970 * suitable for access. */
1973 inquire_access (const char *string
, int len
, int mode
)
1977 char *path
= fc_strdup (string
, len
);
1978 int res
= access (path
, mode
);
1987 /* inquire_read()-- Given a fortran string, determine if the file is
1988 * suitable for READ access. */
1991 inquire_read (const char *string
, int len
)
1993 return inquire_access (string
, len
, R_OK
);
1997 /* inquire_write()-- Given a fortran string, determine if the file is
1998 * suitable for READ access. */
2001 inquire_write (const char *string
, int len
)
2003 return inquire_access (string
, len
, W_OK
);
2007 /* inquire_readwrite()-- Given a fortran string, determine if the file is
2008 * suitable for read and write access. */
2011 inquire_readwrite (const char *string
, int len
)
2013 return inquire_access (string
, len
, R_OK
| W_OK
);
2018 stream_isatty (stream
*s
)
2020 return isatty (((unix_stream
*) s
)->fd
);
2024 stream_ttyname (stream
*s
__attribute__ ((unused
)),
2025 char * buf
__attribute__ ((unused
)),
2026 size_t buflen
__attribute__ ((unused
)))
2028 #ifdef HAVE_TTYNAME_R
2029 return ttyname_r (((unix_stream
*) s
)->fd
, buf
, buflen
);
2030 #elif defined HAVE_TTYNAME
2033 p
= ttyname (((unix_stream
*) s
)->fd
);
2039 memcpy (buf
, p
, plen
);
2049 /* How files are stored: This is an operating-system specific issue,
2050 and therefore belongs here. There are three cases to consider.
2053 Records are written as block of bytes corresponding to the record
2054 length of the file. This goes for both formatted and unformatted
2055 records. Positioning is done explicitly for each data transfer,
2056 so positioning is not much of an issue.
2058 Sequential Formatted:
2059 Records are separated by newline characters. The newline character
2060 is prohibited from appearing in a string. If it does, this will be
2061 messed up on the next read. End of file is also the end of a record.
2063 Sequential Unformatted:
2064 In this case, we are merely copying bytes to and from main storage,
2065 yet we need to keep track of varying record lengths. We adopt
2066 the solution used by f2c. Each record contains a pair of length
2069 Length of record n in bytes
2071 Length of record n in bytes
2073 Length of record n+1 in bytes
2075 Length of record n+1 in bytes
2077 The length is stored at the end of a record to allow backspacing to the
2078 previous record. Between data transfer statements, the file pointer
2079 is left pointing to the first length of the current record.
2081 ENDFILE records are never explicitly stored.