1*4c3eb207Smrg /* Copyright (C) 2002-2020 Free Software Foundation, Inc.
2627f7eb2Smrg Contributed by Andy Vaught
3627f7eb2Smrg F2003 I/O support contributed by Jerry DeLisle
4627f7eb2Smrg
5627f7eb2Smrg This file is part of the GNU Fortran runtime library (libgfortran).
6627f7eb2Smrg
7627f7eb2Smrg Libgfortran is free software; you can redistribute it and/or modify
8627f7eb2Smrg it under the terms of the GNU General Public License as published by
9627f7eb2Smrg the Free Software Foundation; either version 3, or (at your option)
10627f7eb2Smrg any later version.
11627f7eb2Smrg
12627f7eb2Smrg Libgfortran is distributed in the hope that it will be useful,
13627f7eb2Smrg but WITHOUT ANY WARRANTY; without even the implied warranty of
14627f7eb2Smrg MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15627f7eb2Smrg GNU General Public License for more details.
16627f7eb2Smrg
17627f7eb2Smrg Under Section 7 of GPL version 3, you are granted additional
18627f7eb2Smrg permissions described in the GCC Runtime Library Exception, version
19627f7eb2Smrg 3.1, as published by the Free Software Foundation.
20627f7eb2Smrg
21627f7eb2Smrg You should have received a copy of the GNU General Public License and
22627f7eb2Smrg a copy of the GCC Runtime Library Exception along with this program;
23627f7eb2Smrg see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
24627f7eb2Smrg <http://www.gnu.org/licenses/>. */
25627f7eb2Smrg
26627f7eb2Smrg /* Unix stream I/O module */
27627f7eb2Smrg
28627f7eb2Smrg #include "io.h"
29627f7eb2Smrg #include "unix.h"
30627f7eb2Smrg #include "async.h"
31627f7eb2Smrg #include <limits.h>
32627f7eb2Smrg
33627f7eb2Smrg #ifdef HAVE_UNISTD_H
34627f7eb2Smrg #include <unistd.h>
35627f7eb2Smrg #endif
36627f7eb2Smrg
37627f7eb2Smrg #include <sys/stat.h>
38627f7eb2Smrg #include <fcntl.h>
39627f7eb2Smrg
40627f7eb2Smrg #include <string.h>
41627f7eb2Smrg #include <errno.h>
42627f7eb2Smrg
43627f7eb2Smrg
44627f7eb2Smrg /* For mingw, we don't identify files by their inode number, but by a
45627f7eb2Smrg 64-bit identifier created from a BY_HANDLE_FILE_INFORMATION. */
46627f7eb2Smrg #ifdef __MINGW32__
47627f7eb2Smrg
48627f7eb2Smrg #define WIN32_LEAN_AND_MEAN
49627f7eb2Smrg #include <windows.h>
50627f7eb2Smrg
51627f7eb2Smrg #if !defined(_FILE_OFFSET_BITS) || _FILE_OFFSET_BITS != 64
52627f7eb2Smrg #undef lseek
53627f7eb2Smrg #define lseek _lseeki64
54627f7eb2Smrg #undef fstat
55627f7eb2Smrg #define fstat _fstati64
56627f7eb2Smrg #undef stat
57627f7eb2Smrg #define stat _stati64
58627f7eb2Smrg #endif
59627f7eb2Smrg
60627f7eb2Smrg #ifndef HAVE_WORKING_STAT
61627f7eb2Smrg static uint64_t
id_from_handle(HANDLE hFile)62627f7eb2Smrg id_from_handle (HANDLE hFile)
63627f7eb2Smrg {
64627f7eb2Smrg BY_HANDLE_FILE_INFORMATION FileInformation;
65627f7eb2Smrg
66627f7eb2Smrg if (hFile == INVALID_HANDLE_VALUE)
67627f7eb2Smrg return 0;
68627f7eb2Smrg
69627f7eb2Smrg memset (&FileInformation, 0, sizeof(FileInformation));
70627f7eb2Smrg if (!GetFileInformationByHandle (hFile, &FileInformation))
71627f7eb2Smrg return 0;
72627f7eb2Smrg
73627f7eb2Smrg return ((uint64_t) FileInformation.nFileIndexLow)
74627f7eb2Smrg | (((uint64_t) FileInformation.nFileIndexHigh) << 32);
75627f7eb2Smrg }
76627f7eb2Smrg
77627f7eb2Smrg
78627f7eb2Smrg static uint64_t
id_from_path(const char * path)79627f7eb2Smrg id_from_path (const char *path)
80627f7eb2Smrg {
81627f7eb2Smrg HANDLE hFile;
82627f7eb2Smrg uint64_t res;
83627f7eb2Smrg
84627f7eb2Smrg if (!path || !*path || access (path, F_OK))
85627f7eb2Smrg return (uint64_t) -1;
86627f7eb2Smrg
87627f7eb2Smrg hFile = CreateFile (path, 0, 0, NULL, OPEN_EXISTING,
88627f7eb2Smrg FILE_FLAG_BACKUP_SEMANTICS | FILE_ATTRIBUTE_READONLY,
89627f7eb2Smrg NULL);
90627f7eb2Smrg res = id_from_handle (hFile);
91627f7eb2Smrg CloseHandle (hFile);
92627f7eb2Smrg return res;
93627f7eb2Smrg }
94627f7eb2Smrg
95627f7eb2Smrg
96627f7eb2Smrg static uint64_t
id_from_fd(const int fd)97627f7eb2Smrg id_from_fd (const int fd)
98627f7eb2Smrg {
99627f7eb2Smrg return id_from_handle ((HANDLE) _get_osfhandle (fd));
100627f7eb2Smrg }
101627f7eb2Smrg
102627f7eb2Smrg #endif /* HAVE_WORKING_STAT */
103627f7eb2Smrg
104627f7eb2Smrg
105627f7eb2Smrg /* On mingw, we don't use umask in tempfile_open(), because it
106627f7eb2Smrg doesn't support the user/group/other-based permissions. */
107627f7eb2Smrg #undef HAVE_UMASK
108627f7eb2Smrg
109627f7eb2Smrg #endif /* __MINGW32__ */
110627f7eb2Smrg
111627f7eb2Smrg
112627f7eb2Smrg /* These flags aren't defined on all targets (mingw32), so provide them
113627f7eb2Smrg here. */
114627f7eb2Smrg #ifndef S_IRGRP
115627f7eb2Smrg #define S_IRGRP 0
116627f7eb2Smrg #endif
117627f7eb2Smrg
118627f7eb2Smrg #ifndef S_IWGRP
119627f7eb2Smrg #define S_IWGRP 0
120627f7eb2Smrg #endif
121627f7eb2Smrg
122627f7eb2Smrg #ifndef S_IROTH
123627f7eb2Smrg #define S_IROTH 0
124627f7eb2Smrg #endif
125627f7eb2Smrg
126627f7eb2Smrg #ifndef S_IWOTH
127627f7eb2Smrg #define S_IWOTH 0
128627f7eb2Smrg #endif
129627f7eb2Smrg
130627f7eb2Smrg
131627f7eb2Smrg #ifndef HAVE_ACCESS
132627f7eb2Smrg
133627f7eb2Smrg #ifndef W_OK
134627f7eb2Smrg #define W_OK 2
135627f7eb2Smrg #endif
136627f7eb2Smrg
137627f7eb2Smrg #ifndef R_OK
138627f7eb2Smrg #define R_OK 4
139627f7eb2Smrg #endif
140627f7eb2Smrg
141627f7eb2Smrg #ifndef F_OK
142627f7eb2Smrg #define F_OK 0
143627f7eb2Smrg #endif
144627f7eb2Smrg
145627f7eb2Smrg /* Fallback implementation of access() on systems that don't have it.
146627f7eb2Smrg Only modes R_OK, W_OK and F_OK are used in this file. */
147627f7eb2Smrg
148627f7eb2Smrg static int
fallback_access(const char * path,int mode)149627f7eb2Smrg fallback_access (const char *path, int mode)
150627f7eb2Smrg {
151627f7eb2Smrg int fd;
152627f7eb2Smrg
153627f7eb2Smrg if (mode & R_OK)
154627f7eb2Smrg {
155627f7eb2Smrg if ((fd = open (path, O_RDONLY)) < 0)
156627f7eb2Smrg return -1;
157627f7eb2Smrg else
158627f7eb2Smrg close (fd);
159627f7eb2Smrg }
160627f7eb2Smrg
161627f7eb2Smrg if (mode & W_OK)
162627f7eb2Smrg {
163627f7eb2Smrg if ((fd = open (path, O_WRONLY)) < 0)
164627f7eb2Smrg return -1;
165627f7eb2Smrg else
166627f7eb2Smrg close (fd);
167627f7eb2Smrg }
168627f7eb2Smrg
169627f7eb2Smrg if (mode == F_OK)
170627f7eb2Smrg {
171627f7eb2Smrg struct stat st;
172627f7eb2Smrg return stat (path, &st);
173627f7eb2Smrg }
174627f7eb2Smrg
175627f7eb2Smrg return 0;
176627f7eb2Smrg }
177627f7eb2Smrg
178627f7eb2Smrg #undef access
179627f7eb2Smrg #define access fallback_access
180627f7eb2Smrg #endif
181627f7eb2Smrg
182627f7eb2Smrg
183627f7eb2Smrg /* Fallback directory for creating temporary files. P_tmpdir is
184627f7eb2Smrg defined on many POSIX platforms. */
185627f7eb2Smrg #ifndef P_tmpdir
186627f7eb2Smrg #ifdef _P_tmpdir
187627f7eb2Smrg #define P_tmpdir _P_tmpdir /* MinGW */
188627f7eb2Smrg #else
189627f7eb2Smrg #define P_tmpdir "/tmp"
190627f7eb2Smrg #endif
191627f7eb2Smrg #endif
192627f7eb2Smrg
193627f7eb2Smrg
194627f7eb2Smrg /* Unix and internal stream I/O module */
195627f7eb2Smrg
196627f7eb2Smrg static const int FORMATTED_BUFFER_SIZE_DEFAULT = 8192;
197627f7eb2Smrg static const int UNFORMATTED_BUFFER_SIZE_DEFAULT = 128*1024;
198627f7eb2Smrg
199627f7eb2Smrg typedef struct
200627f7eb2Smrg {
201627f7eb2Smrg stream st;
202627f7eb2Smrg
203627f7eb2Smrg gfc_offset buffer_offset; /* File offset of the start of the buffer */
204627f7eb2Smrg gfc_offset physical_offset; /* Current physical file offset */
205627f7eb2Smrg gfc_offset logical_offset; /* Current logical file offset */
206627f7eb2Smrg gfc_offset file_length; /* Length of the file. */
207627f7eb2Smrg
208627f7eb2Smrg char *buffer; /* Pointer to the buffer. */
209627f7eb2Smrg ssize_t buffer_size; /* Length of the buffer. */
210627f7eb2Smrg int fd; /* The POSIX file descriptor. */
211627f7eb2Smrg
212627f7eb2Smrg int active; /* Length of valid bytes in the buffer */
213627f7eb2Smrg
214627f7eb2Smrg int ndirty; /* Dirty bytes starting at buffer_offset */
215627f7eb2Smrg
216627f7eb2Smrg /* Cached stat(2) values. */
217627f7eb2Smrg dev_t st_dev;
218627f7eb2Smrg ino_t st_ino;
219627f7eb2Smrg
220627f7eb2Smrg bool unbuffered; /* Buffer should be flushed after each I/O statement. */
221627f7eb2Smrg }
222627f7eb2Smrg unix_stream;
223627f7eb2Smrg
224627f7eb2Smrg
225627f7eb2Smrg /* fix_fd()-- Given a file descriptor, make sure it is not one of the
226627f7eb2Smrg standard descriptors, returning a non-standard descriptor. If the
227627f7eb2Smrg user specifies that system errors should go to standard output,
228627f7eb2Smrg then closes standard output, we don't want the system errors to a
229627f7eb2Smrg file that has been given file descriptor 1 or 0. We want to send
230627f7eb2Smrg the error to the invalid descriptor. */
231627f7eb2Smrg
232627f7eb2Smrg static int
fix_fd(int fd)233627f7eb2Smrg fix_fd (int fd)
234627f7eb2Smrg {
235627f7eb2Smrg #ifdef HAVE_DUP
236627f7eb2Smrg int input, output, error;
237627f7eb2Smrg
238627f7eb2Smrg input = output = error = 0;
239627f7eb2Smrg
240627f7eb2Smrg /* Unix allocates the lowest descriptors first, so a loop is not
241627f7eb2Smrg required, but this order is. */
242627f7eb2Smrg if (fd == STDIN_FILENO)
243627f7eb2Smrg {
244627f7eb2Smrg fd = dup (fd);
245627f7eb2Smrg input = 1;
246627f7eb2Smrg }
247627f7eb2Smrg if (fd == STDOUT_FILENO)
248627f7eb2Smrg {
249627f7eb2Smrg fd = dup (fd);
250627f7eb2Smrg output = 1;
251627f7eb2Smrg }
252627f7eb2Smrg if (fd == STDERR_FILENO)
253627f7eb2Smrg {
254627f7eb2Smrg fd = dup (fd);
255627f7eb2Smrg error = 1;
256627f7eb2Smrg }
257627f7eb2Smrg
258627f7eb2Smrg if (input)
259627f7eb2Smrg close (STDIN_FILENO);
260627f7eb2Smrg if (output)
261627f7eb2Smrg close (STDOUT_FILENO);
262627f7eb2Smrg if (error)
263627f7eb2Smrg close (STDERR_FILENO);
264627f7eb2Smrg #endif
265627f7eb2Smrg
266627f7eb2Smrg return fd;
267627f7eb2Smrg }
268627f7eb2Smrg
269627f7eb2Smrg
270627f7eb2Smrg /* If the stream corresponds to a preconnected unit, we flush the
271627f7eb2Smrg corresponding C stream. This is bugware for mixed C-Fortran codes
272627f7eb2Smrg where the C code doesn't flush I/O before returning. */
273627f7eb2Smrg void
flush_if_preconnected(stream * s)274627f7eb2Smrg flush_if_preconnected (stream *s)
275627f7eb2Smrg {
276627f7eb2Smrg int fd;
277627f7eb2Smrg
278627f7eb2Smrg fd = ((unix_stream *) s)->fd;
279627f7eb2Smrg if (fd == STDIN_FILENO)
280627f7eb2Smrg fflush (stdin);
281627f7eb2Smrg else if (fd == STDOUT_FILENO)
282627f7eb2Smrg fflush (stdout);
283627f7eb2Smrg else if (fd == STDERR_FILENO)
284627f7eb2Smrg fflush (stderr);
285627f7eb2Smrg }
286627f7eb2Smrg
287627f7eb2Smrg
288627f7eb2Smrg /********************************************************************
289627f7eb2Smrg Raw I/O functions (read, write, seek, tell, truncate, close).
290627f7eb2Smrg
291627f7eb2Smrg These functions wrap the basic POSIX I/O syscalls. Any deviation in
292627f7eb2Smrg semantics is a bug, except the following: write restarts in case
293627f7eb2Smrg of being interrupted by a signal, and as the first argument the
294627f7eb2Smrg functions take the unix_stream struct rather than an integer file
295627f7eb2Smrg descriptor. Also, for POSIX read() and write() a nbyte argument larger
296627f7eb2Smrg than SSIZE_MAX is undefined; here the type of nbyte is ssize_t rather
297627f7eb2Smrg than size_t as for POSIX read/write.
298627f7eb2Smrg *********************************************************************/
299627f7eb2Smrg
300627f7eb2Smrg static int
raw_flush(unix_stream * s)301627f7eb2Smrg raw_flush (unix_stream *s __attribute__ ((unused)))
302627f7eb2Smrg {
303627f7eb2Smrg return 0;
304627f7eb2Smrg }
305627f7eb2Smrg
306627f7eb2Smrg /* Write/read at most 2 GB - 4k chunks at a time. Linux never reads or
307627f7eb2Smrg writes more than this, and there are reports that macOS fails for
308627f7eb2Smrg larger than 2 GB as well. */
309627f7eb2Smrg #define MAX_CHUNK 2147479552
310627f7eb2Smrg
311627f7eb2Smrg static ssize_t
raw_read(unix_stream * s,void * buf,ssize_t nbyte)312627f7eb2Smrg raw_read (unix_stream *s, void *buf, ssize_t nbyte)
313627f7eb2Smrg {
314627f7eb2Smrg /* For read we can't do I/O in a loop like raw_write does, because
315627f7eb2Smrg that will break applications that wait for interactive I/O. We
316627f7eb2Smrg still can loop around EINTR, though. This however causes a
317627f7eb2Smrg problem for large reads which must be chunked, see comment above.
318627f7eb2Smrg So assume that if the size is larger than the chunk size, we're
319627f7eb2Smrg reading from a file and not the terminal. */
320627f7eb2Smrg if (nbyte <= MAX_CHUNK)
321627f7eb2Smrg {
322627f7eb2Smrg while (true)
323627f7eb2Smrg {
324627f7eb2Smrg ssize_t trans = read (s->fd, buf, nbyte);
325627f7eb2Smrg if (trans == -1 && errno == EINTR)
326627f7eb2Smrg continue;
327627f7eb2Smrg return trans;
328627f7eb2Smrg }
329627f7eb2Smrg }
330627f7eb2Smrg else
331627f7eb2Smrg {
332627f7eb2Smrg ssize_t bytes_left = nbyte;
333627f7eb2Smrg char *buf_st = buf;
334627f7eb2Smrg while (bytes_left > 0)
335627f7eb2Smrg {
336627f7eb2Smrg ssize_t to_read = bytes_left < MAX_CHUNK ? bytes_left: MAX_CHUNK;
337627f7eb2Smrg ssize_t trans = read (s->fd, buf_st, to_read);
338627f7eb2Smrg if (trans == -1)
339627f7eb2Smrg {
340627f7eb2Smrg if (errno == EINTR)
341627f7eb2Smrg continue;
342627f7eb2Smrg else
343627f7eb2Smrg return trans;
344627f7eb2Smrg }
345627f7eb2Smrg buf_st += trans;
346627f7eb2Smrg bytes_left -= trans;
347627f7eb2Smrg }
348627f7eb2Smrg return nbyte - bytes_left;
349627f7eb2Smrg }
350627f7eb2Smrg }
351627f7eb2Smrg
352627f7eb2Smrg static ssize_t
raw_write(unix_stream * s,const void * buf,ssize_t nbyte)353627f7eb2Smrg raw_write (unix_stream *s, const void *buf, ssize_t nbyte)
354627f7eb2Smrg {
355627f7eb2Smrg ssize_t trans, bytes_left;
356627f7eb2Smrg char *buf_st;
357627f7eb2Smrg
358627f7eb2Smrg bytes_left = nbyte;
359627f7eb2Smrg buf_st = (char *) buf;
360627f7eb2Smrg
361627f7eb2Smrg /* We must write in a loop since some systems don't restart system
362627f7eb2Smrg calls in case of a signal. Also some systems might fail outright
363627f7eb2Smrg if we try to write more than 2 GB in a single syscall, so chunk
364627f7eb2Smrg up large writes. */
365627f7eb2Smrg while (bytes_left > 0)
366627f7eb2Smrg {
367627f7eb2Smrg ssize_t to_write = bytes_left < MAX_CHUNK ? bytes_left: MAX_CHUNK;
368627f7eb2Smrg trans = write (s->fd, buf_st, to_write);
369627f7eb2Smrg if (trans == -1)
370627f7eb2Smrg {
371627f7eb2Smrg if (errno == EINTR)
372627f7eb2Smrg continue;
373627f7eb2Smrg else
374627f7eb2Smrg return trans;
375627f7eb2Smrg }
376627f7eb2Smrg buf_st += trans;
377627f7eb2Smrg bytes_left -= trans;
378627f7eb2Smrg }
379627f7eb2Smrg
380627f7eb2Smrg return nbyte - bytes_left;
381627f7eb2Smrg }
382627f7eb2Smrg
383627f7eb2Smrg static gfc_offset
raw_seek(unix_stream * s,gfc_offset offset,int whence)384627f7eb2Smrg raw_seek (unix_stream *s, gfc_offset offset, int whence)
385627f7eb2Smrg {
386627f7eb2Smrg while (true)
387627f7eb2Smrg {
388627f7eb2Smrg gfc_offset off = lseek (s->fd, offset, whence);
389627f7eb2Smrg if (off == (gfc_offset) -1 && errno == EINTR)
390627f7eb2Smrg continue;
391627f7eb2Smrg return off;
392627f7eb2Smrg }
393627f7eb2Smrg }
394627f7eb2Smrg
395627f7eb2Smrg static gfc_offset
raw_tell(unix_stream * s)396627f7eb2Smrg raw_tell (unix_stream *s)
397627f7eb2Smrg {
398627f7eb2Smrg while (true)
399627f7eb2Smrg {
400627f7eb2Smrg gfc_offset off = lseek (s->fd, 0, SEEK_CUR);
401627f7eb2Smrg if (off == (gfc_offset) -1 && errno == EINTR)
402627f7eb2Smrg continue;
403627f7eb2Smrg return off;
404627f7eb2Smrg }
405627f7eb2Smrg }
406627f7eb2Smrg
407627f7eb2Smrg static gfc_offset
raw_size(unix_stream * s)408627f7eb2Smrg raw_size (unix_stream *s)
409627f7eb2Smrg {
410627f7eb2Smrg struct stat statbuf;
411627f7eb2Smrg if (TEMP_FAILURE_RETRY (fstat (s->fd, &statbuf)) == -1)
412627f7eb2Smrg return -1;
413627f7eb2Smrg if (S_ISREG (statbuf.st_mode))
414627f7eb2Smrg return statbuf.st_size;
415627f7eb2Smrg else
416627f7eb2Smrg return 0;
417627f7eb2Smrg }
418627f7eb2Smrg
419627f7eb2Smrg static int
raw_truncate(unix_stream * s,gfc_offset length)420627f7eb2Smrg raw_truncate (unix_stream *s, gfc_offset length)
421627f7eb2Smrg {
422627f7eb2Smrg #ifdef __MINGW32__
423627f7eb2Smrg HANDLE h;
424627f7eb2Smrg gfc_offset cur;
425627f7eb2Smrg
426627f7eb2Smrg if (isatty (s->fd))
427627f7eb2Smrg {
428627f7eb2Smrg errno = EBADF;
429627f7eb2Smrg return -1;
430627f7eb2Smrg }
431627f7eb2Smrg h = (HANDLE) _get_osfhandle (s->fd);
432627f7eb2Smrg if (h == INVALID_HANDLE_VALUE)
433627f7eb2Smrg {
434627f7eb2Smrg errno = EBADF;
435627f7eb2Smrg return -1;
436627f7eb2Smrg }
437627f7eb2Smrg cur = lseek (s->fd, 0, SEEK_CUR);
438627f7eb2Smrg if (cur == -1)
439627f7eb2Smrg return -1;
440627f7eb2Smrg if (lseek (s->fd, length, SEEK_SET) == -1)
441627f7eb2Smrg goto error;
442627f7eb2Smrg if (!SetEndOfFile (h))
443627f7eb2Smrg {
444627f7eb2Smrg errno = EBADF;
445627f7eb2Smrg goto error;
446627f7eb2Smrg }
447627f7eb2Smrg if (lseek (s->fd, cur, SEEK_SET) == -1)
448627f7eb2Smrg return -1;
449627f7eb2Smrg return 0;
450627f7eb2Smrg error:
451627f7eb2Smrg lseek (s->fd, cur, SEEK_SET);
452627f7eb2Smrg return -1;
453627f7eb2Smrg #elif defined HAVE_FTRUNCATE
454627f7eb2Smrg if (TEMP_FAILURE_RETRY (ftruncate (s->fd, length)) == -1)
455627f7eb2Smrg return -1;
456627f7eb2Smrg return 0;
457627f7eb2Smrg #elif defined HAVE_CHSIZE
458627f7eb2Smrg return chsize (s->fd, length);
459627f7eb2Smrg #else
460627f7eb2Smrg runtime_error ("required ftruncate or chsize support not present");
461627f7eb2Smrg return -1;
462627f7eb2Smrg #endif
463627f7eb2Smrg }
464627f7eb2Smrg
465627f7eb2Smrg static int
raw_close(unix_stream * s)466627f7eb2Smrg raw_close (unix_stream *s)
467627f7eb2Smrg {
468627f7eb2Smrg int retval;
469627f7eb2Smrg
470627f7eb2Smrg if (s->fd == -1)
471627f7eb2Smrg retval = -1;
472627f7eb2Smrg else if (s->fd != STDOUT_FILENO
473627f7eb2Smrg && s->fd != STDERR_FILENO
474627f7eb2Smrg && s->fd != STDIN_FILENO)
475627f7eb2Smrg {
476627f7eb2Smrg retval = close (s->fd);
477627f7eb2Smrg /* close() and EINTR is special, as the file descriptor is
478627f7eb2Smrg deallocated before doing anything that might cause the
479627f7eb2Smrg operation to be interrupted. Thus if we get EINTR the best we
480627f7eb2Smrg can do is ignore it and continue (otherwise if we try again
481627f7eb2Smrg the file descriptor may have been allocated again to some
482627f7eb2Smrg other file). */
483627f7eb2Smrg if (retval == -1 && errno == EINTR)
484627f7eb2Smrg retval = errno = 0;
485627f7eb2Smrg }
486627f7eb2Smrg else
487627f7eb2Smrg retval = 0;
488627f7eb2Smrg free (s);
489627f7eb2Smrg return retval;
490627f7eb2Smrg }
491627f7eb2Smrg
492627f7eb2Smrg static int
raw_markeor(unix_stream * s)493627f7eb2Smrg raw_markeor (unix_stream *s __attribute__ ((unused)))
494627f7eb2Smrg {
495627f7eb2Smrg return 0;
496627f7eb2Smrg }
497627f7eb2Smrg
498627f7eb2Smrg static const struct stream_vtable raw_vtable = {
499627f7eb2Smrg .read = (void *) raw_read,
500627f7eb2Smrg .write = (void *) raw_write,
501627f7eb2Smrg .seek = (void *) raw_seek,
502627f7eb2Smrg .tell = (void *) raw_tell,
503627f7eb2Smrg .size = (void *) raw_size,
504627f7eb2Smrg .trunc = (void *) raw_truncate,
505627f7eb2Smrg .close = (void *) raw_close,
506627f7eb2Smrg .flush = (void *) raw_flush,
507627f7eb2Smrg .markeor = (void *) raw_markeor
508627f7eb2Smrg };
509627f7eb2Smrg
510627f7eb2Smrg static int
raw_init(unix_stream * s)511627f7eb2Smrg raw_init (unix_stream *s)
512627f7eb2Smrg {
513627f7eb2Smrg s->st.vptr = &raw_vtable;
514627f7eb2Smrg
515627f7eb2Smrg s->buffer = NULL;
516627f7eb2Smrg return 0;
517627f7eb2Smrg }
518627f7eb2Smrg
519627f7eb2Smrg
520627f7eb2Smrg /*********************************************************************
521627f7eb2Smrg Buffered I/O functions. These functions have the same semantics as the
522627f7eb2Smrg raw I/O functions above, except that they are buffered in order to
523627f7eb2Smrg improve performance. The buffer must be flushed when switching from
524627f7eb2Smrg reading to writing and vice versa.
525627f7eb2Smrg *********************************************************************/
526627f7eb2Smrg
527627f7eb2Smrg static int
buf_flush(unix_stream * s)528627f7eb2Smrg buf_flush (unix_stream *s)
529627f7eb2Smrg {
530627f7eb2Smrg int writelen;
531627f7eb2Smrg
532627f7eb2Smrg /* Flushing in read mode means discarding read bytes. */
533627f7eb2Smrg s->active = 0;
534627f7eb2Smrg
535627f7eb2Smrg if (s->ndirty == 0)
536627f7eb2Smrg return 0;
537627f7eb2Smrg
538627f7eb2Smrg if (s->physical_offset != s->buffer_offset
539627f7eb2Smrg && raw_seek (s, s->buffer_offset, SEEK_SET) < 0)
540627f7eb2Smrg return -1;
541627f7eb2Smrg
542627f7eb2Smrg writelen = raw_write (s, s->buffer, s->ndirty);
543627f7eb2Smrg
544627f7eb2Smrg s->physical_offset = s->buffer_offset + writelen;
545627f7eb2Smrg
546627f7eb2Smrg if (s->physical_offset > s->file_length)
547627f7eb2Smrg s->file_length = s->physical_offset;
548627f7eb2Smrg
549627f7eb2Smrg s->ndirty -= writelen;
550627f7eb2Smrg if (s->ndirty != 0)
551627f7eb2Smrg return -1;
552627f7eb2Smrg
553627f7eb2Smrg return 0;
554627f7eb2Smrg }
555627f7eb2Smrg
556627f7eb2Smrg static ssize_t
buf_read(unix_stream * s,void * buf,ssize_t nbyte)557627f7eb2Smrg buf_read (unix_stream *s, void *buf, ssize_t nbyte)
558627f7eb2Smrg {
559627f7eb2Smrg if (s->active == 0)
560627f7eb2Smrg s->buffer_offset = s->logical_offset;
561627f7eb2Smrg
562627f7eb2Smrg /* Is the data we want in the buffer? */
563627f7eb2Smrg if (s->logical_offset + nbyte <= s->buffer_offset + s->active
564627f7eb2Smrg && s->buffer_offset <= s->logical_offset)
565627f7eb2Smrg {
566627f7eb2Smrg /* When nbyte == 0, buf can be NULL which would lead to undefined
567627f7eb2Smrg behavior if we called memcpy(). */
568627f7eb2Smrg if (nbyte != 0)
569627f7eb2Smrg memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
570627f7eb2Smrg nbyte);
571627f7eb2Smrg }
572627f7eb2Smrg else
573627f7eb2Smrg {
574627f7eb2Smrg /* First copy the active bytes if applicable, then read the rest
575627f7eb2Smrg either directly or filling the buffer. */
576627f7eb2Smrg char *p;
577627f7eb2Smrg int nread = 0;
578627f7eb2Smrg ssize_t to_read, did_read;
579627f7eb2Smrg gfc_offset new_logical;
580627f7eb2Smrg
581627f7eb2Smrg p = (char *) buf;
582627f7eb2Smrg if (s->logical_offset >= s->buffer_offset
583627f7eb2Smrg && s->buffer_offset + s->active >= s->logical_offset)
584627f7eb2Smrg {
585627f7eb2Smrg nread = s->active - (s->logical_offset - s->buffer_offset);
586627f7eb2Smrg memcpy (buf, s->buffer + (s->logical_offset - s->buffer_offset),
587627f7eb2Smrg nread);
588627f7eb2Smrg p += nread;
589627f7eb2Smrg }
590627f7eb2Smrg /* At this point we consider all bytes in the buffer discarded. */
591627f7eb2Smrg to_read = nbyte - nread;
592627f7eb2Smrg new_logical = s->logical_offset + nread;
593627f7eb2Smrg if (s->physical_offset != new_logical
594627f7eb2Smrg && raw_seek (s, new_logical, SEEK_SET) < 0)
595627f7eb2Smrg return -1;
596627f7eb2Smrg s->buffer_offset = s->physical_offset = new_logical;
597627f7eb2Smrg if (to_read <= s->buffer_size/2)
598627f7eb2Smrg {
599627f7eb2Smrg did_read = raw_read (s, s->buffer, s->buffer_size);
600627f7eb2Smrg if (likely (did_read >= 0))
601627f7eb2Smrg {
602627f7eb2Smrg s->physical_offset += did_read;
603627f7eb2Smrg s->active = did_read;
604627f7eb2Smrg did_read = (did_read > to_read) ? to_read : did_read;
605627f7eb2Smrg memcpy (p, s->buffer, did_read);
606627f7eb2Smrg }
607627f7eb2Smrg else
608627f7eb2Smrg return did_read;
609627f7eb2Smrg }
610627f7eb2Smrg else
611627f7eb2Smrg {
612627f7eb2Smrg did_read = raw_read (s, p, to_read);
613627f7eb2Smrg if (likely (did_read >= 0))
614627f7eb2Smrg {
615627f7eb2Smrg s->physical_offset += did_read;
616627f7eb2Smrg s->active = 0;
617627f7eb2Smrg }
618627f7eb2Smrg else
619627f7eb2Smrg return did_read;
620627f7eb2Smrg }
621627f7eb2Smrg nbyte = did_read + nread;
622627f7eb2Smrg }
623627f7eb2Smrg s->logical_offset += nbyte;
624627f7eb2Smrg return nbyte;
625627f7eb2Smrg }
626627f7eb2Smrg
627627f7eb2Smrg static ssize_t
buf_write(unix_stream * s,const void * buf,ssize_t nbyte)628627f7eb2Smrg buf_write (unix_stream *s, const void *buf, ssize_t nbyte)
629627f7eb2Smrg {
630627f7eb2Smrg if (nbyte == 0)
631627f7eb2Smrg return 0;
632627f7eb2Smrg
633627f7eb2Smrg if (s->ndirty == 0)
634627f7eb2Smrg s->buffer_offset = s->logical_offset;
635627f7eb2Smrg
636627f7eb2Smrg /* Does the data fit into the buffer? As a special case, if the
637627f7eb2Smrg buffer is empty and the request is bigger than s->buffer_size/2,
638627f7eb2Smrg write directly. This avoids the case where the buffer would have
639627f7eb2Smrg to be flushed at every write. */
640627f7eb2Smrg if (!(s->ndirty == 0 && nbyte > s->buffer_size/2)
641627f7eb2Smrg && s->logical_offset + nbyte <= s->buffer_offset + s->buffer_size
642627f7eb2Smrg && s->buffer_offset <= s->logical_offset
643627f7eb2Smrg && s->buffer_offset + s->ndirty >= s->logical_offset)
644627f7eb2Smrg {
645627f7eb2Smrg memcpy (s->buffer + (s->logical_offset - s->buffer_offset), buf, nbyte);
646627f7eb2Smrg int nd = (s->logical_offset - s->buffer_offset) + nbyte;
647627f7eb2Smrg if (nd > s->ndirty)
648627f7eb2Smrg s->ndirty = nd;
649627f7eb2Smrg }
650627f7eb2Smrg else
651627f7eb2Smrg {
652627f7eb2Smrg /* Flush, and either fill the buffer with the new data, or if
653627f7eb2Smrg the request is bigger than the buffer size, write directly
654627f7eb2Smrg bypassing the buffer. */
655627f7eb2Smrg buf_flush (s);
656627f7eb2Smrg if (nbyte <= s->buffer_size/2)
657627f7eb2Smrg {
658627f7eb2Smrg memcpy (s->buffer, buf, nbyte);
659627f7eb2Smrg s->buffer_offset = s->logical_offset;
660627f7eb2Smrg s->ndirty += nbyte;
661627f7eb2Smrg }
662627f7eb2Smrg else
663627f7eb2Smrg {
664627f7eb2Smrg if (s->physical_offset != s->logical_offset)
665627f7eb2Smrg {
666627f7eb2Smrg if (raw_seek (s, s->logical_offset, SEEK_SET) < 0)
667627f7eb2Smrg return -1;
668627f7eb2Smrg s->physical_offset = s->logical_offset;
669627f7eb2Smrg }
670627f7eb2Smrg
671627f7eb2Smrg nbyte = raw_write (s, buf, nbyte);
672627f7eb2Smrg s->physical_offset += nbyte;
673627f7eb2Smrg }
674627f7eb2Smrg }
675627f7eb2Smrg s->logical_offset += nbyte;
676627f7eb2Smrg if (s->logical_offset > s->file_length)
677627f7eb2Smrg s->file_length = s->logical_offset;
678627f7eb2Smrg return nbyte;
679627f7eb2Smrg }
680627f7eb2Smrg
681627f7eb2Smrg
682627f7eb2Smrg /* "Unbuffered" really means I/O statement buffering. For formatted
683627f7eb2Smrg I/O, the fbuf manages this, and then uses raw I/O. For unformatted
684627f7eb2Smrg I/O, buffered I/O is used, and the buffer is flushed at the end of
685627f7eb2Smrg each I/O statement, where this function is called. Alternatively,
686627f7eb2Smrg the buffer is flushed at the end of the record if the buffer is
687627f7eb2Smrg more than half full; this prevents needless seeking back and forth
688627f7eb2Smrg when writing sequential unformatted. */
689627f7eb2Smrg
690627f7eb2Smrg static int
buf_markeor(unix_stream * s)691627f7eb2Smrg buf_markeor (unix_stream *s)
692627f7eb2Smrg {
693627f7eb2Smrg if (s->unbuffered || s->ndirty >= s->buffer_size / 2)
694627f7eb2Smrg return buf_flush (s);
695627f7eb2Smrg return 0;
696627f7eb2Smrg }
697627f7eb2Smrg
698627f7eb2Smrg static gfc_offset
buf_seek(unix_stream * s,gfc_offset offset,int whence)699627f7eb2Smrg buf_seek (unix_stream *s, gfc_offset offset, int whence)
700627f7eb2Smrg {
701627f7eb2Smrg switch (whence)
702627f7eb2Smrg {
703627f7eb2Smrg case SEEK_SET:
704627f7eb2Smrg break;
705627f7eb2Smrg case SEEK_CUR:
706627f7eb2Smrg offset += s->logical_offset;
707627f7eb2Smrg break;
708627f7eb2Smrg case SEEK_END:
709627f7eb2Smrg offset += s->file_length;
710627f7eb2Smrg break;
711627f7eb2Smrg default:
712627f7eb2Smrg return -1;
713627f7eb2Smrg }
714627f7eb2Smrg if (offset < 0)
715627f7eb2Smrg {
716627f7eb2Smrg errno = EINVAL;
717627f7eb2Smrg return -1;
718627f7eb2Smrg }
719627f7eb2Smrg s->logical_offset = offset;
720627f7eb2Smrg return offset;
721627f7eb2Smrg }
722627f7eb2Smrg
723627f7eb2Smrg static gfc_offset
buf_tell(unix_stream * s)724627f7eb2Smrg buf_tell (unix_stream *s)
725627f7eb2Smrg {
726627f7eb2Smrg return buf_seek (s, 0, SEEK_CUR);
727627f7eb2Smrg }
728627f7eb2Smrg
729627f7eb2Smrg static gfc_offset
buf_size(unix_stream * s)730627f7eb2Smrg buf_size (unix_stream *s)
731627f7eb2Smrg {
732627f7eb2Smrg return s->file_length;
733627f7eb2Smrg }
734627f7eb2Smrg
735627f7eb2Smrg static int
buf_truncate(unix_stream * s,gfc_offset length)736627f7eb2Smrg buf_truncate (unix_stream *s, gfc_offset length)
737627f7eb2Smrg {
738627f7eb2Smrg int r;
739627f7eb2Smrg
740627f7eb2Smrg if (buf_flush (s) != 0)
741627f7eb2Smrg return -1;
742627f7eb2Smrg r = raw_truncate (s, length);
743627f7eb2Smrg if (r == 0)
744627f7eb2Smrg s->file_length = length;
745627f7eb2Smrg return r;
746627f7eb2Smrg }
747627f7eb2Smrg
748627f7eb2Smrg static int
buf_close(unix_stream * s)749627f7eb2Smrg buf_close (unix_stream *s)
750627f7eb2Smrg {
751627f7eb2Smrg if (buf_flush (s) != 0)
752627f7eb2Smrg return -1;
753627f7eb2Smrg free (s->buffer);
754627f7eb2Smrg return raw_close (s);
755627f7eb2Smrg }
756627f7eb2Smrg
757627f7eb2Smrg static const struct stream_vtable buf_vtable = {
758627f7eb2Smrg .read = (void *) buf_read,
759627f7eb2Smrg .write = (void *) buf_write,
760627f7eb2Smrg .seek = (void *) buf_seek,
761627f7eb2Smrg .tell = (void *) buf_tell,
762627f7eb2Smrg .size = (void *) buf_size,
763627f7eb2Smrg .trunc = (void *) buf_truncate,
764627f7eb2Smrg .close = (void *) buf_close,
765627f7eb2Smrg .flush = (void *) buf_flush,
766627f7eb2Smrg .markeor = (void *) buf_markeor
767627f7eb2Smrg };
768627f7eb2Smrg
769627f7eb2Smrg static int
buf_init(unix_stream * s,bool unformatted)770627f7eb2Smrg buf_init (unix_stream *s, bool unformatted)
771627f7eb2Smrg {
772627f7eb2Smrg s->st.vptr = &buf_vtable;
773627f7eb2Smrg
774627f7eb2Smrg /* Try to guess a good value for the buffer size. For formatted
775627f7eb2Smrg I/O, we use so many CPU cycles converting the data that there is
776627f7eb2Smrg more sense in converving memory and especially cache. For
777627f7eb2Smrg unformatted, a bigger block can have a large impact in some
778627f7eb2Smrg environments. */
779627f7eb2Smrg
780627f7eb2Smrg if (unformatted)
781627f7eb2Smrg {
782627f7eb2Smrg if (options.unformatted_buffer_size > 0)
783627f7eb2Smrg s->buffer_size = options.unformatted_buffer_size;
784627f7eb2Smrg else
785627f7eb2Smrg s->buffer_size = UNFORMATTED_BUFFER_SIZE_DEFAULT;
786627f7eb2Smrg }
787627f7eb2Smrg else
788627f7eb2Smrg {
789627f7eb2Smrg if (options.formatted_buffer_size > 0)
790627f7eb2Smrg s->buffer_size = options.formatted_buffer_size;
791627f7eb2Smrg else
792627f7eb2Smrg s->buffer_size = FORMATTED_BUFFER_SIZE_DEFAULT;
793627f7eb2Smrg }
794627f7eb2Smrg
795627f7eb2Smrg s->buffer = xmalloc (s->buffer_size);
796627f7eb2Smrg return 0;
797627f7eb2Smrg }
798627f7eb2Smrg
799627f7eb2Smrg
800627f7eb2Smrg /*********************************************************************
801627f7eb2Smrg memory stream functions - These are used for internal files
802627f7eb2Smrg
803627f7eb2Smrg The idea here is that a single stream structure is created and all
804627f7eb2Smrg requests must be satisfied from it. The location and size of the
805627f7eb2Smrg buffer is the character variable supplied to the READ or WRITE
806627f7eb2Smrg statement.
807627f7eb2Smrg
808627f7eb2Smrg *********************************************************************/
809627f7eb2Smrg
810627f7eb2Smrg char *
mem_alloc_r(stream * strm,size_t * len)811627f7eb2Smrg mem_alloc_r (stream *strm, size_t *len)
812627f7eb2Smrg {
813627f7eb2Smrg unix_stream *s = (unix_stream *) strm;
814627f7eb2Smrg gfc_offset n;
815627f7eb2Smrg gfc_offset where = s->logical_offset;
816627f7eb2Smrg
817627f7eb2Smrg if (where < s->buffer_offset || where > s->buffer_offset + s->active)
818627f7eb2Smrg return NULL;
819627f7eb2Smrg
820627f7eb2Smrg n = s->buffer_offset + s->active - where;
821627f7eb2Smrg if ((gfc_offset) *len > n)
822627f7eb2Smrg *len = n;
823627f7eb2Smrg
824627f7eb2Smrg s->logical_offset = where + *len;
825627f7eb2Smrg
826627f7eb2Smrg return s->buffer + (where - s->buffer_offset);
827627f7eb2Smrg }
828627f7eb2Smrg
829627f7eb2Smrg
830627f7eb2Smrg char *
mem_alloc_r4(stream * strm,size_t * len)831627f7eb2Smrg mem_alloc_r4 (stream *strm, size_t *len)
832627f7eb2Smrg {
833627f7eb2Smrg unix_stream *s = (unix_stream *) strm;
834627f7eb2Smrg gfc_offset n;
835627f7eb2Smrg gfc_offset where = s->logical_offset;
836627f7eb2Smrg
837627f7eb2Smrg if (where < s->buffer_offset || where > s->buffer_offset + s->active)
838627f7eb2Smrg return NULL;
839627f7eb2Smrg
840627f7eb2Smrg n = s->buffer_offset + s->active - where;
841627f7eb2Smrg if ((gfc_offset) *len > n)
842627f7eb2Smrg *len = n;
843627f7eb2Smrg
844627f7eb2Smrg s->logical_offset = where + *len;
845627f7eb2Smrg
846627f7eb2Smrg return s->buffer + (where - s->buffer_offset) * 4;
847627f7eb2Smrg }
848627f7eb2Smrg
849627f7eb2Smrg
850627f7eb2Smrg char *
mem_alloc_w(stream * strm,size_t * len)851627f7eb2Smrg mem_alloc_w (stream *strm, size_t *len)
852627f7eb2Smrg {
853627f7eb2Smrg unix_stream *s = (unix_stream *)strm;
854627f7eb2Smrg gfc_offset m;
855627f7eb2Smrg gfc_offset where = s->logical_offset;
856627f7eb2Smrg
857627f7eb2Smrg m = where + *len;
858627f7eb2Smrg
859627f7eb2Smrg if (where < s->buffer_offset)
860627f7eb2Smrg return NULL;
861627f7eb2Smrg
862627f7eb2Smrg if (m > s->file_length)
863627f7eb2Smrg return NULL;
864627f7eb2Smrg
865627f7eb2Smrg s->logical_offset = m;
866627f7eb2Smrg
867627f7eb2Smrg return s->buffer + (where - s->buffer_offset);
868627f7eb2Smrg }
869627f7eb2Smrg
870627f7eb2Smrg
871627f7eb2Smrg gfc_char4_t *
mem_alloc_w4(stream * strm,size_t * len)872627f7eb2Smrg mem_alloc_w4 (stream *strm, size_t *len)
873627f7eb2Smrg {
874627f7eb2Smrg unix_stream *s = (unix_stream *)strm;
875627f7eb2Smrg gfc_offset m;
876627f7eb2Smrg gfc_offset where = s->logical_offset;
877627f7eb2Smrg gfc_char4_t *result = (gfc_char4_t *) s->buffer;
878627f7eb2Smrg
879627f7eb2Smrg m = where + *len;
880627f7eb2Smrg
881627f7eb2Smrg if (where < s->buffer_offset)
882627f7eb2Smrg return NULL;
883627f7eb2Smrg
884627f7eb2Smrg if (m > s->file_length)
885627f7eb2Smrg return NULL;
886627f7eb2Smrg
887627f7eb2Smrg s->logical_offset = m;
888627f7eb2Smrg return &result[where - s->buffer_offset];
889627f7eb2Smrg }
890627f7eb2Smrg
891627f7eb2Smrg
892627f7eb2Smrg /* Stream read function for character(kind=1) internal units. */
893627f7eb2Smrg
894627f7eb2Smrg static ssize_t
mem_read(stream * s,void * buf,ssize_t nbytes)895627f7eb2Smrg mem_read (stream *s, void *buf, ssize_t nbytes)
896627f7eb2Smrg {
897627f7eb2Smrg void *p;
898627f7eb2Smrg size_t nb = nbytes;
899627f7eb2Smrg
900627f7eb2Smrg p = mem_alloc_r (s, &nb);
901627f7eb2Smrg if (p)
902627f7eb2Smrg {
903627f7eb2Smrg memcpy (buf, p, nb);
904627f7eb2Smrg return (ssize_t) nb;
905627f7eb2Smrg }
906627f7eb2Smrg else
907627f7eb2Smrg return 0;
908627f7eb2Smrg }
909627f7eb2Smrg
910627f7eb2Smrg
911627f7eb2Smrg /* Stream read function for chracter(kind=4) internal units. */
912627f7eb2Smrg
913627f7eb2Smrg static ssize_t
mem_read4(stream * s,void * buf,ssize_t nbytes)914627f7eb2Smrg mem_read4 (stream *s, void *buf, ssize_t nbytes)
915627f7eb2Smrg {
916627f7eb2Smrg void *p;
917627f7eb2Smrg size_t nb = nbytes;
918627f7eb2Smrg
919627f7eb2Smrg p = mem_alloc_r4 (s, &nb);
920627f7eb2Smrg if (p)
921627f7eb2Smrg {
922627f7eb2Smrg memcpy (buf, p, nb * 4);
923627f7eb2Smrg return (ssize_t) nb;
924627f7eb2Smrg }
925627f7eb2Smrg else
926627f7eb2Smrg return 0;
927627f7eb2Smrg }
928627f7eb2Smrg
929627f7eb2Smrg
930627f7eb2Smrg /* Stream write function for character(kind=1) internal units. */
931627f7eb2Smrg
932627f7eb2Smrg static ssize_t
mem_write(stream * s,const void * buf,ssize_t nbytes)933627f7eb2Smrg mem_write (stream *s, const void *buf, ssize_t nbytes)
934627f7eb2Smrg {
935627f7eb2Smrg void *p;
936627f7eb2Smrg size_t nb = nbytes;
937627f7eb2Smrg
938627f7eb2Smrg p = mem_alloc_w (s, &nb);
939627f7eb2Smrg if (p)
940627f7eb2Smrg {
941627f7eb2Smrg memcpy (p, buf, nb);
942627f7eb2Smrg return (ssize_t) nb;
943627f7eb2Smrg }
944627f7eb2Smrg else
945627f7eb2Smrg return 0;
946627f7eb2Smrg }
947627f7eb2Smrg
948627f7eb2Smrg
949627f7eb2Smrg /* Stream write function for character(kind=4) internal units. */
950627f7eb2Smrg
951627f7eb2Smrg static ssize_t
mem_write4(stream * s,const void * buf,ssize_t nwords)952627f7eb2Smrg mem_write4 (stream *s, const void *buf, ssize_t nwords)
953627f7eb2Smrg {
954627f7eb2Smrg gfc_char4_t *p;
955627f7eb2Smrg size_t nw = nwords;
956627f7eb2Smrg
957627f7eb2Smrg p = mem_alloc_w4 (s, &nw);
958627f7eb2Smrg if (p)
959627f7eb2Smrg {
960627f7eb2Smrg while (nw--)
961627f7eb2Smrg *p++ = (gfc_char4_t) *((char *) buf);
962627f7eb2Smrg return nwords;
963627f7eb2Smrg }
964627f7eb2Smrg else
965627f7eb2Smrg return 0;
966627f7eb2Smrg }
967627f7eb2Smrg
968627f7eb2Smrg
969627f7eb2Smrg static gfc_offset
mem_seek(stream * strm,gfc_offset offset,int whence)970627f7eb2Smrg mem_seek (stream *strm, gfc_offset offset, int whence)
971627f7eb2Smrg {
972627f7eb2Smrg unix_stream *s = (unix_stream *)strm;
973627f7eb2Smrg switch (whence)
974627f7eb2Smrg {
975627f7eb2Smrg case SEEK_SET:
976627f7eb2Smrg break;
977627f7eb2Smrg case SEEK_CUR:
978627f7eb2Smrg offset += s->logical_offset;
979627f7eb2Smrg break;
980627f7eb2Smrg case SEEK_END:
981627f7eb2Smrg offset += s->file_length;
982627f7eb2Smrg break;
983627f7eb2Smrg default:
984627f7eb2Smrg return -1;
985627f7eb2Smrg }
986627f7eb2Smrg
987627f7eb2Smrg /* Note that for internal array I/O it's actually possible to have a
988627f7eb2Smrg negative offset, so don't check for that. */
989627f7eb2Smrg if (offset > s->file_length)
990627f7eb2Smrg {
991627f7eb2Smrg errno = EINVAL;
992627f7eb2Smrg return -1;
993627f7eb2Smrg }
994627f7eb2Smrg
995627f7eb2Smrg s->logical_offset = offset;
996627f7eb2Smrg
997627f7eb2Smrg /* Returning < 0 is the error indicator for sseek(), so return 0 if
998627f7eb2Smrg offset is negative. Thus if the return value is 0, the caller
999627f7eb2Smrg has to use stell() to get the real value of logical_offset. */
1000627f7eb2Smrg if (offset >= 0)
1001627f7eb2Smrg return offset;
1002627f7eb2Smrg return 0;
1003627f7eb2Smrg }
1004627f7eb2Smrg
1005627f7eb2Smrg
1006627f7eb2Smrg static gfc_offset
mem_tell(stream * s)1007627f7eb2Smrg mem_tell (stream *s)
1008627f7eb2Smrg {
1009627f7eb2Smrg return ((unix_stream *)s)->logical_offset;
1010627f7eb2Smrg }
1011627f7eb2Smrg
1012627f7eb2Smrg
1013627f7eb2Smrg static int
mem_truncate(unix_stream * s,gfc_offset length)1014627f7eb2Smrg mem_truncate (unix_stream *s __attribute__ ((unused)),
1015627f7eb2Smrg gfc_offset length __attribute__ ((unused)))
1016627f7eb2Smrg {
1017627f7eb2Smrg return 0;
1018627f7eb2Smrg }
1019627f7eb2Smrg
1020627f7eb2Smrg
1021627f7eb2Smrg static int
mem_flush(unix_stream * s)1022627f7eb2Smrg mem_flush (unix_stream *s __attribute__ ((unused)))
1023627f7eb2Smrg {
1024627f7eb2Smrg return 0;
1025627f7eb2Smrg }
1026627f7eb2Smrg
1027627f7eb2Smrg
1028627f7eb2Smrg static int
mem_close(unix_stream * s)1029627f7eb2Smrg mem_close (unix_stream *s)
1030627f7eb2Smrg {
1031627f7eb2Smrg if (s)
1032627f7eb2Smrg free (s);
1033627f7eb2Smrg return 0;
1034627f7eb2Smrg }
1035627f7eb2Smrg
1036627f7eb2Smrg static const struct stream_vtable mem_vtable = {
1037627f7eb2Smrg .read = (void *) mem_read,
1038627f7eb2Smrg .write = (void *) mem_write,
1039627f7eb2Smrg .seek = (void *) mem_seek,
1040627f7eb2Smrg .tell = (void *) mem_tell,
1041627f7eb2Smrg /* buf_size is not a typo, we just reuse an identical
1042627f7eb2Smrg implementation. */
1043627f7eb2Smrg .size = (void *) buf_size,
1044627f7eb2Smrg .trunc = (void *) mem_truncate,
1045627f7eb2Smrg .close = (void *) mem_close,
1046627f7eb2Smrg .flush = (void *) mem_flush,
1047627f7eb2Smrg .markeor = (void *) raw_markeor
1048627f7eb2Smrg };
1049627f7eb2Smrg
1050627f7eb2Smrg static const struct stream_vtable mem4_vtable = {
1051627f7eb2Smrg .read = (void *) mem_read4,
1052627f7eb2Smrg .write = (void *) mem_write4,
1053627f7eb2Smrg .seek = (void *) mem_seek,
1054627f7eb2Smrg .tell = (void *) mem_tell,
1055627f7eb2Smrg /* buf_size is not a typo, we just reuse an identical
1056627f7eb2Smrg implementation. */
1057627f7eb2Smrg .size = (void *) buf_size,
1058627f7eb2Smrg .trunc = (void *) mem_truncate,
1059627f7eb2Smrg .close = (void *) mem_close,
1060627f7eb2Smrg .flush = (void *) mem_flush,
1061627f7eb2Smrg .markeor = (void *) raw_markeor
1062627f7eb2Smrg };
1063627f7eb2Smrg
1064627f7eb2Smrg /*********************************************************************
1065627f7eb2Smrg Public functions -- A reimplementation of this module needs to
1066627f7eb2Smrg define functional equivalents of the following.
1067627f7eb2Smrg *********************************************************************/
1068627f7eb2Smrg
1069627f7eb2Smrg /* open_internal()-- Returns a stream structure from a character(kind=1)
1070627f7eb2Smrg internal file */
1071627f7eb2Smrg
1072627f7eb2Smrg stream *
open_internal(char * base,size_t length,gfc_offset offset)1073627f7eb2Smrg open_internal (char *base, size_t length, gfc_offset offset)
1074627f7eb2Smrg {
1075627f7eb2Smrg unix_stream *s;
1076627f7eb2Smrg
1077627f7eb2Smrg s = xcalloc (1, sizeof (unix_stream));
1078627f7eb2Smrg
1079627f7eb2Smrg s->buffer = base;
1080627f7eb2Smrg s->buffer_offset = offset;
1081627f7eb2Smrg
1082627f7eb2Smrg s->active = s->file_length = length;
1083627f7eb2Smrg
1084627f7eb2Smrg s->st.vptr = &mem_vtable;
1085627f7eb2Smrg
1086627f7eb2Smrg return (stream *) s;
1087627f7eb2Smrg }
1088627f7eb2Smrg
1089627f7eb2Smrg /* open_internal4()-- Returns a stream structure from a character(kind=4)
1090627f7eb2Smrg internal file */
1091627f7eb2Smrg
1092627f7eb2Smrg stream *
open_internal4(char * base,size_t length,gfc_offset offset)1093627f7eb2Smrg open_internal4 (char *base, size_t length, gfc_offset offset)
1094627f7eb2Smrg {
1095627f7eb2Smrg unix_stream *s;
1096627f7eb2Smrg
1097627f7eb2Smrg s = xcalloc (1, sizeof (unix_stream));
1098627f7eb2Smrg
1099627f7eb2Smrg s->buffer = base;
1100627f7eb2Smrg s->buffer_offset = offset;
1101627f7eb2Smrg
1102627f7eb2Smrg s->active = s->file_length = length * sizeof (gfc_char4_t);
1103627f7eb2Smrg
1104627f7eb2Smrg s->st.vptr = &mem4_vtable;
1105627f7eb2Smrg
1106627f7eb2Smrg return (stream *)s;
1107627f7eb2Smrg }
1108627f7eb2Smrg
1109627f7eb2Smrg
1110627f7eb2Smrg /* fd_to_stream()-- Given an open file descriptor, build a stream
1111627f7eb2Smrg around it. */
1112627f7eb2Smrg
1113627f7eb2Smrg static stream *
fd_to_stream(int fd,bool unformatted)1114627f7eb2Smrg fd_to_stream (int fd, bool unformatted)
1115627f7eb2Smrg {
1116627f7eb2Smrg struct stat statbuf;
1117627f7eb2Smrg unix_stream *s;
1118627f7eb2Smrg
1119627f7eb2Smrg s = xcalloc (1, sizeof (unix_stream));
1120627f7eb2Smrg
1121627f7eb2Smrg s->fd = fd;
1122627f7eb2Smrg
1123627f7eb2Smrg /* Get the current length of the file. */
1124627f7eb2Smrg
1125627f7eb2Smrg if (TEMP_FAILURE_RETRY (fstat (fd, &statbuf)) == -1)
1126627f7eb2Smrg {
1127627f7eb2Smrg s->st_dev = s->st_ino = -1;
1128627f7eb2Smrg s->file_length = 0;
1129627f7eb2Smrg if (errno == EBADF)
1130627f7eb2Smrg s->fd = -1;
1131627f7eb2Smrg raw_init (s);
1132627f7eb2Smrg return (stream *) s;
1133627f7eb2Smrg }
1134627f7eb2Smrg
1135627f7eb2Smrg s->st_dev = statbuf.st_dev;
1136627f7eb2Smrg s->st_ino = statbuf.st_ino;
1137627f7eb2Smrg s->file_length = statbuf.st_size;
1138627f7eb2Smrg
1139627f7eb2Smrg /* Only use buffered IO for regular files. */
1140627f7eb2Smrg if (S_ISREG (statbuf.st_mode)
1141627f7eb2Smrg && !options.all_unbuffered
1142627f7eb2Smrg && !(options.unbuffered_preconnected &&
1143627f7eb2Smrg (s->fd == STDIN_FILENO
1144627f7eb2Smrg || s->fd == STDOUT_FILENO
1145627f7eb2Smrg || s->fd == STDERR_FILENO)))
1146627f7eb2Smrg buf_init (s, unformatted);
1147627f7eb2Smrg else
1148627f7eb2Smrg {
1149627f7eb2Smrg if (unformatted)
1150627f7eb2Smrg {
1151627f7eb2Smrg s->unbuffered = true;
1152627f7eb2Smrg buf_init (s, unformatted);
1153627f7eb2Smrg }
1154627f7eb2Smrg else
1155627f7eb2Smrg raw_init (s);
1156627f7eb2Smrg }
1157627f7eb2Smrg
1158627f7eb2Smrg return (stream *) s;
1159627f7eb2Smrg }
1160627f7eb2Smrg
1161627f7eb2Smrg
1162627f7eb2Smrg /* Given the Fortran unit number, convert it to a C file descriptor. */
1163627f7eb2Smrg
1164627f7eb2Smrg int
unit_to_fd(int unit)1165627f7eb2Smrg unit_to_fd (int unit)
1166627f7eb2Smrg {
1167627f7eb2Smrg gfc_unit *us;
1168627f7eb2Smrg int fd;
1169627f7eb2Smrg
1170627f7eb2Smrg us = find_unit (unit);
1171627f7eb2Smrg if (us == NULL)
1172627f7eb2Smrg return -1;
1173627f7eb2Smrg
1174627f7eb2Smrg fd = ((unix_stream *) us->s)->fd;
1175627f7eb2Smrg unlock_unit (us);
1176627f7eb2Smrg return fd;
1177627f7eb2Smrg }
1178627f7eb2Smrg
1179627f7eb2Smrg
1180627f7eb2Smrg /* Set the close-on-exec flag for an existing fd, if the system
1181627f7eb2Smrg supports such. */
1182627f7eb2Smrg
1183627f7eb2Smrg static void __attribute__ ((unused))
set_close_on_exec(int fd)1184627f7eb2Smrg set_close_on_exec (int fd __attribute__ ((unused)))
1185627f7eb2Smrg {
1186627f7eb2Smrg /* Mingw does not define F_SETFD. */
1187627f7eb2Smrg #if defined(HAVE_FCNTL) && defined(F_SETFD) && defined(FD_CLOEXEC)
1188627f7eb2Smrg if (fd >= 0)
1189627f7eb2Smrg fcntl(fd, F_SETFD, FD_CLOEXEC);
1190627f7eb2Smrg #endif
1191627f7eb2Smrg }
1192627f7eb2Smrg
1193627f7eb2Smrg
1194627f7eb2Smrg /* Helper function for tempfile(). Tries to open a temporary file in
1195627f7eb2Smrg the directory specified by tempdir. If successful, the file name is
1196627f7eb2Smrg stored in fname and the descriptor returned. Returns -1 on
1197627f7eb2Smrg failure. */
1198627f7eb2Smrg
1199627f7eb2Smrg static int
tempfile_open(const char * tempdir,char ** fname)1200627f7eb2Smrg tempfile_open (const char *tempdir, char **fname)
1201627f7eb2Smrg {
1202627f7eb2Smrg int fd;
1203627f7eb2Smrg const char *slash = "/";
1204627f7eb2Smrg #if defined(HAVE_UMASK) && defined(HAVE_MKSTEMP)
1205627f7eb2Smrg mode_t mode_mask;
1206627f7eb2Smrg #endif
1207627f7eb2Smrg
1208627f7eb2Smrg if (!tempdir)
1209627f7eb2Smrg return -1;
1210627f7eb2Smrg
1211627f7eb2Smrg /* Check for the special case that tempdir ends with a slash or
1212627f7eb2Smrg backslash. */
1213627f7eb2Smrg size_t tempdirlen = strlen (tempdir);
1214627f7eb2Smrg if (*tempdir == 0 || tempdir[tempdirlen - 1] == '/'
1215627f7eb2Smrg #ifdef __MINGW32__
1216627f7eb2Smrg || tempdir[tempdirlen - 1] == '\\'
1217627f7eb2Smrg #endif
1218627f7eb2Smrg )
1219627f7eb2Smrg slash = "";
1220627f7eb2Smrg
1221627f7eb2Smrg /* Take care that the template is longer in the mktemp() branch. */
1222627f7eb2Smrg char *template = xmalloc (tempdirlen + 23);
1223627f7eb2Smrg
1224627f7eb2Smrg #ifdef HAVE_MKSTEMP
1225627f7eb2Smrg snprintf (template, tempdirlen + 23, "%s%sgfortrantmpXXXXXX",
1226627f7eb2Smrg tempdir, slash);
1227627f7eb2Smrg
1228627f7eb2Smrg #ifdef HAVE_UMASK
1229627f7eb2Smrg /* Temporarily set the umask such that the file has 0600 permissions. */
1230627f7eb2Smrg mode_mask = umask (S_IXUSR | S_IRWXG | S_IRWXO);
1231627f7eb2Smrg #endif
1232627f7eb2Smrg
1233627f7eb2Smrg #if defined(HAVE_MKOSTEMP) && defined(O_CLOEXEC)
1234627f7eb2Smrg TEMP_FAILURE_RETRY (fd = mkostemp (template, O_CLOEXEC));
1235627f7eb2Smrg #else
1236627f7eb2Smrg TEMP_FAILURE_RETRY (fd = mkstemp (template));
1237627f7eb2Smrg set_close_on_exec (fd);
1238627f7eb2Smrg #endif
1239627f7eb2Smrg
1240627f7eb2Smrg #ifdef HAVE_UMASK
1241627f7eb2Smrg (void) umask (mode_mask);
1242627f7eb2Smrg #endif
1243627f7eb2Smrg
1244627f7eb2Smrg #else /* HAVE_MKSTEMP */
1245627f7eb2Smrg fd = -1;
1246627f7eb2Smrg int count = 0;
1247627f7eb2Smrg size_t slashlen = strlen (slash);
1248627f7eb2Smrg int flags = O_RDWR | O_CREAT | O_EXCL;
1249627f7eb2Smrg #if defined(HAVE_CRLF) && defined(O_BINARY)
1250627f7eb2Smrg flags |= O_BINARY;
1251627f7eb2Smrg #endif
1252627f7eb2Smrg #ifdef O_CLOEXEC
1253627f7eb2Smrg flags |= O_CLOEXEC;
1254627f7eb2Smrg #endif
1255627f7eb2Smrg do
1256627f7eb2Smrg {
1257627f7eb2Smrg snprintf (template, tempdirlen + 23, "%s%sgfortrantmpaaaXXXXXX",
1258627f7eb2Smrg tempdir, slash);
1259627f7eb2Smrg if (count > 0)
1260627f7eb2Smrg {
1261627f7eb2Smrg int c = count;
1262627f7eb2Smrg template[tempdirlen + slashlen + 13] = 'a' + (c% 26);
1263627f7eb2Smrg c /= 26;
1264627f7eb2Smrg template[tempdirlen + slashlen + 12] = 'a' + (c % 26);
1265627f7eb2Smrg c /= 26;
1266627f7eb2Smrg template[tempdirlen + slashlen + 11] = 'a' + (c % 26);
1267627f7eb2Smrg if (c >= 26)
1268627f7eb2Smrg break;
1269627f7eb2Smrg }
1270627f7eb2Smrg
1271627f7eb2Smrg if (!mktemp (template))
1272627f7eb2Smrg {
1273627f7eb2Smrg errno = EEXIST;
1274627f7eb2Smrg count++;
1275627f7eb2Smrg continue;
1276627f7eb2Smrg }
1277627f7eb2Smrg
1278627f7eb2Smrg TEMP_FAILURE_RETRY (fd = open (template, flags, S_IRUSR | S_IWUSR));
1279627f7eb2Smrg }
1280627f7eb2Smrg while (fd == -1 && errno == EEXIST);
1281627f7eb2Smrg #ifndef O_CLOEXEC
1282627f7eb2Smrg set_close_on_exec (fd);
1283627f7eb2Smrg #endif
1284627f7eb2Smrg #endif /* HAVE_MKSTEMP */
1285627f7eb2Smrg
1286627f7eb2Smrg *fname = template;
1287627f7eb2Smrg return fd;
1288627f7eb2Smrg }
1289627f7eb2Smrg
1290627f7eb2Smrg
1291627f7eb2Smrg /* tempfile()-- Generate a temporary filename for a scratch file and
1292627f7eb2Smrg open it. mkstemp() opens the file for reading and writing, but the
1293627f7eb2Smrg library mode prevents anything that is not allowed. The descriptor
1294627f7eb2Smrg is returned, which is -1 on error. The template is pointed to by
1295627f7eb2Smrg opp->file, which is copied into the unit structure
1296627f7eb2Smrg and freed later. */
1297627f7eb2Smrg
1298627f7eb2Smrg static int
tempfile(st_parameter_open * opp)1299627f7eb2Smrg tempfile (st_parameter_open *opp)
1300627f7eb2Smrg {
1301627f7eb2Smrg const char *tempdir;
1302627f7eb2Smrg char *fname;
1303627f7eb2Smrg int fd = -1;
1304627f7eb2Smrg
1305627f7eb2Smrg tempdir = secure_getenv ("TMPDIR");
1306627f7eb2Smrg fd = tempfile_open (tempdir, &fname);
1307627f7eb2Smrg #ifdef __MINGW32__
1308627f7eb2Smrg if (fd == -1)
1309627f7eb2Smrg {
1310627f7eb2Smrg char buffer[MAX_PATH + 1];
1311627f7eb2Smrg DWORD ret;
1312627f7eb2Smrg ret = GetTempPath (MAX_PATH, buffer);
1313627f7eb2Smrg /* If we are not able to get a temp-directory, we use
1314627f7eb2Smrg current directory. */
1315627f7eb2Smrg if (ret > MAX_PATH || !ret)
1316627f7eb2Smrg buffer[0] = 0;
1317627f7eb2Smrg else
1318627f7eb2Smrg buffer[ret] = 0;
1319627f7eb2Smrg tempdir = strdup (buffer);
1320627f7eb2Smrg fd = tempfile_open (tempdir, &fname);
1321627f7eb2Smrg }
1322627f7eb2Smrg #elif defined(__CYGWIN__)
1323627f7eb2Smrg if (fd == -1)
1324627f7eb2Smrg {
1325627f7eb2Smrg tempdir = secure_getenv ("TMP");
1326627f7eb2Smrg fd = tempfile_open (tempdir, &fname);
1327627f7eb2Smrg }
1328627f7eb2Smrg if (fd == -1)
1329627f7eb2Smrg {
1330627f7eb2Smrg tempdir = secure_getenv ("TEMP");
1331627f7eb2Smrg fd = tempfile_open (tempdir, &fname);
1332627f7eb2Smrg }
1333627f7eb2Smrg #endif
1334627f7eb2Smrg if (fd == -1)
1335627f7eb2Smrg fd = tempfile_open (P_tmpdir, &fname);
1336627f7eb2Smrg
1337627f7eb2Smrg opp->file = fname;
1338627f7eb2Smrg opp->file_len = strlen (fname); /* Don't include trailing nul */
1339627f7eb2Smrg
1340627f7eb2Smrg return fd;
1341627f7eb2Smrg }
1342627f7eb2Smrg
1343627f7eb2Smrg
1344627f7eb2Smrg /* regular_file2()-- Open a regular file.
1345627f7eb2Smrg Change flags->action if it is ACTION_UNSPECIFIED on entry,
1346627f7eb2Smrg unless an error occurs.
1347627f7eb2Smrg Returns the descriptor, which is less than zero on error. */
1348627f7eb2Smrg
1349627f7eb2Smrg static int
regular_file2(const char * path,st_parameter_open * opp,unit_flags * flags)1350627f7eb2Smrg regular_file2 (const char *path, st_parameter_open *opp, unit_flags *flags)
1351627f7eb2Smrg {
1352627f7eb2Smrg int mode;
1353627f7eb2Smrg int rwflag;
1354627f7eb2Smrg int crflag, crflag2;
1355627f7eb2Smrg int fd;
1356627f7eb2Smrg
1357627f7eb2Smrg #ifdef __CYGWIN__
1358627f7eb2Smrg if (opp->file_len == 7)
1359627f7eb2Smrg {
1360627f7eb2Smrg if (strncmp (path, "CONOUT$", 7) == 0
1361627f7eb2Smrg || strncmp (path, "CONERR$", 7) == 0)
1362627f7eb2Smrg {
1363627f7eb2Smrg fd = open ("/dev/conout", O_WRONLY);
1364627f7eb2Smrg flags->action = ACTION_WRITE;
1365627f7eb2Smrg return fd;
1366627f7eb2Smrg }
1367627f7eb2Smrg }
1368627f7eb2Smrg
1369627f7eb2Smrg if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1370627f7eb2Smrg {
1371627f7eb2Smrg fd = open ("/dev/conin", O_RDONLY);
1372627f7eb2Smrg flags->action = ACTION_READ;
1373627f7eb2Smrg return fd;
1374627f7eb2Smrg }
1375627f7eb2Smrg #endif
1376627f7eb2Smrg
1377627f7eb2Smrg
1378627f7eb2Smrg #ifdef __MINGW32__
1379627f7eb2Smrg if (opp->file_len == 7)
1380627f7eb2Smrg {
1381627f7eb2Smrg if (strncmp (path, "CONOUT$", 7) == 0
1382627f7eb2Smrg || strncmp (path, "CONERR$", 7) == 0)
1383627f7eb2Smrg {
1384627f7eb2Smrg fd = open ("CONOUT$", O_WRONLY);
1385627f7eb2Smrg flags->action = ACTION_WRITE;
1386627f7eb2Smrg return fd;
1387627f7eb2Smrg }
1388627f7eb2Smrg }
1389627f7eb2Smrg
1390627f7eb2Smrg if (opp->file_len == 6 && strncmp (path, "CONIN$", 6) == 0)
1391627f7eb2Smrg {
1392627f7eb2Smrg fd = open ("CONIN$", O_RDONLY);
1393627f7eb2Smrg flags->action = ACTION_READ;
1394627f7eb2Smrg return fd;
1395627f7eb2Smrg }
1396627f7eb2Smrg #endif
1397627f7eb2Smrg
1398627f7eb2Smrg switch (flags->action)
1399627f7eb2Smrg {
1400627f7eb2Smrg case ACTION_READ:
1401627f7eb2Smrg rwflag = O_RDONLY;
1402627f7eb2Smrg break;
1403627f7eb2Smrg
1404627f7eb2Smrg case ACTION_WRITE:
1405627f7eb2Smrg rwflag = O_WRONLY;
1406627f7eb2Smrg break;
1407627f7eb2Smrg
1408627f7eb2Smrg case ACTION_READWRITE:
1409627f7eb2Smrg case ACTION_UNSPECIFIED:
1410627f7eb2Smrg rwflag = O_RDWR;
1411627f7eb2Smrg break;
1412627f7eb2Smrg
1413627f7eb2Smrg default:
1414627f7eb2Smrg internal_error (&opp->common, "regular_file(): Bad action");
1415627f7eb2Smrg }
1416627f7eb2Smrg
1417627f7eb2Smrg switch (flags->status)
1418627f7eb2Smrg {
1419627f7eb2Smrg case STATUS_NEW:
1420627f7eb2Smrg crflag = O_CREAT | O_EXCL;
1421627f7eb2Smrg break;
1422627f7eb2Smrg
1423627f7eb2Smrg case STATUS_OLD: /* open will fail if the file does not exist*/
1424627f7eb2Smrg crflag = 0;
1425627f7eb2Smrg break;
1426627f7eb2Smrg
1427627f7eb2Smrg case STATUS_UNKNOWN:
1428627f7eb2Smrg if (rwflag == O_RDONLY)
1429627f7eb2Smrg crflag = 0;
1430627f7eb2Smrg else
1431627f7eb2Smrg crflag = O_CREAT;
1432627f7eb2Smrg break;
1433627f7eb2Smrg
1434627f7eb2Smrg case STATUS_REPLACE:
1435627f7eb2Smrg crflag = O_CREAT | O_TRUNC;
1436627f7eb2Smrg break;
1437627f7eb2Smrg
1438627f7eb2Smrg default:
1439627f7eb2Smrg /* Note: STATUS_SCRATCH is handled by tempfile () and should
1440627f7eb2Smrg never be seen here. */
1441627f7eb2Smrg internal_error (&opp->common, "regular_file(): Bad status");
1442627f7eb2Smrg }
1443627f7eb2Smrg
1444627f7eb2Smrg /* rwflag |= O_LARGEFILE; */
1445627f7eb2Smrg
1446627f7eb2Smrg #if defined(HAVE_CRLF) && defined(O_BINARY)
1447627f7eb2Smrg crflag |= O_BINARY;
1448627f7eb2Smrg #endif
1449627f7eb2Smrg
1450627f7eb2Smrg #ifdef O_CLOEXEC
1451627f7eb2Smrg crflag |= O_CLOEXEC;
1452627f7eb2Smrg #endif
1453627f7eb2Smrg
1454627f7eb2Smrg mode = S_IRUSR | S_IWUSR | S_IRGRP | S_IWGRP | S_IROTH | S_IWOTH;
1455627f7eb2Smrg TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1456627f7eb2Smrg if (flags->action != ACTION_UNSPECIFIED)
1457627f7eb2Smrg return fd;
1458627f7eb2Smrg
1459627f7eb2Smrg if (fd >= 0)
1460627f7eb2Smrg {
1461627f7eb2Smrg flags->action = ACTION_READWRITE;
1462627f7eb2Smrg return fd;
1463627f7eb2Smrg }
1464627f7eb2Smrg if (errno != EACCES && errno != EPERM && errno != EROFS)
1465627f7eb2Smrg return fd;
1466627f7eb2Smrg
1467627f7eb2Smrg /* retry for read-only access */
1468627f7eb2Smrg rwflag = O_RDONLY;
1469627f7eb2Smrg if (flags->status == STATUS_UNKNOWN)
1470627f7eb2Smrg crflag2 = crflag & ~(O_CREAT);
1471627f7eb2Smrg else
1472627f7eb2Smrg crflag2 = crflag;
1473627f7eb2Smrg TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag2, mode));
1474627f7eb2Smrg if (fd >=0)
1475627f7eb2Smrg {
1476627f7eb2Smrg flags->action = ACTION_READ;
1477627f7eb2Smrg return fd; /* success */
1478627f7eb2Smrg }
1479627f7eb2Smrg
1480627f7eb2Smrg if (errno != EACCES && errno != EPERM && errno != ENOENT)
1481627f7eb2Smrg return fd; /* failure */
1482627f7eb2Smrg
1483627f7eb2Smrg /* retry for write-only access */
1484627f7eb2Smrg rwflag = O_WRONLY;
1485627f7eb2Smrg TEMP_FAILURE_RETRY (fd = open (path, rwflag | crflag, mode));
1486627f7eb2Smrg if (fd >=0)
1487627f7eb2Smrg {
1488627f7eb2Smrg flags->action = ACTION_WRITE;
1489627f7eb2Smrg return fd; /* success */
1490627f7eb2Smrg }
1491627f7eb2Smrg return fd; /* failure */
1492627f7eb2Smrg }
1493627f7eb2Smrg
1494627f7eb2Smrg
1495627f7eb2Smrg /* Lock the file, if necessary, based on SHARE flags. */
1496627f7eb2Smrg
1497627f7eb2Smrg #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1498627f7eb2Smrg static int
open_share(st_parameter_open * opp,int fd,unit_flags * flags)1499627f7eb2Smrg open_share (st_parameter_open *opp, int fd, unit_flags *flags)
1500627f7eb2Smrg {
1501627f7eb2Smrg int r = 0;
1502627f7eb2Smrg struct flock f;
1503627f7eb2Smrg if (fd == STDOUT_FILENO || fd == STDERR_FILENO || fd == STDIN_FILENO)
1504627f7eb2Smrg return 0;
1505627f7eb2Smrg
1506627f7eb2Smrg f.l_start = 0;
1507627f7eb2Smrg f.l_len = 0;
1508627f7eb2Smrg f.l_whence = SEEK_SET;
1509627f7eb2Smrg
1510627f7eb2Smrg switch (flags->share)
1511627f7eb2Smrg {
1512627f7eb2Smrg case SHARE_DENYNONE:
1513627f7eb2Smrg f.l_type = F_RDLCK;
1514627f7eb2Smrg r = fcntl (fd, F_SETLK, &f);
1515627f7eb2Smrg break;
1516627f7eb2Smrg case SHARE_DENYRW:
1517627f7eb2Smrg /* Must be writable to hold write lock. */
1518627f7eb2Smrg if (flags->action == ACTION_READ)
1519627f7eb2Smrg {
1520627f7eb2Smrg generate_error (&opp->common, LIBERROR_BAD_ACTION,
1521627f7eb2Smrg "Cannot set write lock on file opened for READ");
1522627f7eb2Smrg return -1;
1523627f7eb2Smrg }
1524627f7eb2Smrg f.l_type = F_WRLCK;
1525627f7eb2Smrg r = fcntl (fd, F_SETLK, &f);
1526627f7eb2Smrg break;
1527627f7eb2Smrg case SHARE_UNSPECIFIED:
1528627f7eb2Smrg default:
1529627f7eb2Smrg break;
1530627f7eb2Smrg }
1531627f7eb2Smrg
1532627f7eb2Smrg return r;
1533627f7eb2Smrg }
1534627f7eb2Smrg #else
1535627f7eb2Smrg static int
open_share(st_parameter_open * opp,int fd,unit_flags * flags)1536627f7eb2Smrg open_share (st_parameter_open *opp __attribute__ ((unused)),
1537627f7eb2Smrg int fd __attribute__ ((unused)),
1538627f7eb2Smrg unit_flags *flags __attribute__ ((unused)))
1539627f7eb2Smrg {
1540627f7eb2Smrg return 0;
1541627f7eb2Smrg }
1542627f7eb2Smrg #endif /* defined(HAVE_FCNTL) ... */
1543627f7eb2Smrg
1544627f7eb2Smrg
1545627f7eb2Smrg /* Wrapper around regular_file2, to make sure we free the path after
1546627f7eb2Smrg we're done. */
1547627f7eb2Smrg
1548627f7eb2Smrg static int
regular_file(st_parameter_open * opp,unit_flags * flags)1549627f7eb2Smrg regular_file (st_parameter_open *opp, unit_flags *flags)
1550627f7eb2Smrg {
1551627f7eb2Smrg char *path = fc_strdup (opp->file, opp->file_len);
1552627f7eb2Smrg int fd = regular_file2 (path, opp, flags);
1553627f7eb2Smrg free (path);
1554627f7eb2Smrg return fd;
1555627f7eb2Smrg }
1556627f7eb2Smrg
1557627f7eb2Smrg /* open_external()-- Open an external file, unix specific version.
1558627f7eb2Smrg Change flags->action if it is ACTION_UNSPECIFIED on entry.
1559627f7eb2Smrg Returns NULL on operating system error. */
1560627f7eb2Smrg
1561627f7eb2Smrg stream *
open_external(st_parameter_open * opp,unit_flags * flags)1562627f7eb2Smrg open_external (st_parameter_open *opp, unit_flags *flags)
1563627f7eb2Smrg {
1564627f7eb2Smrg int fd;
1565627f7eb2Smrg
1566627f7eb2Smrg if (flags->status == STATUS_SCRATCH)
1567627f7eb2Smrg {
1568627f7eb2Smrg fd = tempfile (opp);
1569627f7eb2Smrg if (flags->action == ACTION_UNSPECIFIED)
1570627f7eb2Smrg flags->action = flags->readonly ? ACTION_READ : ACTION_READWRITE;
1571627f7eb2Smrg
1572627f7eb2Smrg #if HAVE_UNLINK_OPEN_FILE
1573627f7eb2Smrg /* We can unlink scratch files now and it will go away when closed. */
1574627f7eb2Smrg if (fd >= 0)
1575627f7eb2Smrg unlink (opp->file);
1576627f7eb2Smrg #endif
1577627f7eb2Smrg }
1578627f7eb2Smrg else
1579627f7eb2Smrg {
1580627f7eb2Smrg /* regular_file resets flags->action if it is ACTION_UNSPECIFIED and
1581627f7eb2Smrg if it succeeds */
1582627f7eb2Smrg fd = regular_file (opp, flags);
1583627f7eb2Smrg #ifndef O_CLOEXEC
1584627f7eb2Smrg set_close_on_exec (fd);
1585627f7eb2Smrg #endif
1586627f7eb2Smrg }
1587627f7eb2Smrg
1588627f7eb2Smrg if (fd < 0)
1589627f7eb2Smrg return NULL;
1590627f7eb2Smrg fd = fix_fd (fd);
1591627f7eb2Smrg
1592627f7eb2Smrg if (open_share (opp, fd, flags) < 0)
1593627f7eb2Smrg return NULL;
1594627f7eb2Smrg
1595627f7eb2Smrg return fd_to_stream (fd, flags->form == FORM_UNFORMATTED);
1596627f7eb2Smrg }
1597627f7eb2Smrg
1598627f7eb2Smrg
1599627f7eb2Smrg /* input_stream()-- Return a stream pointer to the default input stream.
1600627f7eb2Smrg Called on initialization. */
1601627f7eb2Smrg
1602627f7eb2Smrg stream *
input_stream(void)1603627f7eb2Smrg input_stream (void)
1604627f7eb2Smrg {
1605627f7eb2Smrg return fd_to_stream (STDIN_FILENO, false);
1606627f7eb2Smrg }
1607627f7eb2Smrg
1608627f7eb2Smrg
1609627f7eb2Smrg /* output_stream()-- Return a stream pointer to the default output stream.
1610627f7eb2Smrg Called on initialization. */
1611627f7eb2Smrg
1612627f7eb2Smrg stream *
output_stream(void)1613627f7eb2Smrg output_stream (void)
1614627f7eb2Smrg {
1615627f7eb2Smrg stream *s;
1616627f7eb2Smrg
1617627f7eb2Smrg #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1618627f7eb2Smrg setmode (STDOUT_FILENO, O_BINARY);
1619627f7eb2Smrg #endif
1620627f7eb2Smrg
1621627f7eb2Smrg s = fd_to_stream (STDOUT_FILENO, false);
1622627f7eb2Smrg return s;
1623627f7eb2Smrg }
1624627f7eb2Smrg
1625627f7eb2Smrg
1626627f7eb2Smrg /* error_stream()-- Return a stream pointer to the default error stream.
1627627f7eb2Smrg Called on initialization. */
1628627f7eb2Smrg
1629627f7eb2Smrg stream *
error_stream(void)1630627f7eb2Smrg error_stream (void)
1631627f7eb2Smrg {
1632627f7eb2Smrg stream *s;
1633627f7eb2Smrg
1634627f7eb2Smrg #if defined(HAVE_CRLF) && defined(HAVE_SETMODE)
1635627f7eb2Smrg setmode (STDERR_FILENO, O_BINARY);
1636627f7eb2Smrg #endif
1637627f7eb2Smrg
1638627f7eb2Smrg s = fd_to_stream (STDERR_FILENO, false);
1639627f7eb2Smrg return s;
1640627f7eb2Smrg }
1641627f7eb2Smrg
1642627f7eb2Smrg
1643627f7eb2Smrg /* compare_file_filename()-- Given an open stream and a fortran string
1644627f7eb2Smrg that is a filename, figure out if the file is the same as the
1645627f7eb2Smrg filename. */
1646627f7eb2Smrg
1647627f7eb2Smrg int
compare_file_filename(gfc_unit * u,const char * name,gfc_charlen_type len)1648627f7eb2Smrg compare_file_filename (gfc_unit *u, const char *name, gfc_charlen_type len)
1649627f7eb2Smrg {
1650627f7eb2Smrg struct stat st;
1651627f7eb2Smrg int ret;
1652627f7eb2Smrg #ifdef HAVE_WORKING_STAT
1653627f7eb2Smrg unix_stream *s;
1654627f7eb2Smrg #else
1655627f7eb2Smrg # ifdef __MINGW32__
1656627f7eb2Smrg uint64_t id1, id2;
1657627f7eb2Smrg # endif
1658627f7eb2Smrg #endif
1659627f7eb2Smrg
1660627f7eb2Smrg char *path = fc_strdup (name, len);
1661627f7eb2Smrg
1662627f7eb2Smrg /* If the filename doesn't exist, then there is no match with the
1663627f7eb2Smrg existing file. */
1664627f7eb2Smrg
1665627f7eb2Smrg if (TEMP_FAILURE_RETRY (stat (path, &st)) < 0)
1666627f7eb2Smrg {
1667627f7eb2Smrg ret = 0;
1668627f7eb2Smrg goto done;
1669627f7eb2Smrg }
1670627f7eb2Smrg
1671627f7eb2Smrg #ifdef HAVE_WORKING_STAT
1672627f7eb2Smrg s = (unix_stream *) (u->s);
1673627f7eb2Smrg ret = (st.st_dev == s->st_dev) && (st.st_ino == s->st_ino);
1674627f7eb2Smrg goto done;
1675627f7eb2Smrg #else
1676627f7eb2Smrg
1677627f7eb2Smrg # ifdef __MINGW32__
1678627f7eb2Smrg /* We try to match files by a unique ID. On some filesystems (network
1679627f7eb2Smrg fs and FAT), we can't generate this unique ID, and will simply compare
1680627f7eb2Smrg filenames. */
1681627f7eb2Smrg id1 = id_from_path (path);
1682627f7eb2Smrg id2 = id_from_fd (((unix_stream *) (u->s))->fd);
1683627f7eb2Smrg if (id1 || id2)
1684627f7eb2Smrg {
1685627f7eb2Smrg ret = (id1 == id2);
1686627f7eb2Smrg goto done;
1687627f7eb2Smrg }
1688627f7eb2Smrg # endif
1689627f7eb2Smrg if (u->filename)
1690627f7eb2Smrg ret = (strcmp(path, u->filename) == 0);
1691627f7eb2Smrg else
1692627f7eb2Smrg ret = 0;
1693627f7eb2Smrg #endif
1694627f7eb2Smrg done:
1695627f7eb2Smrg free (path);
1696627f7eb2Smrg return ret;
1697627f7eb2Smrg }
1698627f7eb2Smrg
1699627f7eb2Smrg
1700627f7eb2Smrg #ifdef HAVE_WORKING_STAT
1701627f7eb2Smrg # define FIND_FILE0_DECL struct stat *st
1702627f7eb2Smrg # define FIND_FILE0_ARGS st
1703627f7eb2Smrg #else
1704627f7eb2Smrg # define FIND_FILE0_DECL uint64_t id, const char *path
1705627f7eb2Smrg # define FIND_FILE0_ARGS id, path
1706627f7eb2Smrg #endif
1707627f7eb2Smrg
1708627f7eb2Smrg /* find_file0()-- Recursive work function for find_file() */
1709627f7eb2Smrg
1710627f7eb2Smrg static gfc_unit *
find_file0(gfc_unit * u,FIND_FILE0_DECL)1711627f7eb2Smrg find_file0 (gfc_unit *u, FIND_FILE0_DECL)
1712627f7eb2Smrg {
1713627f7eb2Smrg gfc_unit *v;
1714627f7eb2Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1715627f7eb2Smrg uint64_t id1;
1716627f7eb2Smrg #endif
1717627f7eb2Smrg
1718627f7eb2Smrg if (u == NULL)
1719627f7eb2Smrg return NULL;
1720627f7eb2Smrg
1721627f7eb2Smrg #ifdef HAVE_WORKING_STAT
1722627f7eb2Smrg if (u->s != NULL)
1723627f7eb2Smrg {
1724627f7eb2Smrg unix_stream *s = (unix_stream *) (u->s);
1725627f7eb2Smrg if (st[0].st_dev == s->st_dev && st[0].st_ino == s->st_ino)
1726627f7eb2Smrg return u;
1727627f7eb2Smrg }
1728627f7eb2Smrg #else
1729627f7eb2Smrg # ifdef __MINGW32__
1730627f7eb2Smrg if (u->s && ((id1 = id_from_fd (((unix_stream *) u->s)->fd)) || id1))
1731627f7eb2Smrg {
1732627f7eb2Smrg if (id == id1)
1733627f7eb2Smrg return u;
1734627f7eb2Smrg }
1735627f7eb2Smrg else
1736627f7eb2Smrg # endif
1737627f7eb2Smrg if (u->filename && strcmp (u->filename, path) == 0)
1738627f7eb2Smrg return u;
1739627f7eb2Smrg #endif
1740627f7eb2Smrg
1741627f7eb2Smrg v = find_file0 (u->left, FIND_FILE0_ARGS);
1742627f7eb2Smrg if (v != NULL)
1743627f7eb2Smrg return v;
1744627f7eb2Smrg
1745627f7eb2Smrg v = find_file0 (u->right, FIND_FILE0_ARGS);
1746627f7eb2Smrg if (v != NULL)
1747627f7eb2Smrg return v;
1748627f7eb2Smrg
1749627f7eb2Smrg return NULL;
1750627f7eb2Smrg }
1751627f7eb2Smrg
1752627f7eb2Smrg
1753627f7eb2Smrg /* find_file()-- Take the current filename and see if there is a unit
1754627f7eb2Smrg that has the file already open. Returns a pointer to the unit if so. */
1755627f7eb2Smrg
1756627f7eb2Smrg gfc_unit *
find_file(const char * file,gfc_charlen_type file_len)1757627f7eb2Smrg find_file (const char *file, gfc_charlen_type file_len)
1758627f7eb2Smrg {
1759627f7eb2Smrg struct stat st[1];
1760627f7eb2Smrg gfc_unit *u;
1761627f7eb2Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1762627f7eb2Smrg uint64_t id = 0ULL;
1763627f7eb2Smrg #endif
1764627f7eb2Smrg
1765627f7eb2Smrg char *path = fc_strdup (file, file_len);
1766627f7eb2Smrg
1767627f7eb2Smrg if (TEMP_FAILURE_RETRY (stat (path, &st[0])) < 0)
1768627f7eb2Smrg {
1769627f7eb2Smrg u = NULL;
1770627f7eb2Smrg goto done;
1771627f7eb2Smrg }
1772627f7eb2Smrg
1773627f7eb2Smrg #if defined(__MINGW32__) && !HAVE_WORKING_STAT
1774627f7eb2Smrg id = id_from_path (path);
1775627f7eb2Smrg #endif
1776627f7eb2Smrg
1777627f7eb2Smrg LOCK (&unit_lock);
1778627f7eb2Smrg retry:
1779627f7eb2Smrg u = find_file0 (unit_root, FIND_FILE0_ARGS);
1780627f7eb2Smrg if (u != NULL)
1781627f7eb2Smrg {
1782627f7eb2Smrg /* Fast path. */
1783627f7eb2Smrg if (! __gthread_mutex_trylock (&u->lock))
1784627f7eb2Smrg {
1785627f7eb2Smrg /* assert (u->closed == 0); */
1786627f7eb2Smrg UNLOCK (&unit_lock);
1787627f7eb2Smrg goto done;
1788627f7eb2Smrg }
1789627f7eb2Smrg
1790627f7eb2Smrg inc_waiting_locked (u);
1791627f7eb2Smrg }
1792627f7eb2Smrg UNLOCK (&unit_lock);
1793627f7eb2Smrg if (u != NULL)
1794627f7eb2Smrg {
1795627f7eb2Smrg LOCK (&u->lock);
1796627f7eb2Smrg if (u->closed)
1797627f7eb2Smrg {
1798627f7eb2Smrg LOCK (&unit_lock);
1799627f7eb2Smrg UNLOCK (&u->lock);
1800627f7eb2Smrg if (predec_waiting_locked (u) == 0)
1801627f7eb2Smrg free (u);
1802627f7eb2Smrg goto retry;
1803627f7eb2Smrg }
1804627f7eb2Smrg
1805627f7eb2Smrg dec_waiting_unlocked (u);
1806627f7eb2Smrg }
1807627f7eb2Smrg done:
1808627f7eb2Smrg free (path);
1809627f7eb2Smrg return u;
1810627f7eb2Smrg }
1811627f7eb2Smrg
1812627f7eb2Smrg static gfc_unit *
flush_all_units_1(gfc_unit * u,int min_unit)1813627f7eb2Smrg flush_all_units_1 (gfc_unit *u, int min_unit)
1814627f7eb2Smrg {
1815627f7eb2Smrg while (u != NULL)
1816627f7eb2Smrg {
1817627f7eb2Smrg if (u->unit_number > min_unit)
1818627f7eb2Smrg {
1819627f7eb2Smrg gfc_unit *r = flush_all_units_1 (u->left, min_unit);
1820627f7eb2Smrg if (r != NULL)
1821627f7eb2Smrg return r;
1822627f7eb2Smrg }
1823627f7eb2Smrg if (u->unit_number >= min_unit)
1824627f7eb2Smrg {
1825627f7eb2Smrg if (__gthread_mutex_trylock (&u->lock))
1826627f7eb2Smrg return u;
1827627f7eb2Smrg if (u->s)
1828627f7eb2Smrg sflush (u->s);
1829627f7eb2Smrg UNLOCK (&u->lock);
1830627f7eb2Smrg }
1831627f7eb2Smrg u = u->right;
1832627f7eb2Smrg }
1833627f7eb2Smrg return NULL;
1834627f7eb2Smrg }
1835627f7eb2Smrg
1836627f7eb2Smrg void
flush_all_units(void)1837627f7eb2Smrg flush_all_units (void)
1838627f7eb2Smrg {
1839627f7eb2Smrg gfc_unit *u;
1840627f7eb2Smrg int min_unit = 0;
1841627f7eb2Smrg
1842627f7eb2Smrg LOCK (&unit_lock);
1843627f7eb2Smrg do
1844627f7eb2Smrg {
1845627f7eb2Smrg u = flush_all_units_1 (unit_root, min_unit);
1846627f7eb2Smrg if (u != NULL)
1847627f7eb2Smrg inc_waiting_locked (u);
1848627f7eb2Smrg UNLOCK (&unit_lock);
1849627f7eb2Smrg if (u == NULL)
1850627f7eb2Smrg return;
1851627f7eb2Smrg
1852627f7eb2Smrg LOCK (&u->lock);
1853627f7eb2Smrg
1854627f7eb2Smrg min_unit = u->unit_number + 1;
1855627f7eb2Smrg
1856627f7eb2Smrg if (u->closed == 0)
1857627f7eb2Smrg {
1858627f7eb2Smrg sflush (u->s);
1859627f7eb2Smrg LOCK (&unit_lock);
1860627f7eb2Smrg UNLOCK (&u->lock);
1861627f7eb2Smrg (void) predec_waiting_locked (u);
1862627f7eb2Smrg }
1863627f7eb2Smrg else
1864627f7eb2Smrg {
1865627f7eb2Smrg LOCK (&unit_lock);
1866627f7eb2Smrg UNLOCK (&u->lock);
1867627f7eb2Smrg if (predec_waiting_locked (u) == 0)
1868627f7eb2Smrg free (u);
1869627f7eb2Smrg }
1870627f7eb2Smrg }
1871627f7eb2Smrg while (1);
1872627f7eb2Smrg }
1873627f7eb2Smrg
1874627f7eb2Smrg
1875627f7eb2Smrg /* Unlock the unit if necessary, based on SHARE flags. */
1876627f7eb2Smrg
1877627f7eb2Smrg int
close_share(gfc_unit * u)1878627f7eb2Smrg close_share (gfc_unit *u __attribute__ ((unused)))
1879627f7eb2Smrg {
1880627f7eb2Smrg int r = 0;
1881627f7eb2Smrg #if defined(HAVE_FCNTL) && defined(F_SETLK) && defined(F_UNLCK)
1882627f7eb2Smrg unix_stream *s = (unix_stream *) u->s;
1883627f7eb2Smrg int fd = s->fd;
1884627f7eb2Smrg struct flock f;
1885627f7eb2Smrg
1886627f7eb2Smrg switch (u->flags.share)
1887627f7eb2Smrg {
1888627f7eb2Smrg case SHARE_DENYRW:
1889627f7eb2Smrg case SHARE_DENYNONE:
1890627f7eb2Smrg if (fd != STDOUT_FILENO && fd != STDERR_FILENO && fd != STDIN_FILENO)
1891627f7eb2Smrg {
1892627f7eb2Smrg f.l_start = 0;
1893627f7eb2Smrg f.l_len = 0;
1894627f7eb2Smrg f.l_whence = SEEK_SET;
1895627f7eb2Smrg f.l_type = F_UNLCK;
1896627f7eb2Smrg r = fcntl (fd, F_SETLK, &f);
1897627f7eb2Smrg }
1898627f7eb2Smrg break;
1899627f7eb2Smrg case SHARE_UNSPECIFIED:
1900627f7eb2Smrg default:
1901627f7eb2Smrg break;
1902627f7eb2Smrg }
1903627f7eb2Smrg
1904627f7eb2Smrg #endif
1905627f7eb2Smrg return r;
1906627f7eb2Smrg }
1907627f7eb2Smrg
1908627f7eb2Smrg
1909627f7eb2Smrg /* file_exists()-- Returns nonzero if the current filename exists on
1910627f7eb2Smrg the system */
1911627f7eb2Smrg
1912627f7eb2Smrg int
file_exists(const char * file,gfc_charlen_type file_len)1913627f7eb2Smrg file_exists (const char *file, gfc_charlen_type file_len)
1914627f7eb2Smrg {
1915627f7eb2Smrg char *path = fc_strdup (file, file_len);
1916627f7eb2Smrg int res = !(access (path, F_OK));
1917627f7eb2Smrg free (path);
1918627f7eb2Smrg return res;
1919627f7eb2Smrg }
1920627f7eb2Smrg
1921627f7eb2Smrg
1922627f7eb2Smrg /* file_size()-- Returns the size of the file. */
1923627f7eb2Smrg
1924627f7eb2Smrg GFC_IO_INT
file_size(const char * file,gfc_charlen_type file_len)1925627f7eb2Smrg file_size (const char *file, gfc_charlen_type file_len)
1926627f7eb2Smrg {
1927627f7eb2Smrg char *path = fc_strdup (file, file_len);
1928627f7eb2Smrg struct stat statbuf;
1929627f7eb2Smrg int err;
1930627f7eb2Smrg TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1931627f7eb2Smrg free (path);
1932627f7eb2Smrg if (err == -1)
1933627f7eb2Smrg return -1;
1934627f7eb2Smrg return (GFC_IO_INT) statbuf.st_size;
1935627f7eb2Smrg }
1936627f7eb2Smrg
1937627f7eb2Smrg static const char yes[] = "YES", no[] = "NO", unknown[] = "UNKNOWN";
1938627f7eb2Smrg
1939627f7eb2Smrg /* inquire_sequential()-- Given a fortran string, determine if the
1940627f7eb2Smrg file is suitable for sequential access. Returns a C-style
1941627f7eb2Smrg string. */
1942627f7eb2Smrg
1943627f7eb2Smrg const char *
inquire_sequential(const char * string,gfc_charlen_type len)1944627f7eb2Smrg inquire_sequential (const char *string, gfc_charlen_type len)
1945627f7eb2Smrg {
1946627f7eb2Smrg struct stat statbuf;
1947627f7eb2Smrg
1948627f7eb2Smrg if (string == NULL)
1949627f7eb2Smrg return unknown;
1950627f7eb2Smrg
1951627f7eb2Smrg char *path = fc_strdup (string, len);
1952627f7eb2Smrg int err;
1953627f7eb2Smrg TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1954627f7eb2Smrg free (path);
1955627f7eb2Smrg if (err == -1)
1956627f7eb2Smrg return unknown;
1957627f7eb2Smrg
1958627f7eb2Smrg if (S_ISREG (statbuf.st_mode) ||
1959627f7eb2Smrg S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1960627f7eb2Smrg return unknown;
1961627f7eb2Smrg
1962627f7eb2Smrg if (S_ISDIR (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1963627f7eb2Smrg return no;
1964627f7eb2Smrg
1965627f7eb2Smrg return unknown;
1966627f7eb2Smrg }
1967627f7eb2Smrg
1968627f7eb2Smrg
1969627f7eb2Smrg /* inquire_direct()-- Given a fortran string, determine if the file is
1970627f7eb2Smrg suitable for direct access. Returns a C-style string. */
1971627f7eb2Smrg
1972627f7eb2Smrg const char *
inquire_direct(const char * string,gfc_charlen_type len)1973627f7eb2Smrg inquire_direct (const char *string, gfc_charlen_type len)
1974627f7eb2Smrg {
1975627f7eb2Smrg struct stat statbuf;
1976627f7eb2Smrg
1977627f7eb2Smrg if (string == NULL)
1978627f7eb2Smrg return unknown;
1979627f7eb2Smrg
1980627f7eb2Smrg char *path = fc_strdup (string, len);
1981627f7eb2Smrg int err;
1982627f7eb2Smrg TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
1983627f7eb2Smrg free (path);
1984627f7eb2Smrg if (err == -1)
1985627f7eb2Smrg return unknown;
1986627f7eb2Smrg
1987627f7eb2Smrg if (S_ISREG (statbuf.st_mode) || S_ISBLK (statbuf.st_mode))
1988627f7eb2Smrg return unknown;
1989627f7eb2Smrg
1990627f7eb2Smrg if (S_ISDIR (statbuf.st_mode) ||
1991627f7eb2Smrg S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
1992627f7eb2Smrg return no;
1993627f7eb2Smrg
1994627f7eb2Smrg return unknown;
1995627f7eb2Smrg }
1996627f7eb2Smrg
1997627f7eb2Smrg
1998627f7eb2Smrg /* inquire_formatted()-- Given a fortran string, determine if the file
1999627f7eb2Smrg is suitable for formatted form. Returns a C-style string. */
2000627f7eb2Smrg
2001627f7eb2Smrg const char *
inquire_formatted(const char * string,gfc_charlen_type len)2002627f7eb2Smrg inquire_formatted (const char *string, gfc_charlen_type len)
2003627f7eb2Smrg {
2004627f7eb2Smrg struct stat statbuf;
2005627f7eb2Smrg
2006627f7eb2Smrg if (string == NULL)
2007627f7eb2Smrg return unknown;
2008627f7eb2Smrg
2009627f7eb2Smrg char *path = fc_strdup (string, len);
2010627f7eb2Smrg int err;
2011627f7eb2Smrg TEMP_FAILURE_RETRY (err = stat (path, &statbuf));
2012627f7eb2Smrg free (path);
2013627f7eb2Smrg if (err == -1)
2014627f7eb2Smrg return unknown;
2015627f7eb2Smrg
2016627f7eb2Smrg if (S_ISREG (statbuf.st_mode) ||
2017627f7eb2Smrg S_ISBLK (statbuf.st_mode) ||
2018627f7eb2Smrg S_ISCHR (statbuf.st_mode) || S_ISFIFO (statbuf.st_mode))
2019627f7eb2Smrg return unknown;
2020627f7eb2Smrg
2021627f7eb2Smrg if (S_ISDIR (statbuf.st_mode))
2022627f7eb2Smrg return no;
2023627f7eb2Smrg
2024627f7eb2Smrg return unknown;
2025627f7eb2Smrg }
2026627f7eb2Smrg
2027627f7eb2Smrg
2028627f7eb2Smrg /* inquire_unformatted()-- Given a fortran string, determine if the file
2029627f7eb2Smrg is suitable for unformatted form. Returns a C-style string. */
2030627f7eb2Smrg
2031627f7eb2Smrg const char *
inquire_unformatted(const char * string,gfc_charlen_type len)2032627f7eb2Smrg inquire_unformatted (const char *string, gfc_charlen_type len)
2033627f7eb2Smrg {
2034627f7eb2Smrg return inquire_formatted (string, len);
2035627f7eb2Smrg }
2036627f7eb2Smrg
2037627f7eb2Smrg
2038627f7eb2Smrg /* inquire_access()-- Given a fortran string, determine if the file is
2039627f7eb2Smrg suitable for access. */
2040627f7eb2Smrg
2041627f7eb2Smrg static const char *
inquire_access(const char * string,gfc_charlen_type len,int mode)2042627f7eb2Smrg inquire_access (const char *string, gfc_charlen_type len, int mode)
2043627f7eb2Smrg {
2044627f7eb2Smrg if (string == NULL)
2045627f7eb2Smrg return no;
2046627f7eb2Smrg char *path = fc_strdup (string, len);
2047627f7eb2Smrg int res = access (path, mode);
2048627f7eb2Smrg free (path);
2049627f7eb2Smrg if (res == -1)
2050627f7eb2Smrg return no;
2051627f7eb2Smrg
2052627f7eb2Smrg return yes;
2053627f7eb2Smrg }
2054627f7eb2Smrg
2055627f7eb2Smrg
2056627f7eb2Smrg /* inquire_read()-- Given a fortran string, determine if the file is
2057627f7eb2Smrg suitable for READ access. */
2058627f7eb2Smrg
2059627f7eb2Smrg const char *
inquire_read(const char * string,gfc_charlen_type len)2060627f7eb2Smrg inquire_read (const char *string, gfc_charlen_type len)
2061627f7eb2Smrg {
2062627f7eb2Smrg return inquire_access (string, len, R_OK);
2063627f7eb2Smrg }
2064627f7eb2Smrg
2065627f7eb2Smrg
2066627f7eb2Smrg /* inquire_write()-- Given a fortran string, determine if the file is
2067627f7eb2Smrg suitable for READ access. */
2068627f7eb2Smrg
2069627f7eb2Smrg const char *
inquire_write(const char * string,gfc_charlen_type len)2070627f7eb2Smrg inquire_write (const char *string, gfc_charlen_type len)
2071627f7eb2Smrg {
2072627f7eb2Smrg return inquire_access (string, len, W_OK);
2073627f7eb2Smrg }
2074627f7eb2Smrg
2075627f7eb2Smrg
2076627f7eb2Smrg /* inquire_readwrite()-- Given a fortran string, determine if the file is
2077627f7eb2Smrg suitable for read and write access. */
2078627f7eb2Smrg
2079627f7eb2Smrg const char *
inquire_readwrite(const char * string,gfc_charlen_type len)2080627f7eb2Smrg inquire_readwrite (const char *string, gfc_charlen_type len)
2081627f7eb2Smrg {
2082627f7eb2Smrg return inquire_access (string, len, R_OK | W_OK);
2083627f7eb2Smrg }
2084627f7eb2Smrg
2085627f7eb2Smrg
2086627f7eb2Smrg int
stream_isatty(stream * s)2087627f7eb2Smrg stream_isatty (stream *s)
2088627f7eb2Smrg {
2089627f7eb2Smrg return isatty (((unix_stream *) s)->fd);
2090627f7eb2Smrg }
2091627f7eb2Smrg
2092627f7eb2Smrg int
stream_ttyname(stream * s,char * buf,size_t buflen)2093627f7eb2Smrg stream_ttyname (stream *s __attribute__ ((unused)),
2094627f7eb2Smrg char *buf __attribute__ ((unused)),
2095627f7eb2Smrg size_t buflen __attribute__ ((unused)))
2096627f7eb2Smrg {
2097627f7eb2Smrg #ifdef HAVE_TTYNAME_R
2098627f7eb2Smrg return ttyname_r (((unix_stream *)s)->fd, buf, buflen);
2099627f7eb2Smrg #elif defined HAVE_TTYNAME
2100627f7eb2Smrg char *p;
2101627f7eb2Smrg size_t plen;
2102627f7eb2Smrg p = ttyname (((unix_stream *)s)->fd);
2103627f7eb2Smrg if (!p)
2104627f7eb2Smrg return errno;
2105627f7eb2Smrg plen = strlen (p);
2106627f7eb2Smrg if (buflen < plen)
2107627f7eb2Smrg plen = buflen;
2108627f7eb2Smrg memcpy (buf, p, plen);
2109627f7eb2Smrg return 0;
2110627f7eb2Smrg #else
2111627f7eb2Smrg return ENOSYS;
2112627f7eb2Smrg #endif
2113627f7eb2Smrg }
2114627f7eb2Smrg
2115627f7eb2Smrg
2116627f7eb2Smrg
2117627f7eb2Smrg
2118627f7eb2Smrg /* How files are stored: This is an operating-system specific issue,
2119627f7eb2Smrg and therefore belongs here. There are three cases to consider.
2120627f7eb2Smrg
2121627f7eb2Smrg Direct Access:
2122627f7eb2Smrg Records are written as block of bytes corresponding to the record
2123627f7eb2Smrg length of the file. This goes for both formatted and unformatted
2124627f7eb2Smrg records. Positioning is done explicitly for each data transfer,
2125627f7eb2Smrg so positioning is not much of an issue.
2126627f7eb2Smrg
2127627f7eb2Smrg Sequential Formatted:
2128627f7eb2Smrg Records are separated by newline characters. The newline character
2129627f7eb2Smrg is prohibited from appearing in a string. If it does, this will be
2130627f7eb2Smrg messed up on the next read. End of file is also the end of a record.
2131627f7eb2Smrg
2132627f7eb2Smrg Sequential Unformatted:
2133627f7eb2Smrg In this case, we are merely copying bytes to and from main storage,
2134627f7eb2Smrg yet we need to keep track of varying record lengths. We adopt
2135627f7eb2Smrg the solution used by f2c. Each record contains a pair of length
2136627f7eb2Smrg markers:
2137627f7eb2Smrg
2138627f7eb2Smrg Length of record n in bytes
2139627f7eb2Smrg Data of record n
2140627f7eb2Smrg Length of record n in bytes
2141627f7eb2Smrg
2142627f7eb2Smrg Length of record n+1 in bytes
2143627f7eb2Smrg Data of record n+1
2144627f7eb2Smrg Length of record n+1 in bytes
2145627f7eb2Smrg
2146627f7eb2Smrg The length is stored at the end of a record to allow backspacing to the
2147627f7eb2Smrg previous record. Between data transfer statements, the file pointer
2148627f7eb2Smrg is left pointing to the first length of the current record.
2149627f7eb2Smrg
2150627f7eb2Smrg ENDFILE records are never explicitly stored.
2151627f7eb2Smrg
2152627f7eb2Smrg */
2153